Index: ChangeLog ================================================================== --- ChangeLog +++ ChangeLog @@ -1,15 +1,3258 @@ +2005-10-08 Don Porter + + [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 + + [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 + + * 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 + + [kennykb-numerics-branch] + + * generic/tclExecute.c: Improved performance of INST_RSHIFT and + INST_LSHIFT. + +2005-10-05 Don Porter + + [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 + + * generic/tclPipe.c (TclCreatePipeline): Fixed [SF Tcl Bug + 1109294]. Applied the patch provided by David Gravereaux. + + * doc/CrtChannel.3: Fixed [SF Tcl Bug 1104682], by application of + David Welton's patch for it, and added a note about + wideSeekProc. + + * generic/tclIORChan.c (RcClose): Removed unreachable panic/return + statements. This fixes the remainder of [SF Tcl Bug 1286256]. + +2005-10-05 Jeff Hobbs + + * tests/env.test (env-6.1): + * win/tclWinPort.h: define USE_PUTENV_FOR_UNSET 1 + * generic/tclEnv.c (TclSetEnv, TclUnsetEnv): add + USE_PUTENV_FOR_UNSET to existing USE_PUTENV define to account for + various systems that have putenv(), but can't unset env vars with + it. Note difference between Windows and Linux for actually + unsetting the env var (use of '='). + 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 + + [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 + + * win/tclWinSerial.c (SerialSetOptionProc): free argv [Bug 1067708] + + * tests/http.test: do not URI encode -._~ according + * library/http/http.tcl (init): to RFC3986. [Bug 1182373] (aho) + + * unix/tclLoadShl.c (TclpDlopen): use DYNAMIC_PATH on second + shl_load only. [Bug 1204237] + + * doc/scan.n: scan %[] requires "one or more chars" [Bug 1277503] + + * tests/winFile.test (getuser): allow valid Windows usernames. + [Bug 1311285] + + * generic/tclParse.c (Tcl_ParseCommand): add code that recognizes + {} in addition to {expand} for word expansion (make with + -DALLOW_EMPTY_EXPAND). + +2005-10-04 Zoran Vasiljevic + + * generic/tclIO.c (Tcl_ClearChannelHandlers): now deletes any + outstanding timer for the channel. Also, prevents events still + in the event queue from triggering on the current channel. + + * generic/tclTimer.c (Tcl_DeleteTimerHandler): bail out early + if passed NULL argument. + +2005-10-03 Don Porter + + [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 + + * tools/loadICU.tcl: Changed the file names of message catalogs + to lowercase. + * tools/makeTestCases.tcl: + * library/tzdata/*: Olson's tzdata2005n.tar.gz. + Includes new DST rules for USA and a + number of changes to other locales. + * tests/clock.test: Regenerated for new US DST rules. + +2005-09-30 Don Porter + + * generic/tclMain.c: Separate encoding conversion of command line + arguments from list formatting. [Bug 1306162]. + +2005-09-30 Don Porter + + [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 + + * 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 + + [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 + + * tests/binary.test (binary-14.18): Added test for [Bug 1116542] + though the bug itself was already fixed by unrelated changes. + +2005-09-26 Kevin Kenny + + [kennykb-numerics-branch] Merge updates from HEAD. + +2005-09-26 Kevin Kenny + + * 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 + + [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 + + [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 + + [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 + + * doc/ParseCmd.3: copy/paste fix [Bug 1292427] + +2005-09-15 Don Porter + + [kennykb-numerics-branch] Merge updates from HEAD. + + * generic/tclStringObj.c (TclAppendFormattedObjs): Revision + to eliminate one round of string copying. + + * generic/tclBasic.c: More callers of TclObjPrintf and + * generic/tclCkalloc.c: TclFormatToErrorInfo. + * generic/tclCmdMZ.c: + * generic/tclExecute.c: + * generic/tclIORChan.c: + * generic/tclMain.c: + * generic/tclProc.c: + * generic/tclTimer.c: + * generic/tclUtil.c: + * unix/tclUnixFCmd.c + + * unix/configure: autoconf-2.59 + +2005-09-15 Donal K. Fellows + + * unix/tcl.m4 (SC_TCL_EARLY_FLAGS): Added extra hack to allow Tcl + to transparently open large files on RHEL 3. [Bug 1287638] + +2005-09-14 Don Porter + + * generic/tclStringObj.c: Bug fixes: ObjPrintfVA needed to + support "*" fields and needed to interpret precision limits on + %s conversions as a maximum number of bytes, not Tcl_UniChars, to + take from the (char *) argument. + + * generic/tclBasic.c: Updated several callers to use + * generic/tclCkalloc.c: TclFormatToErrorInfo() and/or + * generic/tclCmdAH.c: TclObjPrintf(). + * generic/tclCmdIL.c: + * generic/tclCmdMZ.c: + * generic/tclDictObj.c: + * generic/tclExecute.c: + * generic/tclIORChan.c: + * generic/tclIOUtil.c: + * generic/tclNamesp.c: + * generic/tclProc.c: + + * library/init.tcl: Keep [unknown] in sync with errorInfo + formatting rules. + +2005-09-13 Don Porter + + * generic/tclBasic.c: First caller of TclFormatToErrorInfo. + + * generic/tclInt.h: Using stdarg.h conventions, add more + * generic/tclStringObj.c: fixed arguments to TclFormatObj() and + TclObjPrintf(). Added new routine TclFormatToErrorInfo(). + + * generic/tcl.h: Explicitly standardized on the use of stdarg.h + * generic/tclBasic.c: conventions for functions with variable number + * generic/tclInt.h: of arguments. Support for varargs.h has been + * generic/tclPanic.c: implicitly gone for some time now. All + * generic/tclResult.c: TCL_VARARGS* macros purged from Tcl sources, + * generic/tclStringObj.c: leaving only some deprecated #define's + * tools/genStubs.tcl: in tcl.h for the sake of older extensions. + + * generic/tclDecls.h: make genstubs + + * doc/AddErrInfo.3: Replaced all documented requirement for use + * doc/Eval.3: of TCL_VARARGS_START() with requirement for + * doc/Panic.3: use of va_start(). + * doc/SetResult.3: + * doc/StringObj.3: + +2005-09-12 Don Porter + + [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. + +2005-09-09 Andreas Kupries + + * generic/tclIORChan.c (RcDecodeEventMask): Added missing type + declaration for the parameter 'mask'. This fixes the [SF Tcl Bug + 1286256]. The other warning can be removed only by removing the + panic/return code. + +2005-09-09 Don Porter + + [kennykb-numerics-branch] Merge updates from HEAD. + +2005-09-09 Kevin Kenny + + * generic/tclStringObj.c: Added two missing casts to silence + messages from MSVC6. + +2005-09-09 Don Porter + + * generic/tclInt.h: New internal routine TclObjPrintf() + * generic/tclStringObj.c: is similar to TclFormatObj() but + accepts arguments in non-Tcl_Obj format. + + * generic/tclInt.h: New internal routines TclFormatObj() + * generic/tclStringObj.c: and TclAppendFormattedObjs() to offer + sprintf()-like means to append to Tcl_Obj. Work in progress toward + [RFE 572392]. + + * generic/tclCmdAH.c: Compiler directive NEW_FORMAT when #define'd + directs the [format] command to be implemented in terms of the new + TclAppendFormattedObjs() routine. + +2005-09-08 Donal K. Fellows + + TIP#254 IMPLEMENTATION + + * generic/tclLink.c (LinkTraceProc,ObjValue): Added many new of C var + * generic/tcl.h: to link to, making it + * doc/LinkVar.3: easier to seamlessly + * generic/tclTest.c (TestlinkCmd): couple C code and Tcl + * tests/link.test: scripts in an + application. [Patch 1242844] + +2005-09-07 Don Porter + + * generic/tclUtf.c (Tcl_UniCharToUtf): Corrected handling of negative + * tests/utf.test (utf-1.5): Tcl_UniChar input value. Incorrect + handling was producing byte sequences outside of Tcl's legal internal + encoding. [Bug 1283976]. + +2005-09-06 Donal K. Fellows + + * generic/tclInt.h (List): Added flag to keep track of whether a list + * generic/tclListObj.c: with a string rep is provably canonical. + * generic/tclUtil.c (Tcl_ConcatObj): Do efficient concatenation and + * generic/tclBasic.c (Tcl_EvalObjEx): evaluation when the list is + canonical, and not just when the list is pure. This should make the + "pure list" hacking introduced in 8.3 much more robust. + +2005-09-05 Donal K. Fellows + + * generic/tclObj.c (pendingObjDataKey): Added missing 'static' to stop + symbol from leaking outside the Tcl library. [Bug 1263012] + +2005-09-02 Don Porter + + [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 + + * unix/tclUnixSock.c (InitializeHostName): Synchronized use of + static modifier in declaration and definition of function. + + * unix/tclUnixChan.c (FileTruncateProc): Synchronized use of + static modifier in declaration and definition of function. + + * generic/tclResult.c (ReleaseKeys): Synchronized use of static + modifier in declaration and definition of function. + + * generic/tclListObj.c (NewListIntRep): Synchronized use of static + modifier in declaration and definition of function. + + * generic/tclEncoding.c (InitializeEncodingSearchPath): + Synchronized use of static modifier in declaration and + definition of function. + + * generic/tclEncoding.c (FillEncodingFileMap): Synchronized use of + static modifier in declaration and definition of function. + + * generic/tclIORChan.c (RcNewHandle): Synchronized use of static + modifier in declaration and definition of function. + +2005-09-01 Don Porter + + [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 + + * doc/FileSystem.3: + * unix/tclUnixFile.c: + * windows/tclWinFile.c: clarify that Tcl_FSMatchInDirectory may + be called with a NULL interpreter, and fix the code so this is + allowed. Tcl's core itself (tclEncoding.c:FillEncodingFileMap()) + calls this with a NULL interpreter. + +2005-08-30 Don Porter + + [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 + + * 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 + + [kennykb-numerics-branch] Merge updates from HEAD. + + * generic/tclBasic.c: Restored round(.) to the Tcl 8.4 rules. + +2005-08-29 Kevin Kenny + + * generic/tclBasic.c (ExprMathFunc): Restored "round away from + * tests/expr.test (expr-46.*): zero" behaviour to the + "round" function. Added + test cases for the behavior, including the awkward case of a + number whose fractional part is 1/2-1/2ulp. [Bug 1275043] + +2005-08-26 Andreas Kupries + + * generic/tclIO.c: Moved Tcl_{Cut,Splice}Channel to + {Cut,Splice}Channel for internal use, and created new public + functions for Tcl_{Cut,Splice}Channel which walk the whole stack + of transformations and invoke the necessary thread actions. + Added code to Tcl_(Un)StackChannel to properly invoke the thread + actions when pushing and popping transformations on/from a + channel. + +2005-08-26 Donal K. Fellows + + * generic/tclNamesp.c (NamespaceEnsembleCmd): Reset the result after + creating an ensemble to clear any result object sharing (potentially + caused by delete traces) so that we can safely return the name of the + ensemble. Previously, this caused crashes in Snit's test suite. + +2005-08-25 Donal K. Fellows + + * generic/tclListObj.c (UpdateStringOfList): Stop uncontrolled and + unsafe crashes from happening when working with very large string + representations. [Bug 1267380] + + * generic/tclExecute.c (TEBC:INST_DICT_LAPPEND): Stop dropping a + 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 + + [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 + + TIP#219 IMPLEMENTATION + + * doc/SetChanErr.3: ** New File **. Documentation of the new + channel API functions. + * generic/tcl.decls: Stub declarations of the new channel API. + * generic/tclDecls.h: Regenerated + * generic/tclStubInit.c: + + * tclIORChan.c: ** New File **. Implementation of the reflected + channel. + * generic/tclInt.h: Integration of reflected channel and new error + * generic/tclIO.c: propagation into the generic I/O core. + * generic/tclIOCmd.c: + * generic/tclIO.h: + * library/init.tcl: + + * tests/io.test: Extended testsuite. + * tests/ioCmd.test: + * tests/chan.test: + * generic/tclTest.c: + * generic/tclThreadTest.c: + + * unix/Makefile.in: Integration into the build machinery. + * win/Makefile.in: + * win/Makefile.vc: + +2005-08-24 Kevin Kenny + + * generic/tclStrToD.c (Tcl_DoubleDigits): Fixed the corner cases of + * tests/binary.test (binary-65.*) formatting floating + point numbers with the largest and smallest possible significands, + and added test cases for them. + +2005-08-24 Kevin Kenny + + [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 + + [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 + + * unix/configure.in: + * win/configure: Regen. + * win/configure.in: Update minimum autoconf version + to 2.59. + +2005-08-23 Kevin Kenny + + [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 + + [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 + + * unix/tclConfig.h.in: autoheader-2.59. + +2005-08-22 Don Porter + + [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 + + [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 + + [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 + + [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 + + * generic/tclBasic.c: eliminate a namespace clash caused by + BuiltinFuncTable not being static. + + * generic/tclObj.c: fix a namespace clash caused by a missing + static for pendingObjData. + +2005-08-17 Kevin Kenny + + * generic/tclEvent.c (Tcl_Finalize): Removed a copy-and-paste + accident that caused a (mostly harmless) double finalize of the + load and filesystem subsystems. + * tests/clock.test: Eliminated the bad test clock-43.1, and split + 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-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 + + [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 + + [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 + + [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 + + [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 + + [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 + + [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 + + * generic/tclClock.c (MktimeObjCmd): + * library/clock.tcl (GetSystemTimeZone, LoadZoneinfoFile, + ReadZoneinfoFile): + * tests/clock.test (clock-50.1): + Added functionality to read /etc/localtime if it exists, so that + 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 + + [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 + + * generic/tclEvent.c: Eliminated the USE_THREAD_STORAGE + * generic/tclInt.h: option (which is on in every build + * generic/tclThread.c: generated by the standard configurator). + * generic/tclThreadStorage.c: Eliminated the code for thread + * unix/configure: specific data without USE_THREAD_STORAGE + * unix/tcl.m4: and radically refactored the code + * unix/tclConfig.h.in: for USE_THREAD_STORAGE so that it + * unix/tclUnixThrd.c: has fewer dependencies on the order + * win/configure: of finalization. (Also, made + * win/Makefile.in: 'make distclean' on Windows clean + * win/rules.vc: just a little bit cleaner.) + * win/tcl.m4: + * win/tclWinThrd.c: + +2005-08-10 Don Porter + + [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 + + * generic/tclEvent.c (Tcl_Finalize): Pushed Tcl_FinalizeLoad and + Tcl_ResetFilesystem down after Tcl_FinalizeThreadAlloc because + we can't unload DLL's until after their TSD keys are finalized. + (Note that we'll still see aborts if an unloaded DLL has TSD - + that still needs to be fixed. + + * tests/compExpr-old.test (compExpr-3.8): Made tests conditional on + * tests/expr.test (expr-3.8): 'unix' because they get + stack overflows on Win32 + threaded builds, + +2005-08-09 Vince Darley + + * generic/tclPathObj.c: fix to [file rootname] bug in optimized + code path reported on comp.lang.tcl. + +2005-08-08 Don Porter + + [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 + + * 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 + + [kennykb-numerics-branch] + * generic/tclObj.c: Rewrote Tcl_GetDoubleFromObj(). + +2005-08-05 Donal K. Fellows + + * unix/tclUnixInit.c (localeTable): Solaris uses a non-standard + name for the cp1251 charset. Thanks to Victor Wagner for reporting + this. [Bug 1252475] + +2005-08-05 Kevin Kenny + + * win/makefile.vc: Removed unused file ldAout.tcl. + * win/makefile.bc: [Bug #1244361] + + * tests/binary.test: Cleaned up testing for scanning of NaN. + [Bug #1246264] + + * generic/tclBasic.c (ExprAbsFunc): Added code to handle the + * tests/expr.test (expr-38.1): corner case of applying + 'abs' to the smallest 32-bit integer. [Bug #1241572] + +2005-08-04 Andreas Kupries + + * generic/tclIO.c (CloseChannel): Fixed comment nit, added + apparently missing word to complete a sentence. + + * generic/tclObj.c (Tcl_DbDecrRefCount): Fixed whitespace nit in + panic message. + +2005-08-04 Don Porter + + [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. + +2005-08-03 Don Porter + + * generic/tclCompExpr.c: Untangled some dependencies in the + * generic/tclEvent.c: order of finalization routines. + * generic/tclInt.h: [Bug 1251399] + * generic/tclObj.c: + +2005-08-02 Don Porter + + [kennykb-numerics-branch] Updated from HEAD + +2005-07-30 Daniel Steffen + + * unix/tclLoadDyld.c (TclpDlopen, TclpLoadMemory): workarounds + for bugs/changes in behaviour in Mac OS X 10.4 Tiger. + +2005-07-29 Donal K. Fellows + + * generic/tclCmdIL.c (InfoGlobalsCmd): Even in high-speed mode, + still have to take care with non-existant variables. [Bug 1247135] + +2005-07-28 Mo DeJong + + * win/README: Update link to msys_mingw8.zip. + +2005-07-28 Don Porter + + * tests/compExpr-old.test: Still more conversion of "nonPortable" + * tests/error.test: tests into tests with constraints that + * tests/expr-old.test: describe the limits of their + * tests/expr.test: portability. Also more consolidation + * tests/fileName.test: of constraint synonyms. + * tests/format.test: wideis64bit, 64bitInts => wideIs64bit + * tests/get.test: wideIntegerUnparsed => wideIs32bit + * tests/load.test: wideIntExpressions => wideBiggerThanInt + * tests/obj.test: + * tests/parseExpr.test: Dropped "roundOffBug" constraint that + * tests/string.test: protected from buggy sprintf. + +2005-07-28 Donal K. Fellows + + * generic/tclPipe.c (TclCreatePipeline): Arrange for POSIX systems to + * unix/tclUnixPipe.c (TclpOpenFile): use the O_APPEND flag for + * tests/exec.test (exec-19.1): files opened in a pipeline + like ">>this". Note that Windows cannot support such access; there is + no equivalent flag on the handle that can be set at the kernel-call + level. The test is unix-specific in every way. [Bug 1245953] + +2005-07-27 Don Porter + + * generic/tclUtil.c: Converted the $::tcl_precision value to be + kept per-thread to prevent different threads from stomping on each + others' formatting prescriptions. + + ***POTENTIAL INCOMPATIBILITY*** Multi-threaded programs that set + the value of ::tcl_precision will now have to set it in each thread. + + * tests/expr.test: Consolidated equivalent constraints into + * tests/fileName.test: single definitions and (more precise) names: + * tests/get.test: longis32bit, 32bit, !intsAre64bit => longIs32bit + * tests/listObj.test: empty => emptyTest; winOnly => win + * tests/obj.test: intsAre64bit => longIs64bit + Also updated some "nonPortable" tests to use constraints that mark + precisely what about them isn't portable, so the tests can run where + they work. + + * library/init.tcl ([unknown]): Corrected return code handling + in the portions of [unknown] that expand incomplete commands + during interactive operations. [Bug 1214462]. + +2005-07-26 Mo DeJong + + * unix/configure: Regen. + * unix/configure.in: Check for a $prefix/share + directory and add it the the package if found. + This will check for Tcl packages in /usr/local/share + when Tcl is configured with the default dist install. + [patch 1231015] + +2005-07-26 Don Porter + + * generic/tclBasic.c (Tcl_CallWhenDeleted): Converted to use + per-thread counter, rather than a process global one that required + mutex protection. [RFE 1077194] + + * generic/tclNamesp.c (TclTeardownNamespace): Re-ordering so that + * tests/trace.test (trace-34.4): command delete traces fire + while the command still exists. [Bug 1047286] + +2005-07-24 Mo DeJong + + * unix/configure: Regen. + * unix/tcl.m4 (SC_PROG_TCLSH, SC_BUILD_TCLSH): + * win/configure: Regen. + * win/tcl.m4 (SC_PROG_TCLSH, SC_BUILD_TCLSH): + Split confused search for tclsh on PATH and + build and install locations into two macros. + SC_PROG_TCLSH searches just the PATH. + SC_BUILD_TCLSH determines the name of the tclsh + executable in the Tcl build directory. + [Tcl bug 1160114] + [Tcl patch 1244153] + +2005-07-23 Don Porter + + * library/auto.tcl: Updates to the Tcl script library to make + * library/history.tcl: use of Tcl 8.4 features. Forward port of + * library/init.tcl: appropriate portions of [Patch 1237755]. + * library/package.tcl: + * library/safe.tcl: + * library/word.tcl: + +2005-07-23 Mo DeJong + + * tests/string.test: Add string is tests for + functionality that was not tested. + * win/README: Update msys + mingw URL. + Remove old Cygwin + mingw info. + +2005-07-23 Miguel Sofer + + * generic/tclExecute.c (INST_DICT_*): stop 2 compiler + warnings for uninitialised variables. + +2005-07-23 Donal K. Fellows + + * generic/tclExecute.c (TEBC:INST_DICT_INCR_IMM): Fix the + incrementor to work correctly with wide values. + +2005-07-21 Donal K. Fellows + + * generic/tclCompCmds.c (TclCompileDictCmd): First run at a compiler + * generic/tclExecute.c (TclExecuteByteCode): for dictionaries. + Also added an instruction to support 'finally'-like clauses, exposed + more of the dict guts to the rest of the core, and defined a few + tests to exercise more obscure parts of the compiler's operation that + were bugs during development. + +2005-07-21 Kevin B. Kenny + + * library/ldAout.tcl (***REMOVED***): Removed support for ancient + * unix/configure: BSD's, IRIX 4, RISCos and + * unix/Makefile.in: Ultrix. Removed two files + * unix/tcl.m4: whose code is used only on + * unix/tclLoadAout.c (***REMOVED***): those antique platforms. + + ***POTENTIAL INCOMPATIBILITY*** if anyone actually uses those + platforms; it is to be noted though, that an error in the + installer has actually not caused a necessary file to be installed + on those platforms in several releases, and nobody's complained. + +2005-07-16 Kevin B. Kenny + + * generic/tclStrToD.c (RefineResult): Plugged a stupid memory + leak in RefineResult (called from Tcl_StrToD). [Tk Bug 1227781] + +2005-07-15 Kevin B. Kenny + + * generic/tclClock.c (TclClockLocaltimeObjCmd,ThreadSafeLocalTime): + * library/clock.tcl (GuessWindowsTimeZone, ClearCaches): + * tests/clock.test (clock-49.1, clock-49.2): + Handle correctly the case where localtime() returns NULL to + report a conversion error. Also handle the case where the Windows + registry contains timezone values that can be mapped to a tzdata + file name but the corresponding file does not exist or is + corrupted, by falling back on a Posix timezone string instead; + this last case will avoid calls to localtime() in starpacks on + Windows. [Bug 1237907] + +2005-07-14 Donal K. Fellows + + * generic/tclCompile.c: Update to follow style guidelines. + (TclPrintInstruction): Reorganize to do better printing out of + bytecode with far fewer "special hacks" for particular opcodes. + * generic/tclCompile.h: Requires two new opcode types. + +2005-07-13 Don Porter + + * unix/tclUnixSock.c: Use a ProcessGlobalValue to store the + * win/tclWinSock.c: value returned by Tcl_GetHostName() + ([info hostname]). Also re-order initialization of the value + on Windows to favor GetComputerName() over gethostname() as + a source of the information. + +2005-07-12 Kevin Kenny + + [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 + + * doc/lsearch.n: Clarify documentation of -exact option; wording was + open to misinterpretation by non-English speakers. + +2005-07-11 Donal K. Fellows + + * generic/tclExecute.c: General style cleanup. + +2005-07-08 Mo DeJong + + * generic/tclExecute.c (TclExecuteByteCode): Reimplement long and wide + type integer division and modulus operations so that the smallest and + largest integer values are handled properly. The divide operation is + more efficient since it no longer does a modulus or negation and only + checks for a remainder when the quotient will be a negative number. + The modulus operation is now a bit more complex because of a number of + special cases dealing with the smallest and largest integers. + * tests/expr.test: Add test cases for division and modulus operations + on the smallest and largest integer values for 32 and 64 bit types. + [Patch 1230205] + +2005-07-06 Don Porter + + * generic/tclLink.c: Simplified LinkTraceProc [Bug 1208108]. + +2005-07-05 Don Porter + + * unix/Makefile.in: Purged use of TCLTESTARGS [RFE 1161550]. + + * generic/tclUtil.c: Converted TclFormatInt() into a macro. + * generic/tclInt.decls: [RFE 1194015] + * generic/tclInt.h: + + * generic/tclIntDecls.h: make genstubs + * generic/tclStubInit.c: + + * generic/tclNamesp.c: Allow for [namespace import] of a command + * tests/namespace.test: over a previous [namespace import] of itself + without throwing an error. [RFE 1230597] + +2005-07-04 Donal K. Fellows + + * generic/tclDictObj.c (DictForCmd, DictFilterCmd): Interlocking of + dictionary internal representations is now done in the core of the + dict iterator. Purge the last attempts at doing it at a higher level + as they didn't work and were no longer needed. + +2005-07-01 Zoran Vasiljevic + + * unix/tclUnixNotfy.c: protect against spurious wake-ups while + waiting on the condition variable when tearing down the notifier + thread [Bug# 1222872]. + +2005-06-28 Mo DeJong + + * generic/tclExecute.c (TclExecuteByteCode): When parsing an integer + operand for a unary minus expression operator, check for a wide + integer that is actually LONG_MIN. If found, convert it back to a long + int type. + * tests/expr.test: Add constraint for 32bit long int type and 64bit + wide int type. Add tests that parse the smallest/largest long int and + wide int values. + +2004-06-24 Kevin Kenny + + * generic/tclEvent.c (Tcl_Finalize): + * generic/tclInt.h: + * generic/tclPreserve.c (TclFinalizePreserve): Changed the + finalization logic so that Tcl_Preserve finalizes after exit handlers + run; a lot of code called from Tk's exit handlers presumes that + Tcl_Preserve will still work even from an exit handler. + +2005-06-24 Don Porter + + * library/auto.tcl: Make file safe to re-[source] without + destroying registered auto_mkindex_parser hooks. + +2005-06-23 Kevin Kenny + + * win/tclWinChan.c: More rewriting of __asm__ blocks that implement + * win/tclWinFCmd.c: SEH in GCC, because mingw's gcc 3.4.2 is not as + forgiving of violations committed by the old code and caused panics. + [Bug #1225957] + +2005-06-23 Daniel Steffen + + * tools/tcltk-man2html.tcl: fixed useversion glob pattern to accept + multi-digit patchlevels. + +2005-06-22 Don Porter + + * win/tclWinFile.c: Potential buffer overflow. [Bug 1225571] + Thanks to Pat Thoyts for discovery and fix. + +2005-06-22 Kevin Kenny + + * generic/tclInt.h: Changed the finalization + * generic/tclEvent.c (Tcl_Finalize): logic to defer the + * generic/tclIO.c (TclFinalizeIOSubsystem): shutdown of the pipe + * unix/tclUnixPipe.c (TclFinalizePipes): management until after + * win/tclWinPipe.c (TclFinalizePipes): all channels have been + closed, in order to avoid a situation where the Windows PipeCloseProc2 + would re-establish the exit handler after exit handlers had already + run, corrupting the heap. [Bug #1225727] + Also corrected a potential read of uninitialized memory in + PipeClose2Proc [Bug #1225044] + +2005-06-21 Andreas Kupries + + * generic/tclInt.h: Followup to change made on 2005-06-18 by Daniel + Steffen. There are compilers (*) who error out on the redefinition of + WORDS_BIGENDIAN. We have to undef the previous definition (on the + command line) first to make this acceptable. (*): AIX native. + +2005-06-21 Kevin B. Kenny + + * generic/tclFileName.c: Changed [file split] and [file join] to treat + Windows drive letters similarly to ~ syntax and make sure that they + appear with "./" in front when they are in intermediate components of + the path. [Bug 1194458] + * tests/fileName.test: Added test for the above bug. + +2005-06-21 Don Porter + + * generic/tclBasic.c: Added missing walk of the list of active traces + * generic/tclTrace.c: to cleanup references to traces being deleted. + * generic/tclInt.h: [Bug 1201035] Made the walk of the active trace + * tests/trace.test (trace-34.*): list aware of the direction of trace + scanning, so the proper correction can be made. [Bug 1224585] + +2005-06-21 Donal K. Fellows + + * unix/tcl.m4 (SC_ENABLE_SYMBOLS): Only enable the 'compile' special + debugging feature when requested in configure.in; removes irrelevant + junk from the configure files of extensions that use Tcl's tcl.m4. + +2005-06-20 Donal K. Fellows + + * generic/tclCompile.h (INST_PUSH_RETURN_OPTIONS): New opcode to allow + * generic/tclCompCmds.c (TclCompileCatchCmd): compilation of TIP90 + * generic/tclCompile.c: catch [Bug 1219112] + * generic/tclExecute.c (TclExecuteByteCode): + + * generic/tclCompCmds.c (TclCompileSwitchCmd): Ensure we spill to the + command form in all cases where it generates an error. + +2005-06-20 Mo DeJong + + * generic/tclCmdMZ.c (Tcl_SwitchObjCmd): Generate an error if a mode + argument like -exact is passed more than once to the switch command. + The previous implementation silently accepted invalid switch + invocations like [switch -exact -glob $str ...]. + * tests/for.test: Check some error cases when invoking continue and + break inside a for loop next script. + * tests/switch.test: Add checks for shortened version of a mode + argument like -exact. Add test for more than one mode argument. Add + test for odd case of passing a variable as a body script. + +2005-06-18 Daniel Steffen + + * generic/tclInt.h: ensure WORDS_BIGENDIAN is defined correctly with + fat compiles on Darwin (i.e. ppc and i386 at the same time), the + configure AC_C_BIGENDIAN check is not sufficient in this case because + a single run of the compiler builds for two architectures with + different endianness. + + * unix/tcl.m4 (Darwin): add -headerpad_max_install_names to LDFLAGS to + ensure we can always relocate binaries with install_name_tool. + + * unix/configure: autoconf-2.59 + +2005-06-18 Donal K. Fellows + + * generic/tclCmdAH.c (Tcl_FormatObjCmd): Fix for [Bug 1154163]; only + * tests/format.test: insert 'l' modifier when it is needed. + +2005-06-17 Donal K. Fellows + + * generic/tclTimer.c (AfterDelay): Split out the code to manage + synchronous-delay [after] commands. + * tests/interp.test (interp-34.10): Time limits and synch-delay + [after] did not mix well... [Bug 1221395] + +2005-06-14 Donal K. Fellows + + * generic/tclBasic.c (Tcl_DeleteCommandFromToken): Only delete a + * tests/namespace.test (namespace-49.2): command from the hashtable on + reentrant processing if it has not been already deleted; at least + three deletes of the same command are possible. [Bug 1220058] + * generic/tclTrace.c (TraceCommandProc): Remove bogus error message + creation when traces trigger in situations where the command has + already been deleted. + +2005-06-13 Vince Darley + + * generic/tclFCmd.c: correct fix to file mkdir 2005-06-09, [Bug 1219176] + +2005-06-12 Donal K. Fellows + + * generic/tclCompCmds.c: Factor out some common idioms into named + forms for greater clarity. + +2005-06-10 Donal K. Fellows + + * doc/chan.n: Fold in the descriptive parts of the documentation + for all the commands that [chan] builds on top of. + +2005-06-09 Vince Darley + + * generic/tclFCmd.c: fix to race condition in file mkdir [Bug 1217375] + * doc/glob.n: improve glob documentation [Bug 1190891] + +2005-06-09 Donal K. Fellows + + * doc/expr.n, doc/mathfunc.n: Fix minor typos [Bug 1211078] and + add mention of distinctly-relevant [namespace path] subcommand. + +2005-06-07 Don Porter + + * generic/tclInt.h: Reduced the Tcl_ObjTypes "index", + * generic/tclIndexObj.c: "ensembleCmd", "localVarName", and + * generic/tclNamesp.c: "levelReference" to file static scope. + * generic/tclProc.c: + * generic/tclVar.c: + + * generic/tclObj.c: Restored registration of the "procbody" + Tcl_ObjType, as required by the tclcompiler application. + + * generic/tclDecls.h: make genstubs + * generic/tclStubInit.c: + +2005-06-07 Donal K. Fellows + + * generic/tclIO.c (Tcl_ChannelTruncateProc): Stop proliferation of + * generic/tcl.h: channel type versions + * doc/CrtChannel.3: following advice from AKu + + Bump patchlevel to a4 to distinguish from a3 release. + + * generic/tclInt.h (INTERP_TRACE_IN_PROGRESS): Add flag so the error + * generic/tclIndexObj.c (Tcl_WrongNumArgs): messages from ensembles + * generic/tclIOCmd.c (Tcl_ReadObjCmd): can be correct. + + TIP#208 IMPLEMENTATION + + * library/init.tcl: Create the chan ensemble. + * tests/chan.test: Rudimentary test suite. + * doc/chan.n: General documentation. + + TRUNCATION API (part of TIP#208) + * generic/tcl.h, generic/tcl.decls: Declaration of the API. + * doc/CrtChannel.3, doc/OpenFileChnl.3: Documentation of the API. + * generic/tclBasic.c (Tcl_CreateInterp): Create the mapping into Tcl. + * generic/tclIOCmd.c (TclChanTruncateObjCmd): Implementation of + Tcl-level truncation API. + * generic/tclIO.c (Tcl_TruncateChannel): Generic C-level + truncation API implementation. + * unix/tclUnixChan.c (FileTruncateProc): Basic implementation of + truncating driver. + + * win/tclWinChan.c (FileTruncateProc): Added implementation of + file truncation for Windows. + * tests/chan.test (chan-15.2): Added real test of truncation. + +2005-06-06 Kevin B. Kenny + + * win/tclWin32Dll.c: Corrected another buglet in the assembly code for + stack probing on Win32/gcc. [Bug #1213678] + * generic/tclObj,c: Added missing 'static' on definition of + UpdateStringOfBignum, and removed a 'switch' on a 'long long' operand + (which HP-UX native 'cc' seems unable to handle). [Bug #1215775] + +2005-06-04 Jeff Hobbs + + *** 8.5a3 TAGGED FOR RELEASE *** + + * unix/Makefile.in (dist): add libtommath + +2005-06-03 Donal K. Fellows + + * library/parray.tcl (parray): Only generate the sorted list of + element names once. Thanks to Andreas Leitgeb for spotting this. + +2005-06-03 Daniel Steffen + + * macosx/Makefile: fixed 'embedded' target. + +2005-06-02 Jeff Hobbs + + * unix/Makefile.in (html): add BUILD_HTML_FLAGS optional var + * tools/tcltk-man2html.tcl: add a --useversion to prevent + confusion when multiple Tcl source dirs exist. + +2005-06-01 Don Porter + + * generic/tclBasic.c: For compatibility with earlier Tcl releases, + * generic/tclResult.c: when a command procedure simply does a + * generic/tclTest.c: "return TCL_RETURN;" we must interpret that + * tests/result.test: the same as + "return Tcl_SetReturnOptions(interp, Tcl_NewObj());" [Bug 1209759]. + +2005-06-01 Donal K. Fellows + + * generic/tclCompCmds.c (TclCompileSwitchCmd): Allow compilation + of -nocase -glob [switch]es (only one we know how to compile). + + TIP#241 IMPLEMENTATION from Joe Mistachkin + + * generic/tclCmdIL.c (Tcl_LsearchObjCmd, Tcl_LsortObjCmd): + * generic/tclCmdMZ.c (Tcl_SwitchObjCmd): Implementation of -nocase + option for [lsearch], [lsort] and [switch] commands. + * win/tclWinPort.h: Win uses nonstandard function names... + * tests/cmdIL.test, tests/lsearch.test, tests/switch.test: Tests + * doc/lsearch.n, doc/lsort.n, doc/switch.n: Docs + + * generic/tclCompCmds.c (TclCompileLindexCmd): Compile the most + common case of [lindex] more efficiently. + + * unix/tclUnixNotfy.c (Tcl_FinalizeNotifier): Pass the correct + number of arguments to Tcl_JoinThread. + +2005-05-31 Donal K. Fellows + + * unix/configure.in, unix/tcl.m4: Standardize generation of help + messages to always use AC_HELP_STRING and always (except for + --with-tcl and --with-tk, where the default is complex) say what + the default is. + +2005-05-31 Zoran Vasiljevic + + * unix/tclUnixNotfy.c: the notifier thread is now created as + joinable thread and it is properly joined in Tcl_FinalizeNotifier. + This is an attempt to fix the Tcl Bug #1082283. + +2005-05-30 Zoran Vasiljevic + + * win/tclWinThrd.c: Fixed Tcl Bug #1204064. + +2005-05-30 Donal K. Fellows + + TIP #229 IMPLEMENTATION + + * generic/tclNamesp.c (Tcl_FindCommand, TclResetShadowedCmdRefs) + (NamespacePathCmd, SetNsPath, UnlinkNsPath, TclInvalidateNsPath): + Implementation of the [namespace path] command and the command + name resolution engine. + * doc/info.n, doc/namespace.n: Doc updates. + * tests/namespace.test (namespace-51.*): Test updates. + * generic/tclResolve.c (BumpCmdRefEpochs, Tcl_SetNamespaceResolvers): + * generic/tclBasic.c (Tcl_CreateCommand, Tcl_CreateObjCommand): + Ensure that people don't see stale paths. + * generic/tclInt.h (Namespace, NamespacePathEntry): Structure defs. + * generic/tclCmdIL.c (InfoCommandsCmd): Updates to [info commands]. + +2005-05-26 Daniel Steffen + + * macosx/Makefile: moved & corrected EMBEDDED_BUILD check. + + * unix/configure.in: corrected framework finalization to softlink + stub library to Versions/8.x subdir instead of Versions/Current. + * unix/configure: autoconf-2.59 + +2005-05-25 Jeff Hobbs + + * generic/tclCmdMZ.c (Tcl_TimeObjCmd): add necessary cast + +2005-05-25 Don Porter + + TIP#182 IMPLEMENTATION [Patch 1165062] + + * doc/mathfunc.n: New built-in math function bool(). + * generic/tclBasic.c: + * tests/expr.test: + * tests/info.test: + +2005-05-24 Don Porter + + * library/init.tcl: Updated [unknown] to be sure the [return] + * tests/init.test: options from an auto-loaded command are + seen correctly by the caller. + +2005-05-24 Daniel Steffen + + * tests/env.test: added DYLD_FRAMEWORK_PATH to the list of env vars + that need to be handled specially. + + * macosx/Makefile: + * macosx/README: + * macosx/Tcl-Info.plist.in (new file): + * unix/Makefile.in: + * unix/configure.in: + * unix/tcl.m4: + * unix/tclUnixInit.c: moved all Darwin framework build support from + macosx/Makefile into the standard unix configure/make buildsystem, the + macosx/Makefile is no longer required to build Tcl.framework (but its + functionality is still available for backwards compatibility). + * unix/configure: autoconf-2.59 + + * generic/tclIOUtil.c (TclLoadFile): + * generic/tclInt.h: + * unix/tcl.m4: + * unix/tclLoadDyld.c: added support for [load]ing .bundle binaries in + addition to .dylib's: .bundle's can be [unload]ed (unlike .dylib's), + and can be [load]ed from memory, e.g. directly from VFS without + needing to be written out to a temporary location first. [Bug 1202209] + * unix/configure: autoconf-2.59 + * unix/tclConfig.h.in: autoheader-2.59 + + * generic/tclCmdMZ.c (Tcl_TimeObjCmd): change [time] called with a + count > 1 to return a string with a float value instead of a rounded + off integer. [Bug 1202178] + + * doc/expr.n: + * doc/string.n: fixed roff syntax complaints from 'make html'. + +2005-05-20 Don Porter + + * generic/tclParseExpr.c: Corrected parser to recognize all + boolean literals accepted by Tcl_GetBoolean, including prefixes + like "y" and "f", and to allow "eq" and "ne" as function names + in the proper context. [Bug 1201589]. + +2005-05-19 Donal K. Fellows + + * generic/tclBasic.c (TclEvalObjvInternal): Rewrite for greater + clarity; although 'goto' is Bad, the contortions you have to go + through to avoid it can be worse... + +2005-05-19 Daniel Steffen + + * macosx/tclMacOSXNotify.c (Tcl_InitNotifier): fixed crashing + CFRelease of runLoopSource in Tcl_InitNotifier (reported by Zoran): + CFRunLoopAddSource doesn't CFRetain, so can only CFRelease the + runLoopSource in Tcl_FinalizeNotifier. + +2005-05-18 Don Porter + + * generic/tclBasic.c (Tcl_ExprBoolean): Rewrite as wrapper around + Tcl_ExprBooleanObj. + + * generic/tclCmdMZ.c ([string is boolean/true/false]): Rewrite + dropping string-based Tcl_GetBoolean call, so that internal reps + are kept for subsequent quick boolean operations. + + * generic/tclExecute.c: Dropped most special handling of the + "boolean" Tcl_ObjType, since that type should now be rarely + encountered. + + * doc/BoolObj.3: Rewrite of documentation dropping many details + about the internals of Tcl_Objs. Shorter documentation focuses on + the function and use of the routines. + + * generic/tclInt.h: Revision to the "boolean" Tcl_ObjType, so + * generic/tclObj.c: that only string values like "yes" and "false" + * tests/obj.test: are kept as the "boolean" Tcl_ObjType. The + string values "0" and "1" are kept as "int" Tcl_ObjType, which also + produce quick calls to Tcl_GetBooleanFromObj(). Since this internal + change means a Tcl_ConvertToType to a "boolean" Tcl_ObjType might + not produce a Tcl_Obj of type "boolean", the registration of the + "boolean" type is also removed. + ***POTENTIAL INCOMPATIBILITY*** + For callers of Tcl_GetObjType on the type name "boolean". + +2005-05-17 Don Porter + + * generic/tclObj.c (TclInitObjSubsystem): Removed the + * tests/listObj.test: registration of the Tcl_ObjType's "list", + * tests/obj.test: "procbody", "index", "ensembleCommand", + "localVarName", and "levelReference". The only reason to register + a Tcl_ObjType is to have it returned by Tcl_GetObjType, and the + only reason for that is to retrieve a (Tcl_ObjType *) to pass to + Tcl_ConvertToType(). None of the types above can support a + Tcl_ConvertToType() call; they panic. Better not to offer something + than to lead users into a panic. + ***POTENTIAL INCOMPATIBILITY*** + For callers of Tcl_GetObjType on the type names listed above. + +2005-05-15 Kevin Kenny + + * win/tclWin32Dll.c: conditioned definition of + EXCEPTION_REGISTRATION structures on HAVE_NO_SEH, to fix a bug in + buildability on MSVC. + +2005-05-14 Daniel Steffen + + * generic/tclInt.decls: + * generic/tclTest.c: + * generic/tclUtil.c: + * win/tclWin32Dll.c: fixed link error due to direct access by + tclTest.c to the MODULE_SCOPE tclPlatform global: renamed existing + TclWinGetPlatform() accessor to TclGetPlatform() and moved it to + generic code so that it can be used by on all platforms where + MODULE_SCOPE is enforced. + + * macosx/tclMacOSXBundle.c: + * unix/tclUnixInit.c: + * unix/tcl.m4 (Darwin): made use of CoreFoundation API configurable + and added test of CoreFoundation availablility to allow building on + ppc64, replaced HAVE_CFBUNDLE by HAVE_COREFOUNDATION; test for + availability of Tiger or later OSSpinLockLock API. + + * unix/tclUnixNotfy.c: + * unix/Makefile.in: + * macosx/tclMacOSXNotify.c (new file): when CoreFoundation is + available, use new CFRunLoop based notifier: allows easy integration + with other event loops on Mac OS X, in particular the TkAqua Carbon + event loop is now integrated via a standard tcl event source (instead + of TkAqua upon loading having to finalize the exsting notifier and + replace it with its custom version). [Patch 1202052] + + * tests/unixNotfy.test: don't run unthreaded tests on Darwin + since notifier may be using threads even in unthreaded core. + + * unix/tclUnixPort.h: + * unix/tcl.m4 (Darwin): test for thread-unsafe realpath durning + configure, as Darwin 7 and later realpath is threadsafe. + + * macosx/Makefile: enable configure caching. + + * unix/configure.in: wrap tclConfig.h header in #ifndef _TCLCONFIG so + that it can be included more than once without warnings from gcc4.0 + (as happens e.g. when including both tclInt.h and tclPort.h) + + * macosx/tclMacOSXBundle.c: + * unix/tclUnixChan.c: + * unix/tclLoadDyld.c: + * unix/tclUnixInit.c: fixed gcc 4.0 warnings. + + * unix/configure: autoconf-2.59 + * unix/tclConfig.h.in: autoheader-2.59 + + * generic/tclIntDecls.h: + * generic/tclIntPlatDecls.h: + * generic/tclStubInit.c: make genstubs + +2005-05-13 Kevin Kenny + + * win/tclWin32Dll.c: Further rework of the SEH logic. All + EXCEPTION_REGISTRATION records are now + in the activation record rather than pushed + on the stack. + +2005-05-13 Don Porter + + * generic/tclBasic.c: Dropped the TCL_NO_MATH configuration. + * generic/tclBinary.c: It's believed this has not been working + * generic/tclExecute.c: in a long time. Tcl needs math.h. + * unix/Makefile.in: [RFE 1200680]. + +2005-05-12 Kevin Kenny + + * doc/mathfunc.n: Changed NAME line to match the name of the page. + +2005-05-11 Kevin Kenny + + [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 + + * generic/tclStrToD.c (TclStrToD, RefineResult, ParseNaN): + Changed the code to cast 'char' to UCHAR explicitly when + using ctype macros, to silence complaints from the Solaris + compiler. + +2005-05-10 Jeff Hobbs + + * unix/tclUnixFCmd.c: add lint attr to enum to satisfy strictly + compliant compilers that don't like trailing ,s. + + * tests/string.test: string-10.[21-30] + * generic/tclCmdMZ.c (Tcl_StringObjCmd): add extra checks to + prevent possible UMR in unichar cmp function for string map. + +2005-05-10 Kevin Kenny + + * generic/tclBinary.c (FormatNumber): Fixed a bug where NaN's + resulted in reads of uninitialized memory when using 'd', + 'q', or 'Q' format. + * generic/tclStrToD.c (ParseNaN, TclFormatNaN): Added code to + handle the peculiarities of HP's PA_RISC, which uses a different + 'quiet' bit in NaN from everyone else. + * libtommath/tommath_superclass.h: Corrected C++-style comment. + +2005-05-10 Kevin Kenny + + Merged all changes on kennykb-numerics-branch back into the + HEAD. TIP's 132 and 232 are now Final. + +2005-05-10 Kevin Kenny + + [kennykb-numerics-branch] Merged changes from HEAD. + +2005-05-10 Miguel Sofer + + * generic/tclExecute.c (ExponLong, ExponWide): + * tests/expr.test (expr-23.34/35): fixed special case 'i**0' for + i>0 [Bug 1198892] + +2005-05-09 Kevin B. Kenny + + [kennykb-numerics-branch] + * win/tclWin32Dll.c (TclpCheckStackSpace, TclWinCPUID): + Reworked structured event handling to function even + with -fomit-frame-pointers. + +2005-05-08 Kevin B. Kenny + + [kennykb-numerics-branch] + * generic/tclStrToD.c: Made code more portable by finding a + workaround for MSVC's 'volatile' issue that + does not require conditional compilation. + * win/tclWin32Dll.c (TclWinCPUID): Removed structured event + handling from the GCC code + since (a) bad code is generated + by the instruction scheduling + with -O2, and (b) it's not + needed on any reasonably modern + CPU. + +2005-05-07 Kevin B. Kenny + + [kennykb-numerics-branch] + * generic/tclEvent.c: Moved initialization of tclStrToD.c's + * generic/tclInt.h: static constants into a procedure called + * generic/tclStrToD.c: from TclInitSubsystems to avoid double + checked locking protocol. Cleaned up + an issue where MSVC ignored the 'volatile' + specifier, causing incorrect comparison + of an underflowed number against zero. + +2005-05-06 Jeff Hobbs + + * unix/tcl.m4, unix/configure: correct Solaris 10 (5.10) check and + add support for x86_64 Solaris cc builds. + +2005-05-05 Kevin B. Kenny + + [kennykb-numerics-branch] Merged with HEAD. + +2005-05-05 Kevin B. Kenny + + * win/tclWinThrd.c: Corrected a compilation error on the + --enable-threads configuration. + +2005-05-05 Don Porter + + * generic/tclInt.decls: Converted TclMatchIsTrivial to a macro. + * generic/tclInt.h: + * generic/tclUtil.c: + * generic/tclIntDecls.h: `make genstubs` + * generic/tclStubInit.c: + * generic/tclBasic.c: Added callers of TclMatchIsTrivial where + * generic/tclCmdIL.c: a search can be done more efficiently + * generic/tclCompCmds.c:when it is recognized that a pattern match + * generic/tclDictObj.c: is really an exact match. [Patch 1076088] + * generic/tclIO.c: + * generic/tclNamesp.c: + * generic/tclVar.c: + + * generic/tclCompCmds.c: Factored common efficiency trick into + a macro named CompileWord. + + * generic/tclCompCmds.c: Replaced all instance of + * generic/tclCompile.c: TCL_OUT_LINE_COMPILE with TCL_ERROR. + * generic/tclInt.h: Now that we've eradicated the mistaken + * tests/appendComp.test: notion of a "compile-time error", we + can use the TCL_ERROR return code to signal any failure to produce + bytecode. + +2005-05-03 Don Porter + + * doc/DString.3: Eliminated use of identifier "string" in Tcl's + * doc/Environment.3: public C API to avoid conflict/confusion with + * doc/Eval.3: the std::string of C++. + * doc/ExprLong.3, doc/ExprLongObj.3, doc/GetInt.3, doc/GetOpnFl.3: + * doc/ParseCmd.3, doc/RegExp.3, doc/SetResult.3, doc/StrMatch.3: + * doc/Utf.3, generic/tcl.decls, generic/tclBasic.c, generic/tclEnv.c: + * generic/tclGet.c, generic/tclParse.c, generic/tclParseExpr.c: + * generic/tclRegexp.c, generic/tclResult.c, generic/tclUtf.c: + * generic/tclUtil.c, unix/tclUnixChan.c: + + * generic/tclDecls.h: `make genstubs` + +2005-05-02 Don Porter + + * generic/tcl.decls: + * generic/tclBasic.c: Simplified implementation of Tcl_ExprString. + * tests/expr-old.test: + + * generic/tclDecls.h: `make genstubs` + +2005-04-30 Daniel Steffen + + * unix/tclUnixNotfy.c: applied dkf's tkMacOSXNotify.c cleanup changes. + +2005-04-29 Don Porter + + TIP#176 IMPLEMENTATION [Patch 1165695] + + * generic/tclUtil.c: Extended TclGetIntForIndex to recognize + index formats including end+integer and integer+/-integer. + + * generic/tclCmdMZ.c: Extended the -start switch of [regexp] + and [regsub] to accept all index formats known by TclGetIntForIndex. + + * doc/lindex.n: Updated docs to note new index formats. + * doc/linsert.n, doc/lrange.n, doc/lreplace.n, doc/lsearch.n: + * doc/lset.n, doc/lsort.n, doc/regexp.n, doc/regsub.n, doc/string.n: + + * tests/cmdIL.test: Updated tests. + * tests/compile.test, tests/lindex.test, tests/linsert.test: + * tests/lrange.test, tests/lreplace.test, tests/lsearch.test: + * tests/lset.test, tests/regexp.test, tests/regexpComp.test: + * tests/string.test, tests/stringComp.test, tests/util.test: + +2005-04-28 Don Porter + + * tests/unixInit.test (7.1): Alternative fix for the 2004-11-11 commit. + +2005-04-27 Don Porter + + * library/init.tcl: Corrected flaw in interactive command + * tests/main.test: auto-completion. [Bug 1191409]. + + TIP#183 IMPLEMENTATION [Patch 577093] + + * generic/tclIOUtil.c (TclGetOpenModeEx): New routine. + * generic/tclInt.h: + + * generic/tclIO.c (Tcl_OpenObjCmd): Support for "b" and + * doc/open.n: "BINARY" in "access" argument to [open]. + * tests/ioCmd.test: + +2005-04-26 Kevin B. Kenny + + * generic/tclBinary.c (FormatNumber): + Dredge the NaN out of the internal representation if + Tcl_GetDoubleFromObj returns TCL_ERROR on a NaN. + + * generic/tclObj.c (Tcl_GetDoubleFromObj): + Restored silent overflow/underflow behaviour that the merge + of 2004-04-25 messed up. Thanks to Don Porter for calling + attention to this bug. Also removed an uninitialised memory + reference in this function that valgrind caught. Also changed + to return TCL_ERROR on a pure NaN. + + * generic/tclStrToD.c (RefineResult): + Added a test for the initial approximation being HUGE_VAL; + this test avoids EDOM being returned from ldexp on some platforms + on input values exceeding the floating point range. + + * tests/expr.test (expr-29.*, expr-30.*): + Added further tests of overflow/underflow on input conversions. + +2005-04-25 Kevin B. Kenny + + [kennykb-numerics-branch] Merged with HEAD. + + * doc/CrtMathFunc.n: Revised documentation for TIP 232 + +2005-04-25 Daniel Steffen + + * compat/string.h: fixed memchr() protoype for __APPLE__ so that we + build on Mac OS X 10.1 again. + + * generic/tclNotify.c (TclFinalizeNotifier): fixed notifier not being + finalized in unthreaded core (was testing for notifier initialization in + current thread by checking thread id != 0 but thread id is always 0 in + untreaded core). + + * win/tclWinNotify.c (Tcl_WaitForEvent): + * unix/tclUnixNotfy.c (Tcl_WaitForEvent): don't call ScaleTimeProc for + zero wait times (as specified in TIP 233). + + * unix/Makefile.in: added @PLAT_SRCS@ to SRCS and split out NOTIFY_SRCS + from UNIX_SRCS for parity with UNIX_OBJS & NOTIFY_OBJS. + + * unix/tcl.m4 (Darwin): added configure checks for recently added linker + flags -single_module and -search_paths_first to allow building with + older tools (and on Mac OS X 10.1), use -single_module in SHLIB_LD and + not just T{CL,K}_SHLIB_LD_EXTRAS, added unexporting from Tk of symbols + from libtclstub to avoid duplicate symbol warnings, added PLAT_SRCS + definition for Mac OS X, defined MODULE_SCOPE to __private_extern__. + (SC_MISSING_POSIX_HEADERS): added caching of dirent.h check. + + * unix/configure: autoconf-2.59 + +2005-04-25 Kevin B. Kenny + + * library/tzdata/America/Boise: + * library/tzdata/America/Chicago: + * library/tzdata/America/Denver + * library/tzdata/America/Indianapolis: + * library/tzdata/America/Los_Angeles: + * library/tzdata/America/Louisville: + * library/tzdata/America/Managua: + * library/tzdata/America/New_York: + * library/tzdata/America/Phoenix: + * library/tzdata/America/Port-au-Prince: + * library/tzdata/America/Indiana/Knox: + * library/tzdata/America/Indiana/Marengo: + * library/tzdata/America/Indiana/Vevay: + * library/tzdata/America/Kentucky/Monticello: + * library/tzdata/America/North_Dakota/Center: + * library/tzdata/Asia/Tehran: + Olson's tzdata2005i. Corrects exact time at which Standard Time + was adopted in the US (generally, noon, Standard Time, rather than + noon, Local Mean Time). Adopts new civil rules for Nicaragua + and Iran. + +2005-04-25 Don Porter + + * library/init.tcl: Use "ni" and "in" operators. + +2005-04-25 Miguel Sofer + + * generic/tclExecute.c: fix for [Bug 1189274]. + +2005-04-24 Don Porter + + * generic/tclLiteral.c: Silence compiler warnings. + * generic/tclObj.c: [Bug 1188863]. + +2005-04-22 Don Porter + + The 2005-04-21 changes to Tcl_GetBooleanFromObj were done to bring + it into agreement with its docs. Further investigation reveals it + was the docs that were incorrect. + + * doc/BoolObj.3: Corrections to the documentation of + Tcl_GetBooleanFromObj to bring it into agreement with what this + public interface has always done, including noting the difference + in function between Tcl_GetBooleanFromObj and Tcl_GetBoolean. + + * generic/tclGet.c: Revised Tcl_GetBoolean to no longer be a + wrapper around Tcl_GetBooleanFromObj (different function!). + + * generic/tclObj.c: Removed TclGetTruthValueFromObj routine + that was added yesterday. Revisions so that only + Tcl_GetBoolean-approved values get the "boolean" Tcl_ObjType. + This retains the fix for [Bug 1187123]. + * tests/string.test: Test string-23.0 for Bug 1187123. + + * generic/tclInt.h: Revert most recent change. + * generic/tclBasic.c: + * generic/tclCompCmds.c: + * generic/tclDictObj.c: + * generic/tclExecute.c: + * tests/obj.test: + +2005-04-21 Don Porter + + * doc/GetInt.3: Convert argument "string" to "str" to agree with code. + Also clarified a few details on int and double formats. + * generic/tclGet.c: Radical code simplification. Converted + Tcl_GetFoo() routines into wrappers around Tcl_GetFooFromObj(). + Reduces code duplication, and the resulting potential for inconsistency. + + * generic/tclObj.c: Several changes: + + - Re-ordered error detection code so all values with trailing + garbage receive a "not an integer" message instead of an + "integer too large" message. + - Removed inactive code meant to deal with strtoul* routines that + fail to parse leading signs. All of them do, and if any are + detected that do not, the correct fix is replacement with + compat/strtoul*.c, not a lot of special care by the callers. + - Tcl_GetDoubleFromObj now avoids shimmering away a "wideInt" intrep. + - Fixed Tcl_GetBooleanFromObj to agree with its documentation and + with Tcl_GetBoolean, accepting only "0" and "1" and not other + numeric strings. [Bug 1187123] + - Added new private routine TclGetTruthValueFromObj to perform + the more permissive conversion of numeric values to boolean + that is needed by the [expr] machinery. + + * generic/tclInt.h (TclGetTruthValueFromObj): New routine. + * generic/tclExecute.c: Updated callers to call new routine. + * generic/tclBasic.c: Updated callers to call new routine. + * generic/tclCompCmds.c: Updated callers to call new routine. + * generic/tclDictObj.c: Updated callers to call new routine. + * tests/obj.test: Corrected bad tests that actually expected + values like "47" and "0xac" to be accepted as booleans. + + * generic/tclLiteral.c: Disabled the code that forces some literals + into the "int" Tcl_ObjType during registration. We can re-enable it + if this change causes trouble, but it seems more sensible to let + Tcl's "on-demand" shimmering rule, and not try to pre-guess things. + +2005-04-20 Kevin B. Kenny + + [kennykb-numerics-branch] + * doc/expr.n: + * doc/mathfunc.n (new file): Revised documentation for TIP 232 + +2005-04-20 Don Porter + + * generic/tclGet.c (Tcl_GetInt): Corrected error that did not + * generic/tclObj.c (Tcl_GetIntFromObj): permit 0x80000000 to be + recognized as an integer on TCL_WIDE_INT_IS_LONG systems [Bug 1090869]. + +2005-04-20 Kevin B. Kenny + + * generic/tclFileName.c: Silenced a compiler warning about + '/*' within a comment. + +2005-04-19 Don Porter + + * generic/tclBasic.c: Added unsupported command + * generic/tclCmdAH.c: [::tcl::unsupported::EncodingDirs] to permit + * generic/tclInt.h: query/set of the encoding search path at + * generic/tclInterp.c: the script level. Updated init.tcl to make + * library/init.tcl: use of the new command. Also updated several + coding practices in init.tcl ("eq" for [string equal], etc.) + +2005-04-19 Kevin B. Kenny + + * library/clock.tcl (Initialize): Put initialization code into a + proc to avoid inadvertently clobbering global variables. + [Bug 1185933] + * tests/clock.test (clock-48.1): Added regression test for the + above bug. + Thanks to Ulrich Ring for reporting this bug. + +2005-04-16 Miguel Sofer + + * generic/Var.c (Tcl_ArrayObjCmd - ARRAY_NAMES): fix Tcl_Obj leak + [Bug 1084111] + +2005-04-16 Zoran Vasiljevic + + * generic/tclIOUtil.c: force clenaup of the interp result + in TclLoadFile(). Some implementations of TclpFindSymbol() + will seed the interp result with error message when unable + to find the requested symbol (this is not considered to + be an error). + + Set of changes correcting huge memory waste (not a leak) + when a thread exits. This has been introduced in 8.4.7 + within an attempt to correctly cleanup after ourselves when + Tcl library is being unloaded with the Tcl_Finalize() call. + + This fixes the Tcl Bug #1178445. + + * generic/tclInt.h: added prototypes for TclpFreeAllocCache() + and TclFreeAllocCache() + + * generic/tclThreadAlloc.c: modified TclFinalizeThreadAlloc() + to explicitly call TclpFreeAllocCache with the NULL-ptr as + argument signalling cleanup of private tsd key used only by + the threading allocator. + + * unix/tclUnixThrd.c: fixed TclpFreeAllocCache() to recognize + when being called with NULL argument. This is a signal for it + to clean up the tsd key associated with the threading allocator. + + * win/tclWinThrd.c: renamed TclWinFreeAllocCache to TclpFreeAllocCache + and fixed to recognize when being called with NULL argument. + This is a signal for it to clean up the tsd key associated with the + threading allocator. + +2005-04-13 Don Porter + + * tests/unixInit.test: Disabled obsolete tests and removed code + * tests/encoding.test: that supported them. + * generic/tclInterp.c: + + * library/init.tcl: Use auto-loading to bring in Tcl Module + * library/tclIndex: support as needed. This reduces startup + * library/tm.tcl: time by delaying this initialization to + a later time. + +2005-04-15 Miguel Sofer + + * generic/tclExecute.c: missing semicolons caused failure to + compile with TCL_COMPILE_DEBUG. + +2005-04-13 David Gravereaux + + * generic/tclIO.c (Tcl_SetChannelBufferSize): Lowest size limit + * tests/io.test: changed from ten bytes to one byte. Need + * tests/iogt.test: for this change was proven by + Ross Cartlidge where [read stdin 1] was grabbing + 10 bytes followed by starting a child process that was intended to + continue reading from stdin. Even with -buffersize set to one, + nine chars were getting lost by the buffersize over reading for + the native read() caused by [read]. + +2005-04-13 Don Porter + + * unix/tclUnixInit.c (TclpGetEncodingNameFromEnvironment): Reversed + order of verifying candidate [encoding system] value, checking against + a table in memory first before calling Tcl_GetEncoding and potentially + scanning through the filesystem. Also ordered the table so that a + binary search could be used within it. Improves startup time a bit + more on some systems. + +2004-04-13 Kevin B. Kenny + + * library/clock.n: Added a missing '--' on several [switch] + commands to improve performance of [clock format] and related + operations. [Feature Request 1182459] + +2005-04-13 Donal K. Fellows + + * doc/fcopy.n: Improved documentation on copying binary files, + added an example and mentioned the use of [file copy]. + * doc/fconfigure.n: Improved documentation of -encoding binary + option. + This is all following comments from Steve Manning + on comp.lang.tcl that the current documentation was not clear. + +2005-04-13 Miguel Sofer + + * generic/tclCompile.c:Commented out the functions + TclPrintInstruction(), TclPrintObject() and TclPrintSource() when + not debugging the compiler, as they are never called in that case. + +2005-04-12 Don Porter + + * generic/tclInterp.c: Corrected bad syntax of Tcl_Panic() call. + + * generic/tclUtil.c (TclGetProcessGlobalValue): More robust handling + of bad TclInitProcessGlobalValueProc behavior; an immediate panic + rather than a mysterious crash later. + + * generic/tclEncoding.c: Several changes to the way the + encodingFileMap cache is maintained. Previously, it was attempted + to keep the file map filled and up to date with changes in the + encoding search path. This contributed to slow startup times since + it required an expensive "glob" operation to fill the cache. Now the + validity of items in the cache are checked at the time they are + used, so the cache is permitted to fall out of sync with the + encoding search path. Only [encoding names] and Tcl_GetEncodingNames() + now pay the full expense. [Bug 1177363] + +2005-04-12 Kevin B. Kenny + + * compat/strstr.c: Added default definition of NULL to + accommodate building on systems with badly broken headers. + [Bug #1175161] + +2005-04-11 Donal K. Fellows + + * tools/tclZIC.tcl: Rewrote to take advantage of more features of + Tcl 8.5 (on which it was dependent anyway). Also added a [package + require] line to formalize the relationship. + +2005-04-11 Kevin Kenny + + [kennykb-numerics-branch] Merged with HEAD. Updated to libtommath 0.35. + + * generic/tclBasic.c: Attempted to repeat changes that applied + to tclExecute.c in Miguel Sofer's commit of 2005-04-01, together + with (possibly) a few more uses of his new object creation macros. + Also plugged a memory leak in TclObjInvoke. [Bug 1180368] + +2005-04-10 Kevin Kenny + + * library/tzdata/America/Montevideo: + * library/tzdata/Asia/Almaty: + * library/tzdata/Asia/Aqtau: + * library/tzdata/Asia/Aqtobe: + * library/tzdata/Asia/Baku: + * library/tzdata/Asia/Jerusalem: + * library/tzdata/Asia/Oral: + * library/tzdata/Asia/Qyzylorda: + * library/tzdata/Indian/Chagos: + * library/tzdata/Indian/Cocos: Olson's tzdata2005h + +2005-04-10 Don Porter + + * generic/tclBasic.c (TclObjInvoke): Plug memory leak. [Bug 1180368] + +2005-04-09 Miguel Sofer + + * generic/tclExecute.c: fix possible leak of expansion Tcl_Objs + +2005-04-09 Daniel Steffen + + * macosx/README: updated requirements for OS & developer tool + versions + other small fixes/cleanup. + + * generic/tclListObj.c (Tcl_ListObjIndex): added missing NULL return + when getting index from an empty list. + + * unix/tcl.m4 (Darwin): added -single_module linker flag to + TCL_SHLIB_LD_EXTRAS and TK_SHLIB_LD_EXTRAS. + * unix/configure: autoconf-2.59 + +2005-04-08 Don Porter + + * generic/tclInt.h (TclGetEncodingFromObj): New function to + * generic/tclEncoding.c (TclGetEncodingFromObj): retrieve a + Tcl_Encoding value, as well as cache it in the internal rep + of a new "encoding" Tcl_ObjType. + * generic/tclCmdAH.c (Tcl_EncodingObjCmd): Updated to call + new function so that Tcl_Encoding's used by [encoding convert*] + routines are not freed too quickly. [Bug 1077262] + +2005-04-08 Donal K. Fellows + + * generic/tclCompCmds.c (TclCompileSwitchCmd): Rewritten to be + able to handle the other form of [switch] and generate slightly + simpler (but longer) code. + +2005-04-06 Donal K. Fellows + + * doc/upvar.n, doc/unset.n, doc/tell.n, doc/tclvars.n, doc/subst.n: + * doc/seek.n, doc/scan.n, doc/regsub.n, doc/registry.n, doc/regexp.n: + * doc/read.n, doc/puts.n, doc/pkgMkIndex.n, doc/open.n, doc/lreplace.n: + * doc/lrange.n, doc/load.n, doc/llength.n, doc/linsert.n, doc/lindex.n: + * doc/lappend.n, doc/info.n, doc/gets.n, doc/format.n, doc/flush.n: + * doc/fileevent.n, doc/file.n, doc/fblocked.n, doc/close.n: + * doc/array.n, doc/Utf.3, doc/TraceVar.3, doc/StrMatch.3, doc/RegExp.3: + * doc/PrintDbl.3, doc/OpenTcp.3, doc/OpenFileChnl.3, doc/Object.3: + * doc/Notifier.3, doc/LinkVar.3, doc/IntObj.3, doc/Interp.3: + * doc/GetOpnFl.3, doc/GetIndex.3, doc/Eval.3, doc/CrtMathFnc.3: + * doc/CrtFileHdlr.3, doc/CrtCommand.3, doc/CrtChannel.3: + * doc/Backslash.3: Purge old .VS/.VE macro instances. + + * tools/man2html2.tcl (IPmacro): Rewrote to understand what .IP + really is (.IP and .TP are really just two ways of doing the same + thing). Change below made this relevant. + * doc/re_syntax.n: Change some uses of .TP to .IP to work around + bugs in various *roff implementations. Also reworded the atom + descriptions slightly. + +2005-04-05 Don Porter + + * generic/tclExecute.c (ExprSrandFunc): Replaced incursions into the + * generic/tclUtil.c (TclGetIntForIndex): intreps of numeric types + with simpler calls of Tcl_GetIntFromObj and Tcl_GetLongFromObj, + now that those routines are better behaved wrt shimmering. + [Patch 1177219] + +2005-04-05 Miguel Sofer + + * generic/tclInt.h: + * generic/tclObj.c: Change in TclDecrRefCount and TclFreeObj, to + speed up the freeing of simple Tcl_Obj [Patch 1174551] + +2005-04-04 Miguel Sofer + + * generic/tclExecute.c: small opts in obj handling + +2005-04-02 Miguel Sofer + + * generic/tclVar.c: converted a few function calls to macros. + +2005-04-01 Miguel Sofer + + * doc/ListObj.3: + * generic/tclBasic.c: + * generic/tclCmdIL.c: + * generic/tclConfig.c: + * generic/tclExecute.c: + * generic/tclInt.decls: + * generic/tclInt.h: + * generic/tclIntDecls.h: + * generic/tclListObj.c: + * generic/tclStubInit.c: + * generic/tclVar.c: Changed the internal representation of lists + to (a) reduce the malloc/free calls at list creation (from 2 to + 1), (b) reduce the cost of handling empty lists (we now never + create a list internal rep for them), (c) allow refcounting of the + list internal rep. The latter permits insuring that the pointers + returned by Tcl_ListObjGetElements remain valid even if the object + shimmers away from its original list type. This is [Patch 1158008] + + * generic/tclExecute.c: + * generic/tclInt.h: + * generic/tclObj.c: + * generic/tclStringObj.c: + (1) defined new internal macros for creating and setting + frequently used obj types (int,long, wideInt, double, + string). Changed TEBC to use eg 'TclNewIntObj(objPtr, i)' to avoid + the function call in 'objPtr = Tcl_NewIntObj(i)' + (2) ExecEnv now stores two Tcl_Obj* pointing to the constants "0" + and "1", for use by TEBC. + (3) slight reduction in cost of INST_START_CMD + +2005-03-31 Miguel Sofer + + * generic/tclExecute.c (INST_JUMP_TRUE/FALSE): replaced + "test and branch" with "compute index into table" + +2005-03-30 Donal K. Fellows + + * doc/FileSystem.3: Defined loadHandle argument. [Bug 1172401] + +2005-03-29 Jeff Hobbs + + * win/tcl.m4, win/configure: do not require cygpath in macros to + allow msys alone as an alternative. + +2005-03-24 Don Porter + + * generic/tclCompile.h: Move the TclInterpReady() declaration from + * generic/tclInt.h: tclCompile.h to tclInt.h. Should have + been done as part of the 1115904 bug fix on 2005-03-18. + + * generic/tclThreadTest.c: Stop providing the phony package + "Thread 1.0" when the [::testthread] command is defined. It's + never used by anything, and conflicts with loading the real + "Thread" package. + +2005-03-18 Don Porter + + * generic/tclCompCmds.c (TclCompileIncrCmd): Corrected checks + for immediate operand usage to permit leading space and sign + characters. Restores more efficient bytecode for [incr x -1] + that got lost in the CONST string reforms of Tcl 8.4. [Bug 1165671] + + * generic/tclBasic.c (Tcl_EvalEx): Restored recursion limit + * generic/tclParse.c (TclSubstTokens): testing in nested command + * tests/basic.test (basic-46.4): substitutions within direct + * tests/parse.test (parse-19.*): script evaluation (Tcl_EvalEx) + that got lost in the parser reforms of Tcl 8.1. Added tests for + correct behavior. [Bug 1115904] + +2005-03-15 Vince Darley + + * generic/tclFileName.c: + * win/tclWinFile.c: + * tests/winFCMd.test: fix to 'file pathtype' and 'file norm' + failures on reserved filenames like 'COM1:', etc. + +2005-03-15 Pat Thoyts + + * unix/tcl.m4: Updated the OpenBSD configuration and regenerated + * unix/configure: the configure script. + +2005-03-15 Kevin B. Kenny + + [kennykb-numerics-branch] Merged with HEAD. + + * generic/tclBasic.c (many): + * generic/tclCompExpr.c (CompileMathFuncCall): + * generic/tclCompile.h: + * generic/tclExecute.c (many): + * generic/tclParseExpr.c (ParsePrimaryExpr): + * tests/compExpr-old.test: + * tests/compExpr.test: + * tests/compile.test: + * tests/expr-old.test: + * tests/expr.test: + * tests/for.test: + * tests/parseExpr.test: + Initial implementation of TIP #232. + + * generic/tclObj.c (Tcl_DbNewBignumObj): Fixed typo that broke + --enable-symbols=mem build + * tests/binary.test (binary-40.3, binary-40.6): Corrected tests + to allow NaN(7ffffffffffff). + +2005-03-14 Miguel Sofer + + * generic/tclExecute.c: fixed INST_PUSH1's debugging code (wrong + obj ref passed to TRACE_WITH_OBJ). + +2005-03-14 Miguel Sofer + + * generic/tclCompile.c: fixed INST_RETURN's stack effect in + tclInstructionTable (-1 instead of -2) + +2005-03-10 Miguel Sofer + + * generic/tclCompCmds.c: removed debugging line + +2005-03-10 Don Porter + + * generic/tclTrace.c (TclCheckInterpTraces): Corrected mistaken + cast of ClientData to (TraceCommandInfo *) when not warranted. + Thanks to Yuri Victorovich for the report. [Bug 1153871] + * generic/tcl.h: Moved flag values TCL_TRACE_ENTER_EXEC and + * generic/tclInt.h: TCL_TRACE_LEAVE_EXEC from public interface + into private. Should be used only by internal workings of + execution traces. + +2005-03-09 Kevin B. Kenny + + [kennykb-numerics-branch] Merged from HEAD. + + * doc/PrintDbl.3: + * doc/tclVars.n: Documented new semantics for tcl_precision. + * generic/tclExecute.c (Tcl_ExecuteByteCode): Removed the check + for division-by-zero on IEEE-754 machines. + * generic/tclUtil.c (Tcl_PrintDouble): Corrected bug where numbers + in the range [1e-4 .. 1.) were printed incorrectly. + * tests/compExpr-old.test (compExpr-old-11.13): Revised test + case for division by zero + * tests/expr-old.test (expr-34.11, expr-34.12): Revised test + cases for overflow in pow() to deal with infinities. + * tests/expr.test (expr-11.13, expr-29.1, expr-29.2): Revised + test case for division by zero and for underflow on input + conversions. + * tests/parseExpr.test (parseExpr-16.11): Revised test case for + overflow on input conversion. + * tests/string.test (string-6.38 deleted): Removed test case + for underflow on input conversion, which is no longer an error. + * tests/util.test (util-10.*): Added test case for the bug in + tclUtil.c. + +2005-03-08 Jeff Hobbs + + * win/makefile.vc: clarify necessary defined vars that can come + from MSVC or the Platform SDK. + +2005-03-07 Donal K. Fellows + + * doc/string.n: Minor typo. [Bug 1158247] + +2005-03-07 Miguel Sofer + + * generic/tclExecute.c: new peephole optimisation for INST_PUSH1; + fixed the peephole opt in INST_POP so that it is not used when + TCL_COMPILE_DEBUG is defined. + +2005-03-04 Kevin B. Kenny + + [kennykb-numerics-branch] + + * generic/tclCmdMZ.c: Changed [scan] to treat out-of-range + floating point values as infinities and zeroes. + * generic/tclExecute.c: Changed [expr] to be permissive about + infinities, allowing them to propagate. + * generic/tclGet.c: Changed Tcl_GetDouble to be permissive about + over/underflow. + * generic/tclObj.c: Changed SetDoubleFromAny to be permissive + about over/underflow. + * generic/tclParseExpr.c: Made [expr] permissive about input + numbers out of range. + +2005-03-03 Kevin B. Kenny + + [kennykb-numerics-branch] + + * generic/tclInt.h: + * generic/tclStrToD.c (Tcl_DoubleDigits, TclFormatNaN): + * generic/tclUtil.c (Tcl_PrintDouble): + Changed the signature of TclDoubleDigits so that it + accepts a pointer to the signum of the argument, and + returns the signum via that pointer. Added very + hacky code to handle IEEE signed zeroes in Tcl_DoubleDigits. + (It can't be done other than as a hack until C9x; + C89 simply doesn't deal with the concept of -0.0). + Added output conversion of tagged NaN values. + * generic/tclBinary.c (FormatNumber): + Changed to allow [binary format] to handle NaN. + * tests/binary.test (binary-60.1): + Added a quick-n-dirty test to make sure that NaN's + can be scanned and formatted. + * generic/tclParseExpr.c (GetLexeme, ParseMaxDoubleLength): + Modified so that tagged NaN (e.g., NaN(DEADBEEF)) can + be recognized. + +2005-03-02 Kevin B. Kenny + + [kennykb-numerics-branch] Merged with HEAD as of 2005-02-23. + + * generic/tclExecute.c: + Broadened test for NaN to work on Windows. + * generic/tclInt.h: + * generic/tclStrToD.c (Tcl_DoubleDigits): + * generic/tclUtil.c (Tcl_PrintDouble, TclPrecTraceProc): + Added Tcl_DoubleDigits to format 'double' numbers + with the minimum number of significant digits to + yield correct rounding. Modified tcl_precision to + accept 0 as a precision (meaning "minimum digits"), and + made 0 the default. [TIP #132] + * generic/tclObj.c: + Made NaN's throw an error in Tcl_GetDoubleFromObj. + * unix/Makefile.in: + * win/Makefile.in: + * win/makefile.vc: + Added libtommath/bn_mp_init_set.c to the build. + * libtommath/tommath.h (mp_iseven): + Fixed a bug that caused zero to test 'odd'. + * generic/tommath.h: + Regenerated. + * tests/binary.test: + * tests/expr-old.test: + * tests/expr.test: + * tests/scan.test: + Corrected a number of tests that depended on + tcl_precision, and removed the {eformat} condition + from tests that no longer require it. + * tests/util.test: + Corrected a number of tests that depended on + tcl_precision, and removed the {eformat} condition + from tests that no longer require it. Added a series + of tests for correct rounding in Tcl_PrintDouble. [TIP + #132]. + +2005-03-01 David N. Welton + + * doc/CrtSlave.3: Changed to Tcl_Object to Tcl_Obj in the man + page. + +2005-02-24 Don Porter + + * library/tcltest/tcltest.tcl: Better use of [glob -types] to avoid + * tests/tcltest.test: failed attempts to [source] a directory, and + similar matters. Thanks to "mpettigr". [Bug 1119798] + + * library/tcltest/pkgIndex.tcl: Bump to tcltest 2.2.8 + * unix/Makefile.in: + * win/Makefile.in: + +2005-02-23 Donal K. Fellows + + * doc/CrtChannel.3 (THREADACTIONPROC): Formatting fix. [Bug 1149605] + +2005-02-17 Jeff Hobbs + + * win/tclWinFCmd.c (TraverseWinTree): use wcslen on wchar, not + Tcl_UniCharLen. + +2005-02-16 Miguel Sofer + + * doc/variable.n: fix for [Bug 1124160], variables are detected + by [info vars] but not by [info locals]. + +2005-02-11 Jeff Hobbs + + * unix/Makefile.in: remove SHLIB_LD_FLAGS (only for AIX, inlined + * unix/tcl.m4: into SHLIB_LD). Combine AIX-* and AIX-5 + * unix/configure: branches in SC_CONFIG_CFLAGS. + Correct gcc builds for AIX-4+ and HP-UX-11. autoconf-2.59 gen'd. + +2005-02-11 Miguel Sofer + + * tests/basic.test (basic-26.3): new test + +2005-02-10 Miguel Sofer + + * generic/tclBasic.c (Tcl_EvalObjEx): + * tests/basic.test (basic-26.2): preserve the arguments passed to + TEOV in the pure-list branch, in case the list shimmers away. Fix + for [Bug 1119369], reported by Peter MacDonald. + +2005-02-10 Vince Darley + + * generic/tclFileName.c: fix for test failures introduced + on 2005-01-17 [Bug 1119092] + +2005-02-10 Donal K. Fellows + + * doc/binary.n: Made the documentation of sign bit masking and + [binary scan] consistent. [Bug 1117017] + +2005-02-08 David N. Welton + + * doc/CrtChannel.3: Typo: return->returns. + +2005-02-06 Kevin B. Kenny + + [kennykb-numerics-branch] + + * generic/tclStrToD.c (TclStrToD, SafeLdExp): + Added code to manage the FPU precision on gcc+x86. + Enabled fast conversion of floats with small exponents + now that precision is correct. + * tests/expr.test: Corrected test for the smallest representible + value to the right IEEE values. + +2005-02-06 David N. Welton + + * doc/Thread.3: One-word grammar fix. + +2005-02-05 David N. Welton + + * doc/Thread.3: Fixed sentence describing flags for + Tcl_CreateThread. + + * doc/FileSystem.3: Cleaned up typo in Tcl_FSNewNativePath + documentation. + + * generic/tclPathObj.c: Cleaned up typo in comment. + +2005-02-03 Kevin B. Kenny + + [kennykb-numerics-branch] + + * generic/tclStrToD.c (TclStrToD, RefineResult, SafeLdExp): + Added code to ensure that 'ldexp' is never called with + a value that will underflow. + * tests/expr.test: Added tests for the smallest representible + value, and rounding between it and zero. (The tests reflect + current behaviour; plan is to change the specification of + Tcl so that input conversion of doubles underflows silently.) + +2005-02-02 Mo DeJong + + * generic/tclProc.c (TclInitCompiledLocals): + Add check for type of the framePtr->procPtr->bodyPtr + passed to TclInitCompiledLocals and panic if + it is not the correct type. If the body of the proc + is not of the compiled byte code type then the + code will crash. This was discovered while tracking + down a crash in Itcl, that crash is fixed by + Itcl patch 1115085. + +2005-02-01 Kevin B. Kenny + + [kennykb-numerics-branch] Merged with HEAD as of today. + + * generic/tclInt.decls: + Changed numbers of new stubs to resolve a conflict. + * generic/tclInt.h: + Added new TclStrToD routine that replaces the native + 'strtod' thro + ughout Tcl. + * generic/tclCmdMZ (Tcl_StringObjCmd): + * generic/tclGet.c (Tcl_GetDouble): + * generic/tclObj.c (SetBooleanFromAny, SetDoubleFromAny): + * generic/tclParseExpr.c (GetLexeme): + * generic/tclScan.c (Tcl_ScanObjCmd): + Replaced all uses of the native 'strtod' with a TclStrToD + routine that performs correct rounding and handles denormals. + * generic/tclStrToD.c: (new file) + New scanning function for extracting 'double' from a string + that rounds correctly, and handles denormals and infinities. + * unix/Makefile.in: + * win/Makefile.in: + * win/makefile.vc: + Added tclStrToD.c and the tommath routines that support it. + + These changes represent a partial implementation of TIP #132. + Output conversion of floating point numbers, and proper handling + of infinities within expressions, still need to be addressed. + +2005-02-01 Don Porter + + * generic/tclExecute.c (TclCompEvalObj): Removed stray statement + left behind in prior code reorganization. + +2005-01-31 Don Porter + + * unix/configure: autoconf-2.57 + +2005-01-30 Joe English + + * unix/configure.in: Restored two double-evals that were + removed in the DBGX purge; these are still needed on some + platforms to account for TCL_TRIM_DOTS. [Bug 1112654] + + * unix/configure: NOT REGENERATED: only have autoconf 2.59 here, + need to find someone with autoconf 2.57. + +2005-01-28 Jeff Hobbs + + * unix/configure, unix/tcl.m4: add solaris 64-bit gcc build + support. [Bug 1021871] + +2005-01-28 Donal K. Fellows + + * tests/expr-old.test (expr-old-37.2): Added test for [Bug 1109484] + +2005-01-27 Jeff Hobbs + + * generic/tclBasic.c (Tcl_ExprBoolean, Tcl_ExprDouble) + (Tcl_ExprLong): Fix to recognize Tcl_WideInt type. [Bug 1109484] + +2005-01-26 Andreas Kupries + + TIP#218 IMPLEMENTATION + + * generic/tclDecls.h: Regenerated from tcl.decls. + * generic/tclStubInit.c: + + * doc/CrtChannel.3: Documentation of extended API, + * generic/tcl.decls: extended testsuite, and + * generic/tcl.h: implementation. Removal of old + * generic/tclIO.c: driver-specific TclpCut/Splice + * generic/tclInt.h: functions. Replaced with generic + * tests/io.test: thread-action calls through the + * unix/tclUnixChan.c: new hooks. Update of all builtin + * unix/tclUnixPipe.c: channel drivers to version 4. + * unix/tclUnixSock.c: Windows drivers extended to + * win/tclWinChan.c: manage thread state in a thread + * win/tclWinConsole.c: action handler. + * win/tclWinPipe.c: + * win/tclWinSerial.c: + * win/tclWinSock.c: + +2005-01-25 Don Porter + + * library/auto.tcl: Updated [auto_reset] to clear auto-loaded + commands in namespaces other than :: and to clear auto-loaded commands + that do not happen to be procs. [Bug 1101670] + ***POTENTIAL INCOMPATIBILITY*** + +2005-01-25 Daniel Steffen + + * unix/tcl.m4 (Darwin): fixed bug with static build linking to + dynamic library in /usr/lib etc instead of linking to static library + earlier in search path. [Tcl Bug 956908] + Removed obsolete references to Rhapsody. + * unix/configure: autoconf-2.57 + +2005-01-21 Andreas Kupries + + * generic/tclStubInit.c: Regenerated the stubs support code from + * generic/tclDecls.h: the modified tcl.decls (TIP #233, see below). + + * doc/GetTime.3: Implemented TIP #233, i.e. the + * generic/tcl.decls: 'Virtualization of Tcl's Sense of Time'. + * generic/tcl.h: Declared, implemented, and documented the + * generic/tclInt.h: specified new API functions. Moved the + * unix/tclUnixEvent.c: native (OS) access to time information + * unix/tclUnixNotfy.c: into standard handler functions. Inserted + * unix/tclUnixTime.c: hooks calling on the handlers where native + * win/tclWinNotify.c: access was done before, and where scaling + * win/tclWinTime.c: between domains (real/virtual) is required. + +2005-01-21 Andreas Kupries + + * generic/tclThread.c: Typo police. Fixed some nits + * generic/tclCmdAH.c: in header comments of functions. + * generic/tclBasic.c: (Missing --). + * generic/tclFileName.c: + +2005-01-21 Donal K. Fellows + + * doc/FileSystem.3: Add missing ARGUMENTS section definitions for + arguments to Tcl_FSLink. [Bug 1106272] + +2005-01-21 Kevin B. Kenny + + [kennykb-numerics-branch] + + * unix/Makefile.in: Updated Makefile to build libtommath on + Unix as well as Windows. [Bug 1106865] + + * generic/tclTestObj.c (TestbignumobjCmd): + Silenced a compiler warning about a mismatched 'const'. + +2005-01-20 Kevin B. Kenny + + [kennykb-numerics-branch] Development checkpoint. + + * compat/strtoll.c: Reverted to HEAD. + * compat/strtoull.c: + * doc/Ensemble.3: + * generic/tclBasic.c: + * generic/tclCmdIL.c: + * generic/tclNamesp.c: + * generic/tclPathObj.c: + * generic/tclPort.h: + * unix/configure: + * unix/configure.in: + * unix/tcl.m4: + * win/configure: + * win/configure.in: + * win/rules.vc: + * win/tcl.m4: + + * generic/tcl.h: Added declarations for bignum types, and + for a 'bignumValue' in the Tcl_Obj structure. + * generic/tclInt.h: Added declarations of interface procedures + for memory allocation in libtommath. + + * generic/tcl.decls: Added new interface to bignum objects. + * generic/tclInt.decls: Added internal stubs for bignum routines + used by the test code in tclTestObj.c. + + * generic/tclDecls/h: Regen. + * generic/tclIntDecls.h: + * generic/tclStubInit.h: + + * tools/fix_tommath_h.tcl: (New file) Script to edit + libtommath/tommath.h and produce + generic/tommath.h so that storage + classes, allocation routines, and + data types conform to Tcl's + conventions. + * generic/tommath.h: (New file) Generated by the above. + + * generic/tclTomMath.h: (New file) Additional declarations + to be included in tommath.h when building + Tcl. + + * generic/tclTomMathInterface.c: (New file) Small 'glue' routines + adapting tommath's API to Tcl. + + * libtommath/bn_fast_s_mp_mul_digs.c: + * libtommath/bn_mp_mul_d.c: + * libtommath/bn_mp_read_radix.c: + * libtommath/tommath.h: Applied suggested changes from Tom St + Denis that correct an off-by-one error in single-digit + multiplication (leading to a pointer smash if uncorrected) and + change the string argument to 'mp_read_radix' from 'char*' to + 'const char*'. + + * libtommath/bn_mp_radix_size.c: + Local patch to ensure that sufficient memory is requested + even if the number has a single digit. + + * libtommath/bn_mp_read_radix.c: + Local patch to return MP_VAL if the input string contains + an invalid character. + + * generic/tclObj.c: Added accessor functions for bignums. + * generic/tclTestObj.c: Added a 'testbignumobj' command to + exercise the accessor functions for bignums. + + * win/Makefile.in: Added rules for making libtommath. + +2005-01-19 Donal K. Fellows + + TIP#235 IMPLEMENTATION + + * doc/Ensemble.3: Documentation for the new public API. + * generic/tclNamesp.c (Tcl_CreateEnsemble,...): Rename of + * generic/tcl.decls: existing API into TIPped form. + +2005-01-19 Mo DeJong + + * win/tclWinChan.c (FileCloseProc): Invoke TclpCutFileChannel() to + remove a FileInfo from the thread local list before deallocating + it. This should have been done via an earlier call to + Tcl_CutChannel, but I was running into a crash in the next call to + Tcl_CutChannel during the IO finalization stage. + +2005-01-18 Kevin Kenny + + * library/tzdata/GMT+0: + * library/tzdata/GMT-0: + * library/tzdata/GMT0: + * library/tzdata/Greenwich: + * library/tzdata/Navajo: + * library/tzdata/Universal: + * library/tzdata/Zulu: + * library/tzdata/America/Asuncion: + * library/tzdata/America/Rosario: + * library/tzdata/Asia/Jerusalem: + * library/tzdata/Brazil/Acre: + Routine update per Olson's tzdata2005c. Removed links to links + (Greenwich in several aliases; Navajo; Acre). Updated Paraguayan + DST rules and "best guess" at this year's Israeli rules. + +2005-01-17 Vince Darley + + * generic/tclFileName.c: fix for glob failure on Windows shares + [Bug 1100542]. + + * doc/pkgMkIndex.n: added documentation that 'pkg_mkIndex -lazy' is + not a good idea. [Bug 1101678] + +2005-01-14 Donal K. Fellows + + * tests/compile.test (compile-17.1): Document known issue with + binding time of compiled command interpretations in [expr]. + + * generic/tclIOUtil.c (TclFSFileAttrIndex): New helper function so + that we don't need to hard-code attribute indexes. [Bug 1100671] + +2005-01-13 Donal K. Fellows + + * doc/string.n: Removed the term 'set' from the documentation of + the [string trim] commands, as it caused confusion. + +2005-01-12 Donal K. Fellows + + * unix/tcl.m4 (SC_PATH_{TCL,TK}CONFIG): Added code to detect the + case when the --with-tcl/--with-tk arguments point to the config + scripts themselves and not their directory. If this is the case, + they now complain but keep working. [FRQ 951247] + * unix/configure: autoconf-2.57 + +2005-01-10 Joe English + + * unix/Makefile.in, unix/configure.in, unix/tcl.m4, + * unix/tclConfig.sh.in, unix/dltest/Makefile.in: + Remove ${DBGX}, ${TCL_DBGX} from Tcl build system [Patch 1081595]. + * unix/configure: regenerated + +2005-01-10 Donal K. Fellows + + * unix/tclUnixFCmd.c (TclUnixCopyFile): Convert u_int to unsigned + to make clashes with types in standard C headers less of a + problem. [Bug 1098829] + +2005-01-09 Joe English + + * unix/tclUnixThrd.c, unix/tclUnixPort.h: Remove readdir_r() + and related #ifdeffery (see #1095909). + * unix/tcl.m4, unix/tclConfig.h.in: Don't check for HAVE_READDIR_R. + * unix/configure: Regenerated. + +2005-01-06 Donal K. Fellows + + * library/http/http.tcl (http::mapReply): Significant performance + enhancement by using [string map] instead of [regsub]/[subst], and + update version requirement to Tcl8.4. [Bug 1020491] + +2005-01-05 Donal K. Fellows + + * doc/lsearch.n, doc/re_syntax.n: Convert to other form of emacs + mode control comment to prevent problems with old versions of + man. [Bug 1085127] + +2005-01-05 Pat Thoyts + + * tests/winDde.test: Fixed broken test result. + +2005-01-05 Donal K. Fellows + + * generic/tclInt.h, generic/tclPort.h: Move the #include of + tclConfig.h *first* before any reference to tcl.h so that the + build configuration is loaded before the first reference to any + system headers. Issue reported by Art Haas on tcl-core. + +2005-01-04 Don Porter + + * tests/fCmd.test (fCmd-18.10): Added notNetworkFilesystem constraint. + [Bug 456665] + +2004-12-29 Jeff Hobbs + + * win/tcl.m4, win/configure: update MSVC CFLAGS_OPT to -O2, remove + -Gs (included in -O2) and -GD (outdated). Use "link -lib" instead + of "lib" binary and remove -YX for MSVC7 portability. Add + -fomit-frame-pointer for gcc OPT compiles. [Bug 1092952, 1091967] + Align LIBS_GUI with Tk head needs. + +2004-12-29 Kevin B. Kenny + + * generic/tclDate.c: Regen + * generic/tclGetDate.y (TclDatelex): + Fixed a problem where a four-digit group with >=2 + leading zeroes appeared to be a two-digit group, leading to + misinterpreting the time 0012 as 1200. [Bug # 1090413] + * library/clock.tcl: Added code to interpret correctly months + outside the range 01-12 as reduced modulo 12 + with a corresponding adjustment to the year. + [Bug 1092789] + * tests/clock.test: Added regression test cases for the above two + bugs. + * unix/Makefile.in: Added --no-lines to the 'bison' command line + * win/Makefile.in: to help constrain the number of diffs in a cvs + checkin. + +2004-12-24 Miguel Sofer + + * generic/tclCompile.c: + * generic/tclCompile.h: + * generic/tclExecute.c: + * generic/tclInt.h: + * generic/tclLiteral.c: + * generic/tclProc.c: + Avoid sharing cmdName literals accross namespaces, and generalise + usage of the TclRegisterNewLiteral macro [Patch 1090905] + +2004-12-20 Miguel Sofer + + * generic/tclCompile.c: moved TclInitCompiledLocals to tclProc.c + * generic/tclProc.c: new static InitCompiledLocals to allow for a + single pass over the proc's arguments at proc load time (instead of + two as previously). TclObjInterpProc() now allocates the + compiledLocals on the tcl execution stack, using the new + TclStackAlloc/Free functions. + +2004-12-16 Donal K. Fellows + + * generic/tclInterp.c (Tcl_LimitSetTime, TimeLimitCallback): + (TclLimitRemoveAllHandlers, TclInitLimitSupport): Set a timer + event to trigger when the time limit runs out. All the time limit + actually does is check to see if the time limit has been exceeded, + but this is enough to fix [Bug 1085023]. + * generic/tclInt.h (struct Interp): Added a field to hold the token + for the timer event handler associated with the current time limit. + * generic/tclEvent.c (Tcl_UpdateObjCmd, Tcl_VwaitObjCmd): Add + error message when limit exceeded. + * tests/interp.test (interp-34.[89]): Check that time limits + handle the two cases reported in [Bug 1085023] + + * generic/tclTimer.c (TclCreateAbsoluteTimerHandler): New internal + function that allows setting a timer handler that will be + triggered at (or after) a specific time instead of at some number + of milliseconds in the future. This is a candidate for future + exposure via a TIP. + +2004-12-15 Miguel Sofer + + * generic/tclBasic.c: + * generic/tclExecute.c: + * generic/tclInt.decls: + * generic/tclIntDecls.h: + * generic/tclNamesp.c: + * generic/tclProc.c: + * generic/tclStubInit.c: + * generic/tclTest.c: Added two new functions to allocate memory + from the execution stack (TclStackAlloc, TclStackFree). Added + functions TclPushStackFrame and TclPopStackFrame that do the work + of Tcl_PushCallFrame and Tcl_PopCallFrame, but using frames + allocated in the execution stack - i.e., heap instead of + C-stack. The core uses these two new functions exclusively; the + old ones remain for backwards compat, as at least two popular + extensions (itcl, xotcl) are known to use them. + +2004-12-14 Miguel Sofer + + * generic/tclCmdIL.c: + * generic/tclInt.h: + * generic/tclProc.c: + * generic/tclVar.c: changing the isProcCallFrame field of the + CallFrame struct from a 0/1 field to flags. Should be perfectly + backwards compatible. + +2004-12-14 Don Porter + + * unix/configure.in: Added special processing to remove "$U" + from libraries in the LIBOBJS value. This is an auto-make-ism + we need to avoid. [Bug 1081541] + + * unix/configure: autoconf-2.57 + +2004-12-13 Don Porter + + * generic/tcl.h: Restored extern "C" guards so that C++ code + sees function pointer typedef linkage consistent with earlier Tcl + releases. [Bug 1082349]. + + * generic/tclEncoding.c: Plugged some memory leaks. Thanks to + * generic/tclUtil.c: Rolf Ade for reports and testing [Bug 1083082] + +2004-12-13 Kevin B. Kenny + + * doc/clock.n: Clarify that the [clock scan] command does not + accept the full range of ISO8601 point-in-time formats + [Bug 1075433]. + +2004-12-12 Miguel Sofer + + * generic/tclVar.c (TclArrayObjCmd - ARRAY_NAMES): leaking an + object [Bug 1084111] - thanks to Rolf Ade. + +2004-12-12 Miguel Sofer + + * generic/tclObj.c (TclSetCmdNameObj): special handling for fully + qualified command names (as in fix [Patch 456668]). + +2004-12-11 Miguel Sofer + + * generic/tclInt.h: + * generic/tclNamesp.c: converting the static function + GetNamespaceFromObj() to MODULE_SCOPE TclGetNamespaceFromObj(). + +2004-12-10 Donal K. Fellows + + * tools/tcl.wse.in, unix/tcl.spec, win/README.binary, README: + * win/configure.in, unix/configure.in, generic/tcl.h: + Bumped version number to 8.5a3 to distinguish HEAD of CVS + development from the recent 8.5a2 release. + +2004-12-10 Miguel Sofer + + * generic/tclCompile.c (TclInitCompiledLocals): + * generic/tclCompile.h: + * generic/tclInt.h: + * generic/tclProc.c (TclObjInterpProc, TclCreateProc): optimised + loops that initialise a proc's arguments and compiled local + variables, removing tests from inner loops. + +2004-12-10 Donal K. Fellows + + * generic/tclInt.h: Move ensemble API decls here from tclNamesp.c + +2004-12-09 Donal K. Fellows + + * generic/tclNamesp.c (TclMakeEnsembleCmd, TclSetEnsemble*) + (TclSetEnsemble*, TclFindEnsemble): Build an internal API for + creating and manipulating ensembles; they can be deleted using the + normal command-deletion API. + + * doc/Async.3: Reword for better grammar, better nroff and get the + flag name right. (Reported by David Welton.) + +2004-12-07 Don Porter + + * tests/unixInit.test (2.1-4): Added constraints so that when a + value of TCL_LIBRARY is required for process initialization, we skip + the tests that mess with that value. + +2004-12-07 Donal K. Fellows + + *** 8.5a2 TAGGED FOR RELEASE *** + + * unix/Makefile.in: add library/{tzdata,msgs} to dist target (kbk) + + * doc/foreach.n: Adjust tabs to be friendlier to some HTML + converters. [Bug 1078760] + +2004-12-06 Jeff Hobbs + + * unix/tclUnixNotfy.c (NotifierThreadProc): init numFdBits + [Bug 1079286] + + * doc/error.n, doc/SaveResult.3, doc/Thread.3: minor nroff typos + +2004-12-06 Don Porter + + * tests/safe.test: Trim auto_path to improve performance [1080039] + + * tests/msgcat.test: makeFile/removeFile cleanup [1079117] + +2004-12-04 Don Porter + + * generic/tclEncoding.c: Different fix for [Bug 1077005]. + * generic/tclEvent.c: Broke apart TclpSetInitialEncodings() on + * generic/tclInt.h: Windows into TclpSetInterfaces(), that is + * unix/tclUnixInit.c: fundamentally essential, and the initialization + * win/tclWinInit.c: of the system encoding, which is not. Made + the TclpSetInterfaces call part of TclInitSubsystems so it cannot be + overlooked. + +2004-12-03 Jeff Hobbs + + * changes: updated for 8.5a2 release + +2004-12-02 Don Porter + + * generic/tclUtil.c (TclSetProcessGlobalValue): Handle the case + where a ProcessGlobalValue might be assigned to itself. + + * generic/tclEncoding.c (MakeFileMap): Correct refcounting errors + managing values returned by TclPathPart (with refCount of 1!) that + led to a memory leak. [Bug 1077474]. + +2004-12-02 Vince Darley + + * generic/tclPathObj.c: fix and new tests for [Bug 1074671] to + * tests/fileSystem.test: ensure tilde paths are not returned + specially by 'glob'. + +2004-12-02 Kevin B. Kenny + + * win/Makefile.in: Added a 'sed' in the setting of ROOT_DIR_NATIVE + to compensate for a bug in cygpath (at least version 1.36) that + leaves a trailing backslash on the end of the converted path. + 2004-12-02 Donal K. Fellows * generic/tclInterp.c (Alias,Target,Master): Rewrote these so that the aliases that refer to an interpreter are stored in a list and not a hashtable (which was only ever a convenience, and forced the use of a global mutex to generate keys!) [FRQ 1077210] * generic/tclNamesp.c (numNsCreated): Moved into thread-local storage to remove a global mutex. [FRQ 1077210] -2004-12-01 Don Porter +2004-12-01 Don Porter * generic/tclUtil.c (TclGetProcessGlobalValue): Narrowed the scope of mutex locks. * generic/tclUtil.c: Updated Tcl_GetNameOfExecutable() to @@ -46,11 +3289,11 @@ * tests/winDde.test: Rewritten to use tcltest2 features more thoroughly (reducing the [catch] count!) and fix the problem with winDde-6.1 being out of synch with the implementation. -2004-11-30 Don Porter +2004-11-30 Don Porter * library/init.tcl ([unknown]): Restored the save/restore of the variables ::errorCode and ::errorInfo. This is needed when the [::bgerror] command is auto-loaded (as it is by Tk). @@ -58,11 +3301,11 @@ startup/initialization of the Tcl library, focused on the activities of Tcl_FindExecutable(). * generic/tclIO.c: Removed bogus claim in comment that encoding "iso8859-1" is "built-in" to Tcl. - + * generic/tclInt.h: Created a new struct ProcessGlobalValue, * generic/tclUtil.c: routines Tcl(Get|Set)ProcessGlobalValue, and function type TclInitProcessGlobalValueProc. Together, these take care of the housekeeping for "values" (things that can be held in a Tcl_Obj) that are global across a whole process. That is, @@ -79,25 +3322,25 @@ Converted Tcl(Get|Set)LibraryPath to use a ProcessGlobalValue, and moved them to tclEncoding.c. * generic/tclBasic.c: Updated caller. * generic/tclInt.h: TclpFindExecutable now returns void. - * unix/tclUnixFile.c: + * unix/tclUnixFile.c: * win/tclWinFile.c: * win/tclWinPipe.c: * generic/tclEncoding.c: Built new encoding search initialization on a foundation of ProcessGlobalValues, exposing new routines - Tcl(Get|Set)EncodingSearchPath. A cache of a map from encoding name + Tcl(Get|Set)EncodingSearchPath. A cache of a map from encoding name to directory pathname keeps track of where encodings are available for loading. Tcl_FindExecutable greatly simplified into just three function calls. The "library path" is now misnamed, as its only remaining purpose is as a foundation for the default encoding search path. * generic/tclInterp.c: Inlined the initScript that is evaluated - by Tcl_Init(). Added verification after initScript evaluation + by Tcl_Init(). Added verification after initScript evaluation that Tcl can find its installed *.enc files, and that it has initialized [encoding system] in agreement with what the environment expects. [tclInit] no longer driven by the value of $::tcl_libPath; it largely constructs its own search path now, rather than attempt to share one with the encoding system. @@ -112,20 +3355,20 @@ * unix/tclUnixTest.c: Update implementations of [testfindexecutable], [testgetdefenc], and [testsetdefenc]. * tests/unixInit.test: Corrected tests to operate properly even when a value of TCL_LIBRARY is required to find encodings. - + * generic/tclInt.decls: New internal stubs: TclGetEncodingSearchPath, TclSetEncodingSearchPath, TclpGetEncodingNameFromEnvironment. These are candidates for public exposure by future TIPs. * generic/tclIntDecls.h: make genstubs * generic/tclStubInit.c: - + * generic/tclTest.c: Updated [testencoding] to use - * tests/encoding.test: Tcl(Get|Set)EncodingSearchPath. Updated tests. + * tests/encoding.test: Tcl(Get|Set)EncodingSearchPath. Updated tests. 2004-11-30 Kevin B. Kenny * library/clock.tcl: Corrected the regular expressions that match a time zone to allow for time zones specified as +HH or -HH. @@ -132,11 +3375,11 @@ * tests/clock.test: Added regression test case for the above issue. Thanks to Rolf Ade for reporting this issue [http://wiki.tcl.tk/13094] * win/tclWinDde.c (Tcl_DdeObjCmd): Corrected a typo that caused a compilation failure on VC++. - + 2004-11-29 Andreas Kupries * win/Makefile.in (install-libraries): Brought entry '2004-10-26 Don Porter (Tcl Modules)' into the windows world, actually the win/configure buildsystem. The other windows buildsystems (.vc, @@ -151,14 +3394,14 @@ unknown if the other changes to this file actually pass the testsuite. Running testsuite ... They don't. winDde-6.1 fails. This is only a message discrepance, i.e. not too bad. Leaving resolution of that to Pat and Donal. -2004-11-26 Don Porter +2004-11-26 Don Porter - * library/auto.tcl (tcl_findLibrary): Made sure the uniquifying - operations on the search path does not also normalize. [Bug 1072136] + * library/auto.tcl (tcl_findLibrary): Made sure the uniquifying + operations on the search path does not also normalize. [Bug 1072136] 2004-11-26 Donal K. Fellows * unix/configure.in: Simplify the code to check for correctness of strstr, strtoul and strtod. @@ -180,11 +3423,11 @@ 2004-11-25 Reinhard Max * tests/tcltest.test: The order in which [glob] returns the file names is undefined, so tests should not depend on it. - + 2004-11-25 Zoran Vasiljevic * doc/Thread.3: * doc/Notifier.3: Added changes from the core-8-4-branch @@ -213,15 +3456,15 @@ FD_ZERO macros rather than bit-whacking that failed under Solaris-Sparc-64. [Bug 1071807] * win/tclWinInit.c (TclpInitLibraryPath): Removed unused vars 'pathc' and 'pathv' that caused compilation problems on VC++ with --enable-symbols. - -2004-11-24 Don Porter + +2004-11-24 Don Porter * unix/tcl.m4 (SC_ENABLE_THREADS): Corrected failure to determine - the number of arguments for readdir_r on SunOS systems. [Bug 1071701] + the number of arguments for readdir_r on SunOS systems. [Bug 1071701] * unix/configure: autoconf-2.57 * generic/tclCmdIL.c (InfoVarsCmd): Corrected segfault in new * tests/info.test (info-19.6): trivial matching branch [Bug 1072654] @@ -258,15 +3501,15 @@ exists under IRIX 5.3. * unix/tclUnixThrd.c (TclpReaddir): Use either 2 arg or 3 arg version of readdir_r. [Bug 1001325] -2004-11-22 Don Porter +2004-11-22 Don Porter * unix/tclUnixInit.c (TclpInitLibraryPath): Purged dead code that * win/tclWinInit.c (TclpInitLibraryPath): used to extend the - "library path". Search path construction for init.tcl is now done + "library path". Search path construction for init.tcl is now done within the [tclInit] proc. * generic/tclInterp.c: Restored several directories to the search * tests/unixInit.test: path used to locate init.tcl within [tclInit]. This change does not restore any directories to the encoding search @@ -278,16 +3521,16 @@ * generic/tclPathObj.c: fix and new test for [Bug 1043129] in * tests/fileSystem.test: the treatment of backslashes in file join on Windows. -2004-11-21 Don Porter +2004-11-21 Don Porter * doc/AddErrInfo.3: Typo corrections (Thanks Daniel South). * doc/interp.n: -2004-11-19 Don Porter +2004-11-19 Don Porter * doc/AddErrInfo.3: Docs for Tcl_(Get|Set)ReturnOptions. [TIP 227] * doc/AddErrInfo.3: * doc/Async.3: Documentation updates to replace references @@ -307,20 +3550,20 @@ * tests/unixInit.test: Removed "knownBug" constraints to prompt bug fixing before 8.5a2 release. 2004-11-19 Daniel Steffen - * macosx/Makefile: - * unix/configure.in: + * macosx/Makefile: + * unix/configure.in: * unix/tclUnixInit.c (MacOSXGetLibraryPath): changed detection of tcl framework build when determining tclLibPath from overloaded TCL_LIBRARY to configuration define TCL_FRAMEWORK. [Bug 1068088] * unix/configure: autoconf-2.57 * unix/tclConfig.h.in: autoheader-2.57 -2004-11-18 Don Porter +2004-11-18 Don Porter * doc/SaveResult.3: Documentation for Tcl_*InterpState (TIP 226). * generic/tclEvent.c (HandleBgErrors): Simplified program flow. @@ -334,46 +3577,46 @@ * generic/tclInterp.c: Corrected [interp bgerror] error messages. 2004-11-18 Reinhard Max * unix/tcl.m4 (SC_CONFIG_MANPAGES): Applied an improved version of - * unix/configure.in: patch #996085, that introduces - * unix/Makefile.in: --enable-man-suffix. - - * unix/installManPage: added - * unix/mkLinks.tcl: removed - * unix/mkLinks: removed - * unix/configure: generated - - * unix/Makefile.in: Don't install tclConfig.h . - -2004-11-17 Don Porter + * unix/configure.in: patch #996085, that introduces + * unix/Makefile.in: --enable-man-suffix. + + * unix/installManPage: added + * unix/mkLinks.tcl: removed + * unix/mkLinks: removed + * unix/configure: generated + + * unix/Makefile.in: Don't install tclConfig.h . + +2004-11-17 Don Porter * unix/configure.in: The change below reveals that the public data type Tcl_StatBuf relies on config information. For now, disabled the use of the tclConfig.h file until its full impact on Tcl's interface can be assessed. * unix/configure: autoconf-2.57 * generic/tcl.h: Moved the #include "tclConfig.h" out of - * generic/tclInt.h: tcl.h. The config settings are not part of + * generic/tclInt.h: tcl.h. The config settings are not part of * generic/tclPort.: the public interface, and having it there breaks compiled against uninstalled Tcl and extensions using autoconf-2.5*. -2004-11-16 Jeff Hobbs +2004-11-16 Jeff Hobbs * unix/tclUnixChan.c (TtySetOptionProc): fixed crash configuring -ttycontrol on a channel. [Bug 1067708] -2004-11-16 Don Porter +2004-11-16 Don Porter * generic/tclIOUtil.c (TclFSEpochOk): There were two code paths via which the thread copy of filesystemEpoch could be synched with the master copy, but only one kept the filesystem list cache up - to date. Fix routes everything through a single code path. + to date. Fix routes everything through a single code path. [Bug 1035775]. 2004-11-16 Donal K. Fellows * unix/tcl.m4 (SC_CONFIG_CFLAGS): Stop architecture flags to 'ld' @@ -384,36 +3627,36 @@ * generic/tcl.h: * unix/configure.in: changed HAVE_CONFIG_H to HAVE_TCL_CONFIG_H. * unix/configure: autoconf-2.57 -2004-11-15 Don Porter +2004-11-15 Don Porter * generic/tclInt.h: Added comment warning that the old ERR_IN_PROGRESS and ERROR_CODE_SET flag values should not be re-used for the sake of those extensions that have accessed them. * generic/tclCmdMZ.c (Tcl_TraceObjCmd): Fixed Bug 1065378 which failed - * tests/trace.test (trace-33.1): to permit a variable trace + * tests/trace.test (trace-33.1): to permit a variable trace created with [trace variable] to be destroyed with [trace remove]. Thanks to Keith Vetter for the report. 2004-11-15 Donal K. Fellows * doc/tclvars.n: Added section to documentation on global variables that are specific to tclsh and wish. [Patch 1065732] -2004-11-12 Jeff Hobbs +2004-11-12 Jeff Hobbs * generic/tclEncoding.c (TableFromUtfProc): correct crash condition when TCL_UTF_MAX == 6. [Bug 1004065] 2004-11-12 Donal K. Fellows * doc/interp.n: Basic documentation of the TIP#221 API. -2004-11-12 Don Porter +2004-11-12 Don Porter TIP #221 IMPLEMENTATION * generic/tclBasic.c: Define [::tcl::Bgerror] in new interps. * generic/tclEvent.c: Update Tcl_BackgroundError to make use of the registered [interp bgerror] command. @@ -421,11 +3664,11 @@ * tests/interp.test: syntax tests updated. TIP #226 IMPLEMENTATION * generic/tcl.decls: Stubs for Tcl_(Save|Restore|Discard)InterpState * generic/tcl.h: New public opaque type, Tcl_InterpState. - * generic/tclInt.h: Drop old private declarations. Add + * generic/tclInt.h: Drop old private declarations. Add Tcl(Get|Set)BgErrorHandler * generic/tclResult.c: Tcl_*InterpState implementations. * generic/tclDictObj.c: Update callers. * generic/tclIOGT.c: * generic/tclTrace.c: @@ -450,11 +3693,11 @@ 2004-11-12 Daniel Steffen * generic/tcl.h: * generic/tclInt.h: * unix/Makefile.in: include tclConfig.h from tcl.h and install it - as a public header. Normalized compiler include path order to + as a public header. Normalized compiler include path order to -I${BUILD_DIR} -I${UNIX_DIR} -I${GENERIC_DIR}. * unix/dltest/Makefile.in: add ${BUILD_DIR}/.. to include path to pick up tclConfig.h. @@ -469,11 +3712,11 @@ * unix/Makefile.in: Completed support for config header, * unix/configure.in: fixed building outside of the unix dir, * unix/tclAppinit.c: and reflected the name change of config.h. * generic/tclInt.h: - * unix/configure: generated + * unix/configure: generated 2004-11-12 Donal K. Fellows * unix/config.h.in: Allow configure to put all the C #defs into * unix/configure.in: a file (called config.h) so that Unix builds @@ -571,11 +3814,11 @@ tests have much more meaningful content. * tests/tm.test (genpaths): Add a [file normalize] so we pick up Windows drive letters, etc. [Bug 1053568] -2004-11-04 Don Porter +2004-11-04 Don Porter * changes: Updates toward an 8.5a2 release. 2004-11-03 Kevin B. Kenny @@ -604,11 +3847,11 @@ extrainious reset from tclWinPort.h. [Patch 1055668] * generic/tclCompile.h: Removed extrainious reset of TCL_STORAGE_CLASS missed in my last edit. -2004-11-03 Don Porter +2004-11-03 Don Porter * library/init.tcl ([unknown]): Corrections to the 2004-10-25 mods to Aunt ??? in [unknown]. Flaws revealed by Itcl test suite, which still apparently relies on this brokenness. Also added comment suggesting the error message that any code using this hack *ought* @@ -626,18 +3869,18 @@ the #define of MODULE_SCOPE. About the only time it would be problem is when someone is statically linking to Tcl and accessing internals from a C++ file and has name mangling issues from the lack of "C" after 'extern' [Patch 1055668]. * generic/tclCompile.h: Exchanged use of the EXTERN macro to the - new MODULE_SCOPE macro. Lowered exported internals count by 35. + new MODULE_SCOPE macro. Lowered exported internals count by 35. [Patch 1055668] * win/tclWinInt.h: * win/tclWinPort.h: exported internals dropped by a count of 14. * generic/tclFileSystem.h: Added use of MODULE_SCOPE on protos. * generic/tclRegexp.h: manipulating TCL_STORAGE_CLASS unnecessary. -2004-11-02 Don Porter +2004-11-02 Don Porter * library/tcltest/tcltest.tcl: Corrected some misleading * tests/tcltest.test (tcltest-26.1,2): displays of ::errorInfo and ::errorCode information when the -setup, -body, and/or -cleanup scripts return an unexpected return code. Thanks to Robert Seeger for the @@ -646,22 +3889,22 @@ 2004-11-02 Donal K. Fellows * generic/tclExecute.c (TclExecuteByteCode): Improved version of the NaN fix from Miguel Sofer. [Bug 761471] -2004-11-02 Kevin Kenny +2004-11-02 Kevin Kenny * library/tzdata/America/Cuiaba: Change to DST rules for - * library/tzdata/America/Havana: autumn of 2004. + * library/tzdata/America/Havana: autumn of 2004. [ftp://elsie.nci.nih.gov/pub/tzdata2004g.tar.gz] * tools/tclZIC.tcl: Updated to be compatible with recent changes in library/clock.tcl. 2004-11-02 Vince Darley - * win/tclWinFile.c: Simplify TclpUtime to use Tcl_FSGetNativePath, + * win/tclWinFile.c: Simplify TclpUtime to use Tcl_FSGetNativePath, and add comments. 2004-11-02 Donal K. Fellows * generic/tclInt.h: Change uses of EXTERN to MODULE_SCOPE (defined @@ -700,24 +3943,24 @@ * tests/cmdAH.test (cmdAH-8.45): Removed broken test constraint. It didn't do what it was intended to do, and it implied the other correct constraint. [Bug 1053908] - * generic/tclCmdIL.c (InfoGlobalsCmd): + * generic/tclCmdIL.c (InfoGlobalsCmd): * tests/info.test (info-8.4): Strip leading global-namespace specifiers from the pattern argument. [Bug 1057461] -2004-10-30 Kevin Kenny +2004-10-30 Kevin Kenny * generic/clock.c: Replaced WIN32 macro with __WIN32__. - [Bug 1054357]. Thanks to David Gravereaux for the patch. + [Bug 1054357]. Thanks to David Gravereaux for the patch. * win/tclWinFile.c: Removed a long-standing bug that causes incorrect conversion between file time and UTC time if the file time is recorded in a different Daylight Saving Time status than the current one. [Bug 926106] -2004-10-29 Don Porter +2004-10-29 Don Porter * library/tcltest/tcltest.tcl: Correct reaction to errors in the obsolete processCmdLineArgsHook. [Bug 1055673] * library/tcltest/pkgIndex.tcl: Bump to tcltest 2.2.7 * unix/Makefile.in: @@ -736,11 +3979,11 @@ * tests/namespace.test (namespace-50.*): Tests of ensemble subcommand error message rewriting. * generic/tclProc.c (TclObjInterpProc): Make procedures implement their wrong-num-args message using Tcl_WrongNumArgs instead of something baked-at-home. - * generic/tclNamesp.c (TclIsEnsemble, NsEnsembleImplementationCmd): + * generic/tclNamesp.c (TclIsEnsemble, NsEnsembleImplementationCmd): Added test of ensemble-hood (available to rest of core) and made ensembles set up the rewriting for Tcl_WrongNumArgs to take advantage of. * generic/tclInt.h (Interp.ensembleRewrite): Extra fields. * generic/tclIndexObj.c (Tcl_WrongNumArgs): Add knowledge of what @@ -752,15 +3995,15 @@ 2004-10-28 Miguel Sofer * generic/tclExecute.c (INST_START_CMD): * tests/execute.test (execute-8.3): fix for execution stack - corruption [Bug 1055676]. Credit dgp for detective work and fix. + corruption [Bug 1055676]. Credit dgp for detective work and fix. -2004-10-27 Don Porter +2004-10-27 Don Porter - * tests/socket.test (socket-13.1): Balanced [makeFile] and + * tests/socket.test (socket-13.1): Balanced [makeFile] and [removeFile] commands. * tests/clock.test: Correct duplicate test names. * tests/namespace.test: * tests/string.test: @@ -806,11 +4049,11 @@ * library/tm.tcl: Even found bugs, these have been corrected. 2004-10-26 Kevin Kenny * tests/format.test (format-19.1): Additional regression test for - Bug 868489. + Bug 868489. 2004-10-27 Donal K. Fellows * doc/*.n: Many small general documentation fixes. @@ -826,14 +4069,14 @@ * library/tm.tcl (::tcl::tm::Defaults): Added a second [file dirname] around the location of the executable. This fixes [Tcl SF Bug 1038705]. Instable of a bogus "foo/bin/lib" we now have the correct "foo/lib" as a base path for modules. -2004-10-26 Don Porter +2004-10-26 Don Porter * generic/tclParse.c (Tcl_SubstObj): Fix for failed subst-12.3 test. - * tests/subst.test (subst-12.3-5): More tests for Bug 1036649. + * tests/subst.test (subst-12.3-5): More tests for Bug 1036649. * unix/Makefile.in (install-libraries): Updated the installation of the http, msgcat, and tcltest packages to install as Tcl Modules on Unix systems. Other platform Makefiles still need updating. [Patch 1054370] @@ -874,11 +4117,11 @@ namespace separators in it. [Bug 1047928] * tests/cmdAH.test (cmdAH-8.45): Simplify in the hope that the reasons for [Bug 1053908] will become clearer. -2004-10-25 Don Porter +2004-10-25 Don Porter * generic/tclExecute.c (IllegalExprOperandType,TclExecuteByteCode): Removed several DECACHE_INFO/CACHE_INFO pairs that are no longer needed for protection because routines like Tcl_SetErrorCode() and Tcl_AddErrorInfo() can no longer re-enter bytecode execution. @@ -896,11 +4139,11 @@ * generic/tclMain.c (Tcl_Main): Updated to make use of TclGetReturnOptions instead of ::errorInfo variable. * generic/tclInterp.c (tclInit): Bug fix. Access dict variables - with [dict get], not array syntax. + with [dict get], not array syntax. 2004-10-25 Donal K. Fellows * tests/tm.test: Rewrote the tests to actually perform syntax checks on the public API. Added a new test (currently failing) to @@ -911,15 +4154,15 @@ 2004-10-24 Miguel Sofer * generic/tclCmdIL.c: * generic/tclExecute.c: * generic/tclInt.h: - * generic/tclTrace.c: defined new macros to get/set the flags of + * generic/tclTrace.c: defined new macros to get/set the flags of variables. The only files that still access the flag values directly are tclCompCmds.c, tclCompile.c, tclProc.c and tclVar.c -2004-10-24 Don Porter +2004-10-24 Don Porter * generic/tclBasic.c (Tcl_LogCommandInfo,Tcl_AddObjErrorInfo): Shift the initialization of errorCode to NONE to more central location. @@ -952,11 +4195,11 @@ Thanks to Todd M. Helfter for finding these bugs. 2004-10-22 Donal K. Fellows - * generic/tclExecute.c (TclCompEvalObj, Tcl_ExprObj): + * generic/tclExecute.c (TclCompEvalObj, Tcl_ExprObj): * generic/tclProc.c (TclProcCompileProc): Always call object freeIntRepProc's in the same way. 2004-10-22 Miguel Sofer @@ -963,11 +4206,11 @@ * generic/tclVar.c: fixed bug in commit of 2004-07-23, which was causing a leak of Proc structures and failure of compile-12.1. Two lines were 'zombies' from the previous way localVarNames worked. Credit dgp for finding this. -2004-10-21 Don Porter +2004-10-21 Don Porter * generic/tclInt.h (Interp): * generic/tclBasic.c (Tcl_CreateInterp,Tcl_DeleteInterp): * generic/tclResult.c (GetKeys,ReleaseKeys,etc.): Moved the key values of the return options dictionary out of @@ -990,11 +4233,11 @@ * generic/tclBasic.c (Tcl_CreateInterp, Tcl_DeleteInterp): * generic/tclResult.c (TclTransferResult): Rework so that iPtr->returnOpts can be NULL when there are no special options. - * generic/tclResult.c (TclRestoreInterpState): Plug potential + * generic/tclResult.c (TclRestoreInterpState): Plug potential memory leak. 2004-10-21 Kevin B. Kenny * generic/tclBasic.c: Various changes to [clock format] that, @@ -1009,11 +4252,11 @@ and message catalogs. They used the installed tcl library directory, not the source library. Before it was installed. Switched to source lib dir. Thanks to Kevin for the help in figuring this out. -2004-10-20 Don Porter +2004-10-20 Don Porter * generic/tclThreadTest.c (ThreadEventProc): Corrected subtle bug where the returned (char *) from Tcl_GetStringResult(interp) continued to be used without copying or refcounting, while activity on the interp continued. That's not safe, and recent @@ -1023,11 +4266,11 @@ 2004-10-19 Donal K. Fellows * generic/tclDictObj.c (DictWithCmd): Make sure all paths (that are not themselves error paths) do not lose the result code. -2004-10-19 Don Porter +2004-10-19 Don Porter * generic/tclInt.h (Tcl*InterpState): New internal routines * generic/tclResult.c (Tcl*InterpState): TclSaveInterpState, TclRestoreInterpState, and TclDiscardInterpState are superior replacements for Tcl_(Save|Restore|Discard)Result. Intent is that @@ -1046,29 +4289,29 @@ * generic/tclFCmd.c (CopyRenameOneFile): Calls to Tcl_*Result that were eliminated because they appeared to serve no useful purpose, typically saving/restoring an error message, only to throw it away. -2004-10-18 Don Porter +2004-10-18 Don Porter * generic/tclBasic.c (Tcl_CreateInterp,Tcl_DeleteInterp): * generic/tclCmdAH.c (Tcl_CatchObjCmd): * generic/tclCmdMZ.c (TclMergeReturnOptions,TclProcessReturn): * generic/tclCompCmds.c (TclCompileReturnCmd): * generic/tclExecute.c (TclCompEvalObj): * generic/tclInt.h (Interp): * generic/tclProc.c (TclUpdateReturnInfo): Place primary storage of the -level and -code information in private - fields of the Interp struct, rather than in a DictObj. This should + fields of the Interp struct, rather than in a DictObj. This should significantly improve performance of TclUpdateReturnInfo. 2004-10-17 Miguel Sofer - * generic/tclResult.c: removed unused variable [Bug 1048588]. + * generic/tclResult.c: removed unused variable [Bug 1048588]. Thanks to Daniel South. -2004-10-15 Don Porter +2004-10-15 Don Porter * generic/tclCmdMZ.c (TclProcessReturn): Now that primary * generic/tclProc.c (TclUpdateReturnInfo): storage for the errorInfo and errorCode values are internal fields, we can set them at the time of the [return] command, and not have to wait @@ -1093,11 +4336,11 @@ Reworked management of the "errorInfo" data of an interp. That information is now primarily stored in a new private (Tcl_Obj *) field of the Interp struct, rather than using a global variable ::errorInfo as the primary storage. The ERR_IN_PROGRESS flag bit value is no longer required to manage - the value in its new location, and is removed. Variable traces + the value in its new location, and is removed. Variable traces are established to support compatibility for any code expecting the ::errorInfo variable to hold the information. ***POTENTIAL INCOMPATIBILITY*** Code that sets traces on the ::errorInfo variable may notice a @@ -1138,11 +4381,11 @@ * generic/tclParseExpr.c (GetLexeme): Parse the 'in' and 'ni' operators for TIP#201. * generic/tclDictObj.c (DictUpdateCmd,DictWithCmd): Core of implementation of TIP#212; docs and tests still to do... -2004-10-07 Don Porter +2004-10-07 Don Porter * generic/tclTest.c (TestsetobjerrorcodeCmd): Simplified. 2004-10-07 Vince Darley @@ -1153,11 +4396,11 @@ * unix/tclUnixFile.c: * win/tclWinFile.c: * tests/fileName.test: * tests/winFCmd.test: code reorganization for better generic/ platform code splitting [Bug 925620] removing the need for - several #ifdef's, and tests and fix for an unreported Windows + several #ifdef's, and tests and fix for an unreported Windows glob problem ('glob -dir C: -tails *'). 2004-10-07 Donal K. Fellows * *.3: Convert CONST to const and VOID to void so we document how @@ -1193,11 +4436,11 @@ * generic/tclCmdMZ.c (Tcl_SwitchObjCmd): Reorganized to have fewer magic flag variables and to separate the code that scans for a match from the code that processes a match body. -2004-10-06 Don Porter +2004-10-06 Don Porter * generic/tclBasic.c: * generic/tclBinary.c: * generic/tclCmdAH.c: * generic/tclCmdIL.c: @@ -1228,11 +4471,11 @@ * win/tclWinPipe.c: * win/tclWinReg.c: It is a poor practice to directly set or append to the value of the objResult of an interp, because that value might be shared, and in that circumstance a Tcl_Panic() will be the - result. Searched for example of this practice and replaced + result. Searched for example of this practice and replaced with safer alternatives, often using the Tcl_AppendResult() routine that dkf just rehabilitated. * library/dde/pkgIndex.tcl: Bump to dde 1.3.1 * library/reg/pkgIndex.tcl: Bump to registry 1.1.5 @@ -1243,11 +4486,11 @@ * generic/tclResult.c (Tcl_AppendResultVA): Make this work better with Tcl_Objs. [Patch 1041072] (Tcl_SetResult, Tcl_AppendElement): Change string to stringPtr to avoid C++ keywords. -2004-10-05 Don Porter +2004-10-05 Don Porter * generic/tclBasic.c (TclObjInvoke): More simplification of the TclObjInvoke routine toward unification with the rest of the evaluation stack. @@ -1264,11 +4507,11 @@ Reworked management of the "errorCode" data of an interp. That information is now primarily stored in a new private (Tcl_Obj *) field of the Interp struct, rather than using a global variable ::errorCode as the primary storage. The ERROR_CODE_SET flag bit value is no longer required to manage - the value in its new location, and is removed. Variable traces + the value in its new location, and is removed. Variable traces are established to support compatibility for any code expecting the ::errorCode variable to hold the information. ***POTENTIAL INCOMPATIBILITY*** Code that sets traces on the ::errorCode variable may notice a @@ -1289,11 +4532,11 @@ * generic/tclParseExpr.c (GetLexeme): Ensure that the 'eq' and 'ne' operators are followed by non-alphabetic characters so lexemes can't run together. [Bug 884830] * doc/DictObj.3, doc/dict.n: Clarified that a dictionary is not - order-preserving. [Bug 1032243] Also added another example to + order-preserving. [Bug 1032243] Also added another example to show off more ways of using a dictionary and a few other formatting improvements. 2004-10-02 Donal K. Fellows @@ -1302,22 +4545,22 @@ what everyone seems to actually expect of the API! [Bug 1037235] (Tcl_DictObjNext): Make calling this after Tcl_DictObjDone non-fatal as that simplifies a number of internal APIs. This doesn't break any existing working code as it is a case which previously caused a panic. -2004-10-02 Don Porter +2004-10-02 Don Porter * tests/namespace.test (namespace-8.7): Another test for save/restore of ::errorInfo and ::errorCode during global namespace teardown. 2004-10-01 Donal K. Fellows - * generic/tclProc.c (TclObjGetFrame, Tcl_UplevelObjCmd): + * generic/tclProc.c (TclObjGetFrame, Tcl_UplevelObjCmd): * generic/tclVar.c (Tcl_UpvarObjCmd): Cache stackframe level references in the level object for speed. -2004-09-30 Don Porter +2004-09-30 Don Porter * generic/tclBasic.c (Tcl_CreateInterp): Removed the flag bit value * generic/tclInt.h (Interp): EXPR_INITIALIZED. It was set during interp creation and never tested. Whatever purpose it had is in the past. @@ -1327,11 +4570,11 @@ * generic/tcLTest.c (TestevalexObjCmd): in the testing command * tests/parser.test (parse-9.2): [testevalex] and nothing in the test suite made use of the capability it enabled. * generic/tclBasic.c (Tcl_AddObjErrorInfo): More re-organization - * generic/tclCmdAH.c (Tcl_ErrorObjCmd): of the management of + * generic/tclCmdAH.c (Tcl_ErrorObjCmd): of the management of * generic/tclCmdMZ.c (TclProcessReturn): the errorCode value. * tests/error.test (error-6.4-9): * generic/tclNamespace.c (TclTeardownNamespace): Tcl_Obj-ified * tests/namespace.test (namespace-8.5,6): the save/restore @@ -1349,44 +4592,44 @@ 2004-09-30 Miguel Sofer * tests/subst.test (12.1-2): added tests for [Bug 1036649] -2004-09-29 Don Porter +2004-09-29 Don Porter * tests/basic.test (49.*): New tests for TCL_EVAL_GLOBAL. 2004-09-29 Donal K. Fellows - * generic/tclVar.c (TclObjLookupVar, TclObjLookupVar): - (TclObjUnsetVar2, SetArraySearchObj): - * generic/tclUtil.c (SetEndOffsetFromAny): - * generic/tclStringObj.c (Tcl_SetStringObj): - (Tcl_SetUnicodeObj, SetStringFromAny): - * generic/tclResult.c (ResetObjResult): - * generic/tclRegexp.c (Tcl_GetRegExpFromObj): - * generic/tclPathObj.c (TclFSMakePathRelative, SetFsPathFromAny): - (TclFSMakePathFromNormalized, Tcl_FSNewNativePath): - * generic/tclObj.c (TclFreeObj, Tcl_SetBooleanObj, SetBooleanFromAny): - (Tcl_SetDoubleObj, SetDoubleFromAny, Tcl_SetIntObj): - (SetIntOrWideFromAny, Tcl_SetLongObj, SetWideIntFromAny): - (Tcl_SetWideIntObj, TclSetCmdNameObj, SetCmdNameFromAny): - * generic/tclNamesp.c (SetNsNameFromAny, MakeCachedEnsembleCommand): - * generic/tclListObj.c (Tcl_SetListObj, SetListFromAny): - * generic/tclIndexObj.c (Tcl_GetIndexFromObjStruct): - * generic/tclDictObj.c (SetDictFromAny): - * generic/tclCompile.c (TclInitByteCodeObj): - * generic/tclBinary.c (Tcl_SetByteArrayObj, SetByteArrayFromAny): + * generic/tclVar.c (TclObjLookupVar, TclObjLookupVar): + (TclObjUnsetVar2, SetArraySearchObj): + * generic/tclUtil.c (SetEndOffsetFromAny): + * generic/tclStringObj.c (Tcl_SetStringObj): + (Tcl_SetUnicodeObj, SetStringFromAny): + * generic/tclResult.c (ResetObjResult): + * generic/tclRegexp.c (Tcl_GetRegExpFromObj): + * generic/tclPathObj.c (TclFSMakePathRelative, SetFsPathFromAny): + (TclFSMakePathFromNormalized, Tcl_FSNewNativePath): + * generic/tclObj.c (TclFreeObj, Tcl_SetBooleanObj, SetBooleanFromAny): + (Tcl_SetDoubleObj, SetDoubleFromAny, Tcl_SetIntObj): + (SetIntOrWideFromAny, Tcl_SetLongObj, SetWideIntFromAny): + (Tcl_SetWideIntObj, TclSetCmdNameObj, SetCmdNameFromAny): + * generic/tclNamesp.c (SetNsNameFromAny, MakeCachedEnsembleCommand): + * generic/tclListObj.c (Tcl_SetListObj, SetListFromAny): + * generic/tclIndexObj.c (Tcl_GetIndexFromObjStruct): + * generic/tclDictObj.c (SetDictFromAny): + * generic/tclCompile.c (TclInitByteCodeObj): + * generic/tclBinary.c (Tcl_SetByteArrayObj, SetByteArrayFromAny): * generic/tclInt.h (TclFreeIntRep): Factorize out deletion of object internal representation to a shared macro, so simplifying much code. 2004-09-27 Miguel Sofer * generic/tclBasic.c (TclObjInvoke): fix for bogus gcc warning about uninitialised variable. -2004-09-27 Don Porter +2004-09-27 Don Porter * generic/tclBasic.c: Removed internal routines TclInvoke, * generic/tclInt.decls: TclGlobalInvoke, TclObjInvokeGlobal and * tests/basic.test: the portion of TclObjInvoke that handles calls without TCL_INVOKE_HIDDEN enabled. None of this code is @@ -1413,21 +4656,21 @@ to treatment of a volume-relative pwd on Windows [Bug 1018980]. * doc/FileSystem.3: added missing Tcl_GlobTypeData documentation [Bug 935853] -2004-09-27 Kevin Kenny +2004-09-27 Kevin Kenny * compat/strftime.c (Removed): * generic/tclClock.c (removed TclClockOldscanObjCmd): * generic/tclDate.c (Regenerated): * generic/tclGetDate.y: * generic/tclInt.decls (removed TclGetDate and TclpStrftime): * generic/tclInt.h (removed TclGetDateInfo): * generic/tclIntDecls.h (Regenerated): * generic/tclStubInit.c (Regenerated): - * library/clock.tcl: + * library/clock.tcl: * unix/tclUnixTime.c (removed TclpStrftime): * win/Makefile.in: * win/makefile.bc: * win/makefile.bc: * win/tcl.dsp: @@ -1446,13 +4689,13 @@ eliminating any need for mutex protection around [clock scan]. Also, changed the Makefiles so that 'make gendate' is available on Windows as well as Unix. * generic/tclCmdAH.c (Tcl_FormatObjCmd): Removed some grubby - * generic/tclObj.c (SetBooleanFromAny): work-around code - that was needed only - because of Bug 868489. + * generic/tclObj.c (SetBooleanFromAny): work-around code + that was needed only + because of Bug 868489. * generic/tclBasic.c (TclObjInvoke): Removed three unused variables to silence a compiler warning in VC++. 2004-09-27 Vince Darley @@ -1471,21 +4714,21 @@ * tests/compExpr.test: * tests/expr.test: * tests/for.test: * tests/if.test: * tests/incr.test: - * tests/while.test: - Report compilation errors at runtime, [Patch 1033689] by dgp. + * tests/while.test: + Report compilation errors at runtime, [Patch 1033689] by dgp. 2004-09-23 Mo DeJong * unix/dltest/Makefile.in (clean): Fixup make clean rule so that it does not delete all files when SHLIB_SUFFIX is set to the empty string in a static build. [Bug 1016726] -2004-09-23 Don Porter +2004-09-23 Don Porter * generic/tclBasic.c: Corrections to the 2004-09-21 commit * generic/tclExecute.c: regarding ERR_ALREADY_LOGGED. That commit * generic/tclNamesp.c: caused Tk test send-10.7 to fail. Added * tests/namespace.test (25.7,8): tests in the Tcl test suite @@ -1493,11 +4736,11 @@ aid of Tk in the future. * generic/tclCmdAH.c (Tcl_ExprObjCmd): Simplified the TclObjCmdProc of [expr] with a call to Tcl_ConcatObj. -2004-09-22 Don Porter +2004-09-22 Don Porter * generic/tclCmdMZ.c (TclProcessReturn): Support the -errorline * generic/tclCompile.c (TclCompileScript): option to [return]. * tests/compile.test (16.23.*): Use that capability to defer reporting * tests/misc.test (1.2): of parse errors until runtime. @@ -1515,21 +4758,21 @@ ftp://elsie.nci.nih.gov/pub/tzdata2004d.tar.gz. (Changes to Asia/Jerusalem were in the comments only.) [Routine maintenance - no bug] Spanish-language description of the change at http://www.presidencia.gub.uy/decretos/2004091502.htm -2004-09-21 Don Porter +2004-09-21 Don Porter * generic/tclCompCmds.c: Tolerate [append] syntax errors * tests/appendComp.test (8.1): at compile time, and allow runtime to raise the error (or succeed if a redefined [append] allows). * generic/tclBasic.c: Reworked management of the interp * generic/tclCompile.c: flag ERR_ALREADY_LOGGED, to reduce * generic/tclExecute.c: its exposure. Still left several * generic/tclNamesp.c: references that are just too nice - on performace to do away with. These changes also resolve + on performace to do away with. These changes also resolve an inconsistency in the ::errorInfo values produced by [namespace eval x error foo bar] and [namespace eval x {error foo bar}]. * generic/tclExecute.c (TclCompEvalObj): Simplified @@ -1539,11 +4782,11 @@ 2004-09-21 Donal K. Fellows * doc/interp.n: Tighten up wording on how [interp eval] and [interp invokehidden] operate w.r.t. stack frames. [Bug 926590] -2004-09-20 Don Porter +2004-09-20 Don Porter * tests/error.test (error-6.2,3): Added more tests to verify ::errorCode setting by/after a [catch]. 2004-09-19 Miguel Sofer @@ -1563,29 +4806,29 @@ * doc/FileSystem.3, doc/OpenFileChnl.3: More documentation fixes from Mikhail Kolesnitchenko. [Patch 1022527] * doc/*: Standardize highlighting of symbols defined in tcl.h -2004-09-17 Don Porter +2004-09-17 Don Porter * generic/tclBasic.c (Tcl_AddObjErrorInfo, Tcl_LogCommandInfo): * generic/tclCmdAH.c ([catch], [error]): * generic/tclCmdMZ.c ([return]): * generic/tclProc.c (TclUpdateReturnInfo): * generic/tclResult.c (Tcl_SetErrorCodeVA, Tcl_SetObjErrorCode) - (TclTransferResult): Refactored so that all errorCode setting + (TclTransferResult): Refactored so that all errorCode setting flows through Tcl_SetObjErrorCode(). This greatly reduces the number of different places in the code that need to know details about an internal bitflag field of the Interp struct. Also places errorCode setting in one place for easier future mods. 2004-09-17 Kevin B.Kenny - * generic/tclDate.c: Revised tclGetDate.y to use bison instead + * generic/tclDate.c: Revised tclGetDate.y to use bison instead * generic/tclGetDate.y: of yacc to build the parser, eliminating - * generic/tclInt.h: all the complicated hackery involving - * unix/Makefile.in: 'sed' postprocessing. Rebuilt the parser. + * generic/tclInt.h: all the complicated hackery involving + * unix/Makefile.in: 'sed' postprocessing. Rebuilt the parser. 2004-09-14 Kevin B. Kenny * generic/tclClock.c (ClockOldscanObjCmd): Silenced a compiler warning (long passed as a param where unsigend long was @@ -1598,11 +4841,11 @@ 2004-09-10 Miguel Sofer * doc/interp.n: * generic/tclInterp.c (TclPreventAliasLoop, AliasCreate): * tests/interp.test (17.4-6, 19.3-4): fixing problems with - renaming of aliases [Bugs 707104 1026493]. Fix designed by dgp. + renaming of aliases [Bugs 707104 1026493]. Fix designed by dgp. 2004-09-13 Donal K. Fellows * generic/tclNamesp.c (NsEnsembleImplementationCmd): Add token field to internal rep of EnsembleCmdRep structure so that we can @@ -1642,21 +4885,21 @@ * generic/tcl.h: Micro formatting fixes. * generic/tclIOGT.c: Channel version fixed, must be 3, to have wideseekProc. Thanks to David Graveraux . -2004-09-11 Don Porter +2004-09-11 Don Porter * generic/tclNamespace.c (TclGetNamespaceForQualName): Resolved longstanding inconsistency in the treatment of the TCL_NAMESPACE_ONLY flag revealed by testing the 2004-09-09 commits against Itcl. TCL_NAMESPACE_ONLY now acts as specified in the pre-function comment, forcing resolution in the passed in context namespace. It has been incorrectly forcing resolution in the interp's current namespace. -2004-09-10 Kevin Kenny +2004-09-10 Kevin Kenny * library/clock.tcl: Fixed a bug where %z always put a plus sign on the time zone in :localtime. * tests/clock.test: Added test case for the above bug. @@ -1670,19 +4913,19 @@ 2004-09-09 David Gravereaux * win/tclWinConsole.c: Calls to WriteFile and WriteConsoleA changed to WriteConsole for simplicity. -2004-09-09 Don Porter +2004-09-09 Don Porter * generic/tclNamesp.c (Tcl_ForgetImport): Corrected faulty * tests/namespace.test: logic that relied exclusively on string matching and failed in the presence of [rename]s. [Bug 560297] Also corrected faulty prevention of [namespace import] cycles. [Bug 1017299] -2004-09-08 Don Porter +2004-09-08 Don Porter * generic/tclBasic.c (Tcl_CreateInterp): Removed obsolete field for storing the string-based command procedure of built-in commands. We no longer have any string-based built-in commands! @@ -1700,11 +4943,11 @@ allows dealing with issues where the C library has a different idea of DST conversion than Tcl. (Real fix would be to break TclGetDate into separate parser and time converter, and do the time conversion in clock.tcl. That's for another day.) Added regression test case for the bug where month was scanned - incorrectly in -timezone :localtime. [Bug 1023779] Added + incorrectly in -timezone :localtime. [Bug 1023779] Added regression test case for %k at the zero hour. 2004-09-07 David Gravereaux * win/makefile.vc: some quoting needed to be removed as it was @@ -1723,11 +4966,11 @@ in-memory time zone :UTC (and its aliases) always gets reinitialised, in case tzdata is absent. [Bug 1019537, 1023779] * library/tzdata/*: Regenerated. * tests/clock.test (clock-31.*, clock-39.1): Corrected a problem where the 'system' locale tests fail on a non-English Windows - machine. [Bug 1023761]. Added a test to make sure that alias + machine. [Bug 1023761]. Added a test to make sure that alias time zones load correctly. [Bug 1023779]. * tests/timer.test (timer-1.1, timer-2.1): Changed to (one hopes!) be more resilient on an overloaded system, if [after 200] sleeps for 300 ms or longer. * tools/tclZIC.tcl (writeLinks): Corrected a problem where @@ -1763,31 +5006,31 @@ 2004-09-02 Vince Darley * win/makefile.vc: clock.tcl needs to be installed. -2004-09-01 Jeff Hobbs +2004-09-01 Jeff Hobbs * win/tclWinReg.c (BroadcastValue): WIN64 cast corrections - * win/tclWinDde.c (DdeClientWindowProc): + * win/tclWinDde.c (DdeClientWindowProc): (DdeServicesOnAck, DdeEnumWindowsCallback): WIN64 corrections * win/tclWin32Dll.c (TclWinCPUID): need _asm for WIN64 (Itanium), until we have it, just return unknown. [Bug 1020445] 2004-09-01 Donal K. Fellows - * doc/regsub.n, doc/RegConfig.3, doc/Environment.3: + * doc/regsub.n, doc/RegConfig.3, doc/Environment.3: * doc/CrtChannel.3, doc/safe.n: Use correct abbreviations. 2004-08-31 Donal K. Fellows - * doc/trace.n, doc/socket.n, doc/registry.n, doc/pid.n: - * doc/namespace.n, doc/msgcat.n, doc/lsort.n, doc/lsearch.n: - * doc/linsert.n, doc/info.n, doc/http.n, doc/history.n: - * doc/format.n, doc/file.n, doc/exec.n, doc/dde.n, doc/clock.n: + * doc/trace.n, doc/socket.n, doc/registry.n, doc/pid.n: + * doc/namespace.n, doc/msgcat.n, doc/lsort.n, doc/lsearch.n: + * doc/linsert.n, doc/info.n, doc/http.n, doc/history.n: + * doc/format.n, doc/file.n, doc/exec.n, doc/dde.n, doc/clock.n: * doc/catch.n, doc/binary.n: More spelling and grammar fixes from Mikhail Kolesnitchenko. [Patch 1018486] 2004-08-31 Vince Darley @@ -1823,11 +5066,11 @@ * macosx/Makefile: add platform standard locations to default module path roots. [Patch 942881] * tests/env.test: macosx fixes. -2004-08-25 Don Porter +2004-08-25 Don Porter * tests/timer.test (timer-10.1): Test for Bug 1016167. * generic/tclTimer.c: Workaround for situation when a [namespace import] causes the objv[0] value to be something other than what Tcl_AfterObjCmd expects. [Bug 1016167]. @@ -1838,11 +5081,11 @@ ensemble command token to get the name of the ensemble for passing to the -unknown handler instead of relying on objv[0], which may contain useless info in the presence of [namespace import]. Problem found by Don Porter when investigating [Bug 1016167]. -2004-08-24 Don Porter +2004-08-24 Don Porter * generic/tclProc.c: The routine TclProcInterpProc was a * generic/tclTestProcBodyObj.c: specific instance of the general service already provided by TclObjInvokeProc. Removed TclProcInterpProc and TclGetInterpProc from the code... @@ -1853,11 +5096,11 @@ 2004-08-24 Donal K. Fellows * doc/string.n: Added clarifying note. -2004-08-23 Don Porter +2004-08-23 Don Porter * library/auto.tcl: Updated [tcl_findLibrary] search path to include any [::pkgconfig get scriptdir,runtime] directory, as well as the $::auto_path. [RFE 695441] @@ -1871,11 +5114,11 @@ 2004-08-19 Donal K. Fellows * generic/tclScan.c (Tcl_ScanObjCmd, ValidateFormat): Ensure that the %ld conversion works correctly on 64-bit platforms. [Bug 1011860] -2004-08-19 Kevin Kenny +2004-08-19 Kevin Kenny * library/clock.tcl (format): Changed default timezone format from alphabetic to numeric to produce scannable times in more locales. * tests/clock.test (clock-37.1): Removed now-unused 'needPST' @@ -1898,11 +5141,11 @@ TIP. * unix/mkLinks: Regenerated. * win/makefile.vc: Added tm.tcl to list of files to install. -2004-08-18 Kevin Kenny +2004-08-18 Kevin Kenny * tests/httpd (httpdRespond): Corrected an abuse of the [clock] command that caused test failures for some values of [clock clicks]. * doc/clock.n @@ -1962,11 +5205,11 @@ * generic/tclTest.c (TestseterrorcodeCmd): * generic/tclVar.c (TclPtrSetVar): * tests/result.test (result-4.*, result-5.*): [Bug 1008314] detected and fixed by dgp. -2004-08-13 Don Porter +2004-08-13 Don Porter * library/msgcat/msgcat.tcl: Added checks to prevent [mclocale] * tests/msgcat.test: from registering filesystem paths to possibly malicious code to be evaluated by a later [mcload]. @@ -1982,19 +5225,19 @@ epoch field cached in the subcommand. [Bug 989298] (NsEnsembleImplementationCmd): Plug a leak (thanks to Miguel Sofer for spotting it with valgrind) and reduce the number of goto labels to make the code clearer. -2004-08-02 Don Porter +2004-08-02 Don Porter * library/package.tcl (pkg_mkIndex): Updated [pkg_mkIndex] to make use of [glob -directory $dir -tails] and return options. TIP#207 IMPLEMENTATION * doc/interp.n: Added support for a -namespace option to the - * generic/tclBasic.c: [interp invokehidden] command. Also added an + * generic/tclBasic.c: [interp invokehidden] command. Also added an * generic/tclInt.h: internal routine TclObjInvokeNamespace() and * generic/tclInterp.c: corrected the flag names TCL_FIND_ONLY_NS and * generic/tclNamesp.c: TCL_CREATE_NS_IF_UNKNOWN that are passed to the * generic/tclTrace.c: internal routine TclGetNamespaceForQualName(). * tests/interp.test: [Patch 981841] @@ -2002,42 +5245,42 @@ * generic/tclLiteral.c (TclCleanupLiteralTable): Corrected * tests/compile.test (compile-12.4): flawed deletion of literal internal reps that could lead to accessing of freed memory. Thanks to Kevin Kenny for test case and fix [Bug 1001997]. -2004-07-30 Don Porter +2004-07-30 Don Porter - * tests/safe.test (safe-2.1): Disabled senseless test. [Bug 999612] + * tests/safe.test (safe-2.1): Disabled senseless test. [Bug 999612] - * library/auto.tcl (auto_reset): Removed "protected" list of commands + * library/auto.tcl (auto_reset): Removed "protected" list of commands from [auto_reset]. All entries in the auto_index can be re-loaded. * library/package.tcl: Updated comment to reflect 2004-07-28 commit. * generic/tclEvent.c (Tcl_Finalize): Re-organized Tcl_Finalize so that Tcl_ExitProc's that call Tcl_Finalize recursively do not - cause deadlock. [Patch 999084 fixes Tk Bug 714956] + cause deadlock. [Patch 999084 fixes Tk Bug 714956] 2004-07-30 Daniel Steffen * unix/configure: - * unix/tcl.m4 (SC_CONFIG_CFLAGS): Darwin: instead of setting PLAT_OBJS + * unix/tcl.m4 (SC_CONFIG_CFLAGS): Darwin: instead of setting PLAT_OBJS to explict object files in tcl.m4, refer to MAC_OSX_OBJS makefile var. * unix/Makefile.in: added MAC_OSX_OBJS variable. -2004-07-29 Don Porter +2004-07-29 Don Porter * library/package.tcl: [::pkg::create] is now an alias. Test safe-2.1 will now fail until Bug 999612 is corrected. -2004-07-28 Don Porter +2004-07-28 Don Porter * library/package.tcl: Moved private command * library/tclIndex: [pkg_compareExtension] into ::tcl::Pkg. * tests/pkg_mkIndex.test: Also moved implementation of [::pkg::create] to [::tcl::Pkg::Create]. -2004-07-25 Pat Thoyts +2004-07-25 Pat Thoyts * tests/io.test: Make io-61.1 create file as binary to pass on Win32 2004-07-23 Miguel Sofer @@ -2044,24 +5287,24 @@ * generic/tclVar.c: simplify tclLocalVarNameType, removing the reference to the corresponding proc. The reference is now seen as unnecessary, and it may cause leaking circular references under some circumstances (see for example [Bug 994838]). -2004-07-22 Don Porter +2004-07-22 Don Porter * tests/eofchar.data (removed): Test io-61.1 now generates its own - * tests/io.test: file of test data as needed. + * tests/io.test: file of test data as needed. -2004-07-20 Jeff Hobbs +2004-07-20 Jeff Hobbs - * generic/tclEvent.c: Correct threaded obj allocator to - * generic/tclInt.h: fully cleanup on exit and allow for + * generic/tclEvent.c: Correct threaded obj allocator to + * generic/tclInt.h: fully cleanup on exit and allow for * generic/tclThreadAlloc.c: reinitialization. [Bug #736426] - * unix/tclUnixThrd.c: (mistachkin, kenny) + * unix/tclUnixThrd.c: (mistachkin, kenny) * win/tclWinThrd.c: -2004-07-21 Kevin Kenny +2004-07-21 Kevin Kenny * generic/tclBasic.c (DeleteInterpProc): * generic/tclLiteral.c (TclCleanupLiteralTable): * generic/tclInt.h: added a TclCleanupLiteralTable function, called from DeleteInterpProc, that frees internal representations @@ -2068,11 +5311,11 @@ of shared literals early when an interpreter is being deleted. This change corrects a number of memory mismanagement issues in the cases where the internal representation of one literal contains a reference to another, and avoids conditions such as resolved variable names referring to procedure and namespace - contexts that no longer exist. [Bug 994838] + contexts that no longer exist. [Bug 994838] 2004-07-20 Daniel Steffen * unix/Makefile.in: * win/Makefile.in: added 'install-private-headers' makefile target @@ -2088,11 +5331,11 @@ CFBundleOpenBundleResourceMap symbol, since it is only present in full CoreFoundation on Mac OS X and not in CFLite on pure Darwin. 2004-07-19 Zoran Vasiljevic - * win/tclwinThrd.c: redefined MASTER_LOCK to call + * win/tclwinThrd.c: redefined MASTER_LOCK to call TclpMasterLock. Fixes Bug #987967 2004-07-17 Vince Darley * generic/tclIOUtil.c: fix to rare 'cd' infinite loop in @@ -2102,11 +5345,11 @@ * doc/FileSystem.3: clarified documentation of posix error codes in 'remove directory' FS proc - 'EEXIST' is used to signify a non-empty directory error (bug reported against tclvfs). -2004-07-16 Jeff Hobbs +2004-07-16 Jeff Hobbs * unix/Makefile.in, unix/tcl.m4: move (C|LD)FLAGS after their * unix/configure.in, unix/configure: _DEFAULT to allow for env setting to override m4 switches. Move SC_MISSING_POSIX_HEADERS up and consolidate calls to limit redundancy in configure. @@ -2148,13 +5391,13 @@ Mistachkin's patch for [Tcl SF Bug 990453], closing leakage of mutexes. They were not destroyed properly upon finalization. 2004-07-15 Andreas Kupries - * generic/tclIO.h (CHANNEL_INCLOSE): New flag. Set in + * generic/tclIO.h (CHANNEL_INCLOSE): New flag. Set in * generic/tclIO.c (Tcl_UnregisterChannel): 'Tcl_Close' while the - * generic/tclIO.c (Tcl_Close): close callbacks are + * generic/tclIO.c (Tcl_Close): close callbacks are run. Checked in 'Tcl_Close' and 'Tcl_Unregister' to prevent recursive call of 'close' in the close-callbacks. This is a possible error made by implementors of virtual filesystems based on 'tclvfs', thinking that they have to close the channel in the close handler for the filesystem. @@ -2183,12 +5426,12 @@ 2004-07-15 Zoran Vasiljevic * generic/tclEvent.c (Tcl_Finalize): stuffed memory leak incurred by re-initializing of TSD slots after the last call to TclFinalizeThreadData (done from within Tcl_FinalizeThread()). - We basically just repeat the TclFinalizeThreadData() once more - before tearing down TSD keys in TclFinalizeSynchronization(). + We basically just repeat the TclFinalizeThreadData() once more + before tearing down TSD keys in TclFinalizeSynchronization(). There should be more elaborate mechanism in place for handling such issues, based on thread cleanup handlers registered on the OS level. Such change requires much more work and would also require TIP because some visible parts of Tcl API would have to be modified. In the meantime, this will do. @@ -2196,18 +5439,18 @@ * generic/tclNotify.c (TclFinalizeNotifier): Added conditional notifier finalization based on the fact that an TclInitNotifier has been called for the current thread. This fixes the Tcl Bug #770053 again. Hopefully this time w/o unwanted side-effects. -2004-07-15 Kevin Kenny +2004-07-15 Kevin Kenny * generic/tclLiteral.c (TclReleaseLiteral): Removed unused variable 'codePtr' to silence a message from VC++. 2004-07-15 Miguel Sofer - * generic/tclCompile.c (TclCompileScript): + * generic/tclCompile.c (TclCompileScript): * generic/tclLiteral.c (TclReleaseLiteral): fix for [Bug 467523], which resurfaced with the latest changes. The previous strategy was to have special code in TclReleaseLiteral to handle the self-references generated by empty scripts. The new approach avoids the self-reference altogether, by having empty scripts @@ -2235,11 +5478,11 @@ * generic/tclDictObj.c (Tcl_DictObjRemoveKeyList): Oops, forgot to delete value object when removing the hash entry. [Bug 989093 in part] 2004-07-11 Miguel Sofer - * generic/tclExecute.c (TEBC): fixed leak of expandNestList objs + * generic/tclExecute.c (TEBC): fixed leak of expandNestList objs when there is an error while an expansion is in progress (code added at checkForCatch). 2004-07-11 Vince Darley @@ -2246,11 +5489,11 @@ * generic/tclIOUtil.c: fix to 'cd' bug when vfs is active [Bug 986944 in tclvfs project] - this bug recently introduced by some threading fixes. Need to work out how to add tests for this. -2004-07-10 Kevin Kenny +2004-07-10 Kevin Kenny * tests/clock.test (clock-2.11): Changed the test so that it isn't an infinite loop when run under valgrind on a slow virtual machine. Thanks to Miguel Sofer for the bug report. Also put in code to restore env(LC_TIME) after tests complete, @@ -2266,43 +5509,43 @@ updating the dying literal table. * generic/tclLiteral.c (TclDeleteLiteralTable): with the above change to TclCleanupByteCode, this function now removes a single reference to the literal object and cleans up its own structures. -2004-07-08 Kevin Kenny +2004-07-08 Kevin Kenny * win/tclWinInit.c (AppendEnvironment): Silenced a compilation warning about a type mismatch. 2004-07-07 Miguel Sofer - * generic/tclCompile.c (TclCompileScript): fix for [Bug 458361]. + * generic/tclCompile.c (TclCompileScript): fix for [Bug 458361]. Single-word scripts are compiled with an unshared cmdName to avoid shimmering between bytecode and cmdName reps. -2004-07-07 Don Porter +2004-07-07 Don Porter * generic/tclCmdMZ.c (TclMergeReturnOptions): Simplified logic and - removed potential memory leak. [Bug 986257]. + removed potential memory leak. [Bug 986257]. 2004-07-07 Donal K. Fellows * tools/man2help2.tcl (setTabs, IPmacro): Added support for the more advanced *roff macros used in Tk's doc/bind.n * generic/tclObj.c (TclInitObjSubsystem): Declare all current object types. -2004-07-06 Don Porter +2004-07-06 Don Porter - * tests/cmdMZ.test (cmdMZ-return-2.17): Added a test that a word + * tests/cmdMZ.test (cmdMZ-return-2.17): Added a test that a word containing backslash-quoted value is treated correctly. * generic/tclCompile.c (TclWordKnownAtCompileTime): [Bug 986196] Corrected flaw above and the flaw that caused TCL_TOKEN_SIMPLE_WORDs to have their original word value copied ( "{a b}" ) rather than the - actual value ( "a b" ). Thanks to Kevin Kenny for report and tests. + actual value ( "a b" ). Thanks to Kevin Kenny for report and tests. 2004-07-06 Kevin B. Kenny * tests/cmdMZ.test (cmdMZ-return-2.15,cmdMZ-return-2.16): Added a test that a return code containing spaces is correctly @@ -2316,43 +5559,43 @@ 2004-07-05 Miguel Sofer * generic/tclBasic.c (DeleteInterpProc): fix for [Bug 983660], found by pspjuth. Tear down the global namespace before freeing the interp handle, to allow the bytecodes to free their non-shared - literals. + literals. * generic/tclLiteral.c (TclReleaseLiteral): moved special code for self-ref so that it is also used for non-shared literals. Possible bug found by inspection. 2004-07-03 Miguel Sofer * generic/tclExecute.c (ExprRoundFunc): * tests/expr-old.test (39.1): added support for wide integers to - round(); [Bug 908375], reported by Hemang Lavana. + round(); [Bug 908375], reported by Hemang Lavana. 2004-07-03 Miguel Sofer * generic/tclCompile.h: * generic/tclInt.decls: * generic/tclIntDecls.h: * generic/tclStubInit.c: Moved declaration of TclCompEvalObj() from tclCompile.h to the internal stubs table, for compiler - experimentation. + experimentation. -2004-07-02 Jeff Hobbs +2004-07-02 Jeff Hobbs * generic/regcomp.c (stid): correct minor pointer size error * generic/tclPipe.c (TclCreatePipeline): applied TIP #202 patch - * doc/exec.n, tests/exec.test: that adds 2>@1 as a + * doc/exec.n, tests/exec.test: that adds 2>@1 as a special case redirection of stderr to the result output. 2004-07-02 Kevin B. Kenny * tests/io.test: Changed several tests to run the event loop rather than just calling [update] periodically, avoiding - intermittent failures (usually in io-29.32) that stemmed from + intermittent failures (usually in io-29.32) that stemmed from unreaped processes on Windows. * tests/winPipe.test (winpipe-1.11): Fixed a bug that caused test to fail if the path name of the working directory contained whitespace [Bug 678430] @@ -2369,11 +5612,11 @@ getting missed in the future. * doc/Namespace.3, doc/load.n, doc/Limit.3: Typo fixes and remove duplicate documentation. [Bug 983146] -2004-06-30 Don Porter +2004-06-30 Don Porter * tests/fileSystem.test: Minor correction to new fileSystem-9.X tests so that they clean up temporary directories correctly. 2004-06-30 Vince Darley @@ -2390,14 +5633,14 @@ * doc/string.n, tests/string.test: Add 'wideinteger' to things * generic/tclCmdMZ.c (Tcl_StringObjCmd): that can be tested for with the [string is] subcommand. [Patch 940915, by Kevin Kenny] -2004-06-29 Don Porter +2004-06-29 Don Porter * win/tclWinInit.c: Corrected reference counting flaw in - recent changes. Thanks to Pat Thoyts. [Bug 981893]. + recent changes. Thanks to Pat Thoyts. [Bug 981893]. 2004-06-29 Vince Darley * win/tclWin32Dll.c: fix to compilation with VC++ 5.2 @@ -2409,11 +5652,11 @@ 2004-06-24 Donal K. Fellows * tests/unixNotfy.test: Modified constraints so that testing with a threaded tclsh (not tcltest) will not hang. -2004-06-23 Don Porter +2004-06-23 Don Porter * generic/tclThreadStorage.c: Corrected type casting errors that led to calculation of a negative index value, thus accesses outside the threadStorageCache array, thus memory corruption. Crash observed on Mac OS X platform. @@ -2436,11 +5679,11 @@ * win/rules.vc: * win/Makefile.in: Modified the unix, VC++, and Cygwin build systems * win/configure: to include the new "tclThreadStorage.c" and the new * win/tcl.m4: USE_THREAD_STORAGE define. -2004-06-23 Pat Thoyts +2004-06-23 Pat Thoyts * tests/io.test: Added -force to 18.1 and 18.2. This was failing on WinXP. * tests/winFCmd.test: Added a cleanup to winFCmd-16.11 to avoid a @@ -2462,16 +5705,16 @@ 2004-06-23 Donal K. Fellows * tests/*.test: Standardize use of platform constraints. - * unix/tclUnixInit.c (GetStackSize, TclpCheckStackSpace): + * unix/tclUnixInit.c (GetStackSize, TclpCheckStackSpace): * unix/tclUnixThrd.c (TclpThreadGetStackSize): Added code to check whether the C stack is about to be exceeded, from [Patch 746378] by Joe Mistachkin but with substantial revisions. -2004-06-22 Kevin Kenny +2004-06-22 Kevin Kenny * generic/tclEvent.c (NewThreadProc): Fixed broken build on Windows caused by missing TCL_THREAD_CREATE_RETURN. * tests/stack.test (stack-3.1): Corrected nuisance error in @@ -2512,11 +5755,11 @@ * generic/tclThreadAlloc.c (Ptr2Block): Rewrote so as to maximize the chance of detecting and reporting a memory inconsistency without relying on things being consistent. [Bug 975895] -2004-06-18 Don Porter +2004-06-18 Don Porter * tests/load.test: Relaxed strictness of error message matching for test load-2.3 so that it will pass on Mac OSX. * generic/tclEncoding.c: Static TclFindEncodings -> FindEncodings. @@ -2539,28 +5782,28 @@ 2004-06-18 Donal K. Fellows * unix/tclUnixInit.c (localeTable): Added some more locale to encoding mapping info from Jim Huang - * generic/tclInt.h (PendingObjData,TclFreeObjMacro,etc): + * generic/tclInt.h (PendingObjData,TclFreeObjMacro,etc): * generic/tclObj.c (TclFreeObj): Added scheme for making TclFreeObj() avoid blowing up the C stack when freeing up very large object trees. [Bug 886231] * win/tclWinInit.c (SetDefaultLibraryDir): Fix logic, simplify and add comments. -2004-06-17 Don Porter +2004-06-17 Don Porter * generic/tclObj.c: Added missing space in panic message. * win/tclWinInit.c: Inform [tclInit] about the default library - directory via the ::tclDefaultLibrary variable. This should correct + directory via the ::tclDefaultLibrary variable. This should correct a problem with my 2004-06-11 commit. Better solutions still in the - works. Thanks to Joe Mistachkin for pointing out the breakage. + works. Thanks to Joe Mistachkin for pointing out the breakage. -2004-06-16 Don Porter +2004-06-16 Don Porter * doc/library.n: Moved variables ::auto_oldpath and * library/auto.tcl: ::unknown_pending into ::tcl namespace. * library/init.tcl: [Bugs 808319, 948794] @@ -2567,24 +5810,24 @@ 2004-06-15 Donal K. Fellows * doc/binary.n: Added some notes to the documentation of the 'a' format to address the point raised in [RFE 768852]. -2004-06-15 Jeff Hobbs +2004-06-15 Jeff Hobbs * unix/tclConfig.sh.in (TCL_EXTRA_CFLAGS): set to @CFLAGS@, which is the configure-time CFLAGS. Addendum to m4 change on 2004-05-26. -2004-06-14 Kevin Kenny +2004-06-14 Kevin Kenny * win/Makefile.in: Corrected compilation flags for tclPkgConfig.c so that it doesn't require Stubs. * generic/tclBasic.c (Tcl_CreateInterp): Removed comment stating that TclInitEmbeddedConfigurationInformation needs Stubs; with the change above, the comment is now erroneous. -2004-06-11 Don Porter +2004-06-11 Don Porter * doc/Encoding.3: Removed bogus claims about tcl_libPath. * generic/tclInterp.c (Tcl_Init): Stopped setting the tcl_libPath variable. [tclInit] can get all its directories @@ -2620,11 +5863,11 @@ * generic/tclBasic.c (Tcl_CreateInterp): Moved call to TclInitEmbeddedConfigurationInformation() earlier in Tcl_CreateInterp() so that other parts of interp creation and initialization may access and use the config values. -2004-06-11 Kevin Kenny +2004-06-11 Kevin Kenny * win/tclAppInit.c: Restored the 'setargv' procedure when compiling with mingw. Apparently, the command line parsing in mingw doesn't work as well as that in vc++, and the result was (1) that winPipe-8.19 failed, and (2) that 'make test' would @@ -2631,46 +5874,46 @@ work at all only with TESTFLAGS='-singleproc 1'. [Bug 967195] 2004-06-10 Zoran Vasiljevic * generic/tclIOUtil.c: removed forceful setting of the - private cached current working directory rep from + private cached current working directory rep from within the Tcl_FSChdir(). We delegate this task to the Tcl_FSGetCwd() which does this task anyway. - The relevant code is still present but disabled + The relevant code is still present but disabled temporarily until the change proves correct. The Tcl test suite passes all test with the given change so I suppose it is good enough. -2004-06-10 Don Porter +2004-06-10 Don Porter * unix/tclUnixInit.c (TclpInitLibraryPath): Disabled addition of * win/tclWinInit.c (TclpInitLibraryPath): relative-to-executable - directories to the library search path. A first step in reform of + directories to the library search path. A first step in reform of Tcl's startup process. ***POTENTIAL INCOMPATIBILITY*** Attempts to directly run ./tclsh or ./tcltest out of a build directory will either fail, or will make use of an installed script library in preference to the one in the source tree. Use `make shell` or `make runtest` instead. - * tests/unixInit.test: Modified tests to suit above changes. + * tests/unixInit.test: Modified tests to suit above changes. * generic/tclPathObj.c: Corrected [file tail] results when operating on a path produced by TclNewFSPathObj(). [Bug 970529] 2004-06-09 Zoran Vasiljevic * generic/tclIOUtil.c: partially corrected [Bug 932314]. - Also, corrected return values of Tcl_FSChdir() to + Also, corrected return values of Tcl_FSChdir() to reflect those of the underlying platform-specific call. Originally, return codes were mixed with those of Tcl. 2004-06-08 Miguel Sofer - * generic/tclCompile.c: + * generic/tclCompile.c: * generic/tclExecute.c: handle warning [Bug 969066] 2004-06-08 Donal K. Fellows * generic/tclHash.c (RebuildTable): Move declaration of variable @@ -2690,27 +5933,27 @@ * generic/tclIntPlatDecls.h: so that any clock frequency * generic/tclPlatDecls.h: is accepted provided that * generic/tclStubInit.c: all CPU's in the system share * tests/platform.test (platform-1.3): a common chip, and hence, * win/tclWin32Dll.c (TclWinCPUID): presumably, a common clock. - * win/tclWinTest.c (TestwincpuidCmd) This change necessitated a - * win/tclWinTime.c (Tcl_GetTime): small burst of assembly code + * win/tclWinTest.c (TestwincpuidCmd) This change necessitated a + * win/tclWinTime.c (Tcl_GetTime): small burst of assembly code to read CPU ID information, which was added as TclWinCPUID in the - internal Stubs. To test this code in the common case of a + internal Stubs. To test this code in the common case of a single-processor machine, a 'testwincpuid' command was added to - tclWinTest.c, and a test case in platform.test. Thanks to Jeff + tclWinTest.c, and a test case in platform.test. Thanks to Jeff Godfrey and Richard Suchenwirth for reporting this bug. [Bug #976722] -2004-06-04 Don Porter +2004-06-04 Don Porter * generic/tcl.h: Restored #include to tcl.h, rejecting the "fix" for "Bug" 945570. Tcl_FSSeek() needs the values of SEEK_SET, etc. and too many extensions rely on tcl.h providing stdio.h for them. -2004-06-02 Jeff Hobbs +2004-06-02 Jeff Hobbs * win/tclWinFile.c (TclpFindExecutable): when using GetModuleFileNameA (Win9x), convert from CP_ACP to WCHAR then convert back to utf8. Adjunct to 2004-04-07 fix. @@ -2717,11 +5960,11 @@ 2004-06-02 David Gravereaux * tests/winPipe.test (winpipe-6.1): blocking set to 1 before closing to ensure we get an exitcode. The windows pipe channel driver doesn't differentiate between a blocking and non-blocking - close just yet, but will soon. Part of [Bug 947693] + close just yet, but will soon. Part of [Bug 947693] 2004-06-02 Vince Darley * doc/file.n: fix to documentation of 'file volumes' (Bug 962435) @@ -2755,11 +5998,11 @@ * doc/interp.n: Added note about what happens when a limited interpreter creates a slave interpreter. * doc/Limit.3: Added manual page for the resource limit subsystem's C API. [Bug 953903] -2004-05-29 Joe English +2004-05-29 Joe English * doc/global.n, doc/interp.n, doc/lrange.n: Fix minor markup errors. 2004-05-28 Donal K. Fellows @@ -2798,38 +6041,38 @@ The overall effect is to make building with gcc with the additional flags -Wstrict-prototypes -Wmissing-prototypes produce no increase in the total number of warnings (except for main(), which is undeclared for traditional reasons.) -2004-05-26 Jeff Hobbs +2004-05-26 Jeff Hobbs * unix/Makefile.in: Rework configure ordering to TCL_LINK_LIBS, - * unix/tcl.m4: ENABLE_SHARED, CONFIG_CFLAGS, & ENABLE_SYMBOLS + * unix/tcl.m4: ENABLE_SHARED, CONFIG_CFLAGS, & ENABLE_SYMBOLS * unix/configure: before TCL_EARLY_FLAGS and TCL_64BIT_FLAGS * unix/configure.in: (about 400 lines earlier) in configure.in. This forces CFLAGS configuration to be done before many tests, which is needed for 64-bit builds and may affect other builds. Also make CONFIG_CFLAGS append to CFLAGS directly instead of using EXTRA_CFLAGS, and have LDFLAGS append to any existing value. [Bug #874058] * unix/dltest/Makefile.in: change EXTRA_CFLAGS to DEFS -2004-05-26 Don Porter +2004-05-26 Don Porter * library/tcltest/tcltest.tcl: Correction to debug prints and testing * library/tcltest/pkgIndex.tcl: if TCLTEST_OPTIONS value. Corrected * tests/tcltest.test: double increment of numTestFiles in -singleproc 1 configurations. Updated tcltest-19.1 to tcltest 2.1 behavior. Corrected tcltest-25.3 to not falsely report a failure in tcltest.test. Bumped to tcltest 2.2.6. [Bugs 960560, 960926] -2004-05-25 Jeff Hobbs +2004-05-25 Jeff Hobbs * doc/http.n (http::config): add -urlencoding option (default utf-8) * library/http/http.tcl: that specifies encoding conversion of * library/http/pkgIndex.tcl: args for http::formatQuery. Previously - * tests/http.test: undefined, RFC 2718 says it should be + * tests/http.test: undefined, RFC 2718 says it should be utf-8. 'http::config -urlencoding {}' returns previous behavior, which will throw errors processing non-latin-1 chars. Bumped http package to 2.5.0. 2004-05-25 Donal K. Fellows @@ -2838,11 +6081,11 @@ deletion of script callback hash table entries to happen here so the entries are correctly removed at the right time. [Bug 960410] 2004-05-25 Miguel Sofer - * docs/global.n: added details for qualified variable names + * docs/global.n: added details for qualified variable names [Bug 959831] 2004-05-25 Miguel Sofer * generic/tclNamesp.c (Tcl_FindNamespaceVar): @@ -2858,20 +6101,20 @@ for existence. * tests/namespace.c (namespace-17.10): testing for interference between varname caching and name resolver. -2004-05-25 Kevin Kenny +2004-05-25 Kevin Kenny * tests/winFCmd.test: Correct test for the presence of a CD-ROM so - that it doesn't misdetect some other sort - of filesystem with a write-protected root as - being a CD-ROM drive. [Bug 918267] + that it doesn't misdetect some other sort + of filesystem with a write-protected root as + being a CD-ROM drive. [Bug 918267] -2004-05-25 Don Porter +2004-05-25 Don Porter - * tests/winPipe.test: Protect against path being set + * tests/winPipe.test: Protect against path being set * tests/unixInit.test: Unset path when done. * tests/unload.test (unload-3.1): Verify [pkgb_sub] does not exist. Delete interps when done. * tests/stringComp.test: stop re-use of string.test test names * tests/regexpComp.test: stop re-use of regexp.test test names @@ -2895,13 +6138,13 @@ * tests/fCmd.test: Rewrote tests that failed consistently on NFS so they either succeed (through slightly more liberal matching of the results) or are constrained to not run. [Bug 931312] * doc/bgerror.n: Use idiomatic open flags for working with log - files. [Bug 959602] + files. [Bug 959602] -2004-05-24 Jeff Hobbs +2004-05-24 Jeff Hobbs * generic/tclExecute.c (VerifyExprObjType): use GET_WIDE_OR_INT to properly have tclIntType used for smaller values. This corrects TclX bug 896727 and any other 3rd party extension that created math functions but was not yet WIDE_INT aware in them. @@ -2918,13 +6161,13 @@ 2004-05-23 Miguel Sofer * generic/tclNamesp.c (Tcl_FindNamespaceVar): [Bug 959052] fixed, insuring that no "zombie" variables are found. - * generic/tclVar.c (TclLookupSimpleVar): comments re [Bug 736729] + * generic/tclVar.c (TclLookupSimpleVar): comments re [Bug 736729] (predecessor of [Bug 959052]) removed. - * tests/namespace.test: added tests 17.10-12 + * tests/namespace.test: added tests 17.10-12 The patch modifies non-documented behaviour, and passes every test in the testsuite. However, scripts relying on the old behaviour may break. Note that the only behaviour change concerns the creative writing @@ -2932,18 +6175,18 @@ when neither a namespace variable nor a global variable by that name exists, as defined by [info vars]. The new behaviour is that the namespace resolution process deems a variable to exist exactly when [info vars] finds it - ie, either it has value, or else it was "fixed" by a call to [variable]. - Note: this patch was removed on 2002-05-25. + Note: this patch was removed on 2002-05-25. 2004-05-22 Miguel Sofer * generic/tclVar.c (TclObjLookupVar, TclObjUnsetVar2): fix for new (in tcl8.4) exteriorisations of [Bug 736729] due to the use of tclNsVarNameType obj types. Reenabling the use of this objType - ("VAR ref absolute" benchmark down to 66 ms, from 230). + ("VAR ref absolute" benchmark down to 66 ms, from 230). Added comments in TclLookupSimpleVar explaining my current understanding of [Bug 736729]. 2004-05-22 Miguel Sofer @@ -2952,11 +6195,11 @@ [Bug 736729]. 2004-05-21 Miguel Sofer * tests/namespace.test (namespace-41.3): removed the {knownBug} - constraint: [Bug 231259] is closed since nov 2001, and the fix of + constraint: [Bug 231259] is closed since nov 2001, and the fix of [Bug 729692] (INST_START_CMD) makes the test succeed. 2004-05-21 Donal K. Fellows * generic/tclExecute.c (TclExecuteByteCode): Move a few @@ -2973,13 +6216,13 @@ - it allows a better register allocation by the optimiser; under gcc3.3, this results in up to 10% runtime in some tests 2004-05-20 Donal K. Fellows - * generic/tclInterp.c (TclLimitRemoveAllHandlers): - * generic/tclBasic.c (DeleteInterpProc): - * tests/interp.test (interp-34.7): + * generic/tclInterp.c (TclLimitRemoveAllHandlers): + * generic/tclBasic.c (DeleteInterpProc): + * tests/interp.test (interp-34.7): Ensure that all limit callbacks are deleted when their interpreters are deleted. [Bug 956083] 2004-05-19 Kevin B. Kenny @@ -3001,35 +6244,35 @@ * tests/*.test: Many minor fixes, including ensuring that every test is run (so constraints control whether the test is doing anything) and making sure that constraints are always set using the API instead of poking around inside tcltest's internal - datastructures. Also got rid of all trailing whitespace lines + datastructures. Also got rid of all trailing whitespace lines from the test suite! 2004-05-19 Andreas Kupries * generic/tclIO.c: Fixed [SF Tcl Bug 943274]. This is the same problem * generic/tclIO.h: as [SF Tcl Bug 462317], see ChangeLog entry - 2001-09-26. The fix done at that time is incomplete. It - is possible to get around it if the actual read - operation is defered and not executed in the event - handler itself. Instead of tracking if we are in an - read caused by a synthesized fileevent we now track if - the OS has delivered a true event = actual data and - bypass the driver if a read finds that there is no - actual data waiting. The flag is cleared by a short or - full read. + 2001-09-26. The fix done at that time is incomplete. It + is possible to get around it if the actual read + operation is defered and not executed in the event + handler itself. Instead of tracking if we are in an + read caused by a synthesized fileevent we now track if + the OS has delivered a true event = actual data and + bypass the driver if a read finds that there is no + actual data waiting. The flag is cleared by a short or + full read. ***POTENTIAL INCOMPATIBILITY*** for channel drivers. 2004-05-17 Vince Darley * generic/tclPathObj.c: fix to (Bug 956063) in 'file dirname'. * tests/cmdAH.test: added test for this bug. - * doc/FileSystem.3: better documentation of refCount requirements + * doc/FileSystem.3: better documentation of refCount requirements of some FS functions (Bug 956126) 2004-05-19 Donal K. Fellows * generic/tclTest.c (TestgetintCmd): Made the tests in get.test check @@ -3124,32 +6367,32 @@ chance while in alpha as ... ***POTENTIAL INCOMPATIBILITY*** Scripts precompiled with ProComp under previous tcl8.5a versions may malfunction due to changed instruction numbers for - INST_LIST_INDEX_IMM, INST_LIST_RANGE_IMM and INST_START_CMD. + INST_LIST_INDEX_IMM, INST_LIST_RANGE_IMM and INST_START_CMD. 2004-05-14 Kevin B. Kenny - * generic/tclInt.decls: Promoted TclpLocaltime and TclpGmtime + * generic/tclInt.decls: Promoted TclpLocaltime and TclpGmtime * generic/tclIntDecls.h: from Unix-specific stubs to the generic * generic/tclIntPlatDecls.h: internal Stubs table. Reran 'genstubs' * generic/tclStubInit.c: * unix/tclUnixPort.h: * generic/tclClock.c: Changed a buggy 'GMT' timezone specification - to the correct 'GMT0'. [Bug #922848] + to the correct 'GMT0'. [Bug #922848] * unix/tclUnixThrd.c: Moved TclpGmtime and TclpLocaltime to - unix/tclUnixTime.c where they belong. + unix/tclUnixTime.c where they belong. * unix/tclUnixTime.c (TclpGmtime, TclpLocaltime, TclpGetTimeZone, - ThreadSafeGMTime [removed], - ThreadSafeLocalTime [removed], - SetTZIfNecessary, CleanupMemory): + ThreadSafeGMTime [removed], + ThreadSafeLocalTime [removed], + SetTZIfNecessary, CleanupMemory): Restructured to make sure that the same mutex protects - all calls to localtime, gmtime, and tzset. Added a check + all calls to localtime, gmtime, and tzset. Added a check in front of those calls to make sure that the TZ env var hasn't changed since the last call to tzset, and repeat tzset if necessary. [Bug #942078] Removed a buggy test of the Daylight Saving Time information in 'gettimeofday' in favor of applying 'localtime' to a known value. @@ -3171,14 +6414,14 @@ 2004-05-13 Donal K. Fellows TIP#143 IMPLEMENTATION - * generic/tclExecute.c (TclCompEvalObj, TclExecuteByteCode): + * generic/tclExecute.c (TclCompEvalObj, TclExecuteByteCode): * generic/tclBasic.c (TclEvalObjvInternal): Enable limit checking. * generic/tclInterp.c (Tcl_Limit*): Public limit API. - * generic/tcl.decls: + * generic/tcl.decls: * tests/interp.test: Basic tests of command limits. * doc/binary.n: TIP#129 IMPLEMENTATION [Patch 858211] * generic/tclBinary.c: Note that the test suite probably has many more * tests/binary.test: failures now due to alterations in constraints. @@ -3197,11 +6440,11 @@ * doc/split.n, doc/join.n: Updated examples and added more. 2004-05-11 Vince Darley - * doc/glob.n: documented behaviour of symbolic links with + * doc/glob.n: documented behaviour of symbolic links with 'glob -types d' (Bug 951489) 2004-05-11 Donal K. Fellows * doc/scan.n: Updated the examples to be clearer about their @@ -3222,11 +6465,11 @@ DOS application, the path priming does not need an ending space as BuildCommandLine() will do this for us. 2004-05-08 Vince Darley - * generic/tclFileName.c: + * generic/tclFileName.c: * generic/tclIOUtil.c: remove some compiler warnings on MacOS X. 2004-05-07 Chengye Mao * win/tclWinPipe.c: refixed bug 789040 re-entered in rev 1.41. @@ -3240,19 +6483,19 @@ * doc/unset.n: added upvar.n to the "see also" list 2004-05-07 Reinhard Max - * generic/tclEncoding.c: + * generic/tclEncoding.c: * tests/encoding.test: added support and tests for translating embedded null characters between real nullbytes and the internal representation on input/output (Bug #949905). 2004-05-07 Vince Darley - * generic/tclFileName.c: - * generic/tclIOUtil.c: + * generic/tclFileName.c: + * generic/tclIOUtil.c: * generic/tclFileSystem.h: * tests/fileSystem.test: fix for [Bug 943995], in which vfs- registered root volumes were not handled correctly as glob patterns in all circumstances. @@ -3268,15 +6511,15 @@ 2004-05-05 Donal K. Fellows * doc/break.n, doc/continue.n, doc/for.n, doc/while.n: More examples. -2004-05-05 Don Porter +2004-05-05 Don Porter * tests/unixInit.test (unixInit-2.10): Test correction for Mac OSX. - Be sure to consistently compare normalized path names. Thanks to - Steven Abner (tauvan). [Bug 948177] + Be sure to consistently compare normalized path names. Thanks to + Steven Abner (tauvan). [Bug 948177] 2004-05-05 Donal K. Fellows * doc/CrtObjCmd.3: Remove reference to Tcl_RenameCommand; there is no such API. [Bug 848440] @@ -3293,19 +6536,19 @@ conditions. * win/coffbase.txt: Added the tls extension to the list of preferred load addresses. -2004-05-04 Jeff Hobbs +2004-05-04 Jeff Hobbs * tests/fileSystem.test (filesystem-1.39): replace 'file volumes' * tests/fileName.test (filename-12.9,10): lindex with direct C:/ hard-coded because A:/ was being used and that is empty for most. * tests/winFCmd.test (winFCmd-16.12): test volumerelative $HOME -2004-05-04 Don Porter +2004-05-04 Don Porter * generic/tclAlloc.c: Make sure Tclp*Alloc* routines get * generic/tclInt.h: declared in the TCL_MEM_DEBUG and * generic/tclThreadAlloc.c: TCL_THREADS configuration. [Bug 947564] @@ -3336,17 +6579,17 @@ * generic/tclCompile.c: * generic/tclInt.h: reverted fix for [Bug 926445] of 2004-04-02, restoring TCL_ALIGN to the header file. Todd Helfter reported that the macro is required by tbcload. -2004-05-03 Kevin Kenny +2004-05-03 Kevin Kenny * win/tclWin32Dll.c (TclpCheckStackSpace): * tests/stack.test (stack-3.1): Fix for undetected stack overflow in TclReExec on Windows. [Bug 947070] -2004-05-03 Don Porter +2004-05-03 Don Porter * library/init.tcl: Corrected unique prefix matching of interactive command completion in [unknown]. [Bug 946952] 2004-05-02 Miguel Sofer @@ -3358,15 +6601,15 @@ 2004-04-30 Donal K. Fellows * doc/glob.n, doc/incr.n, doc/set.n: More examples. * doc/if.n, doc/rename.n, doc/time.n: -2004-04-30 Don Porter +2004-04-30 Don Porter * generic/tclInt.h: Replaced Kevin Kenny's temporary * generic/tclThreadAlloc.c: fix for Bug 945447 with a cleaner, - more permanent replacement. + more permanent replacement. 2004-04-30 Kevin B. Kenny * generic/tclThreadAlloc.c: Added a temporary (or so I hope!) inclusion of "tclWinInt.h" to avoid problems when compiling @@ -3374,11 +6617,11 @@ 2004-04-30 Donal K. Fellows * doc/puts.n: Added a few examples. -2004-04-29 Don Porter +2004-04-29 Don Porter * tests/execute.test (execute-8.2): Avoid crashes when there is limited system stack space (threads-enabled). 2004-04-28 Miguel Sofer @@ -3392,11 +6635,11 @@ 2004-04-28 Donal K. Fellows * doc/lsearch.n: Fixed fault in documentation of -index option [943448] -2004-04-26 Don Porter +2004-04-26 Don Porter * unix/tclUnixFCmd.c (TclpObjNormalizePath): Corrected improper positioning of returned checkpoint. [Bug 941108] 2004-04-26 Donal K. Fellows @@ -3410,11 +6653,11 @@ * doc/Thread.3: Reworked to remove references to testing interfaces and instead promote the use of the Thread package. [Patch 932527] Also reworked and reordered the page for better readability. -2004-04-25 Don Porter +2004-04-25 Don Porter * generic/tcl.h: Removed obsolete declarations and #include's. * generic/tclInt.h: [Bugs 926459, 926486] 2004-04-24 David Gravereaux @@ -3538,30 +6781,30 @@ 2004-04-15 Donal K. Fellows * generic/tclClock.c (Tcl_ClockObjCmd): Minor fault in a [clock clicks] error message. -2004-04-07 Jeff Hobbs +2004-04-07 Jeff Hobbs * win/tclWinInit.c (TclpSetInitialEncodings): note that WIN32_CE is also a unicode platform. - * generic/tclEncoding.c (TclFindEncodings, Tcl_FindExecutable): - * generic/tclInt.h: Correct handling of UTF + * generic/tclEncoding.c (TclFindEncodings, Tcl_FindExecutable): + * generic/tclInt.h: Correct handling of UTF * unix/tclUnixInit.c (TclpInitLibraryPath): data that is actually * win/tclWinFile.c (TclpFindExecutable): "clean", allowing the * win/tclWinInit.c (TclpInitLibraryPath): loading of Tcl from paths that contain multi-byte chars on Windows [Bug 920667] * win/configure: define TCL_LIB_FLAG, TCL_BUILD_LIB_SPEC, * win/configure.in: TCL_LIB_SPEC, TCL_PACKAGE_PATH in tclConfig.sh. -2004-04-06 Don Porter +2004-04-06 Don Porter - Patch 922727 committed. Implements three changes: + Patch 922727 committed. Implements three changes: * generic/tclInt.h: Reworked the Tcl header files into a clean - * unix/tclUnixPort.h: hierarchy where tcl.h < tclPort.h < tclInt.h + * unix/tclUnixPort.h: hierarchy where tcl.h < tclPort.h < tclInt.h * win/tclWinInt.h: and every C source file should #include * win/tclWinPort.h: at most one of those files to satisfy its declaration needs. tclWinInt.h and tclWinPort.h also better organized so that tclWinPort.h includes the Windows implementation of cross-platform declarations, while tclWinInt.h makes declarations that @@ -3586,29 +6829,29 @@ 2004-04-06 Donal K. Fellows * tests/cmdAH.test (cmdAH-18.2): Added constraint because access(...,X_OK) is defined to be permitted to be meaningless when - running as root, and OSX exhibits this. [Bug 929892] + running as root, and OSX exhibits this. [Bug 929892] 2004-04-02 Miguel Sofer * generic/tclCompile.c: * generic/tclInt.h: removed the macro TCL_ALIGN() from tclInt.h, replaced by the static macro ALIGN() in tclCompile.c [Bug 926445] 2004-04-02 Miguel Sofer - * generic/tclCompile.h: removed redundant #ifdef _TCLINT + * generic/tclCompile.h: removed redundant #ifdef _TCLINT [Bug 928415], reported by tauvan. -2004-04-02 Don Porter +2004-04-02 Don Porter * tests/tcltest.test: Corrected constraint typos: "nonRoot" -> "notRoot". Thanks to Steven Abner (tauvan). [Bug 928353] -2004-04-01 Don Porter +2004-04-01 Don Porter * generic/tclInt.h: Removed obsolete tclBlockTime* declarations. [Bug 926454] 2004-04-01 Vince Darley @@ -3616,11 +6859,11 @@ * generic/tclIOUtil.c: Fix to privately reported vfs bug with 'glob -type d -dir . *' across a vfs boundary. No tests for this are currently possible without effectively moving tclvfs into Tcl's test suite. -2004-03-31 Don Porter +2004-03-31 Don Porter * doc/msgcat.n: Clarified message catalog file encodings. [Bug 811457] * library/msgcat/msgcat.tcl: Updated internals to make use of [dict]s to store message catalog data and to use [source -encoding utf-8] to access catalog files. @@ -3629,19 +6872,19 @@ the empty string. [mcset $loc $src {}] was incorrectly set the $loc translation of $src back to $src. Also changed [ConvertLocale] to minimally require a non-empty "language" part in the locale value. If not, an error raised prompts [Init] to keep looking for a valid locale value, or ultimately fall back on the "C" locale. [Bug 811461]. - * library/msgcat/pkgIndex.tcl: Bump to msgcat 1.4.1. + * library/msgcat/pkgIndex.tcl: Bump to msgcat 1.4.1. 2004-03-30 Donal K. Fellows * generic/tclHash.c (HashStringKey): Cleaned up. This function is not faster, but it is a little bit clearer. * generic/tclLiteral.c (HashString): Applied logic from HashObjKey. * generic/tclObj.c (HashObjKey): Rewrote to fix fault which hashed - every single-character object to the same hash bucket. The new + every single-character object to the same hash bucket. The new code is shorter, simpler, clearer, and (happily) faster. 2004-03-30 Miguel Sofer * generic/tclExecute.c (TEBC): reverting to the previous method @@ -3648,13 +6891,13 @@ for async tests in TEBC, as the new method turned out to be too costly. Async tests now run every 64 instructions. 2004-03-30 Miguel Sofer - * generic/tclCompile.c: New instruction code INST_START_CMD - * generic/tclCompile.h: that allows checking the bytecode's - * generic/tclExecute.c: validity [Bug 729692] and the interp's + * generic/tclCompile.c: New instruction code INST_START_CMD + * generic/tclCompile.h: that allows checking the bytecode's + * generic/tclExecute.c: validity [Bug 729692] and the interp's * tests/interp.test (18.9): readyness [Bug 495830] before running * tests/proc.test (7.1): the command. It also changes the * tests/rename.test (6.1): mechanics of the async tests in TEBC, doing it now at command start instead of every 16 instructions. @@ -3661,23 +6904,23 @@ 2004-03-30 Vince Darley * generic/tclFileName.c: Fix to Windows glob where the pattern is * generic/tclIOUtil.c: a volume relative path or a network * tests/fileName.test: share [Bug 898238]. On windows 'glob' - * tests/fileSystem.test: will now return the results of - 'glob /foo/bar' and 'glob \\foo\\bar' as 'C:/foo/bar', i.e. a + * tests/fileSystem.test: will now return the results of + 'glob /foo/bar' and 'glob \\foo\\bar' as 'C:/foo/bar', i.e. a correct absolute path (rather than a volume relative path). - Note that the test suite does not test commands like - 'glob //Machine/Shared/*' (on a network share). + Note that the test suite does not test commands like + 'glob //Machine/Shared/*' (on a network share). 2004-03-30 Vince Darley * generic/tclPathObj.c: Fix to filename bugs recently * tests/fileName.test: introduced [Bug 918320]. -2004-03-29 Don Porter +2004-03-29 Don Porter * generic/tclMain.c (Tcl_Main, StdinProc): Append newline only * tests/basic.test (basic-46.1): to incomplete scripts as part of multi-line script construction. Do not add an extra trailing newline to the complete script. [Bug 833150] @@ -3691,11 +6934,11 @@ 2004-03-27 Miguel Sofer * doc/array.n: added documentation for trace-realted behaviour of 'array get' [Bug 449893] -2004-03-26 Don Porter +2004-03-26 Don Porter * README: Bumped version number to 8.5a2 to * tools/tcl.wse.in: distinguish HEAD of CVS development * unix/configure.in: from the recent 8.5a1 release. * unix/tcl.spec: @@ -3729,33 +6972,33 @@ * generic/tclIntDecls.h: * generic/tclMain.c: * generic/tclObj.c: * win/tclWinDde.c: * win/tclWinReg.c: - * win/tclWinTime.c: Made HEAD build on Windows VC++ again. + * win/tclWinTime.c: Made HEAD build on Windows VC++ again. 2004-03-19 Donal K. Fellows * generic/tclIntDecls.h: Made HEAD build on Solaris again by applying fix recommended by Don Porter. 2004-03-18 Reinhard Max * generic/tclIntDecls.h: Removed TclpTime_t. It wasn't really needed, - * generic/tclInt.h: but caused warnings related to - * generic/tclInt.decls: strict aliasing with GCC 3.3. + * generic/tclInt.h: but caused warnings related to + * generic/tclInt.decls: strict aliasing with GCC 3.3. * generic/tclClock.c: * generic/tclDate.c: - * generic/tclGetDate.y: - * win/tclWinTime.c: - * unix/tclUnixTime.c: - - * generic/tclNamesp.c: Added temporary pointer variables to work - * generic/tclStubLib.c: around warnings related to - * unix/tclUnixChan.c: strict aliasing with GCC 3.3. - - * unix/tcl.m4: Removed -Wno-strict-aliasing. + * generic/tclGetDate.y: + * win/tclWinTime.c: + * unix/tclUnixTime.c: + + * generic/tclNamesp.c: Added temporary pointer variables to work + * generic/tclStubLib.c: around warnings related to + * unix/tclUnixChan.c: strict aliasing with GCC 3.3. + + * unix/tcl.m4: Removed -Wno-strict-aliasing. 2004-03-18 Daniel Steffen Removed support for Mac OS Classic platform [Patch 918142] @@ -3901,17 +7144,17 @@ * doc/lsearch.n: Improved examples on the advanced capabilities of lsearch (with the right options, set element removal can be done) following discussion on tkchat. -2004-03-16 Don Porter +2004-03-16 Don Porter * doc/catch.n: Compiled [catch] no longer fails to catch syntax - errors. Removed the claims in the documentation that it does. + errors. Removed the claims in the documentation that it does. * doc/return.n: Updated example to use [dict merge]. -2004-03-16 Jeff Hobbs +2004-03-16 Jeff Hobbs * unix/configure, unix/tcl.m4: add -Wno-strict-aliasing for GCC to suppress useless type puning warnings. 2004-03-16 Donal K. Fellows @@ -3934,11 +7177,11 @@ * tests/dict.test (dict-20.*): English in Tcl [FRQ 745851] * doc/dict.n: but not exactly. 2004-03-10 Kevin B. Kenny - * generic/tclGetDate.y (TclGetDate): Fix so that + * generic/tclGetDate.y (TclGetDate): Fix so that [clock scan -gmt true] uses the GMT base date instead of the local one. [Bug 913513] * tests/clock.test: Added test cases for wrong ISO8601 week number [Bug 500285] and wrong GMT base date [Bug 913513]. Several tests still fail on Windows, and these are actual faults in [clock scan]. @@ -3946,13 +7189,13 @@ * generic/tclDate.c: Regenerated. 2004-03-08 Vince Darley * generic/tclFileName.c: Fix to 'glob -path' near the root - * tests/fileName.test: of the filesystem. [Bug 910525] + * tests/fileName.test: of the filesystem. [Bug 910525] -2004-03-08 Don Porter +2004-03-08 Don Porter * generic/tclParse.c (TclParseInit): Modified TclParseInit so * generic/tclTest.c ([testexprparser]): that Tcl_Parse initialization conforms to documented promised about what fields will not be modified by what Tcl_Parse* routines. [Bug 910595] @@ -3978,33 +7221,33 @@ * tests/registry.test: Applied fix from Patch #910174 to make the test for an English-language system include any country code, rather than just English-United States.1252. Thanks to Pat Thoyts for the changes. -2004-03-04 Pat Thoyts +2004-03-04 Pat Thoyts * tests/registry.test: Applied fixed from #766159 to skip two tests on Win98 that depend on a Unicode registry (NT specific). -2004-03-04 Don Porter +2004-03-04 Don Porter * generic/tclInt.h (TclParseInit): Factored the common code * generic/tclParse.c (TclParseInit): for initializing a Tcl_Parse * generic/tclParseExpr.c: struct into one routine. -2004-03-04 Pat Thoyts +2004-03-04 Pat Thoyts * library/reg/pkgIndex.tcl: Added TIP #100 support to the - * win/tclWinReg.c: registry package (patch #903831) - This provides a Windows test of the TIP #100 mechanism and + * win/tclWinReg.c: registry package (patch #903831) + This provides a Windows test of the TIP #100 mechanism and a sample to show how unloading an extension can be done. 2004-03-04 Donal K. Fellows * unix/dltest/pkgua.c: Fix minor syntax problems. [Bug 909288] -2004-03-03 Jeff Hobbs +2004-03-03 Jeff Hobbs *** 8.5a1 TAGGED FOR RELEASE *** * changes: updated for 8.5a1 @@ -4013,27 +7256,27 @@ * win/makefile.vc: default environment variable for VC++ is %MSDevDir% not %MSVCDir%, although vcvars32.bat sets both. * win/tclWinNotify.c (Tcl_WaitForEvent) : Allows an idling notifier to service "Asynchronous Procedure Calls" from its wait - state. Only useful for extension authors who decide they might + state. Only useful for extension authors who decide they might want to try "completion routines" with WriteFileEx(), as an example. From experience, I recommend that "completion ports" should be used instead as the execution of the callbacks are more managable. -2004-03-01 Jeff Hobbs +2004-03-01 Jeff Hobbs - * README: update patchlevel to 8.5a1 + * README: update patchlevel to 8.5a1 * generic/tcl.h: * tools/tcl.wse.in, tools/tclSplash.bmp: * unix/configure, unix/configure.in, unix/tcl.spec: * win/README.binary, win/configure, win/configure.in: * unix/tcl.m4: update HP-11 build libs setup -2004-03-01 Don Porter +2004-03-01 Don Porter * unix/tcl.m4 (SC_CONFIG_CFLAGS): Allow 64-bit enabling on IRIX64-6.5* systems. [Bug 218561] * unix/configure: autoconf-2.57 @@ -4072,13 +7315,13 @@ segfault with non-loadable extension. [Bug 904307] * unix/tclUnixChan.c (TcpGetOptionProc): Stop memory leak with very long hostnames. [Bug 888777] -2004-02-25 Pat Thoyts +2004-02-25 Pat Thoyts - * win/tclWinDde.c: Removed some gcc warnings - except for the + * win/tclWinDde.c: Removed some gcc warnings - except for the -Wconversion warning for GetGlobalAtomName. gcc is just wrong about this. 2004-02-24 Donal K. Fellows @@ -4112,11 +7355,11 @@ * doc/tcltest.n: * library/tcltest/tcltest.tcl: Changed -verbose default value to {body error} so that detailed information on unexpected errors in tests is provided by default, even after the fix for [Bug 725253] -2004-02-17 Jeff Hobbs +2004-02-17 Jeff Hobbs * tests/unixInit.test (unixInit-7.1): * unix/tclUnixInit.c (TclpInitPlatform): ensure the std fds exist to prevent crash condition [Bug #772288] @@ -4123,13 +7366,13 @@ 2004-02-17 Donal K. Fellows * generic/tclCompCmds.c (TclCompileSwitchCmd): Bozo mistake in memory releasing order when in an error case. [Bug 898910] -2004-02-16 Jeff Hobbs +2004-02-16 Jeff Hobbs - * generic/tclTrace.c (TclTraceExecutionObjCmd) + * generic/tclTrace.c (TclTraceExecutionObjCmd) (TclTraceCommandObjCmd): fix possible mem leak in trace info. 2004-02-12 Mo DeJong * win/tclWinInit.c (AppendEnvironment): @@ -4146,13 +7389,13 @@ 2004-02-07 David Gravereaux * win/makefile.vc: * win/rules.vc: * win/tcl.rc: - * win/tclsh.rc: Added an 'unchecked' option to the OPTS macro so a + * win/tclsh.rc: Added an 'unchecked' option to the OPTS macro so a core built with symbols can be linked to the non-debug enabled C - run-time. As per discussion with Kevin Kenny. Called like this: + run-time. As per discussion with Kevin Kenny. Called like this: nmake -af makefile.vc OPTS=unchecked,symbols This clarifies the meaning of the 'g' naming suffix to mean only that the binary requires the debug enabled C run-time. Whether the binary @@ -4224,11 +7467,11 @@ * generic/tclPathObj.c: fix to [Bug 883143] in file normalization 2004-01-29 Vince Darley - * doc/file.n: + * doc/file.n: * generic/tclFCmd.c * generic/tclTest.c * library/init.tcl * mac/tclMacFile.c * tests/fileSystem.test: fix to [Bug 886352] where 'file copy @@ -4257,11 +7500,11 @@ 2004-01-27 David Gravereaux * win/nmakehlp.c: Use '.\nul' as the sourcefile name instead of 'nul' so VC 5.2 doesn't try searching the path for it and failing with a possible dialogbox popping up about having to add a CD to - an empty drive. Also added a SetErrorMode() call to disable any + an empty drive. Also added a SetErrorMode() call to disable any dialogs that cl.exe or link.exe might create. [Bug 885537] 2004-01-22 Vince Darley * doc/file.n: clarified documentation of 'file system' [Bug 883825] @@ -4268,26 +7511,26 @@ * tests/fCmd.test: improved test result in failure case. 2004-01-22 Vince Darley * tests/fileSystem.test: 3 new tests - * generic/tclPathObj.c: fix to [Bug 879555] in file normalization. + * generic/tclPathObj.c: fix to [Bug 879555] in file normalization. * doc/filename.n: small clarification to Windows behaviour with filenames like '.....', 'a.....', '.....a'. * generic/tclIOUtil.c: slight improvement to native cwd caching on Windows. 2004-01-21 David Gravereaux - * doc/Panic.3: Mentions of 'panic' and 'panicVA' removed from + * doc/Panic.3: Mentions of 'panic' and 'panicVA' removed from the documentation. 2004-01-21 Vince Darley - * doc/FileSystem.3: - * generic/tcl.decls: + * doc/FileSystem.3: + * generic/tcl.decls: * generic/tclCmdAH.c * generic/tclDecls.h * generic/tclFCmd.c * generic/tclFileName.c * generic/tclFileSystem.h @@ -4315,19 +7558,19 @@ conversions. (3) clarifications to the documentation, particularly regarding the acceptable refCounts of objects. Some new tests added. Tcl benchmarks show a significant improvement over 8.4.5, and on Windows typically a small improvement over 8.3.5 (Unix still appears to require - optimisation). TCL_FILESYSTEM_VERSION_2 introduced, but for + optimisation). TCL_FILESYSTEM_VERSION_2 introduced, but for internal use only. There should be no public incompatibilities from these changes. Thanks to dgp for extensive testing. 2004-01-19 David Gravereaux * win/tclWinPipe.c (Tcl_WaitPid): Fixed a thread-safety problem - with the process list. The delayed cut operation after the wait - was going stale by being outside the list lock. It now cuts + with the process list. The delayed cut operation after the wait + was going stale by being outside the list lock. It now cuts within the lock and does a locked splice for when it needs to instead. [Bug 859820] 2004-01-18 Donal K. Fellows @@ -4365,11 +7608,11 @@ * win/tclWinReg.c: Placed the requirement for advapi.lib into the object file itself with #paragma comment (lib, ...) when built with VC++. This will simplify linking for users of the static library. - * win/rules.vc: Added new 'fullwarn' to the CHECKS commandline + * win/rules.vc: Added new 'fullwarn' to the CHECKS commandline macro; sets $(FULLWARNINGS). * win/makefile.vc: Removed 'advapi.lib' from $(baselibs). Added new logic to crank-up the warning levels for both compile and link when $(FULLWARNINGS) is set. Some clean-up with how @@ -4379,35 +7622,35 @@ * win/tclAppInit.c: Small change in how TCL_USE_STATIC_PACKAGES is used. * win/tcl.rc: * win/tclsh.rc: Some clean-up with how the resource files are - built. Fixed 'OriginalFilename' problem that still thought + built. Fixed 'OriginalFilename' problem that still thought a debug suffix was still 'd', now is 'g'. 2004-01-14 Donal K. Fellows * generic/tclDictObj.c (TraceDictPath, DictExistsCmd): Adjusted behaviour of [dict exists] so a failure to look up a dictionary along the path of dicts doesn't trigger an error. This is how it - was documented to behave previously... [Bug 871387] + was documented to behave previously... [Bug 871387] * generic/tclDictObj.c: Assorted dict fixes from Peter Spjuth relating to [Bug 876170]. (SetDictFromAny): Make sure that lists retain their ordering even when converted to dictionaries and back. (TraceDictPath): Correct object reference count handling! (DictReplaceCmd, DictRemoveCmd): Stop object leak. - (DictIncrCmd,DictLappendCmd,DictAppendCmd,DictSetCmd,DictUnsetCmd): + (DictIncrCmd,DictLappendCmd,DictAppendCmd,DictSetCmd,DictUnsetCmd): Simpler handling of reference counts when assigning to variables. * tests/dict.test (dict-19.2): Memory leak stress test 2004-01-13 Don Porter * generic/tclCmdMZ.c (Tcl_SwitchObjCmd): Silence compiler warnings. - Patch 876451: restores performance of [return]. Also allows forms + Patch 876451: restores performance of [return]. Also allows forms such as [return -code error $msg] to be bytecompiled. * generic/tclInt.h: Factored Tcl_ReturnObjCmd() into two pieces: * generic/tclCmdMZ.c: TclMergeReturnOptions(), which can parse the options to [return], check their validity, and create the @@ -4446,11 +7689,11 @@ cost for the core will be minimal because of the object cache, and this fixes [Bug 875395]. 2004-01-12 Miguel Sofer - * generic/tclCompExpr.c (CompileLandOrLorExpr): cosmetic changes. + * generic/tclCompExpr.c (CompileLandOrLorExpr): cosmetic changes. 2004-01-12 Miguel Sofer * generic/tclCompExpr.c (CompileLandOrLorExpr): new logic, fewer instructions. As a side effect, the instructions INST_LOR and @@ -4467,25 +7710,25 @@ 2004-01-09 David Gravereaux * generic/tcl.h: Renamed and deprecated #defines moved to within the #ifndef TCL_NO_DEPRECATED block. This allows us to build Tcl to check for deprecated functions in use, such as panic() and - Tcl_Ckalloc(). By request from DKF. Extensions that build + Tcl_Ckalloc(). By request from DKF. Extensions that build with -DTCL_NO_DEPRECATED now have these macros as restricted. ***POTENTIAL INCOMPATIBILITY*** * win/makefile.vc: - * win/rules.vc: Added -DTCL_NO_DEPRECATED usage to makefile.vc. + * win/rules.vc: Added -DTCL_NO_DEPRECATED usage to makefile.vc. Called like this: nmake -af makefile.vc CHECKS=nodep 2004-01-09 Vince Darley - * generic/tclIOUtil.c: fix to infinite loop in + * generic/tclIOUtil.c: fix to infinite loop in TclFinalizeFilesystem [Bug 873311] ****************************************************************** - *** CHANGELOG ENTRIES FOR 2003 IN "ChangeLog.2003" *** - *** CHANGELOG ENTRIES FOR 2002 IN "ChangeLog.2002" *** - *** CHANGELOG ENTRIES FOR 2001 IN "ChangeLog.2001" *** - *** CHANGELOG ENTRIES FOR 2000 IN "ChangeLog.2000" *** + *** CHANGELOG ENTRIES FOR 2003 IN "ChangeLog.2003" *** + *** CHANGELOG ENTRIES FOR 2002 IN "ChangeLog.2002" *** + *** CHANGELOG ENTRIES FOR 2001 IN "ChangeLog.2001" *** + *** CHANGELOG ENTRIES FOR 2000 IN "ChangeLog.2000" *** *** CHANGELOG ENTRIES FOR 1999 AND EARLIER IN "ChangeLog.1999" *** ****************************************************************** Index: README ================================================================== --- README +++ README @@ -1,13 +1,13 @@ README: Tcl - This is the Tcl 8.5a2 source distribution. + This is the Tcl 8.5a4 source distribution. Tcl/Tk is also available through NetCVS: http://tcl.sourceforge.net/ You can get any source release of Tcl from the file distributions link at the above URL. -RCS: @(#) $Id: README,v 1.53 2004/03/26 19:47:28 dgp Exp $ +RCS: @(#) $Id: README,v 1.53.2.2 2005/07/12 20:36:11 kennykb Exp $ Contents -------- 1. Introduction 2. Documentation Index: changes ================================================================== --- changes +++ changes @@ -1,8 +1,8 @@ Recent user-visible changes to Tcl: -RCS: @(#) $Id: changes,v 1.92 2004/11/18 18:34:10 dgp Exp $ +RCS: @(#) $Id: changes,v 1.92.2.2 2005/07/12 20:36:11 kennykb Exp $ 1. No more [command1] [command2] construct for grouping multiple commands on a single command line. 2. Semi-colon now available for grouping commands on a line. @@ -6197,15 +6197,17 @@ 2004-09-08 (bug fix) fixed [clock format 0 -format %k] (kenny) 2004-09-09 (bug fix)[560297] fixed broken [namespace forget] logic (porter) -2004-09-09 (bug fix)[1017299] fixed [namespace import] cycle prevention (porter) +2004-09-09 (bug fix)[1017299] fixed [namespace import] cycle prevention +(porter) 2004-09-10 (performance) $x[set x {}] is now fast [K $x [set x {}]] (sofer) -2004-09-10 (bug fix)[868489] better control over int <-> wideInt (fellows,kenny) +2004-09-10 (bug fix)[868489] better control over int <-> wideInt +(fellows,kenny) 2004-09-10 (bug fix)[1025359] POSIX errorCode from wide seeks (kupries,fellows) 2004-09-10 (bug fix)[707104,1026493] fix [rename] of [interp alias] (porter) @@ -6215,15 +6217,17 @@ and [namespace eval c {error foo bar}] (porter) 2004-09-22 (feature change) syntax errors not reported at compile time; deferred to runtime. Support [return -errorline]. (porter) -2004-09-23 (bug fix)[1016726] fix `make clean` in static config (leitgeb,dejong) +2004-09-23 (bug fix)[1016726] fix `make clean` in static config +(leitgeb,dejong) 2004-09-22 (feature change) report all compile errors at runtime (porter) -2004-09-29 (bug fix)[1036649] syntax error in [subst] => buffer overflow (sofer) +2004-09-29 (bug fix)[1036649] syntax error in [subst] => buffer overflow +(sofer) 2004-09-30 (bug fix)[1038021] save/restore error state: var traces (porter) 2004-10-01 (performance) stackframe level values in internal reps (fellows) @@ -6232,11 +6236,12 @@ 2004-10-04 (bug fix)[884830] eq and ne parse in expr (fellows) 2004-10-05 (reform) errorInfo, errorCode management (porter) *** POTENTIAL INCOMPATIBILITY for traces on those vars *** -2004-10-06 (feature change)[1041072] re-bless and enhance Tcl_AppendResult (dkf) +2004-10-06 (feature change)[1041072] re-bless and enhance Tcl_AppendResult +(dkf) 2004-10-06 (reform) more robust interp result appends (porter) => dde 1.3.1 => registry 1.1.5 @@ -6246,30 +6251,33 @@ 2004-10-08 (new feature)[TIP 201] "in" and "ni" expr operators (fellows) 2004-10-08 (new feature)[TIP 212] [dict update]; [dict with] (fellows) -2004-10-08 (bug fix)[954263] case insensitive [file exec] for Win (hobbs,darley) +2004-10-08 (bug fix)[954263] case insensitive [file exec] for Win +(hobbs,darley) 2004-10-14 (performance) [info commands/globals/procs/vars $pattern] faster when $pattern is trivial (fellows) 2004-10-14 (new feature)[TIP 217] [lsort -indices] (salsman,fellows) 2004-10-24 (reform) replaced bit flag values with macros for Var handling *** POTENTIAL INCOMPATIBILITY for accesses to Var internals *** -2004-10-26 (new feature)[1054370] install msgcat, http, tcltest as TM's (porter) +2004-10-26 (new feature)[1054370] install msgcat, http, tcltest as TM's +(porter) 2004-10-26 (bug fix)[767676] negative PIDs with pipes (giese,gravereaux) -2004-10-27 (bug fix)[731778] stop critical section leaks (mistachkin,gravereaux) +2004-10-27 (bug fix)[731778] stop critical section leaks +(mistachkin,gravereaux) 2004-10-27 (bug fix)[926088] -load option to find tested packages (gravereaux) 2004-10-28 (bug fix)[1030548] restore the --enable-symbols --enable-threads - build on Win (mistachkin,kenny,kupries) +build on Win (mistachkin,kenny,kupries) 2004-10-29 (bug fix)[1055673] fix command line syntax error message (porter) => tcltest 2.2.7 2004-10-30 (bug fix)[926106] fix [file mtime] DST anomaly (kenny) @@ -6281,21 +6289,19 @@ 2004-11-02 (bug fix)[1017151] misleading errorInfo after tests (seeger,porter) 2004-11-03 (bug fix)[527164] preserve errorinfo from var traces (porter) 2004-11-08 (bug fix){947693] Made -blocking option of channel during [close] - consistent on Windows with Unix (gravereaux) +consistent on Windows with Unix (gravereaux) *** POTENTIAL INCOMPATIBILITY *** 2004-11-11 (bug fix)[1034337] recursive file delete, MacOSX (steffen) -2004-11-12 (feature)[TIP 34] make use of a configuration header file (fellows) - *** POTENTIAL INCOMPATIBILITY *** - 2004-11-12 (new feature)[TIP 221] [interp bgerror] (porter) -2004-11-12 (new feature)[TIP 226] Tcl_(Save|Restore|Discard)InterpState (porter) +2004-11-12 (new feature)[TIP 226] Tcl_(Save|Restore|Discard)InterpState +(porter) 2004-11-12 (new feature)[TIP 227] Tcl_(Get|Set)ReturnOptions (porter) 2004-11-12 (bug fix)[1004065] stop crash when TCL_UTF_MAX==6 (hobbs,porter) @@ -6302,10 +6308,188 @@ 2004-11-15 (bug fix)[10653678] [trace variable],[trace remove] interop (porter) 2004-11-16 (bug fix)[1067709] crash in [fconfigure -ttycontrol] (hobbs) 2004-11-18 (new feature) configure options --enable-man-suffix (max) + +2004-11-22 (bug fix)[1030465] Improve HAVE_TYPE_OFF64_T check (dejong) + +2004-11-22 (bug fix)[1043129] Fixed the treatment of backslashes in file +join on Windows (darley) + +2004-11-22 (bug fix)[976438] Move init.tcl search path construction to +tclInit (porter) + +2004-11-24 (bug fix)[1072654] Fixed segfault in info vars trivial +matching branch (new in 8.4.8) (porter) + +2004-11-24 (bug fix)[1001325, 1071701] Fixed readdir_r detection and usage +(dejong, kenny, porter) + +2004-11-24 (bug fix)[1071807] Fixed all uses of 'select' to use standard +macros rather than older bit-whacking style (kenny) + +2004-11-26 (bug fix)[1073524] Simplify the code to check for correctness of +strstr, strtoul and strtod on unix (fellows) + +2004-11-26 (bug fix)[1072136] Remove file normalize on tcl_findLibrary +search path uniqification added in 8.4.8 (porter) + +2004-11-30 (bug fix)[976520] Rework startup/initialization of the Tcl +library, encoding search initialization, and Tcl_FindExecutable structure. +[tclInit] no longer driven by the value of $::tcl_libPath (TCLLIBPATH). +(porter) + *** POTENTIAL INCOMPATIBILITY : makes encoding names case sensitive + on Windows, where they have been case insensitive *** + +2004-12-02 (bug fix)[1074671] Ensure tilde paths are not returned specially +by 'glob' (darley) Doc improvements [759545,926590,935853,1017072,1018486,1022527,1027849, - 1032243,1047928,1048005,1058446,1062647,1065732,etc.] + 1032243,1047928,1048005,1058446,1062647,1065732,1073334,etc.] Test suite expansion [1036649,1001997,etc.] +--- Released 8.5a2, December 7, 2004 --- See ChangeLog for details --- + +2004-12-13 (bug fix)[1083082] encoding memory leaks (ade,porter) + +2004-12-13 (bug fix)[1082349] restored C++ extension support (porter) + +2004-12-14 (bug fix)[1081541] workaround automake-ism "$U" (porter) + +2004-12-15 (new feature) CallFrames on execution, not C, stack (sofer) + +2004-12-16 (bug fix)[1085023] [interp limit] support in [vwait], etc. (fellows) + +2004-12-29 (bug fix)[1090413] make [clock scan 0030] work (morian,kenny) + +2004-12-29 (bug fix)[1092789] make [clock scan 10000] work (porter,kenny) + +2004-12-29 (platform support)[1092952,1091967] MSVC7, gcc OPT compiles (hobbs) + +2005-01-06 (performance)[1020491] [http::mapReply] (fellows) +=> http 2.5.1 + +2005-01-09 (bug fix)[1095909] stopped use of readdir_r (english) + +2005-01-10 (enhancement)[1081595] stopped use of TCL_DBGX (english) + +2005-01-17 (bug fix)[1100542] [glob] of Windows shares (schar,darley) + +2005-01-19 (new feature)[TIP 235] C API for ensembles (fellows) + +2005-01-21 (new feature)[TIP 233] virtual time (kupries) + +2005-01-25 (bug fix)[1101670] [auto_reset] update for [namespace] (porter) +***POTENTIAL INCOMPATIBILITY*** +May cause re-[source]-ing of files that have not anticipated that before. + +2005-01-27 (new feature)[TIP 218] Tcl_Channel API update for threads (kupries) + +2005-01-27 (bug fix)[1109484] Tcl_Expr* updates for Tcl_WideInt (hobbs) + +2005-01-28 (platform support)[1021871] Solaris gcc 64-bit support (hobbs) + +2005-02-10 (bug fix)[1119369] Tcl_EvalObjEx: avoid shimmer loss of List intrep +(sofer,macdonald) + +2005-02-11 (platform support) correct gcc builds for AIX-4+, HP-UX-11 (hobbs) + +2005-02-24 (bug fix)[1119798] prevent [source $directory] (porter,mpettigr) +=> tcltest 2.2.8 + +2005-03-10 (bug fix)[1153871] bad ClientData cast (porter,victorovich) + +2005-03-15 (platform support) OpenBSD ports patch (thoyts) + +2005-03-18 (bug fix)[1115904] restore recursion limit in direct eval (porter) + +2005-03-24 (bug fix) stop conflict between Tcltest and Thread packages (porter) + +2005-03-29 (platform support) allow msys builds without cygwin (hobbs) + +2005-04-01 (internal change)[1158008] internal rep of "list" Tcl_Obj's +now uses a refcounted struct (sofer) +***POTENTIAL INCOMPATIBILITY*** +For any code that goes poking into the internals of "list" Tcl_Obj's + +2005-04-05 (performance)[1174551] Tcl_DecrRefCount of Tcl_Obj "chains" (sofer) + +2005-04-08 (performance)[1077262] better Tcl_Encoding cache lifetimes (porter) + +2005-04-10 (bug fix)[1180368] [interp invokehidden] mem leak (kenny,porter) + +2005-04-12 (performance)[1177363] startup encoding file scan (porter) + +2005-04-12 (performance)[1182459] [clock format] (kenny) + +2005-04-13 (bug fix) min buffer size dropped from 10 to 1 byte (gravereaux) + +2005-04-16 (bug fix)[1178445] fix memory waste at thread exit (vasiljevic) + +2004-04-16 (bug fix)[1084111] [array names] memory leak (ade,sofer) + +2005-04-19 (bug fix)[1185933] [clock] init clobbered global vars (ring,kenny) + +2005-04-19 (new feature) [::tcl::unsupported::EncodingDirs] - unsupported +command to set search path for encoding files (porter) + +2005-04-20 (bug fix)[1090869] Tcl_GetInt accept 0x80000000, 64-bit +(porter,singh) + +2005-04-22 (bug fix)[1187123] [string is boolean] respect EIAS (porter) + +2005-04-25 (enhancement) update to tzdata2005i (kenny) + +2005-04-25 (platform support) builds on Mac OS X 10.1 (steffen) + +2005-04-27 (new feature)[TIP 183] [open $f {... BINARY ...}] (porter) + +2005-04-29 (new feature)[TIP 176] simple index arithmetic (porter) + +2005-05-06 (platform support) x86_64 Solarix cc and Solaris 10 builds (hobbs) + +2005-05-10 (bug fix)[1198892] [expr {i**0}] error (kaitschu,markus) + +2005-05-10 (new feature)[TIP 132] floating-point conversion to string (kenny) +***POTENTIAL INCOMPATIBILITY*** +For scripts that rely on (tcl_precision==12) number formatting + +2005-05-10 (new feature)[TIP 232] math functions as commands (kenny) +***POTENTIAL INCOMPATIBILITY*** +Tcl_GetMathFuncInfo functioning is reduced; routine is now deprecated + +2005-05-13 (feature removed) TCL_NO_MATH compiler directive (porter) + +2005-05-14 (platform support) Mac OSX: configurable CoreFoundation API +(steffen) + +2005-05-14 (platform support) Mac OSX: use realpath when threadsafe (steffen) + +2005-05-17 (feature removed) Tcl_ObjType's "list", "procbody", "index", +"ensembleCommand", "localVarName", "levelReference, "boolean" are no +longer registered (porter) +***POTENTIAL INCOMPATIBILITY*** +For any callers of Tcl_GetObjType on those strings + +2005-05-20 (bug fix)[1201589] boolean literal prefix in expressions (porter) + +2005-05-24 (platform support) Darwin build support merged into unix (steffen) + +2005-05-24 (new feature)[1202209] Mac OSX: support [load] of .bundle binaries +Can support [load] from memory as well (steffen) + +2005-05-24 (new feature)[1202178] [time] returns non-integer result (steffen) + +2005-05-25 (new feature)[TIP 182] [expr {bool(...)}] (mistachkin,porter) + +2005-05-30 (new feature)[TIP 229] [namespace path] (fellows) + +2005-05-31 (bug fix)[1082283] Unix: notifier thread now joinable (vasiljevic) + +2005-06-01 (new feature)[TIP 241] -nocase: lsort, lsearch, switch (mistachkin) + +2005-06-01 (bug fix)[1209759] "return TCL_RETURN;" could cause panic (porter) + +Documentation improvements [1075433,1085127,1117017,1124160,1149605,etc.] + +--- Released 8.5a3, June 4, 2004 --- See ChangeLog for details --- Index: compat/string.h ================================================================== --- compat/string.h +++ compat/string.h @@ -7,11 +7,11 @@ * Copyright (c) 1994-1996 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: string.h,v 1.5 2004/03/17 18:14:12 das Exp $ + * RCS: @(#) $Id: string.h,v 1.5.2.1 2005/05/05 17:55:18 kennykb Exp $ */ #ifndef _STRING #define _STRING @@ -24,11 +24,15 @@ * it exists everywhere) */ #include +#ifdef __APPLE__ +extern VOID * memchr _ANSI_ARGS_((CONST VOID *s, int c, size_t n)); +#else extern char * memchr _ANSI_ARGS_((CONST VOID *s, int c, size_t n)); +#endif extern int memcmp _ANSI_ARGS_((CONST VOID *s1, CONST VOID *s2, size_t n)); extern char * memcpy _ANSI_ARGS_((VOID *t, CONST VOID *f, size_t n)); #ifdef NO_MEMMOVE #define memmove(d, s, n) bcopy ((s), (d), (n)) Index: compat/strstr.c ================================================================== --- compat/strstr.c +++ compat/strstr.c @@ -7,14 +7,17 @@ * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: strstr.c,v 1.4 2004/04/06 22:25:48 dgp Exp $ + * RCS: @(#) $Id: strstr.c,v 1.4.2.1 2005/04/25 21:37:18 kennykb Exp $ */ #include "tcl.h" +#ifndef NULL +#define NULL 0 +#endif /* *---------------------------------------------------------------------- * * strstr -- Index: compat/strtoll.c ================================================================== --- compat/strtoll.c +++ compat/strtoll.c @@ -7,11 +7,11 @@ * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: strtoll.c,v 1.7 2004/04/06 22:25:48 dgp Exp $ + * RCS: @(#) $Id: strtoll.c,v 1.7.2.2 2005/01/20 19:12:26 kennykb Exp $ */ #include "tclInt.h" #include Index: compat/strtoull.c ================================================================== --- compat/strtoull.c +++ compat/strtoull.c @@ -7,11 +7,11 @@ * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: strtoull.c,v 1.7 2004/04/06 22:25:48 dgp Exp $ + * RCS: @(#) $Id: strtoull.c,v 1.7.2.2 2005/01/20 19:12:27 kennykb Exp $ */ #include "tclInt.h" #include Index: doc/AddErrInfo.3 ================================================================== --- doc/AddErrInfo.3 +++ doc/AddErrInfo.3 @@ -3,14 +3,14 @@ '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: AddErrInfo.3,v 1.13 2004/11/21 23:17:50 dgp Exp $ +'\" RCS: @(#) $Id: AddErrInfo.3,v 1.13.2.2 2005/09/15 20:58:38 dgp Exp $ '\" .so man.macros -.TH Tcl_AddErrorInfo 3 8.0 Tcl "Tcl Library Procedures" +.TH Tcl_AddErrorInfo 3 8.5 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_GetReturnOptions, Tcl_SetReturnOptions, Tcl_AddErrorInfo, Tcl_AddObjErrorInfo, Tcl_SetObjErrorCode, Tcl_SetErrorCode, Tcl_SetErrorCodeVA, Tcl_PosixError, Tcl_LogCommandInfo \- retrieve or record information about errors and other return options .SH SYNOPSIS .nf @@ -64,11 +64,11 @@ .AP char *element in String to record as one element of the \fB-errorcode\fR return option. Last \fIelement\fR argument must be NULL. .AP va_list argList in An argument list which must have been initialized using -\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR. +\fBva_start\fR, and cleared using \fBva_end\fR. .AP "const char" *script in Pointer to first character in script containing command (must be <= command) .AP "const char" *command in Pointer to first character in command that generated the error .AP int commandLength in @@ -80,20 +80,20 @@ .VS 8.5 The \fBTcl_SetReturnOptions\fR and \fBTcl_GetReturnOptions\fR routines expose the same capabilities as the \fBreturn\fR and \fBcatch\fR commands, respectively, in the form of a C interface. .PP -\fBTcl_GetObjResult\fR retrieves the dictionary of return options +\fBTcl_GetReturnOptions\fR retrieves the dictionary of return options from an interpreter following a script evaluation. Routines such as \fBTcl_Eval\fR are called to evaluate a script in an interpreter. These routines return an integer completion code. These routines also leave in the interpreter both a result and a dictionary of return options generated by script evaluation. Just as \fBTcl_GetObjResult\fR retrieves the result, \fBTcl_GetReturnOptions\fR retrieves the dictionary of return options. The integer completion code should be -passed as the \fIcode\fR argument to \fBTcl_GetObjResult\fR +passed as the \fIcode\fR argument to \fBTcl_GetReturnOptions\fR so that all required options will be present in the dictionary. Specifically, a \fIcode\fR value of \fBTCL_ERROR\fR will ensure that entries for the keys \fB-errorinfo\fR, \fB-errorcode\fR, and \fB-errorline\fR will appear in the dictionary. Also, the entries for the keys \fB-code\fR @@ -199,11 +199,11 @@ The value of the \fB-errorline\fR return option (retrieved via a call to \fBTcl_GetReturnOptions\fR) often makes up a useful part of the \fImessage\fR passed to \fBTcl_AddErrorInfo\fR. .PP \fBTcl_AddObjErrorInfo\fR is nearly identical -to \fBTcl_AddObjErrorInfo\fR, except that it has an additional \fIlength\fR +to \fBTcl_AddErrorInfo\fR, except that it has an additional \fIlength\fR argument. This allows the \fImessage\fR string to contain embedded null bytes. This is essentially never a good idea. If the \fImessage\fR needs to contain the null character \fBU+0000\fR, Tcl's usual internal encoding rules should be used to avoid the need for a null byte. If the \fBTcl_AddObjErrorInfo\fR @@ -265,22 +265,22 @@ call the procedures described here rather than setting \fBerrorInfo\fR or \fBerrorCode\fR directly with \fBTcl_ObjSetVar2\fR. .PP If the procedure \fBTcl_ResetResult\fR is called, -it clears all of the state of ther interpreter associated with +it clears all of the state of the interpreter associated with script evaluation, including the entire return options dictionary. In particular, the \fB-errorinfo\fR and \fB-errorcode\fR options are reset. If an error had occurred, the \fBTcl_ResetResult\fR call will clear the error state to make it appear as if no error had occurred after all. The global variables \fBerrorInfo\fR and \fBerrorCode\fR are not modified by \fBTcl_ResetResult\fR so they continue to hold a record of information about the -more recent error seen in an interpreter. +most recent error seen in an interpreter. .SH "SEE ALSO" Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_Interp, Tcl_ResetResult, Tcl_SetErrno .SH KEYWORDS error, object, object result, stack, trace, variable Index: doc/Async.3 ================================================================== --- doc/Async.3 +++ doc/Async.3 @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: Async.3,v 1.7 2004/11/20 00:17:31 dgp Exp $ +'\" RCS: @(#) $Id: Async.3,v 1.7.2.1 2004/12/13 22:03:09 kennykb Exp $ '\" .so man.macros .TH Tcl_AsyncCreate 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME @@ -60,15 +60,15 @@ occurred, then handle the event later when the world has returned to a clean state, such as after the current Tcl command completes. .PP \fBTcl_AsyncCreate\fR, \fBTcl_AsyncDelete\fR, and \fBTcl_AsyncReady\fR are thread sensitive. They access and/or set a thread-specific data -structure in the event of an --enable-thread built core. The token -created by Tcl_AsyncCreate contains the needed thread information it -was called from so that calling Tcl_AsyncMark(token) will only yield -the origin thread into the AsyncProc. -.PP +structure in the event of a core built with \fI\-\-enable\-threads\fR. The token +created by \fBTcl_AsyncCreate\fR contains the needed thread information it +was called from so that calling \fBTcl_AsyncMark\fR(\fItoken\fR) will only yield +the origin thread into the asynchronous handler. +.PP \fBTcl_AsyncCreate\fR creates an asynchronous handler and returns a token for it. The asynchronous handler must be created before any occurrences of the asynchronous event that it is intended to handle (it is not safe to create a handler at the time of Index: doc/Backslash.3 ================================================================== --- doc/Backslash.3 +++ doc/Backslash.3 @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: Backslash.3,v 1.5 2004/10/07 14:44:31 dkf Exp $ +'\" RCS: @(#) $Id: Backslash.3,v 1.5.2.1 2005/04/10 23:14:39 kennykb Exp $ '\" .so man.macros .TH Tcl_Backslash 3 "8.1" Tcl "Tcl Library Procedures" .BS .SH NAME @@ -28,26 +28,22 @@ the backslash character. .BE .SH DESCRIPTION .PP -.VS 8.1 The use of \fBTcl_Backslash\fR is deprecated in favor of \fBTcl_UtfBackslash\fR. .PP This is a utility procedure provided for backwards compatibility with non-internationalized Tcl extensions. It parses a backslash sequence and returns the low byte of the Unicode character corresponding to the sequence. -.VE \fBTcl_Backslash\fR modifies \fI*countPtr\fR to contain the number of characters in the backslash sequence. .PP See the Tcl manual entry for information on the valid backslash sequences. All of the sequences described in the Tcl manual entry are supported by \fBTcl_Backslash\fR. -.VS 8.1 br .SH "SEE ALSO" Tcl(n), Tcl_UtfBackslash(3) -.VE .SH KEYWORDS backslash, parse Index: doc/BoolObj.3 ================================================================== --- doc/BoolObj.3 +++ doc/BoolObj.3 @@ -1,18 +1,19 @@ '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. +'\" Contributions from Don Porter, NIST, 2005. (not subject to US copyright) '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: BoolObj.3,v 1.5 2004/10/07 15:37:43 dkf Exp $ +'\" RCS: @(#) $Id: BoolObj.3,v 1.5.2.2 2005/05/21 15:10:25 kennykb Exp $ '\" .so man.macros -.TH Tcl_BooleanObj 3 8.0 Tcl "Tcl Library Procedures" +.TH Tcl_BooleanObj 3 8.5 Tcl "Tcl Library Procedures" .BS .SH NAME -Tcl_NewBooleanObj, Tcl_SetBooleanObj, Tcl_GetBooleanFromObj \- manipulate Tcl objects as boolean values +Tcl_NewBooleanObj, Tcl_SetBooleanObj, Tcl_GetBooleanFromObj \- store/retrieve boolean value in a Tcl_Obj .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Obj * @@ -23,67 +24,72 @@ int \fBTcl_GetBooleanFromObj\fR(\fIinterp, objPtr, boolPtr\fR) .SH ARGUMENTS .AS Tcl_Interp boolValue in/out .AP int boolValue in -Integer value used to initialize or set a boolean object. -If the integer is nonzero, the boolean object is set to 1; -otherwise the boolean object is set to 0. +Integer value to be stored as a boolean value in a Tcl_Obj. .AP Tcl_Obj *objPtr in/out -For \fBTcl_SetBooleanObj\fR, this points to the object to be converted -to boolean type. -For \fBTcl_GetBooleanFromObj\fR, this refers to the object -from which to get a boolean value; -if \fIobjPtr\fR does not already point to a boolean object, -an attempt will be made to convert it to one. +Points to the Tcl_Obj in which to store, or from which to +retrieve a boolean value. .AP Tcl_Interp *interp in/out -If an error occurs during conversion, +If a boolean value cannot be retrieved, an error message is left in the interpreter's result object unless \fIinterp\fR is NULL. .AP int *boolPtr out Points to place where \fBTcl_GetBooleanFromObj\fR stores the boolean value (0 or 1) obtained from \fIobjPtr\fR. .BE .SH DESCRIPTION .PP -These procedures are used to create, modify, and read -boolean Tcl objects from C code. -\fBTcl_NewBooleanObj\fR and \fBTcl_SetBooleanObj\fR -will create a new object of boolean type -or modify an existing object to have boolean type. -Both of these procedures set the object to have the -boolean value (0 or 1) specified by \fIboolValue\fR; -if \fIboolValue\fR is nonzero, the object is set to 1, -otherwise to 0. -\fBTcl_NewBooleanObj\fR returns a pointer to a newly created object -with reference count zero. -Both procedures set the object's type to be boolean -and assign the boolean value to the object's internal representation -\fIlongValue\fR member. -\fBTcl_SetBooleanObj\fR invalidates any old string representation -and, if the object is not already a boolean object, -frees any old internal representation. +These procedures are used to pass boolean values to and from +Tcl as Tcl_Obj's. When storing a boolean value into a Tcl_Obj, +any non-zero integer value in \fIboolValue\fR is taken to be +the boolean value \fB1\fR, and the integer value \fB0\fR is +taken to be the boolean value \fB0\fR. +.PP +\fBTcl_NewBooleanObj\fR creates a new Tcl_Obj, stores the boolean +value \fIboolValue\fR in it, and returns a pointer to the new Tcl_Obj. +The new Tcl_Obj has reference count of zero. +.PP +\fBTcl_SetBooleanObj\fR accepts \fIobjPtr\fR, a pointer to +an existing Tcl_Obj, and stores in the Tcl_Obj \fI*objPtr\fR +the boolean value \fIboolValue\fR. This is a write operation +on \fI*objPtr\fR, so \fIobjPtr\fR must be unshared. Attempts to +write to a shared Tcl_Obj will panic. A successful write +of \fIboolValue\fR into \fI*objPtr\fR implies the freeing of +any former value stored in \fI*objPtr\fR. +.PP +\fBTcl_GetBooleanFromObj\fR attempts to retrive a boolean value +from the value stored in \fI*objPtr\fR. +If \fIobjPtr\fR holds a string value recognized by \fBTcl_GetBoolean\fR, +then the recognized boolean value is written at the address given +by \fIboolPtr\fR. +If \fIobjPtr\fR holds any value recognized as +a number by Tcl, then if that value is zero a 0 is written at +the address given by \fIboolPtr\fR and if that +value is non-zero a 1 is written at the address given by \fIboolPtr\fR. +In all cases where a value is written at the address given +by \fIboolPtr\fR, \fBTcl_GetBooleanFromObj\fR returns \fBTCL_OK\fR. +If the value of \fIobjPtr\fR does not meet any of the conditions +above, then \fBTCL_ERROR\fR is returned and an error message is +left in the interpreter's result unless \fIinterp\fR is NULL. +\fBTcl_GetBooleanFromObj\fR may also make changes to the internal +fields of \fI*objPtr\fR so that future calls to +\fBTcl_GetBooleanFromObj\fR on the same \fIobjPtr\fR can be +performed more efficiently. .PP -\fBTcl_GetBooleanFromObj\fR attempts to return a boolean value -from the Tcl object \fIobjPtr\fR. -If the object is not already a boolean object, -it will attempt to convert it to one. -If an error occurs during conversion, it returns \fBTCL_ERROR\fR -and leaves an error message in the interpreter's result object -unless \fIinterp\fR is NULL. -Otherwise, \fBTcl_GetBooleanFromObj\fR returns \fBTCL_OK\fR -and stores the boolean value in the address given by \fIboolPtr\fR. -If the object is not already a boolean object, -the conversion will free any old internal representation. -Objects having a string representation equal to any of \fB0\fR, -\fBfalse\fR, \fBno\fR, or \fBoff\fR have a boolean value 0; if the -string representation is any of \fB1\fR, \fBtrue\fR, \fByes\fR, or -\fBon\fR the boolean value is 1. -Any of these string values may be abbreviated, and upper-case spellings -are also acceptable. +Note that the routines \fBTcl_GetBooleanFromObj\fR and +\fBTcl_GetBoolean\fR are not functional equivalents. +The set of values for which \fBTcl_GetBooleanFromObj\fR +will return \fBTCL_OK\fR is strictly larger than +the set of values for which \fBTcl_GetBoolean\fR will do the same. +For example, the value "5" passed to \fBTcl_GetBooleanFromObj\fR +will lead to a \fBTCL_OK\fR return (and the boolean value 1), +while the same value passed to \fBTcl_GetBoolean\fR will lead to +a \fBTCL_ERROR\fR return. .SH "SEE ALSO" -Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult +Tcl_NewObj, Tcl_IsShared, Tcl_GetBoolean .SH KEYWORDS -boolean, boolean object, boolean type, internal representation, object, object type, string representation +boolean, object Index: doc/Concat.3 ================================================================== --- doc/Concat.3 +++ doc/Concat.3 @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: Concat.3,v 1.7 2004/10/07 15:15:35 dkf Exp $ +'\" RCS: @(#) $Id: Concat.3,v 1.7.2.1 2005/04/10 23:14:39 kennykb Exp $ '\" .so man.macros .TH Tcl_Concat 3 7.5 Tcl "Tcl Library Procedures" .BS .SH NAME @@ -42,15 +42,12 @@ copies strings from \fBargv\fR to the result. If an element of \fBargv\fR consists of nothing but white space, then that string is ignored entirely. This white-space removal was added to make the output of the \fBconcat\fR command cleaner-looking. .PP -.VS The result string is dynamically allocated using \fBTcl_Alloc\fR; the caller must eventually release the space by calling \fBTcl_Free\fR. -.VE -.VS .SH "SEE ALSO" Tcl_ConcatObj .SH KEYWORDS concatenate, strings Index: doc/CrtChannel.3 ================================================================== --- doc/CrtChannel.3 +++ doc/CrtChannel.3 @@ -3,17 +3,17 @@ '\" Copyright (c) 1997-2000 Ajuba Solutions. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: CrtChannel.3,v 1.24 2004/11/12 09:01:25 das Exp $ +'\" RCS: @(#) $Id: CrtChannel.3,v 1.24.2.5 2005/10/08 13:44:37 dgp Exp $ .so man.macros -.TH Tcl_CreateChannel 3 8.3 Tcl "Tcl Library Procedures" +.TH Tcl_CreateChannel 3 8.4 Tcl "Tcl Library Procedures" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -Tcl_CreateChannel, Tcl_GetChannelInstanceData, Tcl_GetChannelType, Tcl_GetChannelName, Tcl_GetChannelHandle, Tcl_GetChannelMode, Tcl_GetChannelBufferSize, Tcl_SetChannelBufferSize, Tcl_NotifyChannel, Tcl_BadChannelOption, Tcl_ChannelName, Tcl_ChannelVersion, Tcl_ChannelBlockModeProc, Tcl_ChannelCloseProc, Tcl_ChannelClose2Proc, Tcl_ChannelInputProc, Tcl_ChannelOutputProc, Tcl_ChannelSeekProc, Tcl_ChannelWideSeekProc, Tcl_ChannelSetOptionProc, Tcl_ChannelGetOptionProc, Tcl_ChannelWatchProc, Tcl_ChannelGetHandleProc, Tcl_ChannelFlushProc, Tcl_ChannelHandlerProc, Tcl_IsChannelShared, Tcl_IsChannelRegistered, Tcl_CutChannel, Tcl_SpliceChannel, Tcl_IsChannelExisting, Tcl_ClearChannelHandlers, Tcl_GetChannelThread, Tcl_ChannelBuffered \- procedures for creating and manipulating channels +Tcl_CreateChannel, Tcl_GetChannelInstanceData, Tcl_GetChannelType, Tcl_GetChannelName, Tcl_GetChannelHandle, Tcl_GetChannelMode, Tcl_GetChannelBufferSize, Tcl_SetChannelBufferSize, Tcl_NotifyChannel, Tcl_BadChannelOption, Tcl_ChannelName, Tcl_ChannelVersion, Tcl_ChannelBlockModeProc, Tcl_ChannelCloseProc, Tcl_ChannelClose2Proc, Tcl_ChannelInputProc, Tcl_ChannelOutputProc, Tcl_ChannelSeekProc, Tcl_ChannelWideSeekProc, Tcl_ChannelTruncateProc, Tcl_ChannelSetOptionProc, Tcl_ChannelGetOptionProc, Tcl_ChannelWatchProc, Tcl_ChannelGetHandleProc, Tcl_ChannelFlushProc, Tcl_ChannelHandlerProc, Tcl_ChannelThreadActionProc, Tcl_IsChannelShared, Tcl_IsChannelRegistered, Tcl_CutChannel, Tcl_SpliceChannel, Tcl_IsChannelExisting, Tcl_ClearChannelHandlers, Tcl_GetChannelThread, Tcl_ChannelBuffered \- procedures for creating and manipulating channels .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Channel @@ -29,14 +29,12 @@ \fBTcl_GetChannelName\fR(\fIchannel\fR) .sp int \fBTcl_GetChannelHandle\fR(\fIchannel, direction, handlePtr\fR) .sp -.VS 8.4 Tcl_ThreadId \fBTcl_GetChannelThread\fR(\fIchannel\fR) -.VE 8.4 .sp int \fBTcl_GetChannelMode\fR(\fIchannel\fR) .sp int @@ -46,11 +44,10 @@ .sp \fBTcl_NotifyChannel\fR(\fIchannel, mask\fR) .sp int \fBTcl_BadChannelOption\fR(\fIinterp, optionName, optionList\fR) -.VS 8.4 .sp int \fBTcl_IsChannelShared\fR(\fIchannel\fR) .sp int @@ -65,11 +62,10 @@ void \fBTcl_SpliceChannel\fR(\fIchannel\fR) .sp void \fBTcl_ClearChannelHandlers\fR(\fIchannel\fR) -.VE 8.4 .sp int \fBTcl_ChannelBuffered\fR(\fIchannel\fR) .sp const char * @@ -94,14 +90,20 @@ \fBTcl_ChannelOutputProc\fR(\fItypePtr\fR) .sp Tcl_DriverSeekProc * \fBTcl_ChannelSeekProc\fR(\fItypePtr\fR) .sp -.VS 8.4 Tcl_DriverWideSeekProc * \fBTcl_ChannelWideSeekProc\fR(\fItypePtr\fR) -.VE 8.4 +.sp +Tcl_DriverThreadActionProc * +\fBTcl_ChannelThreadActionProc\fR(\fItypePtr\fR) +.sp +.VS 8.5 +Tcl_DriverTruncateProc * +\fBTcl_ChannelTruncateProc\fR(\fItypePtr\fR) +.VE 8.5 .sp Tcl_DriverSetOptionProc * \fBTcl_ChannelSetOptionProc\fR(\fItypePtr\fR) .sp Tcl_DriverGetOptionProc * @@ -233,16 +235,14 @@ location specified by \fIhandlePtr\fR and returns \fBTCL_OK\fR. If the channel does not have a device handle for the specified direction, then \fBTCL_ERROR\fR is returned instead. Different channel drivers will return different types of handle. Refer to the manual entries for each driver to determine what type of handle is returned. -.VS 8.4 .PP \fBTcl_GetChannelThread\fR returns the id of the thread currently managing the specified \fIchannel\fR. This allows channel drivers to send their file events to the correct event queue even for a multi-threaded core. -.VE 8.4 .PP \fBTcl_GetChannelMode\fR returns an OR-ed combination of \fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR, indicating whether the channel is open for input and output. .PP @@ -271,11 +271,10 @@ \fBTcl_ChannelBuffered\fR returns the number of bytes of input currently buffered in the internal buffer (push back area) of the channel itself. It does not report about the data in the overall buffers for the stack of channels the supplied channel is part of. .PP -.VS 8.4 \fBTcl_IsChannelShared\fR checks the refcount of the specified \fIchannel\fR and returns whether the \fIchannel\fR was shared among multiple interpreters (result == 1) or not (result == 0). .PP \fBTcl_IsChannelRegistered\fR checks whether the specified \fIchannel\fR is @@ -288,19 +287,28 @@ .PP \fBTcl_CutChannel\fR removes the specified \fIchannel\fR from the (thread)global list of all channels (of the current thread). Application to a channel still registered in some interpreter is not allowed. +.VS 8.5 +Also notifies the driver if the \fBTcl_ChannelType\fR version is +\fBTCL_CHANNEL_VERSION_4\fR (or higher), and +\fBTcl_DriverThreadActionProc\fR is defined for it. +.VE 8.5 .PP \fBTcl_SpliceChannel\fR adds the specified \fIchannel\fR to the (thread)global list of all channels (of the current thread). Application to a channel registered in some interpreter is not allowed. +.VS 8.5 +Also notifies the driver if the \fBTcl_ChannelType\fR version is +\fBTCL_CHANNEL_VERSION_4\fR (or higher), and +\fBTcl_DriverThreadActionProc\fR is defined for it. +.VE 8.5 .PP \fBTcl_ClearChannelHandlers\fR removes all channelhandlers and event scripts associated with the specified \fIchannel\fR, thus shutting down all event processing for this channel. -.VE 8.4 .SH TCL_CHANNELTYPE .PP A channel driver provides a \fBTcl_ChannelType\fR structure that contains pointers to functions that implement the various operations on a channel; these operations are invoked as needed by the generic layer. The structure @@ -324,31 +332,38 @@ Tcl_DriverClose2Proc *\fIclose2Proc\fR; Tcl_DriverBlockModeProc *\fIblockModeProc\fR; Tcl_DriverFlushProc *\fIflushProc\fR; Tcl_DriverHandlerProc *\fIhandlerProc\fR; Tcl_DriverWideSeekProc *\fIwideSeekProc\fR; + Tcl_DriverThreadActionProc *\fIthreadActionProc\fR; +.VS 8.5 + Tcl_DriverTruncateProc *\fItruncateProc\fR; +.VE 8.5 } Tcl_ChannelType; .CE .PP -The driver must provide implementations for all functions except -\fIblockModeProc\fR, \fIseekProc\fR, \fIsetOptionProc\fR, -\fIgetOptionProc\fR, and \fIclose2Proc\fR, which may be specified as -NULL. Other functions that can not be implemented for this type of -device should return \fBEINVAL\fR when invoked to indicate that they -are not implemented, except in the case of \fIflushProc\fR and -\fIhandlerProc\fR, which should specified as NULL if not otherwise defined. +It is not necessary to provide implementations for all channel +operations. Those which are not necessary may be set to NULL in the +struct: \fIblockModeProc\fR, \fIseekProc\fR, \fIsetOptionProc\fR, +\fIgetOptionProc\fR, and \fIclose2Proc\fR, in addition to +\fIflushProc\fR, \fIhandlerProc\fR, \fIthreadActionProc\fR, and +\fItruncateProc\fR. Other functions that cannot be implemented in a +meaningful way should return \fBEINVAL\fR when called, to indicate +that the operations they represent are not available. Also note that +\fIwideSeekProc\fR can be NULL if \fIseekProc\fR is. .PP The user should only use the above structure for \fBTcl_ChannelType\fR instantiation. When referencing fields in a \fBTcl_ChannelType\fR structure, the following functions should be used to obtain the values: \fBTcl_ChannelName\fR, \fBTcl_ChannelVersion\fR, \fBTcl_ChannelBlockModeProc\fR, \fBTcl_ChannelCloseProc\fR, \fBTcl_ChannelClose2Proc\fR, \fBTcl_ChannelInputProc\fR, \fBTcl_ChannelOutputProc\fR, \fBTcl_ChannelSeekProc\fR, -.VS 8.4 -\fBTcl_ChannelWideSeekProc\fR, -.VE 8.4 +\fBTcl_ChannelWideSeekProc\fR, \fBTcl_ChannelThreadActionProc\fR, +.VS 8.5 +\fBTcl_ChannelTruncateProc\fR, +.VE 8.5 \fBTcl_ChannelSetOptionProc\fR, \fBTcl_ChannelGetOptionProc\fR, \fBTcl_ChannelWatchProc\fR, \fBTcl_ChannelGetHandleProc\fR, \fBTcl_ChannelFlushProc\fR, or \fBTcl_ChannelHandlerProc\fR. .PP The change to the structures was made in such a way that standard channel @@ -363,21 +378,31 @@ .PP This value can be retrieved with \fBTcl_ChannelName\fR, which returns a pointer to the string. .SS VERSION .PP -The \fIversion\fR field should be set to \fBTCL_CHANNEL_VERSION_2\fR. -If it is not set to this value \fBTCL_CHANNEL_VERSION_3\fR, then this -\fBTcl_ChannelType\fR is assumed to have the older structure. See + +The \fIversion\fR field should be set to the version of the structure +that you require. \fBTCL_CHANNEL_VERSION_2\fR is the minimum recommended. +\fBTCL_CHANNEL_VERSION_3\fR must be set to specifiy the \fIwideSeekProc\fR member. +.VS 8.5 +\fBTCL_CHANNEL_VERSION_4\fR must be set to specifiy the +\fIthreadActionProc\fR and \fItruncateProc\fR members (includes +\fIwideSeekProc\fR). +.VE 8.5 +If it is not set to any of these, then this +\fBTcl_ChannelType\fR is assumed to have the original structure. See \fBOLD CHANNEL TYPES\fR for more details. While Tcl will recognize -and function with either structure, stacked channels must be of at +and function with either structures, stacked channels must be of at least \fBTCL_CHANNEL_VERSION_2\fR to function correctly. .PP This value can be retrieved with \fBTcl_ChannelVersion\fR, which returns -.VS 8.4 -one of \fBTCL_CHANNEL_VERSION_3\fR, -.VE 8.4 +one of +.VS 8.5 +\fBTCL_CHANNEL_VERSION_4\fR, +.VE 8.5 +\fBTCL_CHANNEL_VERSION_3\fR, \fBTCL_CHANNEL_VERSION_2\fR or \fBTCL_CHANNEL_VERSION_1\fR. .SS BLOCKMODEPROC .PP The \fIblockModeProc\fR field contains the address of a function called by the generic layer to set blocking and nonblocking mode on the device. @@ -574,11 +599,10 @@ does not implement seeking. .PP The return value is the new access point or -1 in case of error. If an error occurred, the function should not move the access point. .PP -.VS 8.4 If there is a non-NULL \fIseekProc\fR field, the \fIwideSeekProc\fR field may contain the address of an alternative function to use which handles wide (i.e. larger than 32-bit) offsets, so allowing seeks within files larger than 2GB. The \fIwideSeekProc\fR will be called in preference to the \fIseekProc\fR, but both must be defined if the @@ -599,11 +623,10 @@ .PP The \fIseekProc\fR value can be retrieved with \fBTcl_ChannelSeekProc\fR, which returns a pointer to the function, and similarly the \fIwideSeekProc\fR can be retrieved with \fBTcl_ChannelWideSeekProc\fR. -.VE 8.4 .SS SETOPTIONPROC .PP The \fIsetOptionProc\fR field contains the address of a function called by the generic layer to set a channel type specific option on a channel. \fIsetOptionProc\fR must match the following prototype: @@ -773,19 +796,66 @@ combination of \fBTCL_READABLE\fR or \fBTCL_WRITABLE\fR; it indicates what type of event occurred on this channel. .PP This value can be retrieved with \fBTcl_ChannelHandlerProc\fR, which returns a pointer to the function. + +.SS "THREADACTIONPROC" +.PP +The \fIthreadActionProc\fR field contains the address of the function +called by the generic layer when a channel is created, closed, or +going to move to a different thread, i.e. whenever thread-specific +driver state might have to initialized or updated. It can be NULL. +The action \fITCL_CHANNEL_THREAD_REMOVE\fR is used to notify the +driver that it should update or remove any thread-specific data it +might be maintaining for the channel. +.PP +The action \fITCL_CHANNEL_THREAD_INSERT\fR is used to notify the +driver that it should update or initialize any thread-specific data it +might be maintaining using the calling thread as the associate. See +\fBTcl_CutChannel\fR and \fBTcl_SpliceChannel\fR for more detail. +.PP +.CS +typedef void Tcl_DriverThreadActionProc( + ClientData \fIinstanceData\fR, + int \fIaction\fR); +.CE +.PP +\fIInstanceData\fR is the same as the value passed to +\fBTcl_CreateChannel\fR when this channel was created. +.PP +These values can be retrieved with \fBTcl_ChannelThreadActionProc\fR, +which returns a pointer to the function. +.SS "TRUNCATEPROC" +.PP +The \fItruncateProc\fR field contains the address of the function +called by the generic layer when a channel is truncated to some +length. It can be NULL. +.PP +.CS +typedef int Tcl_DriverTruncateProc( + ClientData \fIinstanceData\fR, + Tcl_WideInt \fIlength\fR); +.CE +.PP +\fIInstanceData\fR is the same as the value passed to +\fBTcl_CreateChannel\fR when this channel was created, and +\fIlength\fR is the new length of the underlying file, which should +not be negative. The result should be 0 on success or an errno code +(suitable for use with \fBTcl_SetErrno\fR) on failure. +.PP +These values can be retrieved with \fBTcl_ChannelTruncateProc\fR, +which returns a pointer to the function. .SH TCL_BADCHANNELOPTION .PP This procedure generates a "bad option" error message in an (optional) interpreter. It is used by channel drivers when an invalid Set/Get option is requested. Its purpose is to concatenate the generic options list to the specific ones and factorize the generic options error message string. .PP -It always return \fBTCL_ERROR\fR +It always returns \fBTCL_ERROR\fR .PP An error message is generated in \fIinterp\fR's result object to indicate that a command was invoked with a bad option. The message has the form .CS @@ -828,11 +898,10 @@ internal channel code will determine the version. It is imperative to use the new \fBTcl_ChannelType\fR structure if you are creating a stacked channel driver, due to problems with the earlier stacked channel implementation (in 8.2.0 to 8.3.1). .PP -.VS 8.4 Prior to 8.4.0 (i.e. during the later releases of 8.3 and early part of the 8.4 development cycle) the \fBTcl_ChannelType\fR structure contained the following fields: .PP .CS @@ -849,17 +918,17 @@ Tcl_DriverGetHandleProc *\fIgetHandleProc\fR; Tcl_DriverClose2Proc *\fIclose2Proc\fR; Tcl_DriverBlockModeProc *\fIblockModeProc\fR; Tcl_DriverFlushProc *\fIflushProc\fR; Tcl_DriverHandlerProc *\fIhandlerProc\fR; + Tcl_DriverTruncateProc *\fItruncateProc\fR; } Tcl_ChannelType; .CE .PP When the above structure is registered as a channel type, the \fIversion\fR field should always be \fBTCL_CHANNEL_VERSION_2\fR. -.VE 8.4 .SH "SEE ALSO" Tcl_Close(3), Tcl_OpenFileChannel(3), Tcl_SetErrno(3), Tcl_QueueEvent(3), Tcl_StackChannel(3), Tcl_GetStdChannel(3) .SH KEYWORDS blocking, channel driver, channel registration, channel type, nonblocking Index: doc/CrtCommand.3 ================================================================== --- doc/CrtCommand.3 +++ doc/CrtCommand.3 @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: CrtCommand.3,v 1.10 2004/10/07 15:15:35 dkf Exp $ +'\" RCS: @(#) $Id: CrtCommand.3,v 1.10.2.1 2005/04/10 23:14:40 kennykb Exp $ '\" .so man.macros .TH Tcl_CreateCommand 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME @@ -93,20 +93,16 @@ the command, \fIargc\fR giving the number of arguments (including the command name) and \fIargv\fR giving the values of the arguments as strings. The \fIargv\fR array will contain \fIargc\fR+1 values; the first \fIargc\fR values point to the argument strings, and the last value is NULL. -.VS Note that the argument strings should not be modified as they may point to constant strings or may be shared with other parts of the interpreter. -.VE .PP -.VS Note that the argument strings are encoded in normalized UTF-8 since version 8.1 of Tcl. -.VE .PP \fIProc\fR must return an integer code that is expected to be one of \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR. See the Tcl overview man page for details on what these codes mean. Most normal commands will only Index: doc/CrtFileHdlr.3 ================================================================== --- doc/CrtFileHdlr.3 +++ doc/CrtFileHdlr.3 @@ -3,26 +3,24 @@ '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: CrtFileHdlr.3,v 1.3 2004/10/07 14:44:31 dkf Exp $ +'\" RCS: @(#) $Id: CrtFileHdlr.3,v 1.3.2.1 2005/04/10 23:14:41 kennykb Exp $ '\" .so man.macros .TH Tcl_CreateFileHandler 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateFileHandler, Tcl_DeleteFileHandler \- associate procedure callbacks with files or devices (Unix only) .SH SYNOPSIS .nf \fB#include \fR -.VS .sp \fBTcl_CreateFileHandler\fR(\fIfd, mask, proc, clientData\fR) .sp \fBTcl_DeleteFileHandler\fR(\fIfd\fR) -.VE .SH ARGUMENTS .AS Tcl_FileProc clientData .AP int fd in Unix file descriptor for an open file or device. .AP int mask in @@ -37,16 +35,14 @@ Arbitrary one-word value to pass to \fIproc\fR. .BE .SH DESCRIPTION .PP -.VS \fBTcl_CreateFileHandler\fR arranges for \fIproc\fR to be invoked in the future whenever I/O becomes possible on a file or an exceptional condition exists for the file. The file is indicated by \fIfd\fR, and the conditions of interest -.VE are indicated by \fImask\fR. For example, if \fImask\fR is \fBTCL_READABLE\fR, \fIproc\fR will be called when the file is readable. The callback to \fIproc\fR is made by \fBTcl_DoOneEvent\fR, so \fBTcl_CreateFileHandler\fR is only useful in programs that dispatch @@ -87,12 +83,10 @@ block if it reads or writes too much data; while waiting for the I/O to complete the application won't be able to service other events. Use \fBTcl_SetChannelOption\fR with \fB\-blocking\fR to set the channel into blocking or nonblocking mode as required. .PP -.VS Note that these interfaces are only supported by the Unix implementation of the Tcl notifier. -.VE .SH KEYWORDS callback, file, handler Index: doc/CrtMathFnc.3 ================================================================== --- doc/CrtMathFnc.3 +++ doc/CrtMathFnc.3 @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: CrtMathFnc.3,v 1.11 2004/10/07 15:15:35 dkf Exp $ +'\" RCS: @(#) $Id: CrtMathFnc.3,v 1.11.2.2 2005/04/25 19:59:45 kennykb Exp $ '\" .so man.macros .TH Tcl_CreateMathFunc 3 8.4 Tcl "Tcl Library Procedures" .BS .SH NAME @@ -17,18 +17,16 @@ \fB#include \fR .sp void \fBTcl_CreateMathFunc\fR(\fIinterp, name, numArgs, argTypes, proc, clientData\fR) .sp -.VS 8.4 int \fBTcl_GetMathFuncInfo\fR(\fIinterp, name, numArgsPtr, argTypesPtr, procPtr, clientDataPtr\fR) .sp Tcl_Obj * \fBTcl_ListMathFuncs\fR(\fIinterp, pattern\fR) -.VE .SH ARGUMENTS .AS Tcl_ValueType *clientDataPtr out .AP Tcl_Interp *interp in Interpreter in which new function will be defined. .AP "const char" *name in @@ -64,23 +62,29 @@ .SH DESCRIPTION .PP Tcl allows a number of mathematical functions to be used in expressions, such as \fBsin\fR, \fBcos\fR, and \fBhypot\fR. -\fBTcl_CreateMathFunc\fR allows applications to add additional functions +These functions are represented by commands in the namespace, +\fBtcl::mathfunc\fR. The \fBTcl_CreateMathFunc\fR function is +an obsolete way for applications to add additional functions to those already provided by Tcl or to replace existing functions. +It should not be used by new applications, which should create +math functions using \fBTcl_CreateObjCommand\fR to create a command +in the \fBtcl::mathfunc\fR namespace. +.PP +In the \fBTcl_CreateMathFunc\fR interface, \fIName\fR is the name of the function as it will appear in expressions. -If \fIname\fR doesn't already exist as a function then a new function -is created. If it does exist, then the existing function is replaced. +If \fIname\fR doesn't already exist in the \fB::tcl::mathfunc\fR +namespace, then a new command is created in that namespace. +If \fIname\fR does exist, then the existing function is replaced. \fINumArgs\fR and \fIargTypes\fR describe the arguments to the function. Each entry in the \fIargTypes\fR array must be -.VS 8.4 one of \fBTCL_INT\fR, \fBTCL_DOUBLE\fR, \fBTCL_WIDE_INT\fR, or \fBTCL_EITHER\fR to indicate whether the corresponding argument must be an integer, a double-precision floating value, a wide (64-bit) integer, or any, respectively. -.VE 8.4 .PP Whenever the function is invoked in an expression Tcl will invoke \fIproc\fR. \fIProc\fR should have arguments and result that match the type \fBTcl_MathProc\fR: .CS @@ -93,11 +97,10 @@ .PP When \fIproc\fR is invoked the \fIclientData\fR and \fIinterp\fR arguments will be the same as those passed to \fBTcl_CreateMathFunc\fR. \fIArgs\fR will point to an array of \fInumArgs\fR Tcl_Value structures, which describe the actual arguments to the function: -.VS 8.4 .CS typedef struct Tcl_Value { Tcl_ValueType \fItype\fR; long \fIintValue\fR; double \fIdoubleValue\fR; @@ -105,34 +108,28 @@ } Tcl_Value; .CE .PP The \fItype\fR field indicates the type of the argument and is one of \fBTCL_INT\fR, \fBTCL_DOUBLE\fR or \fBTCL_WIDE_INT\fR. -.VE 8.4 It will match the \fIargTypes\fR value specified for the function unless the \fIargTypes\fR value was \fBTCL_EITHER\fR. Tcl converts the argument supplied in the expression to the type requested in \fIargTypes\fR, if that is necessary. Depending on the value of the \fItype\fR field, the \fIintValue\fR, -.VS 8.4 \fIdoubleValue\fR or \fIwideValue\fR -.VE 8.4 field will contain the actual value of the argument. .PP \fIProc\fR should compute its result and store it either as an integer in \fIresultPtr->intValue\fR or as a floating value in \fIresultPtr->doubleValue\fR. It should set also \fIresultPtr->type\fR to one of -.VS 8.4 \fBTCL_INT\fR, \fBTCL_DOUBLE\fR or \fBTCL_WIDE_INT\fR -.VE 8.4 to indicate which value was set. Under normal circumstances \fIproc\fR should return \fBTCL_OK\fR. If an error occurs while executing the function, \fIproc\fR should return \fBTCL_ERROR\fR and leave an error message in the interpreter's result. .PP -.VS 8.4 \fBTcl_GetMathFuncInfo\fR retrieves the values associated with function \fIname\fR that were passed to a preceding \fBTcl_CreateMathFunc\fR call. Normally, the return code is \fBTCL_OK\fR but if the named function does not exist, \fBTCL_ERROR\fR is returned and an error message is placed in the interpreter's @@ -139,22 +136,25 @@ result. .PP If an error did not occur, the array reference placed in the variable pointed to by \fIargTypesPtr\fR is newly allocated, and should be released by passing it to \fBTcl_Free\fR. Some functions (the -standard set implemented in the core) are implemented directly at the -bytecode level; attempting to retrieve values for them causes a NULL -to be stored in the variable pointed to by \fIprocPtr\fR and the -variable pointed to by \fIclientDataPtr\fR will not be modified. +standard set implemented in the core, and those defined by placing +commands in the \fBtcl::mathfunc\fR namespace) do not have +argument type information; attempting to retrieve values for +them causes a NULL to be stored in the variable pointed to by +\fIprocPtr\fR and the variable pointed to by \fIclientDataPtr\fR +will not be modified. The variable pointed to by \fInumArgsPointer\fR +will contain -1, and no argument types will be stored in the variable +pointed to by \fIargTypesPointer\fR. .PP \fBTcl_ListMathFuncs\fR returns a Tcl object containing a list of all the math functions defined in the interpreter whose name matches \fIpattern\fR. In the case of an error, NULL is returned and an error message is left in the interpreter result, and otherwise the returned object will have a reference count of zero. -.VE .SH KEYWORDS expression, mathematical function .SH "SEE ALSO" -expr(n), info(n), Tcl_Free(3), Tcl_NewListObj(3) +expr(n), info(n), Tcl_CreateObjCommand(3), Tcl_Free(3), Tcl_NewListObj(3) Index: doc/CrtObjCmd.3 ================================================================== --- doc/CrtObjCmd.3 +++ doc/CrtObjCmd.3 @@ -2,11 +2,11 @@ '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: CrtObjCmd.3,v 1.11 2004/10/07 15:15:36 dkf Exp $ +'\" RCS: @(#) $Id: CrtObjCmd.3,v 1.11.2.1 2005/04/10 23:14:41 kennykb Exp $ '\" .so man.macros .TH Tcl_CreateObjCommand 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME @@ -28,21 +28,17 @@ \fBTcl_GetCommandInfo\fR(\fIinterp, cmdName, infoPtr\fR) .sp int \fBTcl_SetCommandInfo\fR(\fIinterp, cmdName, infoPtr\fR) .sp -.VS 8.4 int \fBTcl_GetCommandInfoFromToken\fR(\fItoken, infoPtr\fR) .sp int \fBTcl_SetCommandInfoFromToken\fR(\fItoken, infoPtr\fR) -.VE .sp -.VS 8.4 const char * -.VE \fBTcl_GetCommandName\fR(\fIinterp, token\fR) .sp void \fBTcl_GetCommandFullName\fR(\fIinterp, token, objPtr\fR) .sp @@ -97,11 +93,10 @@ .CS typedef int Tcl_ObjCmdProc( ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR, int \fIobjc\fR, -.VS Tcl_Obj *const \fIobjv\fR[]); .CE When \fIproc\fR is invoked, the \fIclientData\fR and \fIinterp\fR parameters will be copies of the \fIclientData\fR and \fIinterp\fR arguments given to \fBTcl_CreateObjCommand\fR. Typically, \fIclientData\fR points to an @@ -123,11 +118,10 @@ object argument. For instance, the user may call \fBTcl_GetIntFromObj\fR on \fIobjv\fR[\fB2\fR] to obtain the integer representation of that object; that call may change the type of the object that \fIobjv\fR[\fB2\fR] points at, but will not change where \fIobjv\fR[\fB2\fR] points. -.VE .PP \fIproc\fR must return an integer code that is either \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR. See the Tcl overview man page for details on what these codes mean. Most normal commands will only Index: doc/CrtSlave.3 ================================================================== --- doc/CrtSlave.3 +++ doc/CrtSlave.3 @@ -2,11 +2,11 @@ '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: CrtSlave.3,v 1.14 2004/10/07 15:37:43 dkf Exp $ +'\" RCS: @(#) $Id: CrtSlave.3,v 1.14.2.1 2005/03/09 15:57:15 kennykb Exp $ '\" .so man.macros .TH Tcl_CreateSlave 3 7.6 Tcl "Tcl Library Procedures" .BS .SH NAME @@ -77,11 +77,11 @@ .AP "const char *const" *argv in Vector of strings, the additional arguments to pass to the alias command. This storage is owned by the caller. .AP int objc in Count of additional object arguments to pass to the alias object command. -.AP Tcl_Object **objv in +.AP Tcl_Obj **objv in Vector of Tcl_Obj structures, the additional object arguments to pass to the alias object command. This storage is owned by the caller. .AP Tcl_Interp **targetInterpPtr in Pointer to location to store the address of the interpreter where a target Index: doc/DString.3 ================================================================== --- doc/DString.3 +++ doc/DString.3 @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: DString.3,v 1.11 2004/10/07 15:15:36 dkf Exp $ +'\" RCS: @(#) $Id: DString.3,v 1.11.2.1 2005/05/05 17:55:20 kennykb Exp $ '\" .so man.macros .TH Tcl_DString 3 7.4 Tcl "Tcl Library Procedures" .BS .SH NAME @@ -17,14 +17,14 @@ \fB#include \fR .sp \fBTcl_DStringInit\fR(\fIdsPtr\fR) .sp char * -\fBTcl_DStringAppend\fR(\fIdsPtr, string, length\fR) +\fBTcl_DStringAppend\fR(\fIdsPtr, bytes, length\fR) .sp char * -\fBTcl_DStringAppendElement\fR(\fIdsPtr, string\fR) +\fBTcl_DStringAppendElement\fR(\fIdsPtr, element\fR) .sp \fBTcl_DStringStartSublist\fR(\fIdsPtr\fR) .sp \fBTcl_DStringEndSublist\fR(\fIdsPtr\fR) .sp @@ -45,14 +45,16 @@ \fBTcl_DStringGetResult\fR(\fIinterp, dsPtr\fR) .SH ARGUMENTS .AS Tcl_DString newLength in/out .AP Tcl_DString *dsPtr in/out Pointer to structure that is used to manage a dynamic string. -.AP "const char" *string in -Pointer to characters to add to dynamic string. +.AP "const char" *bytes in +Pointer to characters to append to dynamic string. +.AP "const char" *element in +Pointer to characters to append as list element to dynamic string. .AP int length in -Number of characters from string to add to dynamic string. If -1, +Number of bytes from \fIbytes\fR to add to dynamic string. If -1, add all characters up to null terminating character. .AP int newLength in New length for dynamic string, not including null terminating character. .AP Tcl_Interp *interp in/out @@ -75,20 +77,20 @@ be called first to free up any memory allocated for the old string. .PP \fBTcl_DStringAppend\fR adds new information to a dynamic string, allocating more memory for the string if needed. -If \fIlength\fR is less than zero then everything in \fIstring\fR +If \fIlength\fR is less than zero then everything in \fIbytes\fR is appended to the dynamic string; otherwise \fIlength\fR specifies the number of bytes to append. \fBTcl_DStringAppend\fR returns a pointer to the characters of the new string. The string can also be retrieved from the \fIstring\fR field of the Tcl_DString structure. .PP \fBTcl_DStringAppendElement\fR is similar to \fBTcl_DStringAppend\fR except that it doesn't take a \fIlength\fR argument (it appends -all of \fIstring\fR) and it converts the string to a proper list element +all of \fIelement\fR) and it converts the string to a proper list element before appending. \fBTcl_DStringAppendElement\fR adds a separator space before the new list element unless the new list element is the first in a list or sub-list (i.e. either the current string is empty, or it contains the single character ``{'', or the last two characters of ADDED doc/Ensemble.3 Index: doc/Ensemble.3 ================================================================== --- /dev/null +++ doc/Ensemble.3 @@ -0,0 +1,186 @@ +'\" +'\" Copyright (c) 2005 Donal K. Fellows +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" RCS: @(#) $Id: Ensemble.3,v 1.1.2.1 2005/01/20 19:12:28 kennykb Exp $ +'\" +'\" This documents the C API introduced in TIP#235 +'\" +.so man.macros +.TH Tcl_Ensemble 3 8.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_CreateEnsemble, Tcl_FindEnsemble, Tcl_GetEnsembleFlags, Tcl_GetEnsembleMappingDict, Tcl_GetEnsembleNamespace, Tcl_GetEnsembleUnknownHandler, Tcl_GetEnsmelbeSubcommandList, Tcl_IsEnsemble, Tcl_SetEnsembleFlags, Tcl_SetEnsembleMappingDict, Tcl_SetEnsembleSubcommandList, Tcl_SetEnsembleUnknownHandler \- manipulate ensemble commands +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +Tcl_Command +\fBTcl_CreateEnsemble\fR(\fIinterp, name, namespacePtr, ensFlags\fR) +.sp +Tcl_Command +\fBTcl_FindEnsemble\fR(\fIinterp, cmdNameObj, flags\fR) +.sp +int +\fBTcl_IsEnsemble\fR(\fItoken\fR) +.sp +int +\fBTcl_GetEnsembleFlags\fR(\fIinterp, token, ensFlagsPtr\fR) +.sp +int +\fBTcl_SetEnsembleFlags\fR(\fIinterp, token, ensFlags\fR) +.sp +int +\fBTcl_GetEnsembleMappingDict\fR(\fIinterp, token, dictObjPtr\fR) +.sp +int +\fBTcl_SetEnsembleMappingDict\fR(\fIinterp, token, dictObj\fR) +.sp +int +\fBTcl_GetEnsembleSubcommandList\fR(\fIinterp, token, listObjPtr\fR) +.sp +int +\fBTcl_SetEnsembleSubcommandList\fR(\fIinterp, token, listObj\fR) +.sp +int +\fBTcl_GetEnsembleUnknownHandler\fR(\fIinterp, token, listObjPtr\fR) +.sp +int +\fBTcl_SetEnsembleUnknownHandler\fR(\fIinterp, token, listObj\fR) +.sp +int +\fBTcl_GetEnsembleNamespace\fR(\fIinterp, token, namespacePtrPtr\fR) +.SH ARGUMENTS +.AS Tcl_Namespace **namespacePtrPtr in/out +.AP Tcl_Interp *interp in/out +The interpreter in which the ensemble is to be created or found. Also +where error result messages are written. +.AP "const char" *name in +The name of the ensemble command to be created. +.AP Tcl_Namespace *namespacePtr in +The namespace to which the ensemble command is to be bound, or NULL +for the current namespace. +.AP int ensFlags in +An ORed set of flag bits describing the basic configuration of the +ensemble. Currently only one bit has meaning, TCL_ENSEMBLE_PREFIX, +which is present when the ensemble command should also match +unambiguous prefixes of subcommands. +.AP Tcl_Obj *cmdNameObj in +A value holding the name of the ensemble command to look up. +.AP int flags in +An ORed set of flag bits controlling the behavior of +\fBTcl_FindEnsemble\fR. Currently only TCL_LEAVE_ERR_MSG is supported. +.AP Tcl_Command token in +A normal command token that refers to an ensemble command, or which +you wish to use for testing as an ensemble command in \fBTcl_IsEnsemble\fR. +.AP int *ensFlagsPtr out +Pointer to a variable into which to write the current ensemble flag +bits; currently only the bit TCL_ENSEMBLE_PREFIX is defined. +.AP Tcl_Obj *dictObj in +A dictionary value to use for the subcommand to implementation command +prefix mapping dictionary in the ensemble. May be NULL if the mapping +dictionary is to be removed. +.AP Tcl_Obj **dictObjPtr out +Pointer to a variable into which to write the current ensemble mapping +dictionary. +.AP Tcl_Obj *listObj in +A list value to use for the defined list of subcommands in the +dictionary or the unknown subcommmand handler command prefix. May be +NULL if the subcommand list or unknown handler are to be removed. +.AP Tcl_Obj **listObjPtr out +Pointer to a variable into which to write the current defiend list of +subcommands or the current unknown handler prefix. +.AP Tcl_Namespace **namespacePtrPtr out +Pointer to a variable into which to write the handle of the namespace +to which the ensemble is bound. +.BE + +.SH DESCRIPTION +An ensemble is a command, bound to some namespace, which consists of a +collection of subcommands implemented by other Tcl commands. The first +argument to the ensemble command is always interpreted as a selector +that states what subcommand to execute. +.PP +Ensembles are created using \fBTcl_CreateEnsemble\fR, which takes four +arguments: the interpreter to work within, the name of the ensemble to +create, the namespace within the interpreter to bind the ensemble to, +and the default set of ensemble flags. The result of the function is +the command token for the ensemble, which may be used to further +configure the ensemble using the API descibed below in \fBENSEMBLE +PROPERTIES\fR. +.PP +Given the name of an ensemble command, the token for that command may +be retrieved using \fBTcl_FindEnsemble\fR. If the given command name +(in \fIcmdNameObj\fR) does not refer to an ensemble command, the +result of the function is NULL and (if the TCL_LEAVE_ERR_MSG bit is +set in \fIflags\fR) an error message is left in the interpreter +result. +.PP +A command token may be checked to see if it refers to an ensemble +using \fBTcl_IsEnsemble\fR. This returns 1 if the token refers to an +ensemble, or 0 otherwise. +.SS "ENSEMBLE PROPERTIES" +Every ensemble has four read-write properties and a read-only +property. The properties are: +.TP +\fBflags\fR (read-write) +The set of flags for the ensemble, expressed as a +bit-field. Currently, the only public flag is TCL_ENSEMBLE_PREFIX +which is set when unambiguous prefixes of subcommands are permitted to +be resolved to implementations as well as exact matches. The flags may +be read and written using \fBTcl_GetEnsembleFlags\fR and +\fBTcl_SetEnsembleFlags\fR respectively. The result of both of those +functions is a Tcl result code (TCL_OK, or TCL_ERROR if the token does +not refer to an ensemble). +.TP +\fBmapping dictionary\fR (read-write) +A dictionary containing a mapping from subcommand names to lists of +words to use as a command prefix (replacing the first two words of the +command which are the ensemble command itself and the subcommand +name), or NULL if every subcommand is to be mapped to the command with +the same unqualified name in the ensemble's bound namespace. Defaults +to NULL. May be read and written using +\fBTcl_GetEnsembleMappingDict\fR and \fBTcl_SetEnsembleMappingDict\fR +respectively. The result of both of those functions is a Tcl result +code (TCL_OK, or TCL_ERROR if the token does not refer to an +ensemble) and the dictionary obtained from +\fBTcl_GetEnsembleMappingDict\fR should always be treated as immutable +even if it is unshared. +.TP +\fBsubcommand list\fR (read-write) +A list of all the subcommand names for the ensemble, or NULL if this +is to be derived from either the keys of the mapping dictionary (see +above) or (if that is also NULL) from the set of commands exported by +the bound namespace. May be read and written using +\fBTcl_GetEnsembleSubcommandList\fR and +\fBTcl_SetEnsembleSubcommandList\fR respectively. The result of both +of those functions is a Tcl result code (TCL_OK, or TCL_ERROR if the +token does not refer to an ensemble) and the list obtained from +\fBTcl_GetEnsembleSubcommandList\fR should alays be treated as +immutable even if it is unshared. +.TP +\fBunknown subcommand handler command prefix\fR (read-write) +A list of words to prepend on the front of any subcommand when the +subcommand is unknown to the ensemble (according to the current prefix +handling rule); see the \fBnamespace ensemble\fR command for more +details. If NULL, the default behavior \- generate a suitable error +message \- will be used when an unknown subcommand is encountered. May +be read and written using \fBTcl_GetEnsembleUnknownHandler\fR and +\fBTcl_SetEnsembleUnknownHandler\fR respectively. The result of both +functions is a Tcl result code (TCL_OK, or TCL_ERROR if the token does +not refer to an ensemble) and the list obtained from +\fBTcl_GetEnsembleUnknownHandler\fR should always be treated as +immutable even if it is unshared. +.TP +\fBbound namespace\fR (read-only) +The namespace to which the ensemble is bound; when the namespace is +deleted, so too will the ensemble, and this namespace is also the +namespace whose list of exported commands is used if both the mapping +dictionary and the subcommand list properties are NULL. May be read +using \fBTcl_GetEnsembleNamespace\fR which returns a Tcl result code +(TCL_OK, or TCL_ERROR if the token does not refer to an ensemble). + +.SH "SEE ALSO" +namespace(n), Tcl_DeleteCommandFromToken(3) Index: doc/Environment.3 ================================================================== --- doc/Environment.3 +++ doc/Environment.3 @@ -2,11 +2,11 @@ '\" Copyright (c) 1997-1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: Environment.3,v 1.4 2004/10/07 15:15:37 dkf Exp $ +'\" RCS: @(#) $Id: Environment.3,v 1.4.2.1 2005/05/05 17:55:20 kennykb Exp $ '\" .so man.macros .TH Tcl_PutEnv 3 "7.5" Tcl "Tcl Library Procedures" .BS .SH NAME @@ -14,16 +14,16 @@ .SH SYNOPSIS .nf \fB#include \fR .sp int -\fBTcl_PutEnv\fR(\fIstring\fR) +\fBTcl_PutEnv\fR(\fIassignment\fR) .SH ARGUMENTS -.AS "const char" *string -.AP "const char" *string in -Info about environment variable in the form NAME=value. The string is -in native format. +.AS "const char" *assignment +.AP "const char" *assignnment in +Info about environment variable in the format NAME=value. +The \fIassignment\fR argument is in the system encoding. .BE .SH DESCRIPTION .PP \fBTcl_PutEnv\fR sets an environment variable. The information is Index: doc/Eval.3 ================================================================== --- doc/Eval.3 +++ doc/Eval.3 @@ -4,11 +4,11 @@ '\" Copyright (c) 2000 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: Eval.3,v 1.18 2004/10/07 15:15:37 dkf Exp $ +'\" RCS: @(#) $Id: Eval.3,v 1.18.2.3 2005/09/15 20:58:38 dgp Exp $ '\" .so man.macros .TH Tcl_Eval 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME @@ -37,11 +37,11 @@ .sp int \fBTcl_GlobalEvalObj\fR(\fIinterp, objPtr\fR) .sp int -\fBTcl_VarEval\fR(\fIinterp, string, string, ... \fB(char *) NULL\fR) +\fBTcl_VarEval\fR(\fIinterp, part, part, ... \fB(char *) NULL\fR) .sp int \fBTcl_VarEvalVA\fR(\fIinterp, argList\fR) .SH ARGUMENTS .AS Tcl_Interp **termPtr @@ -65,15 +65,15 @@ The number of bytes in \fIscript\fR, not including any null terminating character. If \-1, then all characters up to the first null byte are used. .AP "const char" *script in Points to first byte of script to execute (null-terminated and UTF-8). -.AP char *string in +.AP char *part in String forming part of a Tcl script. .AP va_list argList in An argument list which must have been initialized using -\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR. +\fBva_start\fR, and cleared using \fBva_end\fR. .BE .SH DESCRIPTION .PP The procedures described here are invoked to execute Tcl scripts in @@ -98,16 +98,14 @@ \fBTcl_EvalFile\fR reads the file given by \fIfileName\fR and evaluates its contents as a Tcl script. It returns the same information as \fBTcl_EvalObjEx\fR. If the file couldn't be read then a Tcl error is returned to describe why the file couldn't be read. -.VS 8.4 The eofchar for files is '\\32' (^Z) for all platforms. If you require a ``^Z'' in code for string comparison, you can use ``\\032'' or ``\\u001a'', which will be safely substituted by the Tcl interpreter into ``^Z''. -.VE 8.4 .PP \fBTcl_EvalObjv\fR executes a single pre-parsed command instead of a script. The \fIobjc\fR and \fIobjv\fR arguments contain the values of the words for the Tcl command, one word in each object in \fIobjv\fR. \fBTcl_EvalObjv\fR evaluates the command and returns Index: doc/ExprLong.3 ================================================================== --- doc/ExprLong.3 +++ doc/ExprLong.3 @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: ExprLong.3,v 1.9 2004/10/07 16:05:13 dkf Exp $ +'\" RCS: @(#) $Id: ExprLong.3,v 1.9.2.1 2005/05/05 17:55:21 kennykb Exp $ '\" .so man.macros .TH Tcl_ExprLong 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME @@ -15,25 +15,25 @@ .SH SYNOPSIS .nf \fB#include \fR .sp int -\fBTcl_ExprLong\fR(\fIinterp, string, longPtr\fR) +\fBTcl_ExprLong\fR(\fIinterp, expr, longPtr\fR) +.sp +int +\fBTcl_ExprDouble\fR(\fIinterp, expr, doublePtr\fR) .sp int -\fBTcl_ExprDouble\fR(\fIinterp, string, doublePtr\fR) +\fBTcl_ExprBoolean\fR(\fIinterp, expr, booleanPtr\fR) .sp int -\fBTcl_ExprBoolean\fR(\fIinterp, string, booleanPtr\fR) -.sp -int -\fBTcl_ExprString\fR(\fIinterp, string\fR) +\fBTcl_ExprString\fR(\fIinterp, expr\fR) .SH ARGUMENTS .AS Tcl_Interp *booleanPtr out .AP Tcl_Interp *interp in -Interpreter in whose context to evaluate \fIstring\fR or \fIobjPtr\fR. -.AP "const char" *string in +Interpreter in whose context to evaluate \fIexpr\fR. +.AP "const char" *expr in Expression to be evaluated. .AP long *longPtr out Pointer to location in which to store the integer value of the expression. .AP int *doublePtr out @@ -45,11 +45,11 @@ .BE .SH DESCRIPTION .PP These four procedures all evaluate the expression -given by the \fIstring\fR argument +given by the \fIexpr\fR argument and return the result in one of four different forms. The expression can have any of the forms accepted by the \fBexpr\fR command. Note that these procedures have been largely replaced by the object-based procedures \fBTcl_ExprLongObj\fR, \fBTcl_ExprDoubleObj\fR, \fBTcl_ExprBooleanObj\fR, and \fBTcl_ExprObj\fR. @@ -94,17 +94,11 @@ it must be one of the values accepted by \fBTcl_GetBoolean\fR such as ``yes'' or ``no'', or else an error occurs. .PP \fBTcl_ExprString\fR returns the value of the expression as a string stored in the interpreter's result. -If the expression's actual value is an integer -then \fBTcl_ExprString\fR converts it to a string using \fBsprintf\fR -with a ``%d'' converter. -If the expression's actual value is a floating-point -number, then \fBTcl_ExprString\fR calls \fBTcl_PrintDouble\fR -to convert it to a string. .SH "SEE ALSO" Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj, Tcl_ExprObj .SH KEYWORDS boolean, double, evaluate, expression, integer, object, string Index: doc/ExprLongObj.3 ================================================================== --- doc/ExprLongObj.3 +++ doc/ExprLongObj.3 @@ -2,11 +2,11 @@ '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: ExprLongObj.3,v 1.3 2001/09/03 09:38:50 dkf Exp $ +'\" RCS: @(#) $Id: ExprLongObj.3,v 1.3.16.1 2005/05/05 17:55:21 kennykb Exp $ '\" .so man.macros .TH Tcl_ExprLongObj 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME @@ -27,11 +27,11 @@ int \fBTcl_ExprObj\fR(\fIinterp, objPtr, resultPtrPtr\fR) .SH ARGUMENTS .AS Tcl_Interp **resultPtrPtr out .AP Tcl_Interp *interp in -Interpreter in whose context to evaluate \fIstring\fR or \fIobjPtr\fR. +Interpreter in whose context to evaluate \fIobjPtr\fR. .AP Tcl_Obj *objPtr in Pointer to an object containing the expression to evaluate. .AP long *longPtr out Pointer to location in which to store the integer value of the expression. Index: doc/FileSystem.3 ================================================================== --- doc/FileSystem.3 +++ doc/FileSystem.3 @@ -2,11 +2,11 @@ '\" Copyright (c) 2001 Vincent Darley '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: FileSystem.3,v 1.50 2004/10/07 15:15:37 dkf Exp $ +'\" RCS: @(#) $Id: FileSystem.3,v 1.50.2.4 2005/09/09 18:48:40 dgp Exp $ '\" .so man.macros .TH Filesystem 3 8.4 Tcl "Tcl Library Procedures" .BS .SH NAME @@ -207,10 +207,12 @@ .AP Tcl_PackageInitProc **proc2Ptr out Filled with the safe-init function for this code. .AP ClientData *clientDataPtr out Filled with the clientData value to pass to this code's unload function when it is called. +.AP Tcl_LoadHandle *handlePtr out +Filled with an abstract token representing the loaded file. .AP Tcl_FSUnloadFileProc **unloadProcPtr out Filled with the function to use to unload this piece of code. .AP utimbuf *tval in The access and modification times in this structure are read and used to set those values for a given file. @@ -226,10 +228,21 @@ The base path on to which to join the given elements. May be NULL. .AP int objc in The number of elements in \fIobjv\fR. .AP "Tcl_Obj *const" objv[] in The elements to join to the given base path. +.AP Tcl_Obj *linkNamePtr in +The name of the link to be created or read. +.AP Tcl_Obj *toPtr in +What the link called \fIlinkNamePtr\fR should be linked to, or NULL if +the symbolic link specified by \fIlinkNamePtr\fR is to be read. +.AP int linkAction in +OR-ed combination of flags indicating what kind of link should be +created (will be ignored if \fItoPtr\fR is NULL). Valid bits to set +are \fBTCL_CREATE_SYMBOLIC_LINK\fR and \fBTCL_CREATE_HARD_LINK\fR. +When both flags are set and the underlying filesystem can do either, +symbolic links are preferred. .BE .SH DESCRIPTION .PP There are several reasons for calling the \fBTcl_FS\fR API functions @@ -361,12 +374,13 @@ \fBTcl_FSMatchInDirectory\fR is used by the globbing code to search a directory for all files which match a given pattern. The appropriate function for the filesystem to which \fIpathPtr\fR belongs will be called. .PP The return value is a standard Tcl result indicating whether an error -occurred in globbing. Error messages are placed in interp, but good -results are placed in the resultPtr given. +occurred in globbing. Error messages are placed in interp (unless +interp is NULL, which is allowed), but good results are placed in the +resultPtr given. .PP Note that the \fBglob\fR code implements recursive patterns internally, so this function will only ever be passed simple patterns, which can be matched using the logic of \fBstring match\fR. To handle recursion, Tcl will call this function frequently asking only for directories to be @@ -605,11 +619,11 @@ The string returned is dynamically allocated and owned by the caller, which must store it or call \fBckfree\fR to ensure it is freed. Again, \fBTcl_FSGetNormalizedPath\fR or \fBTcl_GetNativePath\fR are usually better functions to use for most purposes. .PP -\fBTcl_FSNewNativePath\fR performs something like that reverse of the +\fBTcl_FSNewNativePath\fR performs something like the reverse of the usual obj->path->nativerep conversions. If some code retrieves a path in native form (from, e.g. \fBreadlink\fR or a native dialog), and that path is to be used at the Tcl level, then calling this function is an efficient way of creating the appropriate path object type. .PP @@ -1080,13 +1094,14 @@ documented whether \fIpathPtr\fR will have a file separator at its end of not, so code should be flexible to both possibilities. .PP The return value is a standard Tcl result indicating whether an error occurred in the matching process. Error messages are placed in -\fIinterp\fR; on a \fBTCL_OK\fR result, results should be added to the -\fIresultPtr\fR object given (which can be assumed to be a valid -unshared Tcl list). The matches added +\fIinterp\fR, unless \fIinterp\fR in NULL in which case no error +message need be generated; on a \fBTCL_OK\fR result, results should be +added to the \fIresultPtr\fR object given (which can be assumed to be a +valid unshared Tcl list). The matches added to \fIresultPtr\fR should include any path prefix given in \fIpathPtr\fR (this usually means they will be absolute path specifications). Note that if no matches are found, that simply leads to an empty result; errors are only signaled for actual file or filesystem problems which may occur during the matching process. @@ -1401,11 +1416,11 @@ Returns a standard Tcl completion code. If an error occurs, an error message is left in the \fIinterp\fR's result. The function dynamically loads a binary code file into memory. On a successful load, the \fIhandlePtr\fR should be filled with a token for the dynamically loaded file, and the \fIunloadProcPtr\fR should be filled in with the address of a procedure. -The unload procedure will be called with the given Tcl_LoadHandle as its +The unload procedure will be called with the given \fBTcl_LoadHandle\fR as its only parameter when Tcl needs to unload the file. For example, for the native filesystem, the \fBTcl_LoadHandle\fR returned is currently a token which can be used in the private \fBTclpFindSymbol\fR to access functions in the new code. Each filesystem is free to define the \fBTcl_LoadHandle\fR as it requires. Finally, if the Index: doc/GetIndex.3 ================================================================== --- doc/GetIndex.3 +++ doc/GetIndex.3 @@ -2,11 +2,11 @@ '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: GetIndex.3,v 1.16 2004/10/07 16:05:13 dkf Exp $ +'\" RCS: @(#) $Id: GetIndex.3,v 1.16.2.1 2005/04/10 23:14:41 kennykb Exp $ '\" .so man.macros .TH Tcl_GetIndexFromObj 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME @@ -16,16 +16,14 @@ \fB#include \fR .sp int \fBTcl_GetIndexFromObj\fR(\fIinterp, objPtr, tablePtr, msg, flags, indexPtr\fR) -.VS .sp int \fBTcl_GetIndexFromObjStruct\fR(\fIinterp, objPtr, structTablePtr, offset, msg, flags, indexPtr\fR) -.VE .SH ARGUMENTS .AS "const char" *structTablePtr in/out .AP Tcl_Interp *interp in Interpreter to use for error reporting; if NULL, then no message is provided on errors. @@ -84,11 +82,10 @@ operation. Note: \fBTcl_GetIndexFromObj\fR assumes that the entries in \fItablePtr\fR are static: they must not change between invocations. If the value of \fIobjPtr\fR is the empty string, \fBTcl_GetIndexFromObj\fR will treat it as a non-matching value and return \fBTCL_ERROR\fR. -.VS .PP \fBTcl_GetIndexFromObjStruct\fR works just like \fBTcl_GetIndexFromObj\fR, except that instead of treating \fItablePtr\fR as an array of string pointers, it treats it as a pointer to the first string in a series of strings that have @@ -96,12 +93,11 @@ first array of characters at \fItablePtr\fR, a pointer to the second array of characters at \fItablePtr\fR+\fIoffset\fR bytes, etc.) This is particularly useful when processing things like \fBTk_ConfigurationSpec\fR, whose string keys are in the same place in each of several array elements. -.VE .SH "SEE ALSO" Tcl_WrongNumArgs .SH KEYWORDS index, object, table lookup Index: doc/GetInt.3 ================================================================== --- doc/GetInt.3 +++ doc/GetInt.3 @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: GetInt.3,v 1.7 2004/10/07 15:15:38 dkf Exp $ +'\" RCS: @(#) $Id: GetInt.3,v 1.7.2.2 2005/05/05 17:55:21 kennykb Exp $ '\" .so man.macros .TH Tcl_GetInt 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME @@ -15,67 +15,69 @@ .SH SYNOPSIS .nf \fB#include \fR .sp int -\fBTcl_GetInt\fR(\fIinterp, string, intPtr\fR) +\fBTcl_GetInt\fR(\fIinterp, src, intPtr\fR) .sp int -\fBTcl_GetDouble\fR(\fIinterp, string, doublePtr\fR) +\fBTcl_GetDouble\fR(\fIinterp, src, doublePtr\fR) .sp int -\fBTcl_GetBoolean\fR(\fIinterp, string, boolPtr\fR) +\fBTcl_GetBoolean\fR(\fIinterp, src, boolPtr\fR) .SH ARGUMENTS .AS Tcl_Interp *doublePtr out .AP Tcl_Interp *interp in Interpreter to use for error reporting. -.AP "const char" *string in +.AP "const char" *src in Textual value to be converted. .AP int *intPtr out -Points to place to store integer value converted from \fIstring\fR. +Points to place to store integer value converted from \fIsrc\fR. .AP double *doublePtr out Points to place to store double-precision floating-point -value converted from \fIstring\fR. +value converted from \fIsrc\fR. .AP int *boolPtr out -Points to place to store boolean value (0 or 1) converted from \fIstring\fR. +Points to place to store boolean value (0 or 1) converted from \fIsrc\fR. .BE .SH DESCRIPTION .PP These procedures convert from strings to integers or double-precision floating-point values or booleans (represented as 0- or 1-valued -integers). Each of the procedures takes a \fIstring\fR argument, +integers). Each of the procedures takes a \fIsrc\fR argument, converts it to an internal form of a particular type, and stores the converted value at the location indicated by the procedure's third argument. If all goes well, each of the procedures returns -\fBTCL_OK\fR. If \fIstring\fR doesn't have the proper syntax for the +\fBTCL_OK\fR. If \fIsrc\fR doesn't have the proper syntax for the desired type then \fBTCL_ERROR\fR is returned, an error message is left in the interpreter's result, and nothing is stored at *\fIintPtr\fR or *\fIdoublePtr\fR or *\fIboolPtr\fR. .PP -\fBTcl_GetInt\fR expects \fIstring\fR to consist of a collection +\fBTcl_GetInt\fR expects \fIsrc\fR to consist of a collection of integer digits, optionally signed and optionally preceded by -white space. If the first two characters of \fIstring\fR are ``0x'' -then \fIstring\fR is expected to be in hexadecimal form; otherwise, -if the first character of \fIstring\fR is ``0'' then \fIstring\fR -is expected to be in octal form; otherwise, \fIstring\fR is +white space. If the first two characters of \fIsrc\fR +after the optional white space and sign are ``0x'' +then \fIsrc\fR is expected to be in hexadecimal form; otherwise, +if the first such character is ``0'' then \fIsrc\fR +is expected to be in octal form; otherwise, \fIsrc\fR is expected to be in decimal form. .PP -\fBTcl_GetDouble\fR expects \fIstring\fR to consist of a floating-point +\fBTcl_GetDouble\fR expects \fIsrc\fR to consist of a floating-point number, which is: white space; a sign; a sequence of digits; a -decimal point; a sequence of digits; the letter ``e''; and a -signed decimal exponent. Any of the fields may be omitted, except that +decimal point; a sequence of digits; the letter ``e''; a +signed decimal exponent ; and more white space. +Any of the fields may be omitted, except that the digits either before or after the decimal point must be present and if the ``e'' is present then it must be followed by the exponent number. .PP -\fBTcl_GetBoolean\fR expects \fIstring\fR to specify a boolean -value. If \fIstring\fR is any of \fB0\fR, \fBfalse\fR, +\fBTcl_GetBoolean\fR expects \fIsrc\fR to specify a boolean +value. If \fIsrc\fR is any of \fB0\fR, \fBfalse\fR, \fBno\fR, or \fBoff\fR, then \fBTcl_GetBoolean\fR stores a zero value at \fI*boolPtr\fR. -If \fIstring\fR is any of \fB1\fR, \fBtrue\fR, \fByes\fR, or \fBon\fR, +If \fIsrc\fR is any of \fB1\fR, \fBtrue\fR, \fByes\fR, or \fBon\fR, then 1 is stored at \fI*boolPtr\fR. Any of these values may be abbreviated, and upper-case spellings are also acceptable. .SH KEYWORDS boolean, conversion, double, floating-point, integer Index: doc/GetOpnFl.3 ================================================================== --- doc/GetOpnFl.3 +++ doc/GetOpnFl.3 @@ -2,11 +2,11 @@ '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: GetOpnFl.3,v 1.8 2004/10/07 15:15:38 dkf Exp $ +'\" RCS: @(#) $Id: GetOpnFl.3,v 1.8.2.2 2005/05/05 17:55:22 kennykb Exp $ .so man.macros .TH Tcl_GetOpenFile 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_GetOpenFile \- Return a FILE* for a channel registered in the given interpreter (Unix only) @@ -13,27 +13,27 @@ .SH SYNOPSIS .nf \fB#include \fR .sp int -\fBTcl_GetOpenFile\fR(\fIinterp, string, write, checkUsage, filePtr\fR) +\fBTcl_GetOpenFile\fR(\fIinterp, chanID, write, checkUsage, filePtr\fR) .sp .SH ARGUMENTS .AS Tcl_Interp checkUsage out .AP Tcl_Interp *interp in Tcl interpreter from which file handle is to be obtained. -.AP "const char" *string in +.AP "const char" *chanID in String identifying channel, such as \fBstdin\fR or \fBfile4\fR. .AP int write in Non-zero means the file will be used for writing, zero means it will be used for reading. .AP int checkUsage in If non-zero, then an error will be generated if the file wasn't opened for the access indicated by \fIwrite\fR. .AP ClientData *filePtr out Points to word in which to store pointer to FILE structure for -the file given by \fIstring\fR. +the file given by \fIchanID\fR. .BE .SH DESCRIPTION .PP \fBTcl_GetOpenFile\fR takes as argument a file identifier of the form @@ -44,18 +44,16 @@ be used for reading or writing. In some cases, such as a channel that connects to a pipeline of subprocesses, different FILE pointers will be returned for reading and writing. \fBTcl_GetOpenFile\fR normally returns \fBTCL_OK\fR. -If an error occurs in \fBTcl_GetOpenFile\fR (e.g. \fIstring\fR didn't +If an error occurs in \fBTcl_GetOpenFile\fR (e.g. \fIchanID\fR didn't make any sense or \fIcheckUsage\fR was set and the file wasn't opened for the access specified by \fIwrite\fR) then \fBTCL_ERROR\fR is returned and the interpreter's result will contain an error message. In the current implementation \fIcheckUsage\fR is ignored and consistency checks are always performed. -.VS .PP Note that this interface is only supported on the Unix platform. -.VE .SH KEYWORDS channel, file handle, permissions, pipeline, read, write Index: doc/GetTime.3 ================================================================== --- doc/GetTime.3 +++ doc/GetTime.3 @@ -14,14 +14,37 @@ .SH SYNOPSIS .nf \fB#include \fR .sp \fBTcl_GetTime\fR(\fItimePtr\fR) +.sp +\fBTcl_SetTimeProc\fR(\fIgetProc, scaleProc, clientData\fR) +.sp +\fBTcl_QueryTimeProc\fR(\fIgetProcPtr, scaleProcPtr, clientDataPtr\fR) .SH ARGUMENTS .AS "Tcl_Time *" timePtr out .AP "Tcl_Time *" timePtr out Points to memory in which to store the date and time information. +.AS "Tcl_GetTimeProc *" getProc in +.AP "Tcl_GetTimeProc *" getProc in +Pointer to handler function replacing Tcl_GetTime's access to the OS. +.AS "Tcl_ScaleTimeProc *" scaleProc in +.AP "Tcl_ScaleTimeProc *" scaleProc in +Pointer to handler function for the conversion of time delays in the +virtual domain to real-time. +.AS "ClientData *" clientData in +.AP "ClientData *" clientData in +Value passed through to the two handler functions. +.AS "Tcl_GetTimeProc **" getProcPtr inout +.AP "Tcl_GetTimeProc **" getProcPtr inout +Pointer to place the currently registered get handler function into. +.AS "Tcl_ScaleTimeProc **" scaleProcPtr inout +.AP "Tcl_ScaleTimeProc **" scaleProcPtr inout +Pointer to place the currently registered scale handler function into. +.AS "ClientData **" clientDataPtr inout +.AP "ClientData **" clientDataPtr inout +Pointer to place the currently registered pass-through value into. .BE .SH DESCRIPTION .PP The \fBTcl_GetTime\fR function retrieves the current time as a \fITcl_Time\fR structure in memory the caller provides. This @@ -45,9 +68,35 @@ this number as precise as possible, subject to the limitations of the computer system. On multiprocessor variants of Windows, this number may be limited to the 10- or 20-ms granularity of the system clock. (On single-processor Windows systems, the \fIusec\fR field is derived from a performance counter and is highly precise.) +.PP +The \fBTcl_SetTime\fR function registers two related handler functions +with the core. The first handler function is a replacement for +\fBTcl_GetTime\fR, or rather the OS access made by +\fBTcl_GetTime\fR. The other handler function is used by the Tcl +notifier to convert wait/block times from the virtual domain into real +time. +.PP +The \fBTcl_QueryTime\fR function returns the currently registered +handler functions. If no external handlers were set then this will +return the standard handlers accessing and processing the native time +of the OS. The arguments to the function are allowed to be NULL; and +any argument which is NULL is ignored and not set. +.PP +Any handler pair specified has to return data which is consistent +between them. In other words, setting one handler of the pair to +something assuming a 10-times slowdown, and the other handler of the +pair to something assuming a two-times slowdown is wrong and not +allowed. +.PP +The set handler functions are allowed to run the delivered time +backwards, however this should be avoided. We have to allow it as the +native time can run backwards as the user can fiddle with the system +time one way or other. Note that the insertion of the hooks will not +change the behaviour of the Tcl core with regard to this situation, +i.e. the existing behaviour is retained. .SH "SEE ALSO" clock .SH KEYWORDS date, time Index: doc/IntObj.3 ================================================================== --- doc/IntObj.3 +++ doc/IntObj.3 @@ -2,11 +2,11 @@ '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: IntObj.3,v 1.6 2004/10/07 15:37:43 dkf Exp $ +'\" RCS: @(#) $Id: IntObj.3,v 1.6.2.1 2005/04/10 23:14:41 kennykb Exp $ '\" .so man.macros .TH Tcl_IntObj 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME @@ -19,54 +19,44 @@ \fBTcl_NewIntObj\fR(\fIintValue\fR) .sp Tcl_Obj * \fBTcl_NewLongObj\fR(\fIlongValue\fR) .sp -.VS 8.4 Tcl_Obj * \fBTcl_NewWideIntObj\fR(\fIwideValue\fR) -.VE 8.4 .sp \fBTcl_SetIntObj\fR(\fIobjPtr, intValue\fR) .sp \fBTcl_SetLongObj\fR(\fIobjPtr, longValue\fR) .sp -.VS 8.4 \fBTcl_SetWideIntObj\fR(\fIobjPtr, wideValue\fR) -.VE 8.4 .sp int \fBTcl_GetIntFromObj\fR(\fIinterp, objPtr, intPtr\fR) .sp int \fBTcl_GetLongFromObj\fR(\fIinterp, objPtr, longPtr\fR) .sp -.VS 8.4 int \fBTcl_GetWideIntFromObj\fR(\fIinterp, objPtr, widePtr\fR) -.VE 8.4 .SH ARGUMENTS .AS Tcl_WideInt longValue in/out .AP int intValue in Integer value used to initialize or set an integer object. .AP long longValue in Long integer value used to initialize or set an integer object. .AP Tcl_WideInt wideValue in -.VS 8.4 Wide integer value (minimum 64-bits wide where supported by the compiler) used to initialize or set a wide integer object. -.VE 8.4 .AP Tcl_Obj *objPtr in/out For \fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR, and -.VS 8.4 \fBTcl_SetWideIntObj\fR, this points to the object to be converted to integer type. For \fBTcl_GetIntFromObj\fR, \fBTcl_GetLongFromObj\fR, and \fBTcl_GetWideIntFromObj\fR, this refers to the object from which to get an integer or long integer value; if \fIobjPtr\fR does not already point to an integer object (or a wide integer object in the case of \fBTcl_SetWideIntObj\fR and \fBTcl_GetWideIntFromObj\fR), an -.VE 8.4 attempt will be made to convert it to one. .AP Tcl_Interp *interp in/out If an error occurs during conversion, an error message is left in the interpreter's result object unless \fIinterp\fR is NULL. @@ -75,14 +65,12 @@ obtained by \fBTcl_GetIntFromObj\fR from \fIobjPtr\fR. .AP long *longPtr out Points to place to store the long integer value obtained by \fBTcl_GetLongFromObj\fR from \fIobjPtr\fR. .AP Tcl_WideInt *widePtr out -.VS 8.4 Points to place to store the wide integer value obtained by \fBTcl_GetWideIntFromObj\fR from \fIobjPtr\fR. -.VE 8.4 .BE .SH DESCRIPTION .PP These procedures are used to create, modify, and read @@ -89,43 +77,37 @@ integer and wide integer Tcl objects from C code. \fBTcl_NewIntObj\fR, \fBTcl_NewLongObj\fR, \fBTcl_SetIntObj\fR, and \fBTcl_SetLongObj\fR create a new object of integer type or modify an existing object to have integer type, -.VS 8.4 and \fBTcl_NewWideIntObj\fR and \fBTcl_SetWideIntObj\fR create a new object of wide integer type or modify an existing object to have wide integer type. -.VE 8.4 \fBTcl_NewIntObj\fR and \fBTcl_SetIntObj\fR set the object to have the integer value given by \fIintValue\fR, \fBTcl_NewLongObj\fR and \fBTcl_SetLongObj\fR set the object to have the long integer value given by \fIlongValue\fR, -.VS 8.4 and \fBTcl_NewWideIntObj\fR and \fBTcl_SetWideIntObj\fR set the object to have the wide integer value given by \fIwideValue\fR. \fBTcl_NewIntObj\fR, \fBTcl_NewLongObj\fR and \fBTcl_NewWideIntObj\fR return a pointer to a newly created object with reference count zero. These procedures set the object's type to be integer and assign the integer value to the object's internal representation \fIlongValue\fR or \fIwideValue\fR member (as appropriate). \fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR and \fBTcl_SetWideIntObj\fR -.VE 8.4 invalidate any old string representation and, if the object is not already an integer object, free any old internal representation. .PP \fBTcl_GetIntFromObj\fR and \fBTcl_GetLongFromObj\fR attempt to return an integer value from the Tcl object \fIobjPtr\fR, -.VS 8.4 and \fBTcl_GetWideIntFromObj\fR attempts to return a wide integer value from the Tcl object \fIobjPtr\fR. If the object is not already an integer object, or a wide integer object in the case of \fBTcl_GetWideIntFromObj\fR -.VE 8.4 they will attempt to convert it to one. If an error occurs during conversion, they return \fBTCL_ERROR\fR and leave an error message in the interpreter's result object unless \fIinterp\fR is NULL. Also, if the long integer held in the object's internal representation @@ -133,17 +115,15 @@ \fBTcl_GetIntFromObj\fR returns \fBTCL_ERROR\fR and leaves an error message in the interpreter's result object unless \fIinterp\fR is NULL. Otherwise, all three procedures return \fBTCL_OK\fR and store the integer, long integer value -.VS 8.4 or wide integer in the address given by \fIintPtr\fR, \fIlongPtr\fR and \fIwidePtr\fR -.VE 8.4 respectively. If the object is not already an integer or wide integer object, the conversion will free any old internal representation. .SH "SEE ALSO" Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult .SH KEYWORDS integer, integer object, integer type, internal representation, object, object type, string representation Index: doc/Interp.3 ================================================================== --- doc/Interp.3 +++ doc/Interp.3 @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: Interp.3,v 1.7 2004/11/12 09:01:25 das Exp $ +'\" RCS: @(#) $Id: Interp.3,v 1.7.2.1 2005/04/10 23:14:41 kennykb Exp $ '\" .so man.macros .TH Tcl_Interp 3 7.5 Tcl "Tcl Library Procedures" .BS .SH NAME @@ -58,20 +58,18 @@ If a command wishes to return no result then \fIinterp->result\fR should point to an empty string. Normally, results are assumed to be statically allocated, which means that the contents will not change before the next time \fBTcl_Eval\fR is called or some other command procedure is invoked. -.VS In this case, the \fIfreeProc\fR field must be zero. Alternatively, a command procedure may dynamically allocate its return value (e.g. using \fBTcl_Alloc\fR) and store a pointer to it in \fIinterp->result\fR. In this case, the command procedure must also set \fIinterp->freeProc\fR to the address of a procedure that can free the value, or \fBTCL_DYNAMIC\fR if the storage was allocated directly by Tcl or by a call to \fBTcl_Alloc\fR. -.VE If \fIinterp->freeProc\fR is non-zero, then Tcl will call \fIfreeProc\fR to free the space pointed to by \fIinterp->result\fR before it invokes the next command. If a client procedure overwrites \fIinterp->result\fR when \fIinterp->freeProc\fR is non-zero, then it is responsible for calling @@ -79,14 +77,12 @@ macro should be used for this purpose). .PP \fIFreeProc\fR should have arguments and result that match the \fBTcl_FreeProc\fR declaration above: it receives a single argument which is a pointer to the result value to free. -.VS In most applications \fBTCL_DYNAMIC\fR is the only non-zero value ever used for \fIfreeProc\fR. -.VE However, an application may store a different procedure address in \fIfreeProc\fR in order to use an alternate memory allocator or in order to do other cleanup when the result memory is freed. .PP As part of processing each command, \fBTcl_Eval\fR initializes Index: doc/LinkVar.3 ================================================================== --- doc/LinkVar.3 +++ doc/LinkVar.3 @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: LinkVar.3,v 1.9 2004/10/07 15:15:38 dkf Exp $ +'\" RCS: @(#) $Id: LinkVar.3,v 1.9.2.2 2005/09/09 18:48:40 dgp Exp $ '\" .so man.macros .TH Tcl_LinkVar 3 7.5 Tcl "Tcl Library Procedures" .BS .SH NAME @@ -26,20 +26,27 @@ .AS Tcl_Interp writable .AP Tcl_Interp *interp in Interpreter that contains \fIvarName\fR. Also used by \fBTcl_LinkVar\fR to return error messages. .AP "const char" *varName in -Name of global variable. +Name of global variable. .AP char *addr in Address of C variable that is to be linked to \fIvarName\fR. .AP int type in -Type of C variable. Must be one of \fBTCL_LINK_INT\fR, \fBTCL_LINK_DOUBLE\fR, -.VS 8.4 +Type of C variable. Must be one of \fBTCL_LINK_INT\fR, +.VS 8.5 +\fBTCL_LINK_UINT\fR, \fBTCL_LINK_CHAR\fR, \fBTCL_LINK_UCHAR\fR, +\fBTCL_LINK_SHORT\fR, \fBTCL_LINK_USHORT\fR, \fBTCL_LINK_LONG\fR, +\fBTCL_LINK_ULONG\fR, +.VE 8.5 \fBTCL_LINK_WIDE_INT\fR, -.VE 8.4 -\fBTCL_LINK_BOOLEAN\fR, or \fBTCL_LINK_STRING\fR, optionally OR'ed with -\fBTCL_LINK_READ_ONLY\fR to make Tcl variable read-only. +.VS 8.5 +\fBTCL_LINK_WIDE_UINT\fR, \fBTCL_LINK_FLOAT\fR, +.VE 8.5 +\fBTCL_LINK_DOUBLE\fR, \fBTCL_LINK_BOOLEAN\fR, or +\fBTCL_LINK_STRING\fR, optionally OR'ed with \fBTCL_LINK_READ_ONLY\fR +to make Tcl variable read-only. .BE .SH DESCRIPTION .PP \fBTcl_LinkVar\fR uses variable traces to keep the Tcl variable @@ -61,27 +68,103 @@ The C variable is of type \fBint\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetIntFromObj\fR; attempts to write non-integer values into \fIvarName\fR will be rejected with Tcl errors. +.VS 8.5 +.TP +\fBTCL_LINK_UINT\fR +The C variable is of type \fBunsigned int\fR. +Any value written into the Tcl variable must have a proper unsigned +integer form acceptable to \fBTcl_GetWideIntFromObj\fR and in the +platform's defined range for the \fBunsigned int\fR type; attempts to +write non-integer values (or values outside the range) into +\fIvarName\fR will be rejected with Tcl errors. +.TP +\fBTCL_LINK_CHAR\fR +The C variable is of type \fBchar\fR. +Any value written into the Tcl variable must have a proper integer +form acceptable to \fBTcl_GetIntFromObj\fR and be in the range of the +\fBchar\fR datatype; attempts to write non-integer or out-of-range +values into \fIvarName\fR will be rejected with Tcl errors. +.TP +\fBTCL_LINK_UCHAR\fR +The C variable is of type \fBunsigned char\fR. +Any value written into the Tcl variable must have a proper unsigned +integer form acceptable to \fBTcl_GetIntFromObj\fR and in the +platform's defined range for the \fBunsigned char\fR type; attempts to +write non-integer values (or values outside the range) into +\fIvarName\fR will be rejected with Tcl errors. +.TP +\fBTCL_LINK_SHORT\fR +The C variable is of type \fBshort\fR. +Any value written into the Tcl variable must have a proper integer +form acceptable to \fBTcl_GetIntFromObj\fR and be in the range of the +\fBshort\fR datatype; attempts to write non-integer or out-of-range +values into \fIvarName\fR will be rejected with Tcl errors. +.TP +\fBTCL_LINK_USHORT\fR +The C variable is of type \fBunsigned short\fR. +Any value written into the Tcl variable must have a proper unsigned +integer form acceptable to \fBTcl_GetIntFromObj\fR and in the +platform's defined range for the \fBunsigned short\fR type; attempts to +write non-integer values (or values outside the range) into +\fIvarName\fR will be rejected with Tcl errors. +.TP +\fBTCL_LINK_LONG\fR +The C variable is of type \fBlong\fR. +Any value written into the Tcl variable must have a proper integer +form acceptable to \fBTcl_GetLongFromObj\fR; attempts to write +non-integer or out-of-range +values into \fIvarName\fR will be rejected with Tcl errors. +.TP +\fBTCL_LINK_ULONG\fR +The C variable is of type \fBunsigned long\fR. +Any value written into the Tcl variable must have a proper unsigned +integer form acceptable to \fBTcl_GetWideIntFromObj\fR and in the +platform's defined range for the \fBunsigned long\fR type; attempts to +write non-integer values (or values outside the range) into +\fIvarName\fR will be rejected with Tcl errors. +.VE 8.5 .TP \fBTCL_LINK_DOUBLE\fR The C variable is of type \fBdouble\fR. Any value written into the Tcl variable must have a proper real form acceptable to \fBTcl_GetDoubleFromObj\fR; attempts to write non-real values into \fIvarName\fR will be rejected with Tcl errors. +.VS 8.5 +.TP +\fBTCL_LINK_FLOAT\fR +The C variable is of type \fBfloat\fR. +Any value written into the Tcl variable must have a proper real +form acceptable to \fBTcl_GetDoubleFromObj\fR and must be within the +range acceptable for a \fBfloat\fR; attempts to +write non-real values (or values outside the range) into +\fIvarName\fR will be rejected with Tcl errors. +.VE 8.5 .TP \fBTCL_LINK_WIDE_INT\fR -.VS 8.4 The C variable is of type \fBTcl_WideInt\fR (which is an integer type at least 64-bits wide on all platforms that can support it.) Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetWideIntFromObj\fR; attempts to write non-integer values into \fIvarName\fR will be rejected with Tcl errors. -.VE 8.4 +.VS 8.5 +.TP +\fBTCL_LINK_WIDE_UINT\fR +The C variable is of type \fBTcl_WideUInt\fR (which is an unsigned +integer type at least 64-bits wide on all platforms that can support +it.) +Any value written into the Tcl variable must have a proper unsigned +integer form acceptable to \fBTcl_GetWideIntFromObj\fR (it will be +cast to unsigned); +'\" FIXME! Use bignums instead. +attempts to write non-integer values into \fIvarName\fR will be +rejected with Tcl errors. +.VE 8.5 .TP \fBTCL_LINK_BOOLEAN\fR The C variable is of type \fBint\fR. If its value is zero then it will read from Tcl as ``0''; otherwise it will read from Tcl as ``1''. @@ -92,14 +175,12 @@ non-boolean values into \fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_STRING\fR The C variable is of type \fBchar *\fR. -.VS If its value is not NULL then it must be a pointer to a string allocated with \fBTcl_Alloc\fR or \fBckalloc\fR. -.VE Whenever the Tcl variable is modified the current C string will be freed and new memory will be allocated to hold a copy of the variable's new value. If the C variable contains a NULL pointer then the Tcl variable will read as ``NULL''. Index: doc/ListObj.3 ================================================================== --- doc/ListObj.3 +++ doc/ListObj.3 @@ -2,11 +2,11 @@ '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: ListObj.3,v 1.8 2004/10/07 16:05:14 dkf Exp $ +'\" RCS: @(#) $Id: ListObj.3,v 1.8.2.1 2005/04/10 23:14:41 kennykb Exp $ '\" .so man.macros .TH Tcl_ListObj 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME @@ -149,12 +149,13 @@ .PP \fBTcl_ListObjGetElements\fR returns a count and a pointer to an array of the elements in a list object. It returns the count by storing it in the address \fIobjcPtr\fR. Similarly, it returns the array pointer by storing it in the address \fIobjvPtr\fR. -The memory pointed to is managed by Tcl and should not be freed by the -caller. +The memory pointed to is managed by Tcl and should not be freed or written +to by the caller. If the list is empty, 0 is stored at \fIobjcPtr\fR +and NULL at \fIobjvPtr\fR. If \fIlistPtr\fR is not already a list object, \fBTcl_ListObjGetElements\fR will attempt to convert it to one; if the conversion fails, it returns \fBTCL_ERROR\fR and leaves an error message in the interpreter's result object if \fIinterp\fR is not NULL. Otherwise it returns \fBTCL_OK\fR after storing the count and array pointer. Index: doc/Notifier.3 ================================================================== --- doc/Notifier.3 +++ doc/Notifier.3 @@ -3,11 +3,11 @@ '\" Copyright (c) 1995-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: Notifier.3,v 1.13 2004/11/25 16:01:16 vasiljevic Exp $ +'\" RCS: @(#) $Id: Notifier.3,v 1.13.2.1 2005/04/10 23:14:42 kennykb Exp $ '\" .so man.macros .TH Notifier 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME @@ -25,11 +25,10 @@ void \fBTcl_SetMaxBlockTime\fR(\fItimePtr\fR) .sp void \fBTcl_QueueEvent\fR(\fIevPtr, position\fR) -.VS 8.1 .sp void \fBTcl_ThreadQueueEvent\fR(\fIthreadId, evPtr, position\fR) .sp void @@ -65,11 +64,10 @@ int \fBTcl_GetServiceMode\fR() .sp int \fBTcl_SetServiceMode\fR(\fImode\fR) -.VE .SH ARGUMENTS .AS Tcl_EventDeleteProc *deleteProc .AP Tcl_EventSetupProc *setupProc in Procedure to invoke to prepare for event wait in \fBTcl_DoOneEvent\fR. Index: doc/Object.3 ================================================================== --- doc/Object.3 +++ doc/Object.3 @@ -2,11 +2,11 @@ '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: Object.3,v 1.10 2004/10/07 15:15:38 dkf Exp $ +'\" RCS: @(#) $Id: Object.3,v 1.10.2.1 2005/04/10 23:14:42 kennykb Exp $ '\" .so man.macros .TH Tcl_Obj 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME @@ -127,21 +127,19 @@ } \fItwoPtrValue\fR; } \fIinternalRep\fR; } Tcl_Obj; .CE The \fIbytes\fR and the \fIlength\fR members together hold -.VS 8.1 an object's UTF-8 string representation, which is a \fIcounted string\fR not containing null bytes (UTF-8 null characters should be encoded as a two byte sequence: 192, 128.) \fIbytes\fR points to the first byte of the string representation. The \fIlength\fR member gives the number of bytes. The byte array must always have a null byte after the last data byte, at offset \fIlength\fR; this allows string representations to be treated as conventional null-terminated C strings. -.VE 8.1 C programs use \fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR to get an object's string representation. If \fIbytes\fR is NULL, the string representation is invalid. .PP Index: doc/OpenFileChnl.3 ================================================================== --- doc/OpenFileChnl.3 +++ doc/OpenFileChnl.3 @@ -2,17 +2,17 @@ '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: OpenFileChnl.3,v 1.29 2004/10/07 15:37:44 dkf Exp $ +'\" RCS: @(#) $Id: OpenFileChnl.3,v 1.29.2.2 2005/07/12 20:36:15 kennykb Exp $ .so man.macros .TH Tcl_OpenFileChannel 3 8.3 Tcl "Tcl Library Procedures" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -Tcl_OpenFileChannel, Tcl_OpenCommandChannel, Tcl_MakeFileChannel, Tcl_GetChannel, Tcl_GetChannelNames, Tcl_GetChannelNamesEx, Tcl_RegisterChannel, Tcl_UnregisterChannel, Tcl_DetachChannel, Tcl_IsStandardChannel, Tcl_Close, Tcl_ReadChars, Tcl_Read, Tcl_GetsObj, Tcl_Gets, Tcl_WriteObj, Tcl_WriteChars, Tcl_Write, Tcl_Flush, Tcl_Seek, Tcl_Tell, Tcl_GetChannelOption, Tcl_SetChannelOption, Tcl_Eof, Tcl_InputBlocked, Tcl_InputBuffered, Tcl_OutputBuffered, Tcl_Ungets, Tcl_ReadRaw, Tcl_WriteRaw \- buffered I/O facilities using channels +Tcl_OpenFileChannel, Tcl_OpenCommandChannel, Tcl_MakeFileChannel, Tcl_GetChannel, Tcl_GetChannelNames, Tcl_GetChannelNamesEx, Tcl_RegisterChannel, Tcl_UnregisterChannel, Tcl_DetachChannel, Tcl_IsStandardChannel, Tcl_Close, Tcl_ReadChars, Tcl_Read, Tcl_GetsObj, Tcl_Gets, Tcl_WriteObj, Tcl_WriteChars, Tcl_Write, Tcl_Flush, Tcl_Seek, Tcl_Tell, Tcl_TruncateChannel, Tcl_GetChannelOption, Tcl_SetChannelOption, Tcl_Eof, Tcl_InputBlocked, Tcl_InputBuffered, Tcl_OutputBuffered, Tcl_Ungets, Tcl_ReadRaw, Tcl_WriteRaw \- buffered I/O facilities using channels .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Channel @@ -87,21 +87,24 @@ int \fBTcl_InputBlocked\fR(\fIchannel\fR) .sp int \fBTcl_InputBuffered\fR(\fIchannel\fR) -.VS 8.4 .sp int \fBTcl_OutputBuffered\fR(\fIchannel\fR) -.VE .sp Tcl_WideInt \fBTcl_Seek\fR(\fIchannel, offset, seekMode\fR) .sp Tcl_WideInt \fBTcl_Tell\fR(\fIchannel\fR) +.sp +.VS 8.5 +int +\fBTcl_TruncateChannel\fR(\fIchannel, length\fR) +.VE 8.5 .sp int \fBTcl_GetChannelOption\fR(\fIinterp, channel, optionName, optionValue\fR) .sp int @@ -196,10 +199,12 @@ given by \fIseekMode\fR. May be either positive or negative. .AP int seekMode in Relative to which point to seek; used with \fIoffset\fR to calculate the new access point for the channel. Legal values are \fBSEEK_SET\fR, \fBSEEK_CUR\fR, and \fBSEEK_END\fR. +.AP Tcl_WideInt length in +The (non-negative) length to truncate the channel the channel to. .AP "const char" *optionName in The name of an option applicable to this channel, such as \fB\-blocking\fR. May have any of the values accepted by the \fBfconfigure\fR command. .AP Tcl_DString *optionValue in Where to store the value of an option or a list of all options and their @@ -591,10 +596,18 @@ .SH TCL_TELL .PP \fBTcl_Tell\fR returns the current access point for a channel. The returned value is \-1 if the channel does not support seeking. + +.SH TCL_TRUNCATECHANNEL +.PP +.VS 8.5 +\fBTcl_TruncateChannel\fR truncates the file underlying \fIchannel\fR +to a given \fIlength\fR of bytes. It returns \fBTCL_OK\fR if the +operation succeeded, and \fBTCL_ERROR\fR otherwise. +.VE 8.5 .SH TCL_GETCHANNELOPTION .PP \fBTcl_GetChannelOption\fR retrieves, in \fIoptionValue\fR, the value of one of the options currently in effect for a channel, or a list of all options and @@ -641,15 +654,13 @@ \fBTcl_InputBuffered\fR returns the number of bytes of input currently buffered in the internal buffers for a channel. If the channel is not open for reading, this function always returns zero. .SH TCL_OUTPUTBUFFERED -.VS 8.4 \fBTcl_OutputBuffered\fR returns the number of bytes of output currently buffered in the internal buffers for a channel. If the channel is not open for writing, this function always returns zero. -.VE .SH "PLATFORM ISSUES" .PP The handles returned from \fBTcl_GetChannelHandle\fR depend on the platform and the channel type. On Unix platforms, the handle is Index: doc/OpenTcp.3 ================================================================== --- doc/OpenTcp.3 +++ doc/OpenTcp.3 @@ -2,11 +2,11 @@ '\" Copyright (c) 1996-7 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: OpenTcp.3,v 1.8 2004/10/07 15:15:42 dkf Exp $ +'\" RCS: @(#) $Id: OpenTcp.3,v 1.8.2.1 2005/04/10 23:14:42 kennykb Exp $ .so man.macros .TH Tcl_OpenTcpClient 3 8.0 Tcl "Tcl Library Procedures" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -161,18 +161,16 @@ register it, use \fBTcl_RegisterChannel\fR. If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was previously closed, the act of creating the new channel also assigns it as a replacement for the standard channel. -.VS .SH "PLATFORM ISSUES" .PP On Unix platforms, the socket handle is a Unix file descriptor as returned by the \fBsocket\fR system call. On the Windows platform, the socket handle is a \fBSOCKET\fR as defined in the WinSock API. -.VE .SH "SEE ALSO" Tcl_OpenFileChannel(3), Tcl_RegisterChannel(3), vwait(n) .SH KEYWORDS client, server, TCP Index: doc/Panic.3 ================================================================== --- doc/Panic.3 +++ doc/Panic.3 @@ -1,10 +1,10 @@ '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: Panic.3,v 1.7 2004/10/07 15:15:47 dkf Exp $ +'\" RCS: @(#) $Id: Panic.3,v 1.7.2.1 2005/09/15 20:58:38 dgp Exp $ '\" .so man.macros .TH Tcl_Panic 3 8.4 Tcl "Tcl Library Procedures" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -29,11 +29,11 @@ A printf-style format string. .AP "" arg in Arguments matching the format string. .AP va_list argList in An argument list of arguments matching the format string. -Must have been initialized using \fBTCL_VARARGS_START\fR, +Must have been initialized using \fBva_start\fR, and cleared using \fBva_end\fR. .AP Tcl_PanicProc *panicProc in Procedure to report fatal error message and abort. .BE Index: doc/ParseCmd.3 ================================================================== --- doc/ParseCmd.3 +++ doc/ParseCmd.3 @@ -2,11 +2,11 @@ '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: ParseCmd.3,v 1.18 2004/10/07 16:05:15 dkf Exp $ +'\" RCS: @(#) $Id: ParseCmd.3,v 1.18.2.3 2005/09/26 20:16:53 kennykb Exp $ '\" .so man.macros .TH Tcl_ParseCommand 3 8.3 Tcl "Tcl Library Procedures" .BS .SH NAME @@ -14,26 +14,26 @@ .SH SYNOPSIS .nf \fB#include \fR .sp int -\fBTcl_ParseCommand\fR(\fIinterp, string, numBytes, nested, parsePtr\fR) -.sp -int -\fBTcl_ParseExpr\fR(\fIinterp, string, numBytes, parsePtr\fR) -.sp -int -\fBTcl_ParseBraces\fR(\fIinterp, string, numBytes, parsePtr, append, termPtr\fR) -.sp -int -\fBTcl_ParseQuotedString\fR(\fIinterp, string, numBytes, parsePtr, append, termPtr\fR) -.sp -int -\fBTcl_ParseVarName\fR(\fIinterp, string, numBytes, parsePtr, append\fR) -.sp -const char * -\fBTcl_ParseVar\fR(\fIinterp, string, termPtr\fR) +\fBTcl_ParseCommand\fR(\fIinterp, start, numBytes, nested, parsePtr\fR) +.sp +int +\fBTcl_ParseExpr\fR(\fIinterp, start, numBytes, parsePtr\fR) +.sp +int +\fBTcl_ParseBraces\fR(\fIinterp, start, numBytes, parsePtr, append, termPtr\fR) +.sp +int +\fBTcl_ParseQuotedString\fR(\fIinterp, start, numBytes, parsePtr, append, termPtr\fR) +.sp +int +\fBTcl_ParseVarName\fR(\fIinterp, start, numBytes, parsePtr, append\fR) +.sp +const char * +\fBTcl_ParseVar\fR(\fIinterp, start, termPtr\fR) .sp \fBTcl_FreeParse\fR(\fIusedParsePtr\fR) .sp Tcl_Obj * \fBTcl_EvalTokens\fR(\fIinterp, tokenPtr, numTokens\fR) @@ -47,16 +47,16 @@ and \fBTcl_EvalTokensStandard\fR, used only for error reporting; if NULL, then no error messages are left after errors. For \fBTcl_EvalTokens\fR and \fBTcl_EvalTokensStandard\fR, determines the context for evaluating the script and also is used for error reporting; must not be NULL. -.AP "const char" *string in +.AP "const char" *start in Pointer to first character in string to parse. .AP int numBytes in -Number of bytes in \fIstring\fR, not including any terminating null +Number of bytes in string to parse, not including any terminating null character. If less than 0 then the script consists of all characters -in \fIstring\fR up to the first null character. +following \fIstart\fR up to the first null character. .AP int nested in Non-zero means that the script is part of a command substitution so an unquoted close bracket should be treated as a command terminator. If zero, close brackets have no special meaning. .AP int append in @@ -106,11 +106,11 @@ \fBTCL_ERROR\fR is returned, an error message is left in \fIinterp\fR's result, and no information is left at \fI*parsePtr\fR. .PP \fBTcl_ParseExpr\fR parses Tcl expressions. Given a pointer to a script containing an expression, -\fBTcl_ParseCommand\fR parses the expression. +\fBTcl_ParseExpr\fR parses the expression. If the expression was parsed successfully, \fBTcl_ParseExpr\fR returns \fBTCL_OK\fR and fills in the structure pointed to by \fIparsePtr\fR with information about the structure of the expression (see below for details). If an error occurred in parsing the command then @@ -118,12 +118,12 @@ result, and no information is left at \fI*parsePtr\fR. .PP \fBTcl_ParseBraces\fR parses a string or command argument enclosed in braces such as \fB{hello}\fR or \fB{string \\t with \\t tabs}\fR -from the beginning of its argument \fIstring\fR. -The first character of \fIstring\fR must be \fB{\fR. +from the beginning of its argument \fIstart\fR. +The first character of \fIstart\fR must be \fB{\fR. If the braced string was parsed successfully, \fBTcl_ParseBraces\fR returns \fBTCL_OK\fR, fills in the structure pointed to by \fIparsePtr\fR with information about the structure of the string (see below for details), @@ -134,12 +134,12 @@ an error message is left in \fIinterp\fR's result, and no information is left at \fI*parsePtr\fR or \fI*termPtr\fR. .PP \fBTcl_ParseQuotedString\fR parses a double-quoted string such as \fB"sum is [expr $a+$b]"\fR -from the beginning of the argument \fIstring\fR. -The first character of \fIstring\fR must be \fB"\fR. +from the beginning of the argument \fIstart\fR. +The first character of \fIstart\fR must be \fB"\fR. If the double-quoted string was parsed successfully, \fBTcl_ParseQuotedString\fR returns \fBTCL_OK\fR, fills in the structure pointed to by \fIparsePtr\fR with information about the structure of the string (see below for details), @@ -150,23 +150,23 @@ an error message is left in \fIinterp\fR's result, and no information is left at \fI*parsePtr\fR or \fI*termPtr\fR. .PP \fBTcl_ParseVarName\fR parses a Tcl variable reference such as \fB$abc\fR or \fB$x([expr $index + 1])\fR from the beginning of its -\fIstring\fR argument. -The first character of \fIstring\fR must be \fB$\fR. +\fIstart\fR argument. +The first character of \fIstart\fR must be \fB$\fR. If a variable name was parsed successfully, \fBTcl_ParseVarName\fR returns \fBTCL_OK\fR and fills in the structure pointed to by \fIparsePtr\fR with information about the structure of the variable name (see below for details). If an error occurs while parsing the command then \fBTCL_ERROR\fR is returned, an error message is left in \fIinterp\fR's result (if \fIinterp\fR isn't NULL), and no information is left at \fI*parsePtr\fR. .PP \fBTcl_ParseVar\fR parse a Tcl variable reference such as \fB$abc\fR -or \fB$x([expr $index + 1])\fR from the beginning of its \fIstring\fR -argument. The first character of \fIstring\fR must be \fB$\fR. If +or \fB$x([expr $index + 1])\fR from the beginning of its \fIstart\fR +argument. The first character of \fIstart\fR must be \fB$\fR. If the variable name is parsed successfully, \fBTcl_ParseVar\fR returns a pointer to the string value of the variable. If an error occurs while parsing, then NULL is returned and an error message is left in \fIinterp\fR's result. .PP @@ -293,11 +293,11 @@ the command parser notes this word began with the expansion prefix \fB{expand}\fR, indicating that after substitution, the list value of this word should be expanded to form multiple arguments in command evaluation. This token type can only be created by Tcl_ParseCommand. -.VE +.VE 8.5 .TP \fBTCL_TOKEN_TEXT\fR The token describes a range of literal text that is part of a word. The \fInumComponents\fR field is always 0. .TP @@ -429,11 +429,11 @@ the array of tokens pointed to by the \fItokenPtr\fR field of the Tcl_Parse structure depends on the contents of the quoted string. It will consist of one or more \fBTCL_TOKEN_TEXT\fR, \fBTCL_TOKEN_BS\fR, \fBTCL_TOKEN_COMMAND\fR, and \fBTCL_TOKEN_VARIABLE\fR sub-tokens. The array always contains at least one token; -for example, if the argument \fIstring\fR is empty, +for example, if the argument \fIstart\fR is empty, the array returned consists of a single \fBTCL_TOKEN_TEXT\fR token with a zero \fIsize\fR field. Only the token information in the Tcl_Parse structure is modified: the \fIcommentStart\fR, \fIcommentSize\fR, \fIcommandStart\fR, and \fIcommandSize\fR fields are not modified. @@ -450,11 +450,11 @@ the \fIcommentStart\fR, \fIcommentSize\fR, \fIcommandStart\fR, and \fIcommandSize\fR fields are not modified. .PP All of the character pointers in the Tcl_Parse and Tcl_Token structures refer -to characters in the \fIstring\fR argument passed to +to characters in the \fIstart\fR argument passed to \fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR, \fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR. .PP There are additional fields in the Tcl_Parse structure after the \fInumTokens\fR field, but these are for the private use of Index: doc/PrintDbl.3 ================================================================== --- doc/PrintDbl.3 +++ doc/PrintDbl.3 @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: PrintDbl.3,v 1.5 2004/10/07 14:44:33 dkf Exp $ +'\" RCS: @(#) $Id: PrintDbl.3,v 1.5.2.2 2005/04/10 23:14:42 kennykb Exp $ '\" .so man.macros .TH Tcl_PrintDouble 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME @@ -18,16 +18,14 @@ .sp \fBTcl_PrintDouble\fR(\fIinterp, value, dst\fR) .SH ARGUMENTS .AS Tcl_Interp *interp out .AP Tcl_Interp *interp in -.VS Before Tcl 8.0, the \fBtcl_precision\fR variable in this interpreter controlled the conversion. As of Tcl 8.0, this argument is ignored and the conversion is controlled by the \fBtcl_precision\fR variable that is now shared by all interpreters. -.VE .AP double value in Floating-point value to be converted. .AP char *dst out Where to store the string representing \fIvalue\fR. Must have at least \fBTCL_DOUBLE_SPACE\fR characters of storage. @@ -40,8 +38,17 @@ \fIdst\fR. It uses \fB%g\fR format to generate the string, with one special twist: the string is guaranteed to contain either a ``.'' or an ``e'' so that it doesn't look like an integer. Where \fB%g\fR would generate an integer with no decimal point, \fBTcl_PrintDouble\fR adds ``.0''. +.VS 8.5 +.PP +If the \fBtcl_precision\fR value is non-zero, the result will have +precisely that many digits of significance. If the value is zero +(the default), the result will have the fewest digits needed to +represent the number in such a way that \fBTcl_NewDoubleObj\fR +will generate the same number when presented with the given string. +IEEE semantics of rounding to even apply to the conversion. +.VE .SH KEYWORDS conversion, double-precision, floating-point, string Index: doc/RegExp.3 ================================================================== --- doc/RegExp.3 +++ doc/RegExp.3 @@ -4,11 +4,11 @@ '\" Copyright (c) 1998-1999 Scriptics Corporation '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: RegExp.3,v 1.20 2004/10/07 16:22:16 dkf Exp $ +'\" RCS: @(#) $Id: RegExp.3,v 1.20.2.2 2005/05/05 17:55:22 kennykb Exp $ '\" .so man.macros .TH Tcl_RegExpMatch 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME @@ -16,78 +16,71 @@ .SH SYNOPSIS .nf \fB#include \fR .sp int -\fBTcl_RegExpMatchObj\fR(\fIinterp\fR, \fIstrObj\fR, \fIpatObj\fR) +\fBTcl_RegExpMatchObj\fR(\fIinterp\fR, \fItextObj\fR, \fIpatObj\fR) .sp int -\fBTcl_RegExpMatch\fR(\fIinterp\fR, \fIstring\fR, \fIpattern\fR) +\fBTcl_RegExpMatch\fR(\fIinterp\fR, \fItext\fR, \fIpattern\fR) .sp Tcl_RegExp \fBTcl_RegExpCompile\fR(\fIinterp\fR, \fIpattern\fR) .sp int -\fBTcl_RegExpExec\fR(\fIinterp\fR, \fIregexp\fR, \fIstring\fR, \fIstart\fR) +\fBTcl_RegExpExec\fR(\fIinterp\fR, \fIregexp\fR, \fItext\fR, \fIstart\fR) .sp void \fBTcl_RegExpRange\fR(\fIregexp\fR, \fIindex\fR, \fIstartPtr\fR, \fIendPtr\fR) .sp Tcl_RegExp \fBTcl_GetRegExpFromObj\fR(\fIinterp\fR, \fIpatObj\fR, \fIcflags\fR) .sp int -\fBTcl_RegExpExecObj\fR(\fIinterp\fR, \fIregexp\fR, \fIobjPtr\fR, \fIoffset\fR, \fInmatches\fR, \fIeflags\fR) +\fBTcl_RegExpExecObj\fR(\fIinterp\fR, \fIregexp\fR, \fItextObj\fR, \fIoffset\fR, \fInmatches\fR, \fIeflags\fR) .sp void \fBTcl_RegExpGetInfo\fR(\fIregexp\fR, \fIinfoPtr\fR) .SH ARGUMENTS .AS Tcl_RegExpInfo *interp in/out .AP Tcl_Interp *interp in Tcl interpreter to use for error reporting. The interpreter may be NULL if no error reporting is desired. -.AP Tcl_Obj *strObj in/out -Refers to the object from which to get the string to search. The +.AP Tcl_Obj *textObj in/out +Refers to the object from which to get the text to search. The internal representation of the object may be converted to a form that can be efficiently searched. .AP Tcl_Obj *patObj in/out Refers to the object from which to get a regular expression. The compiled regular expression is cached in the object. -.AP char *string in -String to check for a match with a regular expression. +.AP char *text in +Text to search for a match with a regular expression. .AP "const char" *pattern in String in the form of a regular expression pattern. .AP Tcl_RegExp regexp in Compiled regular expression. Must have been returned previously by \fBTcl_GetRegExpFromObj\fR or \fBTcl_RegExpCompile\fR. .AP char *start in -If \fIstring\fR is just a portion of some other string, this argument +If \fItext\fR is just a portion of some other string, this argument identifies the beginning of the larger string. -If it isn't the same as \fIstring\fR, then no \fB^\fR matches +If it isn't the same as \fItext\fR, then no \fB^\fR matches will be allowed. .AP int index in Specifies which range is desired: 0 means the range of the entire match, 1 or greater means the range that matched a parenthesized sub-expression. .AP "const char" **startPtr out -.VS 8.4 The address of the first character in the range is stored here, or NULL if there is no such range. -.VE 8.4 .AP "const char" **endPtr out -.VS 8.4 The address of the character just after the last one in the range is stored here, or NULL if there is no such range. -.VE 8.4 .AP int cflags in OR-ed combination of compilation flags. See below for more information. -.AP Tcl_Obj *objPtr in/out -An object which contains the string to check for a match with a -regular expression. .AP int offset in -The character offset into the string where matching should begin. +The character offset into the text where matching should begin. The value of the offset has no impact on \fB^\fR matches. This behavior is controlled by \fIeflags\fR. .AP int nmatches in The number of matching subexpressions that should be remembered for later use. If this value is 0, then no subexpression match @@ -113,11 +106,11 @@ If there is no match then \fBTcl_RegExpMatch\fR returns 0. If an error occurs in the matching process (e.g. \fIpattern\fR is not a valid regular expression) then \fBTcl_RegExpMatch\fR returns \-1 and leaves an error message in the interpreter result. \fBTcl_RegExpMatchObj\fR is similar to \fBTcl_RegExpMatch\fR except it -operates on the Tcl objects \fIstrObj\fR and \fIpatObj\fR instead of +operates on the Tcl objects \fItextObj\fR and \fIpatObj\fR instead of UTF strings. \fBTcl_RegExpMatchObj\fR is generally more efficient than \fBTcl_RegExpMatch\fR, so it is the preferred interface. .PP \fBTcl_RegExpCompile\fR, \fBTcl_RegExpExec\fR, and \fBTcl_RegExpRange\fR @@ -132,27 +125,27 @@ Note: the return value from \fBTcl_RegExpCompile\fR is only valid up to the next call to \fBTcl_RegExpCompile\fR; it is not safe to retain these values for long periods of time. .PP \fBTcl_RegExpExec\fR executes the regular expression pattern matcher. -It returns 1 if \fIstring\fR contains a range of characters that +It returns 1 if \fItext\fR contains a range of characters that match \fIregexp\fR, 0 if no match is found, and \-1 if an error occurs. In the case of an error, \fBTcl_RegExpExec\fR leaves an error message in the interpreter result. When searching a string for multiple matches of a pattern, it is important to distinguish between the start of the original string and the start of the current search. For example, when searching for the second occurrence of a -match, the \fIstring\fR argument might point to the character +match, the \fItext\fR argument might point to the character just after the first match; however, it is important for the pattern matcher to know that this is not the start of the entire string, so that it doesn't allow \fB^\fR atoms in the pattern to match. The \fIstart\fR argument provides this information by pointing -to the start of the overall string containing \fIstring\fR. -\fIStart\fR will be less than or equal to \fIstring\fR; if it -is less than \fIstring\fR then no \fB^\fR matches will be allowed. +to the start of the overall string containing \fItext\fR. +\fIStart\fR will be less than or equal to \fItext\fR; if it +is less than \fItext\fR then no \fB^\fR matches will be allowed. .PP \fBTcl_RegExpRange\fR may be invoked after \fBTcl_RegExpExec\fR returns; it provides detailed information about what ranges of the string matched what parts of the pattern. \fBTcl_RegExpRange\fR returns a pair of pointers in \fI*startPtr\fR Index: doc/SaveResult.3 ================================================================== --- doc/SaveResult.3 +++ doc/SaveResult.3 @@ -3,11 +3,11 @@ '\" Contributions from Don Porter, NIST, 2004. (not subject to US copyright) '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: SaveResult.3,v 1.4 2004/11/20 00:17:31 dgp Exp $ +'\" RCS: @(#) $Id: SaveResult.3,v 1.4.2.2 2005/04/10 23:14:42 kennykb Exp $ '\" .so man.macros .TH Tcl_SaveResult 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME @@ -15,22 +15,22 @@ .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_InterpState -\fBTcl_SaveInterpState(\fIinterp, status\fB)\fR +\fBTcl_SaveInterpState\fR(\fIinterp, status\fR) .sp int -\fBTcl_RestoreInterpState(\fIinterp, state\fB)\fR -.sp -\fBTcl_DiscardInterpState(\fIstate\fB)\fR -.sp -\fBTcl_SaveResult(\fIinterp, savedPtr\fB)\fR -.sp -\fBTcl_RestoreResult(\fIinterp, savedPtr\fB)\fR -.sp -\fBTcl_DiscardResult(\fIsavedPtr\fB)\fR +\fBTcl_RestoreInterpState\fR(\fIinterp, state\fR) +.sp +\fBTcl_DiscardInterpState\fR(\fIstate\fR) +.sp +\fBTcl_SaveResult\fR(\fIinterp, savedPtr\fR) +.sp +\fBTcl_RestoreResult\fR(\fIinterp, savedPtr\fR) +.sp +\fBTcl_DiscardResult\fR(\fIsavedPtr\fR) .SH ARGUMENTS .AS Tcl_InterpState savedPtr .AP Tcl_Interp *interp in Interpreter for which state should be saved. .AP int status in @@ -64,15 +64,15 @@ procedure. These routines do not save the state of any error information in the interpreter (e.g. the \fB-errorcode\fR or \fB-errorinfo\fR return options, when an error is in progress). .PP Because the routines \fBTcl_SaveInterpState\fR, -\fBTcl_RestoreInterpState\fB, and \fBTcl_DiscardInterpState\fR perform +\fBTcl_RestoreInterpState\fR, and \fBTcl_DiscardInterpState\fR perform a superset of the functions provided by the other routines, any new code should only make use of the more powerful routines. -The older, weaker routines \fBTcl_SaveResult\fB, \fBTcl_RestoreResult\fB, -and \fBTcl_DiscardResult\fB continue to exist only for the sake +The older, weaker routines \fBTcl_SaveResult\fR, \fBTcl_RestoreResult\fR, +and \fBTcl_DiscardResult\fR continue to exist only for the sake of existing programs that may already be using them. .PP \fBTcl_SaveInterpState\fR takes a snapshot of those portions of interpreter state that make up the full result of script evaluation. This include the interpreter result, the return code (passed in @@ -97,11 +97,11 @@ The \fBTcl_InterpState\fR token returned by \fBTcl_SaveInterpState\fR must eventually be passed to either \fBTcl_RestoreInterpState\fR or \fBTcl_DiscardInterpState\fR to avoid a memory leak. Once the \fBTcl_InterpState\fR token is passed to one of them, the token is no longer valid and should not be used anymore. -.VE +.VE 8.5 .PP \fBTcl_SaveResult\fR moves the string and object results of \fIinterp\fR into the location specified by \fIstatePtr\fR. \fBTcl_SaveResult\fR clears the result for \fIinterp\fR and leaves the result in its normal empty initialized state. ADDED doc/SetChanErr.3 Index: doc/SetChanErr.3 ================================================================== --- /dev/null +++ doc/SetChanErr.3 @@ -0,0 +1,155 @@ +'\" +'\" Copyright (c) 2005 Andreas Kupries +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" RCS: @(#) $Id: SetChanErr.3,v 1.1.2.2 2005/08/25 15:46:30 dgp Exp $ +.so man.macros +.TH Tcl_SetChannelError 3 8.5 Tcl "Tcl Library Procedures" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +Tcl_SetChannelError, Tcl_SetChannelErrorInterp, Tcl_GetChannelError, Tcl_GetChannelErrorInterp \- functions to create/intercept Tcl errors by channel drivers. +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +void +\fBTcl_SetChannelError\fR(\fIchan, msg\fR) +.sp +void +\fBTcl_SetChannelErrorInterp\fR(\fIinterp, msg\fR) +.sp +void +\fBTcl_GetChannelError\fR(\fIchan, msgPtr\fR) +.sp +void +\fBTcl_GetChannelErrorInterp\fR(\fIinterp, msgPtr\fR) +.sp +.SH ARGUMENTS +.AS Tcl_Channel chan +.AP Tcl_Channel chan in +Refers to the Tcl channel whose bypass area is accessed. +.AP Tcl_Interp* interp in +Refers to the Tcl interpreter whose bypass area is accessed. +.AP Tcl_Obj* msg in +Error message put into a bypass area. A list of return options and +values, followed by a string message. Both message and the +option/value information are optional. +.AP Tcl_Obj** msgPtr out +Reference to a place where the message stored in the accessed bypass +area can be stored in. +.BE +.SH DESCRIPTION +.PP +The current definition of a Tcl channel driver does not permit the +direct return of arbitrary error messages, except for the setting and +retrieval of channel options. All other functions are restricted to +POSIX error codes. +.PP +The functions described here overcome this limitation. Channel drivers +are allowed to use \fBTcl_SetChannelError\fR and +\fBTcl_SetChannelErrorInterp\fR to place arbitrary error messages in +\fBbypass areas\fI defined for channels and interpreters. And the +generic I/O layer uses \fBTcl_GetChannelError\fR and +\fBTcl_GetChannelErrorInterp\fR to look for messages in the bypass +areas and arrange for their return as errors. The posix error codes +set by a driver are used now if and only if no messages are present. +.PP +\fBTcl_SetChannelError\fR stores error information in the bypass area +of the specified channel. The number of references to the \fBmsg\fI +object goes up by one. Previously stored information will be +discarded, by releasing the reference held by the channel. The channel +reference must not be NULL. +.PP +\fBTcl_SetChannelErrorInterp\fR stores error information in the bypass +area of the specified interpreter. The number of references to the +\fBmsg\fI object goes up by one. Previously stored information will be +discarded, by releasing the reference held by the interpreter. The +interpreter reference must not be NULL. +.PP +\fBTcl_GetChannelError\fR places either the error message held in the +bypass area of the specified channel into \fImsgPtr\fR, or NULL; and +resets the bypass. I.e. after an invokation all following invokations +will return NULL, until an intervening invokation of +\fBTcl_SetChannelError\fR with a non-NULL message. The \fImsgPtr\fR +must not be NULL. The reference count of the message is not touched. +The reference previously held by the channel is now held by the caller +of the function and it is its responsibility to release that reference +when it is done with the object. +.PP +\fBTcl_GetChannelErrorInterp\fR places either the error message held +in the bypass area of the specified interpreter into \fImsgPtr\fR, or +NULL; and resets the bypass. I.e. after an invokation all following +invokations will return NULL, until an intervening invokation of +\fBTcl_SetChannelErrorInterp\fR with a non-NULL message. The +\fImsgPtr\fR must not be NULL. The reference count of the message is +not touched. The reference previously held by the interpreter is now +held by the caller of the function and it is its responsibility to +release that reference when it is done with the object. +.PP +Which functions of a channel driver are allowed to use which bypass +function is listed below, as is which functions of the public channel +API may leave a messages in the bypass areas. +.PP +.IP \fBTcl_DriverCloseProc\fR +May use \fBTcl_SetChannelErrorInterp\fR, and only this function. +.IP \fBTcl_DriverInputProc\fR +May use \fBTcl_SetChannelError\fR, and only this function. +.IP \fBTcl_DriverOutputProc\fR +May use \fBTcl_SetChannelError\fR, and only this function. +.IP \fBTcl_DriverSeekProc\fR +May use \fBTcl_SetChannelError\fR, and only this function. +.IP \fBTcl_DriverWideSeekProc +May use \fBTcl_SetChannelError\fR, and only this function. +.IP \fBTcl_DriverSetOptionProc\fR +Has already the ability to pass arbitrary error messages. Must +\fBnot\fR use any of the new functions. +.IP \fBTcl_DriverGetOptionProc\fR +Has already the ability to pass arbitrary error messages. Must +\fBnot\fR use any of the new functions. +.IP \fBTcl_DriverWatchProc\fR +Must \fBnot\fR use any of the new functions. Is internally called and +has no ability to return any type of error whatsoever. +.IP \fBTcl_DriverBlockModeProc\fR +May use \fBTcl_SetChannelError\fR, and only this function. +.IP \fBTcl_DriverGetHandleProc\fR +Must \fBnot\fR use any of the new functions. It is only a low-level +function, and not used by Tcl commands. +.IP \fBTcl_DriverHandlerProc\fR +Must \fBnot\fR use any of the new functions. Is internally called and +has no ability to return any type of error whatsoever. +.PP +Given the information above the following public functions of the Tcl +C API are affected by these changes. I.e. when these functions are +called the channel may now contain a stored arbitrary error message +requiring processing by the caller. +.PP +.IP \fBTcl_StackChannel\fR +.IP \fBTcl_Seek\fR +.IP \fBTcl_Tell\fR +.IP \fBTcl_ReadRaw\fR +.IP \fBTcl_Read\fR +.IP \fBTcl_ReadChars\fR +.IP \fBTcl_Gets\fR +.IP \fBTcl_GetsObj\fR +.IP \fBTcl_Flush\fR +.IP \fBTcl_WriteRaw\fR +.IP \fBTcl_WriteObj\fR +.IP \fBTcl_Write\fR +.IP \fBTcl_WriteChars\fR +.PP +All other API functions are unchanged. Especially the functions below +leave all their error information in the interpreter result. +.PP +.IP \fBTcl_Close\fR +.IP \fBTcl_UnregisterChannel\fR +.IP \fBTcl_UnstackChannel\fR +.PP + +.SH "SEE ALSO" +Tcl_Close(3), Tcl_OpenFileChannel(3), Tcl_SetErrno(3) + +.SH KEYWORDS +channel driver, error messages, channel type Index: doc/SetResult.3 ================================================================== --- doc/SetResult.3 +++ doc/SetResult.3 @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: SetResult.3,v 1.11 2004/10/07 15:15:48 dkf Exp $ +'\" RCS: @(#) $Id: SetResult.3,v 1.11.2.2 2005/09/15 20:58:38 dgp Exp $ '\" .so man.macros .TH Tcl_SetResult 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME @@ -19,20 +19,20 @@ \fBTcl_SetObjResult\fR(\fIinterp, objPtr\fR) .sp Tcl_Obj * \fBTcl_GetObjResult\fR(\fIinterp\fR) .sp -\fBTcl_SetResult\fR(\fIinterp, string, freeProc\fR) +\fBTcl_SetResult\fR(\fIinterp, result, freeProc\fR) .sp const char * \fBTcl_GetStringResult\fR(\fIinterp\fR) .sp -\fBTcl_AppendResult\fR(\fIinterp, string, string, ... , \fB(char *) NULL\fR) +\fBTcl_AppendResult\fR(\fIinterp, result, result, ... , \fB(char *) NULL\fR) .sp \fBTcl_AppendResultVA\fR(\fIinterp, argList\fR) .sp -\fBTcl_AppendElement\fR(\fIinterp, string\fR) +\fBTcl_AppendElement\fR(\fIinterp, element\fR) .sp \fBTcl_ResetResult\fR(\fIinterp\fR) .sp \fBTcl_FreeResult\fR(\fIinterp\fR) .SH ARGUMENTS @@ -39,20 +39,23 @@ .AS Tcl_FreeProc freeProc out .AP Tcl_Interp *interp out Interpreter whose result is to be modified or read. .AP Tcl_Obj *objPtr in Object value to become result for \fIinterp\fR. -.AP char *string in +.AP char *result in String value to become result for \fIinterp\fR or to be appended to the existing result. +.AP char *element in +String value to append as a list element +to the existing result of \fIinterp\fR. .AP Tcl_FreeProc *freeProc in Address of procedure to call to release storage at -\fIstring\fR, or \fBTCL_STATIC\fR, \fBTCL_DYNAMIC\fR, or +\fIresult\fR, or \fBTCL_STATIC\fR, \fBTCL_DYNAMIC\fR, or \fBTCL_VOLATILE\fR. .AP va_list argList in An argument list which must have been initialized using -\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR. +\fBva_start\fR, and cleared using \fBva_end\fR. .BE .SH DESCRIPTION .PP The procedures described here are utilities for manipulating the @@ -85,21 +88,21 @@ if the caller needs to retain a long-term pointer to the object they should use \fBTcl_IncrRefCount\fR to increment its reference count in order to keep it from being freed too early or accidentally changed. .PP \fBTcl_SetResult\fR -arranges for \fIstring\fR to be the result for the current Tcl +arranges for \fIresult\fR to be the result for the current Tcl command in \fIinterp\fR, replacing any existing result. The \fIfreeProc\fR argument specifies how to manage the storage -for the \fIstring\fR argument; +for the \fIresult\fR argument; it is discussed in the section \fBTHE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT\fR below. -If \fIstring\fR is \fBNULL\fR, then \fIfreeProc\fR is ignored +If \fIresult\fR is \fBNULL\fR, then \fIfreeProc\fR is ignored and \fBTcl_SetResult\fR re-initializes \fIinterp\fR's result to point to an empty string. .PP -\fBTcl_GetStringResult\fR returns the result for \fIinterp\fR as an string. +\fBTcl_GetStringResult\fR returns the result for \fIinterp\fR as a string. If the result was set to an object by a \fBTcl_SetObjResult\fR call, the object form will be converted to a string and returned. If the object's string representation contains null bytes, this conversion will lose information. For this reason, programmers are encouraged to @@ -116,25 +119,25 @@ \fBTcl_ResetResult\fR also clears the error state managed by \fBTcl_AddErrorInfo\fR, \fBTcl_AddObjErrorInfo\fR, and \fBTcl_SetErrorCode\fR. .PP \fBTcl_AppendResult\fR makes it easy to build up Tcl results in pieces. -It takes each of its \fIstring\fR arguments and appends them in order +It takes each of its \fIresult\fR arguments and appends them in order to the current result associated with \fIinterp\fR. If the result is in its initialized empty state (e.g. a command procedure was just invoked or \fBTcl_ResetResult\fR was just called), then \fBTcl_AppendResult\fR sets the result to the concatenation of -its \fIstring\fR arguments. +its \fIresult\fR arguments. \fBTcl_AppendResult\fR may be called repeatedly as additional pieces of the result are produced. \fBTcl_AppendResult\fR takes care of all the storage management issues associated with managing \fIinterp\fR's result, such as allocating a larger result area if necessary. It also manages conversion to and from the \fIresult\fR field of the \fIinterp\fR so as to handle backward-compatability with old-style extensions. -Any number of \fIstring\fR arguments may be passed in a single +Any number of \fIresult\fR arguments may be passed in a single call; the last argument in the list must be a NULL pointer. .PP \fBTcl_AppendResultVA\fR is the same as \fBTcl_AppendResult\fR except that instead of taking a variable number of arguments it takes an argument list. @@ -146,16 +149,16 @@ that manipulate the result as an object can be significantly more efficient. .PP \fBTcl_AppendElement\fR is similar to \fBTcl_AppendResult\fR in that it allows results to be built up in pieces. -However, \fBTcl_AppendElement\fR takes only a single \fIstring\fR +However, \fBTcl_AppendElement\fR takes only a single \fIelement\fR argument and it appends that argument to the current result as a proper Tcl list element. \fBTcl_AppendElement\fR adds backslashes or braces if necessary to ensure that \fIinterp\fR's result can be parsed as a list and that -\fIstring\fR will be extracted as a single element. +\fIelement\fR will be extracted as a single element. Under normal conditions, \fBTcl_AppendElement\fR will add a space character to \fIinterp\fR's result just before adding the new list element, so that the list elements in the result are properly separated. However if the new list element is the first in a list or sub-list @@ -183,25 +186,25 @@ and write the result using \fBTcl_SetObjResult\fR or \fBTcl_SetResult\fR. .SH "THE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT" .PP \fBTcl_SetResult\fR's \fIfreeProc\fR argument specifies how -the Tcl system is to manage the storage for the \fIstring\fR argument. +the Tcl system is to manage the storage for the \fIresult\fR argument. If \fBTcl_SetResult\fR or \fBTcl_SetObjResult\fR are called at a time when \fIinterp\fR holds a string result, they do whatever is necessary to dispose of the old string result (see the \fBTcl_Interp\fR manual entry for details on this). .PP -If \fIfreeProc\fR is \fBTCL_STATIC\fR it means that \fIstring\fR +If \fIfreeProc\fR is \fBTCL_STATIC\fR it means that \fIresult\fR refers to an area of static storage that is guaranteed not to be modified until at least the next call to \fBTcl_Eval\fR. If \fIfreeProc\fR -is \fBTCL_DYNAMIC\fR it means that \fIstring\fR was allocated with a call +is \fBTCL_DYNAMIC\fR it means that \fIresult\fR was allocated with a call to \fBTcl_Alloc\fR and is now the property of the Tcl system. \fBTcl_SetResult\fR will arrange for the string's storage to be released by calling \fBTcl_Free\fR when it is no longer needed. -If \fIfreeProc\fR is \fBTCL_VOLATILE\fR it means that \fIstring\fR +If \fIfreeProc\fR is \fBTCL_VOLATILE\fR it means that \fIresult\fR points to an area of memory that is likely to be overwritten when \fBTcl_SetResult\fR returns (e.g. it points to something in a stack frame). In this case \fBTcl_SetResult\fR will make a copy of the string in dynamically allocated storage and arrange for the copy to be the result for the current Tcl command. @@ -215,12 +218,12 @@ result that match the type \fBTcl_FreeProc\fR: .CS typedef void Tcl_FreeProc(char *\fIblockPtr\fR); .CE When \fIfreeProc\fR is called, its \fIblockPtr\fR will be set to -the value of \fIstring\fR passed to \fBTcl_SetResult\fR. +the value of \fIresult\fR passed to \fBTcl_SetResult\fR. .SH "SEE ALSO" Tcl_AddErrorInfo, Tcl_CreateObjCommand, Tcl_SetErrorCode, Tcl_Interp .SH KEYWORDS append, command, element, list, object, result, return value, interpreter Index: doc/StrMatch.3 ================================================================== --- doc/StrMatch.3 +++ doc/StrMatch.3 @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: StrMatch.3,v 1.6 2004/10/07 15:15:48 dkf Exp $ +'\" RCS: @(#) $Id: StrMatch.3,v 1.6.2.2 2005/05/05 17:55:24 kennykb Exp $ '\" .so man.macros .TH Tcl_StringMatch 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME @@ -15,17 +15,17 @@ .SH SYNOPSIS .nf \fB#include \fR .sp int -\fBTcl_StringMatch\fR(\fIstring\fR, \fIpattern\fR) +\fBTcl_StringMatch\fR(\fIstr\fR, \fIpattern\fR) .sp int -\fBTcl_StringCaseMatch\fR(\fIstring\fR, \fIpattern\fR, \fInocase\fR) +\fBTcl_StringCaseMatch\fR(\fIstr\fR, \fIpattern\fR, \fInocase\fR) .SH ARGUMENTS .AS "const char" *pattern -.AP "const char" *string in +.AP "const char" *str in String to test. .AP "const char" *pattern in Pattern to match against string. May contain special characters from the set *?\e[]. .AP int nocase in @@ -39,15 +39,13 @@ a given pattern. If it does, then \fBTcl_StringMatch\fR returns 1. Otherwise \fBTcl_StringMatch\fR returns 0. The algorithm used for matching is the same algorithm used in the ``string match'' Tcl command and is similar to the algorithm used by the C-shell for file name matching; see the Tcl manual entry for details. -.VS 8.1 .PP In \fBTcl_StringCaseMatch\fR, the algorithm is the same, but you have the option to make the matching case-insensitive. If you choose this (by passing \fBnocase\fR as 1), then the string and pattern are essentially matched in the lower case. -.VE 8.1 .SH KEYWORDS match, pattern, string Index: doc/StringObj.3 ================================================================== --- doc/StringObj.3 +++ doc/StringObj.3 @@ -2,11 +2,11 @@ '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: StringObj.3,v 1.17 2004/10/07 15:15:48 dkf Exp $ +'\" RCS: @(#) $Id: StringObj.3,v 1.17.2.2 2005/09/15 20:58:39 dgp Exp $ '\" .so man.macros .TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME @@ -72,19 +72,17 @@ Tcl_Obj * \fBTcl_ConcatObj\fR(\fIobjc, objv\fR) .SH ARGUMENTS .AS "const Tcl_UniChar" *appendObjPtr in/out .AP "const char" *bytes in -.VS 8.1 Points to the first byte of an array of UTF-8-encoded bytes used to set or append to a string object. This byte array may contain embedded null characters unless \fInumChars\fR is negative. (Applications needing null bytes should represent them as the two-byte sequence \fI\\700\\600\fR, use \fBTcl_ExternalToUtf\fR to convert, or \fBTcl_NewByteArrayObj\fR if the string is a collection of uninterpreted bytes.) -.VE 8.1 .AP int length in The number of bytes to copy from \fIbytes\fR when initializing, setting, or appending to a string object. If negative, all bytes up to the first null are used. .AP "const Tcl_UniChar" *unicode in @@ -113,11 +111,11 @@ the length of an object's string representation. .AP "const char" *string in Null-terminated string value to append to \fIobjPtr\fR. .AP va_list argList in An argument list which must have been initialised using -\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR. +\fBva_start\fR, and cleared using \fBva_end\fR. .AP int newLength in New length for the string value of \fIobjPtr\fR, not including the final null character. .AP int objc in The number of elements to concatenate. Index: doc/Thread.3 ================================================================== --- doc/Thread.3 +++ doc/Thread.3 @@ -3,11 +3,11 @@ '\" Copyright (c) 1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: Thread.3,v 1.20 2004/11/25 16:01:17 vasiljevic Exp $ +'\" RCS: @(#) $Id: Thread.3,v 1.20.2.2 2005/03/02 21:25:19 kennykb Exp $ '\" .so man.macros .TH Threads 3 "8.1" Tcl "Tcl Library Procedures" .BS .SH NAME @@ -94,12 +94,12 @@ Tcl provides \fBTcl_CreateThread\fR for creating threads. The caller can determine the size of the stack given to the new thread and modify the behaviour through the supplied \fIflags\fR. The value \fBTCL_THREAD_STACK_DEFAULT\fR for the \fIstackSize\fR indicates that the default size as specified by the operating system is to be used -for the new thread. As for the flags, currently are only the values -\fBTCL_THREAD_NOFLAGS\fR and \fBTCL_THREAD_JOINABLE\fR defined. The +for the new thread. As for the flags, currently only the values +\fBTCL_THREAD_NOFLAGS\fR and \fBTCL_THREAD_JOINABLE\fR are defined. The first of them invokes the default behaviour with no specialties. Using the second value marks the new thread as \fIjoinable\fR. This means that another thread can wait for the such marked thread to exit and join it. .PP @@ -107,11 +107,11 @@ contain the functionality to specify the stack size of a thread. The specified value for the stack size is ignored on these systems. Windows currently does not support joinable threads. This flag value is therefore ignored on this platform. .PP -Tcl does provide \fBTcl_ExitThread\fR and \fBTcl_FinalizeThread\fR +Tcl provides the \fBTcl_ExitThread\fR and \fBTcl_FinalizeThread\fR functions for terminating threads and invoking optional per-thread exit handlers. See the \fBTcl_Exit\fR page for more information on these procedures. .PP The \fBTcl_JoinThread\fR function is provided to allow threads to wait @@ -189,10 +189,9 @@ interfaces, and leaves it up to packages to expose these matters to the script level. One such package is the \fBThread\fR package. .VE 8.5 .SH "SEE ALSO" Tcl_GetCurrentThread(3), Tcl_ThreadQueueEvent(3), Tcl_ThreadAlert(3), -Tcl_ExitThread(3), Tcl_FinalizeThread(3), -Tcl_CreateThreadExitHandler(3), Tcl_DeleteThreadExitHandler(3), -\fBThread\fR package +Tcl_ExitThread(3), Tcl_FinalizeThread(3), Tcl_CreateThreadExitHandler(3), +Tcl_DeleteThreadExitHandler(3), Thread .SH KEYWORDS thread, mutex, condition variable, thread local storage Index: doc/TraceVar.3 ================================================================== --- doc/TraceVar.3 +++ doc/TraceVar.3 @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: TraceVar.3,v 1.13 2004/10/07 16:05:15 dkf Exp $ +'\" RCS: @(#) $Id: TraceVar.3,v 1.13.2.1 2005/04/10 23:14:42 kennykb Exp $ '\" .so man.macros .TH Tcl_TraceVar 3 7.4 Tcl "Tcl Library Procedures" .BS .SH NAME @@ -106,25 +106,21 @@ This gives the trace procedure a chance to update the array before array names or array get is called. Note that this is called before an array set, but that will trigger write traces. .TP \fBTCL_TRACE_RESULT_DYNAMIC\fR -.VS 8.4 The result of invoking the \fIproc\fR is a dynamically allocated string that will be released by the Tcl library via a call to \fBckfree\fR. Must not be specified at the same time as \fBTCL_TRACE_RESULT_OBJECT\fR. -.VE 8.4 .TP \fBTCL_TRACE_RESULT_OBJECT\fR -.VS 8.4 The result of invoking the \fIproc\fR is a Tcl_Obj* (cast to a char*) with a reference count of at least one. The ownership of that reference will be transferred to the Tcl core for release (when the core has finished with it) via a call to \fBTcl_DecrRefCount\fR. Must not be specified at the same time as \fBTCL_TRACE_RESULT_DYNAMIC\fR. -.VE 8.4 .PP Whenever one of the specified operations occurs on the variable, \fIproc\fR will be invoked. It should have arguments and result that match the type \fBTcl_VarTraceProc\fR: @@ -207,21 +203,19 @@ \fBTcl_VarTraceInfo2\fR are identical to \fBTcl_TraceVar\fR, \fBTcl_UntraceVar\fR, and \fBTcl_VarTraceInfo\fR, respectively, except that the name of the variable consists of two parts. \fIName1\fR gives the name of a scalar variable or array, and \fIname2\fR gives the name of an element within an array. -.VS 8.1 When \fIname2\fR is NULL, \fIname1\fR may contain both an array and an element name: if the name contains an open parenthesis and ends with a close parenthesis, then the value between the parentheses is treated as an element name (which can have any string value) and the characters before the first open parenthesis are treated as the name of an array variable. If \fIname2\fR is NULL and \fIname1\fR does not refer to an array element -.VE it means that either the variable is a scalar or the trace is to be set on the entire array rather than an individual element (see WHOLE-ARRAY TRACES below for more information). @@ -323,17 +317,15 @@ successful completion. If \fIproc\fR returns a non-NULL value it signifies that an error occurred. The return value must be a pointer to a static character string containing an error message, -.VS 8.4 unless (\fIexactly\fR one of) the \fBTCL_TRACE_RESULT_DYNAMIC\fR and \fBTCL_TRACE_RESULT_OBJECT\fR flags is set, which specify that the result is either a dynamic string (to be released with \fBckfree\fR) or a Tcl_Obj* (cast to char* and to be released with \fBTcl_DecrRefCount\fR) containing the error message. -.VE 8.4 If a trace procedure returns an error, no further traces are invoked for the access and the traced access aborts with the given message. Trace procedures can use this facility to make variables read-only, for example (but note that the value of the variable Index: doc/Utf.3 ================================================================== --- doc/Utf.3 +++ doc/Utf.3 @@ -2,11 +2,11 @@ '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: Utf.3,v 1.20 2004/10/07 16:05:15 dkf Exp $ +'\" RCS: @(#) $Id: Utf.3,v 1.20.2.2 2005/05/05 17:55:24 kennykb Exp $ '\" .so man.macros .TH Utf 3 "8.1" Tcl "Tcl Library Procedures" .BS .SH NAME @@ -20,45 +20,40 @@ int \fBTcl_UniCharToUtf\fR(\fIch, buf\fR) .sp int \fBTcl_UtfToUniChar\fR(\fIsrc, chPtr\fR) -.VS 8.4 .sp char * -\fBTcl_UniCharToUtfDString\fR(\fIuniStr, numChars, dstPtr\fR) +\fBTcl_UniCharToUtfDString\fR(\fIuniStr, uniLength, dsPtr\fR) .sp Tcl_UniChar * -\fBTcl_UtfToUniCharDString\fR(\fIsrc, len, dstPtr\fR) -.VE 8.4 +\fBTcl_UtfToUniCharDString\fR(\fIsrc, length, dsPtr\fR) .sp int \fBTcl_UniCharLen\fR(\fIuniStr\fR) .sp int -\fBTcl_UniCharNcmp\fR(\fIuniStr, uniStr, num\fR) -.VS 8.4 +\fBTcl_UniCharNcmp\fR(\fIucs, uct, numChars\fR) .sp int -\fBTcl_UniCharNcasecmp\fR(\fIuniStr, uniStr, num\fR) +\fBTcl_UniCharNcasecmp\fR(\fIucs, uct, numChars\fR) .sp int \fBTcl_UniCharCaseMatch\fR(\fIuniStr, uniPattern, nocase\fR) -.VE 8.4 +.sp +int +\fBTcl_UtfNcmp\fR(\fIcs, ct, numChars\fR) .sp int -\fBTcl_UtfNcmp\fR(\fIsrc, src, num\fR) -.sp -int -\fBTcl_UtfNcasecmp\fR(\fIsrc, src, num\fR) +\fBTcl_UtfNcasecmp\fR(\fIcs, ct, numChars\fR) .sp int -\fBTcl_UtfCharComplete\fR(\fIsrc, len\fR) +\fBTcl_UtfCharComplete\fR(\fIsrc, length\fR) .sp int -\fBTcl_NumUtfChars\fR(\fIsrc, len\fR) -.VS 8.4 +\fBTcl_NumUtfChars\fR(\fIsrc, length\fR) .sp const char * \fBTcl_UtfFindFirst\fR(\fIsrc, ch\fR) .sp const char * @@ -67,19 +62,16 @@ const char * \fBTcl_UtfNext\fR(\fIsrc\fR) .sp const char * \fBTcl_UtfPrev\fR(\fIsrc, start\fR) -.VE 8.4 .sp Tcl_UniChar \fBTcl_UniCharAtIndex\fR(\fIsrc, index\fR) -.VS 8.4 .sp const char * \fBTcl_UtfAtIndex\fR(\fIsrc, index\fR) -.VE 8.4 .sp int \fBTcl_UtfBackslash\fR(\fIsrc, readPtr, dst\fR) .SH ARGUMENTS .AS "const Tcl_UniChar" *uniPattern in/out @@ -89,24 +81,32 @@ .AP int ch in The Tcl_UniChar to be converted or examined. .AP Tcl_UniChar *chPtr out Filled with the Tcl_UniChar represented by the head of the UTF-8 string. .AP "const char" *src in +Pointer to a UTF-8 string. +.AP "const char" *cs in +Pointer to a UTF-8 string. +.AP "const char" *ct in Pointer to a UTF-8 string. .AP "const Tcl_UniChar" *uniStr in +A null-terminated Unicode string. +.AP "const Tcl_UniChar" *ucs in +A null-terminated Unicode string. +.AP "const Tcl_UniChar" *uct in A null-terminated Unicode string. .AP "const Tcl_UniChar" *uniPattern in A null-terminated Unicode string. -.AP int len in +.AP int length in The length of the UTF-8 string in bytes (not UTF-8 characters). If negative, all bytes up to the first null byte are used. -.AP int numChars in +.AP int uniLength in The length of the Unicode string in characters. Must be greater than or equal to 0. -.AP "Tcl_DString" *dstPtr in/out +.AP "Tcl_DString" *dsPtr in/out A pointer to a previously initialized \fBTcl_DString\fR. -.AP "unsigned long" num in +.AP "unsigned long" numChars in The number of characters to compare. .AP "const char" *start in Pointer to the beginning of a UTF-8 string. .AP int index in The index of a character (not byte) in the UTF-8 string. @@ -115,14 +115,12 @@ including the backslash character. .AP char *dst out Buffer in which the bytes represented by the backslash sequence are stored. At most \fBTCL_UTF_MAX\fR bytes are stored in the buffer. .AP int nocase in -.VS 8.4 Specifies whether the match should be done case-sensitive (0) or case-insensitive (1). -.VE 8.4 .BE .SH DESCRIPTION .PP These routines convert between UTF-8 strings and Tcl_UniChars. A @@ -148,19 +146,20 @@ byte of \fIsrc\fR in \fI*chPtr\fR as a Tcl_UniChar between 0x0000 and 0x00ff and return 1. .PP \fBTcl_UniCharToUtfDString\fR converts the given Unicode string to UTF-8, storing the result in a previously initialized \fBTcl_DString\fR. -You must specify the length of the given Unicode string. +You must specify \fIuniLength\fR, the length of the given Unicode string. The return value is a pointer to the UTF-8 representation of the Unicode string. Storage for the return value is appended to the end of the \fBTcl_DString\fR. .PP \fBTcl_UtfToUniCharDString\fR converts the given UTF-8 string to Unicode, storing the result in the previously initialized \fBTcl_DString\fR. -You may either specify the length of the given UTF-8 string or "-1", -in which case \fBTcl_UtfToUniCharDString\fR uses \fBstrlen\fR to +In the argument \fIlength\fR, you may either specify the length of +the given UTF-8 string in bytes or "-1", in which +case \fBTcl_UtfToUniCharDString\fR uses \fBstrlen\fR to calculate the length. The return value is a pointer to the Unicode representation of the UTF-8 string. Storage for the return value is appended to the end of the \fBTcl_DString\fR. The Unicode string is terminated with a Unicode null character. .PP @@ -169,27 +168,25 @@ the number of Unicode characters (not bytes) in that string. .PP \fBTcl_UniCharNcmp\fR and \fBTcl_UniCharNcasecmp\fR correspond to \fBstrncmp\fR and \fBstrncasecmp\fR, respectively, for Unicode characters. They accept two null-terminated Unicode strings and the number of characters -to compare. Both strings are assumed to be at least \fIlen\fR characters +to compare. Both strings are assumed to be at least \fInumChars\fR characters long. \fBTcl_UniCharNcmp\fR compares the two strings character-by-character according to the Unicode character ordering. It returns an integer greater than, equal to, or less than 0 if the first string is greater than, equal to, or less than the second string respectively. \fBTcl_UniCharNcasecmp\fR is the Unicode case insensitive version. .PP -.VS 8.4 \fBTcl_UniCharCaseMatch\fR is the Unicode equivalent to \fBTcl_StringCaseMatch\fR. It accepts a null-terminated Unicode string, a Unicode pattern, and a boolean value specifying whether the match should be case sensitive and returns whether the string matches the pattern. -.VE 8.4 .PP \fBTcl_UtfNcmp\fR corresponds to \fBstrncmp\fR for UTF-8 strings. It accepts two null-terminated UTF-8 strings and the number of characters -to compare. (Both strings are assumed to be at least \fIlen\fR +to compare. (Both strings are assumed to be at least \fInumChars\fR characters long.) \fBTcl_UtfNcmp\fR compares the two strings character-by-character according to the Unicode character ordering. It returns an integer greater than, equal to, or less than 0 if the first string is greater than, equal to, or less than the second string respectively. @@ -198,19 +195,19 @@ strings. It is similar to \fBTcl_UtfNcmp\fR except comparisons ignore differences in case when comparing upper, lower or title case characters. .PP \fBTcl_UtfCharComplete\fR returns 1 if the source UTF-8 string \fIsrc\fR -of length \fIlen\fR bytes is long enough to be decoded by +of \fIlength\fR bytes is long enough to be decoded by \fBTcl_UtfToUniChar\fR, or 0 otherwise. This function does not guarantee that the UTF-8 string is properly formed. This routine is used by procedures that are operating on a byte at a time and need to know if a full Tcl_UniChar has been seen. .PP \fBTcl_NumUtfChars\fR corresponds to \fBstrlen\fR for UTF-8 strings. It returns the number of Tcl_UniChars that are represented by the UTF-8 string -\fIsrc\fR. The length of the source string is \fIlen\fR bytes. If the +\fIsrc\fR. The length of the source string is \fIlength\fR bytes. If the length is negative, all bytes up to the first null byte are used. .PP \fBTcl_UtfFindFirst\fR corresponds to \fBstrchr\fR for UTF-8 strings. It returns a pointer to the first occurrence of the Tcl_UniChar \fIch\fR in the null-terminated UTF-8 string \fIsrc\fR. The null terminator is Index: doc/array.n ================================================================== --- doc/array.n +++ doc/array.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: array.n,v 1.13 2004/10/27 14:24:37 dkf Exp $ +'\" RCS: @(#) $Id: array.n,v 1.13.2.1 2005/04/10 23:14:42 kennykb Exp $ '\" .so man.macros .TH array n 8.3 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -120,28 +120,24 @@ searches to be underway simultaneously for the same array. It is currently more efficient and easier to use either the \fBarray get\fR or \fBarray names\fR, together with \fBforeach\fR, to iterate over all but very large arrays. See the examples below for how to do this. -.VS 8.4 .TP \fBarray statistics \fIarrayName\fR Returns statistics about the distribution of data within the hashtable that represents the array. This information includes the number of entries in the table, the number of buckets, and the utilization of the buckets. -.VE 8.4 -.VS 8.3 .TP \fBarray unset \fIarrayName\fR ?\fIpattern\fR? Unsets all of the elements in the array that match \fIpattern\fR (using the matching rules of \fBstring match\fR). If \fIarrayName\fR isn't the name of an array variable or there are no matching elements in the array, no error will be raised. If \fIpattern\fR is omitted and \fIarrayName\fR is an array variable, then the command unsets the entire array. The command always returns an empty string. -.VE 8.3 .SH EXAMPLES .CS \fBarray set\fR colorcount { red 1 green 5 Index: doc/binary.n ================================================================== --- doc/binary.n +++ doc/binary.n @@ -2,11 +2,11 @@ '\" Copyright (c) 1997 by Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: binary.n,v 1.24 2004/11/12 11:03:16 dkf Exp $ +'\" RCS: @(#) $Id: binary.n,v 1.24.2.1 2005/03/02 21:25:20 kennykb Exp $ '\" .so man.macros .TH binary n 8.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -429,11 +429,11 @@ .CE If you want to produce an unsigned value, then you can mask the return value to the desired size. For example, to produce an unsigned short value: .CS -set val [expr {$val & 0xFFFF}]; \fI# val == 0x8000\fR +set val [expr { $val & 0xFFFF }]; \fI# val == 0x8000\fR .CE .PP Each type-count pair moves an imaginary cursor through the binary data, reading bytes from the current position. The cursor is initially at position 0 at the beginning of the data. The type may be any one of @@ -527,11 +527,11 @@ will return \fB2\fR with \fB7 -122\fR stored in \fIvar1\fR and \fB5\fR stored in \fIvar2\fR. Note that the integers returned are signed, but they can be converted to unsigned 8-bit quantities using an expression like: .CS -expr { ( $num + 0x100 ) % 0x100 } +set num [expr { $num & 0xff }] .CE .RE .IP \fBs\fR 5 The data is interpreted as \fIcount\fR 16-bit signed integers represented in little-endian byte order. The integers are stored in @@ -546,11 +546,11 @@ will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB-16\fR stored in \fIvar2\fR. Note that the integers returned are signed, but they can be converted to unsigned 16-bit quantities using an expression like: .CS -expr { ( $num + 0x10000 ) % 0x10000 } +set num [expr { $num & 0xffff }] .CE .RE .IP \fBS\fR 5 This form is the same as \fBs\fR except that the data is interpreted as \fIcount\fR 16-bit signed integers represented in big-endian byte @@ -581,12 +581,16 @@ .CS set str \\x05\\x00\\x00\\x00\\x07\\x00\\x00\\x00\\xf0\\xff\\xff\\xff \fBbinary scan\fR $str i2i* var1 var2 .CE will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB-16\fR -stored in \fIvar2\fR. Note that the integers returned are signed and -cannot be represented by Tcl as unsigned values. +stored in \fIvar2\fR. Note that the integers returned are signed, but +they can be converted to unsigned 32-bit quantities using an expression +like: +.CS +set num [expr { $num & 0xffffffff }] +.CE .RE .IP \fBI\fR 5 This form is the same as \fBI\fR except that the data is interpreted as \fIcount\fR 32-bit signed integers represented in big-endian byte order. For example, ADDED doc/chan.n Index: doc/chan.n ================================================================== --- /dev/null +++ doc/chan.n @@ -0,0 +1,588 @@ +'\" +'\" Copyright (c) 2005 Donal K. Fellows +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" RCS: @(#) $Id: chan.n,v 1.2.6.2 2005/07/12 20:36:15 kennykb Exp $ +.so man.macros +.TH chan n 8.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +chan \- Read, write and manipulate channels +.SH SYNOPSIS +\fBchan \fIoption\fR ?\fIarg arg ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command provides several operations for reading from, writing to +and otherwise manipulating open channels (such as have been created +with the \fBopen\fR and \fBsocket\fR commands, or the default named +channels \fBstdin\fR, \fBstdout\fR or \fBstderr\fR which correspond to +the process's standard input, output and error streams respectively). +\fIOption\fR indicates what to do with the channel; any unique +abbreviation for \fIoption\fR is acceptable. Valid options are: +.TP +\fBchan blocked \fIchannelId\fR +. +This tests whether the last input operation on the channel called +\fIchannelId\fR failed because it would have otherwise caused the +process to block, and returns 1 if that was the case. It returns 0 +otherwise. Note that this only ever returns 1 when the channel has +been configured to be non-blocking; all Tcl channels have blocking +turned on by default. +.TP +\fBchan close \fIchannelId\fR +. +Close and destroy the channel called \fIchannelId\fR. Note that this +deletes all existing file-events registered on the channel. +.RS +.PP +As part of closing the channel, all buffered output is flushed to the +channel's outpuot device, any buffered input is discarded, the +underlying operating system resource is closed and \fIchannelId\fR +becomes unavailable for future use. +.PP +If the channel is blocking, the command does not return until all +output is flushed. If the channel is nonblocking and there is +unflushed output, the channel remains open and the command returns +immediately; output will be flushed in the background and the channel +will be closed when all the flushing is complete. +.PP +If \fIchannelId\fR is a blocking channel for a command pipeline then +\fBchan close\fR waits for the child processes to complete. +.PP +If the channel is shared between interpreters, then \fBchan close\fR +makes \fIchannelId\fR unavailable in the invoking interpreter but has +no other effect until all of the sharing interpreters have closed the +channel. When the last interpreter in which the channel is registered +invokes \fBchan close\fR (or \fBclose\fR), the cleanup actions +described above occur. See the \fBinterp\fR command for a description +of channel sharing. +.PP +Channels are automatically closed when an interpreter is destroyed and +when the process exits. Channels are switched to blocking mode, to +ensure that all output is correctly flushed before the process exits. +.PP +The command returns an empty string, and may generate an error if +an error occurs while flushing output. If a command in a command +pipeline created with \fBopen\fR returns an error, \fBchan close\fR +generates an error (similar to the \fBexec\fR command.) +.RE +.TP +\fBchan configure \fIchannelId\fR ?\fIoptionName\fR? ?\fIvalue\fR? ?\fIoptionName value\fR?... +. +Query or set the configuration options of the channel named +\fIchannelId\fR. +.RS +.PP +If no \fIoptionName\fR or \fIvalue\fR arguments are supplied, the +command returns a list containing alternating option names and values +for the channel. If \fIoptionName\fR is supplied but no \fIvalue\fR +then the command returns the current value of the given option. If +one or more pairs of \fIoptionName\fR and \fIvalue\fR are supplied, +the command sets each of the named options to the corresponding +\fIvalue\fR; in this case the return value is an empty string. +.PP +The options described below are supported for all channels. In +addition, each channel type may add options that only it supports. See +the manual entry for the command that creates each type of channels +for the options that that specific type of channel supports. For +example, see the manual entry for the \fBsocket\fR command for its +additional options. +.TP +\fB\-blocking\fR \fIboolean\fR +. +The \fB\-blocking\fR option determines whether I/O operations on the +channel can cause the process to block indefinitely. The value of the +option must be a proper boolean value. Channels are normally in +blocking mode; if a channel is placed into nonblocking mode it will +affect the operation of the \fBchan gets\fR, \fBchan read\fR, \fBchan +puts\fR, \fBchan flush\fR, and \fBchan close\fR commands; see the +documentation for those commands for details. For nonblocking mode to +work correctly, the application must be using the Tcl event loop +(e.g. by calling \fBTcl_DoOneEvent\fR or invoking the \fBvwait\fR +command). +.TP +\fB\-buffering\fR \fInewValue\fR +. +If \fInewValue\fR is \fBfull\fR then the I/O system will buffer output +until its internal buffer is full or until the \fBchan flush\fR +command is invoked. If \fInewValue\fR is \fBline\fR, then the I/O +system will automatically flush output for the channel whenever a +newline character is output. If \fInewValue\fR is \fBnone\fR, the I/O +system will flush automatically after every output operation. The +default is for \fB\-buffering\fR to be set to \fBfull\fR except for +channels that connect to terminal-like devices; for these channels the +initial setting is \fBline\fR. Additionally, \fBstdin\fR and +\fBstdout\fR are initially set to \fBline\fR, and \fBstderr\fR is set +to \fBnone\fR. +.TP +\fB\-buffersize\fR \fInewSize\fR +. +\fINewvalue\fR must be an integer; its value is used to set the size +of buffers, in bytes, subsequently allocated for this channel to store +input or output. \fINewvalue\fR must be a number of no more than one +million, allowing buffers of up to one million bytes in size. +.TP +\fB\-encoding\fR \fIname\fR +. +This option is used to specify the encoding of the channel as one of +the named encodings returned by \fBencoding names\fR or the special +value \fBbinary\fR, so that the data can be converted to and from +Unicode for use in Tcl. For instance, in order for Tcl to read +characters from a Japanese file in \fBshiftjis\fR and properly process +and display the contents, the encoding would be set to \fBshiftjis\fR. +Thereafter, when reading from the channel, the bytes in the Japanese +file would be converted to Unicode as they are read. Writing is also +supported \- as Tcl strings are written to the channel they will +automatically be converted to the specified encoding on output. +.RS +.PP +If a file contains pure binary data (for instance, a JPEG image), the +encoding for the channel should be configured to be \fBbinary\fR. Tcl +will then assign no interpretation to the data in the file and simply +read or write raw bytes. The Tcl \fBbinary\fR command can be used to +manipulate this byte-oriented data. It is usually better to set the +\fB\-translation\fR option to \fBbinary\fR when you want to transfer +binary data, as this turns off the other automatic interpretations of +the bytes in the stream as well. +.PP +The default encoding for newly opened channels is the same platform- +and locale-dependent system encoding used for interfacing with the +operating system, as returned by \fBencoding system\fR. +.RE +.TP +\fB\-eofchar\fR \fIchar\fR +.TP +\fB\-eofchar\fR \fB{\fIinChar outChar\fB}\fR +. +This option supports DOS file systems that use Control-z (\ex1a) as an +end of file marker. If \fIchar\fR is not an empty string, then this +character signals end-of-file when it is encountered during input. +For output, the end-of-file character is output when the channel is +closed. If \fIchar\fR is the empty string, then there is no special +end of file character marker. For read-write channels, a two-element +list specifies the end of file marker for input and output, +respectively. As a convenience, when setting the end-of-file +character for a read-write channel you can specify a single value that +will apply to both reading and writing. When querying the end-of-file +character of a read-write channel, a two-element list will always be +returned. The default value for \fB\-eofchar\fR is the empty string +in all cases except for files under Windows. In that case the +\fB\-eofchar\fR is Control-z (\ex1a) for reading and the empty string +for writing. +.TP +\fB\-translation\fR \fImode\fR +.TP +\fB\-translation\fR \fB{\fIinMode outMode\fB}\fR +. +In Tcl scripts the end of a line is always represented using a single +newline character (\en). However, in actual files and devices the end +of a line may be represented differently on different platforms, or +even for different devices on the same platform. For example, under +UNIX newlines are used in files, whereas carriage-return-linefeed +sequences are normally used in network connections. On input (i.e., +with \fBchan gets\fP and \fBchan read\fP) the Tcl I/O system +automatically translates the external end-of-line representation into +newline characters. Upon output (i.e., with \fBchan puts\fP), the I/O +system translates newlines to the external end-of-line representation. +The default translation mode, \fBauto\fP, handles all the common cases +automatically, but the \fB\-translation\fR option provides explicit +control over the end of line translations. +.RS +.PP +The value associated with \fB\-translation\fR is a single item for +read-only and write-only channels. The value is a two-element list for +read-write channels; the read translation mode is the first element of +the list, and the write translation mode is the second element. As a +convenience, when setting the translation mode for a read-write channel +you can specify a single value that will apply to both reading and +writing. When querying the translation mode of a read-write channel, a +two-element list will always be returned. The following values are +currently supported: +.TP +\fBauto\fR +. +As the input translation mode, \fBauto\fR treats any of newline +(\fBlf\fP), carriage return (\fBcr\fP), or carriage return followed by +a newline (\fBcrlf\fP) as the end of line representation. The end of +line representation can even change from line-to-line, and all cases +are translated to a newline. As the output translation mode, +\fBauto\fR chooses a platform specific representation; for sockets on +all platforms Tcl chooses \fBcrlf\fR, for all Unix flavors, it chooses +\fBlf\fR, and for the various flavors of Windows it chooses +\fBcrlf\fR. The default setting for \fB\-translation\fR is \fBauto\fR +for both input and output. +.TP +\fBbinary\fR +. +No end-of-line translations are performed. This is nearly identical +to \fBlf\fP mode, except that in addition \fBbinary\fP mode also sets +the end-of-file character to the empty string (which disables it) and +sets the encoding to \fBbinary\fR (which disables encoding filtering). +See the description of \fB\-eofchar\fR and \fB\-encoding\fR for more +information. +.TP +\fBcr\fR +. +The end of a line in the underlying file or device is represented by a +single carriage return character. As the input translation mode, +\fBcr\fP mode converts carriage returns to newline characters. As the +output translation mode, \fBcr\fP mode translates newline characters +to carriage returns. +.TP +\fBcrlf\fR +. +The end of a line in the underlying file or device is represented by a +carriage return character followed by a linefeed character. As the +input translation mode, \fBcrlf\fP mode converts +carriage-return-linefeed sequences to newline characters. As the +output translation mode, \fBcrlf\fP mode translates newline characters +to carriage-return-linefeed sequences. This mode is typically used on +Windows platforms and for network connections. +.TP +\fBlf\fR +. +The end of a line in the underlying file or device is represented by a +single newline (linefeed) character. In this mode no translations +occur during either input or output. This mode is typically used on +UNIX platforms. +.RE +.RE +.TP +\fBchan copy \fIinputChan outputChan\fR ?\fB\-size \fIsize\fR? ?\fB\-command \fIcallback\fR? +. +Copy data from the channel \fIinputChan\fR, which must have been +opened for reading, to the channel \fIoutputChan\fR, which must have +been opened for writing. The \fBchan copy\fR command leverages the +buffering in the Tcl I/O system to avoid extra copies and to avoid +buffering too much data in main memory when copying large files to +slow destinations like network sockets. +.RS +.PP +The \fBchan copy\fP command transfers data from \fIinputChan\fR until +end of file or \fIsize\fP bytes have been transferred. If no +\fB\-size\fP argument is given, then the copy goes until end of file. +All the data read from \fIinputChan\fR is copied to \fIoutputChan\fR. +Without the \fB\-command\fP option, \fBchan copy\fP blocks until the +copy is complete and returns the number of bytes written to +\fIoutputChan\fR. +.PP +The \fB\-command\fP argument makes \fBchan copy\fP work in the +background. In this case it returns immediately and the +\fIcallback\fP is invoked later when the copy completes. The +\fIcallback\fP is called with one or two additional arguments that +indicates how many bytes were written to \fIoutputChan\fR. If an +error occurred during the background copy, the second argument is the +error string associated with the error. With a background copy, it is +not necessary to put \fIinputChan\fR or \fIoutputChan\fR into +non-blocking mode; the \fBchan copy\fP command takes care of that +automatically. However, it is necessary to enter the event loop by +using the \fBvwait\fP command or by using Tk. +.PP +You are not allowed to do other I/O operations with \fIinputChan\fR or +\fIoutputChan\fR during a background \fBchan copy\fR. If either +\fIinputChan\fR or \fIoutputChan\fR get closed while the copy is in +progress, the current copy is stopped and the command callback is +\fInot\fP made. If \fIinputChan\fR is closed, then all data already +queued for \fIoutputChan\fR is written out. +.PP +Note that \fIinputChan\fR can become readable during a background +copy. You should turn off any \fBchan event\fP or \fBfileevent\fR +handlers during a background copy so those handlers do not interfere +with the copy. Any I/O attempted by a \fBchan event\fR or +\fBfileevent\fP handler will get a "channel busy" error. +.PP +\fBChan copy\fR translates end-of-line sequences in \fIinputChan\fR +and \fIoutputChan\fR according to the \fB\-translation\fR option for +these channels (see \fBchan configure\fR above). The translations +mean that the number of bytes read from \fIinputChan\fR can be +different than the number of bytes written to \fIoutputChan\fR. Only +the number of bytes written to \fIoutputChan\fR is reported, either as +the return value of a synchronous \fBchan copy\fP or as the argument +to the callback for an asynchronous \fBchan copy\fP. +.PP +\fBChan copy\fR obeys the encodings and character translations +configured for the channels. This means that the incoming characters +are converted internally first UTF-8 and then into the encoding of the +channel \fBchan copy\fR writes to (see \fBchan configure\fR above for +details on the \fB\-encoding\fR and \fB\-translation\fR options). No +conversion is done if both channels are set to encoding \fBbinary\fR +and have matching translations. If only the output channel is set to +encoding \fBbinary\fR the system will write the internal UTF-8 +representation of the incoming characters. If only the input channel +is set to encoding \fBbinary\fR the system will assume that the +incoming bytes are valid UTF-8 characters and convert them according +to the output encoding. The behaviour of the system for bytes which +are not valid UTF-8 characters is undefined in this case. +.RE +.TP +\fBchan eof \fIchannelId\fR +. +Test whether the last input operation on the channel called +\fIchannelId\fR failed because the end of the data stream was reached, +returning 1 if end-fo-file was reached, and 0 otherwise. +.TP +\fBchan event \fIchannelId event\fR ?\fIscript\fR? +. +Arrange for the Tcl script \fIscript\fR to be installed as a \fIfile +event handler\fR to be called whenever the channel called +\fIchannelId\fR enters the state described by \fIevent\fR (which must +be either \fBreadable\fR or \fBwritable\fR); only one such handler may +be installed per event per channel at a time. If \fIscript\fR is the +empty string, the current handler is deleted (this also happens if the +channel is closed or the interpreter deleted). If \fIscript\fR is +omitted, the currently installed script is returned (or an empty +string if no such handler is installed). The callback is only +performed if the event loop is being serviced (e.g. via \fBvwait\fR or +\fBupdate\fR). +.RS +.PP +A file event handler is a binding between a channel and a script, such +that the script is evaluated whenever the channel becomes readable or +writable. File event handlers are most commonly used to allow data to +be received from another process on an event-driven basis, so that the +receiver can continue to interact with the user or with other channels +while waiting for the data to arrive. If an application invokes +\fBchan gets\fR or \fBchan read\fR on a blocking channel when there is +no input data available, the process will block; until the input data +arrives, it will not be able to service other events, so it will +appear to the user to ``freeze up''. With \fBchan event\fR, the +process can tell when data is present and only invoke \fBchan gets\fR +or \fBchan read\fR when they won't block. +.PP +A channel is considered to be readable if there is unread data +available on the underlying device. A channel is also considered to +be readable if there is unread data in an input buffer, except in the +special case where the most recent attempt to read from the channel +was a \fBchan gets\fR call that could not find a complete line in the +input buffer. This feature allows a file to be read a line at a time +in nonblocking mode using events. A channel is also considered to be +readable if an end of file or error condition is present on the +underlying file or device. It is important for \fIscript\fR to check +for these conditions and handle them appropriately; for example, if +there is no special check for end of file, an infinite loop may occur +where \fIscript\fR reads no data, returns, and is immediately invoked +again. +.PP +A channel is considered to be writable if at least one byte of data +can be written to the underlying file or device without blocking, or +if an error condition is present on the underlying file or device. +Note that client sockets opened in asynchronous mode become writable +when they become connected or if the connection fails. +.PP +Event-driven I/O works best for channels that have been placed into +nonblocking mode with the \fBchan configure\fR command. In blocking +mode, a \fBchan puts\fR command may block if you give it more data +than the underlying file or device can accept, and a \fBchan gets\fR +or \fBchan read\fR command will block if you attempt to read more data +than is ready; no events will be processed while the commands block. +In nonblocking mode \fBchan puts\fR, \fBchan read\fR, and \fBchan +gets\fR never block. +.PP +The script for a file event is executed at global level (outside the +context of any Tcl procedure) in the interpreter in which the \fBchan +event\fR command was invoked. If an error occurs while executing the +script then the command registered with \fBinterp bgerror\fR is used +to report the error. In addition, the file event handler is deleted +if it ever returns an error; this is done in order to prevent infinite +loops due to buggy handlers. +.RE +.TP +\fBchan flush \fIchannelId\fR +. +Ensures that all pending output for the channel called \fIchannelId\fR +is written. +.RS +.PP +If the channel is in blocking mode the command does not return until +all the buffered output has been flushed to the channel. If the +channel is in nonblocking mode, the command may return before all +buffered output has been flushed; the remainder will be flushed in the +background as fast as the underlying file or device is able to absorb +it. +.RE +.TP +\fBchan gets \fIchannelId\fR ?\fIvarName\fR? +. +Reads the next line from the channel called \fIchannelId\fR. If +\fIvarName\fR is not specified, the result of the command will be the +line that has been read (without a trailing newline character) or an +empty string upon end-of-file or, in non-blocking mode, if the data +available is exhausted. If \fIvarName\fR is specified, the line that +has been read will be written to the variable called \fIvarName\fR and +result will be the number of characters that have been read or -1 if +end-of-file was reached or, in non-blocking mode, if the data +available is exhausted. +.RS +.PP +If an end-of-file occurs while part way through reading a line, the +partial line will be returned (or written into \fIvarName\fR). When +\fIvarName\fR is not specified, the end-of-file case can be +distinguished from an empty line using the \fBchan eof\fR command, and +the partial-line-but-nonblocking case can be distinguished with the +\fBchan blocked\fR command. +.RE +.TP +\fBchan names\fR ?\fIpattern\fR? +. +Produces a list of all channel names. If \fIpattern\fR is specified, +only those channel names that match it (according to the rules of +\fBstring match\fR) will be returned. +.TP +\fBchan puts\fR ?\fB\-nonewline\fR? ?\fIchannelId\fR? \fIstring\fR +. +Writes \fIstring\fR to the channel named \fIchannelId\fR followed by a +newline character. A trailing newline character is written unless the +optional flag \fB\-nonewline\fR is given. If \fIchannelId\fR is +omitted, the string is written to the standard output channel, +\fBstdout\fR. +.RS +.PP +Newline characters in the output are translated by \fBchan puts\fR to +platform-specific end-of-line sequences according to the currently +configured value of the \fB\-translation\fR option for the channel +(for example, on PCs newlines are normally replaced with +carriage-return-linefeed sequences; see \fBchan configure\fR above for +details). +.PP +Tcl buffers output internally, so characters written with \fBchan +puts\fR may not appear immediately on the output file or device; Tcl +will normally delay output until the buffer is full or the channel is +closed. You can force output to appear immediately with the \fBchan +flush\fR command. +.PP +When the output buffer fills up, the \fBchan puts\fR command will +normally block until all the buffered data has been accepted for +output by the operating system. If \fIchannelId\fR is in nonblocking +mode then the \fBchan puts\fR command will not block even if the +operating system cannot accept the data. Instead, Tcl continues to +buffer the data and writes it in the background as fast as the +underlying file or device can accept it. The application must use the +Tcl event loop for nonblocking output to work; otherwise Tcl never +finds out that the file or device is ready for more output data. It +is possible for an arbitrarily large amount of data to be buffered for +a channel in nonblocking mode, which could consume a large amount of +memory. To avoid wasting memory, nonblocking I/O should normally be +used in an event-driven fashion with the \fBchan event\fR command +(don't invoke \fBchan puts\fR unless you have recently been notified +via a file event that the channel is ready for more output data). +.RE +.TP +\fBchan read \fIchannelId\fR ?\fInumChars\fR? +.TP +\fBchan read \fR?\fB\-nonewline\fR? \fIchannelId\fR +. +In the first form, the result will be the next \fInumChars\fR +characters read from the channel named \fIchannelId\fR; if +\fInumChars\fR is omitted, all characters up to the point when the +channel would signal a failure (whether an end-of-file, blocked or +other error condition) are read. In the second form (i.e. when +\fInumChars\fR has been omitted) the flag \fB\-nonewline\fR may be +given to indicate that any trailing newline in the string that has +been read should be trimmed. +.RS +.PP +If \fIchannelId\fR is in nonblocking mode, \fBchan read\fR may not +read as many characters as requested: once all available input has +been read, the command will return the data that is available rather +than blocking for more input. If the channel is configured to use a +multi-byte encoding, then there may actually be some bytes remaining +in the internal buffers that do not form a complete character. These +bytes will not be returned until a complete character is available or +end-of-file is reached. The \fB\-nonewline\fR switch is ignored if +the command returns before reaching the end of the file. +.PP +\fBChan read\fR translates end-of-line sequences in the input into +newline characters according to the \fB\-translation\fR option for the +channel (see \fBchan configure\fR above for a discussion on the ways +in which \fBchan configure\fR will alter input). +.PP +When reading from a serial port, most applications should configure +the serial port channel to be nonblocking, like this: +.CS +\fBchan configure \fIchannelId \fB\-blocking \fI0\fR. +.CE +Then \fBchan read\fR behaves much like described above. Note that +most serial ports are comparatively slow; it is entirely possible to +get a \fBreadable\fR event for each character read from them. Care +must be taken when using \fBchan read\fR on blocking serial ports: +.TP +\fBchan read \fIchannelId numChars\fR +. +In this form \fBchan read\fR blocks until \fInumChars\fR have been +received from the serial port. +.TP +\fBchan read \fIchannelId\fR +. +In this form \fBchan read\fR blocks until the reception of the +end-of-file character, see \fBchan configure -eofchar\fR. If there no +end-of-file character has been configured for the channel, then +\fBchan read\fR will block forever. +.RE +.TP +\fBchan seek \fIchannelId offset\fR ?\fIorigin\fR? +. +Sets the current access position within the underlying data stream for +the channel named \fIchannelId\fR to be \fIoffset\fR bytes relative to +\fIorigin\fR. \fIOffset\fR must be an integer (which may be negative) +and \fIorigin\fR must be one of the following: +.RS +.TP 10 +\fBstart\fR +. +The new access position will be \fIoffset\fR bytes from the start +of the underlying file or device. +.TP 10 +\fBcurrent\fR +. +The new access position will be \fIoffset\fR bytes from the current +access position; a negative \fIoffset\fR moves the access position +backwards in the underlying file or device. +.TP 10 +\fBend\fR +. +The new access position will be \fIoffset\fR bytes from the end of the +file or device. A negative \fIoffset\fR places the access position +before the end of file, and a positive \fIoffset\fR places the access +position after the end of file. +.PP +The \fIorigin\fR argument defaults to \fBstart\fR. +.PP +\fBChan seek\fR flushes all buffered output for the channel before the +command returns, even if the channel is in nonblocking mode. It also +discards any buffered and unread input. This command returns an empty +string. An error occurs if this command is applied to channels whose +underlying file or device does not support seeking. +.PP +Note that \fIoffset\fR values are byte offsets, not character offsets. +Both \fBchan seek\fR and \fBchan tell\fR operate in terms of bytes, +not characters, unlike \fBchan read\fR. +.RE +.TP +\fBchan tell \fIchannelId\fR +. +Returns a number giving the current access position within the +underlying data stream for the channel named \fIchannelId\fR. This +value returned is a byte offset that can be passed to \fBchan seek\fR +in order to set the channel to a particular position. Note that this +value is in terms of bytes, not characters like \fBchan read\fR. The +value returned is -1 for channels that do not support seeking. +.TP +\fBchan truncate \fIchannelId\fR ?\fIlength\fR? +. +Sets the byte length of the underlying data stream for the channel +named \fIchannelId\fR to be \fIlength\fR (or to the current byte +offset within the underlying data stream if \fIlength\fR is +omitted). The channel is flushed before truncation. + +.SH "SEE ALSO" +close(n), eof(n), fblocked(n), fconfigure(n), fcopy(n), file(n), +fileevent(n), flush(n), gets(n), open(n), puts(n), read(n), seek(n), +socket(n), tell(n) + +.SH KEYWORDS +channel, input, output, events, offset Index: doc/clock.n ================================================================== --- doc/clock.n +++ doc/clock.n @@ -817,15 +817,19 @@ an error may result if these years are used. .TP \fIISO 8601 point-in-time\fR An ISO 8601 point-in-time specification, such as \fBCCyymmddThhmmss\fR, where \fBT\fR is the literal T, "\fBCCyymmdd hhmmss\fR", or -\fBCCyymmddThh:mm:ss\fR. +\fBCCyymmddThh:mm:ss\fR. Note that only these three formats are accepted. +The command does \fInot\fR accept the full range of point-in-time +specifications specified in ISO8601. Other formats can be recognized by +giving an explicit \fI-format\fR option to the \fBclock scan\fR command. .TP \fIrelative time\fR A specification relative to the current time. The format is \fBnumber -unit\fR. Acceptable units are \fByear\fR, \fBfortnight\fR, \fBmonth\fR, \fBweek\fR, \fBday\fR, +unit\fR. Acceptable units are \fByear\fR, \fBfortnight\fR, +\fBmonth\fR, \fBweek\fR, \fBday\fR, \fBhour\fR, \fBminute\fR (or \fBmin\fR), and \fBsecond\fR (or \fBsec\fR). The unit can be specified as a singular or plural, as in \fB3 weeks\fR. These modifiers may also be specified: \fBtomorrow\fR, \fByesterday\fR, \fBtoday\fR, \fBnow\fR, \fBlast\fR, \fBthis\fR, \fBnext\fR, \fBago\fR. Index: doc/close.n ================================================================== --- doc/close.n +++ doc/close.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: close.n,v 1.8 2004/10/27 09:36:58 dkf Exp $ +'\" RCS: @(#) $Id: close.n,v 1.8.2.1 2005/04/10 23:14:42 kennykb Exp $ '\" .so man.macros .TH close n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -19,33 +19,28 @@ .SH DESCRIPTION .PP Closes the channel given by \fIchannelId\fR. .PP -.VS \fIChannelId\fR must be an identifier for an open channel such as a Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR), the return value from an invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel creation command provided by a Tcl extension. -.VE .PP All buffered output is flushed to the channel's output device, any buffered input is discarded, the underlying file or device is closed, and \fIchannelId\fR becomes unavailable for use. -.VS "" br .PP If the channel is blocking, the command does not return until all output is flushed. If the channel is nonblocking and there is unflushed output, the channel remains open and the command returns immediately; output will be flushed in the background and the channel will be closed when all the flushing is complete. -.VE .PP If \fIchannelId\fR is a blocking channel for a command pipeline then \fBclose\fR waits for the child processes to complete. -.VS "" br .PP If the channel is shared between interpreters, then \fBclose\fR makes \fIchannelId\fR unavailable in the invoking interpreter but has no other effect until all of the sharing interpreters have closed the channel. @@ -54,11 +49,10 @@ \fBinterp\fR command for a description of channel sharing. .PP Channels are automatically closed when an interpreter is destroyed and when the process exits. Channels are switched to blocking mode, to ensure that all output is correctly flushed before the process exits. -.VE .PP The command returns an empty string, and may generate an error if an error occurs while flushing output. If a command in a command pipeline created with \fBopen\fR returns an error, \fBclose\fR generates an error (similar to the \fBexec\fR command.) Index: doc/error.n ================================================================== --- doc/error.n +++ doc/error.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: error.n,v 1.7 2004/11/20 00:17:31 dgp Exp $ +'\" RCS: @(#) $Id: error.n,v 1.7.2.1 2004/12/08 18:24:35 kennykb Exp $ '\" .so man.macros .TH error n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -21,11 +21,11 @@ .PP Returns a \fBTCL_ERROR\fR code, which causes command interpretation to be unwound. \fIMessage\fR is a string that is returned to the application to indicate what went wrong. .PP -The \fB-errorinfo\fB return option of an interpreter is used +The \fB-errorinfo\fR return option of an interpreter is used to accumulate a stack trace of what was in progress when an error occurred; as nested commands unwind, the Tcl interpreter adds information to the \fB-errorinfo\fR return option. If the \fIinfo\fR argument is present, it is used to initialize the \fB-errorinfo\fR return options and Index: doc/expr.n ================================================================== --- doc/expr.n +++ doc/expr.n @@ -1,13 +1,14 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-2000 Sun Microsystems, Inc. +'\" 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: expr.n,v 1.18 2004/10/27 09:36:58 dkf Exp $ +'\" RCS: @(#) $Id: expr.n,v 1.18.2.2 2005/07/12 20:36:15 kennykb Exp $ '\" .so man.macros .TH expr n 8.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -82,12 +83,12 @@ As a Tcl command enclosed in brackets. The command will be executed and its result will be used as the operand. .IP [7] As a mathematical function whose arguments have any of the above -forms for operands, such as \fBsin($x)\fR. See below for a list of defined -functions. +forms for operands, such as \fBsin($x)\fR. See MATH FUNCTIONS below for +a discussion of how mathematical functions are handled. .LP Where the above substitutions occur (e.g. inside quoted strings), they are performed by the expression's instructions. However, the command parser may already have performed one round of substitution before the expression processor was called. @@ -209,135 +210,31 @@ only true if the entire expression is enclosed in braces; otherwise the Tcl parser will evaluate both \fB[a]\fR and \fB[b]\fR before invoking the \fBexpr\fR command. .SS "MATH FUNCTIONS" .PP -Tcl supports the following mathematical functions in expressions, all -of which work solely with floating-point numbers unless otherwise noted: -.DS -.ta 3c 6c 9c -\fBabs\fR \fBcosh\fR \fBlog\fR \fBsqrt\fR -\fBacos\fR \fBdouble\fR \fBlog10\fR \fBsrand\fR -\fBasin\fR \fBexp\fR \fBpow\fR \fBtan\fR -\fBatan\fR \fBfloor\fR \fBrand\fR \fBtanh\fR -\fBatan2\fR \fBfmod\fR \fBround\fR \fBwide\fR -\fBceil\fR \fBhypot\fR \fBsin\fR -\fBcos\fR \fBint\fR \fBsinh\fR -.DE -.PP -.TP -\fBabs(\fIarg\fB)\fR -Returns the absolute value of \fIarg\fR. \fIArg\fR may be either -integer or floating-point, and the result is returned in the same form. -.TP -\fBacos(\fIarg\fB)\fR -Returns the arc cosine of \fIarg\fR, in the range [\fI0\fR,\fIpi\fR] -radians. \fIArg\fR should be in the range [\fI-1\fR,\fI1\fR]. -.TP -\fBasin(\fIarg\fB)\fR -Returns the arc sine of \fIarg\fR, in the range [\fI-pi/2\fR,\fIpi/2\fR] -radians. \fIArg\fR should be in the range [\fI-1\fR,\fI1\fR]. -.TP -\fBatan(\fIarg\fB)\fR -Returns the arc tangent of \fIarg\fR, in the range [\fI-pi/2\fR,\fIpi/2\fR] -radians. -.TP -\fBatan2(\fIy, x\fB)\fR -Returns the arc tangent of \fIy\fR/\fIx\fR, in the range [\fI-pi\fR,\fIpi\fR] -radians. \fIx\fR and \fIy\fR cannot both be 0. If \fIx\fR is greater -than \fI0\fR, this is equivalent to \fBatan(\fIy/x\fB)\fR. -.TP -\fBceil(\fIarg\fB)\fR -Returns the smallest integral floating-point value (i.e. with a zero -fractional part) not less than \fIarg\fR. -.TP -\fBcos(\fIarg\fB)\fR -Returns the cosine of \fIarg\fR, measured in radians. -.TP -\fBcosh(\fIarg\fB)\fR -Returns the hyperbolic cosine of \fIarg\fR. If the result would cause -an overflow, an error is returned. -.TP -\fBdouble(\fIarg\fB)\fR -If \fIarg\fR is a floating-point value, returns \fIarg\fR, otherwise converts -\fIarg\fR to floating-point and returns the converted value. -.TP -\fBexp(\fIarg\fB)\fR -Returns the exponential of \fIarg\fR, defined as \fIe\fR**\fIarg\fR. -If the result would cause an overflow, an error is returned. -.TP -\fBfloor(\fIarg\fB)\fR -Returns the largest integral floating-point value (i.e. with a zero -fractional part) not greater than \fIarg\fR. -.TP -\fBfmod(\fIx, y\fB)\fR -Returns the floating-point remainder of the division of \fIx\fR by -\fIy\fR. If \fIy\fR is 0, an error is returned. -.TP -\fBhypot(\fIx, y\fB)\fR -Computes the length of the hypotenuse of a right-angled triangle -\fBsqrt(\fIx\fR*\fIx\fR+\fIy\fR*\fIy\fB)\fR. -.TP -\fBint(\fIarg\fB)\fR -If \fIarg\fR is an integer value of the same width as the machine -word, returns \fIarg\fR, otherwise -converts \fIarg\fR to an integer (of the same size as a machine word, -i.e. 32-bits on 32-bit systems, and 64-bits on 64-bit systems) by -truncation and returns the converted value. -.TP -\fBlog(\fIarg\fB)\fR -Returns the natural logarithm of \fIarg\fR. \fIArg\fR must be a -positive value. -.TP -\fBlog10(\fIarg\fB)\fR -Returns the base 10 logarithm of \fIarg\fR. \fIArg\fR must be a -positive value. -.TP -\fBpow(\fIx, y\fB)\fR -Computes the value of \fIx\fR raised to the power \fIy\fR. If \fIx\fR -is negative, \fIy\fR must be an integer value. -.TP -\fBrand()\fR -Returns a pseudo-random floating-point value in the range (\fI0\fR,\fI1\fR). -The generator algorithm is a simple linear congruential generator that -is not cryptographically secure. Each result from \fBrand\fR completely -determines all future results from subsequent calls to \fBrand\fR, so -\fBrand\fR should not be used to generate a sequence of secrets, such as -one-time passwords. The seed of the generator is initialized from the -internal clock of the machine or may be set with the \fBsrand\fR function. -.TP -\fBround(\fIarg\fB)\fR -If \fIarg\fR is an integer value, returns \fIarg\fR, otherwise converts -\fIarg\fR to integer by rounding and returns the converted value. -.TP -\fBsin(\fIarg\fB)\fR -Returns the sine of \fIarg\fR, measured in radians. -.TP -\fBsinh(\fIarg\fB)\fR -Returns the hyperbolic sine of \fIarg\fR. If the result would cause -an overflow, an error is returned. -.TP -\fBsqrt(\fIarg\fB)\fR -Returns the square root of \fIarg\fR. \fIArg\fR must be non-negative. -.TP -\fBsrand(\fIarg\fB)\fR -The \fIarg\fR, which must be an integer, is used to reset the seed for -the random number generator of \fBrand\fR. Returns the first random -number (see \fBrand()\fR) from that seed. Each interpreter has its own seed. -.TP -\fBtan(\fIarg\fB)\fR -Returns the tangent of \fIarg\fR, measured in radians. -.TP -\fBtanh(\fIarg\fB)\fR -Returns the hyperbolic tangent of \fIarg\fR. -.TP -\fBwide(\fIarg\fB)\fR -Converts \fIarg\fR to an integer value at least 64-bits wide (by sign-extension -if \fIarg\fR is a 32-bit number) if it is not one already. -.PP -In addition to these predefined functions, applications may -define additional functions using \fBTcl_CreateMathFunc\fR(). +.VS 8.5 +When the expression parser encounters a mathematical function +such as \fBsin($x)\fR, it replaces it with a call to an ordinary +Tcl function in the \fBtcl::mathfunc\fR namespace. The processing +of an expression such as: +.CS +\fBexpr {sin($x+$y)}\fR +.CE +is the same in every way as the processing of: +.CS +\fBexpr {[tcl::mathfunc::sin [expr {$x+$y}]]}\fR +.CE +The executor will search for \fBtcl::mathfunc::sin\fR using the usual +rules for resolving functions in namespaces. Either +\fB::tcl::mathfunc::sin\fR or \fB[namespace +current]::tcl::mathfunc::sin\fR will satisfy the request, and others +may as well (depending on the current \fBnamespace path\fR setting). +.PP +See the \fBmathfunc\fR(n) manual page for the math functions that are +available by default. +.VE 8.5 .SS "TYPES, OVERFLOW, AND PRECISION" .PP All internal computations involving integers are done with the C type \fIlong\fR, and all internal computations involving floating-point are done with the C type \fIdouble\fR. @@ -428,11 +325,11 @@ each time the expression is executed. .SH EXAMPLES Define a procedure that computes an "interesting" mathematical function: .CS -proc calc {x y} { +proc tcl::mathfunc::calc {x y} { \fBexpr\fR { ($x**2 - $y**2) / exp($x**2 + $y**2) } } .CE .PP Convert polar coordinates into cartesian coordinates: @@ -468,9 +365,16 @@ .CS set randNum [\fBexpr\fR { int(100 * rand()) }] .CE .SH "SEE ALSO" -array(n), for(n), if(n), string(n), Tcl(n), while(n) +array(n), for(n), if(n), mathfunc(n), namespace(n), proc(n), string(n), Tcl(n), while(n) .SH KEYWORDS arithmetic, boolean, compare, expression, fuzzy comparison + +.SH COPYRIGHT +Copyright (c) 1993 The Regents of the University of California. +.br +Copyright (c) 1994-2000 Sun Microsystems Incorporated. +.br +Copyright (c) 2005 by Kevin B. Kenny . All rights reserved. Index: doc/fblocked.n ================================================================== --- doc/fblocked.n +++ doc/fblocked.n @@ -2,11 +2,11 @@ '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: fblocked.n,v 1.6 2004/10/27 12:53:22 dkf Exp $ +'\" RCS: @(#) $Id: fblocked.n,v 1.6.2.1 2005/04/10 23:14:43 kennykb Exp $ .so man.macros .TH fblocked n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -23,16 +23,14 @@ For example, if \fBgets\fR is invoked when there are only three characters available for input and no end-of-line sequence, \fBgets\fR returns an empty string and a subsequent call to \fBfblocked\fR will return 1. .PP -.VS \fIChannelId\fR must be an identifier for an open channel such as a Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR), the return value from an invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel creation command provided by a Tcl extension. -.VE .SH EXAMPLE The \fBfblocked\fR command is particularly useful when writing network servers, as it allows you to write your code in a line-by-line style without preventing the servicing of other connections. This can be seen in this simple echo-service: Index: doc/fconfigure.n ================================================================== --- doc/fconfigure.n +++ doc/fconfigure.n @@ -2,11 +2,11 @@ '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: fconfigure.n,v 1.11 2004/10/27 12:53:22 dkf Exp $ +'\" RCS: @(#) $Id: fconfigure.n,v 1.11.2.1 2005/04/25 21:37:18 kennykb Exp $ '\" .so man.macros .TH fconfigure n 8.3 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -89,15 +89,18 @@ .PP If a file contains pure binary data (for instance, a JPEG image), the encoding for the channel should be configured to be \fBbinary\fR. Tcl will then assign no interpretation to the data in the file and simply read or write raw bytes. The Tcl \fBbinary\fR command can be used to manipulate this -byte-oriented data. +byte-oriented data. It is usually better to set the +\fB\-translation\fR option to \fBbinary\fR when you want to transfer +binary data, as this turns off the other automatic interpretations of +the bytes in the stream as well. .PP The default encoding for newly opened channels is the same platform- and locale-dependent system encoding used for interfacing with the operating -system. +system, as returned by \fBencoding system\fR. .RE .TP \fB\-eofchar\fR \fIchar\fR .TP \fB\-eofchar\fR \fB{\fIinChar outChar\fB}\fR Index: doc/fcopy.n ================================================================== --- doc/fcopy.n +++ doc/fcopy.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: fcopy.n,v 1.4 2004/09/06 09:44:56 dkf Exp $ +'\" RCS: @(#) $Id: fcopy.n,v 1.4.2.1 2005/04/25 21:37:19 kennykb Exp $ '\" .so man.macros .TH fcopy n 8.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -70,26 +70,39 @@ can be different than the number of bytes written to \fIoutchan\fR. Only the number of bytes written to \fIoutchan\fR is reported, either as the return value of a synchronous \fBfcopy\fP or as the argument to the callback for an asynchronous \fBfcopy\fP. .PP -\fBFcopy\fR obeys the encodings configured for the channels. This +\fBFcopy\fR obeys the encodings and character translations configured +for the channels. This means that the incoming characters are converted internally first UTF-8 and then into the encoding of the channel \fBfcopy\fR writes to. See the manual entry for \fBfconfigure\fR for details on the -\fB\-encoding\fR option. No conversion is done if both channels are -set to encoding "binary". If only the output channel is set to +\fB\-encoding\fR and \fB\-translation\fR options. No conversion is +done if both channels are +set to encoding "binary" and have matching translations. If only the +output channel is set to encoding "binary" the system will write the internal UTF-8 representation of the incoming characters. If only the input channel is set to encoding "binary" the system will assume that the incoming bytes are valid UTF-8 characters and convert them according to the output encoding. The behaviour of the system for bytes which are not valid UTF-8 characters is undefined in this case. -.SH EXAMPLE +.SH EXAMPLES +.PP +The first example transfers the contents of one channel exactly to +another. Note that when copying one file to another, it is better to +use \fBfile copy\fR which also copies file metadata (e.g. the file +access permissions) where possible. +.DS +fconfigure $in -translation binary +fconfigure $out -translation binary +\fBfcopy\fR $in $out +.DE .PP -This first example shows how the callback gets +This second example shows how the callback gets passed the number of bytes transferred. It also uses vwait to put the application into the event loop. Of course, this simplified example could be done without the command callback. .DS @@ -102,16 +115,15 @@ # error occurred during the copy } } set in [open $file1] set out [socket $server $port] -fcopy $in $out -command [list Cleanup $in $out] +\fBfcopy\fR $in $out -command [list Cleanup $in $out] vwait total - .DE .PP -The second example copies in chunks and tests for end of file +The third example copies in chunks and tests for end of file in the command callback .DS proc CopyMore {in out chunk bytes {error {}}} { global total done incr total $bytes @@ -118,23 +130,22 @@ if {([string length $error] != 0) || [eof $in] { set done $total close $in close $out } else { - fcopy $in $out -command [list CopyMore $in $out $chunk] \\ + \fBfcopy\fR $in $out -command [list CopyMore $in $out $chunk] \\ -size $chunk } } set in [open $file1] set out [socket $server $port] set chunk 1024 set total 0 -fcopy $in $out -command [list CopyMore $in $out $chunk] -size $chunk +\fBfcopy\fR $in $out -command [list CopyMore $in $out $chunk] -size $chunk vwait done - .DE .SH "SEE ALSO" -eof(n), fblocked(n), fconfigure(n) +eof(n), fblocked(n), fconfigure(n), file(n) .SH KEYWORDS blocking, channel, end of line, end of file, nonblocking, read, translation Index: doc/file.n ================================================================== --- doc/file.n +++ doc/file.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: file.n,v 1.38 2004/10/27 14:24:37 dkf Exp $ +'\" RCS: @(#) $Id: file.n,v 1.38.2.1 2005/04/10 23:14:43 kennykb Exp $ '\" .so man.macros .TH file n 8.3 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -79,19 +79,17 @@ clears the readonly attribute of the file. \fB-rsrclength\fR gives the length of the resource fork of the file, this attribute can only be set to the value 0, which results in the resource fork being stripped off the file. .RE -.VS .TP \fBfile channels ?\fIpattern\fR? . If \fIpattern\fR isn't specified, returns a list of names of all registered open channels in this interpreter. If \fIpattern\fR is specified, only those names matching \fIpattern\fR are returned. Matching is determined using the same rules as for \fBstring match\fR. -.VE .TP \fBfile copy \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR \fItarget\fR .TP \fBfile copy \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR ?\fIsource\fR ...? \fItargetDir\fR .RS Index: doc/fileevent.n ================================================================== --- doc/fileevent.n +++ doc/fileevent.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: fileevent.n,v 1.7 2004/11/20 00:17:32 dgp Exp $ +'\" RCS: @(#) $Id: fileevent.n,v 1.7.2.1 2005/04/10 23:14:43 kennykb Exp $ '\" .so man.macros .TH fileevent n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -32,17 +32,15 @@ data arrives, it will not be able to service other events, so it will appear to the user to ``freeze up''. With \fBfileevent\fR, the process can tell when data is present and only invoke \fBgets\fR or \fBread\fR when they won't block. .PP -.VS The \fIchannelId\fR argument to \fBfileevent\fR refers to an open channel such as a Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR), the return value from an invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel creation command provided by a Tcl extension. -.VE .PP If the \fIscript\fR argument is specified, then \fBfileevent\fR creates a new event handler: \fIscript\fR will be evaluated whenever the channel becomes readable or writable (depending on the second argument to \fBfileevent\fR). Index: doc/flush.n ================================================================== --- doc/flush.n +++ doc/flush.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: flush.n,v 1.6 2004/10/27 12:53:22 dkf Exp $ +'\" RCS: @(#) $Id: flush.n,v 1.6.2.1 2005/04/10 23:14:43 kennykb Exp $ '\" .so man.macros .TH flush n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -19,17 +19,15 @@ .SH DESCRIPTION .PP Flushes any output that has been buffered for \fIchannelId\fR. .PP -.VS \fIChannelId\fR must be an identifier for an open channel such as a Tcl standard channel (\fBstdout\fR or \fBstderr\fR), the return value from an invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel creation command provided by a Tcl extension. The channel must have been opened for writing. -.VE .PP If the channel is in blocking mode the command does not return until all the buffered output has been flushed to the channel. If the channel is in nonblocking mode, the command may return before all buffered output has been flushed; the remainder will be flushed in the background as fast as the Index: doc/foreach.n ================================================================== --- doc/foreach.n +++ doc/foreach.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: foreach.n,v 1.5 2004/11/26 10:02:23 dkf Exp $ +'\" RCS: @(#) $Id: foreach.n,v 1.5.2.1 2004/12/08 18:24:35 kennykb Exp $ '\" .so man.macros .TH foreach n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -53,11 +53,11 @@ .SH EXAMPLES This loop prints every value in a list together with the square and cube of the value: .CS '\" Maintainers: notice the tab hacking below! -.ta 32 +.ta 3i set values {1 3 5 7 2 4 6 8} ;# Odd numbers first, for fun! puts "Value\\tSquare\\tCube" ;# Neat-looking header \fBforeach\fR x $values { ;# Now loop and print... puts " $x\\t [expr {$x**2}]\\t [expr {$x**3}]" } Index: doc/format.n ================================================================== --- doc/format.n +++ doc/format.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: format.n,v 1.10 2004/10/27 12:53:22 dkf Exp $ +'\" RCS: @(#) $Id: format.n,v 1.10.2.1 2005/04/10 23:14:43 kennykb Exp $ '\" .so man.macros .TH format n 8.1 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -128,16 +128,14 @@ The fifth part of a conversion specifier is a length modifier, which must be \fBh\fR or \fBl\fR. If it is \fBh\fR it specifies that the numeric value should be truncated to a 16-bit value before converting. This option is rarely useful. -.VS 8.4 If it is \fBl\fR it specifies that the numeric value should be (at least) a 64-bit value. If neither \fBh\fR nor \fBl\fR are present, numeric values are interpreted as being values of the width of the native machine word, as described by \fBtcl_platform(wordSize)\fR. -.VE .PP The last thing in a conversion specifier is an alphabetic character that determines what kind of conversion to perform. The following conversion characters are currently supported: .TP 10 @@ -156,15 +154,13 @@ Convert integer to unsigned octal string. .TP 10 \fBx\fR or \fBX\fR Convert integer to unsigned hexadecimal string, using digits ``0123456789abcdef'' for \fBx\fR and ``0123456789ABCDEF'' for \fBX\fR). -.VS .TP 10 \fBc\fR Convert integer to the Unicode character it represents. -.VE .TP 10 \fBs\fR No conversion; just insert string. .TP 10 \fBf\fR @@ -205,16 +201,14 @@ .IP [2] For \fB%c\fR conversions the argument must be a decimal string, which will then be converted to the corresponding character value. .IP [3] The \fBl\fR modifier -.VS 8.4 is ignored for real values and on 64-bit platforms, which are always converted as if the \fBl\fR modifier were present (i.e. the types \fBdouble\fR and \fBlong\fR are used for the internal representation of real and integer values, respectively). -.VE 8.4 If the \fBh\fR modifier is specified then integer values are truncated to \fBshort\fR before conversion. Both \fBh\fR and \fBl\fR modifiers are ignored on all other conversions. .SH EXAMPLES Convert the output of \fBtime\fR into seconds to an accuracy of Index: doc/gets.n ================================================================== --- doc/gets.n +++ doc/gets.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: gets.n,v 1.6 2004/10/27 12:53:22 dkf Exp $ +'\" RCS: @(#) $Id: gets.n,v 1.6.2.1 2005/04/10 23:14:43 kennykb Exp $ '\" .so man.macros .TH gets n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -21,17 +21,15 @@ .PP This command reads the next line from \fIchannelId\fR, returns everything in the line up to (but not including) the end-of-line character(s), and discards the end-of-line character(s). .PP -.VS \fIChannelId\fR must be an identifier for an open channel such as the Tcl standard input channel (\fBstdin\fR), the return value from an invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel creation command provided by a Tcl extension. The channel must have been opened for input. -.VE .PP If \fIvarName\fR is omitted the line is returned as the result of the command. If \fIvarName\fR is specified then the line is placed in the variable by that name and the return value is a count of the number of characters Index: doc/glob.n ================================================================== --- doc/glob.n +++ doc/glob.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: glob.n,v 1.17 2004/10/27 12:53:22 dkf Exp $ +'\" RCS: @(#) $Id: glob.n,v 1.17.2.1 2005/07/12 20:36:15 kennykb Exp $ '\" .so man.macros .TH glob n 8.3 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -19,11 +19,13 @@ .SH DESCRIPTION .PP This command performs file name ``globbing'' in a fashion similar to the csh shell. It returns a list of the files whose names match any -of the \fIpattern\fR arguments. +of the \fIpattern\fR arguments. No particular order is guaranteed +in the list, so if a sorted list is required the caller should use +\fBlsort\fR. .LP If the initial arguments to \fBglob\fR start with \fB\-\fR then they are treated as switches. The following switches are currently supported: .TP @@ -155,15 +157,10 @@ ``./''. This means care must be taken if those names are later to be used with \fBfile join\fR, to avoid them being interpreted as absolute paths pointing to a given user's home directory. .SH "PORTABILITY ISSUES" .PP -Unlike other Tcl commands that will accept both network and native -style names (see the \fBfilename\fR manual entry for details on how -native and network names are specified), the \fBglob\fR command only -accepts native names. -.TP \fBWindows\fR . For Windows UNC names, the servername and sharename components of the path may not contain ?, *, or [] constructs. On Windows NT, if \fIpattern\fR is of the form ``\fB~\fIusername\fB@\fIdomain\fR'' it refers to the home Index: doc/info.n ================================================================== --- doc/info.n +++ doc/info.n @@ -5,11 +5,11 @@ '\" Copyright (c) 1998-2000 Ajuba Solutions '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: info.n,v 1.14 2004/10/27 14:24:37 dkf Exp $ +'\" RCS: @(#) $Id: info.n,v 1.14.2.2 2005/07/12 20:36:15 kennykb Exp $ '\" .so man.macros .TH info n 8.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -38,11 +38,14 @@ Returns a count of the total number of commands that have been invoked in this interpreter. .TP \fBinfo commands \fR?\fIpattern\fR? If \fIpattern\fR isn't specified, -returns a list of names of all the Tcl commands in the current namespace, +'\" Do not move this .VS above the .TP +.VS 8.5 +returns a list of names of all the Tcl commands visible +(i.e. executable without using a qualified name) to the current namespace, including both the built-in commands written in C and the command procedures defined using the \fBproc\fR command. If \fIpattern\fR is specified, only those names matching \fIpattern\fR are returned. Matching is determined using the same rules as for \fBstring match\fR. @@ -51,11 +54,15 @@ using a sequence of namespace names separated by double colons (\fB::\fR), and may have pattern matching special characters at the end to specify a set of commands in that namespace. If \fIpattern\fR is a qualified name, the resulting list of command names has each one qualified with the name -of the specified namespace. +of the specified namespace, and only the commands defined in the named +namespace are returned. +'\" Technically, most of this hasn't changed; that's mostly just the +'\" way it always worked. Hardly anyone knew that though. +.VE 8.5 .TP \fBinfo complete \fIcommand\fR Returns 1 if \fIcommand\fR is a complete Tcl command in the sense of having no unclosed quotes, braces, brackets or array element names. If the command doesn't appear to be complete then 0 is returned. @@ -73,19 +80,17 @@ .TP \fBinfo exists \fIvarName\fR Returns \fB1\fR if the variable named \fIvarName\fR exists in the current context (either as a global or local variable) and has been defined by being given a value, returns \fB0\fR otherwise. -.VS 8.4 .TP \fBinfo functions \fR?\fIpattern\fR? If \fIpattern\fR isn't specified, returns a list of all the math functions currently defined. If \fIpattern\fR is specified, only those functions whose name matches \fIpattern\fR are returned. Matching is determined using the same rules as for \fBstring match\fR. -.VE .TP \fBinfo globals \fR?\fIpattern\fR? If \fIpattern\fR isn't specified, returns a list of all the names of currently-defined global variables. Global variables are variables in the global namespace. @@ -94,17 +99,15 @@ \fBstring match\fR. .TP \fBinfo hostname\fR Returns the name of the computer on which this invocation is being executed. -.VS Note that this name is not guaranteed to be the fully qualified domain name of the host. Where machines have several different names (as is common on systems with both TCP/IP (DNS) and NetBIOS-based networking installed,) it is the name that is suitable for TCP/IP networking that is returned. -.VE .TP \fBinfo level\fR ?\fInumber\fR? If \fInumber\fR is not specified, this command returns a number giving the stack level of the invoking procedure, or 0 if the command is invoked at top-level. If \fInumber\fR is specified, Index: doc/interp.n ================================================================== --- doc/interp.n +++ doc/interp.n @@ -3,11 +3,11 @@ '\" Copyright (c) 2004 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: interp.n,v 1.22 2004/11/21 23:17:50 dgp Exp $ +'\" RCS: @(#) $Id: interp.n,v 1.22.2.1 2005/04/10 23:14:43 kennykb Exp $ '\" .so man.macros .TH interp n 7.6 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -36,11 +36,11 @@ interpreter. The only other connections between interpreters are through environment variables (the \fBenv\fR variable), which are normally shared among all interpreters in the application, .VS 8.5 and by resource limit exceeded callbacks. -.VE +.VE 8.5 Note that the name space for files (such as the names returned by the \fBopen\fR command) is no longer shared between interpreters. Explicit commands are provided to share files and to transfer references to open files from one interpreter to another. Index: doc/lappend.n ================================================================== --- doc/lappend.n +++ doc/lappend.n @@ -4,11 +4,11 @@ '\" Copyright (c) 2001 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: lappend.n,v 1.9 2004/10/27 12:53:22 dkf Exp $ +'\" RCS: @(#) $Id: lappend.n,v 1.9.2.1 2005/04/10 23:14:43 kennykb Exp $ '\" .so man.macros .TH lappend n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -41,13 +41,10 @@ % \fBlappend\fR var 3 4 5 1 2 3 4 5 .CE .SH "SEE ALSO" -list(n), lindex(n), linsert(n), llength(n), -.VS 8.4 -lset(n) -.VE +list(n), lindex(n), linsert(n), llength(n), lset(n), lsort(n), lrange(n) .SH KEYWORDS append, element, list, variable Index: doc/lindex.n ================================================================== --- doc/lindex.n +++ doc/lindex.n @@ -4,11 +4,11 @@ '\" Copyright (c) 2001 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: lindex.n,v 1.8 2004/10/27 12:53:22 dkf Exp $ +'\" RCS: @(#) $Id: lindex.n,v 1.8.2.2 2005/05/05 17:55:24 kennykb Exp $ '\" .so man.macros .TH lindex n 8.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -17,11 +17,10 @@ .SH SYNOPSIS \fBlindex \fIlist ?index...?\fR .BE .SH DESCRIPTION .PP -.VS 8.4 The \fBlindex\fP command accepts a parameter, \fIlist\fP, which it treats as a Tcl list. It also accepts zero or more \fIindices\fP into the list. The indices may be presented either consecutively on the command line, or grouped in a Tcl list and presented as a single argument. @@ -37,24 +36,24 @@ In this case, the return value of \fBlindex\fR is simply the value of the \fIlist\fR parameter. .PP When presented with a single index, the \fBlindex\fR command treats \fIlist\fR as a Tcl list and returns the -.VE \fIindex\fR'th element from it (0 refers to the first element of the list). In extracting the element, \fBlindex\fR observes the same rules concerning braces and quotes and backslashes as the Tcl command interpreter; however, variable substitution and command substitution do not occur. If \fIindex\fR is negative or greater than or equal to the number of elements in \fIvalue\fR, then an empty string is returned. -If \fIindex\fR has the value \fBend\fR, it refers to the last element -in the list, and \fBend\-\fIinteger\fR refers to the last element in -the list minus the specified integer offset. +.VS 8.5 +The interpretation of each simple \fIindex\fR value is the same as +for the command \fBstring index\fR, supporting simple index +arithmetic and indices relative to the end of the list. +.VE 8.5 .PP -.VS 8.4 If additional \fIindex\fR arguments are supplied, then each argument is used in turn to select an element from the previous indexing operation, allowing the script to select elements from sublists. The command, .CS lindex $a 1 2 3 @@ -78,16 +77,14 @@ \fBlindex\fR {{a b c} {d e f} {g h i}} 2 1 \fI=> h\fR \fBlindex\fR {{a b c} {d e f} {g h i}} {2 1} \fI=> h\fR \fBlindex\fR {{{a b} {c d}} {{e f} {g h}}} 1 1 0 \fI=> g\fR \fBlindex\fR {{{a b} {c d}} {{e f} {g h}}} {1 1 0} \fI=> g\fR .CE -.VE .SH "SEE ALSO" list(n), lappend(n), linsert(n), llength(n), lsearch(n), -.VS 8.4 -lset(n), +lset(n), lsort(n), lrange(n), lreplace(n), +.VS 8.5 +string(n) .VE -lsort(n), -lrange(n), lreplace(n) .SH KEYWORDS element, index, list Index: doc/linsert.n ================================================================== --- doc/linsert.n +++ doc/linsert.n @@ -4,11 +4,11 @@ '\" Copyright (c) 2001 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: linsert.n,v 1.10 2004/10/27 12:53:22 dkf Exp $ +'\" RCS: @(#) $Id: linsert.n,v 1.10.2.2 2005/05/05 17:55:24 kennykb Exp $ '\" .so man.macros .TH linsert n 8.2 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -22,15 +22,16 @@ .PP This command produces a new list from \fIlist\fR by inserting all of the \fIelement\fR arguments just before the \fIindex\fR'th element of \fIlist\fR. Each \fIelement\fR argument will become a separate element of the new list. If \fIindex\fR is less than or equal to zero, then the new -elements are inserted at the beginning of the list. If \fIindex\fR has the -value \fBend\fR, or if it is greater than or equal to the number of -elements in the list, then the new elements are appended to the list. -\fBend\-\fIinteger\fR refers to the last element in the list minus the -specified integer offset. +elements are inserted at the beginning of the list. +.VS 8.5 +The interpretation of the \fIindex\fR value is the same as +for the command \fBstring index\fR, supporting simple index +arithmetic and indices relative to the end of the list. +.VE .SH EXAMPLE Putting some values into a list, first indexing from the start and then indexing from the end, and then chaining them together: .CS set oldList {the fox jumps over the dog} @@ -39,12 +40,13 @@ # The old lists still exist though... set newerList [\fBlinsert\fR [\fBlinsert\fR $oldList end-1 quick] 1 lazy] .CE .SH "SEE ALSO" -.VS 8.4 list(n), lappend(n), lindex(n), llength(n), lsearch(n), -lset(n), lsort(n), lrange(n), lreplace(n) +lset(n), lsort(n), lrange(n), lreplace(n), +.VS 8.5 +string(n) .VE .SH KEYWORDS element, insert, list Index: doc/llength.n ================================================================== --- doc/llength.n +++ doc/llength.n @@ -4,11 +4,11 @@ '\" Copyright (c) 2001 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: llength.n,v 1.8 2004/10/27 12:53:22 dkf Exp $ +'\" RCS: @(#) $Id: llength.n,v 1.8.2.1 2005/04/10 23:14:43 kennykb Exp $ '\" .so man.macros .TH llength n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -48,12 +48,10 @@ % set var { }; puts "[string length $var],[\fBllength\fR $var]" 1,0 .CE .SH "SEE ALSO" -.VS 8.4 list(n), lappend(n), lindex(n), linsert(n), lsearch(n), lset(n), lsort(n), lrange(n), lreplace(n) -.VE .SH KEYWORDS element, list, length Index: doc/load.n ================================================================== --- doc/load.n +++ doc/load.n @@ -2,11 +2,11 @@ '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: load.n,v 1.12 2004/10/27 12:53:22 dkf Exp $ +'\" RCS: @(#) $Id: load.n,v 1.12.2.2 2005/05/21 15:10:25 kennykb Exp $ '\" .so man.macros .TH load n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -90,17 +90,14 @@ Tcl tries to guess the name of the package. This may be done differently on different platforms. The default guess, which is used on most UNIX platforms, is to take the last element of \fIfileName\fR, strip off the first three characters if they are \fBlib\fR, and use any following -.VS alphabetic and underline characters as the module name. -.VE For example, the command \fBload libxyz4.2.so\fR uses the module name \fBxyz\fR and the command \fBload bin/last.so {}\fR uses the module name \fBlast\fR. -.VS "" br .PP If \fIfileName\fR is an empty string, then \fIpackageName\fR must be specified. The \fBload\fR command first searches for a statically loaded package (one that has been registered by calling the \fBTcl_StaticPackage\fR @@ -107,11 +104,10 @@ procedure) by that name; if one is found, it is used. Otherwise, the \fBload\fR command searches for a dynamically loaded package by that name, and uses it if it is found. If several different files have been \fBload\fRed with different versions of the package, Tcl picks the file that was loaded first. -.VE .SH "PORTABILITY ISSUES" .TP \fBWindows\fR\0\0\0\0\0 . When a load fails with "library not found" error, it is also possible @@ -135,11 +131,11 @@ .PP .CS #include #include static int fooCmd(ClientData clientData, - Tcl_Interp *interp, int objc, char * CONST objv[]) { + Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { printf("called with %d arguments\\n", objc); return TCL_OK; } int Foo_Init(Tcl_Interp *interp) { if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { @@ -157,11 +153,11 @@ .PP .CS # Load the extension switch $tcl_platform(platform) { windows { - \fBload\fR ./foo.dll + \fBload\fR [file join [pwd] foo.dll] } unix { \fBload\fR ./libfoo[info sharedlibextension] } } Index: doc/lrange.n ================================================================== --- doc/lrange.n +++ doc/lrange.n @@ -4,11 +4,11 @@ '\" Copyright (c) 2001 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: lrange.n,v 1.9 2004/10/27 12:53:22 dkf Exp $ +'\" RCS: @(#) $Id: lrange.n,v 1.9.2.2 2005/05/05 17:55:25 kennykb Exp $ '\" .so man.macros .TH lrange n 7.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -21,13 +21,16 @@ .SH DESCRIPTION .PP \fIList\fR must be a valid Tcl list. This command will return a new list consisting of elements \fIfirst\fR through \fIlast\fR, inclusive. -\fIFirst\fR or \fIlast\fR -may be \fBend\fR (or any abbreviation of it) to refer to the last -element of the list. +.VS 8.5 +The index values \fIfirst\fR and \fIlast\fR are interpreted +the same as index values for the command \fBstring index\fR, +supporting simple index arithmetic and indices relative to the +end of the list. +.VE If \fIfirst\fR is less than zero, it is treated as if it were zero. If \fIlast\fR is greater than or equal to the number of elements in the list, then it is treated as if it were \fBend\fR. If \fIfirst\fR is greater than \fIlast\fR then an empty string is returned. @@ -64,12 +67,13 @@ % \fBlrange\fR $var 1 1 {elements to} .CE .SH "SEE ALSO" -.VS 8.4 list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), -lset(n), lreplace(n), lsort(n) +lset(n), lreplace(n), lsort(n), +.VS 8.5 +string(n) .VE .SH KEYWORDS element, list, range, sublist Index: doc/lreplace.n ================================================================== --- doc/lreplace.n +++ doc/lreplace.n @@ -4,11 +4,11 @@ '\" Copyright (c) 2001 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: lreplace.n,v 1.10 2004/10/27 12:53:22 dkf Exp $ +'\" RCS: @(#) $Id: lreplace.n,v 1.10.2.2 2005/05/05 17:55:25 kennykb Exp $ '\" .so man.macros .TH lreplace n 7.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -20,15 +20,21 @@ .SH DESCRIPTION .PP \fBlreplace\fR returns a new list formed by replacing one or more elements of \fIlist\fR with the \fIelement\fR arguments. -\fIfirst\fR and \fIlast\fR specify the first and last index of the -range of elements to replace. 0 refers to the first element of the -list, and \fBend\fR (or any abbreviation of it) may be used to refer -to the last element of the list. If \fIlist\fR is empty, then -\fIfirst\fR and \fIlast\fR are ignored. +.VS 8.5 +\fIfirst\fR and \fIlast\fR are index values specifying the first and +last elements of the range to replace. +The index values \fIfirst\fR and \fIlast\fR are interpreted +the same as index values for the command \fBstring index\fR, +supporting simple index arithmetic and indices relative to the +end of the list. +0 refers to the first element of the +list, and \fBend\fR refers to the last element of the list. +If \fIlist\fR is empty, then \fIfirst\fR and \fIlast\fR are ignored. +.VE If \fIfirst\fR is less than zero, it is considered to refer to the first element of the list. For non-empty lists, the element indicated by \fIfirst\fR must exist. @@ -63,12 +69,14 @@ % set var [\fBlreplace\fR $var end end] a b c d .CE .SH "SEE ALSO" -.VS 8.4 list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), -lset(n), lrange(n), lsort(n) +lset(n), lrange(n), lsort(n), +.VS 8.5 +string(n) .VE + .SH KEYWORDS element, list, replace Index: doc/lsearch.n ================================================================== --- doc/lsearch.n +++ doc/lsearch.n @@ -1,16 +1,15 @@ -'\" -*- nroff -*- '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved. '\" Copyright (c) 2003-2004 Donal K. Fellows. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: lsearch.n,v 1.21 2004/09/02 13:55:55 dkf Exp $ +'\" RCS: @(#) $Id: lsearch.n,v 1.21.2.3 2005/07/12 20:36:15 kennykb Exp $ '\" .so man.macros .TH lsearch n 8.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -33,11 +32,12 @@ If all matching style options are omitted, the default matching style is \fB\-glob\fR. If more than one matching style is specified, the last matching style given takes precedence. .TP \fB\-exact\fR -The list element must contain exactly the same string as \fIpattern\fR. +\fIPattern\fR is a literal string that is compared for exact equality +against each list element. .TP \fB\-glob\fR \fIPattern\fR is a glob-style pattern which is matched against each list element using the same rules as the \fBstring match\fR command. .TP @@ -69,14 +69,16 @@ \fB\-not\fR This negates the sense of the match, returning the index of the first non-matching value in the list. .TP \fB\-start\fR\0\fIindex\fR -The list is searched starting at position \fIindex\fR. If \fIindex\fR -has the value \fBend\fR, it refers to the last element in the list, -and \fBend\-\fIinteger\fR refers to the last element in the list minus -the specified integer offset. +The list is searched starting at position \fIindex\fR. +.VS 8.5 +The interpretation of the \fIindex\fR value is the same as +for the command \fBstring index\fR, supporting simple index +arithmetic and indices relative to the end of the list. +.VE 8.5 .SS "CONTENTS DESCRIPTION OPTIONS" These options describe how to interpret the items in the list being searched. They are only meaningful when used with the \fB\-exact\fR and \fB\-sorted\fR options. If more than one is specified, the last one takes precedence. The default is \fB\-ascii\fR. @@ -92,10 +94,17 @@ the \fB\-sorted\fR option is given, because values are only dictionary-equal when exactly equal. .TP \fB\-integer\fR The list elements are to be compared as integers. +.VS 8.5 +.TP +\fB\-nocase\fR +Causes comparisons to be handled in a case-insensitive manner. Has no +effect if combined with the \fB\-dictionary\fR, \fB\-integer\fR, or +\fB\-real\fR options. +.VE 8.5 .TP \fB\-real\fR The list elements are to be compared as floating-point values. .SS "SORTED LIST OPTIONS" These options (only meaningful with the \fB\-sorted\fR option) specify @@ -165,9 +174,17 @@ => {a abc} {b bcd} .CE .SH "SEE ALSO" foreach(n), list(n), lappend(n), lindex(n), linsert(n), llength(n), -lset(n), lsort(n), lrange(n), lreplace(n) +lset(n), lsort(n), lrange(n), lreplace(n), +.VS 8.5 +string(n) +.VE + .SH KEYWORDS list, match, pattern, regular expression, search, string + +'\" Local Variables: +'\" mode: nroff +'\" End: Index: doc/lset.n ================================================================== --- doc/lset.n +++ doc/lset.n @@ -2,11 +2,11 @@ '\" Copyright (c) 2001 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: lset.n,v 1.7 2003/12/01 21:27:14 msofer Exp $ +'\" RCS: @(#) $Id: lset.n,v 1.7.2.1 2005/05/05 17:55:26 kennykb Exp $ '\" .so man.macros .TH lset n 8.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -50,13 +50,15 @@ command. .PP If \fIindex\fR is negative or greater than or equal to the number of elements in \fI$varName\fR, then an error occurs. .PP -If \fIindex\fR has the value \fBend\fR, it refers to the last element -in the list, and \fBend\-\fIinteger\fR refers to the last element in -the list minus the specified integer offset. +.VS 8.5 +The interpretation of each simple \fIindex\fR value is the same as +for the command \fBstring index\fR, supporting simple index +arithmetic and indices relative to the end of the list. +.VE 8.5 .PP If additional \fIindex\fR arguments are supplied, then each argument is used in turn to address an element within a sublist designated by the previous indexing operation, allowing the script to alter elements in sublists. The command, @@ -105,9 +107,13 @@ lset x 1 1 0 j => {{a b} {c d}} {{e f} {j h}} lset x {1 1 0} j => {{a b} {c d}} {{e f} {j h}} .CE .SH "SEE ALSO" list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), -lsort(n), lrange(n), lreplace(n) +lsort(n), lrange(n), lreplace(n), +.VS 8.5 +string(n) +.VE + .SH KEYWORDS element, index, list, replace, set Index: doc/lsort.n ================================================================== --- doc/lsort.n +++ doc/lsort.n @@ -5,14 +5,14 @@ '\" Copyright (c) 2001 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: lsort.n,v 1.18 2004/10/27 12:53:22 dkf Exp $ +'\" RCS: @(#) $Id: lsort.n,v 1.18.2.2 2005/07/12 20:36:16 kennykb Exp $ '\" .so man.macros -.TH lsort n 8.3 Tcl "Tcl Built-In Commands" +.TH lsort n 8.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lsort \- Sort the elements of a list .SH SYNOPSIS @@ -76,14 +76,11 @@ itself be a proper Tcl sublist. Instead of sorting based on whole sublists, \fBlsort\fR will extract the \fIindexList\fR'th element from each sublist .VS 8.5 (as if the overall element and the \fIindexList\fR were passed to -\fBlindex\fR) and sort based on the given element. The keyword -\fBend\fP is allowed for each element of the \fIindexList\fR to sort -on the last sublist element, and \fBend-\fIindex\fR sorts on a sublist -element offset from the end. +\fBlindex\fR) and sort based on the given element. .VE 8.5 For example, .RS .CS lsort -integer -index 1 {{First 24} {Second 18} {Third 30}} @@ -105,10 +102,17 @@ (because \fBe\fR sorts before \fBi\fR which sorts before \fBo\fR.) .VE 8.5 This option is much more efficient than using \fB\-command\fR to achieve the same effect. .RE +.VS 8.5 +.TP 20 +\fB\-nocase\fR +Causes comparisons to be handled in a case-insensitive manner. Has no +effect if combined with the \fB\-dictionary\fR, \fB\-integer\fR, or +\fB\-real\fR options. +.VE 8.5 .TP 20 \fB\-unique\fR If this option is specified, then only the last set of duplicate elements found in the list will be retained. Note that duplicates are determined relative to the comparison used in the sort. Thus if ADDED doc/mathfunc.n Index: doc/mathfunc.n ================================================================== --- /dev/null +++ doc/mathfunc.n @@ -0,0 +1,241 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-2000 Sun Microsystems, Inc. +'\" 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: mathfunc.n,v 1.1.2.4 2005/10/08 13:44:37 dgp Exp $ +'\" +.so man.macros +.TH mathfunc n 8.5 Tcl "Tcl Mathematical Functions" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +mathfunc \- Mathematical functions for Tcl expressions +.SH SYNOPSIS +package require \fBTcl 8.5\fR +.sp +\fB::tcl::mathfunc::abs\fR \fIarg\fR +.br +\fB::tcl::mathfunc::acos\fR \fIarg\fR +.br +\fB::tcl::mathfunc::asin\fR \fIarg\fR +.br +\fB::tcl::mathfunc::atan\fR \fIarg\fR +.br +\fB::tcl::mathfunc::atan2\fR \fIy\fR \fIx\fR +.br +\fB::tcl::mathfunc::bool\fR \fIarg\fR +.br +\fB::tcl::mathfunc::ceil\fR \fIarg\fR +.br +\fB::tcl::mathfunc::cos\fR \fIarg\fR +.br +\fB::tcl::mathfunc::cosh\fR \fIarg\fR +.br +\fB::tcl::mathfunc::double\fR \fIarg\fR +.br +\fB::tcl::mathfunc::exp\fR \fIarg\fR +.br +\fB::tcl::mathfunc::floor\fR \fIarg\fR +.br +\fB::tcl::mathfunc::fmod\fR \fIx\fR \fIy\fR +.br +\fB::tcl::mathfunc::hypot\fR \fIx\fR \fIy\fR +.br +\fB::tcl::mathfunc::int\fR \fIarg\fR +.br +\fB::tcl::mathfunc::log\fR \fIarg\fR +.br +\fB::tcl::mathfunc::log10\fR \fIarg\fR +.br +\fB::tcl::mathfunc::max\fR \fIarg\fR ?\fIarg\fR ...? +.br +\fB::tcl::mathfunc::min\fR \fIarg\fR ?\fIarg\fR ...? +.br +\fB::tcl::mathfunc::pow\fR \fIx\fR \fIy\fR +.br +\fB::tcl::mathfunc::rand\fR +.br +\fB::tcl::mathfunc::round\fR \fIarg\fR +.br +\fB::tcl::mathfunc::sin\fR \fIarg\fR +.br +\fB::tcl::mathfunc::sinh\fR \fIarg\fR +.br +\fB::tcl::mathfunc::sqrt\fR \fIarg\fR +.br +\fB::tcl::mathfunc::srand\fR \fIarg\fR +.br +\fB::tcl::mathfunc::tan\fR \fIarg\fR +.br +\fB::tcl::mathfunc::tanh\fR \fIarg\fR +.br +\fB::tcl::mathfunc::wide\fR \fIarg\fR +.sp +.BE +.SH "DESCRIPTION" +.PP +The \fBexpr\fR command handles mathematical functions of the form +\fBsin($x)\fR or \fBatan2($y,$x)\fR by converting them to calls of the +form \fB[tcl::math::sin [expr {$x}]]\fR or +\fB[tcl::math::atan2 [expr {$y}] [expr {$x}]]\fR. +A number of math functions are available by default within the +namespace \fB::tcl::mathfunc\fR; these functions are also available +for code apart from \fBexpr\fR, by invoking the given commands +directly. +.PP +Tcl supports the following mathematical functions in expressions, all +of which work solely with floating-point numbers unless otherwise noted: +.DS +.ta 3c 6c 9c +\fBabs\fR \fBacos\fR \fBasin\fR \fBatan\fR +\fBatan2\fR \fBbool\fR \fBceil\fR \fBcos\fR +\fBcosh\fR \fBdouble\fR \fBexp\fR \fBfloor\fR +\fBfmod\fR \fBhypot\fR \fBint\fR \fBlog\fR +\fBlog10\fR \fBmax\fR \fBmin\fR \fBpow\fR +\fBrand\fR \fBround\fR \fBsin\fR \fBsinh\fR +\fBsqrt\fR \fBsrand\fR \fBtan\fR \fBtanh\fR +\fBwide\fR +.DE +.PP +.TP +\fBabs(\fIarg\fB)\fR +Returns the absolute value of \fIarg\fR. \fIArg\fR may be either +integer or floating-point, and the result is returned in the same form. +.TP +\fBacos(\fIarg\fB)\fR +Returns the arc cosine of \fIarg\fR, in the range [\fI0\fR,\fIpi\fR] +radians. \fIArg\fR should be in the range [\fI-1\fR,\fI1\fR]. +.TP +\fBasin(\fIarg\fB)\fR +Returns the arc sine of \fIarg\fR, in the range [\fI-pi/2\fR,\fIpi/2\fR] +radians. \fIArg\fR should be in the range [\fI-1\fR,\fI1\fR]. +.TP +\fBatan(\fIarg\fB)\fR +Returns the arc tangent of \fIarg\fR, in the range [\fI-pi/2\fR,\fIpi/2\fR] +radians. +.TP +\fBatan2(\fIy, x\fB)\fR +Returns the arc tangent of \fIy\fR/\fIx\fR, in the range [\fI-pi\fR,\fIpi\fR] +radians. \fIx\fR and \fIy\fR cannot both be 0. If \fIx\fR is greater +than \fI0\fR, this is equivalent to \fBatan(\fIy/x\fB)\fR. +.TP +\fBbool(\fIarg\fB)\fR +Accepts any numerical value, or any string acceptable to +\fBstring is boolean\fR, and returns the corresponding +boolean value \fB0\fR or \fB1\fR. Non-zero numbers are true. +Other numbers are false. Non-numeric strings produce boolean value in +agreement with \fBstring is true\fR and \fBstring is false\fR. +.TP +\fBceil(\fIarg\fB)\fR +Returns the smallest integral floating-point value (i.e. with a zero +fractional part) not less than \fIarg\fR. +.TP +\fBcos(\fIarg\fB)\fR +Returns the cosine of \fIarg\fR, measured in radians. +.TP +\fBcosh(\fIarg\fB)\fR +Returns the hyperbolic cosine of \fIarg\fR. If the result would cause +an overflow, an error is returned. +.TP +\fBdouble(\fIarg\fB)\fR +If \fIarg\fR is a floating-point value, returns \fIarg\fR, otherwise converts +\fIarg\fR to floating-point and returns the converted value. +.TP +\fBexp(\fIarg\fB)\fR +Returns the exponential of \fIarg\fR, defined as \fIe\fR**\fIarg\fR. +If the result would cause an overflow, an error is returned. +.TP +\fBfloor(\fIarg\fB)\fR +Returns the largest integral floating-point value (i.e. with a zero +fractional part) not greater than \fIarg\fR. +.TP +\fBfmod(\fIx, y\fB)\fR +Returns the floating-point remainder of the division of \fIx\fR by +\fIy\fR. If \fIy\fR is 0, an error is returned. +.TP +\fBhypot(\fIx, y\fB)\fR +Computes the length of the hypotenuse of a right-angled triangle +\fBsqrt(\fIx\fR*\fIx\fR+\fIy\fR*\fIy\fB)\fR. +.TP +\fBint(\fIarg\fB)\fR +If \fIarg\fR is an integer value of the same width as the machine +word, returns \fIarg\fR, otherwise +converts \fIarg\fR to an integer (of the same size as a machine word, +i.e. 32-bits on 32-bit systems, and 64-bits on 64-bit systems) by +truncation and returns the converted value. +.TP +\fBlog(\fIarg\fB)\fR +Returns the natural logarithm of \fIarg\fR. \fIArg\fR must be a +positive value. +.TP +\fBlog10(\fIarg\fB)\fR +Returns the base 10 logarithm of \fIarg\fR. \fIArg\fR must be a +positive value. +.TP +\fBmax(\fIarg\fB, \fI...\fB)\fR +Returns the maximum value of all given numeric arguments. +.TP +\fBmin(\fIarg\fB, \fI...\fB)\fR +Returns the minimum value of all given numeric arguments. +.TP +\fBpow(\fIx, y\fB)\fR +Computes the value of \fIx\fR raised to the power \fIy\fR. If \fIx\fR +is negative, \fIy\fR must be an integer value. +.TP +\fBrand()\fR +Returns a pseudo-random floating-point value in the range (\fI0\fR,\fI1\fR). +The generator algorithm is a simple linear congruential generator that +is not cryptographically secure. Each result from \fBrand\fR completely +determines all future results from subsequent calls to \fBrand\fR, so +\fBrand\fR should not be used to generate a sequence of secrets, such as +one-time passwords. The seed of the generator is initialized from the +internal clock of the machine or may be set with the \fBsrand\fR function. +.TP +\fBround(\fIarg\fB)\fR +If \fIarg\fR is an integer value, returns \fIarg\fR, otherwise converts +\fIarg\fR to integer by rounding and returns the converted value. +.TP +\fBsin(\fIarg\fB)\fR +Returns the sine of \fIarg\fR, measured in radians. +.TP +\fBsinh(\fIarg\fB)\fR +Returns the hyperbolic sine of \fIarg\fR. If the result would cause +an overflow, an error is returned. +.TP +\fBsqrt(\fIarg\fB)\fR +Returns the square root of \fIarg\fR. \fIArg\fR must be non-negative. +.TP +\fBsrand(\fIarg\fB)\fR +The \fIarg\fR, which must be an integer, is used to reset the seed for +the random number generator of \fBrand\fR. Returns the first random +number (see \fBrand()\fR) from that seed. Each interpreter has its own seed. +.TP +\fBtan(\fIarg\fB)\fR +Returns the tangent of \fIarg\fR, measured in radians. +.TP +\fBtanh(\fIarg\fB)\fR +Returns the hyperbolic tangent of \fIarg\fR. +.TP +\fBwide(\fIarg\fB)\fR +Converts \fIarg\fR to an integer value at least 64-bits wide (by sign-extension +if \fIarg\fR is a 32-bit number) if it is not one already. +.PP +In addition to these predefined functions, applications may +define additional functions by using \fBproc\fR (or any other method, +such as \fBinterp alias\fR or \fBTcl_CreateObjCommand\fR) to define +new commands in the \fBtcl::mathfunc\fR namespace. In addition, an +obsolete interface named \fBTcl_CreateMathFunc\fR() is available to +extensions that are written in C. The latter interface is not recommended +for new implementations.. +.SH "SEE ALSO" +expr(n), namespace(n) +.SH "COPYRIGHT" +Copyright (c) 1993 The Regents of the University of California. +.br +Copyright (c) 1994-2000 Sun Microsystems Incorporated. +.br +Copyright (c) 2005 by Kevin B. Kenny . All rights reserved. Index: doc/msgcat.n ================================================================== --- doc/msgcat.n +++ doc/msgcat.n @@ -93,11 +93,11 @@ locale set in msgcat by \fB::msgcat::mclocale\fR, and cannot be set independently. For example, if the current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR .VS 1.4 returns \fB{en_US_funky en_US en {}}\fR. -.VE +.VE 1.4 .TP \fB::msgcat::mcload \fIdirname\fR Searches the specified directory for files that match the language specifications returned by \fB::msgcat::mcpreferences\fR (note that these are all lowercase), extended by the file @@ -168,11 +168,11 @@ When a locale is specified by the user, a ``best match'' search is performed during string translation. For example, if a user specifies .VS 1.4 en_GB_Funky, the locales ``en_GB_Funky'', ``en_GB'', ``en'' and ``'' (the empty string) -.VE +.VE 1.4 are searched in order until a matching translation string is found. If no translation string is available, then \fB::msgcat::unknown\fR is called. .SH "NAMESPACES AND MESSAGE CATALOGS" .PP @@ -238,16 +238,16 @@ followed by ``.msg''. For example: .CS es.msg -- spanish en_gb.msg -- United Kingdom English .CE -.VS +.VS 1.4 \fIException:\fR The message file for the root locale ``'' is called \fBROOT.msg\fR. This exception is made so as not to cause peculiar behavior, such as marking the message file as ``hidden'' on Unix file systems. -.VE +.VE 1.4 .IP [3] The file contains a series of calls to \fBmcset\fR and \fBmcmset\fR, setting the necessary translation strings for the language, likely enclosed in a \fBnamespace eval\fR so that all source strings are tied to the namespace of Index: doc/namespace.n ================================================================== --- doc/namespace.n +++ doc/namespace.n @@ -1,14 +1,15 @@ '\" '\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. +'\" Copyright (c) 2004-2005 Donal K. Fellows. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: namespace.n,v 1.16 2004/10/27 14:24:37 dkf Exp $ +'\" RCS: @(#) $Id: namespace.n,v 1.16.2.2 2005/07/12 20:36:16 kennykb Exp $ '\" .so man.macros .TH namespace n 8.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -213,10 +214,21 @@ \fBnamespace parent\fR ?\fInamespace\fR? Returns the fully-qualified name of the parent namespace for namespace \fInamespace\fR. If \fInamespace\fR is not specified, the fully-qualified name of the current namespace's parent is returned. +.TP +\fBnamespace path\fR ?\fInamespaceList\fR? +'\" Should really have the .TP inside the .VS, but that triggers a groff bug +.VS 8.5 +Returns the command resolution path of the current namespace. If +\fInamespaceList\fR is specified as a list of named namespaces, the +current namespace's command resolution path is set to those namespaces +and returns the empty list. The default command resolution path is +always empty. See the section \fBNAME RESOLUTION\fR below for an +explanation of the rules regarding name resolution. +.VE 8.5 .TP \fBnamespace qualifiers\fR \fIstring\fR Returns any leading namespace qualifiers for \fIstring\fR. Qualifiers are namespace names separated by double colons (\fB::\fR). For the \fIstring\fR \fB::foo::bar::x\fR, @@ -385,14 +397,22 @@ If you provide a fully-qualified name that starts with a \fB::\fR, there is no question about what command, variable, or namespace you mean. However, if the name does not start with a \fB::\fR (i.e., is \fIrelative\fR), -Tcl follows a fixed rule for looking it up: -Command and variable names are always resolved +Tcl follows basic rules for looking it up: +Variable names are always resolved by looking first in the current namespace, and then in the global namespace. +.VS 8.5 +Command names are also always resolved by looking in the current +namespace first. If not found there, they are searched for in every +namespace on the current namespace's command path (which is empty by +default). If not found there, command names are looked up in the +global namespace (or, failing that, are processed by the \fBunknown\fR +command.) +.VE 8.5 Namespace names, on the other hand, are always resolved by looking in only the current namespace. .PP In the following example, .CS @@ -762,14 +782,20 @@ .CE .PP Call the command defined in the previous example in various ways. .CS # Direct call -foo::grill +::foo::grill + +# Use the command resolution path to find the name +\fBnamespace eval\fR boo { + \fBnamespace path\fR ::foo + grill +} # Import into current namespace, then call local alias -namespace import foo::grill +\fBnamespace import\fR foo::grill grill # Create two ensembles, one with the default name and one with a # specified name. Then call through the ensembles. \fBnamespace eval\fR foo { @@ -780,13 +806,13 @@ foobar grill .CE .PP Look up where the command imported in the previous example came from: .CS -puts "grill came from [\fBnamespace which\fR grill]" +puts "grill came from [\fBnamespace origin\fR grill]" .CE .SH "SEE ALSO" interp(n), variable(n) .SH KEYWORDS command, ensemble, exported, internal, variable Index: doc/open.n ================================================================== --- doc/open.n +++ doc/open.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: open.n,v 1.22 2004/11/09 04:51:31 davygrvy Exp $ +'\" RCS: @(#) $Id: open.n,v 1.22.2.2 2005/05/05 17:55:27 kennykb Exp $ '\" .so man.macros .TH open n 8.3 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -59,10 +59,18 @@ .TP 15 \fBa+\fR Open the file for reading and writing. If the file doesn't exist, create a new empty file. Set the initial access position to the end of the file. +.VS 8.5 +.PP +All of the legal \fIaccess\fR values above may have the character +\fBb\fR added as the second or third character in the value to +indicate that the opened channel should be configured with the +\fB-translation binary\fR option, making the channel suitable for +reading or writing of binary data. +.VE 8.5 .PP In the second form, \fIaccess\fR consists of a list of any of the following flags, all of which have the standard POSIX meanings. One of the flags must be either \fBRDONLY\fR, \fBWRONLY\fR or \fBRDWR\fR. .TP 15 @@ -75,10 +83,15 @@ \fBRDWR\fR Open the file for both reading and writing. .TP 15 \fBAPPEND\fR Set the file pointer to the end of the file prior to each write. +.TP 15 +.VS 8.5 +\fBBINARY\fR +Configure the opened channed with the \fB-translation binary\fR option. +.VE 8.5 .TP 15 \fBCREAT\fR Create the file if it doesn't already exist (without this flag it is an error for the file not to exist). .TP 15 @@ -104,18 +117,10 @@ .PP If a new file is created as part of opening it, \fIpermissions\fR (an integer) is used to set the permissions for the new file in conjunction with the process's file mode creation mask. \fIPermissions\fR defaults to 0666. -.PP -Note that if you are going to be reading or writing binary data from -the channel created by this command, you should use the -\fBfconfigure\fR command to change the \fB-translation\fR option of -the channel to \fBbinary\fR before transferring any binary data. This -is in contrast to the ``b'' character passed as part of the equivalent -of the \fIaccess\fR parameter to some versions of the C library -\fIfopen()\fR function. .SH "COMMAND PIPELINES" .PP If the first character of \fIfileName\fR is ``|'' then the remaining characters of \fIfileName\fR are treated as a list of arguments @@ -140,11 +145,10 @@ returned (a silent \fBclose\fR with -blocking 0). .PP It is often useful to use the \fBfileevent\fR command with pipelines so other processing may happen at the same time as running the command in the background. -.VS 8.4 .SH "SERIAL COMMUNICATIONS" .PP If \fIfileName\fR refers to a serial port, then the specified serial port is opened and initialized in a platform-dependent manner. Acceptable values for the \fIfileName\fR to use to open a serial port are described in @@ -320,11 +324,10 @@ Wrong mode settings with \fBfconfigure -mode\fR or a noisy data line (RXD) may cause this error. .TP 10 \fBBREAK\fR A BREAK condition has been detected by your UART (see above). -.VE .SH "PORTABILITY ISSUES" .TP \fBWindows \fR(all versions) Valid values for \fIfileName\fR to open a serial port are of the form @@ -382,14 +385,12 @@ .TP \fBUnix\fR\0\0\0\0\0\0\0 Valid values for \fIfileName\fR to open a serial port are generally of the form \fB/dev/tty\fIX\fR, where \fIX\fR is \fBa\fR or \fBb\fR, but the name of any pseudo-file that maps to a serial port may be used. -.VS 8.4 Advanced configuration options are only supported for serial ports when Tcl is built to use the POSIX serial interface. -.VE 8.4 .sp When running Tcl interactively, there may be some strange interactions between the console, if one is present, and a command pipeline that uses standard input. If a command pipeline is opened for reading, some of the lines entered at the console will be sent to the command pipeline and Index: doc/pkgMkIndex.n ================================================================== --- doc/pkgMkIndex.n +++ doc/pkgMkIndex.n @@ -2,23 +2,21 @@ '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: pkgMkIndex.n,v 1.14 2003/02/25 23:58:09 dgp Exp $ +'\" RCS: @(#) $Id: pkgMkIndex.n,v 1.14.6.2 2005/04/10 23:14:43 kennykb Exp $ '\" .so man.macros .TH pkg_mkIndex n 8.3 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME pkg_mkIndex \- Build an index for automatic loading of packages .SH SYNOPSIS .nf -.VS 8.3.0 \fBpkg_mkIndex ?\fI\-direct\fR? ?\fI\-lazy\fR? ?\fI\-load pkgPat\fR? ?\fI\-verbose\fR? \fIdir\fR ?\fIpattern pattern ...\fR? -.VE .fi .BE .SH DESCRIPTION .PP @@ -39,13 +37,11 @@ .IP [2] Create the index by invoking \fBpkg_mkIndex\fR. The \fIdir\fR argument gives the name of a directory and each \fIpattern\fR argument is a \fBglob\fR-style pattern that selects script or binary files in \fIdir\fR. -.VS 8.0.3 The default pattern is \fB*.tcl\fR and \fB*.[info sharedlibextension]\fR. -.VE .br \fBPkg_mkIndex\fR will create a file \fBpkgIndex.tcl\fR in \fIdir\fR with package information about all the files given by the \fIpattern\fR arguments. It does this by loading each file into a slave @@ -107,11 +103,12 @@ upon \fBpackage require\fR. This is the default. .TP 15 \fB\-lazy\fR The generated index will manage to delay loading the package until the use of one of the commands provided by the package, instead of loading -it immediately upon \fBpackage require\fR. +it immediately upon \fBpackage require\fR. This is not compatible with +the use of \fIauto_reset\fR, and therefore its use is discouraged. .TP 15 \fB\-load \fIpkgPat\fR The index process will pre-load any packages that exist in the current interpreter and match \fIpkgPat\fP into the slave interpreter used to generate the index. The pattern match uses string match rules, but without @@ -157,31 +154,27 @@ The \fBpkgIndex.tcl\fR files contain \fBpackage ifneeded\fR commands for each version of each available package; these commands invoke \fBpackage provide\fR commands to announce the availability of the package, and they setup auto-loader information to load the files of the package. -.VS 8.3 If the \fI\-lazy\fR flag was provided when the \fBpkgIndex.tcl\fR was generated, -.VE a given file of a given version of a given package isn't actually loaded until the first time one of its commands is invoked. Thus, after invoking \fBpackage require\fR you may not see the package's commands in the interpreter, but you will be able to invoke the commands and they will be auto-loaded. -.VS 8.3 .SH "DIRECT LOADING" .PP Some packages, for instance packages which use namespaces and export commands or those which require special initialization, might select that their package files be loaded immediately upon \fBpackage require\fR instead of delaying the actual loading to the first use of one of the package's command. This is the default mode when generating the package index. It can be overridden by specifying the \fI\-lazy\fR argument. -.VE .SH "COMPLEX CASES" Most complex cases of dependencies among scripts and binary files, and packages being split among scripts and binary files are handled OK. However, you may have to adjust Index: doc/puts.n ================================================================== --- doc/puts.n +++ doc/puts.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: puts.n,v 1.8 2004/10/27 14:24:37 dkf Exp $ +'\" RCS: @(#) $Id: puts.n,v 1.8.2.1 2005/04/10 23:14:43 kennykb Exp $ '\" .so man.macros .TH puts n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -20,17 +20,15 @@ .SH DESCRIPTION .PP Writes the characters given by \fIstring\fR to the channel given by \fIchannelId\fR. .PP -.VS \fIChannelId\fR must be an identifier for an open channel such as a Tcl standard channel (\fBstdout\fR or \fBstderr\fR), the return value from an invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel creation command provided by a Tcl extension. The channel must have been opened for output. -.VE .PP If no \fIchannelId\fR is specified then it defaults to \fBstdout\fR. \fBPuts\fR normally outputs a newline character after \fIstring\fR, but this feature may be suppressed by specifying the \fB\-nonewline\fR switch. Index: doc/re_syntax.n ================================================================== --- doc/re_syntax.n +++ doc/re_syntax.n @@ -1,14 +1,13 @@ -'\" -*- nroff -*- '\" '\" Copyright (c) 1998 Sun Microsystems, Inc. '\" Copyright (c) 1999 Scriptics Corporation '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: re_syntax.n,v 1.5 2004/10/31 16:01:54 dkf Exp $ +'\" RCS: @(#) $Id: re_syntax.n,v 1.5.2.2 2005/04/10 23:14:43 kennykb Exp $ '\" .so man.macros .TH re_syntax n "8.1" Tcl "Tcl Built-In Commands" .BS .SH NAME @@ -47,11 +46,11 @@ It matches a match for the first, followed by a match for the second, etc; an empty branch matches the empty string. .PP A quantified atom is an \fIatom\fR possibly followed by a single \fIquantifier\fR. -Without a quantifier, it matches a match for the atom. +Without a quantifier, it matches a single match for the atom. The quantifiers, and what a so-quantified atom matches, are: .RS 2 .TP 6 \fB*\fR @@ -84,47 +83,37 @@ numbers \fIm\fR and \fIn\fR are unsigned decimal integers with permissible values from 0 to 255 inclusive. .PP An atom is one of: .RS 2 -.TP 6 -\fB(\fIre\fB)\fR -(where \fIre\fR is any regular expression) matches a match for -\fIre\fR, with the match noted for possible reporting -.TP -\fB(?:\fIre\fB)\fR +.IP \fB(\fIre\fB)\fR 6 +matches a match for \fIre\fR (\fIre\fR is any regular expression) with +the match noted for possible reporting +.IP \fB(?:\fIre\fB)\fR as previous, but does no reporting (a ``non-capturing'' set of parentheses) -.TP -\fB()\fR +.IP \fB()\fR matches an empty string, noted for possible reporting -.TP -\fB(?:)\fR +.IP \fB(?:)\fR matches an empty string, without reporting -.TP -\fB[\fIchars\fB]\fR +.IP \fB[\fIchars\fB]\fR a \fIbracket expression\fR, matching any one of the \fIchars\fR (see \fBBRACKET EXPRESSIONS\fR for more detail) -.TP -\fB.\fR +.IP \fB.\fR matches any single character -.TP -\fB\e\fIk\fR -(where \fIk\fR is a non-alphanumeric character) matches that character -taken as an ordinary character, e.g. \e\e matches a backslash +.IP \fB\e\fIk\fR +matches the non-alphanumeric character \fIk\fR +taken as an ordinary character, e.g. \fB\e\e\fR matches a backslash character -.TP -\fB\e\fIc\fR +.IP \fB\e\fIc\fR where \fIc\fR is alphanumeric (possibly followed by other characters), an \fIescape\fR (AREs only), see \fBESCAPES\fR below -.TP -\fB{\fR +.IP \fB{\fR when followed by a character other than a digit, matches the left-brace character `\fB{\fR'; when followed by a digit, it is the beginning of a \fIbound\fR (see above) -.TP -\fIx\fR +.IP \fIx\fR where \fIx\fR is a single character with no other significance, matches that character. .RE .PP A \fIconstraint\fR matches an empty string when specific conditions @@ -652,5 +641,9 @@ .SH "SEE ALSO" RegExp(3), regexp(n), regsub(n), lsearch(n), switch(n), text(n) .SH KEYWORDS match, regular expression, string + +'\" Local Variables: +'\" mode: nroff +'\" End: Index: doc/read.n ================================================================== --- doc/read.n +++ doc/read.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: read.n,v 1.9 2004/10/27 14:24:37 dkf Exp $ +'\" RCS: @(#) $Id: read.n,v 1.9.2.1 2005/04/10 23:14:44 kennykb Exp $ '\" .so man.macros .TH read n 8.1 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -30,17 +30,15 @@ the file; in this case all the remaining characters are returned. If the channel is configured to use a multi-byte encoding, then the number of characters read may not be the same as the number of bytes read. .PP -.VS \fIChannelId\fR must be an identifier for an open channel such as the Tcl standard input channel (\fBstdin\fR), the return value from an invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel creation command provided by a Tcl extension. The channel must have been opened for input. -.VE .PP If \fIchannelId\fR is in nonblocking mode, the command may not read as many characters as requested: once all available input has been read, the command will return the data that is available rather than blocking for more input. If the channel is configured to use a Index: doc/regexp.n ================================================================== --- doc/regexp.n +++ doc/regexp.n @@ -2,11 +2,11 @@ '\" Copyright (c) 1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: regexp.n,v 1.16 2004/10/27 14:24:37 dkf Exp $ +'\" RCS: @(#) $Id: regexp.n,v 1.16.2.2 2005/05/05 17:55:27 kennykb Exp $ '\" .so man.macros .TH regexp n 8.3 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -81,11 +81,10 @@ manual page). .TP 15 \fB\-nocase\fR Causes upper-case characters in \fIstring\fR to be treated as lower case during the matching process. -.VS 8.3 .TP 15 \fB\-all\fR Causes the regular expression to be matched as many times as possible in the string, returning the total number of matches found. If this is specified with match variables, they will contain information for @@ -106,17 +105,21 @@ => {in n li i ne e} .CE .TP 15 \fB\-start\fR \fIindex\fR Specifies a character index offset into the string to start -matching the regular expression at. When using this switch, `^' +matching the regular expression at. +.VS 8.5 +The \fIindex\fR value is interpreted in the same manner +as the \fIindex\fR argument to \fBstring index\fR. +.VE 8.5 +When using this switch, `^' will not match the beginning of the line, and \\A will still match the start of the string at \fIindex\fR. If \fB\-indices\fR is specified, the indices will be indexed starting from the absolute beginning of the input string. \fIindex\fR will be constrained to the bounds of the input string. -.VE 8.3 .TP 15 \fB\-\|\-\fR Marks the end of switches. The argument following this one will be treated as \fIexp\fR even if it starts with a \fB\-\fR. .PP @@ -153,9 +156,13 @@ .CS \fBregexp\fR \-all \-inline {\\S+} $string .CE .SH "SEE ALSO" -re_syntax(n), regsub(n) +re_syntax(n), regsub(n), +.VS 8.5 +string(n) +.VE + .SH KEYWORDS match, regular expression, string Index: doc/registry.n ================================================================== --- doc/registry.n +++ doc/registry.n @@ -3,11 +3,11 @@ '\" Copyright (c) 2002 ActiveState Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: registry.n,v 1.12 2004/10/27 14:24:37 dkf Exp $ +'\" RCS: @(#) $Id: registry.n,v 1.12.2.1 2005/04/10 23:14:44 kennykb Exp $ '\" .so man.macros .TH registry n 1.1 registry "Tcl Bundled Packages" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -38,21 +38,18 @@ \fIrootname\fR .PP \fIHostname\fR specifies the name of any valid Windows host that exports its registry. The \fIrootname\fR component must be one of \fBHKEY_LOCAL_MACHINE\fR, \fBHKEY_USERS\fR, -.VS \fBHKEY_CLASSES_ROOT\fR, \fBHKEY_CURRENT_USER\fR, \fBHKEY_CURRENT_CONFIG\fR, \fBHKEY_PERFORMANCE_DATA\fR, or \fBHKEY_DYN_DATA\fR. The \fIkeypath\fR can be one or more -.VE registry key names separated by backslash (\fB\e\fR) characters. .PP \fIOption\fR indicates what to do with the registry key name. Any unique abbreviation for \fIoption\fR is acceptable. The valid options are: -.VS 8.4 .TP \fBregistry broadcast \fIkeyName\fR ?\fI-timeout milliseconds\fR? . Sends a broadcast message to the system and running programs to notify them of certain updates. This is necessary to propagate changes to key registry @@ -65,11 +62,10 @@ set regPath {HKEY_LOCAL_MACHINE\\SYSTEM\\CurrentControlSet\\Control\\Session Manager\\Environment} set curPath [registry get $regPath "Path"] registry set $regPath "Path" "$curPath;$addPath" registry broadcast "Environment" .CE -.VE 8.4 .TP \fBregistry delete \fIkeyName\fR ?\fIvalueName\fR? . If the optional \fIvalueName\fR argument is present, the specified value under \fIkeyName\fR will be deleted from the registry. If the Index: doc/regsub.n ================================================================== --- doc/regsub.n +++ doc/regsub.n @@ -4,39 +4,33 @@ '\" Copyright (c) 2000 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: regsub.n,v 1.12 2004/10/27 14:24:37 dkf Exp $ +'\" RCS: @(#) $Id: regsub.n,v 1.12.2.2 2005/05/05 17:55:28 kennykb Exp $ '\" .so man.macros .TH regsub n 8.3 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME regsub \- Perform substitutions based on regular expression pattern matching .SH SYNOPSIS -.VS 8.4 \fBregsub \fR?\fIswitches\fR? \fIexp string subSpec \fR?\fIvarName\fR? -.VE 8.4 .BE .SH DESCRIPTION .PP This command matches the regular expression \fIexp\fR against \fIstring\fR, -.VS 8.4 and either copies \fIstring\fR to the variable whose name is given by \fIvarName\fR or returns \fIstring\fR if \fIvarName\fR is not present. -.VE 8.4 (Regular expression matching is described in the \fBre_syntax\fR reference page.) If there is a match, then while copying \fIstring\fR to \fIvarName\fR -.VS 8.4 (or to the result of this command if \fIvarName\fR is not present) -.VE 8.4 the portion of \fIstring\fR that matched \fIexp\fR is replaced with \fIsubSpec\fR. If \fIsubSpec\fR contains a ``&'' or ``\e0'', then it is replaced in the substitution with the portion of \fIstring\fR that matched \fIexp\fR. @@ -96,24 +90,27 @@ before matching against \fIexp\fR; however, substitutions specified by \fIsubSpec\fR use the original unconverted form of \fIstring\fR. .TP 10 \fB\-start\fR \fIindex\fR Specifies a character index offset into the string to start -matching the regular expression at. When using this switch, `^' +matching the regular expression at. +.VS 8.5 +The \fIindex\fR value is interpreted in the same manner +as the \fIindex\fR argument to \fBstring index\fR. +.VE 8.5 +When using this switch, `^' will not match the beginning of the line, and \\A will still match the start of the string at \fIindex\fR. \fIindex\fR will be constrained to the bounds of the input string. .TP 10 \fB\-\|\-\fR Marks the end of switches. The argument following this one will be treated as \fIexp\fR even if it starts with a \fB\-\fR. .PP -.VS 8.4 If \fIvarName\fR is supplied, the command returns a count of the number of matching ranges that were found and replaced, otherwise the string after replacement is returned. -.VE 8.4 See the manual entry for \fBregexp\fR for details on the interpretation of regular expressions. .SH EXAMPLES Replace (in the string in variable \fIstring\fR) every instance of \fBfoo\fR which is a word by itself with \fBbar\fR: @@ -140,9 +137,13 @@ # will perform the computational parts of the conversion. set quoted [subst [\fBregsub\fR -all $RE $string $substitution]] .CE .SH "SEE ALSO" -regexp(n), re_syntax(n), subst(n) +regexp(n), re_syntax(n), subst(n), +.VS 8.5 +string(n) +.VE + .SH KEYWORDS match, pattern, regular expression, substitute Index: doc/scan.n ================================================================== --- doc/scan.n +++ doc/scan.n @@ -4,11 +4,11 @@ '\" Copyright (c) 2000 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: scan.n,v 1.12 2004/10/27 14:24:37 dkf Exp $ +'\" RCS: @(#) $Id: scan.n,v 1.12.2.2 2005/10/08 13:44:37 dgp Exp $ '\" .so man.macros .TH scan n 8.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -41,17 +41,15 @@ zero). Otherwise, if it isn't a \fB%\fR character then it must match the next character of \fIstring\fR. When a \fB%\fR is encountered in \fIformat\fR, it indicates the start of a conversion specifier. -.VS 8.4 A conversion specifier contains up to four fields after the \fB%\fR: a \fB*\fR, which indicates that the converted value is to be discarded instead of assigned to a variable; a XPG3 position specifier; a number indicating a maximum field width; a field size modifier; and a conversion character. -.VE 8.4 All of these fields are optional except for the conversion character. The fields that are present must appear in the order given above. .PP When \fBscan\fR finds a conversion specifier in \fIformat\fR, it first skips any white-space characters in \fIstring\fR (unless the @@ -73,60 +71,50 @@ The following conversion characters are supported: .TP 10 \fBd\fR The input field must be a decimal integer. It is read in and the value is stored in the variable as a decimal string. -.VS 8.4 If the \fBl\fR or \fBL\fR field size modifier is given, the scanned value will have an internal representation that is at least 64-bits in size. -.VE 8.4 .TP 10 \fBo\fR The input field must be an octal integer. It is read in and the value is stored in the variable as a decimal string. -.VS 8.4 If the \fBl\fR or \fBL\fR field size modifier is given, the scanned value will have an internal representation that is at least 64-bits in size. If the value exceeds MAX_INT (017777777777 on platforms using 32-bit integers when the \fBl\fR and \fBL\fR modifiers are not given), it will be truncated to a signed integer. Hence, 037777777777 will appear as -1 on a 32-bit machine by default. -.VE 8.4 .TP 10 \fBx\fR The input field must be a hexadecimal integer. It is read in and the value is stored in the variable as a decimal string. -.VS 8.4 If the \fBl\fR or \fBL\fR field size modifier is given, the scanned value will have an internal representation that is at least 64-bits in size. If the value exceeds MAX_INT (0x7FFFFFFF on platforms using 32-bit integers when the \fBl\fR and \fBL\fR modifiers are not given), it will be truncated to a signed integer. Hence, 0xFFFFFFFF will appear as -1 on a 32-bit machine. -.VE 8.4 .TP 10 \fBu\fR The input field must be a decimal integer. The value is stored in the variable as an unsigned decimal integer string. -.VS 8.4 If the \fBl\fR or \fBL\fR field size modifier is given, the scanned value will have an internal representation that is at least 64-bits in size. -.VE 8.4 .TP 10 \fBi\fR The input field must be an integer. The base (i.e. decimal, octal, or hexadecimal) is determined in the same fashion as described in \fBexpr\fR. The value is stored in the variable as a decimal string. -.VS 8.4 If the \fBl\fR or \fBL\fR field size modifier is given, the scanned value will have an internal representation that is at least 64-bits in size. -.VE 8.4 .TP 10 \fBc\fR A single character is read in and its binary value is stored in the variable as a decimal string. Initial white space is not skipped in this case, so the input @@ -146,12 +134,11 @@ of an \fBe\fR or \fBE\fR followed by an optional sign and a string of decimal digits. It is read in and stored in the variable as a floating-point string. .TP 10 \fB[\fIchars\fB]\fR -The input field consists of any number of characters in -\fIchars\fR. +The input field consists of one or more characters in \fIchars\fR. The matching string is stored in the variable. If the first character between the brackets is a \fB]\fR then it is treated as part of \fIchars\fR rather than the closing bracket for the set. If \fIchars\fR @@ -159,12 +146,11 @@ character between \fIa\fR and \fIb\fR (inclusive) will match. If the first or last character between the brackets is a \fB\-\fR, then it is treated as part of \fIchars\fR rather than indicating a range. .TP 10 \fB[^\fIchars\fB]\fR -The input field consists of any number of characters not in -\fIchars\fR. +The input field consists of one or more characters not in \fIchars\fR. The matching string is stored in the variable. If the character immediately following the \fB^\fR is a \fB]\fR then it is treated as part of the set rather than the closing bracket for the set. If \fIchars\fR @@ -197,15 +183,13 @@ For \fB%c\fR conversions a single character value is converted to a decimal string, which is then assigned to the corresponding \fIvarName\fR; no field width may be specified for this conversion. .IP [3] -.VS 8.4 The \fBh\fR modifier is always ignored and the \fBl\fR and \fBL\fR modifiers are ignored when converting real values (i.e. type \fBdouble\fR is used for the internal representation). -.VE 8.4 .IP [4] If the end of the input string is reached before any conversions have been performed and no variables are given, an empty string is returned. .SH EXAMPLES Parse a simple color specification of the form \fI#RRGGBB\fR using Index: doc/seek.n ================================================================== --- doc/seek.n +++ doc/seek.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: seek.n,v 1.7 2004/10/27 14:24:37 dkf Exp $ +'\" RCS: @(#) $Id: seek.n,v 1.7.2.1 2005/04/10 23:14:44 kennykb Exp $ '\" .so man.macros .TH seek n 8.1 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -19,16 +19,14 @@ .SH DESCRIPTION .PP Changes the current access position for \fIchannelId\fR. .PP -.VS \fIChannelId\fR must be an identifier for an open channel such as a Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR), the return value from an invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel creation command provided by a Tcl extension. -.VE .PP The \fIoffset\fR and \fIorigin\fR arguments specify the position at which the next read or write will occur for \fIchannelId\fR. \fIOffset\fR must be an integer (which may be negative) and \fIorigin\fR must be one of the following: @@ -55,15 +53,13 @@ It also discards any buffered and unread input. This command returns an empty string. An error occurs if this command is applied to channels whose underlying file or device does not support seeking. .PP -.VS 8.1 Note that \fIoffset\fR values are byte offsets, not character offsets. Both \fBseek\fR and \fBtell\fR operate in terms of bytes, not characters, unlike \fBread\fR. -.VE 8.1 .SH EXAMPLES Read a file twice: .CS set f [open file.txt] set data1 [read $f] Index: doc/string.n ================================================================== --- doc/string.n +++ doc/string.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: string.n,v 1.24 2004/10/27 14:24:37 dkf Exp $ +'\" RCS: @(#) $Id: string.n,v 1.24.2.4 2005/07/12 20:36:16 kennykb Exp $ '\" .so man.macros .TH string n 8.1 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -70,27 +70,47 @@ .TP \fBstring index \fIstring charIndex\fR Returns the \fIcharIndex\fR'th character of the \fIstring\fR argument. A \fIcharIndex\fR of 0 corresponds to the first character of the string. \fIcharIndex\fR may be specified as follows: +.VS 8.5 .RS .IP \fIinteger\fR 10 -The char specified at this integral index. +For any index value that passes \fBstring is integer -strict\fR, +the char specified at this integral index +(e.g. \fB2\fR would refer to the "c" in "abcd"). .IP \fBend\fR 10 -The last char of the string. -.IP \fBend\-\fIinteger\fR 10 -The last char of the string minus the specified integer offset -(e.g. \fBend\-1\fR would refer to the "c" in "abcd"). +The last char of the string +(e.g. \fBend\fR would refer to the "d" in "abcd"). +.IP \fBend\fR\-\fIN\fR 10 +The last char of the string minus the specified integer offset \fIN\fR +(e.g. \fBend\fR\-1 would refer to the "c" in "abcd"). +.IP \fBend\fR+\fIN\fR 10 +The last char of the string plus the specified integer offset \fIN\fR +(e.g. \fBend\fR+\-1 would refer to the "c" in "abcd"). +.IP \fIM\fR+\fIN\fR 10 +The char specified at the integral index that is the sum of +integer values \fIM\fR and \fIN\fR +(e.g. \fB1+1\fR would refer to the "c" in "abcd"). +.IP \fIM\fR\-\fIN\fR 10 +The char specified at the integral index that is the difference of +integer values \fIM\fR and \fIN\fR +(e.g. \fB2\-1\fR would refer to the "b" in "abcd"). +.PP +In the specifications above, the integer value \fIM\fR contains no +trailing whitespace and the integer value \fIN\fR contains no +leading whitespace. .PP If \fIcharIndex\fR is less than 0 or greater than or equal to the -length of the string then an empty string is returned. +length of the string then this command returns an empty string. .RE +.VE .TP \fBstring is \fIclass\fR ?\fB\-strict\fR? ?\fB\-failindex \fIvarname\fR? \fIstring\fR Returns 1 if \fIstring\fR is a valid member of the specified character class, otherwise returns 0. If \fB\-strict\fR is specified, then an -empty string returns 0, otherwise and empty string will return 1 on +empty string returns 0, otherwise an empty string will return 1 on any class. If \fB\-failindex\fR is specified, then if the function returns 0, the index in the string where the class was no longer valid will be stored in the variable named \fIvarname\fR. The \fIvarname\fR will not be set if the function returns 1. The following character classes are recognized (the class name can be abbreviated): @@ -284,23 +304,23 @@ the string to stop at (inclusive). \fIfirst\fR and \fIlast\fR may be specified as for the \fBindex\fR method. .TP \fBstring trim \fIstring\fR ?\fIchars\fR? Returns a value equal to \fIstring\fR except that any leading or -trailing characters from the set given by \fIchars\fR are removed. If +trailing characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (spaces, tabs, newlines, and carriage returns). .TP \fBstring trimleft \fIstring\fR ?\fIchars\fR? Returns a value equal to \fIstring\fR except that any leading -characters from the set given by \fIchars\fR are removed. If +characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (spaces, tabs, newlines, and carriage returns). .TP \fBstring trimright \fIstring\fR ?\fIchars\fR? Returns a value equal to \fIstring\fR except that any trailing -characters from the set given by \fIchars\fR are removed. If +characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (spaces, tabs, newlines, and carriage returns). .TP \fBstring wordend \fIstring charIndex\fR Returns the index of the character just after the last one in the word @@ -332,5 +352,9 @@ .SH "SEE ALSO" expr(n), list(n) .SH KEYWORDS case conversion, compare, index, match, pattern, string, word, equal, ctype + +'\" Local Variables: +'\" mode: nroff +'\" End: Index: doc/subst.n ================================================================== --- doc/subst.n +++ doc/subst.n @@ -4,11 +4,11 @@ '\" Copyright (c) 2001 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: subst.n,v 1.6 2004/10/27 14:24:37 dkf Exp $ +'\" RCS: @(#) $Id: subst.n,v 1.6.2.1 2005/04/10 23:14:44 kennykb Exp $ '\" .so man.macros .TH subst n 7.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -34,11 +34,10 @@ are not performed. For example, if \fB\-nocommands\fR is specified, command substitution is not performed: open and close brackets are treated as ordinary characters with no special interpretation. .PP -.VS 8.4 Note that the substitution of one kind can include substitution of other kinds. For example, even when the \fB-novariables\fR option is specified, command substitution is performed without restriction. This means that any variable substitution necessary to complete the command substitution will still take place. Likewise, any command @@ -57,11 +56,10 @@ or any other return code is returned during command or variable substitution, then the returned value is substituted for that substitution. See the EXAMPLES below. In this way, all exceptional return codes are ``caught'' by \fBsubst\fR. The \fBsubst\fR command itself will either return an error, or will complete successfully. -.VE .SH EXAMPLES .PP When it performs its substitutions, \fIsubst\fR does not give any special treatment to double quotes or curly braces (except within command substitutions) so the script @@ -68,11 +66,10 @@ .CS set a 44 \fBsubst\fR {xyz {$a}} .CE returns ``\fBxyz {44}\fR'', not ``\fBxyz {$a}\fR'' -.VS 8.4 and the script .CS set a "p\\} q \\{r" \fBsubst\fR {xyz {$a}} .CE @@ -114,12 +111,11 @@ returns ``\fBabc,foo,def\fR'', not ``\fBabc,3,def\fR'' and .CS \fBsubst\fR {abc,[return -code 10 foo;expr 1+2],def} .CE also returns ``\fBabc,foo,def\fR'', not ``\fBabc,3,def\fR''. -.VE .SH "SEE ALSO" Tcl(n), eval(n), break(n), continue(n) .SH KEYWORDS backslash substitution, command substitution, variable substitution Index: doc/switch.n ================================================================== --- doc/switch.n +++ doc/switch.n @@ -3,14 +3,14 @@ '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: switch.n,v 1.8 2004/10/27 14:24:37 dkf Exp $ +'\" RCS: @(#) $Id: switch.n,v 1.8.2.1 2005/07/12 20:36:16 kennykb Exp $ '\" .so man.macros -.TH switch n 7.0 Tcl "Tcl Built-In Commands" +.TH switch n 8.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME switch \- Evaluate one of several scripts, depending on a given value .SH SYNOPSIS @@ -49,10 +49,13 @@ expression matching (as described in the \fBre_syntax\fR reference page). '\" Options defined by TIP#75 .VS 8.5 .TP 10 +\fB\-nocase\fR +Causes comparisons to be handled in a case-insensitive manner. +.TP 10 \fB\-matchvar\fR \fIvarName\fR This option (only legal when \fB\-regexp\fR is also specified) specifies the name of a variable into which the list of matches found by the regular expression engine will be written. The first element of the list written will be the overall substring of the input Index: doc/tclvars.n ================================================================== --- doc/tclvars.n +++ doc/tclvars.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: tclvars.n,v 1.20 2004/11/20 00:17:32 dgp Exp $ +'\" RCS: @(#) $Id: tclvars.n,v 1.20.2.3 2005/10/08 13:44:37 dgp Exp $ '\" .so man.macros .TH tclvars n 8.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -35,21 +35,19 @@ passed to children by commands like \fBexec\fR. If the entire \fBenv\fR array is unset then Tcl will stop monitoring \fBenv\fR accesses and will not update environment variables. .RS -.VS 8.0 Under Windows, the environment variables PATH and COMSPEC in any capitalization are converted automatically to upper case. For instance, the PATH variable could be exported by the operating system as ``path'', ``Path'', ``PaTh'', etc., causing otherwise simple Tcl code to have to support many special cases. All other environment variables inherited by Tcl are left unmodified. Setting an env array variable to blank is the same as unsetting it as this is the behavior of the underlying Windows OS. It should be noted that relying on an existing and empty environment variable won't work on windows and is discouraged for cross-platform usage. -.VE .RE .TP \fBerrorCode\fR This variable holds the value of the \fB-errorcode\fR return option set by the most recent error that occurred in this interpreter. @@ -161,11 +159,10 @@ hold a string giving the current patch level for Tcl, such as \fB7.3p2\fR for Tcl 7.3 with the first two official patches, or \fB7.4b4\fR for the fourth beta release of Tcl 7.4. The value of this variable is returned by the \fBinfo patchlevel\fR command. -.VS 8.0 br .TP \fBtcl_pkgPath\fR This variable holds a list of directories indicating where packages are normally installed. It is not used on Windows. It typically contains either one or two entries; if it contains two entries, the first is @@ -174,16 +171,15 @@ packages (e.g., script files). Typically a package is installed as a subdirectory of one of the entries in \fB$tcl_pkgPath\fR. The directories in \fB$tcl_pkgPath\fR are included by default in the \fBauto_path\fR variable, so they and their immediate subdirectories are automatically searched for packages during \fBpackage require\fR commands. Note: -\fBtcl_pkgPath\fR it not intended to be modified by the application. Its +\fBtcl_pkgPath\fR is not intended to be modified by the application. Its value is added to \fBauto_path\fR at startup; changes to \fBtcl_pkgPath\fR are not reflected in \fBauto_path\fR. If you want Tcl to search additional directories for packages you should add the names of those directories to \fBauto_path\fR, not \fBtcl_pkgPath\fR. -.VE .TP \fBtcl_platform\fR This is an associative array whose elements contain information about the platform on which the application is running, such as the name of the operating system, its current release number, and the machine's @@ -191,16 +187,14 @@ be defined, but they may have empty strings as values if Tcl couldn't retrieve any relevant information. In addition, extensions and applications may add additional values to the array. The predefined elements are: .RS -.VS .TP \fBbyteOrder\fR The native byte order of this machine: either \fBlittleEndian\fR or \fBbigEndian\fR. -.VE .TP \fBdebug\fR If this variable exists, then the interpreter was compiled with and linked to a debug-enabled C run-time. This variable will only exist on Windows, so extension writers can specify which package to load depending on the @@ -239,21 +233,31 @@ current user based on the login information available on the platform. This comes from the USER or LOGNAME environment variable on Unix, and the value from GetUserName on Windows. .TP \fBwordSize\fR -.VS 8.4 This gives the size of the native-machine word in bytes (strictly, it is same as the result of evaluating \fIsizeof(long)\fR in C.) -.VE 8.4 .RE .TP \fBtcl_precision\fR -.VS This variable controls the number of digits to generate when converting floating-point values to strings. It defaults -to 12. +.VS 8.5 +to 0. \fIApplications should not change this value;\fR it is +provided for compatibility with legacy code. +.PP +The default value of 0 is special, meaning that Tcl should +convert numbers using as few digits as possible while still +distinguishing any floating point number from its nearest +neighbours. It differs from using an arbitrarily high value +for \fItcl_precision\fR in that an inexact number like \fI1.4\fR +will convert as \fI1.4\fR rather than \fI1.3999999999999999\fR +even though the latter is nearer to the exact value of the +binary number. +.VE 8.5 +.PP 17 digits is ``perfect'' for IEEE floating-point in that it allows double-precision values to be converted to strings and back to binary with no loss of information. However, using 17 digits prevents any rounding, which produces longer, less intuitive results. For example, \fBexpr 1.4\fR returns 1.3999999999999999 with \fBtcl_precision\fR @@ -262,11 +266,10 @@ All interpreters in a process share a single \fBtcl_precision\fR value: changing it in one interpreter will affect all other interpreters as well. However, safe interpreters are not allowed to modify the variable. .RE -.VE .TP \fBtcl_rcFileName\fR This variable is used during initialization to indicate the name of a user-specific startup file. If it is set by application-specific initialization, then the Tcl startup code will check for the existence Index: doc/tell.n ================================================================== --- doc/tell.n +++ doc/tell.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: tell.n,v 1.7 2004/10/27 14:43:54 dkf Exp $ +'\" RCS: @(#) $Id: tell.n,v 1.7.2.1 2005/04/10 23:14:44 kennykb Exp $ '\" .so man.macros .TH tell n 8.1 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -17,25 +17,21 @@ \fBtell \fIchannelId\fR .BE .SH DESCRIPTION .PP -.VS 8.1 Returns an integer string giving the current access position in \fIchannelId\fR. This value returned is a byte offset that can be passed to \fBseek\fR in order to set the channel to a particular position. Note that this value is in terms of bytes, not characters like \fBread\fR. -.VE 8.1 The value returned is -1 for channels that do not support seeking. .PP -.VS \fIChannelId\fR must be an identifier for an open channel such as a Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR), the return value from an invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel creation command provided by a Tcl extension. -.VE .SH EXAMPLE Read a line from a file channel only if it starts with \fBfoobar\fR: .CS # Save the offset in case we need to undo the read... set offset [\fBtell\fR $chan] Index: doc/unload.n ================================================================== --- doc/unload.n +++ doc/unload.n @@ -2,11 +2,11 @@ '\" Copyright (c) 2003 George Petasis, petasis@iit.demokritos.gr. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: unload.n,v 1.6 2004/09/18 17:01:06 dkf Exp $ +'\" RCS: @(#) $Id: unload.n,v 1.6.2.1 2005/04/10 23:14:44 kennykb Exp $ '\" .so man.macros .TH unload n 8.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -114,13 +114,11 @@ Tcl tries to guess the name of the package. This may be done differently on different platforms. The default guess, which is used on most UNIX platforms, is to take the last element of \fIfileName\fR, strip off the first three characters if they are \fBlib\fR, and use any following -.VS alphabetic and underline characters as the module name. -.VE For example, the command \fBunload libxyz4.2.so\fR uses the module name \fBxyz\fR and the command \fBunload bin/last.so {}\fR uses the module name \fBlast\fR. .SH "PORTABILITY ISSUES" .TP Index: doc/unset.n ================================================================== --- doc/unset.n +++ doc/unset.n @@ -4,11 +4,11 @@ '\" Copyright (c) 2000 Ajuba Solutions. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: unset.n,v 1.8 2004/10/27 14:43:54 dkf Exp $ +'\" RCS: @(#) $Id: unset.n,v 1.8.2.1 2005/04/10 23:14:44 kennykb Exp $ '\" .so man.macros .TH unset n 8.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -26,17 +26,15 @@ If a \fIname\fR refers to an element of an array then that element is removed without affecting the rest of the array. If a \fIname\fR consists of an array name with no parenthesized index, then the entire array is deleted. The \fBunset\fR command returns an empty string as result. -.VS 8.4 If \fI\-nocomplain\fR is specified as the first argument, any possible errors are suppressed. The option may not be abbreviated, in order to disambiguate it from possible variable names. The option \fI\-\-\fR indicates the end of the options, and should be used if you wish to remove a variable with the same name as any of the options. -.VE 8.4 If an error occurs, any variables after the named one causing the error not deleted. An error can occur when the named variable doesn't exist, or the name refers to an array element but the variable is a scalar, or the name refers to a variable in a non-existent namespace. .SH EXAMPLE Index: doc/upvar.n ================================================================== --- doc/upvar.n +++ doc/upvar.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: upvar.n,v 1.10 2004/11/12 11:03:16 dkf Exp $ +'\" RCS: @(#) $Id: upvar.n,v 1.10.2.1 2005/04/10 23:14:44 kennykb Exp $ '\" .so man.macros .TH upvar n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -66,11 +66,10 @@ describing a command that is either the outermost procedure call or the outermost \fBnamespace eval\fR command. Also, \fBuplevel #0\fR evaluates a script at top-level in the outermost namespace (the global namespace). .PP -.VS If an upvar variable is unset (e.g. \fBx\fR in \fBadd2\fR above), the \fBunset\fR operation affects the variable it is linked to, not the upvar variable. There is no way to unset an upvar variable except by exiting the procedure in which it is defined. However, it is possible to retarget an upvar variable by executing another \fBupvar\fR @@ -99,11 +98,10 @@ If \fIotherVar\fR refers to an element of an array, then variable traces set for the entire array will not be invoked when \fImyVar\fR is accessed (but traces on the particular element will still be invoked). In particular, if the array is \fBenv\fR, then changes made to \fImyVar\fR will not be passed to subprocesses correctly. -.VE .SH EXAMPLE A \fBdecr\fR command that works like \fBincr\fR except it subtracts the value from the variable instead of adding it: .CS proc decr {varName {decrement 1}} { Index: doc/variable.n ================================================================== --- doc/variable.n +++ doc/variable.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: variable.n,v 1.6 2004/10/27 14:43:54 dkf Exp $ +'\" RCS: @(#) $Id: variable.n,v 1.6.2.1 2005/03/02 21:25:20 kennykb Exp $ '\" .so man.macros .TH variable n 8.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -41,11 +41,11 @@ command, but not to the \fBinfo exists\fR command. .PP If the \fBvariable\fR command is executed inside a Tcl procedure, it creates local variables linked to the corresponding namespace variables (and therefore these -variables are listed by \fBinfo locals\fR.) +variables are listed by \fBinfo vars\fR.) In this way the \fBvariable\fR command resembles the \fBglobal\fR command, although the \fBglobal\fR command only links to variables in the global namespace. If any \fIvalue\fRs are given, they are used to modify the values of the associated namespace variables. Index: generic/tcl.decls ================================================================== --- generic/tcl.decls +++ generic/tcl.decls @@ -9,11 +9,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2001, 2002 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: tcl.decls,v 1.105 2004/11/13 00:19:05 dgp Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.105.2.9 2005/09/20 14:11:51 dgp Exp $ library tcl # Define the tcl interface with several sub interfaces: # tclPlat - platform specific public @@ -134,21 +134,21 @@ } declare 30 generic { void TclFreeObj(Tcl_Obj *objPtr) } declare 31 generic { - int Tcl_GetBoolean(Tcl_Interp *interp, CONST char *str, int *boolPtr) + int Tcl_GetBoolean(Tcl_Interp *interp, CONST char *src, int *boolPtr) } declare 32 generic { int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *boolPtr) } declare 33 generic { unsigned char * Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *lengthPtr) } declare 34 generic { - int Tcl_GetDouble(Tcl_Interp *interp, CONST char *str, double *doublePtr) + int Tcl_GetDouble(Tcl_Interp *interp, CONST char *src, double *doublePtr) } declare 35 generic { int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr) } @@ -155,11 +155,11 @@ declare 36 generic { int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, CONST84 char **tablePtr, CONST char *msg, int flags, int *indexPtr) } declare 37 generic { - int Tcl_GetInt(Tcl_Interp *interp, CONST char *str, int *intPtr) + int Tcl_GetInt(Tcl_Interp *interp, CONST char *src, int *intPtr) } declare 38 generic { int Tcl_GetIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr) } declare 39 generic { @@ -259,11 +259,11 @@ } declare 68 generic { void Tcl_AllowExceptions(Tcl_Interp *interp) } declare 69 generic { - void Tcl_AppendElement(Tcl_Interp *interp, CONST char *string) + void Tcl_AppendElement(Tcl_Interp *interp, CONST char *element) } declare 70 generic { void Tcl_AppendResult(Tcl_Interp *interp, ...) } declare 71 generic { @@ -429,14 +429,14 @@ } declare 116 generic { void Tcl_DoWhenIdle(Tcl_IdleProc *proc, ClientData clientData) } declare 117 generic { - char * Tcl_DStringAppend(Tcl_DString *dsPtr, CONST char *str, int length) + char * Tcl_DStringAppend(Tcl_DString *dsPtr, CONST char *bytes, int length) } declare 118 generic { - char * Tcl_DStringAppendElement(Tcl_DString *dsPtr, CONST char *string) + char * Tcl_DStringAppendElement(Tcl_DString *dsPtr, CONST char *element) } declare 119 generic { void Tcl_DStringEndSublist(Tcl_DString *dsPtr) } declare 120 generic { @@ -465,11 +465,11 @@ } declare 128 generic { CONST84_RETURN char * Tcl_ErrnoMsg(int err) } declare 129 generic { - int Tcl_Eval(Tcl_Interp *interp, CONST char *string) + int Tcl_Eval(Tcl_Interp *interp, CONST char *script) } # This is obsolete, use Tcl_FSEvalFile declare 130 generic { int Tcl_EvalFile(Tcl_Interp *interp, CONST char *fileName) } @@ -485,33 +485,33 @@ declare 134 generic { int Tcl_ExposeCommand(Tcl_Interp *interp, CONST char *hiddenCmdToken, CONST char *cmdName) } declare 135 generic { - int Tcl_ExprBoolean(Tcl_Interp *interp, CONST char *str, int *ptr) + int Tcl_ExprBoolean(Tcl_Interp *interp, CONST char *expr, int *ptr) } declare 136 generic { int Tcl_ExprBooleanObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *ptr) } declare 137 generic { - int Tcl_ExprDouble(Tcl_Interp *interp, CONST char *str, double *ptr) + int Tcl_ExprDouble(Tcl_Interp *interp, CONST char *expr, double *ptr) } declare 138 generic { int Tcl_ExprDoubleObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *ptr) } declare 139 generic { - int Tcl_ExprLong(Tcl_Interp *interp, CONST char *str, long *ptr) + int Tcl_ExprLong(Tcl_Interp *interp, CONST char *expr, long *ptr) } declare 140 generic { int Tcl_ExprLongObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *ptr) } declare 141 generic { int Tcl_ExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr) } declare 142 generic { - int Tcl_ExprString(Tcl_Interp *interp, CONST char *string) + int Tcl_ExprString(Tcl_Interp *interp, CONST char *expr) } declare 143 generic { void Tcl_Finalize(void) } declare 144 generic { @@ -597,11 +597,11 @@ # Tcl_GetOpenFile is only available on unix, but it is a part of the old # generic interface, so we inlcude it here for compatibility reasons. declare 167 unix { - int Tcl_GetOpenFile(Tcl_Interp *interp, CONST char *str, int forWriting, + int Tcl_GetOpenFile(Tcl_Interp *interp, CONST char *chanID, int forWriting, int checkUsage, ClientData *filePtr) } # Obsolete. Should now use Tcl_FSGetPathType which is objectified # and therefore usually faster. declare 168 generic { @@ -725,11 +725,11 @@ } declare 202 generic { void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst) } declare 203 generic { - int Tcl_PutEnv(CONST char *string) + int Tcl_PutEnv(CONST char *assignment) } declare 204 generic { CONST84_RETURN char * Tcl_PosixError(Tcl_Interp *interp) } declare 205 generic { @@ -752,18 +752,18 @@ } declare 211 generic { void Tcl_RegisterObjType(Tcl_ObjType *typePtr) } declare 212 generic { - Tcl_RegExp Tcl_RegExpCompile(Tcl_Interp *interp, CONST char *string) + Tcl_RegExp Tcl_RegExpCompile(Tcl_Interp *interp, CONST char *pattern) } declare 213 generic { int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp, - CONST char *str, CONST char *start) + CONST char *text, CONST char *start) } declare 214 generic { - int Tcl_RegExpMatch(Tcl_Interp *interp, CONST char *str, + int Tcl_RegExpMatch(Tcl_Interp *interp, CONST char *text, CONST char *pattern) } declare 215 generic { void Tcl_RegExpRange(Tcl_RegExp regexp, int index, CONST84 char **startPtr, CONST84 char **endPtr) @@ -819,11 +819,11 @@ } declare 231 generic { int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth) } declare 232 generic { - void Tcl_SetResult(Tcl_Interp *interp, char *str, + void Tcl_SetResult(Tcl_Interp *interp, char *result, Tcl_FreeProc *freeProc) } declare 233 generic { int Tcl_SetServiceMode(int mode) } @@ -954,11 +954,11 @@ } declare 269 generic { CONST84_RETURN char * Tcl_HashStats(Tcl_HashTable *tablePtr) } declare 270 generic { - CONST84_RETURN char * Tcl_ParseVar(Tcl_Interp *interp, CONST char *str, + CONST84_RETURN char * Tcl_ParseVar(Tcl_Interp *interp, CONST char *start, CONST84 char **termPtr) } declare 271 generic { CONST84_RETURN char * Tcl_PkgPresent(Tcl_Interp *interp, CONST char *name, CONST char *version, int exact) @@ -1118,11 +1118,11 @@ declare 311 generic { void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, Tcl_Time *timePtr) } declare 312 generic { - int Tcl_NumUtfChars(CONST char *src, int len) + int Tcl_NumUtfChars(CONST char *src, int length) } declare 313 generic { int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, int appendFlag) } @@ -1163,11 +1163,11 @@ } declare 325 generic { CONST84_RETURN char * Tcl_UtfAtIndex(CONST char *src, int index) } declare 326 generic { - int Tcl_UtfCharComplete(CONST char *src, int len) + int Tcl_UtfCharComplete(CONST char *src, int length) } declare 327 generic { int Tcl_UtfBackslash(CONST char *src, int *readPtr, char *dst) } declare 328 generic { @@ -1245,22 +1245,22 @@ } declare 351 generic { int Tcl_UniCharIsWordChar(int ch) } declare 352 generic { - int Tcl_UniCharLen(CONST Tcl_UniChar *str) + int Tcl_UniCharLen(CONST Tcl_UniChar *uniStr) } declare 353 generic { - int Tcl_UniCharNcmp(CONST Tcl_UniChar *cs, CONST Tcl_UniChar *ct, - unsigned long n) + int Tcl_UniCharNcmp(CONST Tcl_UniChar *ucs, CONST Tcl_UniChar *uct, + unsigned long numChars) } declare 354 generic { - char * Tcl_UniCharToUtfDString(CONST Tcl_UniChar *string, - int numChars, Tcl_DString *dsPtr) + char * Tcl_UniCharToUtfDString(CONST Tcl_UniChar *uniStr, + int uniLength, Tcl_DString *dsPtr) } declare 355 generic { - Tcl_UniChar * Tcl_UtfToUniCharDString(CONST char *string, + Tcl_UniChar * Tcl_UtfToUniCharDString(CONST char *src, int length, Tcl_DString *dsPtr) } declare 356 generic { Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags) @@ -1276,28 +1276,28 @@ declare 359 generic { void Tcl_LogCommandInfo(Tcl_Interp *interp, CONST char *script, CONST char *command, int length) } declare 360 generic { - int Tcl_ParseBraces(Tcl_Interp *interp, CONST char *string, int numBytes, + int Tcl_ParseBraces(Tcl_Interp *interp, CONST char *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr) } declare 361 generic { - int Tcl_ParseCommand(Tcl_Interp *interp, CONST char *string, int numBytes, + int Tcl_ParseCommand(Tcl_Interp *interp, CONST char *start, int numBytes, int nested, Tcl_Parse *parsePtr) } declare 362 generic { - int Tcl_ParseExpr(Tcl_Interp *interp, CONST char *string, int numBytes, + int Tcl_ParseExpr(Tcl_Interp *interp, CONST char *start, int numBytes, Tcl_Parse *parsePtr) } declare 363 generic { - int Tcl_ParseQuotedString(Tcl_Interp *interp, CONST char *string, + int Tcl_ParseQuotedString(Tcl_Interp *interp, CONST char *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr) } declare 364 generic { - int Tcl_ParseVarName(Tcl_Interp *interp, CONST char *string, int numBytes, + int Tcl_ParseVarName(Tcl_Interp *interp, CONST char *start, int numBytes, Tcl_Parse *parsePtr, int append) } # These 4 functions are obsolete, use Tcl_FSGetCwd, Tcl_FSChdir, # Tcl_FSAccess and Tcl_FSStat declare 365 generic { @@ -1333,11 +1333,11 @@ declare 375 generic { int Tcl_UniCharIsPunct(int ch) } declare 376 generic { int Tcl_RegExpExecObj(Tcl_Interp *interp, Tcl_RegExp regexp, - Tcl_Obj *objPtr, int offset, int nmatches, int flags) + Tcl_Obj *textObj, int offset, int nmatches, int flags) } declare 377 generic { void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr) } declare 378 generic { @@ -1362,11 +1362,11 @@ declare 384 generic { void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode, int length) } declare 385 generic { - int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *stringObj, + int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj) } declare 386 generic { void Tcl_SetNotifier(Tcl_NotifierProcs *notifierProcPtr) } @@ -1477,16 +1477,16 @@ declare 418 generic { int Tcl_IsChannelExisting(CONST char* channelName) } declare 419 generic { - int Tcl_UniCharNcasecmp(CONST Tcl_UniChar *cs, CONST Tcl_UniChar *ct, - unsigned long n) + int Tcl_UniCharNcasecmp(CONST Tcl_UniChar *ucs, CONST Tcl_UniChar *uct, + unsigned long numChars) } declare 420 generic { - int Tcl_UniCharCaseMatch(CONST Tcl_UniChar *ustr, - CONST Tcl_UniChar *pattern, int nocase) + int Tcl_UniCharCaseMatch(CONST Tcl_UniChar *uniStr, + CONST Tcl_UniChar *uniPattern, int nocase) } declare 421 generic { Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, CONST char *key) } @@ -1924,10 +1924,114 @@ int Tcl_SetReturnOptions(Tcl_Interp *interp, Tcl_Obj *options) } declare 539 generic { Tcl_Obj *Tcl_GetReturnOptions(Tcl_Interp *interp, int result) } +# TIP#235 +declare 540 generic { + int Tcl_IsEnsemble(Tcl_Command token) +} +declare 541 generic { + Tcl_Command Tcl_CreateEnsemble(Tcl_Interp *interp, CONST char *name, + Tcl_Namespace *namespacePtr, int flags) +} +declare 542 generic { + Tcl_Command Tcl_FindEnsemble(Tcl_Interp *interp, Tcl_Obj *cmdNameObj, + int flags) +} +declare 543 generic { + int Tcl_SetEnsembleSubcommandList(Tcl_Interp *interp, Tcl_Command token, + Tcl_Obj *subcmdList) +} +declare 544 generic { + int Tcl_SetEnsembleMappingDict(Tcl_Interp *interp, Tcl_Command token, + Tcl_Obj *mapDict) +} +declare 545 generic { + int Tcl_SetEnsembleUnknownHandler(Tcl_Interp *interp, Tcl_Command token, + Tcl_Obj *unknownList) +} +declare 546 generic { + int Tcl_SetEnsembleFlags(Tcl_Interp *interp, Tcl_Command token, int flags) +} +declare 547 generic { + int Tcl_GetEnsembleSubcommandList(Tcl_Interp *interp, Tcl_Command token, + Tcl_Obj **subcmdListPtr) +} +declare 548 generic { + int Tcl_GetEnsembleMappingDict(Tcl_Interp *interp, Tcl_Command token, + Tcl_Obj **mapDictPtr) +} +declare 549 generic { + int Tcl_GetEnsembleUnknownHandler(Tcl_Interp *interp, Tcl_Command token, + Tcl_Obj **unknownListPtr) +} +declare 550 generic { + int Tcl_GetEnsembleFlags(Tcl_Interp *interp, Tcl_Command token, + int *flagsPtr) +} +declare 551 generic { + int Tcl_GetEnsembleNamespace(Tcl_Interp *interp, Tcl_Command token, + Tcl_Namespace **namespacePtrPtr) +} +# TIP#233 (Virtualized Time) +declare 552 generic { + void Tcl_SetTimeProc (Tcl_GetTimeProc* getProc, + Tcl_ScaleTimeProc* scaleProc, + ClientData clientData) +} +declare 553 generic { + void Tcl_QueryTimeProc (Tcl_GetTimeProc** getProc, + Tcl_ScaleTimeProc** scaleProc, + ClientData* clientData) +} +# TIP#218 (Driver Thread Actions) davygrvy/akupries ChannelType ver 4 +declare 554 generic { + Tcl_DriverThreadActionProc *Tcl_ChannelThreadActionProc(Tcl_ChannelType *chanTypePtr) +} + +# TIP #237: + +declare 555 generic { + Tcl_Obj* Tcl_NewBignumObj( mp_int* value ) +} +declare 556 generic { + Tcl_Obj* Tcl_DbNewBignumObj( mp_int* value, CONST char* file, int line ) +} +declare 557 generic { + void Tcl_SetBignumObj( Tcl_Obj* obj, mp_int* value ) +} +declare 558 generic { + int Tcl_GetBignumFromObj( Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value ) +} +declare 559 generic { + int Tcl_GetBignumAndClearObj( Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value ) +} + +# TIP #208: +declare 560 generic { + int Tcl_TruncateChannel(Tcl_Channel chan, Tcl_WideInt length) +} +declare 561 generic { + Tcl_DriverTruncateProc *Tcl_ChannelTruncateProc( + Tcl_ChannelType *chanTypePtr) +} + +# TIP#219 (Tcl Channel Reflection API) akupries + +declare 562 generic { + void Tcl_SetChannelErrorInterp (Tcl_Interp* interp, Tcl_Obj* msg) +} +declare 563 generic { + void Tcl_GetChannelErrorInterp (Tcl_Interp* interp, Tcl_Obj** msg) +} +declare 564 generic { + void Tcl_SetChannelError (Tcl_Channel chan, Tcl_Obj* msg) +} +declare 565 generic { + void Tcl_GetChannelError (Tcl_Channel chan, Tcl_Obj** msg) +} ############################################################################## # Define the platform specific public Tcl interface. These functions are # only available on the designated platform. Index: generic/tcl.h ================================================================== --- generic/tcl.h +++ generic/tcl.h @@ -1,37 +1,45 @@ /* * tcl.h -- * - * This header file describes the externally-visible facilities - * of the Tcl interpreter. + * This header file describes the externally-visible facilities of the + * Tcl interpreter. * * Copyright (c) 1987-1994 The Regents of the University of California. * Copyright (c) 1993-1996 Lucent Technologies. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Copyright (c) 2002 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. + * 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.191 2004/11/17 17:53:01 dgp Exp $ + * RCS: @(#) $Id: tcl.h,v 1.191.2.11 2005/09/27 18:42:54 dgp Exp $ */ #ifndef _TCL #define _TCL +/* + * For C++ compilers, use extern "C" + */ + +#ifdef __cplusplus +extern "C" { +#endif + /* * The following defines are used to indicate the various release levels. */ #define TCL_ALPHA_RELEASE 0 #define TCL_BETA_RELEASE 1 #define TCL_FINAL_RELEASE 2 /* - * When version numbers change here, must also go into the following files - * and update the version numbers: + * When version numbers change here, must also go into the following files and + * update the version numbers: * * library/init.tcl (only if Major.minor changes, not patchlevel) 1 LOC * unix/configure.in (2 LOC Major, 2 LOC minor, 1 LOC patch) * win/configure.in (as above) * win/tcl.m4 (not patchlevel) @@ -44,21 +52,22 @@ * tests/basic.test (1 LOC M/M, not patchlevel) * tools/tcl.hpj.in (not patchlevel, for windows installer) * tools/tcl.wse.in (for windows installer) * tools/tclSplash.bmp (not patchlevel) */ + #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 5 #define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE -#define TCL_RELEASE_SERIAL 2 +#define TCL_RELEASE_SERIAL 4 #define TCL_VERSION "8.5" -#define TCL_PATCH_LEVEL "8.5a2" +#define TCL_PATCH_LEVEL "8.5a4" /* - * The following definitions set up the proper options for Windows - * compilers. We use this method because there is no autoconf equivalent. + * The following definitions set up the proper options for Windows compilers. + * We use this method because there is no autoconf equivalent. */ #ifndef __WIN32__ # if defined(_WIN32) || defined(WIN32) || defined(__MINGW32__) || defined(__BORLANDC__) || (defined(__WATCOMC__) && defined(__WINDOWS_386__)) # define __WIN32__ @@ -72,10 +81,11 @@ #endif /* * STRICT: See MSDN Article Q83456 */ + #ifdef __WIN32__ # ifndef STRICT # define STRICT # endif #endif /* __WIN32__ */ @@ -82,44 +92,45 @@ /* * Utility macros: STRINGIFY takes an argument and wraps it in "" (double * quotation marks), JOIN joins two arguments. */ + #ifndef STRINGIFY # define STRINGIFY(x) STRINGIFY1(x) # define STRINGIFY1(x) #x #endif #ifndef JOIN # define JOIN(a,b) JOIN1(a,b) # define JOIN1(a,b) a##b #endif -/* - * A special definition used to allow this header file to be included - * from windows resource files so that they can obtain version - * information. RC_INVOKED is defined by default by the windows RC tool. +/* + * A special definition used to allow this header file to be included from + * windows resource files so that they can obtain version information. + * RC_INVOKED is defined by default by the windows RC tool. * - * Resource compilers don't like all the C stuff, like typedefs and - * procedure declarations, that occur below, so block them out. + * Resource compilers don't like all the C stuff, like typedefs and function + * declarations, that occur below, so block them out. */ #ifndef RC_INVOKED /* - * Special macro to define mutexes, that doesn't do anything - * if we are not using threads. + * Special macro to define mutexes, that doesn't do anything if we are not + * using threads. */ #ifdef TCL_THREADS #define TCL_DECLARE_MUTEX(name) static Tcl_Mutex name; #else #define TCL_DECLARE_MUTEX(name) #endif /* - * Macros that eliminate the overhead of the thread synchronization - * functions when compiling without thread support. + * Macros that eliminate the overhead of the thread synchronization functions + * when compiling without thread support. */ #ifndef TCL_THREADS #define Tcl_MutexLock(mutexPtr) #define Tcl_MutexUnlock(mutexPtr) @@ -128,48 +139,44 @@ #define Tcl_ConditionWait(condPtr, mutexPtr, timePtr) #define Tcl_ConditionFinalize(condPtr) #endif /* TCL_THREADS */ /* - * Tcl's public routine Tcl_FSSeek() uses the values SEEK_SET, - * SEEK_CUR, and SEEK_END, all #define'd by stdio.h . - * - * Also, many extensions need stdio.h, and they've grown accustomed - * to tcl.h providing it for them rather than #include-ing it themselves - * as they should, so also for their sake, we keep the #include to be - * consistent with prior Tcl releases. - */ + * Tcl's public routine Tcl_FSSeek() uses the values SEEK_SET, SEEK_CUR, and + * SEEK_END, all #define'd by stdio.h . + * + * Also, many extensions need stdio.h, and they've grown accustomed to tcl.h + * providing it for them rather than #include-ing it themselves as they + * should, so also for their sake, we keep the #include to be consistent with + * prior Tcl releases. + */ + #include /* - * Definitions that allow Tcl functions with variable numbers of - * arguments to be used with either varargs.h or stdarg.h. TCL_VARARGS - * is used in procedure prototypes. TCL_VARARGS_DEF is used to declare - * the arguments in a function definiton: it takes the type and name of - * the first argument and supplies the appropriate argument declaration - * string for use in the function definition. TCL_VARARGS_START - * initializes the va_list data structure and returns the first argument. + * Support for functions with a variable number of arguments. + * + * The following TCL_VARARGS* macros are to support old extensions + * written for older versions of Tcl where the macros permitted + * support for the varargs.h system as well as stdarg.h . + * + * New code should just directly be written to use stdarg.h conventions. */ -#if !defined(NO_STDARG) -# include -# define TCL_VARARGS(type, name) (type name, ...) -# define TCL_VARARGS_DEF(type, name) (type name, ...) -# define TCL_VARARGS_START(type, name, list) (va_start(list, name), name) -#else -# include -# define TCL_VARARGS(type, name) () -# define TCL_VARARGS_DEF(type, name) (va_alist) -# define TCL_VARARGS_START(type, name, list) \ - (va_start(list), va_arg(list, type)) + +#include +#ifndef TCL_NO_DEPRECATED +# define TCL_VARARGS(type, name) (type name, ...) +# define TCL_VARARGS_DEF(type, name) (type name, ...) +# define TCL_VARARGS_START(type, name, list) (va_start(list, name), name) #endif /* - * Macros used to declare a function to be exported by a DLL. - * Used by Windows, maps to no-op declarations on non-Windows systems. - * The default build on windows is for a DLL, which causes the DLLIMPORT - * and DLLEXPORT macros to be nonempty. To build a static library, the - * macro STATIC_BUILD should be defined. + * Macros used to declare a function to be exported by a DLL. Used by Windows, + * maps to no-op declarations on non-Windows systems. The default build on + * windows is for a DLL, which causes the DLLIMPORT and DLLEXPORT macros to be + * nonempty. To build a static library, the macro STATIC_BUILD should be + * defined. */ #ifdef STATIC_BUILD # define DLLIMPORT # define DLLEXPORT @@ -183,23 +190,24 @@ # endif #endif /* * These macros are used to control whether functions are being declared for - * import or export. If a function is being declared while it is being built + * import or export. If a function is being declared while it is being built * to be included in a shared library, then it should have the DLLEXPORT - * storage class. If is being declared for use by a module that is going to + * storage class. If is being declared for use by a module that is going to * link against the shared library, then it should have the DLLIMPORT storage - * class. If the symbol is beind declared for a static build or for use from a + * class. If the symbol is beind declared for a static build or for use from a * stub library, then the storage class should be empty. * - * The convention is that a macro called BUILD_xxxx, where xxxx is the - * name of a library we are building, is set on the compile line for sources - * that are to be placed in the library. When this macro is set, the - * storage class will be set to DLLEXPORT. At the end of the header file, the - * storage class will be reset to DLLIMPORT. + * The convention is that a macro called BUILD_xxxx, where xxxx is the name of + * a library we are building, is set on the compile line for sources that are + * to be placed in the library. When this macro is set, the storage class will + * be set to DLLEXPORT. At the end of the header file, the storage class will + * be reset to DLLIMPORT. */ + #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl # define TCL_STORAGE_CLASS DLLEXPORT #else # ifdef USE_TCL_STUBS @@ -207,15 +215,15 @@ # else # define TCL_STORAGE_CLASS DLLIMPORT # endif #endif +/* + * Definitions that allow this header file to be used either with or without + * ANSI C features like function prototypes. + */ -/* - * Definitions that allow this header file to be used either with or - * without ANSI C features like function prototypes. - */ #undef _ANSI_ARGS_ #undef CONST #ifndef INLINE # define INLINE #endif @@ -238,22 +246,22 @@ # endif # define CONST84 # define CONST84_RETURN #else # ifdef USE_COMPAT_CONST -# define CONST84 +# define CONST84 # define CONST84_RETURN CONST # else # define CONST84 CONST # define CONST84_RETURN CONST # endif #endif - /* * Make sure EXTERN isn't defined elsewhere */ + #ifdef EXTERN # undef EXTERN #endif /* EXTERN */ #ifdef __cplusplus @@ -260,19 +268,16 @@ # define EXTERN extern "C" TCL_STORAGE_CLASS #else # define EXTERN extern TCL_STORAGE_CLASS #endif - -/* - * The following code is copied from winnt.h. - * If we don't replicate it here, then can't be included - * after tcl.h, since tcl.h also defines VOID. - * This block is skipped under Cygwin and Mingw. - * - * - */ +/* + * The following code is copied from winnt.h. If we don't replicate it here, + * then can't be included after tcl.h, since tcl.h also defines + * VOID. This block is skipped under Cygwin and Mingw. + */ + #if defined(__WIN32__) && !defined(HAVE_WINNT_IGNORE_VOID) #ifndef VOID #define VOID void typedef char CHAR; typedef short SHORT; @@ -279,24 +284,24 @@ typedef long LONG; #endif #endif /* __WIN32__ && !HAVE_WINNT_IGNORE_VOID */ /* - * Macro to use instead of "void" for arguments that must have - * type "void *" in ANSI C; maps them to type "char *" in - * non-ANSI systems. + * Macro to use instead of "void" for arguments that must have type "void *" + * in ANSI C; maps them to type "char *" in non-ANSI systems. */ #ifndef NO_VOID -# define VOID void +#define VOID void #else -# define VOID char +#define VOID char #endif /* * Miscellaneous declarations. */ + #ifndef NULL # define NULL 0 #endif #ifndef _CLIENTDATA @@ -307,31 +312,31 @@ # endif # define _CLIENTDATA #endif /* - * Define Tcl_WideInt to be a type that is (at least) 64-bits wide, - * and define Tcl_WideUInt to be the unsigned variant of that type - * (assuming that where we have one, we can have the other.) + * Define Tcl_WideInt to be a type that is (at least) 64-bits wide, and define + * Tcl_WideUInt to be the unsigned variant of that type (assuming that where + * we have one, we can have the other.) * * Also defines the following macros: - * TCL_WIDE_INT_IS_LONG - if wide ints are really longs (i.e. we're on - * a real 64-bit system.) + * TCL_WIDE_INT_IS_LONG - if wide ints are really longs (i.e. we're on a real + * 64-bit system.) * Tcl_WideAsLong - forgetful converter from wideInt to long. * Tcl_LongAsWide - sign-extending converter from long to wideInt. * Tcl_WideAsDouble - converter from wideInt to double. * Tcl_DoubleAsWide - converter from double to wideInt. * * The following invariant should hold for any long value 'longVal': * longVal == Tcl_WideAsLong(Tcl_LongAsWide(longVal)) * - * Note on converting between Tcl_WideInt and strings. This - * implementation (in tclObj.c) depends on the functions strtoull() - * and sprintf(...,"%" TCL_LL_MODIFIER "d",...). TCL_LL_MODIFIER_SIZE - * is the length of the modifier string, which is "ll" on most 32-bit - * Unix systems. It has to be split up like this to allow for the more - * complex formats sometimes needed (e.g. in the format(n) command.) + * Note on converting between Tcl_WideInt and strings. This implementation (in + * tclObj.c) depends on the functions strtoull() and sprintf(...,"%" + * TCL_LL_MODIFIER "d",...). TCL_LL_MODIFIER_SIZE is the length of the + * modifier string, which is "ll" on most 32-bit Unix systems. It has to be + * split up like this to allow for the more complex formats sometimes needed + * (e.g. in the format(n) command.) */ #if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) # if defined(__GNUC__) # define TCL_WIDE_INT_TYPE long long @@ -354,12 +359,12 @@ # define TCL_LL_MODIFIER "I64" # define TCL_LL_MODIFIER_SIZE 3 # endif /* __BORLANDC__ */ # else /* __WIN32__ */ /* - * Don't know what platform it is and configure hasn't discovered what - * is going on for us. Try to guess... + * Don't know what platform it is and configure hasn't discovered what is + * going on for us. Try to guess... */ # ifdef NO_LIMITS_H # error please define either TCL_WIDE_INT_TYPE or TCL_WIDE_INT_IS_LONG # else /* !NO_LIMITS_H */ # include @@ -389,12 +394,12 @@ # define TCL_LL_MODIFIER "l" # define TCL_LL_MODIFIER_SIZE 1 # endif /* !TCL_LL_MODIFIER */ #else /* TCL_WIDE_INT_IS_LONG */ /* - * The next short section of defines are only done when not running on - * Windows or some other strange platform. + * The next short section of defines are only done when not running on Windows + * or some other strange platform. */ # ifndef TCL_LL_MODIFIER # ifdef HAVE_STRUCT_STAT64 typedef struct stat64 Tcl_StatBuf; # else @@ -407,54 +412,53 @@ # define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val))) # define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val))) # define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val))) #endif /* TCL_WIDE_INT_IS_LONG */ - /* * This flag controls whether binary compatability is maintained with - * extensions built against a previous version of Tcl. This is true - * by default. + * extensions built against a previous version of Tcl. This is true by + * default. */ + #ifndef TCL_PRESERVE_BINARY_COMPATABILITY # define TCL_PRESERVE_BINARY_COMPATABILITY 1 #endif - -/* - * Data structures defined opaquely in this module. The definitions below - * just provide dummy types. A few fields are made visible in Tcl_Interp - * structures, namely those used for returning a string result from - * commands. Direct access to the result field is discouraged in Tcl 8.0. - * The interpreter result is either an object or a string, and the two - * values are kept consistent unless some C code sets interp->result - * directly. Programmers should use either the procedure Tcl_GetObjResult() - * or Tcl_GetStringResult() to read the interpreter's result. See the - * SetResult man page for details. - * - * Note: any change to the Tcl_Interp definition below must be mirrored - * in the "real" definition in tclInt.h. - * - * Note: Tcl_ObjCmdProc procedures do not directly set result and freeProc. +/* + * Data structures defined opaquely in this module. The definitions below just + * provide dummy types. A few fields are made visible in Tcl_Interp + * structures, namely those used for returning a string result from commands. + * Direct access to the result field is discouraged in Tcl 8.0. The + * interpreter result is either an object or a string, and the two values are + * kept consistent unless some C code sets interp->result directly. + * Programmers should use either the function Tcl_GetObjResult() or + * Tcl_GetStringResult() to read the interpreter's result. See the SetResult + * man page for details. + * + * Note: any change to the Tcl_Interp definition below must be mirrored in the + * "real" definition in tclInt.h. + * + * Note: Tcl_ObjCmdProc functions do not directly set result and freeProc. * Instead, they set a Tcl_Obj member in the "real" structure that can be * accessed with Tcl_GetObjResult() and Tcl_SetObjResult(). */ typedef struct Tcl_Interp { char *result; /* If the last command returned a string * result, this points to it. */ void (*freeProc) _ANSI_ARGS_((char *blockPtr)); - /* Zero means the string result is - * statically allocated. TCL_DYNAMIC means - * it was allocated with ckalloc and should - * be freed with ckfree. Other values give - * the address of procedure to invoke to - * free the result. Tcl_Eval must free it - * before executing next command. */ - int errorLine; /* When TCL_ERROR is returned, this gives - * the line number within the command where - * the error occurred (1 if first line). */ + /* Zero means the string result is statically + * allocated. TCL_DYNAMIC means it was + * allocated with ckalloc and should be freed + * with ckfree. Other values give the address + * of function to invoke to free the result. + * Tcl_Eval must free it before executing next + * command. */ + int errorLine; /* When TCL_ERROR is returned, this gives the + * line number within the command where the + * error occurred (1 if first line). */ } Tcl_Interp; typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; typedef struct Tcl_Channel_ *Tcl_Channel; typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion; @@ -474,47 +478,48 @@ typedef struct Tcl_TimerToken_ *Tcl_TimerToken; typedef struct Tcl_Trace_ *Tcl_Trace; typedef struct Tcl_Var_ *Tcl_Var; /* - * Definition of the interface to procedures implementing threads. - * A procedure following this definition is given to each call of - * 'Tcl_CreateThread' and will be called as the main fuction of - * the new thread created by that call. + * Definition of the interface to functions implementing threads. A function + * following this definition is given to each call of 'Tcl_CreateThread' and + * will be called as the main fuction of the new thread created by that call. */ + #if defined __WIN32__ typedef unsigned (__stdcall Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData)); #else typedef void (Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData)); #endif - /* * Threading function return types used for abstracting away platform - * differences when writing a Tcl_ThreadCreateProc. See the NewThread - * function in generic/tclThreadTest.c for it's usage. + * differences when writing a Tcl_ThreadCreateProc. See the NewThread function + * in generic/tclThreadTest.c for it's usage. */ + #if defined __WIN32__ # define Tcl_ThreadCreateType unsigned __stdcall # define TCL_THREAD_CREATE_RETURN return 0 #else # define Tcl_ThreadCreateType void -# define TCL_THREAD_CREATE_RETURN +# define TCL_THREAD_CREATE_RETURN #endif - /* * Definition of values for default stacksize and the possible flags to be * given to Tcl_CreateThread. */ + #define TCL_THREAD_STACK_DEFAULT (0) /* Use default size for stack */ -#define TCL_THREAD_NOFLAGS (0000) /* Standard flags, default behaviour */ -#define TCL_THREAD_JOINABLE (0001) /* Mark the thread as joinable */ +#define TCL_THREAD_NOFLAGS (0000) /* Standard flags, default behaviour */ +#define TCL_THREAD_JOINABLE (0001) /* Mark the thread as joinable */ /* * Flag values passed to Tcl_GetRegExpFromObj. */ + #define TCL_REG_BASIC 000000 /* BREs (convenience) */ #define TCL_REG_EXTENDED 000001 /* EREs */ #define TCL_REG_ADVF 000002 /* advanced features in EREs */ #define TCL_REG_ADVANCED 000003 /* AREs (which are also EREs) */ #define TCL_REG_QUOTE 000004 /* no special characters, none */ @@ -527,71 +532,75 @@ #define TCL_REG_NEWLINE 000300 /* newlines are line terminators */ #define TCL_REG_CANMATCH 001000 /* report details on partial/limited * matches */ /* - * The following flag is experimental and only intended for use by Expect. It + * The following flag is experimental and only intended for use by Expect. It * will probably go away in a later release. */ + #define TCL_REG_BOSONLY 002000 /* prepend \A to pattern so it only * matches at the beginning of the * string. */ /* * Flags values passed to Tcl_RegExpExecObj. */ + #define TCL_REG_NOTBOL 0001 /* Beginning of string does not match ^. */ #define TCL_REG_NOTEOL 0002 /* End of string does not match $. */ /* - * Structures filled in by Tcl_RegExpInfo. Note that all offset values are - * relative to the start of the match string, not the beginning of the - * entire string. + * Structures filled in by Tcl_RegExpInfo. Note that all offset values are + * relative to the start of the match string, not the beginning of the entire + * string. */ + typedef struct Tcl_RegExpIndices { - long start; /* character offset of first character in match */ - long end; /* character offset of first character after the - * match. */ + long start; /* Character offset of first character in + * match. */ + long end; /* Character offset of first character after + * the match. */ } Tcl_RegExpIndices; typedef struct Tcl_RegExpInfo { - int nsubs; /* number of subexpressions in the - * compiled expression */ - Tcl_RegExpIndices *matches; /* array of nsubs match offset - * pairs */ - long extendStart; /* The offset at which a subsequent - * match might begin. */ + int nsubs; /* Number of subexpressions in the compiled + * expression. */ + Tcl_RegExpIndices *matches; /* Array of nsubs match offset pairs. */ + long extendStart; /* The offset at which a subsequent match + * might begin. */ long reserved; /* Reserved for later use. */ } Tcl_RegExpInfo; /* - * Picky compilers complain if this typdef doesn't appear before the - * struct's reference in tclDecls.h. + * Picky compilers complain if this typdef doesn't appear before the struct's + * reference in tclDecls.h. */ + typedef Tcl_StatBuf *Tcl_Stat_; typedef struct stat *Tcl_OldStat_; /* * When a TCL command returns, the interpreter contains a result from the - * command. Programmers are strongly encouraged to use one of the - * procedures Tcl_GetObjResult() or Tcl_GetStringResult() to read the - * interpreter's result. See the SetResult man page for details. Besides - * this result, the command procedure returns an integer code, which is - * one of the following: - * - * TCL_OK Command completed normally; the interpreter's - * result contains the command's result. - * TCL_ERROR The command couldn't be completed successfully; - * the interpreter's result describes what went wrong. - * TCL_RETURN The command requests that the current procedure - * return; the interpreter's result contains the - * procedure's return value. - * TCL_BREAK The command requests that the innermost loop - * be exited; the interpreter's result is meaningless. - * TCL_CONTINUE Go on to the next iteration of the current loop; - * the interpreter's result is meaningless. - */ + * command. Programmers are strongly encouraged to use one of the functions + * Tcl_GetObjResult() or Tcl_GetStringResult() to read the interpreter's + * result. See the SetResult man page for details. Besides this result, the + * command function returns an integer code, which is one of the following: + * + * TCL_OK Command completed normally; the interpreter's result + * contains the command's result. + * TCL_ERROR The command couldn't be completed successfully; the + * interpreter's result describes what went wrong. + * TCL_RETURN The command requests that the current function return; + * the interpreter's result contains the function's + * return value. + * TCL_BREAK The command requests that the innermost loop be + * exited; the interpreter's result is meaningless. + * TCL_CONTINUE Go on to the next iteration of the current loop; the + * interpreter's result is meaningless. + */ + #define TCL_OK 0 #define TCL_ERROR 1 #define TCL_RETURN 2 #define TCL_BREAK 3 #define TCL_CONTINUE 4 @@ -599,40 +608,41 @@ #define TCL_RESULT_SIZE 200 /* * Flags to control what substitutions are performed by Tcl_SubstObj(): */ + #define TCL_SUBST_COMMANDS 001 #define TCL_SUBST_VARIABLES 002 #define TCL_SUBST_BACKSLASHES 004 #define TCL_SUBST_ALL 007 - /* * Argument descriptors for math function callbacks in expressions: */ + typedef enum { TCL_INT, TCL_DOUBLE, TCL_EITHER, TCL_WIDE_INT } Tcl_ValueType; + typedef struct Tcl_Value { - Tcl_ValueType type; /* Indicates intValue or doubleValue is - * valid, or both. */ + Tcl_ValueType type; /* Indicates intValue or doubleValue is valid, + * or both. */ long intValue; /* Integer value. */ double doubleValue; /* Double-precision floating value. */ Tcl_WideInt wideValue; /* Wide (min. 64-bit) integer value. */ } Tcl_Value; /* * Forward declaration of Tcl_Obj to prevent an error when the forward - * reference to Tcl_Obj is encountered in the procedure types declared - * below. + * reference to Tcl_Obj is encountered in the function types declared below. */ + struct Tcl_Obj; - /* - * Procedure types defined by Tcl: + * Function types defined by Tcl: */ typedef int (Tcl_AppInitProc) _ANSI_ARGS_((Tcl_Interp *interp)); typedef int (Tcl_AsyncProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int code)); @@ -646,22 +656,22 @@ ClientData cmdClientData, int argc, CONST84 char *argv[])); typedef int (Tcl_CmdObjTraceProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int level, CONST char *command, Tcl_Command commandInfo, int objc, struct Tcl_Obj * CONST * objv)); typedef void (Tcl_CmdObjTraceDeleteProc) _ANSI_ARGS_((ClientData clientData)); -typedef void (Tcl_DupInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *srcPtr, - struct Tcl_Obj *dupPtr)); +typedef void (Tcl_DupInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *srcPtr, + struct Tcl_Obj *dupPtr)); typedef int (Tcl_EncodingConvertProc)_ANSI_ARGS_((ClientData clientData, CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)); typedef void (Tcl_EncodingFreeProc)_ANSI_ARGS_((ClientData clientData)); typedef int (Tcl_EventProc) _ANSI_ARGS_((Tcl_Event *evPtr, int flags)); typedef void (Tcl_EventCheckProc) _ANSI_ARGS_((ClientData clientData, int flags)); typedef int (Tcl_EventDeleteProc) _ANSI_ARGS_((Tcl_Event *evPtr, - ClientData clientData)); + ClientData clientData)); typedef void (Tcl_EventSetupProc) _ANSI_ARGS_((ClientData clientData, int flags)); typedef void (Tcl_ExitProc) _ANSI_ARGS_((ClientData clientData)); typedef void (Tcl_FileProc) _ANSI_ARGS_((ClientData clientData, int mask)); typedef void (Tcl_FileFreeProc) _ANSI_ARGS_((ClientData clientData)); @@ -675,20 +685,21 @@ typedef void (Tcl_NamespaceDeleteProc) _ANSI_ARGS_((ClientData clientData)); typedef int (Tcl_ObjCmdProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST * objv)); typedef int (Tcl_PackageInitProc) _ANSI_ARGS_((Tcl_Interp *interp)); typedef int (Tcl_PackageUnloadProc) _ANSI_ARGS_((Tcl_Interp *interp, - int flags)); -typedef void (Tcl_PanicProc) _ANSI_ARGS_(TCL_VARARGS(CONST char *, format)); + int flags)); +typedef void (Tcl_PanicProc) _ANSI_ARGS_((CONST char *format, ...)); typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData, - Tcl_Channel chan, char *address, int port)); + Tcl_Channel chan, char *address, int port)); typedef void (Tcl_TimerProc) _ANSI_ARGS_((ClientData clientData)); typedef int (Tcl_SetFromAnyProc) _ANSI_ARGS_((Tcl_Interp *interp, struct Tcl_Obj *objPtr)); typedef void (Tcl_UpdateStringProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr)); typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, CONST84 char *part1, CONST84 char *part2, int flags)); + Tcl_Interp *interp, CONST84 char *part1, CONST84 char *part2, + int flags)); typedef void (Tcl_CommandTraceProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, CONST char *oldName, CONST char *newName, int flags)); typedef void (Tcl_CreateFileHandlerProc) _ANSI_ARGS_((int fd, int mask, Tcl_FileProc *proc, ClientData clientData)); @@ -697,85 +708,88 @@ typedef void (Tcl_ServiceModeHookProc) _ANSI_ARGS_((int mode)); typedef ClientData (Tcl_InitNotifierProc) _ANSI_ARGS_((VOID)); typedef void (Tcl_FinalizeNotifierProc) _ANSI_ARGS_((ClientData clientData)); typedef void (Tcl_MainLoopProc) _ANSI_ARGS_((void)); - /* - * The following structure represents a type of object, which is a - * particular internal representation for an object plus a set of - * procedures that provide standard operations on objects of that type. + * The following structure represents a type of object, which is a particular + * internal representation for an object plus a set of functions that provide + * standard operations on objects of that type. */ typedef struct Tcl_ObjType { char *name; /* Name of the type, e.g. "int". */ Tcl_FreeInternalRepProc *freeIntRepProc; /* Called to free any storage for the type's - * internal rep. NULL if the internal rep - * does not need freeing. */ + * internal rep. NULL if the internal rep does + * not need freeing. */ Tcl_DupInternalRepProc *dupIntRepProc; - /* Called to create a new object as a copy - * of an existing object. */ + /* Called to create a new object as a copy of + * an existing object. */ Tcl_UpdateStringProc *updateStringProc; - /* Called to update the string rep from the + /* Called to update the string rep from the * type's internal representation. */ Tcl_SetFromAnyProc *setFromAnyProc; - /* Called to convert the object's internal - * rep to this type. Frees the internal rep - * of the old type. Returns TCL_ERROR on - * failure. */ + /* Called to convert the object's internal rep + * to this type. Frees the internal rep of the + * old type. Returns TCL_ERROR on failure. */ } Tcl_ObjType; - /* - * One of the following structures exists for each object in the Tcl - * system. An object stores a value as either a string, some internal - * representation, or both. + * One of the following structures exists for each object in the Tcl system. + * An object stores a value as either a string, some internal representation, + * or both. */ typedef struct Tcl_Obj { int refCount; /* When 0 the object will be freed. */ char *bytes; /* This points to the first byte of the * object's string representation. The array * must be followed by a null byte (i.e., at * offset length) but may also contain * embedded null characters. The array's - * storage is allocated by ckalloc. NULL - * means the string rep is invalid and must - * be regenerated from the internal rep. - * Clients should use Tcl_GetStringFromObj - * or Tcl_GetString to get a pointer to the - * byte array as a readonly value. */ + * storage is allocated by ckalloc. NULL means + * the string rep is invalid and must be + * regenerated from the internal rep. Clients + * should use Tcl_GetStringFromObj or + * Tcl_GetString to get a pointer to the byte + * array as a readonly value. */ int length; /* The number of bytes at *bytes, not * including the terminating null. */ Tcl_ObjType *typePtr; /* Denotes the object's type. Always * corresponds to the type of the object's - * internal rep. NULL indicates the object - * has no internal rep (has no type). */ + * internal rep. NULL indicates the object has + * no internal rep (has no type). */ union { /* The internal representation: */ long longValue; /* - an long integer value */ double doubleValue; /* - a double-precision floating value */ VOID *otherValuePtr; /* - another, type-specific value */ Tcl_WideInt wideValue; /* - a long long value */ struct { /* - internal rep as two pointers */ VOID *ptr1; VOID *ptr2; } twoPtrValue; + struct { /* - internal rep as a wide int, tightly + * packed fields */ + VOID *ptr; /* Pointer to digits */ + unsigned long value;/* Alloc, used, and signum packed into a + * single word */ + } ptrAndLongRep; } internalRep; } Tcl_Obj; - -/* - * Macros to increment and decrement a Tcl_Obj's reference count, and to - * test whether an object is shared (i.e. has reference count > 1). - * Note: clients should use Tcl_DecrRefCount() when they are finished using - * an object, and should never call TclFreeObj() directly. TclFreeObj() is - * only defined and made public in tcl.h to support Tcl_DecrRefCount's macro - * definition. Note also that Tcl_DecrRefCount() refers to the parameter - * "obj" twice. This means that you should avoid calling it with an - * expression that is expensive to compute or has side effects. - */ +/* + * Macros to increment and decrement a Tcl_Obj's reference count, and to test + * whether an object is shared (i.e. has reference count > 1). Note: clients + * should use Tcl_DecrRefCount() when they are finished using an object, and + * should never call TclFreeObj() directly. TclFreeObj() is only defined and + * made public in tcl.h to support Tcl_DecrRefCount's macro definition. Note + * also that Tcl_DecrRefCount() refers to the parameter "obj" twice. This + * means that you should avoid calling it with an expression that is expensive + * to compute or has side effects. + */ + void Tcl_IncrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr)); void Tcl_DecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr)); int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr)); #ifdef TCL_MEM_DEBUG @@ -793,16 +807,18 @@ # define Tcl_IsShared(objPtr) \ ((objPtr)->refCount > 1) #endif /* - * Macros and definitions that help to debug the use of Tcl objects. - * When TCL_MEM_DEBUG is defined, the Tcl_New declarations are - * overridden to call debugging versions of the object creation procedures. + * Macros and definitions that help to debug the use of Tcl objects. When + * TCL_MEM_DEBUG is defined, the Tcl_New declarations are overridden to call + * debugging versions of the object creation functions. */ #ifdef TCL_MEM_DEBUG +# define Tcl_NewBignumObj(val) \ + Tcl_DbNewBignumObj(val, __FILE__, __LINE__) # define Tcl_NewBooleanObj(val) \ Tcl_DbNewBooleanObj(val, __FILE__, __LINE__) # define Tcl_NewByteArrayObj(bytes, len) \ Tcl_DbNewByteArrayObj(bytes, len, __FILE__, __LINE__) # define Tcl_NewDoubleObj(val) \ @@ -819,16 +835,16 @@ Tcl_DbNewStringObj(bytes, len, __FILE__, __LINE__) # define Tcl_NewWideIntObj(val) \ Tcl_DbNewWideIntObj(val, __FILE__, __LINE__) #endif /* TCL_MEM_DEBUG */ +/* + * The following structure contains the state needed by Tcl_SaveResult. No-one + * outside of Tcl should access any of these fields. This structure is + * typically allocated on the stack. + */ -/* - * The following structure contains the state needed by - * Tcl_SaveResult. No-one outside of Tcl should access any of these - * fields. This structure is typically allocated on the stack. - */ typedef struct Tcl_SavedResult { char *result; Tcl_FreeProc *freeProc; Tcl_Obj *objResultPtr; char *appendResult; @@ -835,53 +851,51 @@ int appendAvl; int appendUsed; char resultSpace[TCL_RESULT_SIZE+1]; } Tcl_SavedResult; - /* - * The following definitions support Tcl's namespace facility. - * Note: the first five fields must match exactly the fields in a - * Namespace structure (see tclInt.h). + * The following definitions support Tcl's namespace facility. Note: the first + * five fields must match exactly the fields in a Namespace structure (see + * tclInt.h). */ typedef struct Tcl_Namespace { - char *name; /* The namespace's name within its parent - * namespace. This contains no ::'s. The - * name of the global namespace is "" - * although "::" is an synonym. */ - char *fullName; /* The namespace's fully qualified name. - * This starts with ::. */ - ClientData clientData; /* Arbitrary value associated with this + char *name; /* The namespace's name within its parent + * namespace. This contains no ::'s. The name + * of the global namespace is "" although "::" + * is an synonym. */ + char *fullName; /* The namespace's fully qualified name. This + * starts with ::. */ + ClientData clientData; /* Arbitrary value associated with this * namespace. */ Tcl_NamespaceDeleteProc* deleteProc; - /* Procedure invoked when deleting the + /* Function invoked when deleting the * namespace to, e.g., free clientData. */ struct Tcl_Namespace* parentPtr; - /* Points to the namespace that contains - * this one. NULL if this is the global + /* Points to the namespace that contains this + * one. NULL if this is the global * namespace. */ } Tcl_Namespace; - /* - * The following structure represents a call frame, or activation record. - * A call frame defines a naming context for a procedure call: its local - * scope (for local variables) and its namespace scope (used for non-local - * variables; often the global :: namespace). A call frame can also define - * the naming context for a namespace eval or namespace inscope command: - * the namespace in which the command's code should execute. The - * Tcl_CallFrame structures exist only while procedures or namespace - * eval/inscope's are being executed, and provide a Tcl call stack. - * - * A call frame is initialized and pushed using Tcl_PushCallFrame and - * popped using Tcl_PopCallFrame. Storage for a Tcl_CallFrame must be - * provided by the Tcl_PushCallFrame caller, and callers typically allocate - * them on the C call stack for efficiency. For this reason, Tcl_CallFrame - * is defined as a structure and not as an opaque token. However, most - * Tcl_CallFrame fields are hidden since applications should not access - * them directly; others are declared as "dummyX". + * The following structure represents a call frame, or activation record. A + * call frame defines a naming context for a procedure call: its local scope + * (for local variables) and its namespace scope (used for non-local + * variables; often the global :: namespace). A call frame can also define the + * naming context for a namespace eval or namespace inscope command: the + * namespace in which the command's code should execute. The Tcl_CallFrame + * structures exist only while procedures or namespace eval/inscope's are + * being executed, and provide a Tcl call stack. + * + * A call frame is initialized and pushed using Tcl_PushCallFrame and popped + * using Tcl_PopCallFrame. Storage for a Tcl_CallFrame must be provided by the + * Tcl_PushCallFrame caller, and callers typically allocate them on the C call + * stack for efficiency. For this reason, Tcl_CallFrame is defined as a + * structure and not as an opaque token. However, most Tcl_CallFrame fields + * are hidden since applications should not access them directly; others are + * declared as "dummyX". * * WARNING!! The structure definition must be kept consistent with the * CallFrame structure in tclInt.h. If you change one, change the other. */ @@ -897,109 +911,111 @@ char *dummy8; int dummy9; char* dummy10; } Tcl_CallFrame; - /* * Information about commands that is returned by Tcl_GetCommandInfo and - * passed to Tcl_SetCommandInfo. objProc is an objc/objv object-based - * command procedure while proc is a traditional Tcl argc/argv - * string-based procedure. Tcl_CreateObjCommand and Tcl_CreateCommand - * ensure that both objProc and proc are non-NULL and can be called to - * execute the command. However, it may be faster to call one instead of - * the other. The member isNativeObjectProc is set to 1 if an - * object-based procedure was registered by Tcl_CreateObjCommand, and to - * 0 if a string-based procedure was registered by Tcl_CreateCommand. - * The other procedure is typically set to a compatibility wrapper that - * does string-to-object or object-to-string argument conversions then - * calls the other procedure. + * passed to Tcl_SetCommandInfo. objProc is an objc/objv object-based command + * function while proc is a traditional Tcl argc/argv string-based function. + * Tcl_CreateObjCommand and Tcl_CreateCommand ensure that both objProc and + * proc are non-NULL and can be called to execute the command. However, it may + * be faster to call one instead of the other. The member isNativeObjectProc + * is set to 1 if an object-based function was registered by + * Tcl_CreateObjCommand, and to 0 if a string-based function was registered by + * Tcl_CreateCommand. The other function is typically set to a compatibility + * wrapper that does string-to-object or object-to-string argument conversions + * then calls the other function. */ typedef struct Tcl_CmdInfo { - int isNativeObjectProc; /* 1 if objProc was registered by a call to - * Tcl_CreateObjCommand; 0 otherwise. - * Tcl_SetCmdInfo does not modify this - * field. */ - Tcl_ObjCmdProc *objProc; /* Command's object-based procedure. */ - ClientData objClientData; /* ClientData for object proc. */ - Tcl_CmdProc *proc; /* Command's string-based procedure. */ - ClientData clientData; /* ClientData for string proc. */ + int isNativeObjectProc; /* 1 if objProc was registered by a call to + * Tcl_CreateObjCommand; 0 otherwise. + * Tcl_SetCmdInfo does not modify this + * field. */ + Tcl_ObjCmdProc *objProc; /* Command's object-based function. */ + ClientData objClientData; /* ClientData for object proc. */ + Tcl_CmdProc *proc; /* Command's string-based function. */ + ClientData clientData; /* ClientData for string proc. */ Tcl_CmdDeleteProc *deleteProc; - /* Procedure to call when command is - * deleted. */ - ClientData deleteData; /* Value to pass to deleteProc (usually - * the same as clientData). */ - Tcl_Namespace *namespacePtr; /* Points to the namespace that contains - * this command. Note that Tcl_SetCmdInfo - * will not change a command's namespace; - * use TclRenameCommand or Tcl_Eval (of - * 'rename') to do that. */ - + /* Function to call when command is + * deleted. */ + ClientData deleteData; /* Value to pass to deleteProc (usually the + * same as clientData). */ + Tcl_Namespace *namespacePtr;/* Points to the namespace that contains this + * command. Note that Tcl_SetCmdInfo will not + * change a command's namespace; use + * TclRenameCommand or Tcl_Eval (of 'rename') + * to do that. */ } Tcl_CmdInfo; /* - * The structure defined below is used to hold dynamic strings. The only - * field that clients should use is the string field, accessible via the - * macro Tcl_DStringValue. + * The structure defined below is used to hold dynamic strings. The only + * fields that clients should use are string and length, accessible via the + * macros Tcl_DStringValue and Tcl_DStringLength. */ + #define TCL_DSTRING_STATIC_SIZE 200 typedef struct Tcl_DString { - char *string; /* Points to beginning of string: either + char *string; /* Points to beginning of string: either * staticSpace below or a malloced array. */ int length; /* Number of non-NULL characters in the * string. */ int spaceAvl; /* Total number of bytes available for the * string and its terminating NULL char. */ char staticSpace[TCL_DSTRING_STATIC_SIZE]; - /* Space to use in common case where string - * is small. */ + /* Space to use in common case where string is + * small. */ } Tcl_DString; #define Tcl_DStringLength(dsPtr) ((dsPtr)->length) #define Tcl_DStringValue(dsPtr) ((dsPtr)->string) #define Tcl_DStringTrunc Tcl_DStringSetLength /* - * Definitions for the maximum number of digits of precision that may - * be specified in the "tcl_precision" variable, and the number of - * bytes of buffer space required by Tcl_PrintDouble. + * Definitions for the maximum number of digits of precision that may be + * specified in the "tcl_precision" variable, and the number of bytes of + * buffer space required by Tcl_PrintDouble. */ + #define TCL_MAX_PREC 17 #define TCL_DOUBLE_SPACE (TCL_MAX_PREC+10) /* * Definition for a number of bytes of buffer space sufficient to hold the - * string representation of an integer in base 10 (assuming the existence - * of 64-bit integers). + * string representation of an integer in base 10 (assuming the existence of + * 64-bit integers). */ + #define TCL_INTEGER_SPACE 24 /* * Flag values passed to Tcl_ConvertElement. - * TCL_DONT_USE_BRACES forces it not to enclose the element in braces, but - * to use backslash quoting instead. - * TCL_DONT_QUOTE_HASH disables the default quoting of the '#' character. - * It is safe to leave the hash unquoted when the element is not the - * first element of a list, and this flag can be used by the caller to - * indicated that condition. - * (careful! if you change these flag values be sure to change the - * definitions at the front of tclUtil.c). + * TCL_DONT_USE_BRACES forces it not to enclose the element in braces, but to + * use backslash quoting instead. + * TCL_DONT_QUOTE_HASH disables the default quoting of the '#' character. It + * is safe to leave the hash unquoted when the element is not the first + * element of a list, and this flag can be used by the caller to indicate + * that condition. + * (Careful! If you change these flag values be sure to change the definitions + * at the front of tclUtil.c). */ + #define TCL_DONT_USE_BRACES 1 #define TCL_DONT_QUOTE_HASH 8 /* * Flag that may be passed to Tcl_GetIndexFromObj to force it to disallow * abbreviated strings. */ + #define TCL_EXACT 1 /* * Flag values passed to Tcl_RecordAndEval, Tcl_EvalObj, Tcl_EvalObjv. - * WARNING: these bit choices must not conflict with the bit choices - * for evalFlag bits in tclInt.h!! + * WARNING: these bit choices must not conflict with the bit choices for + * evalFlag bits in tclInt.h! * * Meanings: * TCL_NO_EVAL: Just record this command * TCL_EVAL_GLOBAL: Execute script in global namespace * TCL_EVAL_DIRECT: Do not compile this script @@ -1013,20 +1029,22 @@ #define TCL_EVAL_GLOBAL 0x20000 #define TCL_EVAL_DIRECT 0x40000 #define TCL_EVAL_INVOKE 0x80000 /* - * Special freeProc values that may be passed to Tcl_SetResult (see - * the man page for details): + * Special freeProc values that may be passed to Tcl_SetResult (see the man + * page for details): */ + #define TCL_VOLATILE ((Tcl_FreeProc *) 1) #define TCL_STATIC ((Tcl_FreeProc *) 0) #define TCL_DYNAMIC ((Tcl_FreeProc *) 3) /* - * Flag values passed to variable-related procedures. + * Flag values passed to variable-related functions. */ + #define TCL_GLOBAL_ONLY 1 #define TCL_NAMESPACE_ONLY 2 #define TCL_APPEND_VALUE 4 #define TCL_LIST_ELEMENT 8 #define TCL_TRACE_READS 0x10 @@ -1043,52 +1061,61 @@ /* Indicate the semantics of the result of a trace */ #define TCL_TRACE_RESULT_DYNAMIC 0x8000 #define TCL_TRACE_RESULT_OBJECT 0x10000 /* - * Flag values passed to command-related procedures. + * Flag values for ensemble commands. + */ + +#define TCL_ENSEMBLE_PREFIX 0x02/* Flag value to say whether to allow + * unambiguous prefixes of commands or to + * require exact matches for command names. */ + +/* + * Flag values passed to command-related functions. */ #define TCL_TRACE_RENAME 0x2000 #define TCL_TRACE_DELETE 0x4000 #define TCL_ALLOW_INLINE_COMPILATION 0x20000 /* - * Flag values passed to Tcl_CreateObjTrace, and used internally - * by command execution traces. Slots 4,8,16 and 32 are - * used internally by execution traces (see tclCmdMZ.c) - */ -#define TCL_TRACE_ENTER_EXEC 1 -#define TCL_TRACE_LEAVE_EXEC 2 - -/* - * The TCL_PARSE_PART1 flag is deprecated and has no effect. - * The part1 is now always parsed whenever the part2 is NULL. - * (This is to avoid a common error when converting code to - * use the new object based APIs and forgetting to give the - * flag) - */ + * The TCL_PARSE_PART1 flag is deprecated and has no effect. The part1 is now + * always parsed whenever the part2 is NULL. (This is to avoid a common error + * when converting code to use the new object based APIs and forgetting to + * give the flag) + */ + #ifndef TCL_NO_DEPRECATED -# define TCL_PARSE_PART1 0x400 +# define TCL_PARSE_PART1 0x400 #endif - /* * Types for linked variables: */ + #define TCL_LINK_INT 1 #define TCL_LINK_DOUBLE 2 #define TCL_LINK_BOOLEAN 3 #define TCL_LINK_STRING 4 #define TCL_LINK_WIDE_INT 5 +#define TCL_LINK_CHAR 6 +#define TCL_LINK_UCHAR 7 +#define TCL_LINK_SHORT 8 +#define TCL_LINK_USHORT 9 +#define TCL_LINK_UINT 10 +#define TCL_LINK_LONG 11 +#define TCL_LINK_ULONG 12 +#define TCL_LINK_FLOAT 13 +#define TCL_LINK_WIDE_UINT 14 #define TCL_LINK_READ_ONLY 0x80 - /* * Forward declarations of Tcl_HashTable and related types. */ + typedef struct Tcl_HashKeyType Tcl_HashKeyType; typedef struct Tcl_HashTable Tcl_HashTable; typedef struct Tcl_HashEntry Tcl_HashEntry; typedef unsigned int (Tcl_HashKeyProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr, @@ -1099,205 +1126,198 @@ Tcl_HashTable *tablePtr, VOID *keyPtr)); typedef void (Tcl_FreeHashEntryProc) _ANSI_ARGS_((Tcl_HashEntry *hPtr)); /* * This flag controls whether the hash table stores the hash of a key, or - * recalculates it. There should be no reason for turning this flag off - * as it is completely binary and source compatible unless you directly - * access the bucketPtr member of the Tcl_HashTableEntry structure. This - * member has been removed and the space used to store the hash value. + * recalculates it. There should be no reason for turning this flag off as it + * is completely binary and source compatible unless you directly access the + * bucketPtr member of the Tcl_HashTableEntry structure. This member has been + * removed and the space used to store the hash value. */ + #ifndef TCL_HASH_KEY_STORE_HASH # define TCL_HASH_KEY_STORE_HASH 1 #endif /* - * Structure definition for an entry in a hash table. No-one outside - * Tcl should access any of these fields directly; use the macros - * defined below. + * Structure definition for an entry in a hash table. No-one outside Tcl + * should access any of these fields directly; use the macros defined below. */ struct Tcl_HashEntry { - Tcl_HashEntry *nextPtr; /* Pointer to next entry in this - * hash bucket, or NULL for end of - * chain. */ - Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */ + Tcl_HashEntry *nextPtr; /* Pointer to next entry in this hash bucket, + * or NULL for end of chain. */ + Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */ #if TCL_HASH_KEY_STORE_HASH # if TCL_PRESERVE_BINARY_COMPATABILITY - VOID *hash; /* Hash value, stored as pointer to - * ensure that the offsets of the - * fields in this structure are not - * changed. */ + VOID *hash; /* Hash value, stored as pointer to ensure + * that the offsets of the fields in this + * structure are not changed. */ # else - unsigned int hash; /* Hash value. */ + unsigned int hash; /* Hash value. */ # endif #else - Tcl_HashEntry **bucketPtr; /* Pointer to bucket that points to - * first entry in this entry's chain: - * used for deleting the entry. */ + Tcl_HashEntry **bucketPtr; /* Pointer to bucket that points to first + * entry in this entry's chain: used for + * deleting the entry. */ #endif - ClientData clientData; /* Application stores something here - * with Tcl_SetHashValue. */ - union { /* Key has one of these forms: */ - char *oneWordValue; /* One-word value for key. */ - Tcl_Obj *objPtr; /* Tcl_Obj * key value. */ - int words[1]; /* Multiple integer words for key. - * The actual size will be as large - * as necessary for this table's - * keys. */ - char string[4]; /* String for key. The actual size - * will be as large as needed to hold - * the key. */ - } key; /* MUST BE LAST FIELD IN RECORD!! */ + ClientData clientData; /* Application stores something here with + * Tcl_SetHashValue. */ + union { /* Key has one of these forms: */ + char *oneWordValue; /* One-word value for key. */ + Tcl_Obj *objPtr; /* Tcl_Obj * key value. */ + int words[1]; /* Multiple integer words for key. The actual + * size will be as large as necessary for this + * table's keys. */ + char string[4]; /* String for key. The actual size will be as + * large as needed to hold the key. */ + } key; /* MUST BE LAST FIELD IN RECORD!! */ }; /* * Flags used in Tcl_HashKeyType. * - * TCL_HASH_KEY_RANDOMIZE_HASH: + * TCL_HASH_KEY_RANDOMIZE_HASH - * There are some things, pointers for example * which don't hash well because they do not use * the lower bits. If this flag is set then the * hash table will attempt to rectify this by * randomising the bits and then using the upper * N bits as the index into the table. - * TCL_HASH_KEY_SYSTEM_HASH: - * If this flag is set then all memory internally + * TCL_HASH_KEY_SYSTEM_HASH - If this flag is set then all memory internally * allocated for the hash table that is not for an * entry will use the system heap. */ + #define TCL_HASH_KEY_RANDOMIZE_HASH 0x1 #define TCL_HASH_KEY_SYSTEM_HASH 0x2 /* - * Structure definition for the methods associated with a hash table - * key type. + * Structure definition for the methods associated with a hash table key type. */ + #define TCL_HASH_KEY_TYPE_VERSION 1 struct Tcl_HashKeyType { int version; /* Version of the table. If this structure is * extended in future then the version can be * used to distinguish between different - * structures. - */ - + * structures. */ int flags; /* Flags, see above for details. */ - - /* Calculates a hash value for the key. If this is NULL then the pointer - * itself is used as a hash value. - */ Tcl_HashKeyProc *hashKeyProc; - - /* Compares two keys and returns zero if they do not match, and non-zero - * if they do. If this is NULL then the pointers are compared. - */ + /* Calculates a hash value for the key. If + * this is NULL then the pointer itself is + * used as a hash value. */ Tcl_CompareHashKeysProc *compareKeysProc; - - /* Called to allocate memory for a new entry, i.e. if the key is a - * string then this could allocate a single block which contains enough - * space for both the entry and the string. Only the key field of the - * allocated Tcl_HashEntry structure needs to be filled in. If something - * else needs to be done to the key, i.e. incrementing a reference count - * then that should be done by this function. If this is NULL then Tcl_Alloc - * is used to allocate enough space for a Tcl_HashEntry and the key pointer - * is assigned to key.oneWordValue. - */ + /* Compares two keys and returns zero if they + * do not match, and non-zero if they do. If + * this is NULL then the pointers are + * compared. */ Tcl_AllocHashEntryProc *allocEntryProc; - - /* Called to free memory associated with an entry. If something else needs - * to be done to the key, i.e. decrementing a reference count then that - * should be done by this function. If this is NULL then Tcl_Free is used - * to free the Tcl_HashEntry. - */ + /* Called to allocate memory for a new entry, + * i.e. if the key is a string then this could + * allocate a single block which contains + * enough space for both the entry and the + * string. Only the key field of the allocated + * Tcl_HashEntry structure needs to be filled + * in. If something else needs to be done to + * the key, i.e. incrementing a reference + * count then that should be done by this + * function. If this is NULL then Tcl_Alloc is + * used to allocate enough space for a + * Tcl_HashEntry and the key pointer is + * assigned to key.oneWordValue. */ Tcl_FreeHashEntryProc *freeEntryProc; + /* Called to free memory associated with an + * entry. If something else needs to be done + * to the key, i.e. decrementing a reference + * count then that should be done by this + * function. If this is NULL then Tcl_Free is + * used to free the Tcl_HashEntry. */ }; /* - * Structure definition for a hash table. Must be in tcl.h so clients - * can allocate space for these structures, but clients should never - * access any fields in this structure. + * Structure definition for a hash table. Must be in tcl.h so clients can + * allocate space for these structures, but clients should never access any + * fields in this structure. */ #define TCL_SMALL_HASH_TABLE 4 struct Tcl_HashTable { - Tcl_HashEntry **buckets; /* Pointer to bucket array. Each - * element points to first entry in - * bucket's hash chain, or NULL. */ + Tcl_HashEntry **buckets; /* Pointer to bucket array. Each element + * points to first entry in bucket's hash + * chain, or NULL. */ Tcl_HashEntry *staticBuckets[TCL_SMALL_HASH_TABLE]; - /* Bucket array used for small tables - * (to avoid mallocs and frees). */ - int numBuckets; /* Total number of buckets allocated - * at **bucketPtr. */ - int numEntries; /* Total number of entries present - * in table. */ - int rebuildSize; /* Enlarge table when numEntries gets - * to be this large. */ - int downShift; /* Shift count used in hashing - * function. Designed to use high- - * order bits of randomized keys. */ - int mask; /* Mask value used in hashing - * function. */ - int keyType; /* Type of keys used in this table. - * It's either TCL_CUSTOM_KEYS, - * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, - * or an integer giving the number of - * ints that is the size of the key. - */ + /* Bucket array used for small tables (to + * avoid mallocs and frees). */ + int numBuckets; /* Total number of buckets allocated at + * **bucketPtr. */ + int numEntries; /* Total number of entries present in + * table. */ + int rebuildSize; /* Enlarge table when numEntries gets to be + * this large. */ + int downShift; /* Shift count used in hashing function. + * Designed to use high-order bits of + * randomized keys. */ + int mask; /* Mask value used in hashing function. */ + int keyType; /* Type of keys used in this table. It's + * either TCL_CUSTOM_KEYS, TCL_STRING_KEYS, + * TCL_ONE_WORD_KEYS, or an integer giving the + * number of ints that is the size of the + * key. */ #if TCL_PRESERVE_BINARY_COMPATABILITY Tcl_HashEntry *(*findProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr, CONST char *key)); Tcl_HashEntry *(*createProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr, CONST char *key, int *newPtr)); #endif - Tcl_HashKeyType *typePtr; /* Type of the keys used in the - * Tcl_HashTable. */ + Tcl_HashKeyType *typePtr; /* Type of the keys used in the + * Tcl_HashTable. */ }; /* - * Structure definition for information used to keep track of searches - * through hash tables: + * Structure definition for information used to keep track of searches through + * hash tables: */ typedef struct Tcl_HashSearch { - Tcl_HashTable *tablePtr; /* Table being searched. */ - int nextIndex; /* Index of next bucket to be - * enumerated after present one. */ - Tcl_HashEntry *nextEntryPtr; /* Next entry to be enumerated in the - * the current bucket. */ + Tcl_HashTable *tablePtr; /* Table being searched. */ + int nextIndex; /* Index of next bucket to be enumerated after + * present one. */ + Tcl_HashEntry *nextEntryPtr;/* Next entry to be enumerated in the current + * bucket. */ } Tcl_HashSearch; /* * Acceptable key types for hash tables: * - * TCL_STRING_KEYS: The keys are strings, they are copied into - * the entry. + * TCL_STRING_KEYS: The keys are strings, they are copied into the + * entry. * TCL_ONE_WORD_KEYS: The keys are pointers, the pointer is stored * in the entry. * TCL_CUSTOM_TYPE_KEYS: The keys are arbitrary types which are copied * into the entry. * TCL_CUSTOM_PTR_KEYS: The keys are pointers to arbitrary types, the * pointer is stored in the entry. * - * While maintaining binary compatability the above have to be distinct - * values as they are used to differentiate between old versions of the - * hash table which don't have a typePtr and new ones which do. Once binary - * compatability is discarded in favour of making more wide spread changes - * TCL_STRING_KEYS can be the same as TCL_CUSTOM_TYPE_KEYS, and - * TCL_ONE_WORD_KEYS can be the same as TCL_CUSTOM_PTR_KEYS because they - * simply determine how the key is accessed from the entry and not the - * behaviour. + * While maintaining binary compatability the above have to be distinct values + * as they are used to differentiate between old versions of the hash table + * which don't have a typePtr and new ones which do. Once binary compatability + * is discarded in favour of making more wide spread changes TCL_STRING_KEYS + * can be the same as TCL_CUSTOM_TYPE_KEYS, and TCL_ONE_WORD_KEYS can be the + * same as TCL_CUSTOM_PTR_KEYS because they simply determine how the key is + * accessed from the entry and not the behaviour. */ #define TCL_STRING_KEYS 0 #define TCL_ONE_WORD_KEYS 1 #if TCL_PRESERVE_BINARY_COMPATABILITY -# define TCL_CUSTOM_TYPE_KEYS -2 -# define TCL_CUSTOM_PTR_KEYS -1 +# define TCL_CUSTOM_TYPE_KEYS -2 +# define TCL_CUSTOM_PTR_KEYS -1 #else -# define TCL_CUSTOM_TYPE_KEYS TCL_STRING_KEYS -# define TCL_CUSTOM_PTR_KEYS TCL_ONE_WORD_KEYS +# define TCL_CUSTOM_TYPE_KEYS TCL_STRING_KEYS +# define TCL_CUSTOM_PTR_KEYS TCL_ONE_WORD_KEYS #endif /* * Macros for clients to use to access fields of hash entries: */ @@ -1316,12 +1336,12 @@ ? (h)->key.oneWordValue \ : (h)->key.string)) #endif /* - * Macros to use for clients to use to invoke find and create procedures - * for hash tables: + * Macros to use for clients to use to invoke find and create functions for + * hash tables: */ #if TCL_PRESERVE_BINARY_COMPATABILITY # define Tcl_FindHashEntry(tablePtr, key) \ (*((tablePtr)->findProc))(tablePtr, key) @@ -1334,118 +1354,140 @@ # define Tcl_InitHashTable(tablePtr, keyType) \ Tcl_InitHashTableEx(tablePtr, keyType, NULL) #endif /* TCL_PRESERVE_BINARY_COMPATABILITY */ /* - * Structure definition for information used to keep track of searches - * through dictionaries. These fields should not be accessed by code - * outside tclDictObj.c + * Structure definition for information used to keep track of searches through + * dictionaries. These fields should not be accessed by code outside + * tclDictObj.c */ typedef struct { Tcl_HashSearch search; /* Search struct for underlying hash table. */ int epoch; /* Epoch marker for dictionary being searched, * or -1 if search has terminated. */ Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */ } Tcl_DictSearch; - /* - * Flag values to pass to Tcl_DoOneEvent to disable searches - * for some kinds of events: + * Flag values to pass to Tcl_DoOneEvent to disable searches for some kinds of + * events: */ + #define TCL_DONT_WAIT (1<<1) #define TCL_WINDOW_EVENTS (1<<2) #define TCL_FILE_EVENTS (1<<3) #define TCL_TIMER_EVENTS (1<<4) #define TCL_IDLE_EVENTS (1<<5) /* WAS 0x10 ???? */ #define TCL_ALL_EVENTS (~TCL_DONT_WAIT) /* - * The following structure defines a generic event for the Tcl event - * system. These are the things that are queued in calls to Tcl_QueueEvent - * and serviced later by Tcl_DoOneEvent. There can be many different - * kinds of events with different fields, corresponding to window events, - * timer events, etc. The structure for a particular event consists of - * a Tcl_Event header followed by additional information specific to that - * event. + * The following structure defines a generic event for the Tcl event system. + * These are the things that are queued in calls to Tcl_QueueEvent and + * serviced later by Tcl_DoOneEvent. There can be many different kinds of + * events with different fields, corresponding to window events, timer events, + * etc. The structure for a particular event consists of a Tcl_Event header + * followed by additional information specific to that event. */ + struct Tcl_Event { - Tcl_EventProc *proc; /* Procedure to call to service this event. */ + Tcl_EventProc *proc; /* Function to call to service this event. */ struct Tcl_Event *nextPtr; /* Next in list of pending events, or NULL. */ }; /* * Positions to pass to Tcl_QueueEvent: */ + typedef enum { TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK } Tcl_QueuePosition; /* * Values to pass to Tcl_SetServiceMode to specify the behavior of notifier * event routines. */ + #define TCL_SERVICE_NONE 0 #define TCL_SERVICE_ALL 1 - /* - * The following structure keeps is used to hold a time value, either as - * an absolute time (the number of seconds from the epoch) or as an - * elapsed time. On Unix systems the epoch is Midnight Jan 1, 1970 GMT. + * The following structure keeps is used to hold a time value, either as an + * absolute time (the number of seconds from the epoch) or as an elapsed time. + * On Unix systems the epoch is Midnight Jan 1, 1970 GMT. */ + typedef struct Tcl_Time { long sec; /* Seconds. */ long usec; /* Microseconds. */ } Tcl_Time; typedef void (Tcl_SetTimerProc) _ANSI_ARGS_((Tcl_Time *timePtr)); typedef int (Tcl_WaitForEventProc) _ANSI_ARGS_((Tcl_Time *timePtr)); +/* + * TIP #233 (Virtualized Time) + */ + +typedef void (Tcl_GetTimeProc) _ANSI_ARGS_ ((Tcl_Time* timebuf, ClientData clientData)); +typedef void (Tcl_ScaleTimeProc) _ANSI_ARGS_ ((Tcl_Time* timebuf, ClientData clientData)); /* - * Bits to pass to Tcl_CreateFileHandler and Tcl_CreateChannelHandler - * to indicate what sorts of events are of interest: + * Bits to pass to Tcl_CreateFileHandler and Tcl_CreateChannelHandler to + * indicate what sorts of events are of interest: */ + #define TCL_READABLE (1<<1) #define TCL_WRITABLE (1<<2) #define TCL_EXCEPTION (1<<3) /* - * Flag values to pass to Tcl_OpenCommandChannel to indicate the - * disposition of the stdio handles. TCL_STDIN, TCL_STDOUT, TCL_STDERR, - * are also used in Tcl_GetStdChannel. + * Flag values to pass to Tcl_OpenCommandChannel to indicate the disposition + * of the stdio handles. TCL_STDIN, TCL_STDOUT, TCL_STDERR, are also used in + * Tcl_GetStdChannel. */ -#define TCL_STDIN (1<<1) + +#define TCL_STDIN (1<<1) #define TCL_STDOUT (1<<2) #define TCL_STDERR (1<<3) #define TCL_ENFORCE_MODE (1<<4) /* * Bits passed to Tcl_DriverClose2Proc to indicate which side of a channel * should be closed. */ + #define TCL_CLOSE_READ (1<<1) #define TCL_CLOSE_WRITE (1<<2) /* - * Value to use as the closeProc for a channel that supports the - * close2Proc interface. + * Value to use as the closeProc for a channel that supports the close2Proc + * interface. */ + #define TCL_CLOSE2PROC ((Tcl_DriverCloseProc *)1) /* - * Channel version tag. This was introduced in 8.3.2/8.4. + * Channel version tag. This was introduced in 8.3.2/8.4. */ + #define TCL_CHANNEL_VERSION_1 ((Tcl_ChannelTypeVersion) 0x1) #define TCL_CHANNEL_VERSION_2 ((Tcl_ChannelTypeVersion) 0x2) #define TCL_CHANNEL_VERSION_3 ((Tcl_ChannelTypeVersion) 0x3) +#define TCL_CHANNEL_VERSION_4 ((Tcl_ChannelTypeVersion) 0x4) + +/* + * TIP #218: Channel Actions, Ids for Tcl_DriverThreadActionProc + */ + +#define TCL_CHANNEL_THREAD_INSERT (0) +#define TCL_CHANNEL_THREAD_REMOVE (1) /* * Typedefs for the various operations in a channel type: */ + typedef int (Tcl_DriverBlockModeProc) _ANSI_ARGS_(( ClientData instanceData, int mode)); typedef int (Tcl_DriverCloseProc) _ANSI_ARGS_((ClientData instanceData, Tcl_Interp *interp)); typedef int (Tcl_DriverClose2Proc) _ANSI_ARGS_((ClientData instanceData, @@ -1456,48 +1498,58 @@ CONST84 char *buf, int toWrite, int *errorCodePtr)); typedef int (Tcl_DriverSeekProc) _ANSI_ARGS_((ClientData instanceData, long offset, int mode, int *errorCodePtr)); typedef int (Tcl_DriverSetOptionProc) _ANSI_ARGS_(( ClientData instanceData, Tcl_Interp *interp, - CONST char *optionName, CONST char *value)); + CONST char *optionName, CONST char *value)); typedef int (Tcl_DriverGetOptionProc) _ANSI_ARGS_(( ClientData instanceData, Tcl_Interp *interp, CONST84 char *optionName, Tcl_DString *dsPtr)); typedef void (Tcl_DriverWatchProc) _ANSI_ARGS_(( ClientData instanceData, int mask)); typedef int (Tcl_DriverGetHandleProc) _ANSI_ARGS_(( ClientData instanceData, int direction, ClientData *handlePtr)); -typedef int (Tcl_DriverFlushProc) _ANSI_ARGS_(( - ClientData instanceData)); +typedef int (Tcl_DriverFlushProc) _ANSI_ARGS_((ClientData instanceData)); typedef int (Tcl_DriverHandlerProc) _ANSI_ARGS_(( ClientData instanceData, int interestMask)); typedef Tcl_WideInt (Tcl_DriverWideSeekProc) _ANSI_ARGS_(( ClientData instanceData, Tcl_WideInt offset, int mode, int *errorCodePtr)); - +/* + * TIP #218, Channel Thread Actions + */ +typedef void (Tcl_DriverThreadActionProc) _ANSI_ARGS_ (( + ClientData instanceData, int action)); +/* + * TIP #208, File Truncation (etc.) + */ +typedef int (Tcl_DriverTruncateProc) _ANSI_ARGS_(( + ClientData instanceData, Tcl_WideInt length)); /* - * The following declarations either map ckalloc and ckfree to - * malloc and free, or they map them to procedures with all sorts - * of debugging hooks defined in tclCkalloc.c. + * The following declarations either map ckalloc and ckfree to malloc and + * free, or they map them to functions with all sorts of debugging hooks + * defined in tclCkalloc.c. */ + #ifdef TCL_MEM_DEBUG # define ckalloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__) # define ckfree(x) Tcl_DbCkfree(x, __FILE__, __LINE__) # define ckrealloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__) # define attemptckalloc(x) Tcl_AttemptDbCkalloc(x, __FILE__, __LINE__) # define attemptckrealloc(x,y) Tcl_AttemptDbCkrealloc((x), (y), __FILE__, __LINE__) + #else /* !TCL_MEM_DEBUG */ /* - * If we are not using the debugging allocator, we should call the - * Tcl_Alloc, et al. routines in order to guarantee that every module - * is using the same memory allocator both inside and outside of the - * Tcl library. + * If we are not using the debugging allocator, we should call the Tcl_Alloc, + * et al. routines in order to guarantee that every module is using the same + * memory allocator both inside and outside of the Tcl library. */ + # define ckalloc(x) Tcl_Alloc(x) # define ckfree(x) Tcl_Free(x) # define ckrealloc(x,y) Tcl_Realloc(x,y) # define attemptckalloc(x) Tcl_AttemptAlloc(x) # define attemptckrealloc(x,y) Tcl_AttemptRealloc(x,y) @@ -1508,104 +1560,121 @@ #endif /* !TCL_MEM_DEBUG */ /* * struct Tcl_ChannelType: * - * One such structure exists for each type (kind) of channel. - * It collects together in one place all the functions that are - * part of the specific channel type. + * One such structure exists for each type (kind) of channel. It collects + * together in one place all the functions that are part of the specific + * channel type. * - * It is recommend that the Tcl_Channel* functions are used to access - * elements of this structure, instead of direct accessing. + * It is recommend that the Tcl_Channel* functions are used to access elements + * of this structure, instead of direct accessing. */ + typedef struct Tcl_ChannelType { - char *typeName; /* The name of the channel type in Tcl - * commands. This storage is owned by - * channel type. */ - Tcl_ChannelTypeVersion version; /* Version of the channel type. */ - Tcl_DriverCloseProc *closeProc; /* Procedure to call to close the - * channel, or TCL_CLOSE2PROC if the - * close2Proc should be used - * instead. */ - Tcl_DriverInputProc *inputProc; /* Procedure to call for input - * on channel. */ - Tcl_DriverOutputProc *outputProc; /* Procedure to call for output - * on channel. */ - Tcl_DriverSeekProc *seekProc; /* Procedure to call to seek - * on the channel. May be NULL. */ + char *typeName; /* The name of the channel type in Tcl + * commands. This storage is owned by channel + * type. */ + Tcl_ChannelTypeVersion version; + /* Version of the channel type. */ + Tcl_DriverCloseProc *closeProc; + /* Function to call to close the channel, or + * TCL_CLOSE2PROC if the close2Proc should be + * used instead. */ + Tcl_DriverInputProc *inputProc; + /* Function to call for input on channel. */ + Tcl_DriverOutputProc *outputProc; + /* Function to call for output on channel. */ + Tcl_DriverSeekProc *seekProc; + /* Function to call to seek on the channel. + * May be NULL. */ Tcl_DriverSetOptionProc *setOptionProc; - /* Set an option on a channel. */ + /* Set an option on a channel. */ Tcl_DriverGetOptionProc *getOptionProc; - /* Get an option from a channel. */ - Tcl_DriverWatchProc *watchProc; /* Set up the notifier to watch - * for events on this channel. */ + /* Get an option from a channel. */ + Tcl_DriverWatchProc *watchProc; + /* Set up the notifier to watch for events on + * this channel. */ Tcl_DriverGetHandleProc *getHandleProc; - /* Get an OS handle from the channel - * or NULL if not supported. */ - Tcl_DriverClose2Proc *close2Proc; /* Procedure to call to close the - * channel if the device supports - * closing the read & write sides - * independently. */ + /* Get an OS handle from the channel or NULL + * if not supported. */ + Tcl_DriverClose2Proc *close2Proc; + /* Function to call to close the channel if + * the device supports closing the read & + * write sides independently. */ Tcl_DriverBlockModeProc *blockModeProc; - /* Set blocking mode for the - * raw channel. May be NULL. */ + /* Set blocking mode for the raw channel. May + * be NULL. */ /* * Only valid in TCL_CHANNEL_VERSION_2 channels or later */ - Tcl_DriverFlushProc *flushProc; /* Procedure to call to flush a - * channel. May be NULL. */ - Tcl_DriverHandlerProc *handlerProc; /* Procedure to call to handle a - * channel event. This will be passed - * up the stacked channel chain. */ + Tcl_DriverFlushProc *flushProc; + /* Function to call to flush a channel. May be + * NULL. */ + Tcl_DriverHandlerProc *handlerProc; + /* Function to call to handle a channel event. + * This will be passed up the stacked channel + * chain. */ /* * Only valid in TCL_CHANNEL_VERSION_3 channels or later */ Tcl_DriverWideSeekProc *wideSeekProc; - /* Procedure to call to seek - * on the channel which can - * handle 64-bit offsets. May be - * NULL, and must be NULL if - * seekProc is NULL. */ + /* Function to call to seek on the channel + * which can handle 64-bit offsets. May be + * NULL, and must be NULL if seekProc is + * NULL. */ + /* + * Only valid in TCL_CHANNEL_VERSION_4 channels or later + * TIP #218, Channel Thread Actions + * TIP #208 (part relating to truncation) + */ + Tcl_DriverThreadActionProc *threadActionProc; + /* Function to call to notify the driver of + * thread specific activity for a channel. May + * be NULL. */ + Tcl_DriverTruncateProc *truncateProc; + /* Function to call to truncate the underlying + * file to a particular length. May be NULL if + * the channel does not support truncation. */ } Tcl_ChannelType; /* - * The following flags determine whether the blockModeProc above should - * set the channel into blocking or nonblocking mode. They are passed - * as arguments to the blockModeProc procedure in the above structure. + * The following flags determine whether the blockModeProc above should set + * the channel into blocking or nonblocking mode. They are passed as arguments + * to the blockModeProc function in the above structure. */ + #define TCL_MODE_BLOCKING 0 /* Put channel into blocking mode. */ #define TCL_MODE_NONBLOCKING 1 /* Put channel into nonblocking * mode. */ /* * Enum for different types of file paths. */ + typedef enum Tcl_PathType { TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, TCL_PATH_VOLUME_RELATIVE } Tcl_PathType; - -/* - * The following structure is used to pass glob type data amongst - * the various glob routines and Tcl_FSMatchInDirectory. +/* + * The following structure is used to pass glob type data amongst the various + * glob routines and Tcl_FSMatchInDirectory. */ + typedef struct Tcl_GlobTypeData { - /* Corresponds to bcdpfls as in 'find -t' */ - int type; - /* Corresponds to file permissions */ - int perm; - /* Acceptable mac type */ - Tcl_Obj* macType; - /* Acceptable mac creator */ - Tcl_Obj* macCreator; + int type; /* Corresponds to bcdpfls as in 'find -t' */ + int perm; /* Corresponds to file permissions */ + Tcl_Obj *macType; /* Acceptable mac type */ + Tcl_Obj *macCreator; /* Acceptable mac creator */ } Tcl_GlobTypeData; /* - * type and permission definitions for glob command + * Type and permission definitions for glob command */ + #define TCL_GLOB_TYPE_BLOCK (1<<0) #define TCL_GLOB_TYPE_CHAR (1<<1) #define TCL_GLOB_TYPE_DIR (1<<2) #define TCL_GLOB_TYPE_PIPE (1<<3) #define TCL_GLOB_TYPE_FILE (1<<4) @@ -1618,74 +1687,73 @@ #define TCL_GLOB_PERM_R (1<<2) #define TCL_GLOB_PERM_W (1<<3) #define TCL_GLOB_PERM_X (1<<4) /* - * Flags for the unload callback procedure + * Flags for the unload callback function */ -#define TCL_UNLOAD_DETACH_FROM_INTERPRETER (1<<0) -#define TCL_UNLOAD_DETACH_FROM_PROCESS (1<<1) + +#define TCL_UNLOAD_DETACH_FROM_INTERPRETER (1<<0) +#define TCL_UNLOAD_DETACH_FROM_PROCESS (1<<1) /* * Typedefs for the various filesystem operations: */ + typedef int (Tcl_FSStatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *buf)); typedef int (Tcl_FSAccessProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, int mode)); -typedef Tcl_Channel (Tcl_FSOpenFileChannelProc) - _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr, - int mode, int permissions)); -typedef int (Tcl_FSMatchInDirectoryProc) _ANSI_ARGS_((Tcl_Interp* interp, - Tcl_Obj *result, Tcl_Obj *pathPtr, CONST char *pattern, +typedef Tcl_Channel (Tcl_FSOpenFileChannelProc) _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode, int permissions)); +typedef int (Tcl_FSMatchInDirectoryProc) _ANSI_ARGS_((Tcl_Interp* interp, + Tcl_Obj *result, Tcl_Obj *pathPtr, CONST char *pattern, Tcl_GlobTypeData * types)); typedef Tcl_Obj* (Tcl_FSGetCwdProc) _ANSI_ARGS_((Tcl_Interp *interp)); typedef int (Tcl_FSChdirProc) _ANSI_ARGS_((Tcl_Obj *pathPtr)); -typedef int (Tcl_FSLstatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, - Tcl_StatBuf *buf)); +typedef int (Tcl_FSLstatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, + Tcl_StatBuf *buf)); typedef int (Tcl_FSCreateDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr)); typedef int (Tcl_FSDeleteFileProc) _ANSI_ARGS_((Tcl_Obj *pathPtr)); typedef int (Tcl_FSCopyDirectoryProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr, - Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr)); + Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr)); typedef int (Tcl_FSCopyFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr, - Tcl_Obj *destPathPtr)); + Tcl_Obj *destPathPtr)); typedef int (Tcl_FSRemoveDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, - int recursive, Tcl_Obj **errorPtr)); + int recursive, Tcl_Obj **errorPtr)); typedef int (Tcl_FSRenameFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr, - Tcl_Obj *destPathPtr)); + Tcl_Obj *destPathPtr)); typedef void (Tcl_FSUnloadFileProc) _ANSI_ARGS_((Tcl_LoadHandle loadHandle)); typedef Tcl_Obj* (Tcl_FSListVolumesProc) _ANSI_ARGS_((void)); /* We have to declare the utime structure here. */ struct utimbuf; -typedef int (Tcl_FSUtimeProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, - struct utimbuf *tval)); -typedef int (Tcl_FSNormalizePathProc) _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *pathPtr, int nextCheckpoint)); +typedef int (Tcl_FSUtimeProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, + struct utimbuf *tval)); +typedef int (Tcl_FSNormalizePathProc) _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *pathPtr, int nextCheckpoint)); typedef int (Tcl_FSFileAttrsGetProc) _ANSI_ARGS_((Tcl_Interp *interp, - int index, Tcl_Obj *pathPtr, - Tcl_Obj **objPtrRef)); -typedef CONST char** (Tcl_FSFileAttrStringsProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, - Tcl_Obj** objPtrRef)); + int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef)); +typedef CONST char** (Tcl_FSFileAttrStringsProc) _ANSI_ARGS_(( + Tcl_Obj *pathPtr, Tcl_Obj** objPtrRef)); typedef int (Tcl_FSFileAttrsSetProc) _ANSI_ARGS_((Tcl_Interp *interp, - int index, Tcl_Obj *pathPtr, - Tcl_Obj *objPtr)); -typedef Tcl_Obj* (Tcl_FSLinkProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, - Tcl_Obj *toPtr, int linkType)); -typedef int (Tcl_FSLoadFileProc) _ANSI_ARGS_((Tcl_Interp * interp, - Tcl_Obj *pathPtr, - Tcl_LoadHandle *handlePtr, - Tcl_FSUnloadFileProc **unloadProcPtr)); -typedef int (Tcl_FSPathInFilesystemProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, - ClientData *clientDataPtr)); -typedef Tcl_Obj* (Tcl_FSFilesystemPathTypeProc) - _ANSI_ARGS_((Tcl_Obj *pathPtr)); -typedef Tcl_Obj* (Tcl_FSFilesystemSeparatorProc) - _ANSI_ARGS_((Tcl_Obj *pathPtr)); + int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr)); +typedef Tcl_Obj* (Tcl_FSLinkProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, + Tcl_Obj *toPtr, int linkType)); +typedef int (Tcl_FSLoadFileProc) _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_Obj *pathPtr, Tcl_LoadHandle *handlePtr, + Tcl_FSUnloadFileProc **unloadProcPtr)); +typedef int (Tcl_FSPathInFilesystemProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, + ClientData *clientDataPtr)); +typedef Tcl_Obj* (Tcl_FSFilesystemPathTypeProc) _ANSI_ARGS_(( + Tcl_Obj *pathPtr)); +typedef Tcl_Obj* (Tcl_FSFilesystemSeparatorProc) _ANSI_ARGS_(( + Tcl_Obj *pathPtr)); typedef void (Tcl_FSFreeInternalRepProc) _ANSI_ARGS_((ClientData clientData)); -typedef ClientData (Tcl_FSDupInternalRepProc) - _ANSI_ARGS_((ClientData clientData)); -typedef Tcl_Obj* (Tcl_FSInternalToNormalizedProc) - _ANSI_ARGS_((ClientData clientData)); -typedef ClientData (Tcl_FSCreateInternalRepProc) _ANSI_ARGS_((Tcl_Obj *pathPtr)); +typedef ClientData (Tcl_FSDupInternalRepProc) _ANSI_ARGS_(( + ClientData clientData)); +typedef Tcl_Obj* (Tcl_FSInternalToNormalizedProc) _ANSI_ARGS_(( + ClientData clientData)); +typedef ClientData (Tcl_FSCreateInternalRepProc) _ANSI_ARGS_(( + Tcl_Obj *pathPtr)); typedef struct Tcl_FSVersion_ *Tcl_FSVersion; /* *---------------------------------------------------------------- @@ -1699,211 +1767,187 @@ #define TCL_FILESYSTEM_VERSION_1 ((Tcl_FSVersion) 0x1) /* * struct Tcl_Filesystem: * - * One such structure exists for each type (kind) of filesystem. - * It collects together in one place all the functions that are - * part of the specific filesystem. Tcl always accesses the - * filesystem through one of these structures. - * - * Not all entries need be non-NULL; any which are NULL are simply - * ignored. However, a complete filesystem should provide all of - * these functions. The explanations in the structure show - * the importance of each function. + * One such structure exists for each type (kind) of filesystem. It collects + * together in one place all the functions that are part of the specific + * filesystem. Tcl always accesses the filesystem through one of these + * structures. + * + * Not all entries need be non-NULL; any which are NULL are simply ignored. + * However, a complete filesystem should provide all of these functions. The + * explanations in the structure show the importance of each function. */ typedef struct Tcl_Filesystem { - CONST char *typeName; /* The name of the filesystem. */ - int structureLength; /* Length of this structure, so future - * binary compatibility can be assured. */ - Tcl_FSVersion version; - /* Version of the filesystem type. */ + CONST char *typeName; /* The name of the filesystem. */ + int structureLength; /* Length of this structure, so future binary + * compatibility can be assured. */ + Tcl_FSVersion version; /* Version of the filesystem type. */ Tcl_FSPathInFilesystemProc *pathInFilesystemProc; - /* Function to check whether a path is in - * this filesystem. This is the most - * important filesystem procedure. */ + /* Function to check whether a path is in this + * filesystem. This is the most important + * filesystem function. */ Tcl_FSDupInternalRepProc *dupInternalRepProc; - /* Function to duplicate internal fs rep. May - * be NULL (but then fs is less efficient). */ + /* Function to duplicate internal fs rep. May + * be NULL (but then fs is less efficient). */ Tcl_FSFreeInternalRepProc *freeInternalRepProc; - /* Function to free internal fs rep. Must - * be implemented, if internal representations - * need freeing, otherwise it can be NULL. */ + /* Function to free internal fs rep. Must be + * implemented if internal representations + * need freeing, otherwise it can be NULL. */ Tcl_FSInternalToNormalizedProc *internalToNormalizedProc; - /* Function to convert internal representation - * to a normalized path. Only required if - * the fs creates pure path objects with no - * string/path representation. */ + /* Function to convert internal representation + * to a normalized path. Only required if the + * fs creates pure path objects with no + * string/path representation. */ Tcl_FSCreateInternalRepProc *createInternalRepProc; - /* Function to create a filesystem-specific - * internal representation. May be NULL - * if paths have no internal representation, - * or if the Tcl_FSPathInFilesystemProc - * for this filesystem always immediately - * creates an internal representation for - * paths it accepts. */ - Tcl_FSNormalizePathProc *normalizePathProc; - /* Function to normalize a path. Should - * be implemented for all filesystems - * which can have multiple string - * representations for the same path - * object. */ + /* Function to create a filesystem-specific + * internal representation. May be NULL if + * paths have no internal representation, or + * if the Tcl_FSPathInFilesystemProc for this + * filesystem always immediately creates an + * internal representation for paths it + * accepts. */ + Tcl_FSNormalizePathProc *normalizePathProc; + /* Function to normalize a path. Should be + * implemented for all filesystems which can + * have multiple string representations for + * the same path object. */ Tcl_FSFilesystemPathTypeProc *filesystemPathTypeProc; - /* Function to determine the type of a - * path in this filesystem. May be NULL. */ + /* Function to determine the type of a path in + * this filesystem. May be NULL. */ Tcl_FSFilesystemSeparatorProc *filesystemSeparatorProc; - /* Function to return the separator - * character(s) for this filesystem. Must - * be implemented. */ - Tcl_FSStatProc *statProc; - /* - * Function to process a 'Tcl_FSStat()' - * call. Must be implemented for any - * reasonable filesystem. - */ - Tcl_FSAccessProc *accessProc; - /* - * Function to process a 'Tcl_FSAccess()' - * call. Must be implemented for any - * reasonable filesystem. - */ - Tcl_FSOpenFileChannelProc *openFileChannelProc; - /* - * Function to process a - * 'Tcl_FSOpenFileChannel()' call. Must be - * implemented for any reasonable - * filesystem. - */ - Tcl_FSMatchInDirectoryProc *matchInDirectoryProc; - /* Function to process a - * 'Tcl_FSMatchInDirectory()'. If not - * implemented, then glob and recursive - * copy functionality will be lacking in - * the filesystem. */ - Tcl_FSUtimeProc *utimeProc; - /* Function to process a - * 'Tcl_FSUtime()' call. Required to - * allow setting (not reading) of times - * with 'file mtime', 'file atime' and - * the open-r/open-w/fcopy implementation - * of 'file copy'. */ - Tcl_FSLinkProc *linkProc; - /* Function to process a - * 'Tcl_FSLink()' call. Should be - * implemented only if the filesystem supports - * links (reading or creating). */ + /* Function to return the separator + * character(s) for this filesystem. Must be + * implemented. */ + Tcl_FSStatProc *statProc; /* Function to process a 'Tcl_FSStat()' call. + * Must be implemented for any reasonable + * filesystem. */ + Tcl_FSAccessProc *accessProc; + /* Function to process a 'Tcl_FSAccess()' + * call. Must be implemented for any + * reasonable filesystem. */ + Tcl_FSOpenFileChannelProc *openFileChannelProc; + /* Function to process a + * 'Tcl_FSOpenFileChannel()' call. Must be + * implemented for any reasonable + * filesystem. */ + Tcl_FSMatchInDirectoryProc *matchInDirectoryProc; + /* Function to process a + * 'Tcl_FSMatchInDirectory()'. If not + * implemented, then glob and recursive copy + * functionality will be lacking in the + * filesystem. */ + Tcl_FSUtimeProc *utimeProc; /* Function to process a 'Tcl_FSUtime()' call. + * Required to allow setting (not reading) of + * times with 'file mtime', 'file atime' and + * the open-r/open-w/fcopy implementation of + * 'file copy'. */ + Tcl_FSLinkProc *linkProc; /* Function to process a 'Tcl_FSLink()' call. + * Should be implemented only if the + * filesystem supports links (reading or + * creating). */ Tcl_FSListVolumesProc *listVolumesProc; - /* Function to list any filesystem volumes - * added by this filesystem. Should be - * implemented only if the filesystem adds - * volumes at the head of the filesystem. */ + /* Function to list any filesystem volumes + * added by this filesystem. Should be + * implemented only if the filesystem adds + * volumes at the head of the filesystem. */ Tcl_FSFileAttrStringsProc *fileAttrStringsProc; - /* Function to list all attributes strings - * which are valid for this filesystem. - * If not implemented the filesystem will - * not support the 'file attributes' command. - * This allows arbitrary additional information - * to be attached to files in the filesystem. */ + /* Function to list all attributes strings + * which are valid for this filesystem. If not + * implemented the filesystem will not support + * the 'file attributes' command. This allows + * arbitrary additional information to be + * attached to files in the filesystem. */ Tcl_FSFileAttrsGetProc *fileAttrsGetProc; - /* Function to process a - * 'Tcl_FSFileAttrsGet()' call, used by - * 'file attributes'. */ + /* Function to process a + * 'Tcl_FSFileAttrsGet()' call, used by 'file + * attributes'. */ Tcl_FSFileAttrsSetProc *fileAttrsSetProc; - /* Function to process a - * 'Tcl_FSFileAttrsSet()' call, used by - * 'file attributes'. */ - Tcl_FSCreateDirectoryProc *createDirectoryProc; - /* Function to process a - * 'Tcl_FSCreateDirectory()' call. Should - * be implemented unless the FS is - * read-only. */ - Tcl_FSRemoveDirectoryProc *removeDirectoryProc; - /* Function to process a - * 'Tcl_FSRemoveDirectory()' call. Should - * be implemented unless the FS is - * read-only. */ - Tcl_FSDeleteFileProc *deleteFileProc; - /* Function to process a - * 'Tcl_FSDeleteFile()' call. Should - * be implemented unless the FS is - * read-only. */ - Tcl_FSCopyFileProc *copyFileProc; - /* Function to process a - * 'Tcl_FSCopyFile()' call. If not - * implemented Tcl will fall back - * on open-r, open-w and fcopy as - * a copying mechanism, for copying - * actions initiated in Tcl (not C). */ - Tcl_FSRenameFileProc *renameFileProc; - /* Function to process a - * 'Tcl_FSRenameFile()' call. If not - * implemented, Tcl will fall back on - * a copy and delete mechanism, for - * rename actions initiated in Tcl (not C). */ - Tcl_FSCopyDirectoryProc *copyDirectoryProc; - /* Function to process a - * 'Tcl_FSCopyDirectory()' call. If - * not implemented, Tcl will fall back - * on a recursive create-dir, file copy - * mechanism, for copying actions - * initiated in Tcl (not C). */ - Tcl_FSLstatProc *lstatProc; - /* Function to process a - * 'Tcl_FSLstat()' call. If not implemented, - * Tcl will attempt to use the 'statProc' - * defined above instead. */ - Tcl_FSLoadFileProc *loadFileProc; - /* Function to process a - * 'Tcl_FSLoadFile()' call. If not - * implemented, Tcl will fall back on - * a copy to native-temp followed by a - * Tcl_FSLoadFile on that temporary copy. */ - Tcl_FSGetCwdProc *getCwdProc; - /* - * Function to process a 'Tcl_FSGetCwd()' - * call. Most filesystems need not - * implement this. It will usually only be - * called once, if 'getcwd' is called - * before 'chdir'. May be NULL. - */ - Tcl_FSChdirProc *chdirProc; - /* - * Function to process a 'Tcl_FSChdir()' - * call. If filesystems do not implement - * this, it will be emulated by a series of - * directory access checks. Otherwise, - * virtual filesystems which do implement - * it need only respond with a positive - * return result if the dirName is a valid - * directory in their filesystem. They - * need not remember the result, since that - * will be automatically remembered for use - * by GetCwd. Real filesystems should - * carry out the correct action (i.e. call - * the correct system 'chdir' api). If not - * implemented, then 'cd' and 'pwd' will - * fail inside the filesystem. - */ + /* Function to process a + * 'Tcl_FSFileAttrsSet()' call, used by 'file + * attributes'. */ + Tcl_FSCreateDirectoryProc *createDirectoryProc; + /* Function to process a + * 'Tcl_FSCreateDirectory()' call. Should be + * implemented unless the FS is read-only. */ + Tcl_FSRemoveDirectoryProc *removeDirectoryProc; + /* Function to process a + * 'Tcl_FSRemoveDirectory()' call. Should be + * implemented unless the FS is read-only. */ + Tcl_FSDeleteFileProc *deleteFileProc; + /* Function to process a 'Tcl_FSDeleteFile()' + * call. Should be implemented unless the FS + * is read-only. */ + Tcl_FSCopyFileProc *copyFileProc; + /* Function to process a 'Tcl_FSCopyFile()' + * call. If not implemented Tcl will fall back + * on open-r, open-w and fcopy as a copying + * mechanism, for copying actions initiated in + * Tcl (not C). */ + Tcl_FSRenameFileProc *renameFileProc; + /* Function to process a 'Tcl_FSRenameFile()' + * call. If not implemented, Tcl will fall + * back on a copy and delete mechanism, for + * rename actions initiated in Tcl (not C). */ + Tcl_FSCopyDirectoryProc *copyDirectoryProc; + /* Function to process a + * 'Tcl_FSCopyDirectory()' call. If not + * implemented, Tcl will fall back on a + * recursive create-dir, file copy mechanism, + * for copying actions initiated in Tcl (not + * C). */ + Tcl_FSLstatProc *lstatProc; /* Function to process a 'Tcl_FSLstat()' call. + * If not implemented, Tcl will attempt to use + * the 'statProc' defined above instead. */ + Tcl_FSLoadFileProc *loadFileProc; + /* Function to process a 'Tcl_FSLoadFile()' + * call. If not implemented, Tcl will fall + * back on a copy to native-temp followed by a + * Tcl_FSLoadFile on that temporary copy. */ + Tcl_FSGetCwdProc *getCwdProc; + /* Function to process a 'Tcl_FSGetCwd()' + * call. Most filesystems need not implement + * this. It will usually only be called once, + * if 'getcwd' is called before 'chdir'. May + * be NULL. */ + Tcl_FSChdirProc *chdirProc; /* Function to process a 'Tcl_FSChdir()' call. + * If filesystems do not implement this, it + * will be emulated by a series of directory + * access checks. Otherwise, virtual + * filesystems which do implement it need only + * respond with a positive return result if + * the dirName is a valid directory in their + * filesystem. They need not remember the + * result, since that will be automatically + * remembered for use by GetCwd. Real + * filesystems should carry out the correct + * action (i.e. call the correct system + * 'chdir' api). If not implemented, then 'cd' + * and 'pwd' will fail inside the + * filesystem. */ } Tcl_Filesystem; /* - * The following definitions are used as values for the 'linkAction' flag - * to Tcl_FSLink, or the linkProc of any filesystem. Any combination - * of flags can be given. For link creation, the linkProc should create - * a link which matches any of the types given. - * - * TCL_CREATE_SYMBOLIC_LINK: Create a symbolic or soft link. - * TCL_CREATE_HARD_LINK: Create a hard link. + * The following definitions are used as values for the 'linkAction' flag to + * Tcl_FSLink, or the linkProc of any filesystem. Any combination of flags can + * be given. For link creation, the linkProc should create a link which + * matches any of the types given. + * + * TCL_CREATE_SYMBOLIC_LINK - Create a symbolic or soft link. + * TCL_CREATE_HARD_LINK - Create a hard link. */ -#define TCL_CREATE_SYMBOLIC_LINK 0x01 -#define TCL_CREATE_HARD_LINK 0x02 + +#define TCL_CREATE_SYMBOLIC_LINK 0x01 +#define TCL_CREATE_HARD_LINK 0x02 /* - * The following structure represents the Notifier functions that - * you can override with the Tcl_SetNotifier call. + * The following structure represents the Notifier functions that you can + * override with the Tcl_SetNotifier call. */ + typedef struct Tcl_NotifierProcs { Tcl_SetTimerProc *setTimerProc; Tcl_WaitForEventProc *waitForEventProc; Tcl_CreateFileHandlerProc *createFileHandlerProc; Tcl_DeleteFileHandlerProc *deleteFileHandlerProc; @@ -1911,173 +1955,164 @@ Tcl_FinalizeNotifierProc *finalizeNotifierProc; Tcl_AlertNotifierProc *alertNotifierProc; Tcl_ServiceModeHookProc *serviceModeHookProc; } Tcl_NotifierProcs; - /* - * The following structure represents a user-defined encoding. It collects + * The following structure represents a user-defined encoding. It collects * together all the functions that are used by the specific encoding. */ + typedef struct Tcl_EncodingType { - CONST char *encodingName; /* The name of the encoding, e.g. "euc-jp". + CONST char *encodingName; /* The name of the encoding, e.g. "euc-jp". * This name is the unique key for this * encoding type. */ Tcl_EncodingConvertProc *toUtfProc; - /* Procedure to convert from external - * encoding into UTF-8. */ + /* Function to convert from external encoding + * into UTF-8. */ Tcl_EncodingConvertProc *fromUtfProc; - /* Procedure to convert from UTF-8 into + /* Function to convert from UTF-8 into * external encoding. */ Tcl_EncodingFreeProc *freeProc; - /* If non-NULL, procedure to call when this + /* If non-NULL, function to call when this * encoding is deleted. */ ClientData clientData; /* Arbitrary value associated with encoding - * type. Passed to conversion procedures. */ + * type. Passed to conversion functions. */ int nullSize; /* Number of zero bytes that signify - * end-of-string in this encoding. This - * number is used to determine the source - * string length when the srcLen argument is - * negative. Must be 1 or 2. */ -} Tcl_EncodingType; + * end-of-string in this encoding. This number + * is used to determine the source string + * length when the srcLen argument is + * negative. Must be 1 or 2. */ +} Tcl_EncodingType; /* * The following definitions are used as values for the conversion control * flags argument when converting text from one character set to another: * - * TCL_ENCODING_START: Signifies that the source buffer is the first + * TCL_ENCODING_START - Signifies that the source buffer is the first * block in a (potentially multi-block) input - * stream. Tells the conversion procedure to - * reset to an initial state and perform any + * stream. Tells the conversion function to reset + * to an initial state and perform any * initialization that needs to occur before the - * first byte is converted. If the source - * buffer contains the entire input stream to be + * first byte is converted. If the source buffer + * contains the entire input stream to be * converted, this flag should be set. - * - * TCL_ENCODING_END: Signifies that the source buffer is the last + * TCL_ENCODING_END - Signifies that the source buffer is the last * block in a (potentially multi-block) input - * stream. Tells the conversion routine to + * stream. Tells the conversion routine to * perform any finalization that needs to occur * after the last byte is converted and then to - * reset to an initial state. If the source + * reset to an initial state. If the source * buffer contains the entire input stream to be * converted, this flag should be set. - * - * TCL_ENCODING_STOPONERROR: If set, then the converter will return - * immediately upon encountering an invalid - * byte sequence or a source character that has - * no mapping in the target encoding. If clear, - * then the converter will skip the problem, - * substituting one or more "close" characters - * in the destination buffer and then continue - * to sonvert the source. + * TCL_ENCODING_STOPONERROR - If set, then the converter will return + * immediately upon encountering an invalid byte + * sequence or a source character that has no + * mapping in the target encoding. If clear, then + * the converter will skip the problem, + * substituting one or more "close" characters in + * the destination buffer and then continue to + * convert the source. */ + #define TCL_ENCODING_START 0x01 #define TCL_ENCODING_END 0x02 #define TCL_ENCODING_STOPONERROR 0x04 - /* - * The following data structures and declarations are for the new Tcl - * parser. + * The following data structures and declarations are for the new Tcl parser. */ /* - * For each word of a command, and for each piece of a word such as a - * variable reference, one of the following structures is created to - * describe the token. + * For each word of a command, and for each piece of a word such as a variable + * reference, one of the following structures is created to describe the + * token. */ + typedef struct Tcl_Token { - int type; /* Type of token, such as TCL_TOKEN_WORD; - * see below for valid types. */ + int type; /* Type of token, such as TCL_TOKEN_WORD; see + * below for valid types. */ CONST char *start; /* First character in token. */ int size; /* Number of bytes in token. */ - int numComponents; /* If this token is composed of other - * tokens, this field tells how many of - * them there are (including components of - * components, etc.). The component tokens - * immediately follow this one. */ + int numComponents; /* If this token is composed of other tokens, + * this field tells how many of them there are + * (including components of components, etc.). + * The component tokens immediately follow + * this one. */ } Tcl_Token; /* - * Type values defined for Tcl_Token structures. These values are - * defined as mask bits so that it's easy to check for collections of - * types. + * Type values defined for Tcl_Token structures. These values are defined as + * mask bits so that it's easy to check for collections of types. * * TCL_TOKEN_WORD - The token describes one word of a command, - * from the first non-blank character of - * the word (which may be " or {) up to but - * not including the space, semicolon, or - * bracket that terminates the word. - * NumComponents counts the total number of - * sub-tokens that make up the word. This - * includes, for example, sub-tokens of - * TCL_TOKEN_VARIABLE tokens. - * TCL_TOKEN_SIMPLE_WORD - This token is just like TCL_TOKEN_WORD - * except that the word is guaranteed to - * consist of a single TCL_TOKEN_TEXT - * sub-token. - * TCL_TOKEN_TEXT - The token describes a range of literal - * text that is part of a word. - * NumComponents is always 0. - * TCL_TOKEN_BS - The token describes a backslash sequence - * that must be collapsed. NumComponents + * from the first non-blank character of the word + * (which may be " or {) up to but not including + * the space, semicolon, or bracket that + * terminates the word. NumComponents counts the + * total number of sub-tokens that make up the + * word. This includes, for example, sub-tokens + * of TCL_TOKEN_VARIABLE tokens. + * TCL_TOKEN_SIMPLE_WORD - This token is just like TCL_TOKEN_WORD except + * that the word is guaranteed to consist of a + * single TCL_TOKEN_TEXT sub-token. + * TCL_TOKEN_TEXT - The token describes a range of literal text + * that is part of a word. NumComponents is + * always 0. + * TCL_TOKEN_BS - The token describes a backslash sequence that + * must be collapsed. NumComponents is always 0. + * TCL_TOKEN_COMMAND - The token describes a command whose result + * must be substituted into the word. The token + * includes the enclosing brackets. NumComponents * is always 0. - * TCL_TOKEN_COMMAND - The token describes a command whose result - * must be substituted into the word. The - * token includes the enclosing brackets. - * NumComponents is always 0. - * TCL_TOKEN_VARIABLE - The token describes a variable - * substitution, including the dollar sign, - * variable name, and array index (if there - * is one) up through the right - * parentheses. NumComponents tells how - * many additional tokens follow to - * represent the variable name. The first - * token will be a TCL_TOKEN_TEXT token - * that describes the variable name. If - * the variable is an array reference then - * there will be one or more additional - * tokens, of type TCL_TOKEN_TEXT, + * TCL_TOKEN_VARIABLE - The token describes a variable substitution, + * including the dollar sign, variable name, and + * array index (if there is one) up through the + * right parentheses. NumComponents tells how + * many additional tokens follow to represent the + * variable name. The first token will be a + * TCL_TOKEN_TEXT token that describes the + * variable name. If the variable is an array + * reference then there will be one or more + * additional tokens, of type TCL_TOKEN_TEXT, * TCL_TOKEN_BS, TCL_TOKEN_COMMAND, and - * TCL_TOKEN_VARIABLE, that describe the - * array index; numComponents counts the - * total number of nested tokens that make - * up the variable reference, including - * sub-tokens of TCL_TOKEN_VARIABLE tokens. - * TCL_TOKEN_SUB_EXPR - The token describes one subexpression of a - * expression, from the first non-blank - * character of the subexpression up to but not - * including the space, brace, or bracket - * that terminates the subexpression. - * NumComponents counts the total number of - * following subtokens that make up the - * subexpression; this includes all subtokens - * for any nested TCL_TOKEN_SUB_EXPR tokens. - * For example, a numeric value used as a + * TCL_TOKEN_VARIABLE, that describe the array + * index; numComponents counts the total number + * of nested tokens that make up the variable + * reference, including sub-tokens of + * TCL_TOKEN_VARIABLE tokens. + * TCL_TOKEN_SUB_EXPR - The token describes one subexpression of an + * expression, from the first non-blank character + * of the subexpression up to but not including + * the space, brace, or bracket that terminates + * the subexpression. NumComponents counts the + * total number of following subtokens that make + * up the subexpression; this includes all + * subtokens for any nested TCL_TOKEN_SUB_EXPR + * tokens. For example, a numeric value used as a * primitive operand is described by a * TCL_TOKEN_SUB_EXPR token followed by a * TCL_TOKEN_TEXT token. A binary subexpression * is described by a TCL_TOKEN_SUB_EXPR token - * followed by the TCL_TOKEN_OPERATOR token - * for the operator, then TCL_TOKEN_SUB_EXPR - * tokens for the left then the right operands. + * followed by the TCL_TOKEN_OPERATOR token for + * the operator, then TCL_TOKEN_SUB_EXPR tokens + * for the left then the right operands. * TCL_TOKEN_OPERATOR - The token describes one expression operator. * An operator might be the name of a math * function such as "abs". A TCL_TOKEN_OPERATOR * token is always preceeded by one * TCL_TOKEN_SUB_EXPR token for the operator's - * subexpression, and is followed by zero or - * more TCL_TOKEN_SUB_EXPR tokens for the - * operator's operands. NumComponents is - * always 0. - * TCL_TOKEN_EXPAND_WORD - This token is just like TCL_TOKEN_WORD - * except that it marks a word that began with - * the literal character prefix "{expand}". This - * word is marked to be expanded - that is, broken + * subexpression, and is followed by zero or more + * TCL_TOKEN_SUB_EXPR tokens for the operator's + * operands. NumComponents is always 0. + * TCL_TOKEN_EXPAND_WORD - This token is just like TCL_TOKEN_WORD except + * that it marks a word that began with the + * literal character prefix "{expand}". This word + * is marked to be expanded - that is, broken * into words after substitution is complete. */ + #define TCL_TOKEN_WORD 1 #define TCL_TOKEN_SIMPLE_WORD 2 #define TCL_TOKEN_TEXT 4 #define TCL_TOKEN_BS 8 #define TCL_TOKEN_COMMAND 16 @@ -2085,14 +2120,14 @@ #define TCL_TOKEN_SUB_EXPR 64 #define TCL_TOKEN_OPERATOR 128 #define TCL_TOKEN_EXPAND_WORD 256 /* - * Parsing error types. On any parsing error, one of these values - * will be stored in the error field of the Tcl_Parse structure - * defined below. + * Parsing error types. On any parsing error, one of these values will be + * stored in the error field of the Tcl_Parse structure defined below. */ + #define TCL_PARSE_SUCCESS 0 #define TCL_PARSE_QUOTE_EXTRA 1 #define TCL_PARSE_BRACE_EXTRA 2 #define TCL_PARSE_MISSING_BRACE 3 #define TCL_PARSE_MISSING_BRACKET 4 @@ -2101,208 +2136,211 @@ #define TCL_PARSE_MISSING_VAR_BRACE 7 #define TCL_PARSE_SYNTAX 8 #define TCL_PARSE_BAD_NUMBER 9 /* - * A structure of the following type is filled in by Tcl_ParseCommand. - * It describes a single command parsed from an input string. + * A structure of the following type is filled in by Tcl_ParseCommand. It + * describes a single command parsed from an input string. */ + #define NUM_STATIC_TOKENS 20 typedef struct Tcl_Parse { - CONST char *commentStart; /* Pointer to # that begins the first of - * one or more comments preceding the - * command. */ + CONST char *commentStart; /* Pointer to # that begins the first of one + * or more comments preceding the command. */ int commentSize; /* Number of bytes in comments (up through - * newline character that terminates the - * last comment). If there were no - * comments, this field is 0. */ - CONST char *commandStart; /* First character in first word of command. */ - int commandSize; /* Number of bytes in command, including - * first character of first word, up - * through the terminating newline, - * close bracket, or semicolon. */ - int numWords; /* Total number of words in command. May - * be 0. */ - Tcl_Token *tokenPtr; /* Pointer to first token representing - * the words of the command. Initially - * points to staticTokens, but may change - * to point to malloc-ed space if command - * exceeds space in staticTokens. */ + * newline character that terminates the last + * comment). If there were no comments, this + * field is 0. */ + CONST char *commandStart; /* First character in first word of + * command. */ + int commandSize; /* Number of bytes in command, including first + * character of first word, up through the + * terminating newline, close bracket, or + * semicolon. */ + int numWords; /* Total number of words in command. May be + * 0. */ + Tcl_Token *tokenPtr; /* Pointer to first token representing the + * words of the command. Initially points to + * staticTokens, but may change to point to + * malloc-ed space if command exceeds space in + * staticTokens. */ int numTokens; /* Total number of tokens in command. */ int tokensAvailable; /* Total number of tokens available at * *tokenPtr. */ int errorType; /* One of the parsing error types defined * above. */ /* - * The fields below are intended only for the private use of the - * parser. They should not be used by procedures that invoke - * Tcl_ParseCommand. + * The fields below are intended only for the private use of the parser. + * They should not be used by functions that invoke Tcl_ParseCommand. */ CONST char *string; /* The original command string passed to * Tcl_ParseCommand. */ - CONST char *end; /* Points to the character just after the - * last one in the command string. */ - Tcl_Interp *interp; /* Interpreter to use for error reporting, - * or NULL. */ + CONST char *end; /* Points to the character just after the last + * one in the command string. */ + Tcl_Interp *interp; /* Interpreter to use for error reporting, or + * NULL. */ CONST char *term; /* Points to character in string that - * terminated most recent token. Filled in - * by ParseTokens. If an error occurs, - * points to beginning of region where the - * error occurred (e.g. the open brace if - * the close brace is missing). */ + * terminated most recent token. Filled in by + * ParseTokens. If an error occurs, points to + * beginning of region where the error + * occurred (e.g. the open brace if the close + * brace is missing). */ int incomplete; /* This field is set to 1 by Tcl_ParseCommand * if the command appears to be incomplete. * This information is used by * Tcl_CommandComplete. */ Tcl_Token staticTokens[NUM_STATIC_TOKENS]; - /* Initial space for tokens for command. - * This space should be large enough to - * accommodate most commands; dynamic - * space is allocated for very large - * commands that don't fit here. */ + /* Initial space for tokens for command. This + * space should be large enough to accommodate + * most commands; dynamic space is allocated + * for very large commands that don't fit + * here. */ } Tcl_Parse; /* * The following definitions are the error codes returned by the conversion * routines: * - * TCL_OK: All characters were converted. - * - * TCL_CONVERT_NOSPACE: The output buffer would not have been large + * TCL_OK - All characters were converted. + * TCL_CONVERT_NOSPACE - The output buffer would not have been large * enough for all of the converted data; as many * characters as could fit were converted though. - * - * TCL_CONVERT_MULTIBYTE: The last few bytes in the source string were + * TCL_CONVERT_MULTIBYTE - The last few bytes in the source string were * the beginning of a multibyte sequence, but * more bytes were needed to complete this - * sequence. A subsequent call to the conversion + * sequence. A subsequent call to the conversion * routine should pass the beginning of this * unconverted sequence plus additional bytes - * from the source stream to properly convert - * the formerly split-up multibyte sequence. - * - * TCL_CONVERT_SYNTAX: The source stream contained an invalid - * character sequence. This may occur if the + * from the source stream to properly convert the + * formerly split-up multibyte sequence. + * TCL_CONVERT_SYNTAX - The source stream contained an invalid + * character sequence. This may occur if the * input stream has been damaged or if the input - * encoding method was misidentified. This error + * encoding method was misidentified. This error * is reported only if TCL_ENCODING_STOPONERROR * was specified. - * - * TCL_CONVERT_UNKNOWN: The source string contained a character - * that could not be represented in the target - * encoding. This error is reported only if + * TCL_CONVERT_UNKNOWN - The source string contained a character that + * could not be represented in the target + * encoding. This error is reported only if * TCL_ENCODING_STOPONERROR was specified. */ -#define TCL_CONVERT_MULTIBYTE -1 -#define TCL_CONVERT_SYNTAX -2 -#define TCL_CONVERT_UNKNOWN -3 -#define TCL_CONVERT_NOSPACE -4 +#define TCL_CONVERT_MULTIBYTE -1 +#define TCL_CONVERT_SYNTAX -2 +#define TCL_CONVERT_UNKNOWN -3 +#define TCL_CONVERT_NOSPACE -4 /* * The maximum number of bytes that are necessary to represent a single - * Unicode character in UTF-8. The valid values should be 3 or 6 (or - * perhaps 1 if we want to support a non-unicode enabled core). - * If 3, then Tcl_UniChar must be 2-bytes in size (UCS-2). (default) - * If 6, then Tcl_UniChar must be 4-bytes in size (UCS-4). - * At this time UCS-2 mode is the default and recommended mode. - * UCS-4 is experimental and not recommended. It works for the core, - * but most extensions expect UCS-2. + * Unicode character in UTF-8. The valid values should be 3 or 6 (or perhaps 1 + * if we want to support a non-unicode enabled core). If 3, then Tcl_UniChar + * must be 2-bytes in size (UCS-2) (the default). If 6, then Tcl_UniChar must + * be 4-bytes in size (UCS-4). At this time UCS-2 mode is the default and + * recommended mode. UCS-4 is experimental and not recommended. It works for + * the core, but most extensions expect UCS-2. */ + #ifndef TCL_UTF_MAX #define TCL_UTF_MAX 3 #endif /* - * This represents a Unicode character. Any changes to this should - * also be reflected in regcustom.h. + * This represents a Unicode character. Any changes to this should also be + * reflected in regcustom.h. */ + #if TCL_UTF_MAX > 3 /* - * unsigned int isn't 100% accurate as it should be a strict 4-byte - * value (perhaps wchar_t). 64-bit systems may have troubles. The - * size of this value must be reflected correctly in regcustom.h. + * unsigned int isn't 100% accurate as it should be a strict 4-byte value + * (perhaps wchar_t). 64-bit systems may have troubles. The size of this + * value must be reflected correctly in regcustom.h. */ typedef unsigned int Tcl_UniChar; #else typedef unsigned short Tcl_UniChar; #endif -/* TIP #59: The following structure is used in calls - * 'Tcl_RegisterConfig' to provide the system with the embedded - * configuration data. +/* + * TIP #59: The following structure is used in calls 'Tcl_RegisterConfig' to + * provide the system with the embedded configuration data. */ typedef struct Tcl_Config { - CONST char* key; /* Configuration key to register. ASCII encoded, thus UTF-8 */ - CONST char* value; /* The value associated with the key. System encoding */ + CONST char *key; /* Configuration key to register. ASCII + * encoded, thus UTF-8 */ + CONST char *value; /* The value associated with the key. System + * encoding */ } Tcl_Config; - /* * Flags for TIP#143 limits, detailing which limits are active in an - * interpreter. Used for Tcl_{Add,Remove}LimitHandler type argument. + * interpreter. Used for Tcl_{Add,Remove}LimitHandler type argument. */ #define TCL_LIMIT_COMMANDS 0x01 #define TCL_LIMIT_TIME 0x02 /* - * Structure containing information about a limit handler to be called - * when a command- or time-limit is exceeded by an interpreter. + * Structure containing information about a limit handler to be called when a + * command- or time-limit is exceeded by an interpreter. */ typedef void (Tcl_LimitHandlerProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp)); typedef void (Tcl_LimitHandlerDeleteProc) _ANSI_ARGS_((ClientData clientData)); +#ifndef MP_INT_DECLARED +typedef struct mp_int mp_int; +#define MP_INT_DECLARED +#endif +#ifndef MP_DIGIT_DECLARED +typedef unsigned long mp_digit; +#define MP_DIGIT_DECLARED +#endif #ifndef TCL_NO_DEPRECATED - /* - * Deprecated Tcl procedures: + * Deprecated Tcl functions: */ # define Tcl_EvalObj(interp,objPtr) \ Tcl_EvalObjEx((interp),(objPtr),0) # define Tcl_GlobalEvalObj(interp,objPtr) \ Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL) /* - * These function have been renamed. The old names are deprecated, - * but we define these macros for backwards compatibilty. + * These function have been renamed. The old names are deprecated, but we + * define these macros for backwards compatibilty. */ -# define Tcl_Ckalloc Tcl_Alloc -# define Tcl_Ckfree Tcl_Free -# define Tcl_Ckrealloc Tcl_Realloc -# define Tcl_Return Tcl_SetResult -# define Tcl_TildeSubst Tcl_TranslateFileName -# define panic Tcl_Panic -# define panicVA Tcl_PanicVA +# define Tcl_Ckalloc Tcl_Alloc +# define Tcl_Ckfree Tcl_Free +# define Tcl_Ckrealloc Tcl_Realloc +# define Tcl_Return Tcl_SetResult +# define Tcl_TildeSubst Tcl_TranslateFileName +# define panic Tcl_Panic +# define panicVA Tcl_PanicVA #endif - /* - * The following constant is used to test for older versions of Tcl - * in the stubs tables. + * The following constant is used to test for older versions of Tcl in the + * stubs tables. * * Jan Nijtman's plus patch uses 0xFCA1BACF, so we need to pick a different * value since the stubs tables don't match. */ #define TCL_STUB_MAGIC ((int)0xFCA3BACF) /* * The following function is required to be defined in all stubs aware - * extensions. The function is actually implemented in the stub - * library, not the main Tcl library, although there is a trivial - * implementation in the main library in case an extension is statically - * linked into an application. + * extensions. The function is actually implemented in the stub library, not + * the main Tcl library, although there is a trivial implementation in the + * main library in case an extension is statically linked into an application. */ EXTERN CONST char * Tcl_InitStubs _ANSI_ARGS_((Tcl_Interp *interp, CONST char *version, int exact)); @@ -2322,35 +2360,52 @@ */ EXTERN void Tcl_Main _ANSI_ARGS_((int argc, char **argv, Tcl_AppInitProc *appInitProc)); - /* - * Include the public function declarations that are accessible via - * the stubs table. + * Include the public function declarations that are accessible via the stubs + * table. */ #include "tclDecls.h" /* - * Include platform specific public function declarations that are - * accessible via the stubs table. + * Include platform specific public function declarations that are accessible + * via the stubs table. */ #include "tclPlatDecls.h" /* - * Convenience declaration of Tcl_AppInit for backwards compatibility. - * This function is not *implemented* by the tcl library, so the storage - * class is neither DLLEXPORT nor DLLIMPORT + * Convenience declaration of Tcl_AppInit for backwards compatibility. This + * function is not *implemented* by the tcl library, so the storage class is + * neither DLLEXPORT nor DLLIMPORT. */ + #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS EXTERN int Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp)); #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #endif /* RC_INVOKED */ + +/* + * end block for C++ + */ + +#ifdef __cplusplus +} +#endif + #endif /* _TCL */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclAlloc.c ================================================================== --- generic/tclAlloc.c +++ generic/tclAlloc.c @@ -1,23 +1,23 @@ -/* +/* * tclAlloc.c -- * - * This is a very fast storage allocator. It allocates blocks of a - * small number of different sizes, and keeps free lists of each size. - * Blocks that don't exactly fit are passed up to the next larger size. - * Blocks over a certain size are directly allocated from the system. + * This is a very fast storage allocator. It allocates blocks of a small + * number of different sizes, and keeps free lists of each size. Blocks + * that don't exactly fit are passed up to the next larger size. Blocks + * over a certain size are directly allocated from the system. * * Copyright (c) 1983 Regents of the University of California. * Copyright (c) 1996-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * * Portions contributed by Chris Kingsley, Jack Jansen and Ray Johnson. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclAlloc.c,v 1.21 2004/10/06 12:44:52 dkf Exp $ + * RCS: @(#) $Id: tclAlloc.c,v 1.21.2.1 2005/08/02 18:15:09 dgp Exp $ */ /* * Windows and Unix use an alternative allocator when building with threads * that has significantly reduced lock contention. @@ -33,40 +33,41 @@ /* #define MSTATS */ # define RCHECK #endif /* - * We should really make use of AC_CHECK_TYPE(caddr_t) - * here, but it can wait until Tcl uses config.h properly. + * We should really make use of AC_CHECK_TYPE(caddr_t) here, but it can wait + * until Tcl uses config.h properly. */ + #if defined(_MSC_VER) || defined(__MINGW32__) || defined(__BORLANDC__) typedef unsigned long caddr_t; #endif /* - * The overhead on a block is at least 8 bytes. When free, this space - * contains a pointer to the next free block, and the bottom two bits must * be zero. When in use, the first byte is set to MAGIC, and the second - * byte is the size index. The remaining bytes are for alignment. - * If range checking is enabled then a second word holds the size of the - * requested block, less 1, rounded up to a multiple of sizeof(RMAGIC). - * The order of elements is critical: ov.magic must overlay the low order - * bits of ov.next, and ov.magic can not be a valid ov.next bit pattern. + * The overhead on a block is at least 8 bytes. When free, this space contains + * a pointer to the next free block, and the bottom two bits must be zero. + * When in use, the first byte is set to MAGIC, and the second byte is the + * size index. The remaining bytes are for alignment. If range checking is + * enabled then a second word holds the size of the requested block, less 1, + * rounded up to a multiple of sizeof(RMAGIC). The order of elements is + * critical: ov.magic must overlay the low order bits of ov.next, and ov.magic + * can not be a valid ov.next bit pattern. */ union overhead { - union overhead *next; /* when free */ - unsigned char padding[8]; /* Ensure the structure is 8-byte - * aligned. */ + union overhead *next; /* when free */ + unsigned char padding[8]; /* Ensure the structure is 8-byte aligned. */ struct { - unsigned char magic0; /* magic number */ - unsigned char index; /* bucket # */ - unsigned char unused; /* unused */ - unsigned char magic1; /* other magic number */ + unsigned char magic0; /* magic number */ + unsigned char index; /* bucket # */ + unsigned char unused; /* unused */ + unsigned char magic1; /* other magic number */ #ifdef RCHECK - unsigned short rmagic; /* range magic number */ - unsigned long size; /* actual block size */ - unsigned short unused2; /* padding to 8-byte align */ + unsigned short rmagic; /* range magic number */ + unsigned long size; /* actual block size */ + unsigned short unused2; /* padding to 8-byte align */ #endif } ovu; #define overMagic0 ovu.magic0 #define overMagic1 ovu.magic1 #define bucketIndex ovu.index @@ -73,12 +74,12 @@ #define rangeCheckMagic ovu.rmagic #define realBlockSize ovu.size }; -#define MAGIC 0xef /* magic # on accounting info */ -#define RMAGIC 0x5555 /* magic # on range info */ +#define MAGIC 0xef /* magic # on accounting info */ +#define RMAGIC 0x5555 /* magic # on range info */ #ifdef RCHECK #define RSLOP sizeof (unsigned short) #else #define RSLOP 0 @@ -92,62 +93,61 @@ #define BLOCK_END(overPtr) \ (*(unsigned short *)((caddr_t)((overPtr) + 1) + (overPtr)->realBlockSize)) /* - * nextf[i] is the pointer to the next free block of size 2^(i+3). The - * smallest allocatable block is 8 bytes. The overhead information - * precedes the data area returned to the user. + * nextf[i] is the pointer to the next free block of size 2^(i+3). The + * smallest allocatable block is 8 bytes. The overhead information precedes + * the data area returned to the user. */ #define NBUCKETS 13 #define MAXMALLOC (1<<(NBUCKETS+2)) -static union overhead *nextf[NBUCKETS]; +static union overhead *nextf[NBUCKETS]; -/* - * The following structure is used to keep track of all system memory - * currently owned by Tcl. When finalizing, all this memory will - * be returned to the system. +/* + * The following structure is used to keep track of all system memory + * currently owned by Tcl. When finalizing, all this memory will be returned + * to the system. */ struct block { struct block *nextPtr; /* Linked list. */ - struct block *prevPtr; /* Linked list for big blocks, ensures 8-byte + struct block *prevPtr; /* Linked list for big blocks, ensures 8-byte * alignment for suballocated blocks. */ }; -static struct block *blockList; /* Tracks the suballocated blocks. */ -static struct block bigBlocks = { /* Big blocks aren't suballocated. */ +static struct block *blockList; /* Tracks the suballocated blocks. */ +static struct block bigBlocks={ /* Big blocks aren't suballocated. */ &bigBlocks, &bigBlocks }; /* - * The allocator is protected by a special mutex that must be - * explicitly initialized. Futhermore, because Tcl_Alloc may be - * used before anything else in Tcl, we make this module self-initializing - * after all with the allocInit variable. + * The allocator is protected by a special mutex that must be explicitly + * initialized. Futhermore, because Tcl_Alloc may be used before anything else + * in Tcl, we make this module self-initializing after all with the allocInit + * variable. */ #ifdef TCL_THREADS static Tcl_Mutex *allocMutexPtr; #endif static int allocInit = 0; - #ifdef MSTATS /* - * numMallocs[i] is the difference between the number of mallocs and frees - * for a given block size. + * numMallocs[i] is the difference between the number of mallocs and frees for + * a given block size. */ static unsigned int numMallocs[NBUCKETS+1]; #include #endif #if defined(DEBUG) || defined(RCHECK) -#define ASSERT(p) if (!(p)) Tcl_Panic(# p) +#define ASSERT(p) if (!(p)) Tcl_Panic(# p) #define RANGE_ASSERT(p) if (!(p)) Tcl_Panic(# p) #else #define ASSERT(p) #define RANGE_ASSERT(p) #endif @@ -155,11 +155,10 @@ /* * Prototypes for functions used only in this file. */ static void MoreCore _ANSI_ARGS_((int bucket)); - /* *------------------------------------------------------------------------- * * TclInitAlloc -- @@ -189,25 +188,24 @@ /* *------------------------------------------------------------------------- * * TclFinalizeAllocSubsystem -- * - * Release all resources being used by this subsystem, including - * aggressively freeing all memory allocated by TclpAlloc() that - * has not yet been released with TclpFree(). - * - * After this function is called, all memory allocated with - * TclpAlloc() should be considered unusable. + * Release all resources being used by this subsystem, including + * aggressively freeing all memory allocated by TclpAlloc() that has not + * yet been released with TclpFree(). + * + * After this function is called, all memory allocated with TclpAlloc() + * should be considered unusable. * * Results: * None. * * Side effects: - * This subsystem is self-initializing, since memory can be - * allocated before Tcl is formally initialized. After this call, - * this subsystem has been reset to its initial state and is - * usable again. + * This subsystem is self-initializing, since memory can be allocated + * before Tcl is formally initialized. After this call, this subsystem + * has been reset to its initial state and is usable again. * *------------------------------------------------------------------------- */ void @@ -229,11 +227,11 @@ blockPtr = nextPtr; } bigBlocks.nextPtr = &bigBlocks; bigBlocks.prevPtr = &bigBlocks; - for (i = 0; i < NBUCKETS; i++) { + for (i=0 ; i= MAXMALLOC) { - bigBlockPtr = (struct block *) TclpSysAlloc((unsigned) + bigBlockPtr = (struct block *) TclpSysAlloc((unsigned) (sizeof(struct block) + OVERHEAD + numBytes), 0); if (bigBlockPtr == NULL) { Tcl_MutexUnlock(allocMutexPtr); return NULL; } @@ -296,73 +296,84 @@ overPtr->overMagic0 = overPtr->overMagic1 = MAGIC; overPtr->bucketIndex = 0xff; #ifdef MSTATS numMallocs[NBUCKETS]++; #endif + #ifdef RCHECK /* - * Record allocated size of block and - * bound space with magic numbers. + * Record allocated size of block and bound space with magic numbers. */ + overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); overPtr->rangeCheckMagic = RMAGIC; BLOCK_END(overPtr) = RMAGIC; #endif + Tcl_MutexUnlock(allocMutexPtr); return (void *)(overPtr+1); } + /* - * Convert amount of memory requested into closest block size - * stored in hash buckets which satisfies request. - * Account for space used per block for accounting. + * Convert amount of memory requested into closest block size stored in + * hash buckets which satisfies request. Account for space used per block + * for accounting. */ + #ifndef RCHECK amount = 8; /* size of first bucket */ bucket = 0; #else amount = 16; /* size of first bucket */ bucket = 1; #endif + while (numBytes + OVERHEAD > amount) { amount <<= 1; if (amount == 0) { Tcl_MutexUnlock(allocMutexPtr); - return (NULL); + return NULL; } bucket++; } ASSERT(bucket < NBUCKETS); /* - * If nothing in hash bucket right now, - * request more memory from the system. + * If nothing in hash bucket right now, request more memory from the + * system. */ + if ((overPtr = nextf[bucket]) == NULL) { MoreCore(bucket); if ((overPtr = nextf[bucket]) == NULL) { Tcl_MutexUnlock(allocMutexPtr); - return (NULL); + return NULL; } } + /* * Remove from linked list */ + nextf[bucket] = overPtr->next; overPtr->overMagic0 = overPtr->overMagic1 = MAGIC; overPtr->bucketIndex = (unsigned char) bucket; + #ifdef MSTATS numMallocs[bucket]++; #endif + #ifdef RCHECK /* - * Record allocated size of block and - * bound space with magic numbers. + * Record allocated size of block and bound space with magic numbers. */ + overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); overPtr->rangeCheckMagic = RMAGIC; BLOCK_END(overPtr) = RMAGIC; #endif + Tcl_MutexUnlock(allocMutexPtr); return ((char *)(overPtr + 1)); } /* @@ -392,35 +403,36 @@ long amount; /* amount to allocate */ int numBlocks; /* how many blocks we get */ struct block *blockPtr; /* - * sbrk_size <= 0 only for big, FLUFFY, requests (about - * 2^30 bytes on a VAX, I think) or for a negative arg. + * sbrk_size <= 0 only for big, FLUFFY, requests (about 2^30 bytes on a + * VAX, I think) or for a negative arg. */ + size = 1 << (bucket + 3); ASSERT(size > 0); amount = MAXMALLOC; numBlocks = amount / size; ASSERT(numBlocks*size == amount); - blockPtr = (struct block *) TclpSysAlloc((unsigned) + blockPtr = (struct block *) TclpSysAlloc((unsigned) (sizeof(struct block) + amount), 1); /* no more room! */ if (blockPtr == NULL) { return; } blockPtr->nextPtr = blockList; blockList = blockPtr; overPtr = (union overhead *) (blockPtr + 1); - + /* - * Add new memory allocated to that on - * free list for this hash bucket. + * Add new memory allocated to that on free list for this hash bucket. */ + nextf[bucket] = overPtr; while (--numBlocks > 0) { overPtr->next = (union overhead *)((caddr_t)overPtr + size); overPtr = (union overhead *)((caddr_t)overPtr + size); } @@ -444,11 +456,11 @@ */ void TclpFree(oldPtr) char *oldPtr; /* Pointer to memory to free. */ -{ +{ register long size; register union overhead *overPtr; struct block *bigBlockPtr; if (oldPtr == NULL) { @@ -470,23 +482,27 @@ size = overPtr->bucketIndex; if (size == 0xff) { #ifdef MSTATS numMallocs[NBUCKETS]--; #endif + bigBlockPtr = (struct block *) overPtr - 1; bigBlockPtr->prevPtr->nextPtr = bigBlockPtr->nextPtr; bigBlockPtr->nextPtr->prevPtr = bigBlockPtr->prevPtr; TclpSysFree(bigBlockPtr); + Tcl_MutexUnlock(allocMutexPtr); return; } ASSERT(size < NBUCKETS); overPtr->next = nextf[size]; /* also clobbers overMagic */ nextf[size] = overPtr; + #ifdef MSTATS numMallocs[size]--; #endif + Tcl_MutexUnlock(allocMutexPtr); } /* *---------------------------------------------------------------------- @@ -506,19 +522,19 @@ char * TclpRealloc(oldPtr, numBytes) char *oldPtr; /* Pointer to alloced block. */ unsigned int numBytes; /* New size of memory. */ -{ +{ int i; union overhead *overPtr; struct block *bigBlockPtr; int expensive; unsigned long maxSize; if (oldPtr == NULL) { - return (TclpAlloc(numBytes)); + return TclpAlloc(numBytes); } Tcl_MutexLock(allocMutexPtr); overPtr = (union overhead *)((caddr_t)oldPtr - sizeof (union overhead)); @@ -541,39 +557,42 @@ if (i == 0xff) { struct block *prevPtr, *nextPtr; bigBlockPtr = (struct block *) overPtr - 1; prevPtr = bigBlockPtr->prevPtr; nextPtr = bigBlockPtr->nextPtr; - bigBlockPtr = (struct block *) TclpSysRealloc(bigBlockPtr, + bigBlockPtr = (struct block *) TclpSysRealloc(bigBlockPtr, sizeof(struct block) + OVERHEAD + numBytes); if (bigBlockPtr == NULL) { Tcl_MutexUnlock(allocMutexPtr); return NULL; } if (prevPtr->nextPtr != bigBlockPtr) { /* - * If the block has moved, splice the new block into the list where - * the old block used to be. + * If the block has moved, splice the new block into the list + * where the old block used to be. */ prevPtr->nextPtr = bigBlockPtr; nextPtr->prevPtr = bigBlockPtr; } overPtr = (union overhead *) (bigBlockPtr + 1); + #ifdef MSTATS numMallocs[NBUCKETS]++; #endif + #ifdef RCHECK /* * Record allocated size of block and update magic number bounds. */ overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); BLOCK_END(overPtr) = RMAGIC; #endif + Tcl_MutexUnlock(allocMutexPtr); return (char *)(overPtr+1); } maxSize = 1 << (i+3); expensive = 0; @@ -598,30 +617,32 @@ } memcpy((VOID *) newPtr, (VOID *) oldPtr, (size_t) numBytes); TclpFree(oldPtr); return newPtr; } - + /* * Ok, we don't have to copy, it fits as-is */ + #ifdef RCHECK overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); BLOCK_END(overPtr) = RMAGIC; #endif + Tcl_MutexUnlock(allocMutexPtr); return(oldPtr); } /* *---------------------------------------------------------------------- * * mstats -- * - * Prints two lines of numbers, one showing the length of the - * free list for each size category, the second showing the - * number of mallocs - frees for each size category. + * Prints two lines of numbers, one showing the length of the free list + * for each size category, the second showing the number of mallocs - + * frees for each size category. * * Results: * None. * * Side effects: @@ -631,33 +652,37 @@ */ #ifdef MSTATS void mstats(s) - char *s; /* Where to write info. */ + char *s; /* Where to write info. */ { register int i, j; register union overhead *overPtr; int totalFree = 0, totalUsed = 0; Tcl_MutexLock(allocMutexPtr); + fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s); for (i = 0; i < NBUCKETS; i++) { for (j=0, overPtr=nextf[i]; overPtr; overPtr=overPtr->next, j++) { fprintf(stderr, " %d", j); } totalFree += j * (1 << (i + 3)); } + fprintf(stderr, "\nused:\t"); for (i = 0; i < NBUCKETS; i++) { fprintf(stderr, " %d", numMallocs[i]); totalUsed += numMallocs[i] * (1 << (i + 3)); } + fprintf(stderr, "\n\tTotal small in use: %d, total free: %d\n", totalUsed, totalFree); - fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n", + fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n", MAXMALLOC, numMallocs[NBUCKETS]); + Tcl_MutexUnlock(allocMutexPtr); } #endif #else /* !USE_TCLALLOC */ @@ -702,11 +727,11 @@ */ void TclpFree(oldPtr) char *oldPtr; /* Pointer to memory to free. */ -{ +{ free(oldPtr); return; } /* @@ -727,11 +752,19 @@ char * TclpRealloc(oldPtr, numBytes) char *oldPtr; /* Pointer to alloced block. */ unsigned int numBytes; /* New size of memory. */ -{ +{ return (char*) realloc(oldPtr, numBytes); } #endif /* !USE_TCLALLOC */ #endif /* !TCL_THREADS */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclAsync.c ================================================================== --- generic/tclAsync.c +++ generic/tclAsync.c @@ -1,94 +1,82 @@ -/* +/* * tclAsync.c -- * - * This file provides low-level support needed to invoke signal - * handlers in a safe way. The code here doesn't actually handle - * signals, though. This code is based on proposals made by - * Mark Diekhans and Don Libes. + * This file provides low-level support needed to invoke signal handlers + * in a safe way. The code here doesn't actually handle signals, though. + * This code is based on proposals made by Mark Diekhans and Don Libes. * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclAsync.c,v 1.7 2004/04/06 22:25:48 dgp Exp $ + * RCS: @(#) $Id: tclAsync.c,v 1.7.2.1 2005/08/02 18:15:10 dgp Exp $ */ #include "tclInt.h" /* Forward declaration */ struct ThreadSpecificData; /* - * One of the following structures exists for each asynchronous - * handler: + * One of the following structures exists for each asynchronous handler: */ typedef struct AsyncHandler { - int ready; /* Non-zero means this handler should - * be invoked in the next call to - * Tcl_AsyncInvoke. */ - struct AsyncHandler *nextPtr; /* Next in list of all handlers for - * the process. */ - Tcl_AsyncProc *proc; /* Procedure to call when handler - * is invoked. */ - ClientData clientData; /* Value to pass to handler when it - * is invoked. */ + int ready; /* Non-zero means this handler should be + * invoked in the next call to + * Tcl_AsyncInvoke. */ + struct AsyncHandler *nextPtr; + /* Next in list of all handlers for the + * process. */ + Tcl_AsyncProc *proc; /* Procedure to call when handler is + * invoked. */ + ClientData clientData; /* Value to pass to handler when it is + * invoked. */ struct ThreadSpecificData *originTsd; - /* Used in Tcl_AsyncMark to modify thread- - * specific data from outside the thread - * it is associated to. */ - Tcl_ThreadId originThrdId; /* Origin thread where this token was - * created and where it will be - * yielded. */ + /* Used in Tcl_AsyncMark to modify thread- + * specific data from outside the thread it is + * associated to. */ + Tcl_ThreadId originThrdId; /* Origin thread where this token was created + * and where it will be yielded. */ } AsyncHandler; - typedef struct ThreadSpecificData { /* - * The variables below maintain a list of all existing handlers - * specific to the calling thread. - */ - AsyncHandler *firstHandler; /* First handler defined for process, - * or NULL if none. */ - AsyncHandler *lastHandler; /* Last handler or NULL. */ - - /* - * The variable below is set to 1 whenever a handler becomes ready and - * it is cleared to zero whenever Tcl_AsyncInvoke is called. It can be - * checked elsewhere in the application by calling Tcl_AsyncReady to see - * if Tcl_AsyncInvoke should be invoked. - */ - - int asyncReady; - - /* - * The variable below indicates whether Tcl_AsyncInvoke is currently - * working. If so then we won't set asyncReady again until - * Tcl_AsyncInvoke returns. - */ - - int asyncActive; - - Tcl_Mutex asyncMutex; /* Thread-specific AsyncHandler linked-list lock */ - + * The variables below maintain a list of all existing handlers specific + * to the calling thread. + */ + AsyncHandler *firstHandler; /* First handler defined for process, or NULL + * if none. */ + AsyncHandler *lastHandler; /* Last handler or NULL. */ + int asyncReady; /* This is set to 1 whenever a handler becomes + * ready and it is cleared to zero whenever + * Tcl_AsyncInvoke is called. It can be + * checked elsewhere in the application by + * calling Tcl_AsyncReady to see if + * Tcl_AsyncInvoke should be invoked. */ + int asyncActive; /* Indicates whether Tcl_AsyncInvoke is + * currently working. If so then we won't set + * asyncReady again until Tcl_AsyncInvoke + * returns. */ + Tcl_Mutex asyncMutex; /* Thread-specific AsyncHandler linked-list + * lock */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; - /* *---------------------------------------------------------------------- * * TclFinalizeAsync -- * - * Finalizes the mutex in the thread local data structure for the - * async subsystem. + * Finalizes the mutex in the thread local data structure for the async + * subsystem. * * Results: - * None. + * None. * * Side effects: * Forgets knowledge of the mutex should it have been created. * *---------------------------------------------------------------------- @@ -108,28 +96,28 @@ *---------------------------------------------------------------------- * * Tcl_AsyncCreate -- * * This procedure creates the data structures for an asynchronous - * handler, so that no memory has to be allocated when the handler - * is activated. + * handler, so that no memory has to be allocated when the handler is + * activated. * * Results: - * The return value is a token for the handler, which can be used - * to activate it later on. + * The return value is a token for the handler, which can be used to + * activate it later on. * * Side effects: * Information about the handler is recorded. * *---------------------------------------------------------------------- */ Tcl_AsyncHandler Tcl_AsyncCreate(proc, clientData) - Tcl_AsyncProc *proc; /* Procedure to call when handler - * is invoked. */ - ClientData clientData; /* Argument to pass to handler. */ + Tcl_AsyncProc *proc; /* Procedure to call when handler is + * invoked. */ + ClientData clientData; /* Argument to pass to handler. */ { AsyncHandler *asyncPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); asyncPtr = (AsyncHandler *) ckalloc(sizeof(AsyncHandler)); @@ -154,14 +142,14 @@ /* *---------------------------------------------------------------------- * * Tcl_AsyncMark -- * - * This procedure is called to request that an asynchronous handler - * be invoked as soon as possible. It's typically called from - * an interrupt handler, where it isn't safe to do anything that - * depends on or modifies application state. + * This procedure is called to request that an asynchronous handler be + * invoked as soon as possible. It's typically called from an interrupt + * handler, where it isn't safe to do anything that depends on or + * modifies application state. * * Results: * None. * * Side effects: @@ -188,33 +176,31 @@ /* *---------------------------------------------------------------------- * * Tcl_AsyncInvoke -- * - * This procedure is called at a "safe" time at background level - * to invoke any active asynchronous handlers. + * This procedure is called at a "safe" time at background level to + * invoke any active asynchronous handlers. * * Results: - * The return value is a normal Tcl result, which is intended to - * replace the code argument as the current completion code for - * interp. + * The return value is a normal Tcl result, which is intended to replace + * the code argument as the current completion code for interp. * * Side effects: * Depends on the handlers that are active. * *---------------------------------------------------------------------- */ int Tcl_AsyncInvoke(interp, code) - Tcl_Interp *interp; /* If invoked from Tcl_Eval just after - * completing a command, points to - * interpreter. Otherwise it is - * NULL. */ - int code; /* If interp is non-NULL, this gives - * completion code from command that - * just completed. */ + Tcl_Interp *interp; /* If invoked from Tcl_Eval just after + * completing a command, points to + * interpreter. Otherwise it is NULL. */ + int code; /* If interp is non-NULL, this gives + * completion code from command that just + * completed. */ { AsyncHandler *asyncPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); Tcl_MutexLock(&tsdPtr->asyncMutex); @@ -228,17 +214,16 @@ if (interp == NULL) { code = 0; } /* - * Make one or more passes over the list of handlers, invoking - * at most one handler in each pass. After invoking a handler, - * go back to the start of the list again so that (a) if a new - * higher-priority handler gets marked while executing a lower - * priority handler, we execute the higher-priority handler - * next, and (b) if a handler gets deleted during the execution - * of a handler, then the list structure may change so it isn't + * Make one or more passes over the list of handlers, invoking at most one + * handler in each pass. After invoking a handler, go back to the start of + * the list again so that (a) if a new higher-priority handler gets marked + * while executing a lower priority handler, we execute the higher- + * priority handler next, and (b) if a handler gets deleted during the + * execution of a handler, then the list structure may change so it isn't * safe to continue down the list anyway. */ while (1) { for (asyncPtr = tsdPtr->firstHandler; asyncPtr != NULL; @@ -263,12 +248,12 @@ /* *---------------------------------------------------------------------- * * Tcl_AsyncDelete -- * - * Frees up all the state for an asynchronous handler. The handler - * should never be used again. + * Frees up all the state for an asynchronous handler. The handler should + * never be used again. * * Results: * None. * * Side effects: @@ -308,17 +293,17 @@ /* *---------------------------------------------------------------------- * * Tcl_AsyncReady -- * - * This procedure can be used to tell whether Tcl_AsyncInvoke - * needs to be called. This procedure is the external interface - * for checking the thread-specific asyncReady variable. + * This procedure can be used to tell whether Tcl_AsyncInvoke needs to be + * called. This procedure is the external interface for checking the + * thread-specific asyncReady variable. * * Results: - * The return value is 1 whenever a handler is ready and is 0 - * when no handlers are ready. + * The return value is 1 whenever a handler is ready and is 0 when no + * handlers are ready. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -328,5 +313,13 @@ Tcl_AsyncReady() { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); return tsdPtr->asyncReady; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclBasic.c ================================================================== --- generic/tclBasic.c +++ generic/tclBasic.c @@ -1,36 +1,86 @@ /* * tclBasic.c -- * * Contains the basic facilities for TCL command interpretation, - * including interpreter creation and deletion, command creation - * and deletion, and command/script execution. + * including interpreter creation and deletion, command creation and + * deletion, and command/script execution. * * Copyright (c) 1987-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001, 2002 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. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.136 2004/11/30 19:34:46 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.136.2.39 2005/10/04 13:49:36 dgp Exp $ */ #include "tclInt.h" #include "tclCompile.h" +#include +#include +#include "tommath.h" + +/* + * The following structure defines the client data for a math function + * registered with Tcl_CreateMathFunc + */ + +typedef struct OldMathFuncData { + Tcl_MathProc* proc; /* Handler procedure */ + int numArgs; /* Number of args expected */ + Tcl_ValueType* argTypes; /* Types of the args */ + ClientData clientData; /* Client data for the handler function */ +} OldMathFuncData; /* * Static procedures in this file: */ -static char * CallCommandTraces _ANSI_ARGS_((Interp *iPtr, - Command *cmdPtr, CONST char *oldName, - CONST char* newName, int flags)); -static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp)); -static void ProcessUnexpectedResult _ANSI_ARGS_(( - Tcl_Interp *interp, int returnCode)); +static char * CallCommandTraces (Interp *iPtr, Command *cmdPtr, + CONST char *oldName, CONST char* newName, int flags); +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, + int argc, Tcl_Obj *CONST *objv); + +static void OldMathFuncDeleteProc (ClientData clientData); + +static int ExprAbsFunc (ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *CONST *objv); +static int ExprBinaryFunc (ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *CONST *objv); +static int ExprBoolFunc (ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *CONST *objv); +static int ExprCeilFunc (ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *CONST *objv); +static int ExprDoubleFunc (ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *CONST *objv); +static int ExprEntierFunc (ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *CONST *objv); +static int ExprFloorFunc (ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *CONST *objv); +static int ExprIntFunc (ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *CONST *objv); +static int ExprRandFunc (ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *CONST *objv); +static int ExprRoundFunc (ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *CONST *objv); +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); extern TclStubs tclStubs; /* * The following structure defines the commands in the Tcl core. @@ -38,22 +88,22 @@ typedef struct { char *name; /* Name of object-based command. */ Tcl_ObjCmdProc *objProc; /* Object-based procedure for command. */ CompileProc *compileProc; /* Procedure called to compile command. */ - int isSafe; /* If non-zero, command will be present - * in safe interpreter. Otherwise it will - * be hidden. */ + int isSafe; /* If non-zero, command will be present in + * safe interpreter. Otherwise it will be + * hidden. */ } CmdInfo; /* * The built-in commands, and the procedures that implement them: */ static CmdInfo builtInCmds[] = { /* - * Commands in the generic core. + * Commands in the generic core. */ {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, 1}, {"array", Tcl_ArrayObjCmd, (CompileProc *) NULL, 1}, {"binary", Tcl_BinaryObjCmd, (CompileProc *) NULL, 1}, @@ -60,11 +110,11 @@ {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, 1}, {"case", Tcl_CaseObjCmd, (CompileProc *) NULL, 1}, {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, 1}, {"concat", Tcl_ConcatObjCmd, (CompileProc *) NULL, 1}, {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, 1}, - {"dict", Tcl_DictObjCmd, (CompileProc *) NULL, 1}, + {"dict", Tcl_DictObjCmd, TclCompileDictCmd, 1}, {"encoding", Tcl_EncodingObjCmd, (CompileProc *) NULL, 0}, {"error", Tcl_ErrorObjCmd, (CompileProc *) NULL, 1}, {"eval", Tcl_EvalObjCmd, (CompileProc *) NULL, 1}, {"exit", Tcl_ExitObjCmd, (CompileProc *) NULL, 0}, {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, 1}, @@ -142,26 +192,66 @@ {"source", Tcl_SourceObjCmd, (CompileProc *) NULL, 0}, #endif /* TCL_GENERIC_ONLY */ {NULL, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 0} }; +/* + * Math functions + */ + +typedef struct { + CONST char* name; /* Name of the function */ + Tcl_ObjCmdProc* objCmdProc; /* Procedure that evaluates the function */ + ClientData clientData; /* Client data for the procedure */ +} BuiltinFuncDef; +static BuiltinFuncDef BuiltinFuncTable[] = { + { "::tcl::mathfunc::abs", ExprAbsFunc, NULL }, + { "::tcl::mathfunc::acos", ExprUnaryFunc, (ClientData) acos }, + { "::tcl::mathfunc::asin", ExprUnaryFunc, (ClientData) asin }, + { "::tcl::mathfunc::atan", ExprUnaryFunc, (ClientData) atan }, + { "::tcl::mathfunc::atan2", ExprBinaryFunc, (ClientData) atan2 }, + { "::tcl::mathfunc::bool", ExprBoolFunc, NULL }, + { "::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", ExprFloorFunc, NULL }, + { "::tcl::mathfunc::fmod", ExprBinaryFunc, (ClientData) fmod }, + { "::tcl::mathfunc::hypot", ExprBinaryFunc, (ClientData) hypot }, + { "::tcl::mathfunc::int", ExprIntFunc, NULL }, + { "::tcl::mathfunc::log", ExprUnaryFunc, (ClientData) log }, + { "::tcl::mathfunc::log10", ExprUnaryFunc, (ClientData) log10 }, + { "::tcl::mathfunc::pow", ExprBinaryFunc, (ClientData) pow }, + { "::tcl::mathfunc::rand", ExprRandFunc, NULL }, + { "::tcl::mathfunc::round", ExprRoundFunc, NULL }, + { "::tcl::mathfunc::sin", ExprUnaryFunc, (ClientData) sin }, + { "::tcl::mathfunc::sinh", ExprUnaryFunc, (ClientData) sinh }, + { "::tcl::mathfunc::sqrt", ExprSqrtFunc, NULL }, + { "::tcl::mathfunc::srand", ExprSrandFunc, NULL }, + { "::tcl::mathfunc::tan", ExprUnaryFunc, (ClientData) tan }, + { "::tcl::mathfunc::tanh", ExprUnaryFunc, (ClientData) tanh }, + { "::tcl::mathfunc::wide", ExprWideFunc, NULL }, + { NULL, NULL, NULL } +}; + /* *---------------------------------------------------------------------- * * Tcl_CreateInterp -- * * Create a new TCL command interpreter. * * Results: - * The return value is a token for the interpreter, which may be - * used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or - * Tcl_DeleteInterp. + * The return value is a token for the interpreter, which may be used in + * calls to procedures like Tcl_CreateCmd, Tcl_Eval, or Tcl_DeleteInterp. * * Side effects: - * The command interpreter is initialized with the built-in commands - * and with the variables documented in tclvars(n). + * The command interpreter is initialized with the built-in commands and + * with the variables documented in tclvars(n). * *---------------------------------------------------------------------- */ Tcl_Interp * @@ -168,14 +258,13 @@ Tcl_CreateInterp() { Interp *iPtr; Tcl_Interp *interp; Command *cmdPtr; - BuiltinFunc *builtinFuncPtr; - MathFunc *mathFuncPtr; - Tcl_HashEntry *hPtr; + BuiltinFuncDef *builtinFuncPtr; const CmdInfo *cmdInfoPtr; + Tcl_Namespace* mathfuncNSPtr; int i; union { char c[sizeof(short)]; short s; } order; @@ -184,23 +273,23 @@ #endif /* TCL_COMPILE_STATS */ TclInitSubsystems(); /* - * Panic if someone updated the CallFrame structure without - * also updating the Tcl_CallFrame structure (or vice versa). - */ + * Panic if someone updated the CallFrame structure without also updating + * the Tcl_CallFrame structure (or vice versa). + */ if (sizeof(Tcl_CallFrame) != sizeof(CallFrame)) { /*NOTREACHED*/ - Tcl_Panic("Tcl_CallFrame and CallFrame are not the same size"); + Tcl_Panic("Tcl_CallFrame and CallFrame are not the same size"); } /* * Initialize support for namespaces and create the global namespace - * (whose name is ""; an alias is "::"). This also initializes the - * Tcl object type table and other object management code. + * (whose name is ""; an alias is "::"). This also initializes the Tcl + * object type table and other object management code. */ iPtr = (Interp *) ckalloc(sizeof(Interp)); interp = (Tcl_Interp *) iPtr; @@ -211,11 +300,10 @@ Tcl_IncrRefCount(iPtr->objResultPtr); iPtr->handle = TclHandleCreate(iPtr); iPtr->globalNsPtr = NULL; iPtr->hiddenCmdTablePtr = NULL; iPtr->interpInfo = NULL; - Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS); iPtr->numLevels = 0; iPtr->maxNestingDepth = MAX_NESTING_DEPTH; iPtr->framePtr = NULL; iPtr->varFramePtr = NULL; @@ -226,11 +314,11 @@ iPtr->eiVar = Tcl_NewStringObj("errorInfo", -1); Tcl_IncrRefCount(iPtr->eiVar); iPtr->errorCode = NULL; iPtr->ecVar = Tcl_NewStringObj("errorCode", -1); Tcl_IncrRefCount(iPtr->ecVar); - iPtr->returnLevel = 0; + iPtr->returnLevel = 1; iPtr->returnCode = TCL_OK; iPtr->appendResult = NULL; iPtr->appendAvl = 0; iPtr->appendUsed = 0; @@ -248,20 +336,20 @@ iPtr->tracePtr = NULL; iPtr->tracesForbiddingInline = 0; iPtr->activeCmdTracePtr = NULL; iPtr->activeInterpTracePtr = NULL; iPtr->assocData = (Tcl_HashTable *) NULL; - iPtr->execEnvPtr = NULL; /* set after namespaces initialized */ - iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */ + iPtr->execEnvPtr = NULL; /* set after namespaces initialized */ + iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */ Tcl_IncrRefCount(iPtr->emptyObjPtr); iPtr->resultSpace[0] = 0; - iPtr->globalNsPtr = NULL; /* force creation of global ns below */ + iPtr->globalNsPtr = NULL; /* force creation of global ns below */ iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "", (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); if (iPtr->globalNsPtr == NULL) { - Tcl_Panic("Tcl_CreateInterp: can't create global namespace"); + Tcl_Panic("Tcl_CreateInterp: can't create global namespace"); } /* * Initialize support for code compilation and execution. We call * TclCreateExecEnv after initializing namespaces since it tries to @@ -269,10 +357,16 @@ * variable). */ iPtr->execEnvPtr = TclCreateExecEnv(interp); + /* + * TIP #219, Tcl Channel Reflection API support. + */ + + iPtr->chanMsg = NULL; + /* * Initialize the compilation and execution statistics kept for this * interpreter. */ @@ -291,23 +385,22 @@ (VOID *) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount)); (VOID *) memset(statsPtr->byteCodeCount, 0, sizeof(statsPtr->byteCodeCount)); (VOID *) memset(statsPtr->lifetimeCount, 0, sizeof(statsPtr->lifetimeCount)); - + statsPtr->currentInstBytes = 0.0; statsPtr->currentLitBytes = 0.0; statsPtr->currentExceptBytes = 0.0; statsPtr->currentAuxBytes = 0.0; statsPtr->currentCmdMapBytes = 0.0; - + statsPtr->numLiteralsCreated = 0; statsPtr->totalLitStringBytes = 0.0; statsPtr->currentLitStringBytes = 0.0; - (VOID *) memset(statsPtr->literalCount, 0, - sizeof(statsPtr->literalCount)); -#endif /* TCL_COMPILE_STATS */ + (VOID *) memset(statsPtr->literalCount, 0, sizeof(statsPtr->literalCount)); +#endif /* TCL_COMPILE_STATS */ /* * Initialise the stub table pointer. */ @@ -327,30 +420,30 @@ TclInitLimitSupport(interp); /* * Create the core commands. Do it here, rather than calling - * Tcl_CreateCommand, because it's faster (there's no need to check for - * a pre-existing command by the same name). If a command has a - * Tcl_CmdProc but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to - * TclInvokeStringCommand. This is an object-based wrapper procedure - * that extracts strings, calls the string procedure, and creates an - * object for the result. Similarly, if a command has a Tcl_ObjCmdProc - * but no Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand. + * Tcl_CreateCommand, because it's faster (there's no need to check for a + * pre-existing command by the same name). If a command has a Tcl_CmdProc + * but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to + * TclInvokeStringCommand. This is an object-based wrapper procedure that + * extracts strings, calls the string procedure, and creates an object for + * the result. Similarly, if a command has a Tcl_ObjCmdProc but no + * Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand. */ for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { int new; Tcl_HashEntry *hPtr; if ((cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) - && (cmdInfoPtr->compileProc == (CompileProc *) NULL)) { + && (cmdInfoPtr->compileProc == (CompileProc *) NULL)) { Tcl_Panic("Tcl_CreateInterp: builtin command with NULL object command proc and a NULL compile proc\n"); } - + hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable, - cmdInfoPtr->name, &new); + cmdInfoPtr->name, &new); if (new) { cmdPtr = (Command *) ckalloc(sizeof(Command)); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = iPtr->globalNsPtr; cmdPtr->refCount = 1; @@ -368,64 +461,92 @@ Tcl_SetHashValue(hPtr, cmdPtr); } } /* - * Register the clock commands. These *do* go through + * Register clock and chan subcommands. These *do* go through * Tcl_CreateObjCommand, since they aren't in the global namespace. */ - Tcl_CreateObjCommand( interp, "::tcl::clock::clicks", - TclClockClicksObjCmd, (ClientData) NULL, - (Tcl_CmdDeleteProc*) NULL ); - Tcl_CreateObjCommand( interp, "::tcl::clock::getenv", - TclClockGetenvObjCmd, (ClientData) NULL, - (Tcl_CmdDeleteProc*) NULL ); - Tcl_CreateObjCommand( interp, "::tcl::clock::microseconds", - TclClockMicrosecondsObjCmd, (ClientData) NULL, - (Tcl_CmdDeleteProc*) NULL ); - Tcl_CreateObjCommand( interp, "::tcl::clock::milliseconds", - TclClockMillisecondsObjCmd, (ClientData) NULL, - (Tcl_CmdDeleteProc*) NULL ); - Tcl_CreateObjCommand( interp, "::tcl::clock::seconds", + Tcl_CreateObjCommand(interp, "::tcl::clock::clicks", + TclClockClicksObjCmd, (ClientData) NULL, + (Tcl_CmdDeleteProc*) NULL); + Tcl_CreateObjCommand(interp, "::tcl::clock::getenv", + TclClockGetenvObjCmd, (ClientData) NULL, + (Tcl_CmdDeleteProc*) NULL); + Tcl_CreateObjCommand(interp, "::tcl::clock::microseconds", + TclClockMicrosecondsObjCmd, (ClientData) NULL, + (Tcl_CmdDeleteProc*) NULL); + Tcl_CreateObjCommand(interp, "::tcl::clock::milliseconds", + TclClockMillisecondsObjCmd, (ClientData) NULL, + (Tcl_CmdDeleteProc*) NULL); + Tcl_CreateObjCommand(interp, "::tcl::clock::seconds", TclClockSecondsObjCmd, (ClientData) NULL, - (Tcl_CmdDeleteProc*) NULL ); - Tcl_CreateObjCommand( interp, "::tcl::clock::Localtime", + (Tcl_CmdDeleteProc*) NULL); + Tcl_CreateObjCommand(interp, "::tcl::clock::Localtime", TclClockLocaltimeObjCmd, (ClientData) NULL, - (Tcl_CmdDeleteProc*) NULL ); - Tcl_CreateObjCommand( interp, "::tcl::clock::Mktime", + (Tcl_CmdDeleteProc*) NULL); + Tcl_CreateObjCommand(interp, "::tcl::clock::Mktime", TclClockMktimeObjCmd, (ClientData) NULL, - (Tcl_CmdDeleteProc*) NULL ); - Tcl_CreateObjCommand( interp, "::tcl::clock::Oldscan", + (Tcl_CmdDeleteProc*) NULL); + Tcl_CreateObjCommand(interp, "::tcl::clock::Oldscan", TclClockOldscanObjCmd, (ClientData) NULL, - (Tcl_CmdDeleteProc*) NULL ); + (Tcl_CmdDeleteProc*) NULL); + /* TIP #208 */ + Tcl_CreateObjCommand(interp, "::tcl::chan::Truncate", + TclChanTruncateObjCmd, (ClientData) NULL, + (Tcl_CmdDeleteProc*) NULL); + /* TIP #219 */ + Tcl_CreateObjCommand(interp, "::tcl::chan::rCreate", + TclChanCreateObjCmd, (ClientData) NULL, + (Tcl_CmdDeleteProc*) NULL); - /* Register the default [interp bgerror] handler. */ + Tcl_CreateObjCommand(interp, "::tcl::chan::rPostevent", + TclChanPostEventObjCmd, (ClientData) NULL, + (Tcl_CmdDeleteProc*) NULL); - Tcl_CreateObjCommand( interp, "::tcl::Bgerror", + /* + * Register the built-in functions + */ + + + /* + * Register the default [interp bgerror] handler. + */ + + Tcl_CreateObjCommand(interp, "::tcl::Bgerror", TclDefaultBgErrorHandlerObjCmd, (ClientData) NULL, - (Tcl_CmdDeleteProc*) NULL ); + (Tcl_CmdDeleteProc*) NULL); + + /* + * Register the unsupported encoding search path command. + */ + + Tcl_CreateObjCommand(interp, "::tcl::unsupported::EncodingDirs", + TclEncodingDirsObjCmd, NULL, NULL); /* * Register the builtin math functions. */ + mathfuncNSPtr = Tcl_CreateNamespace(interp, "::tcl::mathfunc", + (ClientData) NULL, (Tcl_NamespaceDeleteProc*) NULL); + if (mathfuncNSPtr == NULL) { + Tcl_Panic("Can't create math function namespace"); + } i = 0; - for (builtinFuncPtr = tclBuiltinFuncTable; builtinFuncPtr->name != NULL; - builtinFuncPtr++) { - Tcl_CreateMathFunc((Tcl_Interp *) iPtr, builtinFuncPtr->name, - builtinFuncPtr->numArgs, builtinFuncPtr->argTypes, - (Tcl_MathProc *) NULL, (ClientData) 0); - hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, - builtinFuncPtr->name); - if (hPtr == NULL) { - Tcl_Panic("Tcl_CreateInterp: Tcl_CreateMathFunc incorrectly registered '%s'", builtinFuncPtr->name); - return NULL; - } - mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - mathFuncPtr->builtinFuncIndex = i; - i++; + for (;;) { + CONST char* tail; + builtinFuncPtr = &(BuiltinFuncTable[i++]); + if (builtinFuncPtr->name == NULL) { + break; + } + Tcl_CreateObjCommand(interp, builtinFuncPtr->name, + builtinFuncPtr->objCmdProc, builtinFuncPtr->clientData, + (Tcl_CmdDeleteProc*) NULL); + tail = builtinFuncPtr->name + strlen("::tcl::mathfunc::"); + Tcl_Export(interp, mathfuncNSPtr, tail, 0); } /* * Do Multiple/Safe Interps Tcl init stuff */ @@ -439,11 +560,11 @@ /* * TIP #59: Make embedded configuration information * available. */ - TclInitEmbeddedConfigurationInformation (interp); + TclInitEmbeddedConfigurationInformation(interp); /* * Compute the byte order of this machine. */ @@ -466,27 +587,26 @@ TclPrecTraceProc, (ClientData) NULL); TclpSetVariables(interp); #ifdef TCL_THREADS /* - * The existence of the "threaded" element of the tcl_platform array indicates - * that this particular Tcl shell has been compiled with threads turned on. - * Using "info exists tcl_platform(threaded)" a Tcl script can introspect on the - * interpreter level of thread safety. + * The existence of the "threaded" element of the tcl_platform array + * indicates that this particular Tcl shell has been compiled with threads + * turned on. Using "info exists tcl_platform(threaded)" a Tcl script can + * introspect on the interpreter level of thread safety. */ - Tcl_SetVar2(interp, "tcl_platform", "threaded", "1", - TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_platform", "threaded", "1", TCL_GLOBAL_ONLY); #endif /* * Register Tcl's version number. */ Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs); - + #ifdef Tcl_InitStubs #undef Tcl_InitStubs #endif Tcl_InitStubs(interp, TCL_VERSION, 1); @@ -496,12 +616,11 @@ /* *---------------------------------------------------------------------- * * TclHideUnsafeCommands -- * - * Hides base commands that are not marked as safe from this - * interpreter. + * Hides base commands that are not marked as safe from this interpreter. * * Results: * TCL_OK if it succeeds, TCL_ERROR else. * * Side effects: @@ -515,68 +634,63 @@ Tcl_Interp *interp; /* Hide commands in this interpreter. */ { register const CmdInfo *cmdInfoPtr; if (interp == (Tcl_Interp *) NULL) { - return TCL_ERROR; + return TCL_ERROR; } for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { - if (!cmdInfoPtr->isSafe) { - Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); - } + if (!cmdInfoPtr->isSafe) { + Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); + } } return TCL_OK; } /* *-------------------------------------------------------------- * * Tcl_CallWhenDeleted -- * - * Arrange for a procedure to be called before a given - * interpreter is deleted. The procedure is called as soon - * as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is - * called on an interpreter that has already been deleted, - * the procedure will be called when the last Tcl_Release is - * done on the interpreter. + * Arrange for a procedure to be called before a given interpreter is + * deleted. The procedure is called as soon as Tcl_DeleteInterp is + * called; if Tcl_CallWhenDeleted is called on an interpreter that has + * already been deleted, the procedure will be called when the last + * Tcl_Release is done on the interpreter. * * Results: * None. * * Side effects: - * When Tcl_DeleteInterp is invoked to delete interp, - * proc will be invoked. See the manual entry for - * details. + * When Tcl_DeleteInterp is invoked to delete interp, proc will be + * invoked. See the manual entry for details. * *-------------------------------------------------------------- */ void Tcl_CallWhenDeleted(interp, proc, clientData) Tcl_Interp *interp; /* Interpreter to watch. */ - Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter - * is about to be deleted. */ + Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter is about + * to be deleted. */ ClientData clientData; /* One-word value to pass to proc. */ { Interp *iPtr = (Interp *) interp; - static int assocDataCounter = 0; -#ifdef TCL_THREADS - static Tcl_Mutex assocMutex; -#endif + static Tcl_ThreadDataKey assocDataCounterKey; + int *assocDataCounterPtr = + Tcl_GetThreadData(&assocDataCounterKey, (int)sizeof(int)); int new; char buffer[32 + TCL_INTEGER_SPACE]; AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData)); Tcl_HashEntry *hPtr; - Tcl_MutexLock(&assocMutex); - sprintf(buffer, "Assoc Data Key #%d", assocDataCounter); - assocDataCounter++; - Tcl_MutexUnlock(&assocMutex); + sprintf(buffer, "Assoc Data Key #%d", *assocDataCounterPtr); + (*assocDataCounterPtr)++; if (iPtr->assocData == (Tcl_HashTable *) NULL) { - iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); + iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); } hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new); dPtr->proc = proc; dPtr->clientData = clientData; Tcl_SetHashValue(hPtr, dPtr); @@ -585,30 +699,29 @@ /* *-------------------------------------------------------------- * * Tcl_DontCallWhenDeleted -- * - * Cancel the arrangement for a procedure to be called when - * a given interpreter is deleted. + * Cancel the arrangement for a procedure to be called when a given + * interpreter is deleted. * * Results: * None. * * Side effects: - * If proc and clientData were previously registered as a - * callback via Tcl_CallWhenDeleted, they are unregistered. - * If they weren't previously registered then nothing - * happens. + * If proc and clientData were previously registered as a callback via + * Tcl_CallWhenDeleted, they are unregistered. If they weren't previously + * registered then nothing happens. * *-------------------------------------------------------------- */ void Tcl_DontCallWhenDeleted(interp, proc, clientData) Tcl_Interp *interp; /* Interpreter to watch. */ - Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter - * is about to be deleted. */ + Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter is about + * to be deleted. */ ClientData clientData; /* One-word value to pass to proc. */ { Interp *iPtr = (Interp *) interp; Tcl_HashTable *hTablePtr; Tcl_HashSearch hSearch; @@ -615,32 +728,32 @@ Tcl_HashEntry *hPtr; AssocData *dPtr; hTablePtr = iPtr->assocData; if (hTablePtr == (Tcl_HashTable *) NULL) { - return; + return; } for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - dPtr = (AssocData *) Tcl_GetHashValue(hPtr); - if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) { - ckfree((char *) dPtr); - Tcl_DeleteHashEntry(hPtr); - return; - } + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) { + ckfree((char *) dPtr); + Tcl_DeleteHashEntry(hPtr); + return; + } } } /* *---------------------------------------------------------------------- * * Tcl_SetAssocData -- * * Creates a named association between user-specified data, a delete - * function and this interpreter. If the association already exists - * the data is overwritten with the new data. The delete function will - * be invoked when the interpreter is deleted. + * function and this interpreter. If the association already exists the + * data is overwritten with the new data. The delete function will be + * invoked when the interpreter is deleted. * * Results: * None. * * Side effects: @@ -651,28 +764,28 @@ void Tcl_SetAssocData(interp, name, proc, clientData) Tcl_Interp *interp; /* Interpreter to associate with. */ CONST char *name; /* Name for association. */ - Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is - * about to be deleted. */ + Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is about to + * be deleted. */ ClientData clientData; /* One-word value to pass to proc. */ { Interp *iPtr = (Interp *) interp; AssocData *dPtr; Tcl_HashEntry *hPtr; int new; if (iPtr->assocData == (Tcl_HashTable *) NULL) { - iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); + iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); } hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new); if (new == 0) { - dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); } else { - dPtr = (AssocData *) ckalloc(sizeof(AssocData)); + dPtr = (AssocData *) ckalloc(sizeof(AssocData)); } dPtr->proc = proc; dPtr->clientData = clientData; Tcl_SetHashValue(hPtr, dPtr); @@ -681,12 +794,12 @@ /* *---------------------------------------------------------------------- * * Tcl_DeleteAssocData -- * - * Deletes a named association of user-specified data with - * the specified interpreter. + * Deletes a named association of user-specified data with the specified + * interpreter. * * Results: * None. * * Side effects: @@ -695,27 +808,27 @@ *---------------------------------------------------------------------- */ void Tcl_DeleteAssocData(interp, name) - Tcl_Interp *interp; /* Interpreter to associate with. */ - CONST char *name; /* Name of association. */ + Tcl_Interp *interp; /* Interpreter to associate with. */ + CONST char *name; /* Name of association. */ { Interp *iPtr = (Interp *) interp; AssocData *dPtr; Tcl_HashEntry *hPtr; if (iPtr->assocData == (Tcl_HashTable *) NULL) { - return; + return; } hPtr = Tcl_FindHashEntry(iPtr->assocData, name); if (hPtr == (Tcl_HashEntry *) NULL) { - return; + return; } dPtr = (AssocData *) Tcl_GetHashValue(hPtr); if (dPtr->proc != NULL) { - (dPtr->proc) (dPtr->clientData, interp); + (dPtr->proc) (dPtr->clientData, interp); } ckfree((char *) dPtr); Tcl_DeleteHashEntry(hPtr); } @@ -722,12 +835,12 @@ /* *---------------------------------------------------------------------- * * Tcl_GetAssocData -- * - * Returns the client data associated with this name in the - * specified interpreter. + * Returns the client data associated with this name in the specified + * interpreter. * * Results: * The client data in the AssocData record denoted by the named * association, or NULL. * @@ -737,40 +850,41 @@ *---------------------------------------------------------------------- */ ClientData Tcl_GetAssocData(interp, name, procPtr) - Tcl_Interp *interp; /* Interpreter associated with. */ - CONST char *name; /* Name of association. */ - Tcl_InterpDeleteProc **procPtr; /* Pointer to place to store address - * of current deletion callback. */ + Tcl_Interp *interp; /* Interpreter associated with. */ + CONST char *name; /* Name of association. */ + Tcl_InterpDeleteProc **procPtr; + /* Pointer to place to store address of + * current deletion callback. */ { Interp *iPtr = (Interp *) interp; AssocData *dPtr; Tcl_HashEntry *hPtr; if (iPtr->assocData == (Tcl_HashTable *) NULL) { - return (ClientData) NULL; + return (ClientData) NULL; } hPtr = Tcl_FindHashEntry(iPtr->assocData, name); if (hPtr == (Tcl_HashEntry *) NULL) { - return (ClientData) NULL; + return (ClientData) NULL; } dPtr = (AssocData *) Tcl_GetHashValue(hPtr); if (procPtr != (Tcl_InterpDeleteProc **) NULL) { - *procPtr = dPtr->proc; + *procPtr = dPtr->proc; } return dPtr->clientData; } /* *---------------------------------------------------------------------- * * Tcl_InterpDeleted -- * - * Returns nonzero if the interpreter has been deleted with a call - * to Tcl_DeleteInterp. + * Returns nonzero if the interpreter has been deleted with a call to + * Tcl_DeleteInterp. * * Results: * Nonzero if the interpreter is deleted, zero otherwise. * * Side effects: @@ -789,15 +903,15 @@ /* *---------------------------------------------------------------------- * * Tcl_DeleteInterp -- * - * Ensures that the interpreter will be deleted eventually. If there - * are no Tcl_Preserve calls in effect for this interpreter, it is - * deleted immediately, otherwise the interpreter is deleted when - * the last Tcl_Preserve is matched by a call to Tcl_Release. In either - * case, the procedure runs the currently registered deletion callbacks. + * Ensures that the interpreter will be deleted eventually. If there are + * no Tcl_Preserve calls in effect for this interpreter, it is deleted + * immediately, otherwise the interpreter is deleted when the last + * Tcl_Preserve is matched by a call to Tcl_Release. In either case, the + * procedure runs the currently registered deletion callbacks. * * Results: * None. * * Side effects: @@ -809,64 +923,71 @@ *---------------------------------------------------------------------- */ void Tcl_DeleteInterp(interp) - Tcl_Interp *interp; /* Token for command interpreter (returned - * by a previous call to Tcl_CreateInterp). */ + Tcl_Interp *interp; /* Token for command interpreter (returned by + * a previous call to Tcl_CreateInterp). */ { Interp *iPtr = (Interp *) interp; /* * If the interpreter has already been marked deleted, just punt. */ if (iPtr->flags & DELETED) { - return; + return; } - + /* * Mark the interpreter as deleted. No further evals will be allowed. * Increase the compileEpoch as a signal to compiled bytecodes. */ iPtr->flags |= DELETED; iPtr->compileEpoch++; + /* + * TIP #219, Tcl Channel Reflection API. Discard a leftover state. + */ + + if (iPtr->chanMsg != NULL) { + Tcl_DecrRefCount (iPtr->chanMsg); + iPtr->chanMsg = NULL; + } /* * Ensure that the interpreter is eventually deleted. */ - Tcl_EventuallyFree((ClientData) interp, - (Tcl_FreeProc *) DeleteInterpProc); + Tcl_EventuallyFree((ClientData) interp, (Tcl_FreeProc *) DeleteInterpProc); } /* *---------------------------------------------------------------------- * * DeleteInterpProc -- * - * Helper procedure to delete an interpreter. This procedure is - * called when the last call to Tcl_Preserve on this interpreter - * is matched by a call to Tcl_Release. The procedure cleans up - * all resources used in the interpreter and calls all currently - * registered interpreter deletion callbacks. + * Helper procedure to delete an interpreter. This procedure is called + * when the last call to Tcl_Preserve on this interpreter is matched by a + * call to Tcl_Release. The procedure cleans up all resources used in the + * interpreter and calls all currently registered interpreter deletion + * callbacks. * * Results: * None. * * Side effects: - * Whatever the interpreter deletion callbacks do. Frees resources - * used by the interpreter. + * Whatever the interpreter deletion callbacks do. Frees resources used + * by the interpreter. * *---------------------------------------------------------------------- */ static void DeleteInterpProc(interp) - Tcl_Interp *interp; /* Interpreter to delete. */ + Tcl_Interp *interp; /* Interpreter to delete. */ { Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_HashTable *hTablePtr; @@ -873,28 +994,27 @@ ResolverScheme *resPtr, *nextResPtr; /* * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup. */ - + if (iPtr->numLevels > 0) { - Tcl_Panic("DeleteInterpProc called with active evals"); + Tcl_Panic("DeleteInterpProc called with active evals"); } /* - * The interpreter should already be marked deleted; otherwise how - * did we get here? + * The interpreter should already be marked deleted; otherwise how did we + * get here? */ if (!(iPtr->flags & DELETED)) { - Tcl_Panic("DeleteInterpProc called on interpreter not marked deleted"); + Tcl_Panic("DeleteInterpProc called on interpreter not marked deleted"); } /* - * Shut down all limit handler callback scripts that call back - * into this interpreter. Then eliminate all limit handlers for - * this interpreter. + * Shut down all limit handler callback scripts that call back into this + * interpreter. Then eliminate all limit handlers for this interpreter. */ TclRemoveScriptLimitCallbacks(interp); TclLimitRemoveAllHandlers(interp); @@ -904,81 +1024,70 @@ * * Dismantle the namespace after freeing the iPtr->handle so that each * bytecode releases its literals without caring to update the literal * table, as it will be freed later in this function without further use. */ - + TclCleanupLiteralTable(interp, &(iPtr->literalTable)); TclHandleFree(iPtr->handle); TclTeardownNamespace(iPtr->globalNsPtr); /* * Delete all the hidden commands. */ - + hTablePtr = iPtr->hiddenCmdTablePtr; if (hTablePtr != NULL) { /* - * Non-pernicious deletion. The deletion callbacks will not be - * allowed to create any new hidden or non-hidden commands. + * Non-pernicious deletion. The deletion callbacks will not be allowed + * to create any new hidden or non-hidden commands. * Tcl_DeleteCommandFromToken() will remove the entry from the * hiddenCmdTablePtr. */ - + hPtr = Tcl_FirstHashEntry(hTablePtr, &search); - for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { Tcl_DeleteCommandFromToken(interp, (Tcl_Command) Tcl_GetHashValue(hPtr)); } Tcl_DeleteHashTable(hTablePtr); ckfree((char *) hTablePtr); } - /* - * Tear down the math function table. - */ - - for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { - ckfree((char *) Tcl_GetHashValue(hPtr)); - } - Tcl_DeleteHashTable(&iPtr->mathFuncTable); /* * Invoke deletion callbacks; note that a callback can create new * callbacks, so we iterate. */ while (iPtr->assocData != (Tcl_HashTable *) NULL) { AssocData *dPtr; - - hTablePtr = iPtr->assocData; - iPtr->assocData = (Tcl_HashTable *) NULL; - for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search); - hPtr != NULL; - hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) { - dPtr = (AssocData *) Tcl_GetHashValue(hPtr); - Tcl_DeleteHashEntry(hPtr); - if (dPtr->proc != NULL) { - (*dPtr->proc)(dPtr->clientData, interp); - } - ckfree((char *) dPtr); - } - Tcl_DeleteHashTable(hTablePtr); - ckfree((char *) hTablePtr); + + hTablePtr = iPtr->assocData; + iPtr->assocData = (Tcl_HashTable *) NULL; + for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) { + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + if (dPtr->proc != NULL) { + (*dPtr->proc)(dPtr->clientData, interp); + } + ckfree((char *) dPtr); + } + Tcl_DeleteHashTable(hTablePtr); + ckfree((char *) hTablePtr); } /* * Finish deleting the global namespace. */ - + Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr); /* - * Free up the result *after* deleting variables, since variable - * deletion could have transferred ownership of the result string - * to Tcl. + * Free up the result *after* deleting variables, since variable deletion + * could have transferred ownership of the result string to Tcl. */ Tcl_FreeResult(interp); interp->result = NULL; Tcl_DecrRefCount(iPtr->objResultPtr); @@ -996,11 +1105,11 @@ if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); } if (iPtr->appendResult != NULL) { ckfree(iPtr->appendResult); - iPtr->appendResult = NULL; + iPtr->appendResult = NULL; } TclFreePackageInfo(iPtr); while (iPtr->tracePtr != NULL) { Tcl_DeleteTrace((Tcl_Interp*) iPtr, (Tcl_Trace) iPtr->tracePtr); } @@ -1013,13 +1122,13 @@ resPtr = iPtr->resolverPtr; while (resPtr) { nextResPtr = resPtr->nextPtr; ckfree(resPtr->name); ckfree((char *) resPtr); - resPtr = nextResPtr; + resPtr = nextResPtr; } - + /* * Free up literal objects created for scripts compiled by the * interpreter. */ @@ -1030,20 +1139,20 @@ /* *--------------------------------------------------------------------------- * * Tcl_HideCommand -- * - * Makes a command hidden so that it cannot be invoked from within - * an interpreter, only from within an ancestor. + * Makes a command hidden so that it cannot be invoked from within an + * interpreter, only from within an ancestor. * * Results: - * A standard Tcl result; also leaves a message in the interp's result - * if an error occurs. + * A standard Tcl result; also leaves a message in the interp's result if + * an error occurs. * * Side effects: - * Removes a command from the command table and create an entry - * into the hidden command table under the specified token name. + * Removes a command from the command table and create an entry into the + * hidden command table under the specified token name. * *--------------------------------------------------------------------------- */ int @@ -1059,51 +1168,50 @@ Tcl_HashEntry *hPtr; int new; if (iPtr->flags & DELETED) { - /* - * The interpreter is being deleted. Do not create any new - * structures, because it is not safe to modify the interpreter. - */ - - return TCL_ERROR; + /* + * The interpreter is being deleted. Do not create any new structures, + * because it is not safe to modify the interpreter. + */ + + return TCL_ERROR; } /* * Disallow hiding of commands that are currently in a namespace or - * renaming (as part of hiding) into a namespace. - * - * (because the current implementation with a single global table - * and the needed uniqueness of names cause problems with namespaces) + * renaming (as part of hiding) into a namespace (because the current + * implementation with a single global table and the needed uniqueness of + * names cause problems with namespaces). * - * we don't need to check for "::" in cmdName because the real check is - * on the nsPtr below. + * We don't need to check for "::" in cmdName because the real check is on + * the nsPtr below. * * hiddenCmdToken is just a string which is not interpreted in any way. * It may contain :: but the string is not interpreted as a namespace * qualifier command name. Thus, hiding foo::bar to foo::bar and then * trying to expose or invoke ::foo::bar will NOT work; but if the * application always uses the same strings it will get consistent * behaviour. * - * But as we currently limit ourselves to the global namespace only - * for the source, in order to avoid potential confusion, - * lets prevent "::" in the token too. --dl + * But as we currently limit ourselves to the global namespace only for + * the source, in order to avoid potential confusion, lets prevent "::" in + * the token too. - dl */ if (strstr(hiddenCmdToken, "::") != NULL) { - Tcl_AppendResult(interp, - "cannot use namespace qualifiers in hidden command", + Tcl_AppendResult(interp, + "cannot use namespace qualifiers in hidden command", " token (rename)", (char *) NULL); - return TCL_ERROR; + return TCL_ERROR; } /* - * Find the command to hide. An error is returned if cmdName can't - * be found. Look up the command only from the global namespace. - * Full path of the command must be given if using namespaces. + * Find the command to hide. An error is returned if cmdName can't be + * found. Look up the command only from the global namespace. Full path of + * the command must be given if using namespaces. */ cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, /*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY); if (cmd == (Tcl_Command) NULL) { @@ -1113,83 +1221,82 @@ /* * Check that the command is really in global namespace */ - if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) { - Tcl_AppendResult(interp, "can only hide global namespace commands", + if (cmdPtr->nsPtr != iPtr->globalNsPtr) { + Tcl_AppendResult(interp, "can only hide global namespace commands", " (use rename then hide)", (char *) NULL); - return TCL_ERROR; + return TCL_ERROR; } - + /* * Initialize the hidden command table if necessary. */ hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; if (hiddenCmdTablePtr == NULL) { - hiddenCmdTablePtr = (Tcl_HashTable *) - ckalloc((unsigned) sizeof(Tcl_HashTable)); - Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS); + hiddenCmdTablePtr = (Tcl_HashTable *) + ckalloc((unsigned) sizeof(Tcl_HashTable)); + Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS); iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr; } /* * It is an error to move an exposed command to a hidden command with * hiddenCmdToken if a hidden command with the name hiddenCmdToken already * exists. */ - + hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &new); if (!new) { - Tcl_AppendResult(interp, "hidden command named \"", hiddenCmdToken, + Tcl_AppendResult(interp, "hidden command named \"", hiddenCmdToken, "\" already exists", (char *) NULL); - return TCL_ERROR; + return TCL_ERROR; } /* * Nb : This code is currently 'like' a rename to a specialy set apart - * name table. Changes here and in TclRenameCommand must - * be kept in synch untill the common parts are actually - * factorized out. + * name table. Changes here and in TclRenameCommand must be kept in synch + * untill the common parts are actually factorized out. */ /* * Remove the hash entry for the command from the interpreter command * table. This is like deleting the command, so bump its command epoch; * this invalidates any cached references that point to the command. */ if (cmdPtr->hPtr != NULL) { - Tcl_DeleteHashEntry(cmdPtr->hPtr); - cmdPtr->hPtr = (Tcl_HashEntry *) NULL; + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = (Tcl_HashEntry *) NULL; cmdPtr->cmdEpoch++; } /* - * The list of command exported from the namespace might have - * changed. However, we do not need to recompute this just yet; - * next time we need the info will be soon enough. + * The list of command exported from the namespace might have changed. + * However, we do not need to recompute this just yet; next time we need + * the info will be soon enough. */ TclInvalidateNsCmdLookup(cmdPtr->nsPtr); /* - * Now link the hash table entry with the command structure. - * We ensured above that the nsPtr was right. + * Now link the hash table entry with the command structure. We ensured + * above that the nsPtr was right. */ - + cmdPtr->hPtr = hPtr; Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); /* * If the command being hidden has a compile procedure, increment the - * interpreter's compileEpoch to invalidate its compiled code. This - * makes sure that we don't later try to execute old code compiled with - * command-specific (i.e., inline) bytecodes for the now-hidden - * command. This field is checked in Tcl_EvalObj and ObjInterpProc, - * and code whose compilation epoch doesn't match is recompiled. + * interpreter's compileEpoch to invalidate its compiled code. This makes + * sure that we don't later try to execute old code compiled with + * command-specific (i.e., inline) bytecodes for the now-hidden command. + * This field is checked in Tcl_EvalObj and ObjInterpProc, and code whose + * compilation epoch doesn't match is recompiled. */ if (cmdPtr->compileProc != NULL) { iPtr->compileEpoch++; } @@ -1199,16 +1306,16 @@ /* *---------------------------------------------------------------------- * * Tcl_ExposeCommand -- * - * Makes a previously hidden command callable from inside the - * interpreter instead of only by its ancestors. + * Makes a previously hidden command callable from inside the interpreter + * instead of only by its ancestors. * * Results: - * A standard Tcl result. If an error occurs, a message is left - * in the interp's result. + * A standard Tcl result. If an error occurs, a message is left in the + * interp's result. * * Side effects: * Moves commands from one hash table to another. * *---------------------------------------------------------------------- @@ -1215,11 +1322,11 @@ */ int Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) Tcl_Interp *interp; /* Interpreter in which to make command - * callable. */ + * callable. */ CONST char *hiddenCmdToken; /* Name of hidden command. */ CONST char *cmdName; /* Name of to-be-exposed command. */ { Interp *iPtr = (Interp *) interp; Command *cmdPtr; @@ -1227,28 +1334,28 @@ Tcl_HashEntry *hPtr; Tcl_HashTable *hiddenCmdTablePtr; int new; if (iPtr->flags & DELETED) { - /* - * The interpreter is being deleted. Do not create any new - * structures, because it is not safe to modify the interpreter. - */ - - return TCL_ERROR; + /* + * The interpreter is being deleted. Do not create any new structures, + * because it is not safe to modify the interpreter. + */ + + return TCL_ERROR; } /* - * Check that we have a regular name for the command - * (that the user is not trying to do an expose and a rename - * (to another namespace) at the same time) + * Check that we have a regular name for the command (that the user is not + * trying to do an expose and a rename (to another namespace) at the same + * time). */ if (strstr(cmdName, "::") != NULL) { - Tcl_AppendResult(interp, "can not expose to a namespace ", + Tcl_AppendResult(interp, "can not expose to a namespace ", "(use expose to toplevel, then rename)", (char *) NULL); - return TCL_ERROR; + return TCL_ERROR; } /* * Get the command from the hidden command table: */ @@ -1257,53 +1364,53 @@ hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; if (hiddenCmdTablePtr != NULL) { hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken); } if (hPtr == (Tcl_HashEntry *) NULL) { - Tcl_AppendResult(interp, "unknown hidden command \"", hiddenCmdToken, - "\"", (char *) NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "unknown hidden command \"", hiddenCmdToken, + "\"", (char *) NULL); + return TCL_ERROR; } cmdPtr = (Command *) Tcl_GetHashValue(hPtr); - - - /* - * Check that we have a true global namespace - * command (enforced by Tcl_HideCommand() but let's double - * check. (If it was not, we would not really know how to - * handle it). - */ - if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) { - /* - * This case is theoritically impossible, - * we might rather Tcl_Panic() than 'nicely' erroring out ? - */ - Tcl_AppendResult(interp, - "trying to expose a non global command name space command", + + /* + * Check that we have a true global namespace command (enforced by + * Tcl_HideCommand() but let's double check. (If it was not, we would not + * really know how to handle it). + */ + + if (cmdPtr->nsPtr != iPtr->globalNsPtr) { + /* + * This case is theoritically impossible, we might rather Tcl_Panic() + * than 'nicely' erroring out ? + */ + + Tcl_AppendResult(interp, + "trying to expose a non global command name space command", (char *) NULL); - return TCL_ERROR; + return TCL_ERROR; } - + /* This is the global table */ nsPtr = cmdPtr->nsPtr; /* - * It is an error to overwrite an existing exposed command as a result - * of exposing a previously hidden command. + * It is an error to overwrite an existing exposed command as a result of + * exposing a previously hidden command. */ hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &new); if (!new) { - Tcl_AppendResult(interp, "exposed command \"", cmdName, - "\" already exists", (char *) NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "exposed command \"", cmdName, + "\" already exists", (char *) NULL); + return TCL_ERROR; } /* - * The list of command exported from the namespace might have - * changed. However, we do not need to recompute this just yet; - * next time we need the info will be soon enough. + * The list of command exported from the namespace might have changed. + * However, we do not need to recompute this just yet; next time we need + * the info will be soon enough. */ TclInvalidateNsCmdLookup(nsPtr); /* @@ -1310,38 +1417,37 @@ * Remove the hash entry for the command from the interpreter hidden * command table. */ if (cmdPtr->hPtr != NULL) { - Tcl_DeleteHashEntry(cmdPtr->hPtr); - cmdPtr->hPtr = NULL; + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = NULL; } /* - * Now link the hash table entry with the command structure. - * This is like creating a new command, so deal with any shadowing - * of commands in the global namespace. + * Now link the hash table entry with the command structure. This is like + * creating a new command, so deal with any shadowing of commands in the + * global namespace. */ - + cmdPtr->hPtr = hPtr; Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); /* - * Not needed as we are only in the global namespace - * (but would be needed again if we supported namespace command hiding) + * Not needed as we are only in the global namespace (but would be needed + * again if we supported namespace command hiding) * * TclResetShadowedCmdRefs(interp, cmdPtr); */ - /* * If the command being exposed has a compile procedure, increment - * interpreter's compileEpoch to invalidate its compiled code. This - * makes sure that we don't later try to execute old code compiled - * assuming the command is hidden. This field is checked in Tcl_EvalObj - * and ObjInterpProc, and code whose compilation epoch doesn't match is + * interpreter's compileEpoch to invalidate its compiled code. This makes + * sure that we don't later try to execute old code compiled assuming the + * command is hidden. This field is checked in Tcl_EvalObj and + * ObjInterpProc, and code whose compilation epoch doesn't match is * recompiled. */ if (cmdPtr->compileProc != NULL) { iPtr->compileEpoch++; @@ -1355,38 +1461,38 @@ * Tcl_CreateCommand -- * * Define a new command in a command table. * * Results: - * The return value is a token for the command, which can - * be used in future calls to Tcl_GetCommandName. + * The return value is a token for the command, which can be used in + * future calls to Tcl_GetCommandName. * * Side effects: * If a command named cmdName already exists for interp, it is deleted. * In the future, when cmdName is seen as the name of a command by * Tcl_Eval, proc will be called. To support the bytecode interpreter, * the command is created with a wrapper Tcl_ObjCmdProc - * (TclInvokeStringCommand) that eventially calls proc. When the - * command is deleted from the table, deleteProc will be called. - * See the manual entry for details on the calling sequence. + * (TclInvokeStringCommand) that eventially calls proc. When the command + * is deleted from the table, deleteProc will be called. See the manual + * entry for details on the calling sequence. * *---------------------------------------------------------------------- */ Tcl_Command Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) - Tcl_Interp *interp; /* Token for command interpreter returned by - * a previous call to Tcl_CreateInterp. */ + Tcl_Interp *interp; /* Token for command interpreter returned by a + * previous call to Tcl_CreateInterp. */ CONST char *cmdName; /* Name of command. If it contains namespace * qualifiers, the new command is put in the - * specified namespace; otherwise it is put - * in the global namespace. */ + * specified namespace; otherwise it is put in + * the global namespace. */ Tcl_CmdProc *proc; /* Procedure to associate with cmdName. */ ClientData clientData; /* Arbitrary value passed to string proc. */ Tcl_CmdDeleteProc *deleteProc; - /* If not NULL, gives a procedure to call - * when this command is deleted. */ + /* If not NULL, gives a procedure to call when + * this command is deleted. */ { Interp *iPtr = (Interp *) interp; ImportRef *oldRefPtr = NULL; Namespace *nsPtr, *dummy1, *dummy2; Command *cmdPtr, *refCmdPtr; @@ -1395,41 +1501,41 @@ int new; ImportedCmdData *dataPtr; if (iPtr->flags & DELETED) { /* - * The interpreter is being deleted. Don't create any new - * commands; it's not safe to muck with the interpreter anymore. + * The interpreter is being deleted. Don't create any new commands; + * it's not safe to muck with the interpreter anymore. */ return (Tcl_Command) NULL; } /* - * Determine where the command should reside. If its name contains - * namespace qualifiers, we put it in the specified namespace; - * otherwise, we always put it in the global namespace. + * Determine where the command should reside. If its name contains + * namespace qualifiers, we put it in the specified namespace; otherwise, + * we always put it in the global namespace. */ if (strstr(cmdName, "::") != NULL) { - TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL, - TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); - if ((nsPtr == NULL) || (tail == NULL)) { + TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL, + TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); + if ((nsPtr == NULL) || (tail == NULL)) { return (Tcl_Command) NULL; } } else { nsPtr = iPtr->globalNsPtr; tail = cmdName; } - + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); if (!new) { /* - * Command already exists. Delete the old one. - * Be careful to preserve any existing import links so we can - * restore them down below. That way, you can redefine a - * command and its import status will remain intact. + * Command already exists. Delete the old one. Be careful to preserve + * any existing import links so we can restore them down below. That + * way, you can redefine a command and its import status will remain + * intact. */ cmdPtr = (Command *) Tcl_GetHashValue(hPtr); oldRefPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = NULL; @@ -1436,25 +1542,26 @@ Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); if (!new) { /* - * If the deletion callback recreated the command, just throw - * away the new command (if we try to delete it again, we - * could get stuck in an infinite loop). + * If the deletion callback recreated the command, just throw away + * the new command (if we try to delete it again, we could get + * stuck in an infinite loop). */ ckfree((char*) Tcl_GetHashValue(hPtr)); } } else { /* - * The list of command exported from the namespace might have - * changed. However, we do not need to recompute this just - * yet; next time we need the info will be soon enough. + * The list of command exported from the namespace might have changed. + * However, we do not need to recompute this just yet; next time we + * need the info will be soon enough. */ TclInvalidateNsCmdLookup(nsPtr); + TclInvalidateNsPath(nsPtr); } cmdPtr = (Command *) ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; @@ -1470,12 +1577,12 @@ cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; /* - * Plug in any existing import references found above. Be sure - * to update all of these references to point to the new command. + * Plug in any existing import references found above. Be sure to update + * all of these references to point to the new command. */ if (oldRefPtr != NULL) { cmdPtr->importRefPtr = oldRefPtr; while (oldRefPtr != NULL) { @@ -1490,11 +1597,11 @@ * We just created a command, so in its namespace and all of its parent * namespaces, it may shadow global commands with the same name. If any * shadowed commands are found, invalidate all cached command references * in the affected namespaces. */ - + TclResetShadowedCmdRefs(interp, cmdPtr); return (Tcl_Command) cmdPtr; } /* @@ -1503,45 +1610,45 @@ * Tcl_CreateObjCommand -- * * Define a new object-based command in a command table. * * Results: - * The return value is a token for the command, which can - * be used in future calls to Tcl_GetCommandName. + * The return value is a token for the command, which can be used in + * future calls to Tcl_GetCommandName. * * Side effects: * If no command named "cmdName" already exists for interp, one is - * created. Otherwise, if a command does exist, then if the - * object-based Tcl_ObjCmdProc is TclInvokeStringCommand, we assume - * Tcl_CreateCommand was called previously for the same command and - * just set its Tcl_ObjCmdProc to the argument "proc"; otherwise, we - * delete the old command. + * created. Otherwise, if a command does exist, then if the object-based + * Tcl_ObjCmdProc is TclInvokeStringCommand, we assume Tcl_CreateCommand + * was called previously for the same command and just set its + * Tcl_ObjCmdProc to the argument "proc"; otherwise, we delete the old + * command. * * In the future, during bytecode evaluation when "cmdName" is seen as * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based * Tcl_ObjCmdProc proc will be called. When the command is deleted from - * the table, deleteProc will be called. See the manual entry for - * details on the calling sequence. + * the table, deleteProc will be called. See the manual entry for details + * on the calling sequence. * *---------------------------------------------------------------------- */ Tcl_Command Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) - Tcl_Interp *interp; /* Token for command interpreter (returned - * by previous call to Tcl_CreateInterp). */ + Tcl_Interp *interp; /* Token for command interpreter (returned by + * previous call to Tcl_CreateInterp). */ CONST char *cmdName; /* Name of command. If it contains namespace * qualifiers, the new command is put in the - * specified namespace; otherwise it is put - * in the global namespace. */ + * specified namespace; otherwise it is put in + * the global namespace. */ Tcl_ObjCmdProc *proc; /* Object-based procedure to associate with * name. */ ClientData clientData; /* Arbitrary value to pass to object * procedure. */ Tcl_CmdDeleteProc *deleteProc; - /* If not NULL, gives a procedure to call - * when this command is deleted. */ + /* If not NULL, gives a procedure to call when + * this command is deleted. */ { Interp *iPtr = (Interp *) interp; ImportRef *oldRefPtr = NULL; Namespace *nsPtr, *dummy1, *dummy2; Command *cmdPtr, *refCmdPtr; @@ -1550,81 +1657,83 @@ int new; ImportedCmdData *dataPtr; if (iPtr->flags & DELETED) { /* - * The interpreter is being deleted. Don't create any new - * commands; it's not safe to muck with the interpreter anymore. + * The interpreter is being deleted. Don't create any new commands; + * it's not safe to muck with the interpreter anymore. */ return (Tcl_Command) NULL; } /* - * Determine where the command should reside. If its name contains - * namespace qualifiers, we put it in the specified namespace; - * otherwise, we always put it in the global namespace. + * Determine where the command should reside. If its name contains + * namespace qualifiers, we put it in the specified namespace; otherwise, + * we always put it in the global namespace. */ if (strstr(cmdName, "::") != NULL) { - TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL, - TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); - if ((nsPtr == NULL) || (tail == NULL)) { + TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL, + TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); + if ((nsPtr == NULL) || (tail == NULL)) { return (Tcl_Command) NULL; } } else { nsPtr = iPtr->globalNsPtr; tail = cmdName; } hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); + TclInvalidateNsPath(nsPtr); if (!new) { cmdPtr = (Command *) Tcl_GetHashValue(hPtr); /* * Command already exists. If its object-based Tcl_ObjCmdProc is * TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the - * argument "proc". Otherwise, we delete the old command. + * argument "proc". Otherwise, we delete the old command. */ if (cmdPtr->objProc == TclInvokeStringCommand) { cmdPtr->objProc = proc; cmdPtr->objClientData = clientData; - cmdPtr->deleteProc = deleteProc; - cmdPtr->deleteData = clientData; + cmdPtr->deleteProc = deleteProc; + cmdPtr->deleteData = clientData; return (Tcl_Command) cmdPtr; } /* - * Otherwise, we delete the old command. Be careful to preserve - * any existing import links so we can restore them down below. - * That way, you can redefine a command and its import status - * will remain intact. + * Otherwise, we delete the old command. Be careful to preserve any + * existing import links so we can restore them down below. That way, + * you can redefine a command and its import status will remain + * intact. */ oldRefPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = NULL; Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); if (!new) { /* - * If the deletion callback recreated the command, just throw - * away the new command (if we try to delete it again, we - * could get stuck in an infinite loop). + * If the deletion callback recreated the command, just throw away + * the new command (if we try to delete it again, we could get + * stuck in an infinite loop). */ ckfree((char *) Tcl_GetHashValue(hPtr)); } } else { /* - * The list of command exported from the namespace might have - * changed. However, we do not need to recompute this just - * yet; next time we need the info will be soon enough. + * The list of command exported from the namespace might have changed. + * However, we do not need to recompute this just yet; next time we + * need the info will be soon enough. */ TclInvalidateNsCmdLookup(nsPtr); + TclInvalidateNsPath(nsPtr); } cmdPtr = (Command *) ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; @@ -1640,12 +1749,12 @@ cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; /* - * Plug in any existing import references found above. Be sure - * to update all of these references to point to the new command. + * Plug in any existing import references found above. Be sure to update + * all of these references to point to the new command. */ if (oldRefPtr != NULL) { cmdPtr->importRefPtr = oldRefPtr; while (oldRefPtr != NULL) { @@ -1653,18 +1762,18 @@ dataPtr = (ImportedCmdData*)refCmdPtr->objClientData; dataPtr->realCmdPtr = cmdPtr; oldRefPtr = oldRefPtr->nextPtr; } } - + /* * We just created a command, so in its namespace and all of its parent * namespaces, it may shadow global commands with the same name. If any * shadowed commands are found, invalidate all cached command references * in the affected namespaces. */ - + TclResetShadowedCmdRefs(interp, cmdPtr); return (Tcl_Command) cmdPtr; } /* @@ -1672,13 +1781,13 @@ * * TclInvokeStringCommand -- * * "Wrapper" Tcl_ObjCmdProc used to call an existing string-based * Tcl_CmdProc if no object-based procedure exists for a command. A - * pointer to this procedure is stored as the Tcl_ObjCmdProc in a - * Command structure. It simply turns around and calls the string - * Tcl_CmdProc in the Command structure. + * pointer to this procedure is stored as the Tcl_ObjCmdProc in a Command + * structure. It simply turns around and calls the string Tcl_CmdProc in + * the Command structure. * * Results: * A standard Tcl object result value. * * Side effects: @@ -1708,13 +1817,12 @@ #define NUM_ARGS 20 CONST char *(argStorage[NUM_ARGS]); CONST char **argv = argStorage; /* - * Create the string argument array "argv". Make sure argv is large - * enough to hold the objc arguments plus 1 extra for the zero - * end-of-argv word. + * Create the string argument array "argv". Make sure argv is large enough + * to hold the objc arguments plus 1 extra for the zero end-of-argv word. */ if ((objc + 1) > NUM_ARGS) { argv = (CONST char **) ckalloc((unsigned)(objc + 1) * sizeof(char *)); } @@ -1745,14 +1853,14 @@ *---------------------------------------------------------------------- * * TclInvokeObjectCommand -- * * "Wrapper" Tcl_CmdProc used to call an existing object-based - * Tcl_ObjCmdProc if no string-based procedure exists for a command. - * A pointer to this procedure is stored as the Tcl_CmdProc in a - * Command structure. It simply turns around and calls the object - * Tcl_ObjCmdProc in the Command structure. + * Tcl_ObjCmdProc if no string-based procedure exists for a command. A + * pointer to this procedure is stored as the Tcl_CmdProc in a Command + * structure. It simply turns around and calls the object Tcl_ObjCmdProc + * in the Command structure. * * Results: * A standard Tcl string result value. * * Side effects: @@ -1783,24 +1891,21 @@ #define NUM_ARGS 20 Tcl_Obj *(argStorage[NUM_ARGS]); register Tcl_Obj **objv = argStorage; /* - * Create the object argument array "objv". Make sure objv is large - * enough to hold the objc arguments plus 1 extra for the zero - * end-of-objv word. + * Create the object argument array "objv". Make sure objv is large enough + * to hold the objc arguments plus 1 extra for the zero end-of-objv word. */ if (argc > NUM_ARGS) { - objv = (Tcl_Obj **) - ckalloc((unsigned)(argc * sizeof(Tcl_Obj *))); + objv = (Tcl_Obj **) ckalloc((unsigned)(argc * sizeof(Tcl_Obj *))); } for (i = 0; i < argc; i++) { length = strlen(argv[i]); - TclNewObj(objPtr); - TclInitStringRep(objPtr, argv[i], length); + TclNewStringObj(objPtr, argv[i], length); Tcl_IncrRefCount(objPtr); objv[i] = objPtr; } /* @@ -1808,19 +1913,19 @@ */ result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv); /* - * Move the interpreter's object result to the string result, - * then reset the object result. + * Move the interpreter's object result to the string result, then reset + * the object result. */ (void) Tcl_GetStringResult(interp); - + /* - * Decrement the ref counts for the argument objects created above, - * then free the objv array if malloc'ed storage was used. + * Decrement the ref counts for the argument objects created above, then + * free the objv array if malloc'ed storage was used. */ for (i = 0; i < argc; i++) { objPtr = objv[i]; Tcl_DecrRefCount(objPtr); @@ -1835,34 +1940,34 @@ /* *---------------------------------------------------------------------- * * TclRenameCommand -- * - * Called to give an existing Tcl command a different name. Both the - * old command name and the new command name can have "::" namespace - * qualifiers. If the new command has a different namespace context, - * the command will be moved to that namespace and will execute in - * the context of that new namespace. - * - * If the new command name is NULL or the null string, the command is - * deleted. + * Called to give an existing Tcl command a different name. Both the old + * command name and the new command name can have "::" namespace + * qualifiers. If the new command has a different namespace context, the + * command will be moved to that namespace and will execute in the + * context of that new namespace. + * + * If the new command name is NULL or the null string, the command is + * deleted. * * Results: - * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * If anything goes wrong, an error message is returned in the - * interpreter's result object. + * If anything goes wrong, an error message is returned in the + * interpreter's result object. * *---------------------------------------------------------------------- */ int TclRenameCommand(interp, oldName, newName) - Tcl_Interp *interp; /* Current interpreter. */ - char *oldName; /* Existing command name. */ - char *newName; /* New command name. */ + Tcl_Interp *interp; /* Current interpreter. */ + char *oldName; /* Existing command name. */ + char *newName; /* New command name. */ { Interp *iPtr = (Interp *) interp; CONST char *newTail; Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2; Tcl_Command cmd; @@ -1871,48 +1976,47 @@ int new, result; Tcl_Obj* oldFullName; Tcl_DString newFullName; /* - * Find the existing command. An error is returned if cmdName can't - * be found. + * Find the existing command. An error is returned if cmdName can't be + * found. */ cmd = Tcl_FindCommand(interp, oldName, (Tcl_Namespace *) NULL, - /*flags*/ 0); + /*flags*/ 0); cmdPtr = (Command *) cmd; if (cmdPtr == NULL) { Tcl_AppendResult(interp, "can't ", - ((newName == NULL)||(*newName == '\0'))? "delete":"rename", - " \"", oldName, "\": command doesn't exist", (char *) NULL); + ((newName == NULL)||(*newName == '\0'))? "delete":"rename", + " \"", oldName, "\": command doesn't exist", (char *) NULL); return TCL_ERROR; } cmdNsPtr = cmdPtr->nsPtr; oldFullName = Tcl_NewObj(); - Tcl_IncrRefCount( oldFullName ); - Tcl_GetCommandFullName( interp, cmd, oldFullName ); + Tcl_IncrRefCount(oldFullName); + Tcl_GetCommandFullName(interp, cmd, oldFullName); /* * If the new command name is NULL or empty, delete the command. Do this * with Tcl_DeleteCommandFromToken, since we already have the command. */ - + if ((newName == NULL) || (*newName == '\0')) { Tcl_DeleteCommandFromToken(interp, cmd); result = TCL_OK; goto done; } /* - * Make sure that the destination command does not already exist. - * The rename operation is like creating a command, so we should - * automatically create the containing namespaces just like - * Tcl_CreateCommand would. + * Make sure that the destination command does not already exist. The + * rename operation is like creating a command, so we should automatically + * create the containing namespaces just like Tcl_CreateCommand would. */ TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL, - TCL_CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail); + TCL_CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail); if ((newNsPtr == NULL) || (newTail == NULL)) { Tcl_AppendResult(interp, "can't rename to \"", newName, "\": bad command name", (char *) NULL); result = TCL_ERROR; @@ -1924,171 +2028,168 @@ result = TCL_ERROR; goto done; } /* - * Warning: any changes done in the code here are likely - * to be needed in Tcl_HideCommand() code too. - * (until the common parts are extracted out) --dl + * Warning: any changes done in the code here are likely to be needed in + * Tcl_HideCommand() code too (until the common parts are extracted out). + * - dl */ /* - * Put the command in the new namespace so we can check for an alias - * loop. Since we are adding a new command to a namespace, we must - * handle any shadowing of the global commands that this might create. + * Put the command in the new namespace so we can check for an alias loop. + * Since we are adding a new command to a namespace, we must handle any + * shadowing of the global commands that this might create. */ - + oldHPtr = cmdPtr->hPtr; hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &new); Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = newNsPtr; TclResetShadowedCmdRefs(interp, cmdPtr); /* - * Now check for an alias loop. If we detect one, put everything back - * the way it was and report the error. + * Now check for an alias loop. If we detect one, put everything back the + * way it was and report the error. */ result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr); if (result != TCL_OK) { - Tcl_DeleteHashEntry(cmdPtr->hPtr); - cmdPtr->hPtr = oldHPtr; - cmdPtr->nsPtr = cmdNsPtr; + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = oldHPtr; + cmdPtr->nsPtr = cmdNsPtr; goto done; } /* - * The list of command exported from the namespace might have - * changed. However, we do not need to recompute this just yet; - * next time we need the info will be soon enough. These might - * refer to the same variable, but that's no big deal. + * The list of command exported from the namespace might have changed. + * However, we do not need to recompute this just yet; next time we need + * the info will be soon enough. These might refer to the same variable, + * but that's no big deal. */ TclInvalidateNsCmdLookup(cmdNsPtr); TclInvalidateNsCmdLookup(cmdPtr->nsPtr); /* - * Script for rename traces can delete the command "oldName". - * Therefore increment the reference count for cmdPtr so that - * it's Command structure is freed only towards the end of this - * function by calling TclCleanupCommand. - * - * The trace procedure needs to get a fully qualified name for - * old and new commands [Tcl bug #651271], or else there's no way - * for the trace procedure to get the namespace from which the old - * command is being renamed! - */ - - Tcl_DStringInit( &newFullName ); - Tcl_DStringAppend( &newFullName, newNsPtr->fullName, -1 ); - if ( newNsPtr != iPtr->globalNsPtr ) { - Tcl_DStringAppend( &newFullName, "::", 2 ); - } - Tcl_DStringAppend( &newFullName, newTail, -1 ); + * Script for rename traces can delete the command "oldName". Therefore + * increment the reference count for cmdPtr so that it's Command structure + * is freed only towards the end of this function by calling + * TclCleanupCommand. + * + * The trace procedure needs to get a fully qualified name for old and new + * commands [Tcl bug #651271], or else there's no way for the trace + * procedure to get the namespace from which the old command is being + * renamed! + */ + + Tcl_DStringInit(&newFullName); + Tcl_DStringAppend(&newFullName, newNsPtr->fullName, -1); + if (newNsPtr != iPtr->globalNsPtr) { + Tcl_DStringAppend(&newFullName, "::", 2); + } + Tcl_DStringAppend(&newFullName, newTail, -1); cmdPtr->refCount++; - CallCommandTraces( iPtr, cmdPtr, - Tcl_GetString( oldFullName ), - Tcl_DStringValue( &newFullName ), - TCL_TRACE_RENAME); - Tcl_DStringFree( &newFullName ); + CallCommandTraces(iPtr, cmdPtr, Tcl_GetString(oldFullName), + Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME); + Tcl_DStringFree(&newFullName); /* - * The new command name is okay, so remove the command from its - * current namespace. This is like deleting the command, so bump - * the cmdEpoch to invalidate any cached references to the command. + * The new command name is okay, so remove the command from its current + * namespace. This is like deleting the command, so bump the cmdEpoch to + * invalidate any cached references to the command. */ - + Tcl_DeleteHashEntry(oldHPtr); cmdPtr->cmdEpoch++; /* * If the command being renamed has a compile procedure, increment the - * interpreter's compileEpoch to invalidate its compiled code. This - * makes sure that we don't later try to execute old code compiled for - * the now-renamed command. + * interpreter's compileEpoch to invalidate its compiled code. This makes + * sure that we don't later try to execute old code compiled for the + * now-renamed command. */ if (cmdPtr->compileProc != NULL) { iPtr->compileEpoch++; } /* - * Now free the Command structure, if the "oldName" command has - * been deleted by invocation of rename traces. + * Now free the Command structure, if the "oldName" command has been + * deleted by invocation of rename traces. */ + TclCleanupCommand(cmdPtr); result = TCL_OK; - done: - TclDecrRefCount( oldFullName ); + done: + TclDecrRefCount(oldFullName); return result; } /* *---------------------------------------------------------------------- * * Tcl_SetCommandInfo -- * - * Modifies various information about a Tcl command. Note that - * this procedure will not change a command's namespace; use - * TclRenameCommand to do that. Also, the isNativeObjectProc - * member of *infoPtr is ignored. + * Modifies various information about a Tcl command. Note that this + * procedure will not change a command's namespace; use TclRenameCommand + * to do that. Also, the isNativeObjectProc member of *infoPtr is + * ignored. * * Results: - * If cmdName exists in interp, then the information at *infoPtr - * is stored with the command in place of the current information - * and 1 is returned. If the command doesn't exist then 0 is - * returned. + * If cmdName exists in interp, then the information at *infoPtr is + * stored with the command in place of the current information and 1 is + * returned. If the command doesn't exist then 0 is returned. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_SetCommandInfo(interp, cmdName, infoPtr) - Tcl_Interp *interp; /* Interpreter in which to look - * for command. */ - CONST char *cmdName; /* Name of desired command. */ - CONST Tcl_CmdInfo *infoPtr; /* Where to find information - * to store in the command. */ + Tcl_Interp *interp; /* Interpreter in which to look for + * command. */ + CONST char *cmdName; /* Name of desired command. */ + CONST Tcl_CmdInfo *infoPtr; /* Where to find information to store in the + * command. */ { Tcl_Command cmd; cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, - /*flags*/ 0); + /*flags*/ 0); - return Tcl_SetCommandInfoFromToken( cmd, infoPtr ); + return Tcl_SetCommandInfoFromToken(cmd, infoPtr); } /* *---------------------------------------------------------------------- * * Tcl_SetCommandInfoFromToken -- * - * Modifies various information about a Tcl command. Note that - * this procedure will not change a command's namespace; use - * TclRenameCommand to do that. Also, the isNativeObjectProc - * member of *infoPtr is ignored. + * Modifies various information about a Tcl command. Note that this + * procedure will not change a command's namespace; use TclRenameCommand + * to do that. Also, the isNativeObjectProc member of *infoPtr is + * ignored. * * Results: - * If cmdName exists in interp, then the information at *infoPtr - * is stored with the command in place of the current information - * and 1 is returned. If the command doesn't exist then 0 is - * returned. + * If cmdName exists in interp, then the information at *infoPtr is + * stored with the command in place of the current information and 1 is + * returned. If the command doesn't exist then 0 is returned. * * Side effects: * None. * *---------------------------------------------------------------------- */ int -Tcl_SetCommandInfoFromToken( cmd, infoPtr ) +Tcl_SetCommandInfoFromToken(cmd, infoPtr) Tcl_Command cmd; CONST Tcl_CmdInfo* infoPtr; { Command* cmdPtr; /* Internal representation of the command */ @@ -2097,11 +2198,11 @@ } /* * The isNativeObjectProc and nsPtr members of *infoPtr are ignored. */ - + cmdPtr = (Command *) cmd; cmdPtr->proc = infoPtr->proc; cmdPtr->clientData = infoPtr->clientData; if (infoPtr->objProc == (Tcl_ObjCmdProc *) NULL) { cmdPtr->objProc = TclInvokeStringCommand; @@ -2121,35 +2222,34 @@ * Tcl_GetCommandInfo -- * * Returns various information about a Tcl command. * * Results: - * If cmdName exists in interp, then *infoPtr is modified to - * hold information about cmdName and 1 is returned. If the - * command doesn't exist then 0 is returned and *infoPtr isn't - * modified. + * If cmdName exists in interp, then *infoPtr is modified to hold + * information about cmdName and 1 is returned. If the command doesn't + * exist then 0 is returned and *infoPtr isn't modified. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_GetCommandInfo(interp, cmdName, infoPtr) - Tcl_Interp *interp; /* Interpreter in which to look - * for command. */ - CONST char *cmdName; /* Name of desired command. */ - Tcl_CmdInfo *infoPtr; /* Where to store information about - * command. */ + Tcl_Interp *interp; /* Interpreter in which to look for + * command. */ + CONST char *cmdName; /* Name of desired command. */ + Tcl_CmdInfo *infoPtr; /* Where to store information about + * command. */ { Tcl_Command cmd; cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, - /*flags*/ 0); + /*flags*/ 0); - return Tcl_GetCommandInfoFromToken( cmd, infoPtr ); + return Tcl_GetCommandInfoFromToken(cmd, infoPtr); } /* *---------------------------------------------------------------------- @@ -2157,29 +2257,28 @@ * Tcl_GetCommandInfoFromToken -- * * Returns various information about a Tcl command. * * Results: - * Copies information from the command identified by 'cmd' into - * a caller-supplied structure and returns 1. If the 'cmd' is - * NULL, leaves the structure untouched and returns 0. + * Copies information from the command identified by 'cmd' into a + * caller-supplied structure and returns 1. If the 'cmd' is NULL, leaves + * the structure untouched and returns 0. * * Side effects: * None. * *---------------------------------------------------------------------- */ int -Tcl_GetCommandInfoFromToken( cmd, infoPtr ) +Tcl_GetCommandInfoFromToken(cmd, infoPtr) Tcl_Command cmd; Tcl_CmdInfo* infoPtr; { - Command* cmdPtr; /* Internal representation of the command */ - if ( cmd == (Tcl_Command) NULL ) { + if (cmd == (Tcl_Command) NULL) { return 0; } /* * Set isNativeObjectProc 1 if objProc was registered by a call to @@ -2204,13 +2303,13 @@ /* *---------------------------------------------------------------------- * * Tcl_GetCommandName -- * - * Given a token returned by Tcl_CreateCommand, this procedure - * returns the current name of the command (which may have changed - * due to renaming). + * Given a token returned by Tcl_CreateCommand, this procedure returns + * the current name of the command (which may have changed due to + * renaming). * * Results: * The return value is the name of the given command. * * Side effects: @@ -2221,54 +2320,54 @@ CONST char * Tcl_GetCommandName(interp, command) Tcl_Interp *interp; /* Interpreter containing the command. */ Tcl_Command command; /* Token for command returned by a previous - * call to Tcl_CreateCommand. The command - * must not have been deleted. */ + * call to Tcl_CreateCommand. The command must + * not have been deleted. */ { Command *cmdPtr = (Command *) command; if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) { - /* * This should only happen if command was "created" after the - * interpreter began to be deleted, so there isn't really any - * command. Just return an empty string. + * interpreter began to be deleted, so there isn't really any command. + * Just return an empty string. */ return ""; } + return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); } /* *---------------------------------------------------------------------- * * Tcl_GetCommandFullName -- * - * Given a token returned by, e.g., Tcl_CreateCommand or - * Tcl_FindCommand, this procedure appends to an object the command's - * full name, qualified by a sequence of parent namespace names. The - * command's fully-qualified name may have changed due to renaming. + * Given a token returned by, e.g., Tcl_CreateCommand or Tcl_FindCommand, + * this procedure appends to an object the command's full name, qualified + * by a sequence of parent namespace names. The command's fully-qualified + * name may have changed due to renaming. * * Results: * None. * * Side effects: * The command's fully-qualified name is appended to the string - * representation of objPtr. + * representation of objPtr. * *---------------------------------------------------------------------- */ void Tcl_GetCommandFullName(interp, command, objPtr) Tcl_Interp *interp; /* Interpreter containing the command. */ Tcl_Command command; /* Token for command returned by a previous - * call to Tcl_CreateCommand. The command - * must not have been deleted. */ + * call to Tcl_CreateCommand. The command must + * not have been deleted. */ Tcl_Obj *objPtr; /* Points to the object onto which the * command's full name is appended. */ { Interp *iPtr = (Interp *) interp; @@ -2300,34 +2399,33 @@ * Tcl_DeleteCommand -- * * Remove the given command from the given interpreter. * * Results: - * 0 is returned if the command was deleted successfully. - * -1 is returned if there didn't exist a command by that name. + * 0 is returned if the command was deleted successfully. -1 is returned + * if there didn't exist a command by that name. * * Side effects: - * cmdName will no longer be recognized as a valid command for - * interp. + * cmdName will no longer be recognized as a valid command for interp. * *---------------------------------------------------------------------- */ int Tcl_DeleteCommand(interp, cmdName) - Tcl_Interp *interp; /* Token for command interpreter (returned - * by a previous Tcl_CreateInterp call). */ + Tcl_Interp *interp; /* Token for command interpreter (returned by + * a previous Tcl_CreateInterp call). */ CONST char *cmdName; /* Name of command to remove. */ { Tcl_Command cmd; /* * Find the desired command and delete it. */ cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, - /*flags*/ 0); + /*flags*/ 0); if (cmd == (Tcl_Command) NULL) { return -1; } return Tcl_DeleteCommandFromToken(interp, cmd); } @@ -2336,74 +2434,83 @@ *---------------------------------------------------------------------- * * Tcl_DeleteCommandFromToken -- * * Removes the given command from the given interpreter. This procedure - * resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead - * of a command name for efficiency. + * resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead of + * a command name for efficiency. * * Results: - * 0 is returned if the command was deleted successfully. - * -1 is returned if there didn't exist a command by that name. + * 0 is returned if the command was deleted successfully. -1 is returned + * if there didn't exist a command by that name. * * Side effects: - * The command specified by "cmd" will no longer be recognized as a - * valid command for "interp". + * The command specified by "cmd" will no longer be recognized as a valid + * command for "interp". * *---------------------------------------------------------------------- */ int Tcl_DeleteCommandFromToken(interp, cmd) - Tcl_Interp *interp; /* Token for command interpreter returned by - * a previous call to Tcl_CreateInterp. */ - Tcl_Command cmd; /* Token for command to delete. */ + Tcl_Interp *interp; /* Token for command interpreter returned by a + * previous call to Tcl_CreateInterp. */ + Tcl_Command cmd; /* Token for command to delete. */ { Interp *iPtr = (Interp *) interp; Command *cmdPtr = (Command *) cmd; ImportRef *refPtr, *nextRefPtr; Tcl_Command importCmd; /* - * The code here is tricky. We can't delete the hash table entry - * before invoking the deletion callback because there are cases - * where the deletion callback needs to invoke the command (e.g. - * object systems such as OTcl). However, this means that the - * callback could try to delete or rename the command. The deleted - * flag allows us to detect these cases and skip nested deletes. + * The code here is tricky. We can't delete the hash table entry before + * invoking the deletion callback because there are cases where the + * deletion callback needs to invoke the command (e.g. object systems such + * as OTcl). However, this means that the callback could try to delete or + * rename the command. The deleted flag allows us to detect these cases + * and skip nested deletes. */ if (cmdPtr->flags & CMD_IS_DELETED) { /* - * Another deletion is already in progress. Remove the hash - * table entry now, but don't invoke a callback or free the - * command structure. + * Another deletion is already in progress. Remove the hash table + * entry now, but don't invoke a callback or free the command + * structure. Take care to only remove the hash entry if it has not + * already been removed; otherwise if we manage to hit this function + * three times, everything goes up in smoke. [Bug 1220058] */ - Tcl_DeleteHashEntry(cmdPtr->hPtr); - cmdPtr->hPtr = NULL; + if (cmdPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = NULL; + } return 0; } - /* - * We must delete this command, even though both traces and - * delete procs may try to avoid this (renaming the command etc). - * Also traces and delete procs may try to delete the command - * themsevles. This flag declares that a delete is in progress - * and that recursive deletes should be ignored. + /* + * We must delete this command, even though both traces and delete procs + * may try to avoid this (renaming the command etc). Also traces and + * delete procs may try to delete the command themsevles. This flag + * declares that a delete is in progress and that recursive deletes should + * be ignored. */ + cmdPtr->flags |= CMD_IS_DELETED; /* - * Call trace procedures for the command being deleted. Then delete - * its traces. + * Call trace procedures for the command being deleted. Then delete its + * traces. */ if (cmdPtr->tracePtr != NULL) { CommandTrace *tracePtr; CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE); - /* Now delete these traces */ + + /* + * Now delete these traces. + */ + tracePtr = cmdPtr->tracePtr; while (tracePtr != NULL) { CommandTrace *nextPtr = tracePtr->nextPtr; if ((--tracePtr->refCount) <= 0) { ckfree((char*)tracePtr); @@ -2412,76 +2519,76 @@ } cmdPtr->tracePtr = NULL; } /* - * The list of command exported from the namespace might have - * changed. However, we do not need to recompute this just yet; - * next time we need the info will be soon enough. + * The list of command exported from the namespace might have changed. + * However, we do not need to recompute this just yet; next time we need + * the info will be soon enough. */ TclInvalidateNsCmdLookup(cmdPtr->nsPtr); /* * If the command being deleted has a compile procedure, increment the - * interpreter's compileEpoch to invalidate its compiled code. This - * makes sure that we don't later try to execute old code compiled with - * command-specific (i.e., inline) bytecodes for the now-deleted - * command. This field is checked in Tcl_EvalObj and ObjInterpProc, and - * code whose compilation epoch doesn't match is recompiled. + * interpreter's compileEpoch to invalidate its compiled code. This makes + * sure that we don't later try to execute old code compiled with + * command-specific (i.e., inline) bytecodes for the now-deleted command. + * This field is checked in Tcl_EvalObj and ObjInterpProc, and code whose + * compilation epoch doesn't match is recompiled. */ if (cmdPtr->compileProc != NULL) { - iPtr->compileEpoch++; + iPtr->compileEpoch++; } if (cmdPtr->deleteProc != NULL) { /* * Delete the command's client data. If this was an imported command * created when a command was imported into a namespace, this client * data will be a pointer to a ImportedCmdData structure describing * the "real" command that this imported command refers to. */ - + /* * If you are getting a crash during the call to deleteProc and - * cmdPtr->deleteProc is a pointer to the function free(), the - * most likely cause is that your extension allocated memory - * for the clientData argument to Tcl_CreateObjCommand() with - * the ckalloc() macro and you are now trying to deallocate - * this memory with free() instead of ckfree(). You should - * pass a pointer to your own method that calls ckfree(). + * cmdPtr->deleteProc is a pointer to the function free(), the most + * likely cause is that your extension allocated memory for the + * clientData argument to Tcl_CreateObjCommand() with the ckalloc() + * macro and you are now trying to deallocate this memory with free() + * instead of ckfree(). You should pass a pointer to your own method + * that calls ckfree(). */ (*cmdPtr->deleteProc)(cmdPtr->deleteData); } /* * Bump the command epoch counter. This will invalidate all cached * references that point to this command. */ - + cmdPtr->cmdEpoch++; /* * If this command was imported into other namespaces, then imported * commands were created that refer back to this command. Delete these * imported commands now. */ for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; - refPtr = nextRefPtr) { + refPtr = nextRefPtr) { nextRefPtr = refPtr->nextPtr; importCmd = (Tcl_Command) refPtr->importedCmdPtr; - Tcl_DeleteCommandFromToken(interp, importCmd); + Tcl_DeleteCommandFromToken(interp, importCmd); } /* - * Don't use hPtr to delete the hash entry here, because it's - * possible that the deletion callback renamed the command. - * Instead, use cmdPtr->hptr, and make sure that no-one else - * has already deleted the hash entry. + * Don't use hPtr to delete the hash entry here, because it's possible + * that the deletion callback renamed the command. Instead, use + * cmdPtr->hptr, and make sure that no-one else has already deleted the + * hash entry. */ if (cmdPtr->hPtr != NULL) { Tcl_DeleteHashEntry(cmdPtr->hPtr); } @@ -2488,91 +2595,92 @@ /* * Mark the Command structure as no longer valid. This allows * TclExecuteByteCode to recognize when a Command has logically been * deleted and a pointer to this Command structure cached in a CmdName - * object is invalid. TclExecuteByteCode will look up the command again - * in the interpreter's command hashtable. + * object is invalid. TclExecuteByteCode will look up the command again in + * the interpreter's command hashtable. */ cmdPtr->objProc = NULL; /* - * Now free the Command structure, unless there is another reference to - * it from a CmdName Tcl object in some ByteCode code sequence. In that - * case, delay the cleanup until all references are either discarded - * (when a ByteCode is freed) or replaced by a new reference (when a - * cached CmdName Command reference is found to be invalid and - * TclExecuteByteCode looks up the command in the command hashtable). + * Now free the Command structure, unless there is another reference to it + * from a CmdName Tcl object in some ByteCode code sequence. In that case, + * delay the cleanup until all references are either discarded (when a + * ByteCode is freed) or replaced by a new reference (when a cached + * CmdName Command reference is found to be invalid and TclExecuteByteCode + * looks up the command in the command hashtable). */ - + TclCleanupCommand(cmdPtr); return 0; } static char * CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) Interp *iPtr; /* Interpreter containing command. */ - Command *cmdPtr; /* Command whose traces are to be - * invoked. */ - CONST char *oldName; /* Command's old name, or NULL if we - * must get the name from cmdPtr */ - CONST char *newName; /* Command's new name, or NULL if - * the command is not being renamed */ - int flags; /* Flags indicating the type of traces - * to trigger, either TCL_TRACE_DELETE - * or TCL_TRACE_RENAME. */ + Command *cmdPtr; /* Command whose traces are to be invoked. */ + CONST char *oldName; /* Command's old name, or NULL if we must get + * the name from cmdPtr */ + CONST char *newName; /* Command's new name, or NULL if the command + * is not being renamed */ + int flags; /* Flags indicating the type of traces to + * trigger, either TCL_TRACE_DELETE or + * TCL_TRACE_RENAME. */ { register CommandTrace *tracePtr; ActiveCommandTrace active; char *result; Tcl_Obj *oldNamePtr = NULL; if (cmdPtr->flags & CMD_TRACE_ACTIVE) { - /* - * While a rename trace is active, we will not process any more - * rename traces; while a delete trace is active we will never - * reach here -- because Tcl_DeleteCommandFromToken checks for the - * condition (cmdPtr->flags & CMD_IS_DELETED) and returns immediately - * when a command deletion is in progress. For all other traces, - * delete traces will not be invoked but a call to TraceCommandProc - * will ensure that tracePtr->clientData is freed whenever the - * command "oldName" is deleted. + /* + * While a rename trace is active, we will not process any more rename + * traces; while a delete trace is active we will never reach here - + * because Tcl_DeleteCommandFromToken checks for the condition + * (cmdPtr->flags & CMD_IS_DELETED) and returns immediately when a + * command deletion is in progress. For all other traces, delete + * traces will not be invoked but a call to TraceCommandProc will + * ensure that tracePtr->clientData is freed whenever the command + * "oldName" is deleted. */ + if (cmdPtr->flags & TCL_TRACE_RENAME) { flags &= ~TCL_TRACE_RENAME; } if (flags == 0) { return NULL; } } cmdPtr->flags |= CMD_TRACE_ACTIVE; cmdPtr->refCount++; - + result = NULL; active.nextPtr = iPtr->activeCmdTracePtr; + active.reverseScan = 0; iPtr->activeCmdTracePtr = &active; if (flags & TCL_TRACE_DELETE) { flags |= TCL_TRACE_DESTROYED; } active.cmdPtr = cmdPtr; - + Tcl_Preserve((ClientData) iPtr); - + for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL; - tracePtr = active.nextTracePtr) { + tracePtr = active.nextTracePtr) { active.nextTracePtr = tracePtr->nextPtr; if (!(tracePtr->flags & flags)) { continue; } cmdPtr->flags |= tracePtr->flags; if (oldName == NULL) { TclNewObj(oldNamePtr); Tcl_IncrRefCount(oldNamePtr); - Tcl_GetCommandFullName((Tcl_Interp *) iPtr, - (Tcl_Command) cmdPtr, oldNamePtr); + Tcl_GetCommandFullName((Tcl_Interp *) iPtr, + (Tcl_Command) cmdPtr, oldNamePtr); oldName = TclGetString(oldNamePtr); } tracePtr->refCount++; (*tracePtr->traceProc)(tracePtr->clientData, (Tcl_Interp *) iPtr, oldName, newName, flags); @@ -2581,21 +2689,20 @@ ckfree((char*)tracePtr); } } /* - * If a new object was created to hold the full oldName, - * free it now. + * If a new object was created to hold the full oldName, free it now. */ if (oldNamePtr != NULL) { TclDecrRefCount(oldNamePtr); } /* - * Restore the variable's flags, remove the record of our active - * traces, and then return. + * Restore the variable's flags, remove the record of our active traces, + * and then return. */ cmdPtr->flags &= ~CMD_TRACE_ACTIVE; cmdPtr->refCount--; iPtr->activeCmdTracePtr = active.nextPtr; @@ -2609,11 +2716,11 @@ * TclCleanupCommand -- * * This procedure frees up a Command structure unless it is still * referenced from an interpreter's command hashtable or from a CmdName * Tcl object representing the name of a command in a ByteCode - * instruction sequence. + * instruction sequence. * * Results: * None. * * Side effects: @@ -2638,88 +2745,279 @@ /* *---------------------------------------------------------------------- * * Tcl_CreateMathFunc -- * - * Creates a new math function for expressions in a given - * interpreter. + * Creates a new math function for expressions in a given interpreter. * * Results: * None. * * Side effects: * The function defined by "name" is created or redefined. If the - * function already exists then its definition is replaced; this - * includes the builtin functions. Redefining a builtin function forces - * all existing code to be invalidated since that code may be compiled - * using an instruction specific to the replaced function. In addition, + * function already exists then its definition is replaced; this includes + * the builtin functions. Redefining a builtin function forces all + * existing code to be invalidated since that code may be compiled using + * an instruction specific to the replaced function. In addition, * redefioning a non-builtin function will force existing code to be * invalidated if the number of arguments has changed. * *---------------------------------------------------------------------- */ void Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData) - Tcl_Interp *interp; /* Interpreter in which function is - * to be available. */ - CONST char *name; /* Name of function (e.g. "sin"). */ - int numArgs; /* Nnumber of arguments required by - * function. */ - Tcl_ValueType *argTypes; /* Array of types acceptable for - * each argument. */ - Tcl_MathProc *proc; /* Procedure that implements the - * math function. */ - ClientData clientData; /* Additional value to pass to the - * function. */ -{ - Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hPtr; - MathFunc *mathFuncPtr; - int new, i; - - hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new); - if (new) { - Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc))); - } - mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - - if (!new) { - if (mathFuncPtr->builtinFuncIndex >= 0) { - /* - * We are redefining a builtin math function. Invalidate the - * interpreter's existing code by incrementing its - * compileEpoch member. This field is checked in Tcl_EvalObj - * and ObjInterpProc, and code whose compilation epoch doesn't - * match is recompiled. Newly compiled code will no longer - * treat the function as builtin. - */ - - iPtr->compileEpoch++; - } else { - /* - * A non-builtin function is being redefined. We must invalidate - * existing code if the number of arguments has changed. This - * is because existing code was compiled assuming that number. - */ - - if (numArgs != mathFuncPtr->numArgs) { - iPtr->compileEpoch++; - } - } - } - - mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */ + Tcl_Interp *interp; /* Interpreter in which function is to be + * available. */ + CONST char *name; /* Name of function (e.g. "sin"). */ + int numArgs; /* Nnumber of arguments required by + * function. */ + Tcl_ValueType *argTypes; /* Array of types acceptable for each + * argument. */ + Tcl_MathProc *proc; /* Procedure that implements the math + * function. */ + ClientData clientData; /* Additional value to pass to the + * function. */ +{ + + Tcl_DString bigName; + + OldMathFuncData *data = (OldMathFuncData *) + ckalloc(sizeof(OldMathFuncData)); + if (numArgs > MAX_MATH_ARGS) { - numArgs = MAX_MATH_ARGS; - } - mathFuncPtr->numArgs = numArgs; - for (i = 0; i < numArgs; i++) { - mathFuncPtr->argTypes[i] = argTypes[i]; - } - mathFuncPtr->proc = proc; - mathFuncPtr->clientData = clientData; + Tcl_Panic("attempt to create a math function with too many args"); + } + + data->proc = proc; + data->numArgs = numArgs; + data->argTypes = (Tcl_ValueType*) + Tcl_Alloc(numArgs * sizeof(Tcl_ValueType)); + memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType)); + data->clientData = clientData; + + Tcl_DStringInit(&bigName); + Tcl_DStringAppend(&bigName, "::tcl::mathfunc::", -1); + Tcl_DStringAppend(&bigName, name, -1); + + Tcl_CreateObjCommand(interp, Tcl_DStringValue(&bigName), + OldMathFuncProc, (ClientData) data, OldMathFuncDeleteProc); + Tcl_DStringFree(&bigName); +} + +/* + *---------------------------------------------------------------------- + * + * OldMathFuncProc -- + * + * Dispatch to a math function created with Tcl_CreateMathFunc + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Whatever the math function does. + * + *---------------------------------------------------------------------- + */ + +static int +OldMathFuncProc(clientData, interp, objc, objv) + ClientData clientData; /* Ponter to OldMathFuncData describing the + * function being called */ + Tcl_Interp *interp; /* Tcl interpreter */ + int objc; /* Actual parameter count */ + Tcl_Obj *CONST *objv; /* Parameter vector */ +{ + Tcl_Obj* valuePtr; + OldMathFuncData* dataPtr = (OldMathFuncData*) clientData; + Tcl_Value args[MAX_MATH_ARGS]; + Tcl_Value funcResult; + int result; +#if 0 + int i; +#endif + int j, k; + double d; + + /* + * Check argument count. + */ + + if (objc != dataPtr->numArgs + 1) { + MathFuncWrongNumArgs(interp, dataPtr->numArgs+1, objc, objv); + return TCL_ERROR; + } + + /* + * Convert arguments from Tcl_Obj's to Tcl_Value's. + */ + +#if 0 + for (j = 1, k = 0; j < objc; ++j, ++k) { + valuePtr = objv[j]; + if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Copy the object's numeric value to the argument record, converting + * it if necessary. + */ + + if (valuePtr->typePtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + if (dataPtr->argTypes[k] == TCL_DOUBLE) { + args[k].type = TCL_DOUBLE; + args[k].doubleValue = i; + } else if (dataPtr->argTypes[k] == TCL_WIDE_INT) { + args[k].type = TCL_WIDE_INT; + args[k].wideValue = Tcl_LongAsWide(i); + } else { + args[k].type = TCL_INT; + args[k].intValue = i; + } + } else if (valuePtr->typePtr == &tclWideIntType) { + Tcl_WideInt w; + TclGetWide(w,valuePtr); + if (dataPtr->argTypes[k] == TCL_DOUBLE) { + args[k].type = TCL_DOUBLE; + args[k].doubleValue = Tcl_WideAsDouble(w); + } else if (dataPtr->argTypes[k] == TCL_INT) { + args[k].type = TCL_INT; + args[k].intValue = Tcl_WideAsLong(w); + } else { + args[k].type = TCL_WIDE_INT; + args[k].wideValue = w; + } + } else { + d = valuePtr->internalRep.doubleValue; + if (dataPtr->argTypes[k] == TCL_INT) { + args[k].type = TCL_INT; + args[k].intValue = (long) d; + } else if (dataPtr->argTypes[k] == TCL_WIDE_INT) { + args[k].type = TCL_WIDE_INT; + args[k].wideValue = Tcl_DoubleAsWide(d); + } else { + args[k].type = TCL_DOUBLE; + args[k].doubleValue = d; + } + } + } +#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; + } + + /* + * Return the result of the call. + */ + + if (funcResult.type == TCL_INT) { + TclNewLongObj(valuePtr, funcResult.intValue); + } else if (funcResult.type == TCL_WIDE_INT) { + valuePtr = Tcl_NewWideIntObj(funcResult.wideValue); + } else { + return CheckDoubleResult(interp, funcResult.doubleValue); + } + Tcl_SetObjResult(interp, valuePtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * OldMathFuncDeleteProc -- + * + * Cleans up after deleting a math function registered with + * Tcl_CreateMathFunc + * + * Results: + * None. + * + * Side effects: + * Frees allocated memory. + * + *---------------------------------------------------------------------- + */ + +static void +OldMathFuncDeleteProc(clientData) + ClientData clientData; +{ + OldMathFuncData* dataPtr = (OldMathFuncData*) clientData; + Tcl_Free((VOID*) dataPtr->argTypes); + Tcl_Free((VOID*) dataPtr); } /* *---------------------------------------------------------------------- * @@ -2727,68 +3025,83 @@ * * Discovers how a particular math function was created in a given * interpreter. * * Results: - * TCL_OK if it succeeds, TCL_ERROR else (leaving an error message - * in the interpreter result if that happens.) + * TCL_OK if it succeeds, TCL_ERROR else (leaving an error message in the + * interpreter result if that happens.) * * Side effects: - * If this function succeeds, the variables pointed to by the - * numArgsPtr and argTypePtr arguments will be updated to detail the - * arguments allowed by the function. The variable pointed to by the - * procPtr argument will be set to NULL if the function is a builtin - * function, and will be set to the address of the C function used to - * implement the math function otherwise (in which case the variable - * pointed to by the clientDataPtr argument will also be updated.) + * If this function succeeds, the variables pointed to by the numArgsPtr + * and argTypePtr arguments will be updated to detail the arguments + * allowed by the function. The variable pointed to by the procPtr + * argument will be set to NULL if the function is a builtin function, + * and will be set to the address of the C function used to implement the + * math function otherwise (in which case the variable pointed to by the + * clientDataPtr argument will also be updated.) * *---------------------------------------------------------------------- */ int Tcl_GetMathFuncInfo(interp, name, numArgsPtr, argTypesPtr, procPtr, - clientDataPtr) + clientDataPtr) Tcl_Interp *interp; CONST char *name; int *numArgsPtr; Tcl_ValueType **argTypesPtr; Tcl_MathProc **procPtr; ClientData *clientDataPtr; { - Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hPtr; - MathFunc *mathFuncPtr; - Tcl_ValueType *argTypes; - int i,numArgs; - - hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, name); - if (hPtr == NULL) { - Tcl_AppendResult(interp, "math function \"", name, - "\" not known in this interpreter", (char *) NULL); + Tcl_Obj* cmdNameObj; + Command* cmdPtr; + + /* + * Get the command that implements the math function. + */ + + cmdNameObj = Tcl_NewStringObj("tcl::mathfunc::", -1); + Tcl_AppendToObj(cmdNameObj, name, -1); + Tcl_IncrRefCount(cmdNameObj); + cmdPtr = (Command*) Tcl_GetCommandFromObj(interp, cmdNameObj); + Tcl_DecrRefCount(cmdNameObj); + + /* + * Report unknown functions. + */ + + if (cmdPtr == NULL) { + Tcl_Obj* message; + message = Tcl_NewStringObj("unknown math function \"", -1); + Tcl_AppendToObj(message, name, -1); + Tcl_AppendToObj(message, "\"", 1); + *numArgsPtr = -1; *argTypesPtr = NULL; + *procPtr = NULL; + *clientDataPtr = NULL; return TCL_ERROR; } - mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - - *numArgsPtr = numArgs = mathFuncPtr->numArgs; - if (numArgs == 0) { - /* Avoid doing zero-sized allocs... */ - numArgs = 1; - } - *argTypesPtr = argTypes = - (Tcl_ValueType *)ckalloc(numArgs * sizeof(Tcl_ValueType)); - for (i = 0; i < mathFuncPtr->numArgs; i++) { - argTypes[i] = mathFuncPtr->argTypes[i]; - } - - if (mathFuncPtr->builtinFuncIndex == -1) { - *procPtr = (Tcl_MathProc *) NULL; + + /* + * Retrieve function info for user defined functions; return dummy + * information for builtins. + */ + + if (cmdPtr->objProc == &OldMathFuncProc) { + OldMathFuncData* dataPtr = (OldMathFuncData*) cmdPtr->clientData; + *procPtr = dataPtr->proc; + *numArgsPtr = dataPtr->numArgs; + *argTypesPtr = dataPtr->argTypes; + *clientDataPtr = dataPtr->clientData; } else { - *procPtr = mathFuncPtr->proc; - *clientDataPtr = mathFuncPtr->clientData; + *procPtr = NULL; + *numArgsPtr = -1; + *argTypesPtr = NULL; + *procPtr = NULL; + *clientDataPtr = NULL; } - return TCL_OK; + } /* *---------------------------------------------------------------------- * @@ -2796,13 +3109,13 @@ * * Produces a list of all the math functions defined in a given * interpreter. * * Results: - * A pointer to a Tcl_Obj structure with a reference count of zero, - * or NULL in the case of an error (in which case a suitable error - * message will be left in the interpreter result.) + * A pointer to a Tcl_Obj structure with a reference count of zero, or + * NULL in the case of an error (in which case a suitable error message + * will be left in the interpreter result.) * * Side effects: * None. * *---------------------------------------------------------------------- @@ -2811,85 +3124,98 @@ Tcl_Obj * Tcl_ListMathFuncs(interp, pattern) Tcl_Interp *interp; CONST char *pattern; { - Interp *iPtr = (Interp *) interp; - Tcl_Obj *resultList = Tcl_NewObj(); - register Tcl_HashEntry *hPtr; - Tcl_HashSearch hSearch; - CONST char *name; - - for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &hSearch); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - name = Tcl_GetHashKey(&iPtr->mathFuncTable, hPtr); - if ((pattern == NULL || Tcl_StringMatch(name, pattern)) && - /* I don't expect this to fail, but... */ - Tcl_ListObjAppendElement(interp, resultList, - Tcl_NewStringObj(name,-1)) != TCL_OK) { - Tcl_DecrRefCount(resultList); - return NULL; - } - } - return resultList; + Namespace* globalNsPtr = (Namespace*) Tcl_GetGlobalNamespace(interp); + Namespace* nsPtr; + Namespace* dummy1NsPtr; + Namespace* dummy2NsPtr; + CONST char* dummyNamePtr; + Tcl_Obj* result = Tcl_NewObj(); + Tcl_HashEntry* cmdHashEntry; + Tcl_HashSearch cmdHashSearch; + CONST char* cmdNamePtr; + + TclGetNamespaceForQualName(interp, "::tcl::mathfunc", + globalNsPtr, TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY, + &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &dummyNamePtr); + + if (nsPtr != NULL) { + if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { + if (Tcl_FindHashEntry(&nsPtr->cmdTable, pattern) != NULL) { + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(pattern, -1)); + } + } else { + cmdHashEntry = Tcl_FirstHashEntry(&nsPtr->cmdTable,&cmdHashSearch); + for (; cmdHashEntry != NULL; + cmdHashEntry = Tcl_NextHashEntry(&cmdHashSearch)) { + cmdNamePtr = Tcl_GetHashKey(&nsPtr->cmdTable, cmdHashEntry); + if (pattern == NULL || Tcl_StringMatch(cmdNamePtr, pattern)) { + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(cmdNamePtr, -1)); + } + } + } + } + return result; } /* *---------------------------------------------------------------------- * * TclInterpReady -- * - * Check if an interpreter is ready to eval commands or scripts, - * i.e., if it was not deleted and if the nesting level is not - * too high. + * Check if an interpreter is ready to eval commands or scripts, i.e., if + * it was not deleted and if the nesting level is not too high. * * Results: - * The return value is TCL_OK if it the interpreter is ready, - * TCL_ERROR otherwise. + * The return value is TCL_OK if it the interpreter is ready, TCL_ERROR + * otherwise. * * Side effects: * The interpreters object and string results are cleared. * *---------------------------------------------------------------------- */ -int +int TclInterpReady(interp) Tcl_Interp *interp; { register Interp *iPtr = (Interp *) interp; /* - * Reset both the interpreter's string and object results and clear - * out any previous error information. + * Reset both the interpreter's string and object results and clear out + * any previous error information. */ Tcl_ResetResult(interp); /* * If the interpreter has been deleted, return an error. */ - + if (iPtr->flags & DELETED) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, - "attempt to call eval in deleted interpreter", (char *) NULL); + "attempt to call eval in deleted interpreter", (char *) NULL); Tcl_SetErrorCode(interp, "CORE", "IDELETE", - "attempt to call eval in deleted interpreter", - (char *) NULL); + "attempt to call eval in deleted interpreter", (char *) NULL); return TCL_ERROR; } /* - * Check depth of nested calls to Tcl_Eval: if this gets too large, - * it's probably because of an infinite loop somewhere. + * Check depth of nested calls to Tcl_Eval: if this gets too large, it's + * probably because of an infinite loop somewhere. */ - if (((iPtr->numLevels) > iPtr->maxNestingDepth) + if (((iPtr->numLevels) > iPtr->maxNestingDepth) || (TclpCheckStackSpace() == 0)) { Tcl_AppendResult(interp, - "too many nested evaluations (infinite loop?)", (char *) NULL); + "too many nested evaluations (infinite loop?)", (char *) NULL); return TCL_ERROR; } return TCL_OK; } @@ -2897,19 +3223,19 @@ /* *---------------------------------------------------------------------- * * TclEvalObjvInternal -- * - * This procedure evaluates a Tcl command that has already been - * parsed into words, with one Tcl_Obj holding each word. The caller - * is responsible for managing the iPtr->numLevels. + * This procedure evaluates a Tcl command that has already been parsed + * into words, with one Tcl_Obj holding each word. The caller is + * responsible for managing the iPtr->numLevels. * * Results: - * The return value is a standard Tcl completion code such as - * TCL_OK or TCL_ERROR. A result or error message is left in - * interp's result. If an error occurs, this procedure does - * NOT add any information to the errorInfo variable. + * The return value is a standard Tcl completion code such as TCL_OK or + * TCL_ERROR. A result or error message is left in interp's result. If an + * error occurs, this procedure does NOT add any information to the + * errorInfo variable. * * Side effects: * Depends on the command. * *---------------------------------------------------------------------- @@ -2916,37 +3242,35 @@ */ int TclEvalObjvInternal(interp, objc, objv, command, length, flags) Tcl_Interp *interp; /* Interpreter in which to evaluate the - * command. Also used for error - * reporting. */ + * command. Also used for error reporting. */ int objc; /* Number of words in command. */ Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are * the words that make up the command. */ CONST char *command; /* Points to the beginning of the string - * representation of the command; this - * is used for traces. If the string - * representation of the command is - * unknown, an empty string should be - * supplied. If it is NULL, no traces will - * be called. */ + * representation of the command; this is used + * for traces. If the string representation of + * the command is unknown, an empty string + * should be supplied. If it is NULL, no + * traces will be called. */ int length; /* Number of bytes in command; if -1, all * characters up to the first null byte are * used. */ - int flags; /* Collection of OR-ed bits that control - * the evaluation of the script. Only + int flags; /* Collection of OR-ed bits that control the + * evaluation of the script. Only * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are * currently supported. */ { Command *cmdPtr; Interp *iPtr = (Interp *) interp; Tcl_Obj **newObjv; int i; - CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr - * in case TCL_EVAL_GLOBAL was set. */ + CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case + * TCL_EVAL_GLOBAL was set. */ int code = TCL_OK; int traceCode = TCL_OK; int checkTraces = 1; if (TclInterpReady(interp) == TCL_ERROR) { @@ -2956,100 +3280,102 @@ if (objc == 0) { return TCL_OK; } /* - * If any execution traces rename or delete the current command, - * we may need (at most) two passes here. - */ - while (1) { - - /* - * Find the procedure to execute this command. If there isn't one, - * then see if there is a command "unknown". If so, create a new - * word array with "unknown" as the first word and the original - * command words as arguments. Then call ourselves recursively - * to execute it. - * - * If caller requests, or if we're resolving the target end of - * an interpeter alias (TCL_EVAL_INVOKE), be sure to do command - * name resolution in the global namespace. - */ - - savedVarFramePtr = iPtr->varFramePtr; - if (flags & (TCL_EVAL_INVOKE | TCL_EVAL_GLOBAL)) { - iPtr->varFramePtr = NULL; - } - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); - iPtr->varFramePtr = savedVarFramePtr; - - if (cmdPtr == NULL) { - newObjv = (Tcl_Obj **) ckalloc((unsigned) - ((objc + 1) * sizeof (Tcl_Obj *))); - for (i = objc-1; i >= 0; i--) { - newObjv[i+1] = objv[i]; - } - newObjv[0] = Tcl_NewStringObj("::unknown", -1); - Tcl_IncrRefCount(newObjv[0]); - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]); - if (cmdPtr == NULL) { - Tcl_AppendResult(interp, "invalid command name \"", - Tcl_GetString(objv[0]), "\"", (char *) NULL); - code = TCL_ERROR; - } else { - iPtr->numLevels++; - code = TclEvalObjvInternal(interp, objc+1, newObjv, command, length, 0); - iPtr->numLevels--; - } - Tcl_DecrRefCount(newObjv[0]); - ckfree((char *) newObjv); - goto done; - } - - /* - * Call trace procedures if needed. - */ - if ((checkTraces) && (command != NULL)) { - int cmdEpoch = cmdPtr->cmdEpoch; - cmdPtr->refCount++; - /* - * If the first set of traces modifies/deletes the command or - * any existing traces, then the set checkTraces to 0 and - * go through this while loop one more time. - */ - if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { - traceCode = TclCheckInterpTraces(interp, command, length, - cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); - } - if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) - && (traceCode == TCL_OK)) { - traceCode = TclCheckExecutionTraces(interp, command, length, - cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); - } - cmdPtr->refCount--; - if (cmdEpoch != cmdPtr->cmdEpoch) { - /* The command has been modified in some way */ - checkTraces = 0; - continue; - } - } - break; + * Find the procedure to execute this command. If there isn't one, then + * see if there is a command "unknown". If so, create a new word array + * with "unknown" as the first word and the original command words as + * arguments. Then call ourselves recursively to execute it. + * + * If caller requests, or if we're resolving the target end of an + * interpeter alias (TCL_EVAL_INVOKE), be sure to do command name + * resolution in the global namespace. + * + * If any execution traces rename or delete the current command, we may + * need (at most) two passes here. + */ + + reparseBecauseOfTraces: + savedVarFramePtr = iPtr->varFramePtr; + if (flags & (TCL_EVAL_INVOKE | TCL_EVAL_GLOBAL)) { + iPtr->varFramePtr = NULL; + } + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); + iPtr->varFramePtr = savedVarFramePtr; + + if (cmdPtr == NULL) { + newObjv = (Tcl_Obj **) + ckalloc((unsigned) ((objc + 1) * sizeof(Tcl_Obj *))); + for (i = objc-1; i >= 0; i--) { + newObjv[i+1] = objv[i]; + } + newObjv[0] = Tcl_NewStringObj("::unknown", -1); + Tcl_IncrRefCount(newObjv[0]); + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]); + if (cmdPtr == NULL) { + Tcl_AppendResult(interp, "invalid command name \"", + TclGetString(objv[0]), "\"", (char *) NULL); + code = TCL_ERROR; + } else { + iPtr->numLevels++; + code = TclEvalObjvInternal(interp, objc+1, newObjv, + command, length, 0); + iPtr->numLevels--; + } + Tcl_DecrRefCount(newObjv[0]); + ckfree((char *) newObjv); + goto done; + } + + /* + * Call trace procedures if needed. + */ + + if ((checkTraces) && (command != NULL)) { + int cmdEpoch = cmdPtr->cmdEpoch; + cmdPtr->refCount++; + + /* + * If the first set of traces modifies/deletes the command or any + * existing traces, then the set checkTraces to 0 and go through this + * while loop one more time. + */ + + if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { + traceCode = TclCheckInterpTraces(interp, command, length, + cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); + } + if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { + traceCode = TclCheckExecutionTraces(interp, command, length, + cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); + } + cmdPtr->refCount--; + if (cmdEpoch != cmdPtr->cmdEpoch) { + /* + * The command has been modified in some way. + */ + + checkTraces = 0; + goto reparseBecauseOfTraces; + } } /* * Finally, invoke the command's Tcl_ObjCmdProc. */ + cmdPtr->refCount++; iPtr->cmdCount++; if (code == TCL_OK && traceCode == TCL_OK && !Tcl_LimitExceeded(interp)) { savedVarFramePtr = iPtr->varFramePtr; if (flags & TCL_EVAL_GLOBAL) { iPtr->varFramePtr = NULL; } if (!(flags & TCL_EVAL_INVOKE) && (iPtr->ensembleRewrite.sourceObjs != NULL) && - !TclIsEnsemble(cmdPtr)) { + !Tcl_IsEnsemble((Tcl_Command) cmdPtr)) { iPtr->ensembleRewrite.sourceObjs = NULL; } code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); iPtr->varFramePtr = savedVarFramePtr; } @@ -3061,60 +3387,59 @@ } /* * Call 'leave' command traces */ + if (!(cmdPtr->flags & CMD_IS_DELETED)) { - if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { - traceCode = TclCheckExecutionTraces(interp, command, length, - cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); - } - if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { - traceCode = TclCheckInterpTraces(interp, command, length, - cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); - } + if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { + traceCode = TclCheckExecutionTraces(interp, command, length, + cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); + } + if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { + traceCode = TclCheckInterpTraces(interp, command, length, + cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); + } } TclCleanupCommand(cmdPtr); /* - * If one of the trace invocation resulted in error, then - * change the result code accordingly. Note, that the - * interp->result should already be set correctly by the - * call to TraceExecutionProc. + * If one of the trace invocation resulted in error, then change the + * result code accordingly. Note, that the interp->result should already + * be set correctly by the call to TraceExecutionProc. */ if (traceCode != TCL_OK) { code = traceCode; } - + /* - * If the interpreter has a non-empty string result, the result - * object is either empty or stale because some procedure set - * interp->result directly. If so, move the string result to the - * result object, then reset the string result. + * If the interpreter has a non-empty string result, the result object is + * either empty or stale because some procedure set interp->result + * directly. If so, move the string result to the result object, then + * reset the string result. */ - + if (*(iPtr->result) != 0) { (void) Tcl_GetObjResult(interp); } - done: + done: return code; } /* *---------------------------------------------------------------------- * * Tcl_EvalObjv -- * - * This procedure evaluates a Tcl command that has already been - * parsed into words, with one Tcl_Obj holding each word. + * This procedure evaluates a Tcl command that has already been parsed + * into words, with one Tcl_Obj holding each word. * * Results: - * The return value is a standard Tcl completion code such as - * TCL_OK or TCL_ERROR. A result or error message is left in - * interp's result. + * The return value is a standard Tcl completion code such as TCL_OK or + * TCL_ERROR. A result or error message is left in interp's result. * * Side effects: * Depends on the command. * *---------------------------------------------------------------------- @@ -3121,19 +3446,18 @@ */ int Tcl_EvalObjv(interp, objc, objv, flags) Tcl_Interp *interp; /* Interpreter in which to evaluate the - * command. Also used for error - * reporting. */ + * command. Also used for error reporting. */ int objc; /* Number of words in command. */ Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are * the words that make up the command. */ - int flags; /* Collection of OR-ed bits that control - * the evaluation of the script. Only - * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE - * are currently supported. */ + int flags; /* Collection of OR-ed bits that control the + * evaluation of the script. Only + * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are + * currently supported. */ { Interp *iPtr = (Interp *)interp; Trace *tracePtr; Tcl_DString cmdBuf; char *cmdString = ""; /* A command string is only necessary for @@ -3147,14 +3471,14 @@ int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) { if ((tracePtr->level == 0) || (iPtr->numLevels <= tracePtr->level)) { /* - * The command may be needed for an execution trace. Generate a + * The command may be needed for an execution trace. Generate a * command string. */ - + Tcl_DStringInit(&cmdBuf); for (i = 0; i < objc; i++) { Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i])); } cmdString = Tcl_DStringValue(&cmdBuf); @@ -3166,14 +3490,14 @@ iPtr->numLevels++; code = TclEvalObjvInternal(interp, objc, objv, cmdString, cmdLen, flags); iPtr->numLevels--; /* - * If we are again at the top level, process any unusual - * return code returned by the evaluated code. + * If we are again at the top level, process any unusual return code + * returned by the evaluated code. */ - + if (iPtr->numLevels == 0) { if (code == TCL_RETURN) { code = TclUpdateReturnInfo(iPtr); } if ((code != TCL_OK) && (code != TCL_ERROR) @@ -3180,15 +3504,15 @@ && !allowExceptions) { ProcessUnexpectedResult(interp, code); code = TCL_ERROR; } } - + if ((code == TCL_ERROR) && !(flags & TCL_EVAL_INVOKE)) { - /* - * If there was an error, a command string will be needed for the + /* + * If there was an error, a command string will be needed for the * error log: generate it now if it was not done previously. */ if (cmdLen == 0) { Tcl_DStringInit(&cmdBuf); @@ -3210,42 +3534,42 @@ /* *---------------------------------------------------------------------- * * Tcl_LogCommandInfo -- * - * This procedure is invoked after an error occurs in an interpreter. - * It adds information to iPtr->errorInfo field to describe the - * command that was being executed when the error occurred. + * This procedure is invoked after an error occurs in an interpreter. It + * adds information to iPtr->errorInfo field to describe the command that + * was being executed when the error occurred. * * Results: * None. * * Side effects: - * Information about the command is added to errorInfo and the - * line number stored internally in the interpreter is set. + * Information about the command is added to errorInfo and the line + * number stored internally in the interpreter is set. * *---------------------------------------------------------------------- */ void Tcl_LogCommandInfo(interp, script, command, length) Tcl_Interp *interp; /* Interpreter in which to log information. */ CONST char *script; /* First character in script containing * command (must be <= command). */ - CONST char *command; /* First character in command that - * generated the error. */ - int length; /* Number of bytes in command (-1 means - * use all bytes up to first null byte). */ + CONST char *command; /* First character in command that generated + * the error. */ + int length; /* Number of bytes in command (-1 means use + * all bytes up to first null byte). */ { register CONST char *p; Interp *iPtr = (Interp *) interp; - Tcl_Obj *message; + int overflow, limit = 150; if (iPtr->flags & ERR_ALREADY_LOGGED) { /* - * Someone else has already logged error information for this - * command; we shouldn't add anything more. + * Someone else has already logged error information for this command; + * we shouldn't add anything more. */ return; } @@ -3258,50 +3582,44 @@ if (*p == '\n') { iPtr->errorLine++; } } - if (iPtr->errorInfo == NULL) { - message = Tcl_NewStringObj("\n while executing\n\"", -1); - } else { - message = Tcl_NewStringObj("\n invoked from within\n\"", -1); - } - Tcl_IncrRefCount(message); - TclAppendLimitedToObj(message, command, length, 153, NULL); - Tcl_AppendToObj(message, "\"", -1); - TclAppendObjToErrorInfo(interp, message); - Tcl_DecrRefCount(message); + overflow = (length > limit); + TclFormatToErrorInfo(interp, "\n %s\n\"%.*s%s\"", + ((iPtr->errorInfo == NULL) + ? "while executing" : "invoked from within"), + (overflow ? limit : length), command, (overflow ? "..." : "")); } /* *---------------------------------------------------------------------- * * Tcl_EvalTokensStandard -- * - * Given an array of tokens parsed from a Tcl command (e.g., the - * tokens that make up a word or the index for an array variable) - * this procedure evaluates the tokens and concatenates their - * values to form a single result value. - * + * Given an array of tokens parsed from a Tcl command (e.g., the tokens + * that make up a word or the index for an array variable) this procedure + * evaluates the tokens and concatenates their values to form a single + * result value. + * * Results: - * The return value is a standard Tcl completion code such as - * TCL_OK or TCL_ERROR. A result or error message is left in - * interp's result. + * The return value is a standard Tcl completion code such as TCL_OK or + * TCL_ERROR. A result or error message is left in interp's result. * * Side effects: * Depends on the array of tokens being evaled. * *---------------------------------------------------------------------- */ int Tcl_EvalTokensStandard(interp, tokenPtr, count) - Tcl_Interp *interp; /* Interpreter in which to lookup - * variables, execute nested commands, - * and report errors. */ - Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens - * to evaluate and concatenate. */ + Tcl_Interp *interp; /* Interpreter in which to lookup variables, + * execute nested commands, and report + * errors. */ + Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens to + * evaluate and concatenate. */ int count; /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ { return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL); } @@ -3310,45 +3628,45 @@ /* *---------------------------------------------------------------------- * * Tcl_EvalTokens -- * - * Given an array of tokens parsed from a Tcl command (e.g., the - * tokens that make up a word or the index for an array variable) - * this procedure evaluates the tokens and concatenates their - * values to form a single result value. + * Given an array of tokens parsed from a Tcl command (e.g., the tokens + * that make up a word or the index for an array variable) this procedure + * evaluates the tokens and concatenates their values to form a single + * result value. * * Results: - * The return value is a pointer to a newly allocated Tcl_Obj - * containing the value of the array of tokens. The reference - * count of the returned object has been incremented. If an error - * occurs in evaluating the tokens then a NULL value is returned - * and an error message is left in interp's result. + * The return value is a pointer to a newly allocated Tcl_Obj containing + * the value of the array of tokens. The reference count of the returned + * object has been incremented. If an error occurs in evaluating the + * tokens then a NULL value is returned and an error message is left in + * interp's result. * * Side effects: * A new object is allocated to hold the result. * *---------------------------------------------------------------------- * - * This uses a non-standard return convention; its use is now deprecated. - * It is a wrapper for the new function Tcl_EvalTokensStandard, and is not - * used in the core any longer. It is only kept for backward compatibility. + * This uses a non-standard return convention; its use is now deprecated. It + * is a wrapper for the new function Tcl_EvalTokensStandard, and is not used + * in the core any longer. It is only kept for backward compatibility. */ Tcl_Obj * Tcl_EvalTokens(interp, tokenPtr, count) - Tcl_Interp *interp; /* Interpreter in which to lookup - * variables, execute nested commands, - * and report errors. */ - Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens - * to evaluate and concatenate. */ + Tcl_Interp *interp; /* Interpreter in which to lookup variables, + * execute nested commands, and report + * errors. */ + Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens to + * evaluate and concatenate. */ int count; /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ { int code; Tcl_Obj *resPtr; - + code = Tcl_EvalTokensStandard(interp, tokenPtr, count); if (code == TCL_OK) { resPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(resPtr); Tcl_ResetResult(interp); @@ -3362,19 +3680,18 @@ /* *---------------------------------------------------------------------- * * Tcl_EvalEx -- * - * This procedure evaluates a Tcl script without using the compiler - * or byte-code interpreter. It just parses the script, creates - * values for each word of each command, then calls EvalObjv - * to execute each command. + * This procedure evaluates a Tcl script without using the compiler or + * byte-code interpreter. It just parses the script, creates values for + * each word of each command, then calls EvalObjv to execute each + * command. * * Results: - * The return value is a standard Tcl completion code such as - * TCL_OK or TCL_ERROR. A result or error message is left in - * interp's result. + * The return value is a standard Tcl completion code such as TCL_OK or + * TCL_ERROR. A result or error message is left in interp's result. * * Side effects: * Depends on the script. * *---------------------------------------------------------------------- @@ -3381,36 +3698,35 @@ */ int Tcl_EvalEx(interp, script, numBytes, flags) Tcl_Interp *interp; /* Interpreter in which to evaluate the - * script. Also used for error reporting. */ + * script. Also used for error reporting. */ CONST char *script; /* First character of script to evaluate. */ - int numBytes; /* Number of bytes in script. If < 0, the + int numBytes; /* Number of bytes in script. If < 0, the * script consists of all bytes up to the * first null character. */ - int flags; /* Collection of OR-ed bits that control - * the evaluation of the script. Only - * TCL_EVAL_GLOBAL is currently - * supported. */ + int flags; /* Collection of OR-ed bits that control the + * evaluation of the script. Only + * TCL_EVAL_GLOBAL is currently supported. */ { Interp *iPtr = (Interp *) interp; CONST char *p, *next; Tcl_Parse parse; #define NUM_STATIC_OBJS 20 Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv, **objvSpace; int expandStatic[NUM_STATIC_OBJS], *expand; Tcl_Token *tokenPtr; int i, code, commandLength, bytesLeft, expandRequested; - CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr - * in case TCL_EVAL_GLOBAL was set. */ + CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case + * TCL_EVAL_GLOBAL was set. */ int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); - + /* - * The variables below keep track of how much state has been - * allocated while evaluating the script, so that it can be freed - * properly if an error occurs. + * The variables below keep track of how much state has been allocated + * while evaluating the script, so that it can be freed properly if an + * error occurs. */ int gotParse = 0, objectsUsed = 0; if (numBytes < 0) { @@ -3422,45 +3738,45 @@ if (flags & TCL_EVAL_GLOBAL) { iPtr->varFramePtr = NULL; } /* - * Each iteration through the following loop parses the next - * command from the script and then executes it. + * Each iteration through the following loop parses the next command from + * the script and then executes it. */ objv = objvSpace = staticObjArray; expand = expandStatic; p = script; bytesLeft = numBytes; iPtr->evalFlags = 0; do { - if (Tcl_ParseCommand(interp, p, bytesLeft, 0, &parse) - != TCL_OK) { + if (Tcl_ParseCommand(interp, p, bytesLeft, 0, &parse) != TCL_OK) { code = TCL_ERROR; goto error; } - gotParse = 1; + gotParse = 1; if (parse.numWords > 0) { /* * Generate an array of objects for the words of the command. */ + int objectsNeeded = 0; - + if (parse.numWords > NUM_STATIC_OBJS) { - expand = (int *) ckalloc((unsigned) - (parse.numWords * sizeof (int))); - objvSpace = (Tcl_Obj **) ckalloc((unsigned) - (parse.numWords * sizeof (Tcl_Obj *))); + expand = (int *) + ckalloc((unsigned) (parse.numWords * sizeof(int))); + objvSpace = (Tcl_Obj **) + ckalloc((unsigned) (parse.numWords*sizeof(Tcl_Obj *))); } expandRequested = 0; objv = objvSpace; for (objectsUsed = 0, tokenPtr = parse.tokenPtr; objectsUsed < parse.numWords; objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) { - code = TclSubstTokens(interp, tokenPtr+1, - tokenPtr->numComponents, NULL); + code = TclSubstTokens(interp, tokenPtr+1, + tokenPtr->numComponents, NULL); if (code != TCL_OK) { goto error; } objv[objectsUsed] = Tcl_GetObjResult(interp); Tcl_IncrRefCount(objv[objectsUsed]); @@ -3468,21 +3784,13 @@ int numElements; code = Tcl_ListObjLength(interp, objv[objectsUsed], &numElements); if (code == TCL_ERROR) { - /* Attempt to expand a non-list */ - Tcl_Obj *msg = - Tcl_NewStringObj("\n (expanding word ", -1); - Tcl_Obj *wordNum = Tcl_NewIntObj(objectsUsed); - Tcl_IncrRefCount(wordNum); - Tcl_IncrRefCount(msg); - Tcl_AppendObjToObj(msg, wordNum); - Tcl_DecrRefCount(wordNum); - Tcl_AppendToObj(msg, ")", -1); - TclAppendObjToErrorInfo(interp, msg); - Tcl_DecrRefCount(msg); + /* Attempt to expand a non-list. */ + TclFormatToErrorInfo(interp, + "\n (expanding word %d)", objectsUsed); Tcl_DecrRefCount(objv[objectsUsed]); goto error; } expandRequested = 1; expand[objectsUsed] = 1; @@ -3491,26 +3799,30 @@ expand[objectsUsed] = 0; objectsNeeded++; } } if (expandRequested) { - /* Some word expansion was requested. Check for objv resize */ + /* + * Some word expansion was requested. Check for objv resize. + */ + Tcl_Obj **copy = objvSpace; int wordIdx = parse.numWords; int objIdx = objectsNeeded - 1; if ((parse.numWords > NUM_STATIC_OBJS) || (objectsNeeded > NUM_STATIC_OBJS)) { objv = objvSpace = (Tcl_Obj **) ckalloc((unsigned) - (objectsNeeded * sizeof (Tcl_Obj *))); + (objectsNeeded * sizeof(Tcl_Obj *))); } objectsUsed = 0; while (wordIdx--) { if (expand[wordIdx]) { int numElements; Tcl_Obj **elements, *temp = copy[wordIdx]; + Tcl_ListObjGetElements(NULL, temp, &numElements, &elements); objectsUsed += numElements; while (numElements--) { objv[objIdx--] = elements[numElements]; @@ -3526,30 +3838,20 @@ if (copy != staticObjArray) { ckfree((char *) copy); } } - + /* * Execute the command and free the objects for its words. */ - iPtr->numLevels++; - code = TclEvalObjvInternal(interp, objectsUsed, objv, - parse.commandStart, parse.commandSize, 0); + iPtr->numLevels++; + code = TclEvalObjvInternal(interp, objectsUsed, objv, + parse.commandStart, parse.commandSize, 0); iPtr->numLevels--; if (code != TCL_OK) { - if (iPtr->numLevels == 0) { - if (code == TCL_RETURN) { - code = TclUpdateReturnInfo(iPtr); - } - if ((code != TCL_OK) && (code != TCL_ERROR) - && !allowExceptions) { - ProcessUnexpectedResult(interp, code); - code = TCL_ERROR; - } - } goto error; } for (i = 0; i < objectsUsed; i++) { Tcl_DecrRefCount(objv[i]); } @@ -3556,14 +3858,16 @@ objectsUsed = 0; if (objvSpace != staticObjArray) { ckfree((char *) objvSpace); objvSpace = staticObjArray; } - /* + + /* * Free expand separately since objvSpace could have been - * reallocated above. + * reallocated above. */ + if (expand != expandStatic) { ckfree((char *) expand); expand = expandStatic; } } @@ -3579,30 +3883,42 @@ gotParse = 0; } while (bytesLeft > 0); iPtr->varFramePtr = savedVarFramePtr; return TCL_OK; - error: - /* Generate and log various pieces of error information. */ - - if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + error: + /* + * Generate and log various pieces of error information. + */ + if (iPtr->numLevels == 0) { + if (code == TCL_RETURN) { + code = TclUpdateReturnInfo(iPtr); + } + if ((code != TCL_OK) && (code != TCL_ERROR) && !allowExceptions) { + ProcessUnexpectedResult(interp, code); + code = TCL_ERROR; + } + } + if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { commandLength = parse.commandSize; if (parse.term == parse.commandStart + commandLength - 1) { /* * The terminator character (such as ; or ]) of the command where * the error occurred is the last character in the parsed command. * Reduce the length by one so that the error message doesn't * include the terminator character. */ - + commandLength -= 1; } Tcl_LogCommandInfo(interp, script, parse.commandStart, commandLength); } iPtr->flags &= ~ERR_ALREADY_LOGGED; - - /* Then free resources that had been allocated to the command. */ + + /* + * Then free resources that had been allocated to the command. + */ for (i = 0; i < objectsUsed; i++) { Tcl_DecrRefCount(objv[i]); } if (gotParse) { @@ -3621,41 +3937,39 @@ /* *---------------------------------------------------------------------- * * Tcl_Eval -- * - * Execute a Tcl command in a string. This procedure executes the - * script directly, rather than compiling it to bytecodes. Before - * the arrival of the bytecode compiler in Tcl 8.0 Tcl_Eval was - * the main procedure used for executing Tcl commands, but nowadays - * it isn't used much. + * Execute a Tcl command in a string. This procedure executes the script + * directly, rather than compiling it to bytecodes. Before the arrival of + * the bytecode compiler in Tcl 8.0 Tcl_Eval was the main procedure used + * for executing Tcl commands, but nowadays it isn't used much. * * Results: - * The return value is one of the return codes defined in tcl.h - * (such as TCL_OK), and interp's result contains a value - * to supplement the return code. The value of the result - * will persist only until the next call to Tcl_Eval or Tcl_EvalObj: - * you must copy it or lose it! + * The return value is one of the return codes defined in tcl.h (such as + * TCL_OK), and interp's result contains a value to supplement the return + * code. The value of the result will persist only until the next call to + * Tcl_Eval or Tcl_EvalObj: you must copy it or lose it! * * Side effects: * Can be almost arbitrary, depending on the commands in the script. * *---------------------------------------------------------------------- */ int -Tcl_Eval(interp, string) - Tcl_Interp *interp; /* Token for command interpreter (returned - * by previous call to Tcl_CreateInterp). */ - CONST char *string; /* Pointer to TCL command to execute. */ +Tcl_Eval(interp, script) + Tcl_Interp *interp; /* Token for command interpreter (returned by + * previous call to Tcl_CreateInterp). */ + CONST char *script; /* Pointer to TCL command to execute. */ { - int code = Tcl_EvalEx(interp, string, -1, 0); + int code = Tcl_EvalEx(interp, script, -1, 0); /* - * For backwards compatibility with old C code that predates the - * object system in Tcl 8.0, we have to mirror the object result - * back into the string result (some callers may expect it there). + * For backwards compatibility with old C code that predates the object + * system in Tcl 8.0, we have to mirror the object result back into the + * string result (some callers may expect it there). */ (void) Tcl_GetStringResult(interp); return code; } @@ -3699,72 +4013,101 @@ *---------------------------------------------------------------------- * * Tcl_EvalObjEx -- * * Execute Tcl commands stored in a Tcl object. These commands are - * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT - * is specified. + * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT is + * specified. * * Results: - * The return value is one of the return codes defined in tcl.h - * (such as TCL_OK), and the interpreter's result contains a value - * to supplement the return code. + * The return value is one of the return codes defined in tcl.h (such as + * TCL_OK), and the interpreter's result contains a value to supplement + * the return code. * * Side effects: - * The object is converted, if necessary, to a ByteCode object that - * holds the bytecode instructions for the commands. Executing the - * commands will almost certainly have side effects that depend - * on those commands. + * The object is converted, if necessary, to a ByteCode object that holds + * the bytecode instructions for the commands. Executing the commands + * will almost certainly have side effects that depend on those commands. * *---------------------------------------------------------------------- */ int Tcl_EvalObjEx(interp, objPtr, flags) - Tcl_Interp *interp; /* Token for command interpreter - * (returned by a previous call to - * Tcl_CreateInterp). */ - register Tcl_Obj *objPtr; /* Pointer to object containing - * commands to execute. */ - int flags; /* Collection of OR-ed bits that - * control the evaluation of the - * script. Supported values are - * TCL_EVAL_GLOBAL and - * TCL_EVAL_DIRECT. */ + Tcl_Interp *interp; /* Token for command interpreter (returned by + * a previous call to Tcl_CreateInterp). */ + register Tcl_Obj *objPtr; /* Pointer to object containing commands to + * execute. */ + int flags; /* Collection of OR-ed bits that control the + * evaluation of the script. Supported values + * are TCL_EVAL_GLOBAL and TCL_EVAL_DIRECT. */ { register Interp *iPtr = (Interp *) interp; char *script; int numSrcBytes; int result; - CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr - * in case TCL_EVAL_GLOBAL was set. */ + CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case + * TCL_EVAL_GLOBAL was set. */ int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); Tcl_IncrRefCount(objPtr); if (flags & TCL_EVAL_DIRECT) { /* * We're not supposed to use the compiler or byte-code interpreter. - * Let Tcl_EvalEx evaluate the command directly (and probably - * more slowly). - * - * Pure List Optimization (no string representation). In this - * case, we can safely use Tcl_EvalObjv instead and get an - * appreciable improvement in execution speed. This is because it - * allows us to avoid a setFromAny step that would just pack - * everything into a string and back out again. + * Let Tcl_EvalEx evaluate the command directly (and probably more + * slowly). + * + * Pure List Optimization (no string representation). In this case, we + * can safely use Tcl_EvalObjv instead and get an appreciable + * improvement in execution speed. This is because it allows us to + * avoid a setFromAny step that would just pack everything into a + * string and back out again. + * + * This restriction has been relaxed a bit by storing in lists whether + * they are "canonical" or not (a canonical list being one that is + * either pure or that has its string rep derived by + * UpdateStringOfList from the internal rep). */ - if ((objPtr->typePtr == &tclListType) && /* is a list... */ - (objPtr->bytes == NULL) /* ...without a string rep */) { - register List *listRepPtr = - (List *) objPtr->internalRep.twoPtrValue.ptr1; - result = Tcl_EvalObjv(interp, listRepPtr->elemCount, - listRepPtr->elements, flags); - } else { - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - result = Tcl_EvalEx(interp, script, numSrcBytes, flags); - } + + if (objPtr->typePtr == &tclListType) { /* is a list... */ + List *listRepPtr; + + listRepPtr = (List *) objPtr->internalRep.twoPtrValue.ptr1; + + if (objPtr->bytes == NULL || /* ...without a string rep */ + listRepPtr->canonicalFlag) {/* ...or that is canonical */ + + /* + * Increase the reference count of the List structure, to + * avoid a segfault if objPtr loses its List internal rep [Bug + * 1119369] + */ + + listRepPtr->refCount++; + + result = Tcl_EvalObjv(interp, listRepPtr->elemCount, + &listRepPtr->elements, flags); + + /* + * If we are the last users of listRepPtr, free it. + */ + + if (--listRepPtr->refCount <= 0) { + int i, elemCount = listRepPtr->elemCount; + Tcl_Obj **elements = &listRepPtr->elements; + + for (i=0; inumLevels == 0) { if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } - if ((result != TCL_OK) && (result != TCL_ERROR) - && !allowExceptions) { + if ((result != TCL_OK) && (result != TCL_ERROR) + && !allowExceptions) { ProcessUnexpectedResult(interp, result); result = TCL_ERROR; script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); Tcl_LogCommandInfo(interp, script, script, numSrcBytes); } } iPtr->evalFlags = 0; - iPtr->varFramePtr = savedVarFramePtr; + iPtr->varFramePtr = savedVarFramePtr; } + done: TclDecrRefCount(objPtr); return result; } /* *---------------------------------------------------------------------- * * ProcessUnexpectedResult -- * - * Procedure called by Tcl_EvalObj to set the interpreter's result - * value to an appropriate error message when the code it evaluates - * returns an unexpected result code (not TCL_OK and not TCL_ERROR) to - * the topmost evaluation level. + * Procedure called by Tcl_EvalObj to set the interpreter's result value + * to an appropriate error message when the code it evaluates returns an + * unexpected result code (not TCL_OK and not TCL_ERROR) to the topmost + * evaluation level. * * Results: * None. * * Side effects: - * The interpreter result is set to an error message appropriate to - * the result code. + * The interpreter result is set to an error message appropriate to the + * result code. * *---------------------------------------------------------------------- */ static void @@ -3832,14 +4176,13 @@ "invoked \"break\" outside of a loop", (char *) NULL); } else if (returnCode == TCL_CONTINUE) { Tcl_AppendResult(interp, "invoked \"continue\" outside of a loop", (char *) NULL); } else { - char buf[30 + TCL_INTEGER_SPACE]; - - sprintf(buf, "command returned bad code: %d", returnCode); - Tcl_SetResult(interp, buf, TCL_VOLATILE); + Tcl_Obj *objPtr = Tcl_NewObj(); + TclObjPrintf(NULL, objPtr, "command returned bad code: %d", returnCode); + Tcl_SetObjResult(interp, objPtr); } } /* *--------------------------------------------------------------------------- @@ -3850,264 +4193,219 @@ * particular form. * * Results: * Each of the procedures below returns a standard Tcl result. If an * error occurs then an error message is left in the interp's result. - * Otherwise the value of the expression, in the appropriate form, - * is stored at *ptr. If the expression had a result that was - * incompatible with the desired form then an error is returned. + * Otherwise the value of the expression, in the appropriate form, is + * stored at *ptr. If the expression had a result that was incompatible + * with the desired form then an error is returned. * * Side effects: * None. * *--------------------------------------------------------------------------- */ int -Tcl_ExprLong(interp, string, ptr) - Tcl_Interp *interp; /* Context in which to evaluate the - * expression. */ - CONST char *string; /* Expression to evaluate. */ - long *ptr; /* Where to store result. */ -{ - register Tcl_Obj *exprPtr; - Tcl_Obj *resultPtr; - int length = strlen(string); - int result = TCL_OK; - - if (length > 0) { - exprPtr = Tcl_NewStringObj(string, length); - 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 { - 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. - */ - - (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; -} - -int -Tcl_ExprDouble(interp, string, ptr) - Tcl_Interp *interp; /* Context in which to evaluate the - * expression. */ - CONST char *string; /* Expression to evaluate. */ - double *ptr; /* Where to store result. */ -{ - register Tcl_Obj *exprPtr; - Tcl_Obj *resultPtr; - int length = strlen(string); - int result = TCL_OK; - - if (length > 0) { - exprPtr = Tcl_NewStringObj(string, length); - 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 { - 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. - */ - - (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; -} - -int -Tcl_ExprBoolean(interp, string, ptr) - Tcl_Interp *interp; /* Context in which to evaluate the - * expression. */ - CONST char *string; /* Expression to evaluate. */ - int *ptr; /* Where to store 0/1 result. */ -{ - register Tcl_Obj *exprPtr; - Tcl_Obj *resultPtr; - int length = strlen(string); - int result = TCL_OK; - - if (length > 0) { - exprPtr = Tcl_NewStringObj(string, length); - Tcl_IncrRefCount(exprPtr); - result = Tcl_ExprObj(interp, exprPtr, &resultPtr); - if (result == TCL_OK) { - /* - * Store a boolean based on the expression result. - */ - - if (resultPtr->typePtr == &tclIntType) { - *ptr = (resultPtr->internalRep.longValue != 0); - } else if (resultPtr->typePtr == &tclDoubleType) { - *ptr = (resultPtr->internalRep.doubleValue != 0.0); - } else { - result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); - } - Tcl_DecrRefCount(resultPtr); /* discard the result object */ - } - if (result != TCL_OK) { - /* - * Move the interpreter's object result to the string result, - * then reset the object result. - */ - - (void) Tcl_GetStringResult(interp); - } - Tcl_DecrRefCount(exprPtr); /* discard the expression object */ - } else { - /* - * An empty string. Just set the result boolean to 0 (false). - */ - - *ptr = 0; - } - return result; +Tcl_ExprLong(interp, exprstring, ptr) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + CONST char *exprstring; /* Expression to evaluate. */ + long *ptr; /* Where to store result. */ +{ + register Tcl_Obj *exprPtr; + int result = TCL_OK; + 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_ExprLongObj(interp, exprPtr, ptr); + Tcl_DecrRefCount(exprPtr); + if (result != TCL_OK) { + (void) Tcl_GetStringResult(interp); + } + } + return result; +} + +int +Tcl_ExprDouble(interp, exprstring, ptr) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + CONST char *exprstring; /* Expression to evaluate. */ + double *ptr; /* Where to store result. */ +{ + register Tcl_Obj *exprPtr; + int result = TCL_OK; + + 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_ExprDoubleObj(interp, exprPtr, ptr); + Tcl_DecrRefCount(exprPtr); /* discard the expression object */ + if (result != TCL_OK) { + (void) Tcl_GetStringResult(interp); + } + } + return result; +} + +int +Tcl_ExprBoolean(interp, exprstring, ptr) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + CONST char *exprstring; /* Expression to evaluate. */ + int *ptr; /* Where to store 0/1 result. */ +{ + if (*exprstring == '\0') { + /* + * An empty string. Just set the result boolean to 0 (false). + */ + + *ptr = 0; + return TCL_OK; + } else { + int result; + Tcl_Obj *exprPtr = Tcl_NewStringObj(exprstring, -1); + + Tcl_IncrRefCount(exprPtr); + result = Tcl_ExprBooleanObj(interp, exprPtr, ptr); + Tcl_DecrRefCount(exprPtr); + if (result != TCL_OK) { + /* + * Move the interpreter's object result to the string result, then + * reset the object result. + */ + + (void) Tcl_GetStringResult(interp); + } + return result; + } } /* *-------------------------------------------------------------- * * Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj -- * - * Procedures to evaluate an expression in an object and return its - * value in a particular form. + * Procedures to evaluate an expression in an object and return its value + * in a particular form. * * Results: - * Each of the procedures below returns a standard Tcl result - * object. If an error occurs then an error message is left in the - * interpreter's result. Otherwise the value of the expression, in the - * appropriate form, is stored at *ptr. If the expression had a result - * that was incompatible with the desired form then an error is - * returned. + * Each of the procedures below returns a standard Tcl result object. If + * an error occurs then an error message is left in the interpreter's + * result. Otherwise the value of the expression, in the appropriate + * form, is stored at *ptr. If the expression had a result that was + * incompatible with the desired form then an error is returned. * * Side effects: * None. * *-------------------------------------------------------------- */ int Tcl_ExprLongObj(interp, objPtr, ptr) - Tcl_Interp *interp; /* Context in which to evaluate the - * expression. */ - register Tcl_Obj *objPtr; /* Expression to evaluate. */ - long *ptr; /* Where to store long result. */ + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + register Tcl_Obj *objPtr; /* Expression to evaluate. */ + 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; - } - } - Tcl_DecrRefCount(resultPtr); /* discard the result object */ - } + 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; + } + 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; } int Tcl_ExprDoubleObj(interp, objPtr, ptr) - Tcl_Interp *interp; /* Context in which to evaluate the - * expression. */ - register Tcl_Obj *objPtr; /* Expression to evaluate. */ - double *ptr; /* Where to store double result. */ + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + register Tcl_Obj *objPtr; /* Expression to evaluate. */ + 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; - } - } - Tcl_DecrRefCount(resultPtr); /* discard the result object */ - } + 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 */ return result; } int Tcl_ExprBooleanObj(interp, objPtr, ptr) - Tcl_Interp *interp; /* Context in which to evaluate the - * expression. */ - register Tcl_Obj *objPtr; /* Expression to evaluate. */ - int *ptr; /* Where to store 0/1 result. */ + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + register Tcl_Obj *objPtr; /* Expression to evaluate. */ + int *ptr; /* Where to store 0/1 result. */ { Tcl_Obj *resultPtr; int result; result = Tcl_ExprObj(interp, objPtr, &resultPtr); if (result == TCL_OK) { - if (resultPtr->typePtr == &tclIntType) { - *ptr = (resultPtr->internalRep.longValue != 0); - } else if (resultPtr->typePtr == &tclDoubleType) { - *ptr = (resultPtr->internalRep.doubleValue != 0.0); - } else { - result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); - } + result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); Tcl_DecrRefCount(resultPtr); /* discard the result object */ } return result; } @@ -4114,16 +4412,15 @@ /* *---------------------------------------------------------------------- * * TclObjInvokeNamespace -- * - * Object version: Invokes a Tcl command, given an objv/objc, from - * either the exposed or hidden set of commands in the given - * interpreter. + * Object version: Invokes a Tcl command, given an objv/objc, from either + * the exposed or hidden set of commands in the given interpreter. * NOTE: The command is invoked in the global stack frame of the - * interpreter or namespace, thus it cannot see any current state on - * the stack of that interpreter. + * interpreter or namespace, thus it cannot see any current state on the + * stack of that interpreter. * * Results: * A standard Tcl result. * * Side effects: @@ -4138,41 +4435,40 @@ * invoked. */ int objc; /* Count of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the * name of the command to invoke. */ Tcl_Namespace *nsPtr; /* The namespace to use. */ - int flags; /* Combination of flags controlling the - * call: TCL_INVOKE_HIDDEN, - * TCL_INVOKE_NO_UNKNOWN, or - * TCL_INVOKE_NO_TRACEBACK. */ + int flags; /* Combination of flags controlling the call: + * TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN, + * or TCL_INVOKE_NO_TRACEBACK. */ { - Tcl_CallFrame frame; int result; + Tcl_CallFrame *framePtr; /* - * Make the specified namespace the current namespace and invoke - * the command. + * Make the specified namespace the current namespace and invoke the + * command. */ - result = Tcl_PushCallFrame(interp, &frame, nsPtr, /*isProcCallFrame*/ 0); + result = TclPushStackFrame(interp, &framePtr, nsPtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; } result = TclObjInvoke(interp, objc, objv, flags); - Tcl_PopCallFrame(interp); + TclPopStackFrame(interp); return result; } /* *---------------------------------------------------------------------- * * TclObjInvoke -- * - * Invokes a Tcl command, given an objv/objc, from either the - * exposed or the hidden sets of commands in the given interpreter. + * Invokes a Tcl command, given an objv/objc, from either the exposed or + * the hidden sets of commands in the given interpreter. * * Results: * A standard Tcl object result. * * Side effects: @@ -4186,29 +4482,28 @@ Tcl_Interp *interp; /* Interpreter in which command is to be * invoked. */ int objc; /* Count of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the * name of the command to invoke. */ - int flags; /* Combination of flags controlling the - * call: TCL_INVOKE_HIDDEN, - * TCL_INVOKE_NO_UNKNOWN, or - * TCL_INVOKE_NO_TRACEBACK. */ + int flags; /* Combination of flags controlling the call: + * TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN, + * or TCL_INVOKE_NO_TRACEBACK. */ { register Interp *iPtr = (Interp *) interp; Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ char *cmdName; /* Name of the command from objv[0]. */ Tcl_HashEntry *hPtr = NULL; Command *cmdPtr; int result; if (interp == (Tcl_Interp *) NULL) { - return TCL_ERROR; + return TCL_ERROR; } if ((objc < 1) || (objv == (Tcl_Obj **) NULL)) { - Tcl_AppendResult(interp, "illegal argument vector", (char *) NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "illegal argument vector", (char *) NULL); + return TCL_ERROR; } if ((flags & TCL_INVOKE_HIDDEN) == 0) { Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN"); } @@ -4227,28 +4522,33 @@ cmdName, "\"", (char *) NULL); return TCL_ERROR; } cmdPtr = (Command *) Tcl_GetHashValue(hPtr); - /* Invoke the command procedure. */ + /* + * Invoke the command procedure. + */ iPtr->cmdCount++; result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); /* - * If an error occurred, record information about what was being - * executed when the error occurred. + * If an error occurred, record information about what was being executed + * when the error occurred. */ if ((result == TCL_ERROR) && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0) && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) { int length; Tcl_Obj *command = Tcl_NewListObj(objc, objv); - CONST char* cmdString = Tcl_GetStringFromObj(command, &length); + CONST char* cmdString; + Tcl_IncrRefCount(command); + cmdString = Tcl_GetStringFromObj(command, &length); Tcl_LogCommandInfo(interp, cmdString, cmdString, length); + Tcl_DecrRefCount(command); iPtr->flags &= ~ERR_ALREADY_LOGGED; } return result; } @@ -4260,94 +4560,69 @@ * Evaluate an expression in a string and return its value in string * form. * * Results: * A standard Tcl result. If the result is TCL_OK, then the interp's - * result is set to the string value of the expression. If the result - * is TCL_ERROR, then the interp's result contains an error message. + * result is set to the string value of the expression. If the result is + * TCL_ERROR, then the interp's result contains an error message. * * Side effects: * A Tcl object is allocated to hold a copy of the expression string. - * This expression object is passed to Tcl_ExprObj and then - * deallocated. + * This expression object is passed to Tcl_ExprObj and then deallocated. * *--------------------------------------------------------------------------- */ int -Tcl_ExprString(interp, string) +Tcl_ExprString(interp, expr) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ - CONST char *string; /* Expression to evaluate. */ -{ - register Tcl_Obj *exprPtr; - Tcl_Obj *resultPtr; - int length = strlen(string); - char buf[TCL_DOUBLE_SPACE]; - int result = TCL_OK; - - if (length > 0) { - TclNewObj(exprPtr); - TclInitStringRep(exprPtr, string, length); - Tcl_IncrRefCount(exprPtr); - - result = Tcl_ExprObj(interp, exprPtr, &resultPtr); - if (result == TCL_OK) { - /* - * Set the interpreter's string result from the result object. - */ - - if (resultPtr->typePtr == &tclIntType) { - sprintf(buf, "%ld", resultPtr->internalRep.longValue); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - } else if (resultPtr->typePtr == &tclDoubleType) { - Tcl_PrintDouble((Tcl_Interp *) NULL, - resultPtr->internalRep.doubleValue, buf); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - } else { - /* - * Set interpreter's string result from the result object. - */ - - Tcl_SetResult(interp, TclGetString(resultPtr), - TCL_VOLATILE); - } - Tcl_DecrRefCount(resultPtr); /* discard the result object */ - } else { - /* - * Move the interpreter's object result to the string result, - * then reset the object result. - */ - - (void) Tcl_GetStringResult(interp); - } - Tcl_DecrRefCount(exprPtr); /* discard the expression object */ - } else { + CONST char *expr; /* Expression to evaluate. */ +{ + int code = TCL_OK; + + if (expr[0] == '\0') { /* * An empty string. Just set the interpreter's result to 0. */ - + Tcl_SetResult(interp, "0", TCL_VOLATILE); + } else { + Tcl_Obj *resultPtr, *exprObj = Tcl_NewStringObj(expr, -1); + + Tcl_IncrRefCount(exprObj); + code = Tcl_ExprObj(interp, exprObj, &resultPtr); + Tcl_DecrRefCount(exprObj); + if (code == TCL_OK) { + Tcl_SetObjResult(interp, resultPtr); + Tcl_DecrRefCount(resultPtr); + } + + /* + * Force the string rep of the interp result. + */ + + (void) Tcl_GetStringResult(interp); } - return result; + return code; } /* *---------------------------------------------------------------------- * * TclAppendObjToErrorInfo -- * - * Add a Tcl_Obj value to the errorInfo field that describes the - * current error. + * Add a Tcl_Obj value to the errorInfo field that describes the current + * error. * * Results: * None. * * Side effects: - * The value of the Tcl_obj is appended to the errorInfo field. - * If we are just starting to log an error, errorInfo is initialized - * from the error message in the interpreter's result. + * The value of the Tcl_obj is appended to the errorInfo field. If we are + * just starting to log an error, errorInfo is initialized from the error + * message in the interpreter's result. * *---------------------------------------------------------------------- */ void @@ -4356,28 +4631,29 @@ * pertains. */ Tcl_Obj *objPtr; /* Message to record. */ { int length; CONST char *message = Tcl_GetStringFromObj(objPtr, &length); + Tcl_AddObjErrorInfo(interp, message, length); } /* *---------------------------------------------------------------------- * * Tcl_AddErrorInfo -- * - * Add information to the errorInfo field that describes the - * current error. + * Add information to the errorInfo field that describes the current + * error. * * Results: * None. * * Side effects: - * The contents of message are appended to the errorInfo field. - * If we are just starting to log an error, errorInfo is initialized - * from the error message in the interpreter's result. + * The contents of message are appended to the errorInfo field. If we are + * just starting to log an error, errorInfo is initialized from the error + * message in the interpreter's result. * *---------------------------------------------------------------------- */ void @@ -4392,22 +4668,22 @@ /* *---------------------------------------------------------------------- * * Tcl_AddObjErrorInfo -- * - * Add information to the errorInfo field that describes the - * current error. This routine differs from Tcl_AddErrorInfo by - * taking a byte pointer and length. + * Add information to the errorInfo field that describes the current + * error. This routine differs from Tcl_AddErrorInfo by taking a byte + * pointer and length. * * Results: * None. * * Side effects: - * "length" bytes from "message" are appended to the errorInfo field. - * If "length" is negative, use bytes up to the first NULL byte. - * If we are just starting to log an error, errorInfo is initialized - * from the error message in the interpreter's result. + * "length" bytes from "message" are appended to the errorInfo field. If + * "length" is negative, use bytes up to the first NULL byte. If we are + * just starting to log an error, errorInfo is initialized from the error + * message in the interpreter's result. * *---------------------------------------------------------------------- */ void @@ -4414,30 +4690,30 @@ Tcl_AddObjErrorInfo(interp, message, length) Tcl_Interp *interp; /* Interpreter to which error information * pertains. */ CONST char *message; /* Points to the first byte of an array of * bytes of the message. */ - int length; /* The number of bytes in the message. - * If < 0, then append all bytes up to a - * NULL byte. */ + int length; /* The number of bytes in the message. If < 0, + * then append all bytes up to a NULL byte. */ { register Interp *iPtr = (Interp *) interp; - + /* - * If we are just starting to log an error, errorInfo is initialized - * from the error message in the interpreter's result. + * If we are just starting to log an error, errorInfo is initialized from + * the error message in the interpreter's result. */ if (iPtr->errorInfo == NULL) { /* just starting to log error */ if (iPtr->result[0] != 0) { /* - * The interp's string result is set, apparently by some - * extension making a deprecated direct write to it. - * That extension may expect interp->result to continue - * to be set, so we'll take special pains to avoid clearing - * it, until we drop support for interp->result completely. + * The interp's string result is set, apparently by some extension + * making a deprecated direct write to it. That extension may + * expect interp->result to continue to be set, so we'll take + * special pains to avoid clearing it, until we drop support for + * interp->result completely. */ + iPtr->errorInfo = Tcl_NewStringObj(interp->result, -1); } else { iPtr->errorInfo = iPtr->objResultPtr; } Tcl_IncrRefCount(iPtr->errorInfo); @@ -4463,37 +4739,36 @@ /* *--------------------------------------------------------------------------- * * Tcl_VarEvalVA -- * - * Given a variable number of string arguments, concatenate them - * all together and execute the result as a Tcl command. + * Given a variable number of string arguments, concatenate them all + * together and execute the result as a Tcl command. * * Results: - * A standard Tcl return result. An error message or other result may - * be left in the interp's result. + * A standard Tcl return result. An error message or other result may be + * left in the interp's result. * * Side effects: * Depends on what was done by the command. * *--------------------------------------------------------------------------- */ int -Tcl_VarEvalVA (interp, argList) +Tcl_VarEvalVA(interp, argList) Tcl_Interp *interp; /* Interpreter in which to evaluate command. */ va_list argList; /* Variable argument list. */ { Tcl_DString buf; char *string; int result; /* - * Copy the strings one after the other into a single larger - * string. Use stack-allocated space for small commands, but if - * the command gets too large than call ckalloc to create the - * space. + * Copy the strings one after the other into a single larger string. Use + * stack-allocated space for small commands, but if the command gets too + * large than call ckalloc to create the space. */ Tcl_DStringInit(&buf); while (1) { string = va_arg(argList, char *); @@ -4511,31 +4786,30 @@ /* *---------------------------------------------------------------------- * * Tcl_VarEval -- * - * Given a variable number of string arguments, concatenate them - * all together and execute the result as a Tcl command. + * Given a variable number of string arguments, concatenate them all + * together and execute the result as a Tcl command. * * Results: - * A standard Tcl return result. An error message or other - * result may be left in interp->result. + * A standard Tcl return result. An error message or other result may be + * left in interp->result. * * Side effects: * Depends on what was done by the command. * *---------------------------------------------------------------------- */ - /* VARARGS2 */ /* ARGSUSED */ + /* ARGSUSED */ int -Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1) +Tcl_VarEval(Tcl_Interp *interp, ...) { - Tcl_Interp *interp; va_list argList; int result; - interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); + va_start(argList, interp); result = Tcl_VarEvalVA(interp, argList); va_end(argList); return result; } @@ -4546,18 +4820,17 @@ * Tcl_GlobalEval -- * * Evaluate a command at global level in an interpreter. * * Results: - * A standard Tcl result is returned, and the interp's result is - * modified accordingly. + * A standard Tcl result is returned, and the interp's result is modified + * accordingly. * * Side effects: - * The command string is executed in interp, and the execution - * is carried out in the variable context of global level (no - * procedures active), just as if an "uplevel #0" command were - * being executed. + * The command string is executed in interp, and the execution is carried + * out in the variable context of global level (no procedures active), + * just as if an "uplevel #0" command were being executed. * --------------------------------------------------------------------------- */ int @@ -4579,12 +4852,12 @@ /* *---------------------------------------------------------------------- * * Tcl_SetRecursionLimit -- * - * Set the maximum number of recursive calls that may be active - * for an interpreter at once. + * Set the maximum number of recursive calls that may be active for an + * interpreter at once. * * Results: * The return value is the old limit on nesting for interp. * * Side effects: @@ -4593,13 +4866,13 @@ *---------------------------------------------------------------------- */ int Tcl_SetRecursionLimit(interp, depth) - Tcl_Interp *interp; /* Interpreter whose nesting limit - * is to be set. */ - int depth; /* New value for maximimum depth. */ + Tcl_Interp *interp; /* Interpreter whose nesting limit is to be + * set. */ + int depth; /* New value for maximimum depth. */ { Interp *iPtr = (Interp *) interp; int old; old = iPtr->maxNestingDepth; @@ -4612,21 +4885,19 @@ /* *---------------------------------------------------------------------- * * Tcl_AllowExceptions -- * - * Sets a flag in an interpreter so that exceptions can occur - * in the next call to Tcl_Eval without them being turned into - * errors. + * Sets a flag in an interpreter so that exceptions can occur in the next + * call to Tcl_Eval without them being turned into errors. * * Results: * None. * * Side effects: - * The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's - * evalFlags structure. See the reference documentation for - * more details. + * The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's evalFlags + * structure. See the reference documentation for more details. * *---------------------------------------------------------------------- */ void @@ -4635,20 +4906,19 @@ { Interp *iPtr = (Interp *) interp; iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS; } - /* *---------------------------------------------------------------------- * - * Tcl_GetVersion + * Tcl_GetVersion -- * - * Get the Tcl major, minor, and patchlevel version numbers and - * the release type. A patch is a release type TCL_FINAL_RELEASE - * with a patchLevel > 0. + * Get the Tcl major, minor, and patchlevel version numbers and the + * release type. A patch is a release type TCL_FINAL_RELEASE with a + * patchLevel > 0. * * Results: * None. * * Side effects: @@ -4663,18 +4933,845 @@ int *minorV; int *patchLevelV; int *type; { if (majorV != NULL) { - *majorV = TCL_MAJOR_VERSION; + *majorV = TCL_MAJOR_VERSION; } if (minorV != NULL) { - *minorV = TCL_MINOR_VERSION; + *minorV = TCL_MINOR_VERSION; } if (patchLevelV != NULL) { - *patchLevelV = TCL_RELEASE_SERIAL; + *patchLevelV = TCL_RELEASE_SERIAL; } if (type != NULL) { - *type = TCL_RELEASE_LEVEL; + *type = TCL_RELEASE_LEVEL; + } +} + +/* + *---------------------------------------------------------------------- + * + * Math Functions -- + * + * This page contains the procedures that implement all of the built-in + * math functions for expressions. + * + * Results: + * Each procedure returns TCL_OK if it succeeds and pushes an Tcl object + * holding the result. If it fails it returns TCL_ERROR and leaves an + * error message in the interpreter's result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +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 */ +{ + int code; + double d; + mp_int big; + + 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; +} + +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); + 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; +} + +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; + + 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; +} + +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 +ExprBinaryFunc(clientData, interp, objc, objv) + ClientData clientData; /* Contains the address of a procedure that + * takes two double arguments and returns a + * double result. */ + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + int objc; /* Actual parameter count */ + Tcl_Obj *CONST *objv; /* Parameter vector */ +{ + int code; + double d1, d2; + double (*func)(double, double) = (double (*)(double, double)) clientData; + + if (objc != 3) { + MathFuncWrongNumArgs(interp, 3, objc, objv); + 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; + } +#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 +ExprAbsFunc(clientData, interp, objc, objv) + ClientData clientData; /* Ignored. */ + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + int objc; /* Actual parameter count */ + Tcl_Obj *CONST *objv; /* Parameter vector */ +{ + ClientData ptr; + int type; + mp_int big; + + 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_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 { + Tcl_SetObjResult(interp, objv[1]); + } + return TCL_OK; + } + + 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) { + if (w == LLONG_MIN) { + TclBNInitBignumFromWideInt(&big, w); + goto tooLarge; + } + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-w)); + } else { + Tcl_SetObjResult(interp, objv[1]); + } + 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 { + Tcl_SetObjResult(interp, objv[1]); + } + 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 +ExprBoolFunc(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 */ +{ + int value; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + if (Tcl_GetBooleanFromObj(interp, objv[1], &value) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); + return TCL_OK; +} + +static int +ExprDoubleFunc(clientData, interp, objc, objv) + ClientData clientData; /* Ignored. */ + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + int objc; /* Actual parameter count */ + Tcl_Obj *CONST *objv; /* Actual parameter vector */ +{ + double dResult; +#if 0 + Tcl_Obj* valuePtr; + Tcl_Obj* oResult; + + /* + * Check parameter type + */ + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + } else { + valuePtr = objv[1]; + if (VerifyExprObjType(interp, valuePtr) == TCL_OK) { + GET_DOUBLE_VALUE(dResult, valuePtr, valuePtr->typePtr); + TclNewDoubleObj(oResult, dResult); + Tcl_SetObjResult(interp, oResult); + return TCL_OK; + } + } + + return TCL_ERROR; +#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 +ExprIntFunc(clientData, interp, objc, objv) + ClientData clientData; /* Ignored. */ + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + int objc; /* Actual parameter count */ + Tcl_Obj *CONST *objv; /* Actual parameter vector */ +{ + long iResult; + Tcl_Obj *objPtr; +#if 0 + register Tcl_Obj *valuePtr; + Tcl_Obj* oResult; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + } else { + valuePtr = objv[1]; + if (VerifyExprObjType(interp, valuePtr) == TCL_OK) { + if (valuePtr->typePtr == &tclIntType) { + iResult = valuePtr->internalRep.longValue; + } else if (valuePtr->typePtr == &tclWideIntType) { + TclGetLongFromWide(iResult,valuePtr); + } else { + d = valuePtr->internalRep.doubleValue; + if (d < 0.0) { + if (d < (double) (long) LONG_MIN) { + tooLarge: + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "integer value too large to represent", -1)); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + "integer value too large to represent", + (char *) NULL); + return TCL_ERROR; + } + } else if (d > (double) LONG_MAX) { + goto tooLarge; + } + if (IS_NAN(d) || IS_INF(d)) { + TclExprFloatError(interp, d); + return TCL_ERROR; + } + iResult = (long) d; + } + TclNewIntObj(oResult, iResult); + Tcl_SetObjResult(interp, oResult); + return TCL_OK; + } + } + return TCL_ERROR; +#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 +ExprWideFunc(clientData, interp, objc, objv) + ClientData clientData; /* Ignored. */ + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + int objc; /* Actual parameter count */ + Tcl_Obj *CONST *objv; /* Actual parameter vector */ +{ + Tcl_WideInt wResult; + Tcl_Obj *objPtr; +#if 0 + register Tcl_Obj *valuePtr; + Tcl_Obj* oResult; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + } else { + valuePtr = objv[1]; + if (VerifyExprObjType(interp, valuePtr) == TCL_OK) { + if (valuePtr->typePtr == &tclIntType) { + wResult = valuePtr->internalRep.longValue; + } else if (valuePtr->typePtr == &tclWideIntType) { + wResult = valuePtr->internalRep.wideValue; + } else { + d = valuePtr->internalRep.doubleValue; + if (d < 0.0) { + if (d < Tcl_WideAsDouble(LLONG_MIN)) { + tooLarge: + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "integer value too large to represent", -1)); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + "integer value too large to represent", + (char *) NULL); + return TCL_ERROR; + } + } else if (d > Tcl_WideAsDouble(LLONG_MAX)) { + goto tooLarge; + } + if (IS_NAN(d) || IS_INF(d)) { + TclExprFloatError(interp, d); + return TCL_ERROR; + } + wResult = (Tcl_WideInt) d; + } + TclNewWideIntObj(oResult, wResult); + Tcl_SetObjResult(interp, oResult); + return TCL_OK; + } + } + return TCL_ERROR; +#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 +ExprRandFunc(clientData, interp, objc, objv) + ClientData clientData; /* Ignored. */ + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + int objc; /* Actual parameter count */ + Tcl_Obj *CONST *objv; /* Actual parameter vector */ +{ + Interp *iPtr = (Interp *) interp; + double dResult; + long tmp; /* Algorithm assumes at least 32 bits. + * Only long guarantees that. See below. */ + Tcl_Obj* oResult; + + if (objc != 1) { + MathFuncWrongNumArgs(interp, 1, objc, objv); + return TCL_ERROR; + } + + if (!(iPtr->flags & RAND_SEED_INITIALIZED)) { + iPtr->flags |= RAND_SEED_INITIALIZED; + + /* + * Take into consideration the thread this interp is running in order + * to insure different seeds in different threads (bug #416643) + */ + + iPtr->randSeed = TclpGetClicks() + ((long)Tcl_GetCurrentThread()<<12); + + /* + * Make sure 1 <= randSeed <= (2^31) - 2. See below. + */ + + iPtr->randSeed &= (unsigned long) 0x7fffffff; + if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { + iPtr->randSeed ^= 123459876; + } + } + + /* + * Generate the random number using the linear congruential generator + * defined by the following recurrence: + * seed = ( IA * seed ) mod IM + * where IA is 16807 and IM is (2^31) - 1. The recurrence maps a seed in + * the range [1, IM - 1] to a new seed in that same range. The recurrence + * maps IM to 0, and maps 0 back to 0, so those two values must not be + * allowed as initial values of seed. + * + * In order to avoid potential problems with integer overflow, the + * recurrence is implemented in terms of additional constants IQ and IR + * such that + * IM = IA*IQ + IR + * None of the operations in the implementation overflows a 32-bit signed + * integer, and the C type long is guaranteed to be at least 32 bits wide. + * + * For more details on how this algorithm works, refer to the following + * papers: + * + * S.K. Park & K.W. Miller, "Random number generators: good ones are hard + * to find," Comm ACM 31(10):1192-1201, Oct 1988 + * + * W.H. Press & S.A. Teukolsky, "Portable random number generators," + * Computers in Physics 6(5):522-524, Sep/Oct 1992. + */ + +#define RAND_IA 16807 +#define RAND_IM 2147483647 +#define RAND_IQ 127773 +#define RAND_IR 2836 +#define RAND_MASK 123459876 + + tmp = iPtr->randSeed/RAND_IQ; + iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp; + if (iPtr->randSeed < 0) { + iPtr->randSeed += RAND_IM; + } + + /* + * Since the recurrence keeps seed values in the range [1, RAND_IM - 1], + * dividing by RAND_IM yields a double in the range (0, 1). + */ + + dResult = iPtr->randSeed * (1.0/RAND_IM); + + /* + * Push a Tcl object with the result. + */ + + TclNewDoubleObj(oResult, dResult); + Tcl_SetObjResult(interp, oResult); + return TCL_OK; +} + +static int +ExprRoundFunc(clientData, interp, objc, objv) + ClientData clientData; /* Ignored. */ + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + int objc; /* Actual parameter count */ + Tcl_Obj *CONST *objv; /* Parameter vector */ +{ + double d; + ClientData ptr; + int type; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 1, objc, objv); + return TCL_ERROR; + } + + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + if (type == TCL_NUMBER_DOUBLE) { + double fractPart, intPart; + long max = LONG_MAX, min = LONG_MIN; + + fractPart = modf(*((CONST double *)ptr), &intPart); + if (fractPart <= -0.5) { + min++; + } else if (fractPart >= 0.5) { + max--; + } + 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 { + long result = (long)intPart; + if (fractPart <= -0.5) { + result--; + } else if (fractPart >= 0.5) { + result++; + } + Tcl_SetObjResult(interp, Tcl_NewLongObj(result)); + return TCL_OK; + } + } + 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 +ExprSrandFunc(clientData, interp, objc, objv) + ClientData clientData; /* Ignored. */ + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + int objc; /* Actual parameter count */ + Tcl_Obj *CONST *objv; /* Parameter vector */ +{ + Interp *iPtr = (Interp *) interp; + long i = 0; /* Initialized to avoid compiler warning. */ + + /* + * Convert argument and use it to reset the seed. + */ + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + + if (Tcl_GetLongFromObj(interp, objv[1], &i) != TCL_OK) { + /* TODO: more ::errorInfo here? or in caller? */ + return TCL_ERROR; + } + + /* + * Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2. See comments in + * ExprRandFunc() for more details. + */ + + iPtr->flags |= RAND_SEED_INITIALIZED; + iPtr->randSeed = i; + iPtr->randSeed &= (unsigned long) 0x7fffffff; + if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { + iPtr->randSeed ^= 123459876; + } + + /* + * To avoid duplicating the random number generation code we simply clean + * up our state and call the real random number function. That function + * will always succeed. + */ + + return ExprRandFunc(clientData, interp, 1, objv); + +} + +/* + *---------------------------------------------------------------------- + * + * MathFuncWrongNumArgs -- + * + * Generate an error message when a math function presents the wrong + * number of arguments. + * + * Results: + * None. + * + * Side effects: + * An error message is stored in the interpreter result. + * + *---------------------------------------------------------------------- + */ + +static void +MathFuncWrongNumArgs(interp, expected, found, objv) + Tcl_Interp* interp; /* Tcl interpreter */ + int expected; /* Formal parameter count */ + int found; /* Actual parameter count */ + Tcl_Obj *CONST *objv; /* Actual parameter vector */ +{ + Tcl_Obj* errorMessage; + CONST char* name = Tcl_GetString(objv[0]); + CONST char* tail = name + strlen(name); + + while (tail > name+1) { + --tail; + if (*tail == ':' && tail[-1] == ':') { + name = tail+1; + break; + } + } + errorMessage = Tcl_NewStringObj("too ", -1); + if (found < expected) { + Tcl_AppendToObj(errorMessage, "few", -1); + } else { + Tcl_AppendToObj(errorMessage, "many", -1); } + Tcl_AppendToObj(errorMessage, " arguments for math function \"", -1); + Tcl_AppendToObj(errorMessage, name, -1); + Tcl_AppendToObj(errorMessage, "\"", -1); + Tcl_SetObjResult(interp, errorMessage); } - + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclBinary.c ================================================================== --- generic/tclBinary.c +++ generic/tclBinary.c @@ -1,27 +1,23 @@ -/* +/* * tclBinary.c -- * * This file contains the implementation of the "binary" Tcl built-in * command and the Tcl binary data object. * * Copyright (c) 1997 by Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBinary.c,v 1.21 2004/10/06 05:52:21 dgp Exp $ + * RCS: @(#) $Id: tclBinary.c,v 1.21.2.6 2005/10/08 13:44:37 dgp Exp $ */ #include "tclInt.h" -#ifdef TCL_NO_MATH -#define fabs(x) (x<0 ? -x : x) -#else #include -#endif /* * The following constants are used by GetFormatSpec to indicate various * special conditions in the parsing of a format specifier. */ @@ -28,74 +24,72 @@ #define BINARY_ALL -1 /* Use all elements in the argument. */ #define BINARY_NOCOUNT -2 /* No count was specified in format. */ /* - * The following defines the maximum number of different (integer) - * numbers placed in the object cache by 'binary scan' before it bails - * out and switches back to Plan A (creating a new object for each - * value.) Theoretically, it would be possible to keep the cache - * about for the values that are already in it, but that makes the - * code slower in practise when overflow happens, and makes little - * odds the rest of the time (as measured on my machine.) It is also - * slower (on the sample I tried at least) to grow the cache to hold - * all items we might want to put in it; presumably the extra cost of - * managing the memory for the enlarged table outweighs the benefit - * from allocating fewer objects. This is probably because as the - * number of objects increases, the likelihood of reuse of any - * particular one drops, and there is very little gain from larger - * maximum cache sizes (the value below is chosen to allow caching to - * work in full with conversion of bytes.) - DKF + * The following defines the maximum number of different (integer) numbers + * placed in the object cache by 'binary scan' before it bails out and + * switches back to Plan A (creating a new object for each value.) + * Theoretically, it would be possible to keep the cache about for the values + * that are already in it, but that makes the code slower in practise when + * overflow happens, and makes little odds the rest of the time (as measured + * on my machine.) It is also slower (on the sample I tried at least) to grow + * the cache to hold all items we might want to put in it; presumably the + * extra cost of managing the memory for the enlarged table outweighs the + * benefit from allocating fewer objects. This is probably because as the + * number of objects increases, the likelihood of reuse of any particular one + * drops, and there is very little gain from larger maximum cache sizes (the + * value below is chosen to allow caching to work in full with conversion of + * bytes.) - DKF */ #define BINARY_SCAN_MAX_CACHE 260 /* * Prototypes for local procedures defined in this file: */ -static void DupByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, - Tcl_Obj *copyPtr)); -static int FormatNumber _ANSI_ARGS_((Tcl_Interp *interp, int type, - Tcl_Obj *src, unsigned char **cursorPtr)); -static void FreeByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); -static int GetFormatSpec _ANSI_ARGS_((char **formatPtr, - char *cmdPtr, int *countPtr)); -static Tcl_Obj * ScanNumber _ANSI_ARGS_((unsigned char *buffer, - int type, Tcl_HashTable **numberCachePtr)); -static int SetByteArrayFromAny _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); -static void UpdateStringOfByteArray _ANSI_ARGS_((Tcl_Obj *listPtr)); -static void DeleteScanNumberCache _ANSI_ARGS_(( - Tcl_HashTable *numberCachePtr)); -static int NeedReversing _ANSI_ARGS_((int format)); -static void CopyNumber _ANSI_ARGS_((CONST void *from, void *to, - unsigned int length, int type)); +static void DupByteArrayInternalRep(Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr); +static int FormatNumber(Tcl_Interp *interp, int type, + Tcl_Obj *src, unsigned char **cursorPtr); +static void FreeByteArrayInternalRep(Tcl_Obj *objPtr); +static int GetFormatSpec(char **formatPtr, char *cmdPtr, + int *countPtr); +static Tcl_Obj * ScanNumber(unsigned char *buffer, int type, + Tcl_HashTable **numberCachePtr); +static int SetByteArrayFromAny(Tcl_Interp *interp, + Tcl_Obj *objPtr); +static void UpdateStringOfByteArray(Tcl_Obj *listPtr); +static void DeleteScanNumberCache(Tcl_HashTable *numberCachePtr); +static int NeedReversing(int format); +static void CopyNumber(CONST void *from, void *to, + unsigned int length, int type); /* - * The following object type represents an array of bytes. An array of - * bytes is not equivalent to an internationalized string. Conceptually, a - * string is an array of 16-bit quantities organized as a sequence of properly - * formed UTF-8 characters, while a ByteArray is an array of 8-bit quantities. + * The following object type represents an array of bytes. An array of bytes + * is not equivalent to an internationalized string. Conceptually, a string is + * an array of 16-bit quantities organized as a sequence of properly formed + * UTF-8 characters, while a ByteArray is an array of 8-bit quantities. * Accessor functions are provided to convert a ByteArray to a String or a - * String to a ByteArray. Two or more consecutive bytes in an array of bytes + * String to a ByteArray. Two or more consecutive bytes in an array of bytes * may look like a single UTF-8 character if the array is casually treated as - * a string. But obtaining the String from a ByteArray is guaranteed to - * produced properly formed UTF-8 sequences so that there is a one-to-one - * map between bytes and characters. + * a string. But obtaining the String from a ByteArray is guaranteed to + * produced properly formed UTF-8 sequences so that there is a one-to-one map + * between bytes and characters. * * Converting a ByteArray to a String proceeds by casting each byte in the * array to a 16-bit quantity, treating that number as a Unicode character, - * and storing the UTF-8 version of that Unicode character in the String. - * For ByteArrays consisting entirely of values 1..127, the corresponding - * String representation is the same as the ByteArray representation. + * and storing the UTF-8 version of that Unicode character in the String. For + * ByteArrays consisting entirely of values 1..127, the corresponding String + * representation is the same as the ByteArray representation. * * Converting a String to a ByteArray proceeds by getting the Unicode - * representation of each character in the String, casting it to a - * byte by truncating the upper 8 bits, and then storing the byte in the - * ByteArray. Converting from ByteArray to String and back to ByteArray - * is not lossy, but converting an arbitrary String to a ByteArray may be. + * representation of each character in the String, casting it to a byte by + * truncating the upper 8 bits, and then storing the byte in the ByteArray. + * Converting from ByteArray to String and back to ByteArray is not lossy, but + * converting an arbitrary String to a ByteArray may be. */ Tcl_ObjType tclByteArrayType = { "bytearray", FreeByteArrayInternalRep, @@ -103,23 +97,23 @@ UpdateStringOfByteArray, SetByteArrayFromAny }; /* - * The following structure is the internal rep for a ByteArray object. - * Keeps track of how much memory has been used and how much has been - * allocated for the byte array to enable growing and shrinking of the - * ByteArray object with fewer mallocs. + * The following structure is the internal rep for a ByteArray object. Keeps + * track of how much memory has been used and how much has been allocated for + * the byte array to enable growing and shrinking of the ByteArray object with + * fewer mallocs. */ typedef struct ByteArray { int used; /* The number of bytes used in the byte * array. */ int allocated; /* The amount of space actually allocated * minus 1 byte. */ - unsigned char bytes[4]; /* The array of bytes. The actual size of - * this field depends on the 'allocated' field + unsigned char bytes[4]; /* The array of bytes. The actual size of this + * field depends on the 'allocated' field * above. */ } ByteArray; #define BYTEARRAY_SIZE(len) \ ((unsigned) (sizeof(ByteArray) - 4 + (len))) @@ -132,17 +126,16 @@ /* *---------------------------------------------------------------------- * * Tcl_NewByteArrayObj -- * - * This procedure is creates a new ByteArray object and initializes - * it from the given array of bytes. + * This procedure is creates a new ByteArray object and initializes it + * from the given array of bytes. * * Results: - * The newly create object is returned. This object will have no - * initial string representation. The returned object has a ref count - * of 0. + * The newly create object is returned. This object will have no initial + * string representation. The returned object has a ref count of 0. * * Side effects: * Memory allocated for new object and copy of byte array argument. * *---------------------------------------------------------------------- @@ -149,29 +142,28 @@ */ #ifdef TCL_MEM_DEBUG #undef Tcl_NewByteArrayObj - Tcl_Obj * -Tcl_NewByteArrayObj(bytes, length) - CONST unsigned char *bytes; /* The array of bytes used to initialize - * the new object. */ - int length; /* Length of the array of bytes, which must - * be >= 0. */ +Tcl_NewByteArrayObj( + CONST unsigned char *bytes, /* The array of bytes used to initialize the + * new object. */ + int length) /* Length of the array of bytes, which must be + * >= 0. */ { return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * -Tcl_NewByteArrayObj(bytes, length) - CONST unsigned char *bytes; /* The array of bytes used to initialize - * the new object. */ - int length; /* Length of the array of bytes, which must - * be >= 0. */ +Tcl_NewByteArrayObj( + CONST unsigned char *bytes, /* The array of bytes used to initialize the + * new object. */ + int length) /* Length of the array of bytes, which must be + * >= 0. */ { Tcl_Obj *objPtr; TclNewObj(objPtr); Tcl_SetByteArrayObj(objPtr, bytes, length); @@ -193,13 +185,12 @@ * * When TCL_MEM_DEBUG is not defined, this procedure just returns the * result of calling Tcl_NewByteArrayObj. * * Results: - * The newly create object is returned. This object will have no - * initial string representation. The returned object has a ref count - * of 0. + * The newly create object is returned. This object will have no initial + * string representation. The returned object has a ref count of 0. * * Side effects: * Memory allocated for new object and copy of byte array argument. * *---------------------------------------------------------------------- @@ -206,19 +197,19 @@ */ #ifdef TCL_MEM_DEBUG Tcl_Obj * -Tcl_DbNewByteArrayObj(bytes, length, file, line) - CONST unsigned char *bytes; /* The array of bytes used to initialize - * the new object. */ - int length; /* Length of the array of bytes, which must - * be >= 0. */ - CONST char *file; /* The name of the source file calling this +Tcl_DbNewByteArrayObj( + CONST unsigned char *bytes, /* The array of bytes used to initialize the + * new object. */ + int length, /* Length of the array of bytes, which must be + * >= 0. */ + CONST char *file, /* The name of the source file calling this * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + int line) /* Line number in the source file; used for + * debugging. */ { Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); Tcl_SetByteArrayObj(objPtr, bytes, length); @@ -226,19 +217,19 @@ } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * -Tcl_DbNewByteArrayObj(bytes, length, file, line) - CONST unsigned char *bytes; /* The array of bytes used to initialize - * the new object. */ - int length; /* Length of the array of bytes, which must - * be >= 0. */ - CONST char *file; /* The name of the source file calling this +Tcl_DbNewByteArrayObj( + CONST unsigned char *bytes, /* The array of bytes used to initialize the + * new object. */ + int length, /* Length of the array of bytes, which must be + * >= 0. */ + CONST char *file, /* The name of the source file calling this * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + int line) /* Line number in the source file; used for + * debugging. */ { return Tcl_NewByteArrayObj(bytes, length); } #endif /* TCL_MEM_DEBUG */ @@ -252,23 +243,23 @@ * * Results: * None. * * Side effects: - * The object's old string rep and internal rep is freed. - * Memory allocated for copy of byte array argument. + * The object's old string rep and internal rep is freed. Memory + * allocated for copy of byte array argument. * *---------------------------------------------------------------------- */ void -Tcl_SetByteArrayObj(objPtr, bytes, length) - Tcl_Obj *objPtr; /* Object to initialize as a ByteArray. */ - CONST unsigned char *bytes; /* The array of bytes to use as the new +Tcl_SetByteArrayObj( + Tcl_Obj *objPtr, /* Object to initialize as a ByteArray. */ + CONST unsigned char *bytes, /* The array of bytes to use as the new * value. */ - int length; /* Length of the array of bytes, which must - * be >= 0. */ + int length) /* Length of the array of bytes, which must be + * >= 0. */ { ByteArray *byteArrayPtr; if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetByteArrayObj called with shared object"); @@ -288,31 +279,31 @@ /* *---------------------------------------------------------------------- * * Tcl_GetByteArrayFromObj -- * - * Attempt to get the array of bytes from the Tcl object. If the - * object is not already a ByteArray object, an attempt will be - * made to convert it to one. + * Attempt to get the array of bytes from the Tcl object. If the object + * is not already a ByteArray object, an attempt will be made to convert + * it to one. * * Results: * Pointer to array of bytes representing the ByteArray object. * * Side effects: - * Frees old internal rep. Allocates memory for new internal rep. + * Frees old internal rep. Allocates memory for new internal rep. * *---------------------------------------------------------------------- */ unsigned char * -Tcl_GetByteArrayFromObj(objPtr, lengthPtr) - Tcl_Obj *objPtr; /* The ByteArray object. */ - int *lengthPtr; /* If non-NULL, filled with length of the +Tcl_GetByteArrayFromObj( + Tcl_Obj *objPtr, /* The ByteArray object. */ + int *lengthPtr) /* If non-NULL, filled with length of the * array of bytes in the ByteArray object. */ { ByteArray *baPtr; - + SetByteArrayFromAny(NULL, objPtr); baPtr = GET_BYTEARRAY(objPtr); if (lengthPtr != NULL) { *lengthPtr = baPtr->used; @@ -323,34 +314,34 @@ /* *---------------------------------------------------------------------- * * Tcl_SetByteArrayLength -- * - * This procedure changes the length of the byte array for this - * object. Once the caller has set the length of the array, it - * is acceptable to directly modify the bytes in the array up until - * Tcl_GetStringFromObj() has been called on this object. + * This procedure changes the length of the byte array for this object. + * Once the caller has set the length of the array, it is acceptable to + * directly modify the bytes in the array up until Tcl_GetStringFromObj() + * has been called on this object. * * Results: * The new byte array of the specified length. * * Side effects: - * Allocates enough memory for an array of bytes of the requested - * size. When growing the array, the old array is copied to the - * new array; new bytes are undefined. When shrinking, the - * old array is truncated to the specified length. + * Allocates enough memory for an array of bytes of the requested size. + * When growing the array, the old array is copied to the new array; new + * bytes are undefined. When shrinking, the old array is truncated to the + * specified length. * *---------------------------------------------------------------------- */ unsigned char * -Tcl_SetByteArrayLength(objPtr, length) - Tcl_Obj *objPtr; /* The ByteArray object. */ - int length; /* New length for internal byte array. */ +Tcl_SetByteArrayLength( + Tcl_Obj *objPtr, /* The ByteArray object. */ + int length) /* New length for internal byte array. */ { ByteArray *byteArrayPtr, *newByteArrayPtr; - + if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetObjLength called with shared object"); } if (objPtr->typePtr != &tclByteArrayType) { SetByteArrayFromAny(NULL, objPtr); @@ -387,20 +378,20 @@ * *---------------------------------------------------------------------- */ static int -SetByteArrayFromAny(interp, objPtr) - Tcl_Interp *interp; /* Not used. */ - Tcl_Obj *objPtr; /* The object to convert to type ByteArray. */ +SetByteArrayFromAny( + Tcl_Interp *interp, /* Not used. */ + Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */ { int length; char *src, *srcEnd; unsigned char *dst; ByteArray *byteArrayPtr; Tcl_UniChar ch; - + if (objPtr->typePtr != &tclByteArrayType) { src = Tcl_GetStringFromObj(objPtr, &length); srcEnd = src + length; byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); @@ -429,30 +420,29 @@ * * Results: * None. * * Side effects: - * Frees memory. + * Frees memory. * *---------------------------------------------------------------------- */ static void -FreeByteArrayInternalRep(objPtr) - Tcl_Obj *objPtr; /* Object with internal rep to free. */ +FreeByteArrayInternalRep( + Tcl_Obj *objPtr) /* Object with internal rep to free. */ { ckfree((char *) GET_BYTEARRAY(objPtr)); } /* *---------------------------------------------------------------------- * * DupByteArrayInternalRep -- * - * Initialize the internal representation of a ByteArray Tcl_Obj - * to a copy of the internal representation of an existing ByteArray - * object. + * Initialize the internal representation of a ByteArray Tcl_Obj to a + * copy of the internal representation of an existing ByteArray object. * * Results: * None. * * Side effects: @@ -460,16 +450,16 @@ * *---------------------------------------------------------------------- */ static void -DupByteArrayInternalRep(srcPtr, copyPtr) - Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ - Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +DupByteArrayInternalRep( + Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ + Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { int length; - ByteArray *srcArrayPtr, *copyArrayPtr; + ByteArray *srcArrayPtr, *copyArrayPtr; srcArrayPtr = GET_BYTEARRAY(srcPtr); length = srcArrayPtr->used; copyArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); @@ -485,30 +475,30 @@ /* *---------------------------------------------------------------------- * * UpdateStringOfByteArray -- * - * Update the string representation for a ByteArray data object. - * Note: This procedure does not invalidate an existing old string rep - * so storage will be lost if this has not already been done. + * Update the string representation for a ByteArray data object. Note: + * This procedure does not invalidate an existing old string rep so + * storage will be lost if this has not already been done. * * Results: * None. * * Side effects: - * The object's string is set to a valid string that results from - * the ByteArray-to-string conversion. + * The object's string is set to a valid string that results from the + * ByteArray-to-string conversion. * - * The object becomes a string object -- the internal rep is - * discarded and the typePtr becomes NULL. + * The object becomes a string object -- the internal rep is discarded + * and the typePtr becomes NULL. * *---------------------------------------------------------------------- */ static void -UpdateStringOfByteArray(objPtr) - Tcl_Obj *objPtr; /* ByteArray object whose string rep to +UpdateStringOfByteArray( + Tcl_Obj *objPtr) /* ByteArray object whose string rep to * update. */ { int i, length, size; unsigned char *src; char *dst; @@ -519,11 +509,11 @@ length = byteArrayPtr->used; /* * How much space will string rep need? */ - + size = length; for (i = 0; i < length; i++) { if ((src[i] == 0) || (src[i] > 127)) { size++; } @@ -559,15 +549,15 @@ * *---------------------------------------------------------------------- */ int -Tcl_BinaryObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_BinaryObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { int arg; /* Index of next argument to consume. */ int value = 0; /* Current integer value to be packed. * Initialized to avoid compiler warning. */ char cmd; /* Current format character. */ @@ -580,14 +570,14 @@ unsigned char *cursor; /* Current position within result buffer. */ unsigned char *maxPos; /* Greatest position within result buffer that * cursor has visited.*/ char *errorString, *errorValue, *str; int offset, size, length, index; - static CONST char *options[] = { - "format", "scan", NULL + static CONST char *options[] = { + "format", "scan", NULL }; - enum options { + enum options { BINARY_FORMAT, BINARY_SCAN }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); @@ -598,775 +588,757 @@ &index) != TCL_OK) { return TCL_ERROR; } switch ((enum options) index) { - case BINARY_FORMAT: { - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?"); - return TCL_ERROR; - } - - /* - * To avoid copying the data, we format the string in two passes. - * The first pass computes the size of the output buffer. The - * second pass places the formatted data into the buffer. - */ - - format = Tcl_GetString(objv[2]); - arg = 3; - offset = 0; - length = 0; - while (*format != '\0') { - str = format; - if (!GetFormatSpec(&format, &cmd, &count)) { - break; - } - switch (cmd) { - case 'a': - case 'A': - case 'b': - case 'B': - case 'h': - case 'H': { - /* - * For string-type specifiers, the count corresponds - * to the number of bytes in a single argument. - */ - - if (arg >= objc) { - goto badIndex; - } - if (count == BINARY_ALL) { - Tcl_GetByteArrayFromObj(objv[arg], &count); - } else if (count == BINARY_NOCOUNT) { - count = 1; - } - arg++; - if (cmd == 'a' || cmd == 'A') { - offset += count; - } else if (cmd == 'b' || cmd == 'B') { - offset += (count + 7) / 8; - } else { - offset += (count + 1) / 2; - } - break; - } - case 'c': { - size = 1; - goto doNumbers; - } - case 't': - case 's': - case 'S': { - size = 2; - goto doNumbers; - } - case 'n': - case 'i': - case 'I': { - size = 4; - goto doNumbers; - } - case 'm': - case 'w': - case 'W': { - size = 8; - goto doNumbers; - } - case 'r': - case 'R': - case 'f': { - size = sizeof(float); - goto doNumbers; - } - case 'q': - case 'Q': - case 'd': { - size = sizeof(double); - - doNumbers: - if (arg >= objc) { - goto badIndex; - } - - /* - * For number-type specifiers, the count corresponds - * to the number of elements in the list stored in - * a single argument. If no count is specified, then - * the argument is taken as a single non-list value. - */ - - if (count == BINARY_NOCOUNT) { - arg++; - count = 1; - } else { - int listc; - Tcl_Obj **listv; - if (Tcl_ListObjGetElements(interp, objv[arg++], - &listc, &listv) != TCL_OK) { - return TCL_ERROR; - } - if (count == BINARY_ALL) { - count = listc; - } else if (count > listc) { - Tcl_AppendResult(interp, - "number of elements in list does not match count", - (char *) NULL); - return TCL_ERROR; - } - } - offset += count*size; - break; - } - case 'x': { - if (count == BINARY_ALL) { - Tcl_AppendResult(interp, - "cannot use \"*\" in format string with \"x\"", - (char *) NULL); - return TCL_ERROR; - } else if (count == BINARY_NOCOUNT) { - count = 1; - } - offset += count; - break; - } - case 'X': { - if (count == BINARY_NOCOUNT) { - count = 1; - } - if ((count > offset) || (count == BINARY_ALL)) { - count = offset; - } - if (offset > length) { - length = offset; - } - offset -= count; - break; - } - case '@': { - if (offset > length) { - length = offset; - } - if (count == BINARY_ALL) { - offset = length; - } else if (count == BINARY_NOCOUNT) { - goto badCount; - } else { - offset = count; - } - break; - } - default: { - errorString = str; - goto badField; - } - } - } - if (offset > length) { - length = offset; - } - if (length == 0) { - return TCL_OK; - } - - /* - * Prepare the result object by preallocating the caclulated - * number of bytes and filling with nulls. - */ - - resultPtr = Tcl_NewObj(); - buffer = Tcl_SetByteArrayLength(resultPtr, length); - memset((VOID *) buffer, 0, (size_t) length); - - /* - * Pack the data into the result object. Note that we can skip - * the error checking during this pass, since we have already - * parsed the string once. - */ - - arg = 3; - format = Tcl_GetString(objv[2]); - cursor = buffer; - maxPos = cursor; - while (*format != 0) { - if (!GetFormatSpec(&format, &cmd, &count)) { - break; - } - if ((count == 0) && (cmd != '@')) { - arg++; - continue; - } - switch (cmd) { - case 'a': - case 'A': { - char pad = (char) (cmd == 'a' ? '\0' : ' '); - unsigned char *bytes; - - bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length); - - if (count == BINARY_ALL) { - count = length; - } else if (count == BINARY_NOCOUNT) { - count = 1; - } - if (length >= count) { - memcpy((VOID *) cursor, (VOID *) bytes, - (size_t) count); - } else { - memcpy((VOID *) cursor, (VOID *) bytes, - (size_t) length); - memset((VOID *) (cursor + length), pad, - (size_t) (count - length)); - } - cursor += count; - break; - } - case 'b': - case 'B': { - unsigned char *last; - - str = Tcl_GetStringFromObj(objv[arg++], &length); - if (count == BINARY_ALL) { - count = length; - } else if (count == BINARY_NOCOUNT) { - count = 1; - } - last = cursor + ((count + 7) / 8); - if (count > length) { - count = length; - } - value = 0; - errorString = "binary"; - if (cmd == 'B') { - for (offset = 0; offset < count; offset++) { - value <<= 1; - if (str[offset] == '1') { - value |= 1; - } else if (str[offset] != '0') { - errorValue = str; - goto badValue; - } - if (((offset + 1) % 8) == 0) { - *cursor++ = (unsigned char) value; - value = 0; - } - } - } else { - for (offset = 0; offset < count; offset++) { - value >>= 1; - if (str[offset] == '1') { - value |= 128; - } else if (str[offset] != '0') { - errorValue = str; - goto badValue; - } - if (!((offset + 1) % 8)) { - *cursor++ = (unsigned char) value; - value = 0; - } - } - } - if ((offset % 8) != 0) { - if (cmd == 'B') { - value <<= 8 - (offset % 8); - } else { - value >>= 8 - (offset % 8); - } - *cursor++ = (unsigned char) value; - } - while (cursor < last) { - *cursor++ = '\0'; - } - break; - } - case 'h': - case 'H': { - unsigned char *last; - int c; - - str = Tcl_GetStringFromObj(objv[arg++], &length); - if (count == BINARY_ALL) { - count = length; - } else if (count == BINARY_NOCOUNT) { - count = 1; - } - last = cursor + ((count + 1) / 2); - if (count > length) { - count = length; - } - value = 0; - errorString = "hexadecimal"; - if (cmd == 'H') { - for (offset = 0; offset < count; offset++) { - value <<= 4; - if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ - errorValue = str; - goto badValue; - } - c = str[offset] - '0'; - if (c > 9) { - c += ('0' - 'A') + 10; - } - if (c > 16) { - c += ('A' - 'a'); - } - value |= (c & 0xf); - if (offset % 2) { - *cursor++ = (char) value; - value = 0; - } - } - } else { - for (offset = 0; offset < count; offset++) { - value >>= 4; - - if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ - errorValue = str; - goto badValue; - } - c = str[offset] - '0'; - if (c > 9) { - c += ('0' - 'A') + 10; - } - if (c > 16) { - c += ('A' - 'a'); - } - value |= ((c << 4) & 0xf0); - if (offset % 2) { - *cursor++ = (unsigned char)(value & 0xff); - value = 0; - } - } - } - if (offset % 2) { - if (cmd == 'H') { - value <<= 4; - } else { - value >>= 4; - } - *cursor++ = (unsigned char) value; - } - - while (cursor < last) { - *cursor++ = '\0'; - } - break; - } - case 'c': - case 't': - case 's': - case 'S': - case 'n': - case 'i': - case 'I': - case 'm': - case 'w': - case 'W': - case 'r': - case 'R': - case 'd': - case 'q': - case 'Q': - case 'f': { - int listc, i; - Tcl_Obj **listv; - - if (count == BINARY_NOCOUNT) { - /* - * Note that we are casting away the const-ness of - * objv, but this is safe since we aren't going to - * modify the array. - */ - - listv = (Tcl_Obj**)(objv + arg); - listc = 1; - count = 1; - } else { - Tcl_ListObjGetElements(interp, objv[arg], - &listc, &listv); - if (count == BINARY_ALL) { - count = listc; - } - } - arg++; - for (i = 0; i < count; i++) { - if (FormatNumber(interp, cmd, listv[i], &cursor) - != TCL_OK) { - return TCL_ERROR; - } - } - break; - } - case 'x': { - if (count == BINARY_NOCOUNT) { - count = 1; - } - memset(cursor, 0, (size_t) count); - cursor += count; - break; - } - case 'X': { - if (cursor > maxPos) { - maxPos = cursor; - } - if (count == BINARY_NOCOUNT) { - count = 1; - } - if ((count == BINARY_ALL) - || (count > (cursor - buffer))) { - cursor = buffer; - } else { - cursor -= count; - } - break; - } - case '@': { - if (cursor > maxPos) { - maxPos = cursor; - } - if (count == BINARY_ALL) { - cursor = maxPos; - } else { - cursor = buffer + count; - } - break; - } - } - } - Tcl_SetObjResult(interp, resultPtr); - break; - } - case BINARY_SCAN: { - int i; - Tcl_Obj *valuePtr, *elementPtr; - Tcl_HashTable numberCacheHash; - Tcl_HashTable *numberCachePtr; - - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, - "value formatString ?varName varName ...?"); - return TCL_ERROR; - } - numberCachePtr = &numberCacheHash; - Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS); - buffer = Tcl_GetByteArrayFromObj(objv[2], &length); - format = Tcl_GetString(objv[3]); - cursor = buffer; - arg = 4; - offset = 0; - while (*format != '\0') { - str = format; - if (!GetFormatSpec(&format, &cmd, &count)) { - goto done; - } - switch (cmd) { - case 'a': - case 'A': { - unsigned char *src; - - if (arg >= objc) { - DeleteScanNumberCache(numberCachePtr); - goto badIndex; - } - if (count == BINARY_ALL) { - count = length - offset; - } else { - if (count == BINARY_NOCOUNT) { - count = 1; - } - if (count > (length - offset)) { - goto done; - } - } - - src = buffer + offset; - size = count; - - /* - * Trim trailing nulls and spaces, if necessary. - */ - - if (cmd == 'A') { - while (size > 0) { - if (src[size-1] != '\0' && src[size-1] != ' ') { - break; - } - size--; - } - } - valuePtr = Tcl_NewByteArrayObj(src, size); - resultPtr = Tcl_ObjSetVar2(interp, objv[arg], - NULL, valuePtr, TCL_LEAVE_ERR_MSG); - arg++; - if (resultPtr == NULL) { - DeleteScanNumberCache(numberCachePtr); - Tcl_DecrRefCount(valuePtr); /* unneeded */ - return TCL_ERROR; - } - offset += count; - break; - } - case 'b': - case 'B': { - unsigned char *src; - char *dest; - - if (arg >= objc) { - DeleteScanNumberCache(numberCachePtr); - goto badIndex; - } - if (count == BINARY_ALL) { - count = (length - offset) * 8; - } else { - if (count == BINARY_NOCOUNT) { - count = 1; - } - if (count > (length - offset) * 8) { - goto done; - } - } - src = buffer + offset; - valuePtr = Tcl_NewObj(); - Tcl_SetObjLength(valuePtr, count); - dest = Tcl_GetString(valuePtr); - - if (cmd == 'b') { - for (i = 0; i < count; i++) { - if (i % 8) { - value >>= 1; - } else { - value = *src++; - } - *dest++ = (char) ((value & 1) ? '1' : '0'); - } - } else { - for (i = 0; i < count; i++) { - if (i % 8) { - value <<= 1; - } else { - value = *src++; - } - *dest++ = (char) ((value & 0x80) ? '1' : '0'); - } - } - - resultPtr = Tcl_ObjSetVar2(interp, objv[arg], - NULL, valuePtr, TCL_LEAVE_ERR_MSG); - arg++; - if (resultPtr == NULL) { - DeleteScanNumberCache(numberCachePtr); - Tcl_DecrRefCount(valuePtr); /* unneeded */ - return TCL_ERROR; - } - offset += (count + 7 ) / 8; - break; - } - case 'h': - case 'H': { - char *dest; - unsigned char *src; - int i; - static char hexdigit[] = "0123456789abcdef"; - - if (arg >= objc) { - DeleteScanNumberCache(numberCachePtr); - goto badIndex; - } - if (count == BINARY_ALL) { - count = (length - offset)*2; - } else { - if (count == BINARY_NOCOUNT) { - count = 1; - } - if (count > (length - offset)*2) { - goto done; - } - } - src = buffer + offset; - valuePtr = Tcl_NewObj(); - Tcl_SetObjLength(valuePtr, count); - dest = Tcl_GetString(valuePtr); - - if (cmd == 'h') { - for (i = 0; i < count; i++) { - if (i % 2) { - value >>= 4; - } else { - value = *src++; - } - *dest++ = hexdigit[value & 0xf]; - } - } else { - for (i = 0; i < count; i++) { - if (i % 2) { - value <<= 4; - } else { - value = *src++; - } - *dest++ = hexdigit[(value >> 4) & 0xf]; - } - } - - resultPtr = Tcl_ObjSetVar2(interp, objv[arg], - NULL, valuePtr, TCL_LEAVE_ERR_MSG); - arg++; - if (resultPtr == NULL) { - DeleteScanNumberCache(numberCachePtr); - Tcl_DecrRefCount(valuePtr); /* unneeded */ - return TCL_ERROR; - } - offset += (count + 1) / 2; - break; - } - case 'c': { - size = 1; - goto scanNumber; - } - case 't': - case 's': - case 'S': { - size = 2; - goto scanNumber; - } - case 'n': - case 'i': - case 'I': { - size = 4; - goto scanNumber; - } - case 'm': - case 'w': - case 'W': { - size = 8; - goto scanNumber; - } - case 'r': - case 'R': - case 'f': { - size = sizeof(float); - goto scanNumber; - } - case 'q': - case 'Q': - case 'd': { - unsigned char *src; - - size = sizeof(double); - /* fall through */ - - scanNumber: - if (arg >= objc) { - DeleteScanNumberCache(numberCachePtr); - goto badIndex; - } - if (count == BINARY_NOCOUNT) { - if ((length - offset) < size) { - goto done; - } - valuePtr = ScanNumber(buffer+offset, cmd, - &numberCachePtr); - offset += size; - } else { - if (count == BINARY_ALL) { - count = (length - offset) / size; - } - if ((length - offset) < (count * size)) { - goto done; - } - valuePtr = Tcl_NewObj(); - src = buffer+offset; - for (i = 0; i < count; i++) { - elementPtr = ScanNumber(src, cmd, - &numberCachePtr); - src += size; - Tcl_ListObjAppendElement(NULL, valuePtr, - elementPtr); - } - offset += count*size; - } - - resultPtr = Tcl_ObjSetVar2(interp, objv[arg], - NULL, valuePtr, TCL_LEAVE_ERR_MSG); - arg++; - if (resultPtr == NULL) { - DeleteScanNumberCache(numberCachePtr); - Tcl_DecrRefCount(valuePtr); /* unneeded */ - return TCL_ERROR; - } - break; - } - case 'x': { - if (count == BINARY_NOCOUNT) { - count = 1; - } - if ((count == BINARY_ALL) - || (count > (length - offset))) { - offset = length; - } else { - offset += count; - } - break; - } - case 'X': { - if (count == BINARY_NOCOUNT) { - count = 1; - } - if ((count == BINARY_ALL) || (count > offset)) { - offset = 0; - } else { - offset -= count; - } - break; - } - case '@': { - if (count == BINARY_NOCOUNT) { - DeleteScanNumberCache(numberCachePtr); - goto badCount; - } - if ((count == BINARY_ALL) || (count > length)) { - offset = length; - } else { - offset = count; - } - break; - } - default: { - DeleteScanNumberCache(numberCachePtr); - errorString = str; - goto badField; - } - } - } - - /* - * Set the result to the last position of the cursor. - */ - - done: - Tcl_SetObjResult(interp, Tcl_NewLongObj(arg - 4)); - DeleteScanNumberCache(numberCachePtr); - break; - } - } - return TCL_OK; - - badValue: + case BINARY_FORMAT: + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?"); + return TCL_ERROR; + } + + /* + * To avoid copying the data, we format the string in two passes. The + * first pass computes the size of the output buffer. The second pass + * places the formatted data into the buffer. + */ + + format = Tcl_GetString(objv[2]); + arg = 3; + offset = 0; + length = 0; + while (*format != '\0') { + str = format; + if (!GetFormatSpec(&format, &cmd, &count)) { + break; + } + switch (cmd) { + case 'a': + case 'A': + case 'b': + case 'B': + case 'h': + case 'H': + /* + * For string-type specifiers, the count corresponds to the + * number of bytes in a single argument. + */ + + if (arg >= objc) { + goto badIndex; + } + if (count == BINARY_ALL) { + Tcl_GetByteArrayFromObj(objv[arg], &count); + } else if (count == BINARY_NOCOUNT) { + count = 1; + } + arg++; + if (cmd == 'a' || cmd == 'A') { + offset += count; + } else if (cmd == 'b' || cmd == 'B') { + offset += (count + 7) / 8; + } else { + offset += (count + 1) / 2; + } + break; + case 'c': + size = 1; + goto doNumbers; + case 't': + case 's': + case 'S': + size = 2; + goto doNumbers; + case 'n': + case 'i': + case 'I': + size = 4; + goto doNumbers; + case 'm': + case 'w': + case 'W': + size = 8; + goto doNumbers; + case 'r': + case 'R': + case 'f': + size = sizeof(float); + goto doNumbers; + case 'q': + case 'Q': + case 'd': + size = sizeof(double); + + doNumbers: + if (arg >= objc) { + goto badIndex; + } + + /* + * For number-type specifiers, the count corresponds to the + * number of elements in the list stored in a single argument. + * If no count is specified, then the argument is taken as a + * single non-list value. + */ + + if (count == BINARY_NOCOUNT) { + arg++; + count = 1; + } else { + int listc; + Tcl_Obj **listv; + + if (Tcl_ListObjGetElements(interp, objv[arg++], &listc, + &listv) != TCL_OK) { + return TCL_ERROR; + } + if (count == BINARY_ALL) { + count = listc; + } else if (count > listc) { + Tcl_AppendResult(interp, + "number of elements in list does not match count", + (char *) NULL); + return TCL_ERROR; + } + } + offset += count*size; + break; + + case 'x': + if (count == BINARY_ALL) { + Tcl_AppendResult(interp, + "cannot use \"*\" in format string with \"x\"", + (char *) NULL); + return TCL_ERROR; + } else if (count == BINARY_NOCOUNT) { + count = 1; + } + offset += count; + break; + case 'X': + if (count == BINARY_NOCOUNT) { + count = 1; + } + if ((count > offset) || (count == BINARY_ALL)) { + count = offset; + } + if (offset > length) { + length = offset; + } + offset -= count; + break; + case '@': + if (offset > length) { + length = offset; + } + if (count == BINARY_ALL) { + offset = length; + } else if (count == BINARY_NOCOUNT) { + goto badCount; + } else { + offset = count; + } + break; + default: + errorString = str; + goto badField; + } + } + if (offset > length) { + length = offset; + } + if (length == 0) { + return TCL_OK; + } + + /* + * Prepare the result object by preallocating the caclulated number of + * bytes and filling with nulls. + */ + + resultPtr = Tcl_NewObj(); + buffer = Tcl_SetByteArrayLength(resultPtr, length); + memset((VOID *) buffer, 0, (size_t) length); + + /* + * Pack the data into the result object. Note that we can skip the + * error checking during this pass, since we have already parsed the + * string once. + */ + + arg = 3; + format = Tcl_GetString(objv[2]); + cursor = buffer; + maxPos = cursor; + while (*format != 0) { + if (!GetFormatSpec(&format, &cmd, &count)) { + break; + } + if ((count == 0) && (cmd != '@')) { + arg++; + continue; + } + switch (cmd) { + case 'a': + case 'A': { + char pad = (char) (cmd == 'a' ? '\0' : ' '); + unsigned char *bytes; + + bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length); + + if (count == BINARY_ALL) { + count = length; + } else if (count == BINARY_NOCOUNT) { + count = 1; + } + if (length >= count) { + memcpy((VOID *) cursor, (VOID *) bytes, (size_t) count); + } else { + memcpy((VOID *) cursor, (VOID *) bytes, (size_t) length); + memset((VOID *) (cursor + length), pad, + (size_t) (count - length)); + } + cursor += count; + break; + } + case 'b': + case 'B': { + unsigned char *last; + + str = Tcl_GetStringFromObj(objv[arg++], &length); + if (count == BINARY_ALL) { + count = length; + } else if (count == BINARY_NOCOUNT) { + count = 1; + } + last = cursor + ((count + 7) / 8); + if (count > length) { + count = length; + } + value = 0; + errorString = "binary"; + if (cmd == 'B') { + for (offset = 0; offset < count; offset++) { + value <<= 1; + if (str[offset] == '1') { + value |= 1; + } else if (str[offset] != '0') { + errorValue = str; + goto badValue; + } + if (((offset + 1) % 8) == 0) { + *cursor++ = (unsigned char) value; + value = 0; + } + } + } else { + for (offset = 0; offset < count; offset++) { + value >>= 1; + if (str[offset] == '1') { + value |= 128; + } else if (str[offset] != '0') { + errorValue = str; + goto badValue; + } + if (!((offset + 1) % 8)) { + *cursor++ = (unsigned char) value; + value = 0; + } + } + } + if ((offset % 8) != 0) { + if (cmd == 'B') { + value <<= 8 - (offset % 8); + } else { + value >>= 8 - (offset % 8); + } + *cursor++ = (unsigned char) value; + } + while (cursor < last) { + *cursor++ = '\0'; + } + break; + } + case 'h': + case 'H': { + unsigned char *last; + int c; + + str = Tcl_GetStringFromObj(objv[arg++], &length); + if (count == BINARY_ALL) { + count = length; + } else if (count == BINARY_NOCOUNT) { + count = 1; + } + last = cursor + ((count + 1) / 2); + if (count > length) { + count = length; + } + value = 0; + errorString = "hexadecimal"; + if (cmd == 'H') { + for (offset = 0; offset < count; offset++) { + value <<= 4; + if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ + errorValue = str; + goto badValue; + } + c = str[offset] - '0'; + if (c > 9) { + c += ('0' - 'A') + 10; + } + if (c > 16) { + c += ('A' - 'a'); + } + value |= (c & 0xf); + if (offset % 2) { + *cursor++ = (char) value; + value = 0; + } + } + } else { + for (offset = 0; offset < count; offset++) { + value >>= 4; + + if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ + errorValue = str; + goto badValue; + } + c = str[offset] - '0'; + if (c > 9) { + c += ('0' - 'A') + 10; + } + if (c > 16) { + c += ('A' - 'a'); + } + value |= ((c << 4) & 0xf0); + if (offset % 2) { + *cursor++ = (unsigned char)(value & 0xff); + value = 0; + } + } + } + if (offset % 2) { + if (cmd == 'H') { + value <<= 4; + } else { + value >>= 4; + } + *cursor++ = (unsigned char) value; + } + + while (cursor < last) { + *cursor++ = '\0'; + } + break; + } + case 'c': + case 't': + case 's': + case 'S': + case 'n': + case 'i': + case 'I': + case 'm': + case 'w': + case 'W': + case 'r': + case 'R': + case 'd': + case 'q': + case 'Q': + case 'f': { + int listc, i; + Tcl_Obj **listv; + + if (count == BINARY_NOCOUNT) { + /* + * Note that we are casting away the const-ness of objv, + * but this is safe since we aren't going to modify the + * array. + */ + + listv = (Tcl_Obj**)(objv + arg); + listc = 1; + count = 1; + } else { + Tcl_ListObjGetElements(interp, objv[arg], &listc, &listv); + if (count == BINARY_ALL) { + count = listc; + } + } + arg++; + for (i = 0; i < count; i++) { + if (FormatNumber(interp, cmd, listv[i], &cursor)!=TCL_OK) { + return TCL_ERROR; + } + } + break; + } + case 'x': + if (count == BINARY_NOCOUNT) { + count = 1; + } + memset(cursor, 0, (size_t) count); + cursor += count; + break; + case 'X': + if (cursor > maxPos) { + maxPos = cursor; + } + if (count == BINARY_NOCOUNT) { + count = 1; + } + if ((count == BINARY_ALL) || (count > (cursor - buffer))) { + cursor = buffer; + } else { + cursor -= count; + } + break; + case '@': + if (cursor > maxPos) { + maxPos = cursor; + } + if (count == BINARY_ALL) { + cursor = maxPos; + } else { + cursor = buffer + count; + } + break; + } + } + Tcl_SetObjResult(interp, resultPtr); + break; + case BINARY_SCAN: { + int i; + Tcl_Obj *valuePtr, *elementPtr; + Tcl_HashTable numberCacheHash; + Tcl_HashTable *numberCachePtr; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, + "value formatString ?varName varName ...?"); + return TCL_ERROR; + } + numberCachePtr = &numberCacheHash; + Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS); + buffer = Tcl_GetByteArrayFromObj(objv[2], &length); + format = Tcl_GetString(objv[3]); + cursor = buffer; + arg = 4; + offset = 0; + while (*format != '\0') { + str = format; + if (!GetFormatSpec(&format, &cmd, &count)) { + goto done; + } + switch (cmd) { + case 'a': + case 'A': { + unsigned char *src; + + if (arg >= objc) { + DeleteScanNumberCache(numberCachePtr); + goto badIndex; + } + if (count == BINARY_ALL) { + count = length - offset; + } else { + if (count == BINARY_NOCOUNT) { + count = 1; + } + if (count > (length - offset)) { + goto done; + } + } + + src = buffer + offset; + size = count; + + /* + * Trim trailing nulls and spaces, if necessary. + */ + + if (cmd == 'A') { + while (size > 0) { + if (src[size-1] != '\0' && src[size-1] != ' ') { + break; + } + size--; + } + } + + /* + * Have to do this #ifdef-fery because (as part of defining + * Tcl_NewByteArrayObj) we removed the #def that hides this + * stuff normally. If this code ever gets copied to another + * file, it should be changed back to the simpler version. + */ + +#ifdef TCL_MEM_DEBUG + valuePtr = Tcl_DbNewByteArrayObj(src, size, __FILE__,__LINE__); +#else + valuePtr = Tcl_NewByteArrayObj(src, size); +#endif /* TCL_MEM_DEBUG */ + + resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, + TCL_LEAVE_ERR_MSG); + arg++; + if (resultPtr == NULL) { + DeleteScanNumberCache(numberCachePtr); + Tcl_DecrRefCount(valuePtr); /* unneeded */ + return TCL_ERROR; + } + offset += count; + break; + } + case 'b': + case 'B': { + unsigned char *src; + char *dest; + + if (arg >= objc) { + DeleteScanNumberCache(numberCachePtr); + goto badIndex; + } + if (count == BINARY_ALL) { + count = (length - offset) * 8; + } else { + if (count == BINARY_NOCOUNT) { + count = 1; + } + if (count > (length - offset) * 8) { + goto done; + } + } + src = buffer + offset; + valuePtr = Tcl_NewObj(); + Tcl_SetObjLength(valuePtr, count); + dest = Tcl_GetString(valuePtr); + + if (cmd == 'b') { + for (i = 0; i < count; i++) { + if (i % 8) { + value >>= 1; + } else { + value = *src++; + } + *dest++ = (char) ((value & 1) ? '1' : '0'); + } + } else { + for (i = 0; i < count; i++) { + if (i % 8) { + value <<= 1; + } else { + value = *src++; + } + *dest++ = (char) ((value & 0x80) ? '1' : '0'); + } + } + + resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, + TCL_LEAVE_ERR_MSG); + arg++; + if (resultPtr == NULL) { + DeleteScanNumberCache(numberCachePtr); + Tcl_DecrRefCount(valuePtr); /* unneeded */ + return TCL_ERROR; + } + offset += (count + 7 ) / 8; + break; + } + case 'h': + case 'H': { + char *dest; + unsigned char *src; + int i; + static CONST char hexdigit[] = "0123456789abcdef"; + + if (arg >= objc) { + DeleteScanNumberCache(numberCachePtr); + goto badIndex; + } + if (count == BINARY_ALL) { + count = (length - offset)*2; + } else { + if (count == BINARY_NOCOUNT) { + count = 1; + } + if (count > (length - offset)*2) { + goto done; + } + } + src = buffer + offset; + valuePtr = Tcl_NewObj(); + Tcl_SetObjLength(valuePtr, count); + dest = Tcl_GetString(valuePtr); + + if (cmd == 'h') { + for (i = 0; i < count; i++) { + if (i % 2) { + value >>= 4; + } else { + value = *src++; + } + *dest++ = hexdigit[value & 0xf]; + } + } else { + for (i = 0; i < count; i++) { + if (i % 2) { + value <<= 4; + } else { + value = *src++; + } + *dest++ = hexdigit[(value >> 4) & 0xf]; + } + } + + resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, + TCL_LEAVE_ERR_MSG); + arg++; + if (resultPtr == NULL) { + DeleteScanNumberCache(numberCachePtr); + Tcl_DecrRefCount(valuePtr); /* unneeded */ + return TCL_ERROR; + } + offset += (count + 1) / 2; + break; + } + case 'c': + size = 1; + goto scanNumber; + case 't': + case 's': + case 'S': + size = 2; + goto scanNumber; + case 'n': + case 'i': + case 'I': + size = 4; + goto scanNumber; + case 'm': + case 'w': + case 'W': + size = 8; + goto scanNumber; + case 'r': + case 'R': + case 'f': + size = sizeof(float); + goto scanNumber; + case 'q': + case 'Q': + case 'd': { + unsigned char *src; + + size = sizeof(double); + /* fall through */ + + scanNumber: + if (arg >= objc) { + DeleteScanNumberCache(numberCachePtr); + goto badIndex; + } + if (count == BINARY_NOCOUNT) { + if ((length - offset) < size) { + goto done; + } + valuePtr = ScanNumber(buffer+offset, cmd, &numberCachePtr); + offset += size; + } else { + if (count == BINARY_ALL) { + count = (length - offset) / size; + } + if ((length - offset) < (count * size)) { + goto done; + } + valuePtr = Tcl_NewObj(); + src = buffer+offset; + for (i = 0; i < count; i++) { + elementPtr = ScanNumber(src, cmd, &numberCachePtr); + src += size; + Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr); + } + offset += count*size; + } + + resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, + TCL_LEAVE_ERR_MSG); + arg++; + if (resultPtr == NULL) { + DeleteScanNumberCache(numberCachePtr); + Tcl_DecrRefCount(valuePtr); /* unneeded */ + return TCL_ERROR; + } + break; + } + case 'x': + if (count == BINARY_NOCOUNT) { + count = 1; + } + if ((count == BINARY_ALL) || (count > (length - offset))) { + offset = length; + } else { + offset += count; + } + break; + case 'X': + if (count == BINARY_NOCOUNT) { + count = 1; + } + if ((count == BINARY_ALL) || (count > offset)) { + offset = 0; + } else { + offset -= count; + } + break; + case '@': + if (count == BINARY_NOCOUNT) { + DeleteScanNumberCache(numberCachePtr); + goto badCount; + } + if ((count == BINARY_ALL) || (count > length)) { + offset = length; + } else { + offset = count; + } + break; + default: + DeleteScanNumberCache(numberCachePtr); + errorString = str; + goto badField; + } + } + + /* + * Set the result to the last position of the cursor. + */ + + done: + Tcl_SetObjResult(interp, Tcl_NewLongObj(arg - 4)); + DeleteScanNumberCache(numberCachePtr); + break; + } + } + return TCL_OK; + + badValue: Tcl_ResetResult(interp); Tcl_AppendResult(interp, "expected ", errorString, " string but got \"", errorValue, "\" instead", NULL); return TCL_ERROR; - badCount: + badCount: errorString = "missing count for \"@\" field specifier"; goto error; - badIndex: + badIndex: errorString = "not enough arguments for all format specifiers"; goto error; - badField: + badField: { Tcl_UniChar ch; char buf[TCL_UTF_MAX + 1]; Tcl_UtfToUniChar(errorString, &ch); @@ -1373,41 +1345,41 @@ buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL); return TCL_ERROR; } - error: + error: Tcl_AppendResult(interp, errorString, NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * GetFormatSpec -- * - * This function parses the format strings used in the binary - * format and scan commands. + * This function parses the format strings used in the binary format and + * scan commands. * * Results: - * Moves the formatPtr to the start of the next command. Returns - * the current command character and count in cmdPtr and countPtr. - * The count is set to BINARY_ALL if the count character was '*' - * or BINARY_NOCOUNT if no count was specified. Returns 1 on - * success, or 0 if the string did not have a format specifier. + * Moves the formatPtr to the start of the next command. Returns the + * current command character and count in cmdPtr and countPtr. The count + * is set to BINARY_ALL if the count character was '*' or BINARY_NOCOUNT + * if no count was specified. Returns 1 on success, or 0 if the string + * did not have a format specifier. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int -GetFormatSpec(formatPtr, cmdPtr, countPtr) - char **formatPtr; /* Pointer to format string. */ - char *cmdPtr; /* Pointer to location of command char. */ - int *countPtr; /* Pointer to repeat count value. */ +GetFormatSpec( + char **formatPtr, /* Pointer to format string. */ + char *cmdPtr, /* Pointer to location of command char. */ + int *countPtr) /* Pointer to repeat count value. */ { /* * Skip any leading blanks. */ @@ -1443,32 +1415,31 @@ /* *---------------------------------------------------------------------- * * NeedReversing -- * - * This routine determines, if bytes of a number need to be - * reversed. This depends on the endiannes of the machine and - * the desired format. It is in effect a table (whose contents - * depend on the endianness of the system) describing whether a - * value needs reversing or not. Anyone porting the code to a - * big-endian platform should take care to make sure that they - * define WORDS_BIGENDIAN though this is already done by - * configure for the Unix build; little-endian platforms - * (including Windows) don't need to do anything. + * This routine determines, if bytes of a number need to be reversed. + * This depends on the endiannes of the machine and the desired format. + * It is in effect a table (whose contents depend on the endianness of + * the system) describing whether a value needs reversing or not. Anyone + * porting the code to a big-endian platform should take care to make + * sure that they define WORDS_BIGENDIAN though this is already done by + * configure for the Unix build; little-endian platforms (including + * Windows) don't need to do anything. * * Results: * 1 if reversion is required, 0 if not. * * Side effects: * None - * + * *---------------------------------------------------------------------- */ -static int -NeedReversing(format) - int format; +static int +NeedReversing( + int format) { switch (format) { /* native floats and doubles: never reverse */ case 'd': case 'f': @@ -1518,15 +1489,14 @@ /* *---------------------------------------------------------------------- * * CopyNumber -- * - * This routine is called by FormatNumber and ScanNumber to copy - * a floating-point number. If required, bytes are reversed - * while copying. The behaviour is only fully defined when used - * with IEEE float and double values (guaranteed to be 4 and 8 - * bytes long, respectively.) + * This routine is called by FormatNumber and ScanNumber to copy a + * floating-point number. If required, bytes are reversed while copying. + * The behaviour is only fully defined when used with IEEE float and + * double values (guaranteed to be 4 and 8 bytes long, respectively.) * * Results: * None * * Side effects: @@ -1533,16 +1503,16 @@ * Copies length bytes * *---------------------------------------------------------------------- */ -static void -CopyNumber(from, to, length, type) - CONST void *from; /* source */ - void *to; /* destination */ - unsigned int length; /* Number of bytes to copy */ - int type; /* What type of thing are we copying? */ +static void +CopyNumber( + CONST void *from, /* source */ + void *to, /* destination */ + unsigned int length, /* Number of bytes to copy */ + int type) /* What type of thing are we copying? */ { if (NeedReversing(type)) { CONST unsigned char *fromPtr = (CONST unsigned char *) from; unsigned char *toPtr = (unsigned char *) to; @@ -1563,38 +1533,38 @@ toPtr[6] = fromPtr[1]; toPtr[7] = fromPtr[0]; break; } } else { - memcpy(to, from, length); + memcpy(to, from, length); } } /* *---------------------------------------------------------------------- * * FormatNumber -- * - * This routine is called by Tcl_BinaryObjCmd to format a number - * into a location pointed at by cursor. + * This routine is called by Tcl_BinaryObjCmd to format a number into a + * location pointed at by cursor. * * Results: - * A standard Tcl result. + * A standard Tcl result. * * Side effects: * Moves the cursor to the next location to be written into. * *---------------------------------------------------------------------- */ static int -FormatNumber(interp, type, src, cursorPtr) - Tcl_Interp *interp; /* Current interpreter, used to report +FormatNumber( + Tcl_Interp *interp, /* Current interpreter, used to report * errors. */ - int type; /* Type of number to format. */ - Tcl_Obj *src; /* Number to format. */ - unsigned char **cursorPtr; /* Pointer to index into destination buffer. */ + int type, /* Type of number to format. */ + Tcl_Obj *src, /* Number to format. */ + unsigned char **cursorPtr) /* Pointer to index into destination buffer. */ { long value; double dvalue; Tcl_WideInt wvalue; float fvalue; @@ -1602,35 +1572,45 @@ switch (type) { case 'd': case 'q': case 'Q': /* - * Double-precision floating point values. + * Double-precision floating point values. Tcl_GetDoubleFromObj + * returns TCL_ERROR for NaN, but we can check by comparing the + * object's type pointer. */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { - return TCL_ERROR; + if ( src->typePtr != &tclDoubleType ) { + return TCL_ERROR; + } + dvalue = src->internalRep.doubleValue; } CopyNumber(&dvalue, *cursorPtr, sizeof(double), type); *cursorPtr += sizeof(double); return TCL_OK; case 'f': case 'r': case 'R': /* - * Single-precision floating point values. + * Single-precision floating point values. Tcl_GetDoubleFromObj + * returns TCL_ERROR for NaN, but we can check by comparing the + * object's type pointer. */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { - return TCL_ERROR; + if ( src->typePtr != &tclDoubleType ) { + return TCL_ERROR; + } + dvalue = src->internalRep.doubleValue; } /* - * Because some compilers will generate floating point exceptions - * on an overflow cast (e.g. Borland), we restrict the values - * to the valid range for float. + * Because some compilers will generate floating point exceptions on + * an overflow cast (e.g. Borland), we restrict the values to the + * valid range for float. */ if (fabs(dvalue) > (double)FLT_MAX) { fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX; } else { @@ -1717,11 +1697,11 @@ if (Tcl_GetLongFromObj(interp, src, &value) != TCL_OK) { return TCL_ERROR; } *(*cursorPtr)++ = (unsigned char) value; return TCL_OK; - + default: Tcl_Panic("unexpected fallthrough"); return TCL_ERROR; } } @@ -1729,30 +1709,30 @@ /* *---------------------------------------------------------------------- * * ScanNumber -- * - * This routine is called by Tcl_BinaryObjCmd to scan a number - * out of a buffer. + * This routine is called by Tcl_BinaryObjCmd to scan a number out of a + * buffer. * * Results: - * Returns a newly created object containing the scanned number. - * This object has a ref count of zero. + * Returns a newly created object containing the scanned number. This + * object has a ref count of zero. * * Side effects: - * Might reuse an object in the number cache, place a new object - * in the cache, or delete the cache and set the reference to - * it (itself passed in by reference) to NULL. + * Might reuse an object in the number cache, place a new object in the + * cache, or delete the cache and set the reference to it (itself passed + * in by reference) to NULL. * *---------------------------------------------------------------------- */ static Tcl_Obj * -ScanNumber(buffer, type, numberCachePtrPtr) - unsigned char *buffer; /* Buffer to scan number from. */ - int type; /* Format character from "binary scan" */ - Tcl_HashTable **numberCachePtrPtr; +ScanNumber( + unsigned char *buffer, /* Buffer to scan number from. */ + int type, /* Format character from "binary scan" */ + Tcl_HashTable **numberCachePtrPtr) /* Place to look for cache of scanned * value objects, or NULL if too many * different numbers have been scanned. */ { long value; @@ -1761,33 +1741,33 @@ Tcl_WideUInt uwvalue; /* * We cannot rely on the compiler to properly sign extend integer values * when we cast from smaller values to larger values because we don't know - * the exact size of the integer types. So, we have to handle sign + * the exact size of the integer types. So, we have to handle sign * extension explicitly by checking the high bit and padding with 1's as * needed. */ switch (type) { case 'c': /* - * Characters need special handling. We want to produce a - * signed result, but on some platforms (such as AIX) chars - * are unsigned. To deal with this, check for a value that - * should be negative but isn't. + * Characters need special handling. We want to produce a signed + * result, but on some platforms (such as AIX) chars are unsigned. To + * deal with this, check for a value that should be negative but + * isn't. */ value = buffer[0]; if (value & 0x80) { value |= -0x100; } goto returnNumericObject; /* - * 16-bit numeric values. We need the sign extension trick - * (see above) here as well. + * 16-bit numeric values. We need the sign extension trick (see above) + * here as well. */ case 's': case 'S': case 't': @@ -1807,11 +1787,11 @@ case 'i': case 'I': case 'n': if (NeedReversing(type)) { - value = (long) (buffer[0] + value = (long) (buffer[0] + (buffer[1] << 8) + (buffer[2] << 16) + (buffer[3] << 24)); } else { value = (long) (buffer[3] @@ -1819,12 +1799,12 @@ + (buffer[1] << 16) + (buffer[0] << 24)); } /* - * Check to see if the value was sign extended properly on - * systems where an int is more than 32-bits. + * Check to see if the value was sign extended properly on systems + * where an int is more than 32-bits. */ if ((value & (((unsigned int)1)<<31)) && (value > 0)) { value -= (((unsigned int)1)<<31); value -= (((unsigned int)1)<<31); @@ -1842,19 +1822,17 @@ hPtr = Tcl_CreateHashEntry(tablePtr, (char *)value, &isNew); if (!isNew) { return (Tcl_Obj *) Tcl_GetHashValue(hPtr); } if (tablePtr->numEntries > BINARY_SCAN_MAX_CACHE) { - /* - * We've overflowed the cache! Someone's parsing a - * LOT of varied binary data in a single call! Bail - * out by switching back to the old behaviour for the - * rest of the scan. + * We've overflowed the cache! Someone's parsing a LOT of + * varied binary data in a single call! Bail out by switching + * back to the old behaviour for the rest of the scan. * - * Note that anyone just using the 'c' conversion (for - * bytes) cannot trigger this. + * Note that anyone just using the 'c' conversion (for bytes) + * cannot trigger this. */ DeleteScanNumberCache(tablePtr); *numberCachePtrPtr = NULL; return Tcl_NewLongObj(value); @@ -1866,12 +1844,12 @@ return objPtr; } } /* - * Do not cache wide (64-bit) values; they are already too - * large to use as keys. + * Do not cache wide (64-bit) values; they are already too large to + * use as keys. */ case 'w': case 'W': case 'm': @@ -1895,13 +1873,13 @@ | (((Tcl_WideUInt) buffer[0]) << 56); } return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue); /* - * Do not cache double values; they are already too large to - * use as keys and the values stored are utterly incompatible - * with the integer part of the cache. + * Do not cache double values; they are already too large to use as + * keys and the values stored are utterly incompatible with the + * integer part of the cache. */ /* * 32-bit IEEE single-precision floating point. */ @@ -1927,11 +1905,11 @@ /* *---------------------------------------------------------------------- * * DeleteScanNumberCache -- - * + * * Deletes the hash table acting as a scan number cache. * * Results: * None * @@ -1940,14 +1918,15 @@ * *---------------------------------------------------------------------- */ static void -DeleteScanNumberCache(numberCachePtr) - Tcl_HashTable *numberCachePtr; /* Pointer to the hash table, or - * NULL (when the cache has already - * been deleted due to overflow.) */ +DeleteScanNumberCache( + Tcl_HashTable *numberCachePtr) + /* Pointer to the hash table, or NULL (when + * the cache has already been deleted due to + * overflow.) */ { Tcl_HashEntry *hEntry; Tcl_HashSearch search; if (numberCachePtr == NULL) { @@ -1963,5 +1942,13 @@ } hEntry = Tcl_NextHashEntry(&search); } Tcl_DeleteHashTable(numberCachePtr); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclCkalloc.c ================================================================== --- generic/tclCkalloc.c +++ generic/tclCkalloc.c @@ -1,21 +1,22 @@ -/* +/* * tclCkalloc.c -- * - * Interface to malloc and free that provides support for debugging problems - * involving overwritten, double freeing memory and loss of memory. + * Interface to malloc and free that provides support for debugging + * problems involving overwritten, double freeing memory and loss of + * memory. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * This code contributed by Karl Lehenbauer and Mark Diekhans * - * RCS: @(#) $Id: tclCkalloc.c,v 1.22 2004/10/06 13:05:02 dkf Exp $ + * RCS: @(#) $Id: tclCkalloc.c,v 1.22.2.2 2005/09/15 20:58:39 dgp Exp $ */ #include "tclInt.h" #define FALSE 0 @@ -27,61 +28,60 @@ * One of the following structures is allocated each time the * "memory tag" command is invoked, to hold the current tag. */ typedef struct MemTag { - int refCount; /* Number of mem_headers referencing - * this tag. */ - char string[4]; /* Actual size of string will be as - * large as needed for actual tag. This - * must be the last field in the structure. */ + int refCount; /* Number of mem_headers referencing this + * tag. */ + char string[4]; /* Actual size of string will be as large as + * needed for actual tag. This must be the + * last field in the structure. */ } MemTag; #define TAG_SIZE(bytesInString) ((unsigned) sizeof(MemTag) + bytesInString - 3) -static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers - * (set by "memory tag" command). */ +static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set + * by "memory tag" command). */ /* - * One of the following structures is allocated just before each - * dynamically allocated chunk of memory, both to record information - * about the chunk and to help detect chunk under-runs. + * One of the following structures is allocated just before each dynamically + * allocated chunk of memory, both to record information about the chunk and + * to help detect chunk under-runs. */ #define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + sizeof(int)))%8) struct mem_header { struct mem_header *flink; struct mem_header *blink; - MemTag *tagPtr; /* Tag from "memory tag" command; may be + MemTag *tagPtr; /* Tag from "memory tag" command; may be * NULL. */ CONST char *file; long length; int line; unsigned char low_guard[LOW_GUARD_SIZE]; /* Aligns body on 8-byte boundary, plus * provides at least 8 additional guard bytes * to detect underruns. */ - char body[1]; /* First byte of client's space. Actual - * size of this field will be larger than - * one. */ + char body[1]; /* First byte of client's space. Actual size + * of this field will be larger than one. */ }; static struct mem_header *allocHead = NULL; /* List of allocated structures */ #define GUARD_VALUE 0141 /* - * The following macro determines the amount of guard space *above* each - * chunk of memory. + * The following macro determines the amount of guard space *above* each chunk + * of memory. */ #define HIGH_GUARD_SIZE 8 /* * The following macro computes the offset of the "body" field within - * mem_header. It is used to get back to the header pointer from the - * body pointer that's used by clients. + * mem_header. It is used to get back to the header pointer from the body + * pointer that's used by clients. */ #define BODY_OFFSET \ ((unsigned long) (&((struct mem_header *) 0)->body)) @@ -100,27 +100,28 @@ #else static int validate_memory = FALSE; #endif /* - * The following variable indicates to TclFinalizeMemorySubsystem() - * that it should dump out the state of memory before exiting. If the - * value is non-NULL, it gives the name of the file in which to - * dump memory usage information. + * The following variable indicates to TclFinalizeMemorySubsystem() that it + * should dump out the state of memory before exiting. If the value is + * non-NULL, it gives the name of the file in which to dump memory usage + * information. */ char *tclMemDumpFileName = NULL; static char *onExitMemDumpFileName = NULL; static char dumpFile[100]; /* Records where to dump memory allocation * information. */ /* - * Mutex to serialize allocations. This is a low-level mutex that must - * be explicitly initialized. This is necessary because the self - * initializing mutexes use ckalloc... + * Mutex to serialize allocations. This is a low-level mutex that must be + * explicitly initialized. This is necessary because the self initializing + * mutexes use ckalloc... */ + static Tcl_Mutex *ckallocMutexPtr; static int ckallocInit = 0; /* * Prototypes for procedures defined in this file: @@ -136,19 +137,20 @@ /* *---------------------------------------------------------------------- * * TclInitDbCkalloc -- - * Initialize the locks used by the allocator. - * This is only appropriate to call in a single threaded environment, - * such as during TclInitSubsystems. + * + * Initialize the locks used by the allocator. This is only appropriate + * to call in a single threaded environment, such as during + * TclInitSubsystems. * *---------------------------------------------------------------------- */ void -TclInitDbCkalloc() +TclInitDbCkalloc() { if (!ckallocInit) { ckallocInit = 1; ckallocMutexPtr = Tcl_GetAllocMutex(); } @@ -156,30 +158,31 @@ /* *---------------------------------------------------------------------- * * TclDumpMemoryInfo -- - * Display the global memory management statistics. + * + * Display the global memory management statistics. * *---------------------------------------------------------------------- */ void -TclDumpMemoryInfo(outFile) +TclDumpMemoryInfo(outFile) FILE *outFile; { - fprintf(outFile,"total mallocs %10d\n", + fprintf(outFile,"total mallocs %10d\n", total_mallocs); - fprintf(outFile,"total frees %10d\n", + fprintf(outFile,"total frees %10d\n", total_frees); - fprintf(outFile,"current packets allocated %10d\n", + fprintf(outFile,"current packets allocated %10d\n", current_malloc_packets); - fprintf(outFile,"current bytes allocated %10d\n", + fprintf(outFile,"current bytes allocated %10d\n", current_bytes_malloced); - fprintf(outFile,"maximum packets allocated %10d\n", + fprintf(outFile,"maximum packets allocated %10d\n", maximum_malloc_packets); - fprintf(outFile,"maximum bytes allocated %10d\n", + fprintf(outFile,"maximum bytes allocated %10d\n", maximum_bytes_malloced); } /* *---------------------------------------------------------------------- @@ -211,57 +214,57 @@ { unsigned char *hiPtr; int idx; int guard_failed = FALSE; int byte; - + for (idx = 0; idx < LOW_GUARD_SIZE; idx++) { - byte = *(memHeaderP->low_guard + idx); - if (byte != GUARD_VALUE) { - guard_failed = TRUE; - fflush(stdout); + byte = *(memHeaderP->low_guard + idx); + if (byte != GUARD_VALUE) { + guard_failed = TRUE; + fflush(stdout); byte &= 0xff; - fprintf(stderr, "low guard byte %d is 0x%x \t%c\n", idx, byte, + fprintf(stderr, "low guard byte %d is 0x%x \t%c\n", idx, byte, (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */ - } + } } if (guard_failed) { - TclDumpMemoryInfo (stderr); - fprintf(stderr, "low guard failed at %lx, %s %d\n", - (long unsigned int) memHeaderP->body, file, line); - fflush(stderr); /* In case name pointer is bad. */ - fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length, + TclDumpMemoryInfo (stderr); + fprintf(stderr, "low guard failed at %lx, %s %d\n", + (long unsigned int) memHeaderP->body, file, line); + fflush(stderr); /* In case name pointer is bad. */ + fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length, memHeaderP->file, memHeaderP->line); - Tcl_Panic("Memory validation failure"); + Tcl_Panic("Memory validation failure"); } hiPtr = (unsigned char *)memHeaderP->body + memHeaderP->length; for (idx = 0; idx < HIGH_GUARD_SIZE; idx++) { - byte = *(hiPtr + idx); - if (byte != GUARD_VALUE) { - guard_failed = TRUE; - fflush(stdout); + byte = *(hiPtr + idx); + if (byte != GUARD_VALUE) { + guard_failed = TRUE; + fflush(stdout); byte &= 0xff; - fprintf(stderr, "hi guard byte %d is 0x%x \t%c\n", idx, byte, + fprintf(stderr, "hi guard byte %d is 0x%x \t%c\n", idx, byte, (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */ - } + } } if (guard_failed) { - TclDumpMemoryInfo(stderr); - fprintf(stderr, "high guard failed at %lx, %s %d\n", - (long unsigned int) memHeaderP->body, file, line); - fflush(stderr); /* In case name pointer is bad. */ - fprintf(stderr, "%ld bytes allocated at (%s %d)\n", + TclDumpMemoryInfo(stderr); + fprintf(stderr, "high guard failed at %lx, %s %d\n", + (long unsigned int) memHeaderP->body, file, line); + fflush(stderr); /* In case name pointer is bad. */ + fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length, memHeaderP->file, memHeaderP->line); - Tcl_Panic("Memory validation failure"); + Tcl_Panic("Memory validation failure"); } if (nukeGuards) { - memset((char *) memHeaderP->low_guard, 0, LOW_GUARD_SIZE); - memset((char *) hiPtr, 0, HIGH_GUARD_SIZE); + memset((char *) memHeaderP->low_guard, 0, LOW_GUARD_SIZE); + memset((char *) hiPtr, 0, HIGH_GUARD_SIZE); } } /* @@ -280,21 +283,23 @@ *---------------------------------------------------------------------- */ void Tcl_ValidateAllMemory(file, line) - CONST char *file; /* File from which Tcl_ValidateAllMemory was called */ - int line; /* Line number of call to Tcl_ValidateAllMemory */ + CONST char *file; /* File from which Tcl_ValidateAllMemory was + * called. */ + int line; /* Line number of call to + * Tcl_ValidateAllMemory */ { struct mem_header *memScanP; if (!ckallocInit) { TclInitDbCkalloc(); } Tcl_MutexLock(ckallocMutexPtr); for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { - ValidateMemory(memScanP, file, line, FALSE); + ValidateMemory(memScanP, file, line, FALSE); } Tcl_MutexUnlock(ckallocMutexPtr); } /* @@ -304,18 +309,19 @@ * * Displays all allocated memory to a file; if no filename is given, * information will be written to stderr. * * Results: - * Return TCL_ERROR if an error accessing the file occurs, `errno' - * will have the file error number left in it. + * Return TCL_ERROR if an error accessing the file occurs, `errno' will + * have the file error number left in it. + * *---------------------------------------------------------------------- */ int Tcl_DumpActiveMemory (fileName) - CONST char *fileName; /* Name of the file to write info to */ + CONST char *fileName; /* Name of the file to write info to */ { FILE *fileP; struct mem_header *memScanP; char *address; @@ -328,12 +334,12 @@ } } Tcl_MutexLock(ckallocMutexPtr); for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { - address = &memScanP->body [0]; - fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s", + address = &memScanP->body [0]; + fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s", (long unsigned int) address, (long unsigned int) address + memScanP->length - 1, memScanP->length, memScanP->file, memScanP->line, (memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string); (void) fputc('\n', fileP); @@ -349,20 +355,19 @@ /* *---------------------------------------------------------------------- * * Tcl_DbCkalloc - debugging ckalloc * - * Allocate the requested amount of space plus some extra for - * guard bands at both ends of the request, plus a size, panicing - * if there isn't enough space, then write in the guard bands - * and return the address of the space in the middle that the - * user asked for. - * - * The second and third arguments are file and line, these contain - * the filename and line number corresponding to the caller. - * These are sent by the ckalloc macro; it uses the preprocessor - * autodefines __FILE__ and __LINE__. + * Allocate the requested amount of space plus some extra for guard bands + * at both ends of the request, plus a size, panicing if there isn't + * enough space, then write in the guard bands and return the address of + * the space in the middle that the user asked for. + * + * The second and third arguments are file and line, these contain the + * filename and line number corresponding to the caller. These are sent + * by the ckalloc macro; it uses the preprocessor autodefines __FILE__ + * and __LINE__. * *---------------------------------------------------------------------- */ char * @@ -372,28 +377,29 @@ int line; { struct mem_header *result; if (validate_memory) { - Tcl_ValidateAllMemory(file, line); + Tcl_ValidateAllMemory(file, line); } - result = (struct mem_header *) TclpAlloc((unsigned)size + + result = (struct mem_header *) TclpAlloc((unsigned)size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); if (result == NULL) { - fflush(stdout); - TclDumpMemoryInfo(stderr); - Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line); + fflush(stdout); + TclDumpMemoryInfo(stderr); + Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line); } /* - * Fill in guard zones and size. Also initialize the contents of - * the block with bogus bytes to detect uses of initialized data. - * Link into allocated list. + * Fill in guard zones and size. Also initialize the contents of the block + * with bogus bytes to detect uses of initialized data. Link into + * allocated list. */ + if (init_malloced_bodies) { - memset((VOID *) result, GUARD_VALUE, + memset((VOID *) result, GUARD_VALUE, size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); } else { memset((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE); memset(result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE); } @@ -410,46 +416,46 @@ result->line = line; result->flink = allocHead; result->blink = NULL; if (allocHead != NULL) { - allocHead->blink = result; + allocHead->blink = result; } allocHead = result; total_mallocs++; if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) { (void) fflush(stdout); - fprintf(stderr, "reached malloc trace enable point (%d)\n", - total_mallocs); - fflush(stderr); - alloc_tracing = TRUE; - trace_on_at_malloc = 0; + fprintf(stderr, "reached malloc trace enable point (%d)\n", + total_mallocs); + fflush(stderr); + alloc_tracing = TRUE; + trace_on_at_malloc = 0; } if (alloc_tracing) { - fprintf(stderr,"ckalloc %lx %u %s %d\n", + fprintf(stderr,"ckalloc %lx %u %s %d\n", (long unsigned int) result->body, size, file, line); } if (break_on_malloc && (total_mallocs >= break_on_malloc)) { - break_on_malloc = 0; + break_on_malloc = 0; (void) fflush(stdout); - fprintf(stderr,"reached malloc break limit (%d)\n", - total_mallocs); - fprintf(stderr, "program will now enter C debugger\n"); + fprintf(stderr,"reached malloc break limit (%d)\n", + total_mallocs); + fprintf(stderr, "program will now enter C debugger\n"); (void) fflush(stderr); abort(); } current_malloc_packets++; if (current_malloc_packets > maximum_malloc_packets) { - maximum_malloc_packets = current_malloc_packets; + maximum_malloc_packets = current_malloc_packets; } current_bytes_malloced += size; if (current_bytes_malloced > maximum_bytes_malloced) { - maximum_bytes_malloced = current_bytes_malloced; + maximum_bytes_malloced = current_bytes_malloced; } Tcl_MutexUnlock(ckallocMutexPtr); return result->body; @@ -462,28 +468,28 @@ int line; { struct mem_header *result; if (validate_memory) { - Tcl_ValidateAllMemory(file, line); + Tcl_ValidateAllMemory(file, line); } - result = (struct mem_header *) TclpAlloc((unsigned)size + + result = (struct mem_header *) TclpAlloc((unsigned)size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); if (result == NULL) { - fflush(stdout); - TclDumpMemoryInfo(stderr); + fflush(stdout); + TclDumpMemoryInfo(stderr); return NULL; } /* - * Fill in guard zones and size. Also initialize the contents of - * the block with bogus bytes to detect uses of initialized data. - * Link into allocated list. + * Fill in guard zones and size. Also initialize the contents of the block + * with bogus bytes to detect uses of initialized data. Link into + * allocated list. */ if (init_malloced_bodies) { - memset((VOID *) result, GUARD_VALUE, + memset((VOID *) result, GUARD_VALUE, size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); } else { memset((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE); memset(result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE); } @@ -500,46 +506,46 @@ result->line = line; result->flink = allocHead; result->blink = NULL; if (allocHead != NULL) { - allocHead->blink = result; + allocHead->blink = result; } allocHead = result; total_mallocs++; if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) { (void) fflush(stdout); - fprintf(stderr, "reached malloc trace enable point (%d)\n", - total_mallocs); - fflush(stderr); - alloc_tracing = TRUE; - trace_on_at_malloc = 0; + fprintf(stderr, "reached malloc trace enable point (%d)\n", + total_mallocs); + fflush(stderr); + alloc_tracing = TRUE; + trace_on_at_malloc = 0; } if (alloc_tracing) { - fprintf(stderr,"ckalloc %lx %u %s %d\n", + fprintf(stderr,"ckalloc %lx %u %s %d\n", (long unsigned int) result->body, size, file, line); } if (break_on_malloc && (total_mallocs >= break_on_malloc)) { - break_on_malloc = 0; + break_on_malloc = 0; (void) fflush(stdout); - fprintf(stderr,"reached malloc break limit (%d)\n", - total_mallocs); - fprintf(stderr, "program will now enter C debugger\n"); + fprintf(stderr,"reached malloc break limit (%d)\n", + total_mallocs); + fprintf(stderr, "program will now enter C debugger\n"); (void) fflush(stderr); abort(); } current_malloc_packets++; if (current_malloc_packets > maximum_malloc_packets) { - maximum_malloc_packets = current_malloc_packets; + maximum_malloc_packets = current_malloc_packets; } current_bytes_malloced += size; if (current_bytes_malloced > maximum_bytes_malloced) { - maximum_bytes_malloced = current_bytes_malloced; + maximum_bytes_malloced = current_bytes_malloced; } Tcl_MutexUnlock(ckallocMutexPtr); return result->body; @@ -548,20 +554,19 @@ /* *---------------------------------------------------------------------- * * Tcl_DbCkfree - debugging ckfree * - * Verify that the low and high guards are intact, and if so - * then free the buffer else Tcl_Panic. - * - * The guards are erased after being checked to catch duplicate - * frees. - * - * The second and third arguments are file and line, these contain - * the filename and line number corresponding to the caller. - * These are sent by the ckfree macro; it uses the preprocessor - * autodefines __FILE__ and __LINE__. + * Verify that the low and high guards are intact, and if so then free + * the buffer else Tcl_Panic. + * + * The guards are erased after being checked to catch duplicate frees. + * + * The second and third arguments are file and line, these contain the + * filename and line number corresponding to the caller. These are sent + * by the ckfree macro; it uses the preprocessor autodefines __FILE__ and + * __LINE__. * *---------------------------------------------------------------------- */ int @@ -575,26 +580,26 @@ if (ptr == NULL) { return 0; } /* - * The following cast is *very* tricky. Must convert the pointer - * to an integer before doing arithmetic on it, because otherwise - * the arithmetic will be done differently (and incorrectly) on - * word-addressed machines such as Crays (will subtract only bytes, - * even though BODY_OFFSET is in words on these machines). + * The following cast is *very* tricky. Must convert the pointer to an + * integer before doing arithmetic on it, because otherwise the arithmetic + * will be done differently (and incorrectly) on word-addressed machines + * such as Crays (will subtract only bytes, even though BODY_OFFSET is in + * words on these machines). */ memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET); if (alloc_tracing) { - fprintf(stderr, "ckfree %lx %ld %s %d\n", + fprintf(stderr, "ckfree %lx %ld %s %d\n", (long unsigned int) memp->body, memp->length, file, line); } if (validate_memory) { - Tcl_ValidateAllMemory(file, line); + Tcl_ValidateAllMemory(file, line); } Tcl_MutexLock(ckallocMutexPtr); ValidateMemory(memp, file, line, TRUE); if (init_malloced_bodies) { @@ -613,18 +618,19 @@ } /* * Delink from allocated list */ + if (memp->flink != NULL) { - memp->flink->blink = memp->blink; + memp->flink->blink = memp->blink; } if (memp->blink != NULL) { - memp->blink->flink = memp->flink; + memp->blink->flink = memp->flink; } if (allocHead == memp) { - allocHead = memp->flink; + allocHead = memp->flink; } TclpFree((char *) memp); Tcl_MutexUnlock(ckallocMutexPtr); return 0; @@ -633,14 +639,14 @@ /* *-------------------------------------------------------------------- * * Tcl_DbCkrealloc - debugging ckrealloc * - * Reallocate a chunk of memory by allocating a new one of the - * right size, copying the old data to the new location, and then - * freeing the old memory space, using all the memory checking - * features of this package. + * Reallocate a chunk of memory by allocating a new one of the right + * size, copying the old data to the new location, and then freeing the + * old memory space, using all the memory checking features of this + * package. * *-------------------------------------------------------------------- */ char * @@ -657,12 +663,11 @@ if (ptr == NULL) { return Tcl_DbCkalloc(size, file, line); } /* - * See comment from Tcl_DbCkfree before you change the following - * line. + * See comment from Tcl_DbCkfree before you change the following line. */ memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET); copySize = size; @@ -689,12 +694,11 @@ if (ptr == NULL) { return Tcl_AttemptDbCkalloc(size, file, line); } /* - * See comment from Tcl_DbCkfree before you change the following - * line. + * See comment from Tcl_DbCkfree before you change the following line. */ memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET); copySize = size; @@ -714,12 +718,12 @@ /* *---------------------------------------------------------------------- * * Tcl_Alloc, et al. -- * - * These functions are defined in terms of the debugging versions - * when TCL_MEM_DEBUG is set. + * These functions are defined in terms of the debugging versions when + * TCL_MEM_DEBUG is set. * * Results: * Same as the debug versions. * * Side effects: @@ -772,12 +776,13 @@ /* *---------------------------------------------------------------------- * * MemoryCmd -- - * Implements the Tcl "memory" command, which provides Tcl-level - * control of Tcl memory debugging information. + * + * Implements the Tcl "memory" command, which provides Tcl-level control + * of Tcl memory debugging information. * memory active $file * memory break_on_malloc $count * memory info * memory init on|off * memory onexit $file @@ -785,11 +790,11 @@ * memory trace on|off * memory trace_on_at_malloc $count * memory validate on|off * * Results: - * Standard TCL results. + * Standard TCL results. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int @@ -808,11 +813,11 @@ argv[0], " option [args..]\"", (char *) NULL); return TCL_ERROR; } if ((strcmp(argv[1],"active") == 0) || (strcmp(argv[1],"display") == 0)) { - if (argc != 3) { + if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], " file\"", (char *) NULL); return TCL_ERROR; } fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); @@ -820,45 +825,45 @@ return TCL_ERROR; } result = Tcl_DumpActiveMemory (fileName); Tcl_DStringFree(&buffer); if (result != TCL_OK) { - Tcl_AppendResult(interp, "error accessing ", argv[2], + Tcl_AppendResult(interp, "error accessing ", argv[2], (char *) NULL); return TCL_ERROR; } return TCL_OK; } if (strcmp(argv[1],"break_on_malloc") == 0) { - if (argc != 3) { - goto argError; + if (argc != 3) { + goto argError; } - if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) { + if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) { return TCL_ERROR; } - return TCL_OK; + return TCL_OK; } if (strcmp(argv[1],"info") == 0) { - char buf[400]; - sprintf(buf, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n", - "total mallocs", total_mallocs, "total frees", total_frees, - "current packets allocated", current_malloc_packets, - "current bytes allocated", current_bytes_malloced, - "maximum packets allocated", maximum_malloc_packets, - "maximum bytes allocated", maximum_bytes_malloced); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - return TCL_OK; + Tcl_Obj *objPtr = Tcl_NewObj(); + TclObjPrintf(NULL, objPtr, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n", + "total mallocs", total_mallocs, "total frees", total_frees, + "current packets allocated", current_malloc_packets, + "current bytes allocated", current_bytes_malloced, + "maximum packets allocated", maximum_malloc_packets, + "maximum bytes allocated", maximum_bytes_malloced); + Tcl_SetObjResult(interp, objPtr); + return TCL_OK; } if (strcmp(argv[1],"init") == 0) { - if (argc != 3) { - goto bad_suboption; + if (argc != 3) { + goto bad_suboption; } - init_malloced_bodies = (strcmp(argv[2],"on") == 0); - return TCL_OK; + init_malloced_bodies = (strcmp(argv[2],"on") == 0); + return TCL_OK; } if (strcmp(argv[1],"onexit") == 0) { - if (argc != 3) { + if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " onexit file\"", (char *) NULL); return TCL_ERROR; } fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); @@ -883,45 +888,45 @@ curTagPtr->refCount = 0; strcpy(curTagPtr->string, argv[2]); return TCL_OK; } if (strcmp(argv[1],"trace") == 0) { - if (argc != 3) { - goto bad_suboption; + if (argc != 3) { + goto bad_suboption; } - alloc_tracing = (strcmp(argv[2],"on") == 0); - return TCL_OK; + alloc_tracing = (strcmp(argv[2],"on") == 0); + return TCL_OK; } if (strcmp(argv[1],"trace_on_at_malloc") == 0) { - if (argc != 3) { - goto argError; + if (argc != 3) { + goto argError; } - if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) { + if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) { return TCL_ERROR; } return TCL_OK; } if (strcmp(argv[1],"validate") == 0) { - if (argc != 3) { + if (argc != 3) { goto bad_suboption; } - validate_memory = (strcmp(argv[2],"on") == 0); - return TCL_OK; + validate_memory = (strcmp(argv[2],"on") == 0); + return TCL_OK; } Tcl_AppendResult(interp, "bad option \"", argv[1], "\": should be active, break_on_malloc, info, init, onexit, ", "tag, trace, trace_on_at_malloc, or validate", (char *) NULL); return TCL_ERROR; -argError: + argError: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], " count\"", (char *) NULL); return TCL_ERROR; -bad_suboption: + bad_suboption: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], " on|off\"", (char *) NULL); return TCL_ERROR; } @@ -928,14 +933,13 @@ /* *---------------------------------------------------------------------- * * CheckmemCmd -- * - * This is the command procedure for the "checkmem" command, which - * causes the application to exit after printing information about - * memory usage to the file passed to this command as its first - * argument. + * This is the command procedure for the "checkmem" command, which causes + * the application to exit after printing information about memory usage + * to the file passed to this command as its first argument. * * Results: * Returns a standard Tcl completion code. * * Side effects: @@ -964,12 +968,11 @@ /* *---------------------------------------------------------------------- * * Tcl_InitMemory -- * - * Create the "memory" and "checkmem" commands in the given - * interpreter. + * Create the "memory" and "checkmem" commands in the given interpreter. * * Results: * None. * * Side effects: @@ -981,11 +984,11 @@ void Tcl_InitMemory(interp) Tcl_Interp *interp; /* Interpreter in which commands should be added */ { TclInitDbCkalloc(); - Tcl_CreateCommand(interp, "memory", MemoryCmd, (ClientData) NULL, + Tcl_CreateCommand(interp, "memory", MemoryCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); } @@ -1001,12 +1004,13 @@ /* *---------------------------------------------------------------------- * * Tcl_Alloc -- - * Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does check - * that memory was actually allocated. + * + * Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does check + * that memory was actually allocated. * *---------------------------------------------------------------------- */ char * @@ -1014,19 +1018,21 @@ unsigned int size; { char *result; result = TclpAlloc(size); + /* - * Most systems will not alloc(0), instead bumping it to one so - * that NULL isn't returned. Some systems (AIX, Tru64) will alloc(0) - * by returning NULL, so we have to check that the NULL we get is - * not in response to alloc(0). + * Most systems will not alloc(0), instead bumping it to one so that NULL + * isn't returned. Some systems (AIX, Tru64) will alloc(0) by returning + * NULL, so we have to check that the NULL we get is not in response to + * alloc(0). * - * The ANSI spec actually says that systems either return NULL *or* - * a special pointer on failure, but we only check for NULL + * The ANSI spec actually says that systems either return NULL *or* a + * special pointer on failure, but we only check for NULL */ + if ((result == NULL) && size) { Tcl_Panic("unable to alloc %u bytes", size); } return result; } @@ -1040,22 +1046,23 @@ char *result; result = (char *) TclpAlloc(size); if ((result == NULL) && size) { - fflush(stdout); - Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line); + fflush(stdout); + Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line); } return result; } /* *---------------------------------------------------------------------- * * Tcl_AttemptAlloc -- - * Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does not - * check that memory was actually allocated. + * + * Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does not + * check that memory was actually allocated. * *---------------------------------------------------------------------- */ char * @@ -1077,18 +1084,18 @@ char *result; result = (char *) TclpAlloc(size); return result; } - /* *---------------------------------------------------------------------- * * Tcl_Realloc -- - * Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does - * check that memory was actually allocated. + * + * Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does check + * that memory was actually allocated. * *---------------------------------------------------------------------- */ char * @@ -1116,22 +1123,23 @@ char *result; result = (char *) TclpRealloc(ptr, size); if ((result == NULL) && size) { - fflush(stdout); - Tcl_Panic("unable to realloc %u bytes, %s line %d", size, file, line); + fflush(stdout); + Tcl_Panic("unable to realloc %u bytes, %s line %d", size, file, line); } return result; } /* *---------------------------------------------------------------------- * * Tcl_AttemptRealloc -- - * Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does - * not check that memory was actually allocated. + * + * Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does not + * check that memory was actually allocated. * *---------------------------------------------------------------------- */ char * @@ -1160,13 +1168,14 @@ /* *---------------------------------------------------------------------- * * Tcl_Free -- - * Interface to TclpFree when TCL_MEM_DEBUG is disabled. Done here - * rather in the macro to keep some modules from being compiled with - * TCL_MEM_DEBUG enabled and some with it disabled. + * + * Interface to TclpFree when TCL_MEM_DEBUG is disabled. Done here rather + * in the macro to keep some modules from being compiled with + * TCL_MEM_DEBUG enabled and some with it disabled. * *---------------------------------------------------------------------- */ void @@ -1188,12 +1197,13 @@ /* *---------------------------------------------------------------------- * * Tcl_InitMemory -- - * Dummy initialization for memory command, which is only available - * if TCL_MEM_DEBUG is on. + * + * Dummy initialization for memory command, which is only available if + * TCL_MEM_DEBUG is on. * *---------------------------------------------------------------------- */ /* ARGSUSED */ void @@ -1215,11 +1225,11 @@ int line; { } void -TclDumpMemoryInfo(outFile) +TclDumpMemoryInfo(outFile) FILE *outFile; { } #endif /* TCL_MEM_DEBUG */ @@ -1227,21 +1237,20 @@ /* *--------------------------------------------------------------------------- * * TclFinalizeMemorySubsystem -- * - * This procedure is called to finalize all the structures that - * are used by the memory allocator on a per-process basis. + * This procedure is called to finalize all the structures that are used + * by the memory allocator on a per-process basis. * * Results: * None. * * Side effects: - * This subsystem is self-initializing, since memory can be - * allocated before Tcl is formally initialized. After this call, - * this subsystem has been reset to its initial state and is - * usable again. + * This subsystem is self-initializing, since memory can be allocated + * before Tcl is formally initialized. After this call, this subsystem + * has been reset to its initial state and is usable again. * *--------------------------------------------------------------------------- */ void @@ -1251,18 +1260,29 @@ if (tclMemDumpFileName != NULL) { Tcl_DumpActiveMemory(tclMemDumpFileName); } else if (onExitMemDumpFileName != NULL) { Tcl_DumpActiveMemory(onExitMemDumpFileName); } + Tcl_MutexLock(ckallocMutexPtr); + if (curTagPtr != NULL) { TclpFree((char *) curTagPtr); curTagPtr = NULL; } allocHead = NULL; + Tcl_MutexUnlock(ckallocMutexPtr); #endif #if USE_TCLALLOC - TclFinalizeAllocSubsystem(); + TclFinalizeAllocSubsystem(); #endif } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclClock.c ================================================================== --- generic/tclClock.c +++ generic/tclClock.c @@ -10,11 +10,11 @@ * Copyright (c) 2004 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: tclClock.c,v 1.37 2004/10/30 18:04:00 kennykb Exp $ + * RCS: @(#) $Id: tclClock.c,v 1.37.2.2 2005/08/15 18:13:58 dgp Exp $ */ #include "tclInt.h" /* @@ -164,10 +164,18 @@ Tcl_SetErrorCode( interp, "CLOCK", "argTooLarge", (char*) NULL ); return TCL_ERROR; } TzsetIfNecessary(); timeVal = ThreadSafeLocalTime( &tock ); + if ( timeVal == NULL ) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("localtime failed (clock " + "value may be too large/" + "small to represent)", -1)); + Tcl_SetErrorCode(interp, "CLOCK", "localtimeFailed", (char*) NULL); + return TCL_ERROR; + } /* Package the results */ returnVec[0] = Tcl_NewIntObj( timeVal->tm_year + 1900 ); returnVec[1] = Tcl_NewIntObj( timeVal->tm_mon + 1); @@ -197,14 +205,12 @@ *---------------------------------------------------------------------- */ static struct tm * ThreadSafeLocalTime(timePtr) - CONST time_t *timePtr; /* Pointer to the number of seconds - * since the local system's epoch - */ - + CONST time_t *timePtr; /* Pointer to the number of seconds since the + * local system's epoch */ { /* * Get a thread-local buffer to hold the returned time. */ @@ -211,14 +217,22 @@ struct tm *tmPtr = (struct tm *) Tcl_GetThreadData(&tmKey, (int) sizeof(struct tm)); #ifdef HAVE_LOCALTIME_R localtime_r(timePtr, tmPtr); #else + struct tm *sysTmPtr; + Tcl_MutexLock(&clockMutex); - memcpy((VOID *) tmPtr, (VOID *) localtime(timePtr), sizeof(struct tm)); - Tcl_MutexUnlock(&clockMutex); -#endif + sysTmPtr = localtime(timePtr); + if (sysTmPtr == NULL) { + Tcl_MutexUnlock(&clockMutex); + return NULL; + } else { + memcpy((VOID *) tmPtr, (VOID *) localtime(timePtr), sizeof(struct tm)); + Tcl_MutexUnlock(&clockMutex); + } +#endif return tmPtr; } /* *---------------------------------------------------------------------- @@ -303,12 +317,12 @@ if ( Tcl_GetIntFromObj( interp, objv[6], &i ) != TCL_OK ) { return TCL_ERROR; } toConvert.tm_sec = i; toConvert.tm_isdst = -1; - toConvert.tm_wday = 0; - toConvert.tm_yday = 0; + toConvert.tm_wday = -1; + toConvert.tm_yday = -1; /* Convert the time. It is rumored that mktime is not thread * safe on some platforms. */ TzsetIfNecessary(); @@ -318,11 +332,13 @@ localErrno = errno; Tcl_MutexUnlock( &clockMutex ); /* Return the converted time, or an error if conversion fails */ - if ( localErrno != 0 ) { + if ( localErrno != 0 + || ( convertedTime == -1 + && toConvert.tm_yday == -1 ) ) { Tcl_SetObjResult ( interp, Tcl_NewStringObj( "time value too large/small to represent", -1 ) ); return TCL_ERROR; Index: generic/tclCmdAH.c ================================================================== --- generic/tclCmdAH.c +++ generic/tclCmdAH.c @@ -1,48 +1,48 @@ -/* +/* * tclCmdAH.c -- * - * This file contains the top-level command routines for most of - * the Tcl built-in commands whose names begin with the letters - * A to H. + * This file contains the top-level command routines for most of the Tcl + * built-in commands whose names begin with the letters A to H. * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdAH.c,v 1.57 2004/11/13 00:19:07 dgp Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.57.2.10 2005/09/15 20:58:39 dgp Exp $ */ #include "tclInt.h" #include +#define NEW_FORMAT 1 + /* * Prototypes for local procedures defined in this file: */ -static int CheckAccess _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *pathPtr, int mode)); -static int GetStatBuf _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *pathPtr, Tcl_FSStatProc *statProc, - Tcl_StatBuf *statPtr)); -static char * GetTypeFromMode _ANSI_ARGS_((int mode)); -static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *varName, Tcl_StatBuf *statPtr)); +static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr, + int mode); +static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr, + Tcl_FSStatProc *statProc, Tcl_StatBuf *statPtr); +static char * GetTypeFromMode(int mode); +static int StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName, + Tcl_StatBuf *statPtr); /* *---------------------------------------------------------------------- * * Tcl_BreakObjCmd -- * - * This procedure is invoked to process the "break" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "break" Tcl command. See the + * user documentation for details on what it does. * - * With the bytecode compiler, this procedure is only called when - * a command name is computed at runtime, and is "break" or the name - * to which "break" was renamed: e.g., "set z break; $z" + * With the bytecode compiler, this procedure is only called when a + * command name is computed at runtime, and is "break" or the name to + * which "break" was renamed: e.g., "set z break; $z" * * Results: * A standard Tcl result. * * Side effects: @@ -52,14 +52,14 @@ */ /* ARGSUSED */ int Tcl_BreakObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } @@ -69,12 +69,12 @@ /* *---------------------------------------------------------------------- * * Tcl_CaseObjCmd -- * - * This procedure is invoked to process the "case" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "case" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: @@ -114,12 +114,12 @@ } caseObjc = objc - i; caseObjv = objv + i; /* - * If all of the pattern/command pairs are lumped into a single - * argument, split them out again. + * If all of the pattern/command pairs are lumped into a single argument, + * split them out again. */ if (caseObjc == 1) { Tcl_Obj **newObjv; @@ -138,12 +138,12 @@ Tcl_AppendResult(interp, "extra case pattern with no body", NULL); return TCL_ERROR; } /* - * Check for special case of single pattern (no list) with - * no backslash sequences. + * Check for special case of single pattern (no list) with no + * backslash sequences. */ pat = TclGetString(caseObjv[i]); for (p = (unsigned char *) pat; *p != '\0'; p++) { if (isspace(*p) || (*p == '\\')) { /* INTL: ISO space, UCHAR */ @@ -160,12 +160,12 @@ } continue; } /* - * Break up pattern lists, then check each of the patterns - * in the list. + * Break up pattern lists, then check each of the patterns in the + * list. */ result = Tcl_SplitList(interp, pat, &patObjc, &patObjv); if (result != TCL_OK) { return result; @@ -180,21 +180,17 @@ if (j < patObjc) { break; } } - match: + match: if (body != -1) { armPtr = caseObjv[body - 1]; result = Tcl_EvalObjEx(interp, caseObjv[body], 0); if (result == TCL_ERROR) { - char msg[100 + TCL_INTEGER_SPACE]; - - arg = TclGetString(armPtr); - sprintf(msg, "\n (\"%.50s\" arm line %d)", arg, - interp->errorLine); - Tcl_AddObjErrorInfo(interp, msg, -1); + TclFormatToErrorInfo(interp, "\n (\"%.50s\" arm line %d)", + TclGetString(armPtr), interp->errorLine); } return result; } /* @@ -207,11 +203,11 @@ /* *---------------------------------------------------------------------- * * Tcl_CatchObjCmd -- * - * This object-based procedure is invoked to process the "catch" Tcl + * This object-based procedure is invoked to process the "catch" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result. * @@ -249,24 +245,23 @@ result = Tcl_EvalObjEx(interp, objv[1], 0); /* * We disable catch in interpreters where the limit has been exceeded. */ + if (Tcl_LimitExceeded(interp)) { - char msg[32 + TCL_INTEGER_SPACE]; - - sprintf(msg, "\n (\"catch\" body line %d)", interp->errorLine); - Tcl_AddErrorInfo(interp, msg); + TclFormatToErrorInfo(interp, "\n (\"catch\" body line %d)", + interp->errorLine); return TCL_ERROR; } if (objc >= 3) { if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL, Tcl_GetObjResult(interp), 0)) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, - "couldn't save command result in variable", NULL); + Tcl_AppendResult(interp, + "couldn't save command result in variable", NULL); return TCL_ERROR; } } if (objc == 4) { Tcl_Obj *options = Tcl_GetReturnOptions(interp, result); @@ -273,11 +268,11 @@ if (NULL == Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL, options, 0)) { Tcl_DecrRefCount(options); Tcl_ResetResult(interp); Tcl_AppendResult(interp, - "couldn't save return options in variable", NULL); + "couldn't save return options in variable", NULL); return TCL_ERROR; } } Tcl_ResetResult(interp); @@ -288,12 +283,12 @@ /* *---------------------------------------------------------------------- * * Tcl_CdObjCmd -- * - * This procedure is invoked to process the "cd" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "cd" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -372,18 +367,18 @@ } /* *---------------------------------------------------------------------- * - * Tcl_ContinueObjCmd - - * - * This procedure is invoked to process the "continue" Tcl command. - * See the user documentation for details on what it does. - * - * With the bytecode compiler, this procedure is only called when - * a command name is computed at runtime, and is "continue" or the name - * to which "continue" was renamed: e.g., "set z continue; $z" + * Tcl_ContinueObjCmd -- + * + * This procedure is invoked to process the "continue" Tcl command. See + * the user documentation for details on what it does. + * + * With the bytecode compiler, this procedure is only called when a + * command name is computed at runtime, and is "continue" or the name to + * which "continue" was renamed: e.g., "set z continue; $z" * * Results: * A standard Tcl result. * * Side effects: @@ -428,14 +423,11 @@ ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int index, length; - Tcl_Encoding encoding; - char *stringPtr; - Tcl_DString ds; + int index; static CONST char *optionStrings[] = { "convertfrom", "convertto", "names", "system", NULL }; @@ -443,102 +435,141 @@ ENC_CONVERTFROM, ENC_CONVERTTO, ENC_NAMES, ENC_SYSTEM }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); - return TCL_ERROR; + return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum options) index) { - case ENC_CONVERTTO: - case ENC_CONVERTFROM: { - char *name; - Tcl_Obj *data; - if (objc == 3) { - name = NULL; - data = objv[2]; - } else if (objc == 4) { - name = TclGetString(objv[2]); - data = objv[3]; - } else { - Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data"); - return TCL_ERROR; - } - - encoding = Tcl_GetEncoding(interp, name); - if (!encoding) { - return TCL_ERROR; - } - - if ((enum options) index == ENC_CONVERTFROM) { - /* - * Treat the string as binary data. - */ - - stringPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); - Tcl_ExternalToUtfDString(encoding, stringPtr, length, &ds); - - /* - * Note that we cannot use Tcl_DStringResult here because - * it will truncate the string at the first null byte. - */ - - Tcl_SetObjResult(interp, Tcl_NewStringObj( - Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); - Tcl_DStringFree(&ds); - } else { - /* - * Store the result as binary data. - */ - - stringPtr = Tcl_GetStringFromObj(data, &length); - Tcl_UtfToExternalDString(encoding, stringPtr, length, &ds); - Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( - (unsigned char *) Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds))); - Tcl_DStringFree(&ds); - } - - Tcl_FreeEncoding(encoding); - break; - } - case ENC_NAMES: { - if (objc > 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; - } - Tcl_GetEncodingNames(interp); - break; - } - case ENC_SYSTEM: { - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?encoding?"); - return TCL_ERROR; - } - if (objc == 2) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - Tcl_GetEncodingName(NULL), -1)); - } else { - return Tcl_SetSystemEncoding(interp, TclGetString(objv[2])); - } - break; - } - } + case ENC_CONVERTTO: + case ENC_CONVERTFROM: { + Tcl_Obj *data; + Tcl_DString ds; + Tcl_Encoding encoding; + int length; + char *stringPtr; + + if (objc == 3) { + encoding = Tcl_GetEncoding(interp, NULL); + data = objv[2]; + } else if (objc == 4) { + if (TclGetEncodingFromObj(interp, objv[2], &encoding) != TCL_OK) { + return TCL_ERROR; + } + data = objv[3]; + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data"); + return TCL_ERROR; + } + + if ((enum options) index == ENC_CONVERTFROM) { + /* + * Treat the string as binary data. + */ + + stringPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); + Tcl_ExternalToUtfDString(encoding, stringPtr, length, &ds); + + /* + * Note that we cannot use Tcl_DStringResult here because it will + * truncate the string at the first null byte. + */ + + Tcl_SetObjResult(interp, Tcl_NewStringObj( + Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); + Tcl_DStringFree(&ds); + } else { + /* + * Store the result as binary data. + */ + + stringPtr = Tcl_GetStringFromObj(data, &length); + Tcl_UtfToExternalDString(encoding, stringPtr, length, &ds); + Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( + (unsigned char *) Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds))); + Tcl_DStringFree(&ds); + } + + Tcl_FreeEncoding(encoding); + break; + } + case ENC_NAMES: + if (objc > 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + Tcl_GetEncodingNames(interp); + break; + case ENC_SYSTEM: + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?encoding?"); + return TCL_ERROR; + } + if (objc == 2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + Tcl_GetEncodingName(NULL), -1)); + } else { + return Tcl_SetSystemEncoding(interp, TclGetString(objv[2])); + } + break; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclEncodingDirsObjCmd -- + * + * This command manipulates the encoding search path. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Can set the encoding search path. + * + *---------------------------------------------------------------------- + */ + +int +TclEncodingDirsObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?dirList?"); + return TCL_ERROR; + } + if (objc == 1) { + Tcl_SetObjResult(interp, TclGetEncodingSearchPath()); + return TCL_OK; + } + if (TclSetEncodingSearchPath(objv[1]) == TCL_ERROR) { + Tcl_AppendResult(interp, "expected directory list but got \"", + Tcl_GetString(objv[1]), "\"", NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ErrorObjCmd -- * - * This procedure is invoked to process the "error" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "error" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: @@ -583,11 +614,11 @@ /* *---------------------------------------------------------------------- * * Tcl_EvalObjCmd -- * - * This object-based procedure is invoked to process the "eval" Tcl + * This object-based procedure is invoked to process the "eval" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result. * @@ -616,32 +647,31 @@ if (objc == 2) { result = Tcl_EvalObjEx(interp, objv[1], TCL_EVAL_DIRECT); } else { /* * More than one argument: concatenate them together with spaces - * between, then evaluate the result. Tcl_EvalObjEx will delete - * the object when it decrements its refcount after eval'ing it. + * between, then evaluate the result. Tcl_EvalObjEx will delete the + * object when it decrements its refcount after eval'ing it. */ + objPtr = Tcl_ConcatObj(objc-1, objv+1); result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); } if (result == TCL_ERROR) { - char msg[32 + TCL_INTEGER_SPACE]; - - sprintf(msg, "\n (\"eval\" body line %d)", interp->errorLine); - Tcl_AddObjErrorInfo(interp, msg, -1); + TclFormatToErrorInfo(interp,"\n (\"eval\" body line %d)", + interp->errorLine); } return result; } /* *---------------------------------------------------------------------- * * Tcl_ExitObjCmd -- * - * This procedure is invoked to process the "exit" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "exit" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: @@ -682,12 +712,12 @@ * * This object-based procedure is invoked to process the "expr" Tcl * command. See the user documentation for details on what it does. * * With the bytecode compiler, this procedure is called in two - * circumstances: 1) to execute expr commands that are too complicated - * or too unsafe to try compiling directly into an inline sequence of + * circumstances: 1) to execute expr commands that are too complicated or + * too unsafe to try compiling directly into an inline sequence of * instructions, and 2) to execute commands where the command name is * computed at runtime and is "expr" or the name to which "expr" was * renamed (e.g., "set z expr; $z 2+3") * * Results: @@ -704,11 +734,11 @@ Tcl_ExprObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ +{ register Tcl_Obj *objPtr; Tcl_Obj *resultPtr; int result; if (objc < 2) { @@ -721,11 +751,11 @@ result = Tcl_ExprObj(interp, objPtr, &resultPtr); Tcl_DecrRefCount(objPtr); if (result == TCL_OK) { Tcl_SetObjResult(interp, resultPtr); - Tcl_DecrRefCount(resultPtr); /* done with the result object */ + Tcl_DecrRefCount(resultPtr); /* done with the result object */ } return result; } @@ -732,17 +762,16 @@ /* *---------------------------------------------------------------------- * * Tcl_FileObjCmd -- * - * This procedure is invoked to process the "file" Tcl command. - * See the user documentation for details on what it does. - * PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH - * EMBEDDED NULLS. - * With the object-based Tcl_FS APIs, the above NOTE may no - * longer be true. In any case this assertion should be tested. - * + * This procedure is invoked to process the "file" Tcl command. See the + * user documentation for details on what it does. PLEASE NOTE THAT THIS + * FAILS WITH FILENAMES AND PATHS WITH EMBEDDED NULLS. With the + * object-based Tcl_FS APIs, the above NOTE may no longer be true. In any + * case this assertion should be tested. + * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. @@ -758,634 +787,598 @@ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int index; -/* - * This list of constants should match the fileOption string array below. - */ + /* + * This list of constants should match the fileOption string array below. + */ static CONST char *fileOptions[] = { "atime", "attributes", "channels", "copy", "delete", "dirname", "executable", "exists", "extension", "isdirectory", "isfile", "join", "link", - "lstat", "mtime", "mkdir", "nativename", + "lstat", "mtime", "mkdir", "nativename", "normalize", "owned", "pathtype", "readable", "readlink", "rename", - "rootname", "separator", "size", "split", - "stat", "system", + "rootname", "separator", "size", "split", + "stat", "system", "tail", "type", "volumes", "writable", (char *) NULL }; enum options { FCMD_ATIME, FCMD_ATTRIBUTES, FCMD_CHANNELS, FCMD_COPY, FCMD_DELETE, FCMD_DIRNAME, FCMD_EXECUTABLE, FCMD_EXISTS, FCMD_EXTENSION, - FCMD_ISDIRECTORY, FCMD_ISFILE, FCMD_JOIN, FCMD_LINK, - FCMD_LSTAT, FCMD_MTIME, FCMD_MKDIR, FCMD_NATIVENAME, - FCMD_NORMALIZE, FCMD_OWNED, + FCMD_ISDIRECTORY, FCMD_ISFILE, FCMD_JOIN, FCMD_LINK, + FCMD_LSTAT, FCMD_MTIME, FCMD_MKDIR, FCMD_NATIVENAME, + FCMD_NORMALIZE, FCMD_OWNED, FCMD_PATHTYPE, FCMD_READABLE, FCMD_READLINK, FCMD_RENAME, - FCMD_ROOTNAME, FCMD_SEPARATOR, FCMD_SIZE, FCMD_SPLIT, - FCMD_STAT, FCMD_SYSTEM, + FCMD_ROOTNAME, FCMD_SEPARATOR, FCMD_SIZE, FCMD_SPLIT, + FCMD_STAT, FCMD_SYSTEM, FCMD_TAIL, FCMD_TYPE, FCMD_VOLUMES, FCMD_WRITABLE }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); - return TCL_ERROR; + return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum options) index) { - case FCMD_ATIME: { - Tcl_StatBuf buf; - struct utimbuf tval; - - if ((objc < 3) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "name ?time?"); - return TCL_ERROR; - } - if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { - return TCL_ERROR; - } - if (objc == 4) { - /* - * Need separate variable for reading longs from an - * object on 64-bit platforms. [Bug #698146] - */ - long newTime; - - if (Tcl_GetLongFromObj(interp, objv[3], &newTime) != TCL_OK) { - return TCL_ERROR; - } - - tval.actime = newTime; - tval.modtime = buf.st_mtime; - if (Tcl_FSUtime(objv[2], &tval) != 0) { - Tcl_AppendResult(interp, - "could not set access time for file \"", - TclGetString(objv[2]), "\": ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - /* - * Do another stat to ensure that the we return the - * new recognized atime - hopefully the same as the - * one we sent in. However, fs's like FAT don't - * even know what atime is. - */ - if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { - return TCL_ERROR; - } - } - Tcl_SetObjResult(interp, Tcl_NewLongObj((long) buf.st_atime)); - return TCL_OK; - } - case FCMD_ATTRIBUTES: - return TclFileAttrsCmd(interp, objc, objv); - case FCMD_CHANNELS: - if ((objc < 2) || (objc > 3)) { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); - return TCL_ERROR; - } - return Tcl_GetChannelNamesEx(interp, - ((objc == 2) ? NULL : TclGetString(objv[2]))); - case FCMD_COPY: - return TclFileCopyCmd(interp, objc, objv); - case FCMD_DELETE: - return TclFileDeleteCmd(interp, objc, objv); - case FCMD_DIRNAME: { - Tcl_Obj *dirPtr; - - if (objc != 3) { - goto only3Args; - } - dirPtr = TclPathPart(interp, objv[2], TCL_PATH_DIRNAME); - if (dirPtr == NULL) { - return TCL_ERROR; - } else { - Tcl_SetObjResult(interp, dirPtr); - Tcl_DecrRefCount(dirPtr); - return TCL_OK; - } - } - case FCMD_EXECUTABLE: - if (objc != 3) { - goto only3Args; - } - return CheckAccess(interp, objv[2], X_OK); - case FCMD_EXISTS: - if (objc != 3) { - goto only3Args; - } - return CheckAccess(interp, objv[2], F_OK); - case FCMD_EXTENSION: { - Tcl_Obj *ext; - - if (objc != 3) { - goto only3Args; - } - ext = TclPathPart(interp, objv[2], TCL_PATH_EXTENSION); - if (ext != NULL) { - Tcl_SetObjResult(interp, ext); - Tcl_DecrRefCount(ext); - return TCL_OK; - } else { - return TCL_ERROR; - } - } - case FCMD_ISDIRECTORY: { - int value; - Tcl_StatBuf buf; - - if (objc != 3) { - goto only3Args; - } - value = 0; - if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { - value = S_ISDIR(buf.st_mode); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); - return TCL_OK; - } - case FCMD_ISFILE: { - int value; - Tcl_StatBuf buf; - - if (objc != 3) { - goto only3Args; - } - value = 0; - if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { - value = S_ISREG(buf.st_mode); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); - return TCL_OK; - } - case FCMD_JOIN: { - Tcl_Obj *resObj; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); - return TCL_ERROR; - } - resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2); - Tcl_SetObjResult(interp, resObj); - return TCL_OK; - } - case FCMD_LINK: { - Tcl_Obj *contents; - int index; - - if (objc < 3 || objc > 5) { - Tcl_WrongNumArgs(interp, 2, objv, - "?-linktype? linkname ?target?"); - return TCL_ERROR; - } - - /* Index of the 'source' argument */ - if (objc == 5) { - index = 3; - } else { - index = 2; - } - - if (objc > 3) { - int linkAction; - if (objc == 5) { - /* We have a '-linktype' argument */ - static CONST char *linkTypes[] = { - "-symbolic", "-hard", NULL - }; - if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes, - "switch", 0, &linkAction) != TCL_OK) { - return TCL_ERROR; - } - if (linkAction == 0) { - linkAction = TCL_CREATE_SYMBOLIC_LINK; - } else { - linkAction = TCL_CREATE_HARD_LINK; - } - } else { - linkAction = TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK; - } - if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { - return TCL_ERROR; - } - /* Create link from source to target */ - contents = Tcl_FSLink(objv[index], objv[index+1], linkAction); - if (contents == NULL) { - /* - * We handle three common error cases specially, and - * for all other errors, we use the standard posix - * error message. - */ - if (errno == EEXIST) { - Tcl_AppendResult(interp, - "could not create new link \"", - TclGetString(objv[index]), - "\": that path already exists", (char *) NULL); - } else if (errno == ENOENT) { - /* - * There are two cases here: either the target - * doesn't exist, or the directory of the src - * doesn't exist. - */ - int access; - Tcl_Obj *dirPtr = TclPathPart(interp, objv[index], - TCL_PATH_DIRNAME); - if (dirPtr == NULL) { - return TCL_ERROR; - } - access = Tcl_FSAccess(dirPtr, F_OK); - Tcl_DecrRefCount(dirPtr); - if (access != 0) { - Tcl_AppendResult(interp, - "could not create new link \"", - TclGetString(objv[index]), - "\": no such file or directory", - (char *) NULL); - } else { - Tcl_AppendResult(interp, - "could not create new link \"", - TclGetString(objv[index]), - "\": target \"", - TclGetString(objv[index+1]), - "\" doesn't exist", - (char *) NULL); - } - } else { - Tcl_AppendResult(interp, - "could not create new link \"", - TclGetString(objv[index]), "\" pointing to \"", - TclGetString(objv[index+1]), "\": ", - Tcl_PosixError(interp), (char *) NULL); - } - return TCL_ERROR; - } - } else { - if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { - return TCL_ERROR; - } - /* Read link */ - contents = Tcl_FSLink(objv[index], NULL, 0); - if (contents == NULL) { - Tcl_AppendResult(interp, "could not read link \"", - TclGetString(objv[index]), "\": ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - } - Tcl_SetObjResult(interp, contents); - if (objc == 3) { - /* - * If we are reading a link, we need to free this - * result refCount. If we are creating a link, this - * will just be objv[index+1], and so we don't own it. - */ - Tcl_DecrRefCount(contents); - } - return TCL_OK; - } - case FCMD_LSTAT: { - Tcl_StatBuf buf; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "name varName"); - return TCL_ERROR; - } - if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { - return TCL_ERROR; - } - return StoreStatData(interp, objv[3], &buf); - } - case FCMD_MTIME: { - Tcl_StatBuf buf; - struct utimbuf tval; - - if ((objc < 3) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "name ?time?"); - return TCL_ERROR; - } - if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { - return TCL_ERROR; - } - if (objc == 4) { - /* - * Need separate variable for reading longs from an - * object on 64-bit platforms. [Bug #698146] - */ - long newTime; - - if (Tcl_GetLongFromObj(interp, objv[3], &newTime) != TCL_OK) { - return TCL_ERROR; - } - - tval.actime = buf.st_atime; - tval.modtime = newTime; - if (Tcl_FSUtime(objv[2], &tval) != 0) { - Tcl_AppendResult(interp, - "could not set modification time for file \"", - TclGetString(objv[2]), "\": ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - /* - * Do another stat to ensure that the we return the - * new recognized atime - hopefully the same as the - * one we sent in. However, fs's like FAT don't - * even know what atime is. - */ - if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { - return TCL_ERROR; - } - } - Tcl_SetObjResult(interp, Tcl_NewLongObj((long) buf.st_mtime)); - return TCL_OK; - } - case FCMD_MKDIR: - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); - return TCL_ERROR; - } - return TclFileMakeDirsCmd(interp, objc, objv); - case FCMD_NATIVENAME: { - CONST char *fileName; - Tcl_DString ds; - - if (objc != 3) { - goto only3Args; - } - fileName = TclGetString(objv[2]); - fileName = Tcl_TranslateFileName(interp, fileName, &ds); - if (fileName == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(fileName, - Tcl_DStringLength(&ds))); - Tcl_DStringFree(&ds); - return TCL_OK; - } - case FCMD_NORMALIZE: { - Tcl_Obj *fileName; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "filename"); - return TCL_ERROR; - } - - fileName = Tcl_FSGetNormalizedPath(interp, objv[2]); - if (fileName == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, fileName); - return TCL_OK; - } - case FCMD_OWNED: { - int value; - Tcl_StatBuf buf; - - if (objc != 3) { - goto only3Args; - } - value = 0; - if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { - /* - * For Windows, there are no user ids - * associated with a file, so we always return 1. - */ - -#if defined(__WIN32__) - value = 1; -#else - value = (geteuid() == buf.st_uid); -#endif - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); - return TCL_OK; - } - case FCMD_PATHTYPE: - if (objc != 3) { - goto only3Args; - } - switch (Tcl_FSGetPathType(objv[2])) { - case TCL_PATH_ABSOLUTE: - Tcl_SetObjResult(interp, Tcl_NewStringObj("absolute", -1)); - break; - case TCL_PATH_RELATIVE: - Tcl_SetObjResult(interp, Tcl_NewStringObj("relative", -1)); - break; - case TCL_PATH_VOLUME_RELATIVE: - Tcl_SetObjResult(interp, - Tcl_NewStringObj("volumerelative", -1)); - break; - } - return TCL_OK; - case FCMD_READABLE: - if (objc != 3) { - goto only3Args; - } - return CheckAccess(interp, objv[2], R_OK); - case FCMD_READLINK: { - Tcl_Obj *contents; - - if (objc != 3) { - goto only3Args; - } - - if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) { - return TCL_ERROR; - } - - contents = Tcl_FSLink(objv[2], NULL, 0); - - if (contents == NULL) { - Tcl_AppendResult(interp, "could not readlink \"", - TclGetString(objv[2]), "\": ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, contents); - Tcl_DecrRefCount(contents); - return TCL_OK; - } - case FCMD_RENAME: - return TclFileRenameCmd(interp, objc, objv); - case FCMD_ROOTNAME: { - Tcl_Obj *root; - - if (objc != 3) { - goto only3Args; - } - root = TclPathPart(interp, objv[2], TCL_PATH_ROOT); - if (root != NULL) { - Tcl_SetObjResult(interp, root); - Tcl_DecrRefCount(root); - return TCL_OK; - } else { - return TCL_ERROR; - } - } - case FCMD_SEPARATOR: - if ((objc < 2) || (objc > 3)) { - Tcl_WrongNumArgs(interp, 2, objv, "?name?"); - return TCL_ERROR; - } - if (objc == 2) { - char *separator = NULL; /* lint */ - switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - separator = "/"; - break; - case TCL_PLATFORM_WINDOWS: - separator = "\\"; - break; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(separator,1)); - } else { - Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[2]); - if (separatorObj != NULL) { - Tcl_SetObjResult(interp, separatorObj); - } else { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("Unrecognised path",-1)); - return TCL_ERROR; - } - } - return TCL_OK; - case FCMD_SIZE: { - Tcl_StatBuf buf; - - if (objc != 3) { - goto only3Args; - } - if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, - Tcl_NewWideIntObj((Tcl_WideInt) buf.st_size)); - return TCL_OK; - } - case FCMD_SPLIT: { - Tcl_Obj *res; - - if (objc != 3) { - goto only3Args; - } - res = Tcl_FSSplitPath(objv[2], NULL); - if (res == NULL) { - if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", - TclGetString(objv[2]), - "\": no such file or directory", (char *) NULL); - } - return TCL_ERROR; - } else { - Tcl_SetObjResult(interp, res); - return TCL_OK; - } - } - case FCMD_STAT: { - Tcl_StatBuf buf; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "stat name varName"); - return TCL_ERROR; - } - if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { - return TCL_ERROR; - } - return StoreStatData(interp, objv[3], &buf); - } - case FCMD_SYSTEM: { - Tcl_Obj* fsInfo; - - if (objc != 3) { - goto only3Args; - } - fsInfo = Tcl_FSFileSystemInfo(objv[2]); - if (fsInfo != NULL) { - Tcl_SetObjResult(interp, fsInfo); - return TCL_OK; - } else { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("Unrecognised path",-1)); - return TCL_ERROR; - } - } - case FCMD_TAIL: { - Tcl_Obj *dirPtr; - - if (objc != 3) { - goto only3Args; - } - dirPtr = TclPathPart(interp, objv[2], TCL_PATH_TAIL); - if (dirPtr == NULL) { - return TCL_ERROR; - } else { - Tcl_SetObjResult(interp, dirPtr); - Tcl_DecrRefCount(dirPtr); - return TCL_OK; - } - } - case FCMD_TYPE: { - Tcl_StatBuf buf; - - if (objc != 3) { - goto only3Args; - } - if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj( - GetTypeFromMode((unsigned short) buf.st_mode), -1)); - return TCL_OK; - } - case FCMD_VOLUMES: - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_FSListVolumes()); - return TCL_OK; - case FCMD_WRITABLE: - if (objc != 3) { - goto only3Args; - } - return CheckAccess(interp, objv[2], W_OK); - } - - only3Args: + { + Tcl_StatBuf buf; + struct utimbuf tval; + + case FCMD_ATIME: + case FCMD_MTIME: + if ((objc < 3) || (objc > 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "name ?time?"); + return TCL_ERROR; + } + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { + return TCL_ERROR; + } + if (objc == 4) { + /* + * Need separate variable for reading longs from an object on + * 64-bit platforms. [Bug #698146] + */ + + long newTime; + + if (Tcl_GetLongFromObj(interp, objv[3], &newTime) != TCL_OK) { + return TCL_ERROR; + } + + if (index == FCMD_ATIME) { + tval.actime = newTime; + tval.modtime = buf.st_mtime; + } else { /* index == FCMD_MTIME */ + tval.actime = buf.st_atime; + tval.modtime = newTime; + } + + if (Tcl_FSUtime(objv[2], &tval) != 0) { + Tcl_AppendResult(interp, "could not set ", + (index == FCMD_ATIME ? "access" : "modification"), + " time for file \"", TclGetString(objv[2]), "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + /* + * Do another stat to ensure that the we return the new recognized + * atime - hopefully the same as the one we sent in. However, fs's + * like FAT don't even know what atime is. + */ + + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { + return TCL_ERROR; + } + } + + Tcl_SetObjResult(interp, Tcl_NewLongObj((long) + (index == FCMD_ATIME ? buf.st_atime : buf.st_mtime))); + return TCL_OK; + } + case FCMD_ATTRIBUTES: + return TclFileAttrsCmd(interp, objc, objv); + case FCMD_CHANNELS: + if ((objc < 2) || (objc > 3)) { + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + return TCL_ERROR; + } + return Tcl_GetChannelNamesEx(interp, + ((objc == 2) ? NULL : TclGetString(objv[2]))); + case FCMD_COPY: + return TclFileCopyCmd(interp, objc, objv); + case FCMD_DELETE: + return TclFileDeleteCmd(interp, objc, objv); + case FCMD_DIRNAME: { + Tcl_Obj *dirPtr; + + if (objc != 3) { + goto only3Args; + } + dirPtr = TclPathPart(interp, objv[2], TCL_PATH_DIRNAME); + if (dirPtr == NULL) { + return TCL_ERROR; + } else { + Tcl_SetObjResult(interp, dirPtr); + Tcl_DecrRefCount(dirPtr); + return TCL_OK; + } + } + case FCMD_EXECUTABLE: + if (objc != 3) { + goto only3Args; + } + return CheckAccess(interp, objv[2], X_OK); + case FCMD_EXISTS: + if (objc != 3) { + goto only3Args; + } + return CheckAccess(interp, objv[2], F_OK); + case FCMD_EXTENSION: { + Tcl_Obj *ext; + + if (objc != 3) { + goto only3Args; + } + ext = TclPathPart(interp, objv[2], TCL_PATH_EXTENSION); + if (ext != NULL) { + Tcl_SetObjResult(interp, ext); + Tcl_DecrRefCount(ext); + return TCL_OK; + } else { + return TCL_ERROR; + } + } + { + int value; + Tcl_StatBuf buf; + + case FCMD_ISDIRECTORY: + if (objc != 3) { + goto only3Args; + } + value = 0; + if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { + value = S_ISDIR(buf.st_mode); + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); + return TCL_OK; + case FCMD_ISFILE: + if (objc != 3) { + goto only3Args; + } + value = 0; + if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { + value = S_ISREG(buf.st_mode); + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); + return TCL_OK; + case FCMD_OWNED: + if (objc != 3) { + goto only3Args; + } + value = 0; + if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { + /* + * For Windows, there are no user ids associated with a file, so + * we always return 1. + */ + +#if defined(__WIN32__) + value = 1; +#else + value = (geteuid() == buf.st_uid); +#endif + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); + return TCL_OK; + } + case FCMD_JOIN: { + Tcl_Obj *resObj; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); + return TCL_ERROR; + } + resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2); + Tcl_SetObjResult(interp, resObj); + return TCL_OK; + } + case FCMD_LINK: { + Tcl_Obj *contents; + int index; + + if (objc < 3 || objc > 5) { + Tcl_WrongNumArgs(interp, 2, objv, "?-linktype? linkname ?target?"); + return TCL_ERROR; + } + + /* + * Index of the 'source' argument. + */ + + if (objc == 5) { + index = 3; + } else { + index = 2; + } + + if (objc > 3) { + int linkAction; + if (objc == 5) { + /* + * We have a '-linktype' argument. + */ + + static CONST char *linkTypes[] = { + "-symbolic", "-hard", NULL + }; + if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes, "switch", + 0, &linkAction) != TCL_OK) { + return TCL_ERROR; + } + if (linkAction == 0) { + linkAction = TCL_CREATE_SYMBOLIC_LINK; + } else { + linkAction = TCL_CREATE_HARD_LINK; + } + } else { + linkAction = TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK; + } + if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Create link from source to target. + */ + + contents = Tcl_FSLink(objv[index], objv[index+1], linkAction); + if (contents == NULL) { + /* + * We handle three common error cases specially, and for all + * other errors, we use the standard posix error message. + */ + + if (errno == EEXIST) { + Tcl_AppendResult(interp, "could not create new link \"", + TclGetString(objv[index]), + "\": that path already exists", (char *) NULL); + } else if (errno == ENOENT) { + /* + * There are two cases here: either the target doesn't + * exist, or the directory of the src doesn't exist. + */ + + int access; + Tcl_Obj *dirPtr = TclPathPart(interp, objv[index], + TCL_PATH_DIRNAME); + + if (dirPtr == NULL) { + return TCL_ERROR; + } + access = Tcl_FSAccess(dirPtr, F_OK); + Tcl_DecrRefCount(dirPtr); + if (access != 0) { + Tcl_AppendResult(interp, + "could not create new link \"", + TclGetString(objv[index]), + "\": no such file or directory", + (char *) NULL); + } else { + Tcl_AppendResult(interp, + "could not create new link \"", + TclGetString(objv[index]), "\": target \"", + TclGetString(objv[index+1]), + "\" doesn't exist", (char *) NULL); + } + } else { + Tcl_AppendResult(interp, + "could not create new link \"", + TclGetString(objv[index]), "\" pointing to \"", + TclGetString(objv[index+1]), "\": ", + Tcl_PosixError(interp), (char *) NULL); + } + return TCL_ERROR; + } + } else { + if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Read link + */ + + contents = Tcl_FSLink(objv[index], NULL, 0); + if (contents == NULL) { + Tcl_AppendResult(interp, "could not read link \"", + TclGetString(objv[index]), "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + } + Tcl_SetObjResult(interp, contents); + if (objc == 3) { + /* + * If we are reading a link, we need to free this result refCount. + * If we are creating a link, this will just be objv[index+1], and + * so we don't own it. + */ + + Tcl_DecrRefCount(contents); + } + return TCL_OK; + } + { + Tcl_StatBuf buf; + + case FCMD_LSTAT: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "name varName"); + return TCL_ERROR; + } + if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { + return TCL_ERROR; + } + return StoreStatData(interp, objv[3], &buf); + case FCMD_STAT: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "name varName"); + return TCL_ERROR; + } + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { + return TCL_ERROR; + } + return StoreStatData(interp, objv[3], &buf); + case FCMD_SIZE: + if (objc != 3) { + goto only3Args; + } + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, + Tcl_NewWideIntObj((Tcl_WideInt) buf.st_size)); + return TCL_OK; + case FCMD_TYPE: + if (objc != 3) { + goto only3Args; + } + if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj( + GetTypeFromMode((unsigned short) buf.st_mode), -1)); + return TCL_OK; + } + case FCMD_MKDIR: + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); + return TCL_ERROR; + } + return TclFileMakeDirsCmd(interp, objc, objv); + case FCMD_NATIVENAME: { + CONST char *fileName; + Tcl_DString ds; + + if (objc != 3) { + goto only3Args; + } + fileName = TclGetString(objv[2]); + fileName = Tcl_TranslateFileName(interp, fileName, &ds); + if (fileName == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(fileName, + Tcl_DStringLength(&ds))); + Tcl_DStringFree(&ds); + return TCL_OK; + } + case FCMD_NORMALIZE: { + Tcl_Obj *fileName; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "filename"); + return TCL_ERROR; + } + + fileName = Tcl_FSGetNormalizedPath(interp, objv[2]); + if (fileName == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, fileName); + return TCL_OK; + } + case FCMD_PATHTYPE: + if (objc != 3) { + goto only3Args; + } + switch (Tcl_FSGetPathType(objv[2])) { + case TCL_PATH_ABSOLUTE: + Tcl_SetObjResult(interp, Tcl_NewStringObj("absolute", -1)); + break; + case TCL_PATH_RELATIVE: + Tcl_SetObjResult(interp, Tcl_NewStringObj("relative", -1)); + break; + case TCL_PATH_VOLUME_RELATIVE: + Tcl_SetObjResult(interp, Tcl_NewStringObj("volumerelative", -1)); + break; + } + return TCL_OK; + case FCMD_READABLE: + if (objc != 3) { + goto only3Args; + } + return CheckAccess(interp, objv[2], R_OK); + case FCMD_READLINK: { + Tcl_Obj *contents; + + if (objc != 3) { + goto only3Args; + } + + if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) { + return TCL_ERROR; + } + + contents = Tcl_FSLink(objv[2], NULL, 0); + + if (contents == NULL) { + Tcl_AppendResult(interp, "could not readlink \"", + TclGetString(objv[2]), "\": ", Tcl_PosixError(interp), + (char *) NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, contents); + Tcl_DecrRefCount(contents); + return TCL_OK; + } + case FCMD_RENAME: + return TclFileRenameCmd(interp, objc, objv); + case FCMD_ROOTNAME: { + Tcl_Obj *root; + + if (objc != 3) { + goto only3Args; + } + root = TclPathPart(interp, objv[2], TCL_PATH_ROOT); + if (root != NULL) { + Tcl_SetObjResult(interp, root); + Tcl_DecrRefCount(root); + return TCL_OK; + } else { + return TCL_ERROR; + } + } + case FCMD_SEPARATOR: + if ((objc < 2) || (objc > 3)) { + Tcl_WrongNumArgs(interp, 2, objv, "?name?"); + return TCL_ERROR; + } + if (objc == 2) { + char *separator = NULL; /* lint */ + + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + separator = "/"; + break; + case TCL_PLATFORM_WINDOWS: + separator = "\\"; + break; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(separator,1)); + } else { + Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[2]); + if (separatorObj != NULL) { + Tcl_SetObjResult(interp, separatorObj); + } else { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("Unrecognised path",-1)); + return TCL_ERROR; + } + } + return TCL_OK; + case FCMD_SPLIT: { + Tcl_Obj *res; + + if (objc != 3) { + goto only3Args; + } + res = Tcl_FSSplitPath(objv[2], NULL); + if (res == NULL) { + if (interp != NULL) { + Tcl_AppendResult(interp, "could not read \"", + TclGetString(objv[2]), + "\": no such file or directory", (char *) NULL); + } + return TCL_ERROR; + } else { + Tcl_SetObjResult(interp, res); + return TCL_OK; + } + } + case FCMD_SYSTEM: { + Tcl_Obj* fsInfo; + + if (objc != 3) { + goto only3Args; + } + fsInfo = Tcl_FSFileSystemInfo(objv[2]); + if (fsInfo != NULL) { + Tcl_SetObjResult(interp, fsInfo); + return TCL_OK; + } else { + Tcl_SetObjResult(interp, Tcl_NewStringObj("Unrecognised path",-1)); + return TCL_ERROR; + } + } + case FCMD_TAIL: { + Tcl_Obj *dirPtr; + + if (objc != 3) { + goto only3Args; + } + dirPtr = TclPathPart(interp, objv[2], TCL_PATH_TAIL); + if (dirPtr == NULL) { + return TCL_ERROR; + } else { + Tcl_SetObjResult(interp, dirPtr); + Tcl_DecrRefCount(dirPtr); + return TCL_OK; + } + } + case FCMD_VOLUMES: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_FSListVolumes()); + return TCL_OK; + case FCMD_WRITABLE: + if (objc != 3) { + goto only3Args; + } + return CheckAccess(interp, objv[2], W_OK); + } + + only3Args: Tcl_WrongNumArgs(interp, 2, objv, "name"); return TCL_ERROR; } /* *--------------------------------------------------------------------------- * * CheckAccess -- * - * Utility procedure used by Tcl_FileObjCmd() to query file - * attributes available through the access() system call. + * Utility procedure used by Tcl_FileObjCmd() to query file attributes + * available through the access() system call. * * Results: - * Always returns TCL_OK. Sets interp's result to boolean true or - * false depending on whether the file has the specified attribute. + * Always returns TCL_OK. Sets interp's result to boolean true or false + * depending on whether the file has the specified attribute. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static int CheckAccess(interp, pathPtr, mode) - Tcl_Interp *interp; /* Interp for status return. Must not be + Tcl_Interp *interp; /* Interp for status return. Must not be * NULL. */ Tcl_Obj *pathPtr; /* Name of file to check. */ int mode; /* Attribute to check; passed as argument to * access(). */ { @@ -1404,28 +1397,28 @@ /* *--------------------------------------------------------------------------- * * GetStatBuf -- * - * Utility procedure used by Tcl_FileObjCmd() to query file - * attributes available through the stat() or lstat() system call. + * Utility procedure used by Tcl_FileObjCmd() to query file attributes + * available through the stat() or lstat() system call. * * Results: - * The return value is TCL_OK if the specified file exists and can - * be stat'ed, TCL_ERROR otherwise. If TCL_ERROR is returned, an - * error message is left in interp's result. If TCL_OK is returned, - * *statPtr is filled with information about the specified file. + * The return value is TCL_OK if the specified file exists and can be + * stat'ed, TCL_ERROR otherwise. If TCL_ERROR is returned, an error + * message is left in interp's result. If TCL_OK is returned, *statPtr is + * filled with information about the specified file. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static int GetStatBuf(interp, pathPtr, statProc, statPtr) - Tcl_Interp *interp; /* Interp for error return. May be NULL. */ + Tcl_Interp *interp; /* Interp for error return. May be NULL. */ Tcl_Obj *pathPtr; /* Path name to examine. */ Tcl_FSStatProc *statProc; /* Either stat() or lstat() depending on * desired behavior. */ Tcl_StatBuf *statPtr; /* Filled with info about file obtained by * calling (*statProc)(). */ @@ -1452,84 +1445,86 @@ /* *---------------------------------------------------------------------- * * StoreStatData -- * - * This is a utility procedure that breaks out the fields of a - * "stat" structure and stores them in textual form into the - * elements of an associative array. + * This is a utility procedure that breaks out the fields of a "stat" + * structure and stores them in textual form into the elements of an + * associative array. * * Results: - * Returns a standard Tcl return value. If an error occurs then - * a message is left in interp's result. + * Returns a standard Tcl return value. If an error occurs then a message + * is left in interp's result. * * Side effects: * Elements of the associative array given by "varName" are modified. * *---------------------------------------------------------------------- */ static int StoreStatData(interp, varName, statPtr) - Tcl_Interp *interp; /* Interpreter for error reports. */ - Tcl_Obj *varName; /* Name of associative array variable - * in which to store stat results. */ - Tcl_StatBuf *statPtr; /* Pointer to buffer containing - * stat data to store in varName. */ + Tcl_Interp *interp; /* Interpreter for error reports. */ + Tcl_Obj *varName; /* Name of associative array variable in which + * to store stat results. */ + Tcl_StatBuf *statPtr; /* Pointer to buffer containing stat data to + * store in varName. */ { Tcl_Obj *field = Tcl_NewObj(); Tcl_Obj *value; register unsigned short mode; /* * Assume Tcl_ObjSetVar2() does not keep a copy of the field name! * - * Might be a better idea to call Tcl_SetVar2Ex() instead so we - * don't have to make assumptions that might go wrong later. + * Might be a better idea to call Tcl_SetVar2Ex() instead so we don't have + * to make assumptions that might go wrong later. */ + #define STORE_ARY(fieldName, object) \ Tcl_SetStringObj(field, (fieldName), -1); \ value = (object); \ - if (Tcl_ObjSetVar2(interp,varName,field,value,TCL_LEAVE_ERR_MSG) == NULL) { \ + if (Tcl_ObjSetVar2(interp,varName,field,value,TCL_LEAVE_ERR_MSG)==NULL) { \ Tcl_DecrRefCount(field); \ Tcl_DecrRefCount(value); \ return TCL_ERROR; \ } Tcl_IncrRefCount(field); - STORE_ARY("dev", Tcl_NewLongObj((long)statPtr->st_dev)); + /* - * Watch out porters; the inode is meant to be an *unsigned* value, - * so the cast might fail when there isn't a real arithmentic 'long - * long' type... + * Watch out porters; the inode is meant to be an *unsigned* value, so the + * cast might fail when there isn't a real arithmentic 'long long' type... */ - STORE_ARY("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino)); - STORE_ARY("nlink", Tcl_NewLongObj((long)statPtr->st_nlink)); - STORE_ARY("uid", Tcl_NewLongObj((long)statPtr->st_uid)); - STORE_ARY("gid", Tcl_NewLongObj((long)statPtr->st_gid)); - STORE_ARY("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size)); + + STORE_ARY("dev", Tcl_NewLongObj((long)statPtr->st_dev)); + STORE_ARY("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino)); + STORE_ARY("nlink", Tcl_NewLongObj((long)statPtr->st_nlink)); + STORE_ARY("uid", Tcl_NewLongObj((long)statPtr->st_uid)); + STORE_ARY("gid", Tcl_NewLongObj((long)statPtr->st_gid)); + STORE_ARY("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size)); #ifdef HAVE_ST_BLOCKS - STORE_ARY("blocks",Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks)); + STORE_ARY("blocks", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks)); #endif - STORE_ARY("atime", Tcl_NewLongObj((long)statPtr->st_atime)); - STORE_ARY("mtime", Tcl_NewLongObj((long)statPtr->st_mtime)); - STORE_ARY("ctime", Tcl_NewLongObj((long)statPtr->st_ctime)); + STORE_ARY("atime", Tcl_NewLongObj((long)statPtr->st_atime)); + STORE_ARY("mtime", Tcl_NewLongObj((long)statPtr->st_mtime)); + STORE_ARY("ctime", Tcl_NewLongObj((long)statPtr->st_ctime)); mode = (unsigned short) statPtr->st_mode; - STORE_ARY("mode", Tcl_NewIntObj(mode)); - STORE_ARY("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1)); + STORE_ARY("mode", Tcl_NewIntObj(mode)); + STORE_ARY("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1)); #undef STORE_ARY + Tcl_DecrRefCount(field); return TCL_OK; } /* *---------------------------------------------------------------------- * * GetTypeFromMode -- * - * Given a mode word, returns a string identifying the type of a - * file. + * Given a mode word, returns a string identifying the type of a file. * * Results: * A static text string giving the file type from mode. * * Side effects: @@ -1567,89 +1562,87 @@ /* *---------------------------------------------------------------------- * * Tcl_ForObjCmd -- * - * This procedure is invoked to process the "for" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "for" Tcl command. See the + * user documentation for details on what it does. * - * With the bytecode compiler, this procedure is only called when - * a command name is computed at runtime, and is "for" or the name - * to which "for" was renamed: e.g., + * With the bytecode compiler, this procedure is only called when a + * command name is computed at runtime, and is "for" or the name to which + * "for" was renamed: e.g., * "set z for; $z {set i 0} {$i<100} {incr i} {puts $i}" * * Results: - * A standard Tcl result. + * A standard Tcl result. * * Side effects: - * See the user documentation. + * See the user documentation. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ + /* ARGSUSED */ int Tcl_ForObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int result, value; if (objc != 5) { - Tcl_WrongNumArgs(interp, 1, objv, "start test next command"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, "start test next command"); + return TCL_ERROR; } result = Tcl_EvalObjEx(interp, objv[1], 0); if (result != TCL_OK) { - if (result == TCL_ERROR) { - Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)"); - } - return result; + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)"); + } + return result; } while (1) { /* * We need to reset the result before passing it off to - * Tcl_ExprBooleanObj. Otherwise, any error message will be appended + * Tcl_ExprBooleanObj. Otherwise, any error message will be appended * to the result of the last evaluation. */ Tcl_ResetResult(interp); - result = Tcl_ExprBooleanObj(interp, objv[2], &value); - if (result != TCL_OK) { - return result; - } - if (!value) { - break; - } - result = Tcl_EvalObjEx(interp, objv[4], 0); - if ((result != TCL_OK) && (result != TCL_CONTINUE)) { - if (result == TCL_ERROR) { - char msg[32 + TCL_INTEGER_SPACE]; - - sprintf(msg, "\n (\"for\" body line %d)",interp->errorLine); - Tcl_AddErrorInfo(interp, msg); - } - break; - } - result = Tcl_EvalObjEx(interp, objv[3], 0); - if (result == TCL_BREAK) { - break; - } else if (result != TCL_OK) { - if (result == TCL_ERROR) { - Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)"); - } - return result; - } - } - if (result == TCL_BREAK) { - result = TCL_OK; - } - if (result == TCL_OK) { - Tcl_ResetResult(interp); + result = Tcl_ExprBooleanObj(interp, objv[2], &value); + if (result != TCL_OK) { + return result; + } + if (!value) { + break; + } + result = Tcl_EvalObjEx(interp, objv[4], 0); + if ((result != TCL_OK) && (result != TCL_CONTINUE)) { + if (result == TCL_ERROR) { + TclFormatToErrorInfo(interp, "\n (\"for\" body line %d)", + interp->errorLine); + } + break; + } + result = Tcl_EvalObjEx(interp, objv[3], 0); + if (result == TCL_BREAK) { + break; + } else if (result != TCL_OK) { + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)"); + } + return result; + } + } + if (result == TCL_BREAK) { + result = TCL_OK; + } + if (result == TCL_OK) { + Tcl_ResetResult(interp); } return result; } /* @@ -1656,11 +1649,11 @@ *---------------------------------------------------------------------- * * Tcl_ForeachObjCmd -- * * This object-based procedure is invoked to process the "foreach" Tcl - * command. See the user documentation for details on what it does. + * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: @@ -1683,14 +1676,14 @@ int v; /* v selects a loop variable */ int numLists; /* Count of value lists */ Tcl_Obj *bodyPtr; /* - * We copy the argument object pointers into a local array to avoid - * the problem that "objv" might become invalid. It is a pointer into - * the evaluation stack and that stack might be grown and reallocated - * if the loop body requires a large amount of stack space. + * We copy the argument object pointers into a local array to avoid the + * problem that "objv" might become invalid. It is a pointer into the + * evaluation stack and that stack might be grown and reallocated if the + * loop body requires a large amount of stack space. */ #define NUM_ARGS 9 Tcl_Obj *(argObjStorage[NUM_ARGS]); Tcl_Obj **argObjv = argObjStorage; @@ -1700,40 +1693,40 @@ int varcListArray[STATIC_LIST_SIZE]; Tcl_Obj **varvListArray[STATIC_LIST_SIZE]; int argcListArray[STATIC_LIST_SIZE]; Tcl_Obj **argvListArray[STATIC_LIST_SIZE]; - int *index = indexArray; /* Array of value list indices */ - int *varcList = varcListArray; /* # loop variables per list */ - Tcl_Obj ***varvList = varvListArray; /* Array of var name lists */ - int *argcList = argcListArray; /* Array of value list sizes */ - Tcl_Obj ***argvList = argvListArray; /* Array of value lists */ + int *index = indexArray; /* Array of value list indices */ + int *varcList = varcListArray; /* # loop variables per list */ + Tcl_Obj ***varvList = varvListArray;/* Array of var name lists */ + int *argcList = argcListArray; /* Array of value list sizes */ + Tcl_Obj ***argvList = argvListArray;/* Array of value lists */ if (objc < 4 || (objc%2 != 0)) { Tcl_WrongNumArgs(interp, 1, objv, "varList list ?varList list ...? command"); return TCL_ERROR; } /* - * Create the object argument array "argObjv". Make sure argObjv is - * large enough to hold the objc arguments. + * Create the object argument array "argObjv". Make sure argObjv is large + * enough to hold the objc arguments. */ if (objc > NUM_ARGS) { argObjv = (Tcl_Obj **) ckalloc(objc * sizeof(Tcl_Obj *)); } - for (i = 0; i < objc; i++) { + for (i=0 ; i STATIC_LIST_SIZE) { index = (int *) ckalloc(numLists * sizeof(int)); @@ -1749,17 +1742,17 @@ argcList[i] = 0; argvList[i] = (Tcl_Obj **) NULL; } /* - * Break up the value lists and variable lists into elements + * Break up the value lists and variable lists into elements. */ maxj = 0; - for (i = 0; i < numLists; i++) { + for (i=0 ; ierrorLine); - Tcl_AddObjErrorInfo(interp, msg, -1); + TclFormatToErrorInfo(interp, + "\n (\"foreach\" body line %d)", interp->errorLine); break; } else { break; } } @@ -1858,11 +1846,11 @@ } if (result == TCL_OK) { Tcl_ResetResult(interp); } - done: + done: if (numLists > STATIC_LIST_SIZE) { ckfree((char *) index); ckfree((char *) varcList); ckfree((char *) argcList); ckfree((char *) varvList); @@ -1879,12 +1867,12 @@ /* *---------------------------------------------------------------------- * * Tcl_FormatObjCmd -- * - * This procedure is invoked to process the "format" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "format" Tcl command. See + * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -1899,10 +1887,11 @@ ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { +#ifndef NEW_FORMAT char *format; /* Used to read characters from the format * string. */ int formatLen; /* The length of the format string */ char *endPtr; /* Points to the last char in format array */ char newFormat[43]; /* A new format specifier is generated here. */ @@ -1919,69 +1908,85 @@ * it's a one-word value. */ double doubleValue; /* Used to hold value to pass to sprintf if * it's a double value. */ Tcl_WideInt wideValue; /* Used to hold value to pass to sprintf if * it's a 'long long' value. */ - int whichValue; /* Indicates which of intValue, ptrValue, - * or doubleValue has the value to pass to + int whichValue; /* Indicates which of intValue, ptrValue, or + * doubleValue has the value to pass to * sprintf, according to the following * definitions: */ -# define INT_VALUE 0 -# define CHAR_VALUE 1 -# define PTR_VALUE 2 -# define DOUBLE_VALUE 3 -# define STRING_VALUE 4 -# define WIDE_VALUE 5 -# define MAX_FLOAT_SIZE 320 - +#define INT_VALUE 0 +#define CHAR_VALUE 1 +#define PTR_VALUE 2 +#define DOUBLE_VALUE 3 +#define STRING_VALUE 4 +#define WIDE_VALUE 5 +#define MAX_FLOAT_SIZE 320 + +#endif Tcl_Obj *resultPtr; /* Where result is stored finally. */ +#ifndef NEW_FORMAT char staticBuf[MAX_FLOAT_SIZE + 1]; - /* A static buffer to copy the format results + /* A static buffer to copy the format results * into */ - char *dst = staticBuf; /* The buffer that sprintf writes into each + char *dst = staticBuf; /* The buffer that sprintf writes into each * time the format processes a specifier */ int dstSize = MAX_FLOAT_SIZE; /* The size of the dst buffer */ - int noPercent; /* Special case for speed: indicates there's - * no field specifier, just a string to copy.*/ + int noPercent; /* Special case for speed: indicates there's + * no field specifier, just a string to + * copy. */ int objIndex; /* Index of argument to substitute next. */ int gotXpg = 0; /* Non-zero means that an XPG3 %n$-style * specifier has been seen. */ int gotSequential = 0; /* Non-zero means that a regular sequential * (non-XPG3) conversion specifier has been * seen. */ int useShort; /* Value to be printed is short (half word). */ char *end; /* Used to locate end of numerical fields. */ - int stringLen = 0; /* Length of string in characters rather - * than bytes. Used for %s substitution. */ + int stringLen = 0; /* Length of string in characters rather than + * bytes. Used for %s substitution. */ int gotMinus; /* Non-zero indicates that a minus flag has * been seen in the current field. */ int gotPrecision; /* Non-zero indicates that a precision has * been set for the current field. */ int gotZero; /* Non-zero indicates that a zero flag has * been seen in the current field. */ int useWide; /* Value to be printed is Tcl_WideInt. */ /* - * This procedure is a bit nasty. The goal is to use sprintf to - * do most of the dirty work. There are several problems: + * This procedure is a bit nasty. The goal is to use sprintf to do most of + * the dirty work. There are several problems: * 1. this procedure can't trust its arguments. * 2. we must be able to provide a large enough result area to hold - * whatever's generated. This is hard to estimate. - * 3. there's no way to move the arguments from objv to the call - * to sprintf in a reasonable way. This is particularly nasty - * because some of the arguments may be two-word values (doubles - * and wide-ints). - * So, what happens here is to scan the format string one % group - * at a time, making many individual calls to sprintf. + * whatever's generated. This is hard to estimate. + * 3. there's no way to move the arguments from objv to the call to + * sprintf in a reasonable way. This is particularly nasty because + * some of the arguments may be two-word values (doubles and + * wide-ints). + * So, what happens here is to scan the format string one % group at a + * time, making many individual calls to sprintf. */ +#endif if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg arg ...?"); return TCL_ERROR; } +#ifdef NEW_FORMAT + resultPtr = Tcl_NewObj(); + Tcl_IncrRefCount(resultPtr); + if (TclAppendFormattedObjs(interp, resultPtr, Tcl_GetString(objv[1]), + objc-2, objv+2) != TCL_OK) { + Tcl_DecrRefCount(resultPtr); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, resultPtr); + Tcl_DecrRefCount(resultPtr); + return TCL_OK; +#else format = Tcl_GetStringFromObj(objv[1], &formatLen); endPtr = format + formatLen; resultPtr = Tcl_NewObj(); objIndex = 2; @@ -1994,10 +1999,11 @@ whichValue = PTR_VALUE; /* * Get rid of any characters before the next field specifier. */ + if (*format != '%') { ptrValue = format; while ((*format != '%') && (format < endPtr)) { format++; } @@ -2013,24 +2019,24 @@ format += 2; goto doField; } /* - * Parse off a field specifier, compute how many characters - * will be needed to store the result, and substitute for - * "*" size specifiers. + * Parse off a field specifier, compute how many characters will be + * needed to store the result, and substitute for "*" size specifiers. */ + *newPtr = '%'; newPtr++; format++; if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */ int tmp; /* - * Check for an XPG3-style %n$ specification. Note: there - * must not be a mixture of XPG3 specs and non-XPG3 specs - * in the same format string. + * Check for an XPG3-style %n$ specification. Note: there must not + * be a mixture of XPG3 specs and non-XPG3 specs in the same + * format string. */ tmp = strtoul(format, &end, 10); /* INTL: "C" locale. */ if (*end != '$') { goto notXpg; @@ -2045,27 +2051,28 @@ goto badIndex; } goto xpgCheckDone; } - notXpg: + notXpg: gotSequential = 1; if (gotXpg) { goto mixedXPG; } - xpgCheckDone: + xpgCheckDone: while ((*format == '-') || (*format == '#') || (*format == '0') || (*format == ' ') || (*format == '+')) { if (*format == '-') { gotMinus = 1; } if (*format == '0') { /* - * This will be handled by sprintf for numbers, but we - * need to do the char/string ones ourselves + * This will be handled by sprintf for numbers, but we need to + * do the char/string ones ourselves. */ + gotZero = 1; } *newPtr = *format; newPtr++; format++; @@ -2090,13 +2097,12 @@ objIndex++; format++; } if (width > 100000) { /* - * Don't allow arbitrarily large widths: could cause core - * dump when we try to allocate a zillion bytes of memory - * below. + * Don't allow arbitrarily large widths: could cause core dump + * when we try to allocate a zillion bytes of memory below. */ width = 100000; } else if (width < 0) { width = 0; @@ -2112,11 +2118,11 @@ newPtr++; format++; gotPrecision = 1; } if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */ - precision = strtoul(format, &end, 10); /* INTL: "C" locale. */ + precision = strtoul(format, &end, 10); /* INTL: "C" locale. */ format = end; } else if (*format == '*') { if (objIndex >= objc) { goto badIndex; } @@ -2133,14 +2139,16 @@ newPtr++; } } if (*format == 'l') { useWide = 1; + /* - * Only add a 'll' modifier for integer values as it makes - * some libc's go into spasm otherwise. [Bug #702622] + * Only add a 'll' modifier for integer values as it makes some + * libc's go into spasm otherwise. [Bug #702622] */ + switch (format[1]) { case 'i': case 'd': case 'o': case 'u': @@ -2182,29 +2190,37 @@ if (Tcl_GetLongFromObj(interp, /* INTL: Tcl source. */ objv[objIndex], &intValue) != TCL_OK) { goto fmtError; } #if (LONG_MAX > INT_MAX) - /* - * Add the 'l' for long format type because we are on an - * LP64 archtecture and we are really going to pass a long - * argument to sprintf. - */ - newPtr++; - *newPtr = 0; - newPtr[-1] = newPtr[-2]; - newPtr[-2] = 'l'; + if (!useShort) { + /* + * Add the 'l' for long format type because we are on an LP64 + * archtecture and we are really going to pass a long argument + * to sprintf. + * + * Do not add this if we're going to pass in a short (i.e. if + * we've got an 'h' modifier already in the string); some libc + * implementations of sprintf() do not like it at all. [Bug + * 1154163] + */ + + newPtr++; + *newPtr = 0; + newPtr[-1] = newPtr[-2]; + newPtr[-2] = 'l'; + } #endif /* LONG_MAX > INT_MAX */ whichValue = INT_VALUE; size = 40 + precision; break; case 's': /* - * Compute the length of the string in characters and add - * any additional space required by the field width. All - * of the extra characters will be spaces, so one byte per - * character is adequate. + * Compute the length of the string in characters and add any + * additional space required by the field width. All of the extra + * characters will be spaces, so one byte per character is + * adequate. */ whichValue = STRING_VALUE; ptrValue = Tcl_GetStringFromObj(objv[objIndex], &size); stringLen = Tcl_NumUtfChars(ptrValue, size); @@ -2227,12 +2243,13 @@ case 'e': case 'E': case 'f': case 'g': case 'G': - if (Tcl_GetDoubleFromObj(interp, /* INTL: Tcl source. */ + if (Tcl_GetDoubleFromObj(interp, /* INTL: Tcl source. */ objv[objIndex], &doubleValue) != TCL_OK) { + /*TODO: figure out ACCEPT_NAN */ goto fmtError; } whichValue = DOUBLE_VALUE; size = MAX_FLOAT_SIZE; if (precision > 10) { @@ -2255,23 +2272,23 @@ } objIndex++; format++; /* - * Make sure that there's enough space to hold the formatted - * result, then format it. + * Make sure that there's enough space to hold the formatted result, + * then format it. */ - doField: + doField: if (width > size) { size = width; } if (noPercent) { Tcl_AppendToObj(resultPtr, ptrValue, size); } else { if (size > dstSize) { - if (dst != staticBuf) { + if (dst != staticBuf) { ckfree(dst); } dst = (char *) ckalloc((unsigned) (size + 1)); dstSize = size; } @@ -2322,11 +2339,11 @@ *ptr++ = padChar; pad--; } } - size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue; + size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue; if (size) { memcpy(ptr, ptrValue, (size_t) size); ptr += size; } while (pad > 0) { @@ -2348,26 +2365,35 @@ if (dst != staticBuf) { ckfree(dst); } return TCL_OK; - mixedXPG: - Tcl_SetResult(interp, + mixedXPG: + Tcl_SetResult(interp, "cannot mix \"%\" and \"%n$\" conversion specifiers", TCL_STATIC); goto fmtError; - badIndex: + badIndex: if (gotXpg) { - Tcl_SetResult(interp, + Tcl_SetResult(interp, "\"%n$\" argument index out of range", TCL_STATIC); } else { - Tcl_SetResult(interp, + Tcl_SetResult(interp, "not enough arguments for all format specifiers", TCL_STATIC); } - fmtError: + fmtError: if (dst != staticBuf) { ckfree(dst); } Tcl_DecrRefCount(resultPtr); return TCL_ERROR; +#endif } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclCmdIL.c ================================================================== --- generic/tclCmdIL.c +++ generic/tclCmdIL.c @@ -1,182 +1,169 @@ -/* +/* * tclCmdIL.c -- * - * This file contains the top-level command routines for most of - * the Tcl built-in commands whose names begin with the letters - * I through L. It contains only commands in the generic core - * (i.e. those that don't depend much upon UNIX facilities). + * This file contains the top-level command routines for most of the Tcl + * built-in commands whose names begin with the letters I through L. It + * contains only commands in the generic core (i.e. those that don't + * depend much upon UNIX facilities). * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1993-1997 Lucent Technologies. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. + * Copyright (c) 2005 Donal K. Fellows. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * 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.70 2004/12/01 23:18:49 dgp Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.70.2.9 2005/09/15 20:58:39 dgp Exp $ */ #include "tclInt.h" #include "tclRegexp.h" /* - * During execution of the "lsort" command, structures of the following - * type are used to arrange the objects being sorted into a collection - * of linked lists. + * During execution of the "lsort" command, structures of the following type + * are used to arrange the objects being sorted into a collection of linked + * lists. */ typedef struct SortElement { - Tcl_Obj *objPtr; /* Object being sorted. */ - int count; /* number of same elements in list */ - struct SortElement *nextPtr; /* Next element in the list, or - * NULL for end of list. */ + Tcl_Obj *objPtr; /* Object being sorted. */ + int count; /* number of same elements in list */ + struct SortElement *nextPtr;/* Next element in the list, or NULL for end + * of list. */ } SortElement; /* - * The "lsort" command needs to pass certain information down to the - * function that compares two list elements, and the comparison function - * needs to pass success or failure information back up to the top-level - * "lsort" command. The following structure is used to pass this - * information. + * These function pointer types are used with the "lsearch" and "lsort" + * commands to facilitate the "-nocase" option. + */ + +typedef int (*SortStrCmpFn_t) (const char *, const char *); +typedef int (*SortMemCmpFn_t) (const void *, const void *, size_t); + +/* + * The "lsort" command needs to pass certain information down to the function + * that compares two list elements, and the comparison function needs to pass + * success or failure information back up to the top-level "lsort" command. + * The following structure is used to pass this information. */ typedef struct SortInfo { int isIncreasing; /* Nonzero means sort in increasing order. */ - int sortMode; /* The sort mode. One of SORTMODE_* - * values defined below */ - Tcl_Obj *compareCmdPtr; /* The Tcl comparison command when sortMode - * is SORTMODE_COMMAND. Pre-initialized to - * hold base of command.*/ + int sortMode; /* The sort mode. One of SORTMODE_* values + * defined below */ + SortStrCmpFn_t strCmpFn; /* Basic string compare command (used with + * ASCII mode). */ + Tcl_Obj *compareCmdPtr; /* The Tcl comparison command when sortMode is + * SORTMODE_COMMAND. Pre-initialized to hold + * base of command.*/ int *indexv; /* If the -index option was specified, this * holds the indexes contained in the list * supplied as an argument to that option. - * NULL if no indexes supplied, and points - * to singleIndex field when only one + * NULL if no indexes supplied, and points to + * singleIndex field when only one * supplied. */ int indexc; /* Number of indexes in indexv array. */ int singleIndex; /* Static space for common index case. */ - Tcl_Interp *interp; /* The interpreter in which the sortis - * being done. */ - int resultCode; /* Completion code for the lsort command. - * If an error occurs during the sort this - * is changed from TCL_OK to TCL_ERROR. */ + Tcl_Interp *interp; /* The interpreter in which the sort is being + * done. */ + int resultCode; /* Completion code for the lsort command. If + * an error occurs during the sort this is + * changed from TCL_OK to TCL_ERROR. */ } SortInfo; /* * The "sortMode" field of the SortInfo structure can take on any of the * following values. */ -#define SORTMODE_ASCII 0 -#define SORTMODE_INTEGER 1 -#define SORTMODE_REAL 2 -#define SORTMODE_COMMAND 3 -#define SORTMODE_DICTIONARY 4 +#define SORTMODE_ASCII 0 +#define SORTMODE_INTEGER 1 +#define SORTMODE_REAL 2 +#define SORTMODE_COMMAND 3 +#define SORTMODE_DICTIONARY 4 /* - * Magic values for the index field of the SortInfo structure. - * Note that the index "end-1" will be translated to SORTIDX_END-1, etc. + * Magic values for the index field of the SortInfo structure. Note that the + * index "end-1" will be translated to SORTIDX_END-1, etc. */ -#define SORTIDX_NONE -1 /* Not indexed; use whole value. */ -#define SORTIDX_END -2 /* Indexed from end. */ + +#define SORTIDX_NONE -1 /* Not indexed; use whole value. */ +#define SORTIDX_END -2 /* Indexed from end. */ /* * Forward declarations for procedures defined in this file: */ -static void AppendLocals _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *listPtr, CONST char *pattern, - int includeLinks)); -static int DictionaryCompare _ANSI_ARGS_((char *left, - char *right)); -static int InfoArgsCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -static int InfoBodyCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -static int InfoCmdCountCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -static int InfoCommandsCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -static int InfoCompleteCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -static int InfoDefaultCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -static int InfoExistsCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -static int InfoFunctionsCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -static int InfoGlobalsCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -static int InfoHostnameCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -static int InfoLevelCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -static int InfoLibraryCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -static int InfoLoadedCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -static int InfoLocalsCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -static int InfoNameOfExecutableCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -static int InfoPatchLevelCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -static int InfoProcsCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -static int InfoScriptCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -static int InfoSharedlibCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -static int InfoTclVersionCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -static int InfoVarsCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -static SortElement * MergeSort _ANSI_ARGS_((SortElement *headPt, - SortInfo *infoPtr)); -static SortElement * MergeLists _ANSI_ARGS_((SortElement *leftPtr, - SortElement *rightPtr, SortInfo *infoPtr)); -static int SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr, - Tcl_Obj *second, SortInfo *infoPtr)); -static Tcl_Obj * SelectObjFromSublist _ANSI_ARGS_((Tcl_Obj *firstPtr, - SortInfo *infoPtr)); - +static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr, + CONST char *pattern, int includeLinks); +static int DictionaryCompare(char *left, char *right); +static int InfoArgsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int InfoBodyCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int InfoCmdCountCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int InfoCommandsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int InfoCompleteCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int InfoDefaultCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int InfoExistsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int InfoFunctionsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int InfoGlobalsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int InfoHostnameCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int InfoLevelCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int InfoLibraryCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int InfoLoadedCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int InfoLocalsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int InfoNameOfExecutableCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +static int InfoPatchLevelCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int InfoProcsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int InfoScriptCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int InfoSharedlibCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int InfoTclVersionCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int InfoVarsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static SortElement * MergeSort(SortElement *headPt, SortInfo *infoPtr); +static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr, + SortInfo *infoPtr); +static int SortCompare(Tcl_Obj *firstPtr, Tcl_Obj *second, + SortInfo *infoPtr); +static Tcl_Obj * SelectObjFromSublist(Tcl_Obj *firstPtr, + SortInfo *infoPtr); /* *---------------------------------------------------------------------- * * Tcl_IfObjCmd -- * - * This procedure is invoked to process the "if" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "if" Tcl command. See the + * user documentation for details on what it does. * - * With the bytecode compiler, this procedure is only called when - * a command name is computed at runtime, and is "if" or the name - * to which "if" was renamed: e.g., "set z if; $z 1 {puts foo}" + * With the bytecode compiler, this procedure is only called when a + * command name is computed at runtime, and is "if" or the name to which + * "if" was renamed: e.g., "set z if; $z 1 {puts foo}" * * Results: * A standard Tcl result. * * Side effects: @@ -191,21 +178,21 @@ ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int thenScriptIndex = 0; /* then script to be evaled after syntax check */ + int thenScriptIndex = 0; /* "then" script to be evaled after + * syntax check */ int i, result, value; char *clause; i = 1; while (1) { /* - * At this point in the loop, objv and objc refer to an expression - * to test, either for the main expression or an expression - * following an "elseif". The arguments after the expression must - * be "then" (optional) and a script to execute if the expression is - * true. + * At this point in the loop, objv and objc refer to an expression to + * test, either for the main expression or an expression following an + * "elseif". The arguments after the expression must be "then" + * (optional) and a script to execute if the expression is true. */ if (i >= objc) { clause = TclGetString(objv[i-1]); Tcl_AppendResult(interp, "wrong # args: no expression after \"", @@ -237,12 +224,12 @@ thenScriptIndex = i; value = 0; } /* - * The expression evaluated to false. Skip the command, then - * see if there is an "else" or "elseif" clause. + * The expression evaluated to false. Skip the command, then see if + * there is an "else" or "elseif" clause. */ i++; if (i >= objc) { if (thenScriptIndex) { @@ -257,13 +244,13 @@ } break; } /* - * Couldn't find a "then" or "elseif" clause to execute. Check now - * for an "else" clause. We know that there's at least one more - * argument when we get here. + * Couldn't find a "then" or "elseif" clause to execute. Check now for an + * "else" clause. We know that there's at least one more argument when we + * get here. */ if (strcmp(clause, "else") == 0) { i++; if (i >= objc) { @@ -288,16 +275,16 @@ /* *---------------------------------------------------------------------- * * Tcl_IncrObjCmd -- * - * This procedure is invoked to process the "incr" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "incr" Tcl command. See the + * user documentation for details on what it does. * - * With the bytecode compiler, this procedure is only called when - * a command name is computed at runtime, and is "incr" or the name - * to which "incr" was renamed: e.g., "set z incr; $z i -1" + * With the bytecode compiler, this procedure is only called when a + * command name is computed at runtime, and is "incr" or the name to + * which "incr" was renamed: e.g., "set z incr; $z i -1" * * Results: * A standard Tcl result. * * Side effects: @@ -312,30 +299,34 @@ ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ 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. */ if (objc == 3) { /* - * Need to be a bit cautious to ensure that [expr]-like rules - * are enforced for interpretation of wide integers, despite - * the fact that the underlying API itself is a 'long' only one. + * Need to be a bit cautious to ensure that [expr]-like rules are + * enforced for interpretation of wide integers, despite the fact that + * the underlying API itself is a 'long' only one. */ + if (objv[2]->typePtr == &tclIntType) { incrAmount = objv[2]->internalRep.longValue; isWide = 0; } else if (objv[2]->typePtr == &tclWideIntType) { wideIncrAmount = objv[2]->internalRep.wideValue; @@ -367,10 +358,22 @@ wideIncrAmount, TCL_LEAVE_ERR_MSG); } else { 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; } /* @@ -377,20 +380,20 @@ * Set the interpreter's object result to refer to the variable's new * value object. */ Tcl_SetObjResult(interp, newValuePtr); - return TCL_OK; + return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_InfoObjCmd -- * - * This procedure is invoked to process the "info" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "info" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -505,21 +508,21 @@ /* *---------------------------------------------------------------------- * * InfoArgsCmd -- * - * Called to implement the "info args" command that returns the - * argument list for a procedure. Handles the following syntax: + * Called to implement the "info args" command that returns the argument + * list for a procedure. Handles the following syntax: * * info args procName * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -567,21 +570,21 @@ /* *---------------------------------------------------------------------- * * InfoBodyCmd -- * - * Called to implement the "info body" command that returns the body - * for a procedure. Handles the following syntax: + * Called to implement the "info body" command that returns the body for + * a procedure. Handles the following syntax: * * info body procName * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -607,25 +610,26 @@ Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", (char *) NULL); return TCL_ERROR; } - /* + /* * Here we used to return procPtr->bodyPtr, except when the body was - * bytecompiled - in that case, the return was a copy of the body's - * string rep. In order to better isolate the implementation details - * of the compiler/engine subsystem, we now always return a copy of - * the string rep. It is important to return a copy so that later - * manipulations of the object do not invalidate the internal rep. + * bytecompiled - in that case, the return was a copy of the body's string + * rep. In order to better isolate the implementation details of the + * compiler/engine subsystem, we now always return a copy of the string + * rep. It is important to return a copy so that later manipulations of + * the object do not invalidate the internal rep. */ bodyPtr = procPtr->bodyPtr; if (bodyPtr->bytes == NULL) { /* - * The string rep might not be valid if the procedure has - * never been run before. [Bug #545644] + * The string rep might not be valid if the procedure has never been + * run before. [Bug #545644] */ + (void) Tcl_GetString(bodyPtr); } resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length); Tcl_SetObjResult(interp, resultPtr); @@ -635,22 +639,22 @@ /* *---------------------------------------------------------------------- * * InfoCmdCountCmd -- * - * Called to implement the "info cmdcount" command that returns the - * number of commands that have been executed. Handles the following - * syntax: + * Called to implement the "info cmdcount" command that returns the + * number of commands that have been executed. Handles the following + * syntax: * * info cmdcount * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -674,25 +678,25 @@ /* *---------------------------------------------------------------------- * * InfoCommandsCmd -- * - * Called to implement the "info commands" command that returns the - * list of commands in the interpreter that match an optional pattern. - * The pattern, if any, consists of an optional sequence of namespace - * names separated by "::" qualifiers, which is followed by a - * glob-style pattern that restricts which commands are returned. - * Handles the following syntax: + * Called to implement the "info commands" command that returns the list + * of commands in the interpreter that match an optional pattern. The + * pattern, if any, consists of an optional sequence of namespace names + * separated by "::" qualifiers, which is followed by a glob-style + * pattern that restricts which commands are returned. Handles the + * following syntax: * * info commands ?pattern? * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -706,31 +710,32 @@ CONST char *simplePattern; register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; Namespace *nsPtr; Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); - Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); Tcl_Obj *listPtr, *elemObjPtr; - int specificNsInPattern = 0; /* Init. to avoid compiler warning. */ + int specificNsInPattern = 0;/* Init. to avoid compiler warning. */ Tcl_Command cmd; + int i; /* - * Get the pattern and find the "effective namespace" in which to - * list commands. + * Get the pattern and find the "effective namespace" in which to list + * commands. */ if (objc == 2) { simplePattern = NULL; nsPtr = currNsPtr; specificNsInPattern = 0; } else if (objc == 3) { /* * From the pattern, get the effective namespace and the simple - * pattern (no namespace qualifiers or ::'s) at the end. If an - * error was found while parsing the pattern, return it. Otherwise, - * if the namespace wasn't found, just leave nsPtr NULL: we will - * return an empty list since no commands there can be found. + * pattern (no namespace qualifiers or ::'s) at the end. If an error + * was found while parsing the pattern, return it. Otherwise, if the + * namespace wasn't found, just leave nsPtr NULL: we will return an + * empty list since no commands there can be found. */ Namespace *dummy1NsPtr, *dummy2NsPtr; pattern = TclGetString(objv[2]); @@ -752,24 +757,24 @@ if (nsPtr == NULL) { return TCL_OK; } /* - * Scan through the effective namespace's command table and create a - * list with all commands that match the pattern. If a specific - * namespace was requested in the pattern, qualify the command names - * with the namespace name. + * Scan through the effective namespace's command table and create a list + * with all commands that match the pattern. If a specific namespace was + * requested in the pattern, qualify the command names with the namespace + * name. */ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) { /* - * Special case for when the pattern doesn't include any of - * glob's special characters. This lets us avoid scans of any - * hash tables. + * Special case for when the pattern doesn't include any of glob's + * special characters. This lets us avoid scans of any hash tables. */ + entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); if (entryPtr != NULL) { if (specificNsInPattern) { cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); elemObjPtr = Tcl_NewObj(); @@ -777,20 +782,47 @@ } else { cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); elemObjPtr = Tcl_NewStringObj(cmdName, -1); } Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); - } else if ((nsPtr != globalNsPtr) && !specificNsInPattern) { - entryPtr = Tcl_FindHashEntry(&globalNsPtr->cmdTable, - simplePattern); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; + } + if ((nsPtr != globalNsPtr) && !specificNsInPattern) { + Tcl_HashTable *tablePtr = NULL; /* Quell warning */ + + for (i=0 ; icommandPathLength ; i++) { + Namespace *pathNsPtr = nsPtr->commandPathArray[i].nsPtr; + + if (pathNsPtr == NULL) { + continue; + } + tablePtr = &pathNsPtr->cmdTable; + entryPtr = Tcl_FindHashEntry(tablePtr, simplePattern); + if (entryPtr != NULL) { + break; + } + } + if (entryPtr == NULL) { + tablePtr = &globalNsPtr->cmdTable; + entryPtr = Tcl_FindHashEntry(tablePtr, simplePattern); + } if (entryPtr != NULL) { - cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); + cmdName = Tcl_GetHashKey(tablePtr, entryPtr); Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(cmdName, -1)); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; } } - } else { + } else if (nsPtr->commandPathLength == 0 || specificNsInPattern) { + /* + * The pattern is non-trivial, but either there is no explicit path or + * there is an explicit namespace in the pattern. In both cases, the + * old matching scheme is perfect. + */ + entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); while (entryPtr != NULL) { cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(cmdName, simplePattern)) { @@ -806,14 +838,14 @@ entryPtr = Tcl_NextHashEntry(&search); } /* * If the effective namespace isn't the global :: namespace, and a - * specific namespace wasn't requested in the pattern, then add in - * all global :: commands that match the simple pattern. Of course, - * we add in only those commands that aren't hidden by a command in - * the effective namespace. + * specific namespace wasn't requested in the pattern, then add in all + * global :: commands that match the simple pattern. Of course, we add + * in only those commands that aren't hidden by a command in the + * effective namespace. */ if ((nsPtr != globalNsPtr) && !specificNsInPattern) { entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); while (entryPtr != NULL) { @@ -826,10 +858,99 @@ } } entryPtr = Tcl_NextHashEntry(&search); } } + } else { + /* + * The pattern is non-trivial (can match more than one command name), + * there is an explicit path, and there is no explicit namespace in + * the pattern. This means that we have to traverse the path to + * discover all the commands defined. + */ + + Tcl_HashTable addedCommandsTable; + int isNew; + int foundGlobal = (nsPtr == globalNsPtr); + + /* + * We keep a hash of the objects already added to the result list. + */ + + Tcl_InitObjHashTable(&addedCommandsTable); + + entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + while (entryPtr != NULL) { + cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(cmdName, simplePattern)) { + elemObjPtr = Tcl_NewStringObj(cmdName, -1); + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); + (void) Tcl_CreateHashEntry(&addedCommandsTable, + (char *)elemObjPtr, &isNew); + } + entryPtr = Tcl_NextHashEntry(&search); + } + + /* + * Search the path next. + */ + + for (i=0 ; icommandPathLength ; i++) { + Namespace *pathNsPtr = nsPtr->commandPathArray[i].nsPtr; + + if (pathNsPtr == NULL) { + continue; + } + if (pathNsPtr == globalNsPtr) { + foundGlobal = 1; + } + entryPtr = Tcl_FirstHashEntry(&pathNsPtr->cmdTable, &search); + while (entryPtr != NULL) { + cmdName = Tcl_GetHashKey(&pathNsPtr->cmdTable, entryPtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(cmdName, simplePattern)) { + elemObjPtr = Tcl_NewStringObj(cmdName, -1); + (void) Tcl_CreateHashEntry(&addedCommandsTable, + (char *) elemObjPtr, &isNew); + if (isNew) { + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); + } else { + TclDecrRefCount(elemObjPtr); + } + } + entryPtr = Tcl_NextHashEntry(&search); + } + } + + /* + * If the effective namespace isn't the global :: namespace, and a + * specific namespace wasn't requested in the pattern, then add in all + * global :: commands that match the simple pattern. Of course, we add + * in only those commands that aren't hidden by a command in the + * effective namespace. + */ + + if (!foundGlobal) { + entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); + while (entryPtr != NULL) { + cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(cmdName, simplePattern)) { + elemObjPtr = Tcl_NewStringObj(cmdName, -1); + if (Tcl_FindHashEntry(&addedCommandsTable, + (char *) elemObjPtr) == NULL) { + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); + } else { + TclDecrRefCount(elemObjPtr); + } + } + entryPtr = Tcl_NextHashEntry(&search); + } + } + + Tcl_DeleteHashTable(&addedCommandsTable); } Tcl_SetObjResult(interp, listPtr); return TCL_OK; } @@ -837,22 +958,22 @@ /* *---------------------------------------------------------------------- * * InfoCompleteCmd -- * - * Called to implement the "info complete" command that determines - * whether a string is a complete Tcl command. Handles the following - * syntax: + * Called to implement the "info complete" command that determines + * whether a string is a complete Tcl command. Handles the following + * syntax: * * info complete command * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -879,22 +1000,21 @@ /* *---------------------------------------------------------------------- * * InfoDefaultCmd -- * - * Called to implement the "info default" command that returns the - * default value for a procedure argument. Handles the following - * syntax: + * Called to implement the "info default" command that returns the + * default value for a procedure argument. Handles the following syntax: * * info default procName arg varName * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -963,21 +1083,21 @@ /* *---------------------------------------------------------------------- * * InfoExistsCmd -- * - * Called to implement the "info exists" command that determines - * whether a variable exists. Handles the following syntax: + * Called to implement the "info exists" command that determines whether + * a variable exists. Handles the following syntax: * * info exists varName * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -1008,22 +1128,22 @@ /* *---------------------------------------------------------------------- * * InfoFunctionsCmd -- * - * Called to implement the "info functions" command that returns the - * list of math functions matching an optional pattern. Handles the - * following syntax: + * Called to implement the "info functions" command that returns the list + * of math functions matching an optional pattern. Handles the following + * syntax: * * info functions ?pattern? * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -1056,22 +1176,22 @@ /* *---------------------------------------------------------------------- * * InfoGlobalsCmd -- * - * Called to implement the "info globals" command that returns the list - * of global variables matching an optional pattern. Handles the - * following syntax: + * Called to implement the "info globals" command that returns the list + * of global variables matching an optional pattern. Handles the + * following syntax: * * info globals ?pattern? * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -1093,10 +1213,11 @@ } else if (objc == 3) { pattern = TclGetString(objv[2]); /* * Strip leading global-namespace qualifiers. [Bug 1057461] */ + if (pattern[0] == ':' && pattern[1] == ':') { while (*pattern == ':') { pattern++; } } @@ -1104,20 +1225,23 @@ Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); return TCL_ERROR; } /* - * Scan through the global :: namespace's variable table and create a - * list of all global variables that match the pattern. + * Scan through the global :: namespace's variable table and create a list + * of all global variables that match the pattern. */ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); if (pattern != NULL && TclMatchIsTrivial(pattern)) { entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable, pattern); if (entryPtr != NULL) { - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(pattern, -1)); + varPtr = (Var *) Tcl_GetHashValue(entryPtr); + if (!TclIsVarUndefined(varPtr)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(pattern, -1)); + } } } else { for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search); entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) { @@ -1139,21 +1263,21 @@ /* *---------------------------------------------------------------------- * * InfoHostnameCmd -- * - * Called to implement the "info hostname" command that returns the - * host name. Handles the following syntax: + * Called to implement the "info hostname" command that returns the host + * name. Handles the following syntax: * * info hostname * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -1183,21 +1307,21 @@ /* *---------------------------------------------------------------------- * * InfoLevelCmd -- * - * Called to implement the "info level" command that returns - * information about the call stack. Handles the following syntax: + * Called to implement the "info level" command that returns information + * about the call stack. Handles the following syntax: * * info level ?number? * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -1254,22 +1378,22 @@ /* *---------------------------------------------------------------------- * * InfoLibraryCmd -- * - * Called to implement the "info library" command that returns the - * library directory for the Tcl installation. Handles the following - * syntax: + * Called to implement the "info library" command that returns the + * library directory for the Tcl installation. Handles the following + * syntax: * * info library * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -1299,22 +1423,22 @@ /* *---------------------------------------------------------------------- * * InfoLoadedCmd -- * - * Called to implement the "info loaded" command that returns the - * packages that have been loaded into an interpreter. Handles the - * following syntax: + * Called to implement the "info loaded" command that returns the + * packages that have been loaded into an interpreter. Handles the + * following syntax: * * info loaded ?interp? * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -1344,22 +1468,22 @@ /* *---------------------------------------------------------------------- * * InfoLocalsCmd -- * - * Called to implement the "info locals" command to return a list of - * local variables that match an optional pattern. Handles the - * following syntax: + * Called to implement the "info locals" command to return a list of + * local variables that match an optional pattern. Handles the following + * syntax: * * info locals ?pattern? * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -1380,11 +1504,12 @@ } else { Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); return TCL_ERROR; } - if (iPtr->varFramePtr == NULL || !iPtr->varFramePtr->isProcCallFrame) { + if (iPtr->varFramePtr == NULL || + !(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC )) { return TCL_OK; } /* * Return a list containing names of first the compiled locals (i.e. the @@ -1401,12 +1526,12 @@ /* *---------------------------------------------------------------------- * * AppendLocals -- * - * Append the local variables for the current frame to the - * specified list object. + * Append the local variables for the current frame to the specified list + * object. * * Results: * None. * * Side effects: @@ -1451,23 +1576,49 @@ } varPtr++; localPtr = localPtr->nextPtr; } - if (localVarTablePtr != NULL) { - for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search); - entryPtr != NULL; - entryPtr = Tcl_NextHashEntry(&search)) { + /* + * Do nothing if no local variables. + */ + + if (localVarTablePtr == NULL) { + return; + } + + /* + * Check for the simple and fast case. + */ + + if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { + entryPtr = Tcl_FindHashEntry(localVarTablePtr, pattern); + if (entryPtr != NULL) { varPtr = (Var *) Tcl_GetHashValue(entryPtr); if (!TclIsVarUndefined(varPtr) && (includeLinks || !TclIsVarLink(varPtr))) { - varName = Tcl_GetHashKey(localVarTablePtr, entryPtr); - if ((pattern == NULL) - || Tcl_StringMatch(varName, pattern)) { - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(varName, -1)); - } + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(pattern,-1)); + } + } + return; + } + + /* + * Scan over and process all local variables. + */ + + for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + varPtr = (Var *) Tcl_GetHashValue(entryPtr); + if (!TclIsVarUndefined(varPtr) + && (includeLinks || !TclIsVarLink(varPtr))) { + varName = Tcl_GetHashKey(localVarTablePtr, entryPtr); + if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(varName, -1)); } } } } @@ -1474,22 +1625,22 @@ /* *---------------------------------------------------------------------- * * InfoNameOfExecutableCmd -- * - * Called to implement the "info nameofexecutable" command that returns - * the name of the binary file running this application. Handles the - * following syntax: + * Called to implement the "info nameofexecutable" command that returns + * the name of the binary file running this application. Handles the + * following syntax: * * info nameofexecutable * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -1510,22 +1661,22 @@ /* *---------------------------------------------------------------------- * * InfoPatchLevelCmd -- * - * Called to implement the "info patchlevel" command that returns the - * default value for an argument to a procedure. Handles the following - * syntax: + * Called to implement the "info patchlevel" command that returns the + * default value for an argument to a procedure. Handles the following + * syntax: * * info patchlevel * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -1554,25 +1705,25 @@ /* *---------------------------------------------------------------------- * * InfoProcsCmd -- * - * Called to implement the "info procs" command that returns the - * list of procedures in the interpreter that match an optional pattern. - * The pattern, if any, consists of an optional sequence of namespace - * names separated by "::" qualifiers, which is followed by a - * glob-style pattern that restricts which commands are returned. - * Handles the following syntax: + * Called to implement the "info procs" command that returns the list of + * procedures in the interpreter that match an optional pattern. The + * pattern, if any, consists of an optional sequence of namespace names + * separated by "::" qualifiers, which is followed by a glob-style + * pattern that restricts which commands are returned. Handles the + * following syntax: * * info procs ?pattern? * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -1586,33 +1737,33 @@ CONST char *simplePattern; Namespace *nsPtr; #ifdef INFO_PROCS_SEARCH_GLOBAL_NS Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); #endif - Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); Tcl_Obj *listPtr, *elemObjPtr; - int specificNsInPattern = 0; /* Init. to avoid compiler warning. */ + int specificNsInPattern = 0;/* Init. to avoid compiler warning. */ register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; Command *cmdPtr, *realCmdPtr; /* - * Get the pattern and find the "effective namespace" in which to - * list procs. + * Get the pattern and find the "effective namespace" in which to list + * procs. */ if (objc == 2) { simplePattern = NULL; nsPtr = currNsPtr; specificNsInPattern = 0; } else if (objc == 3) { /* * From the pattern, get the effective namespace and the simple - * pattern (no namespace qualifiers or ::'s) at the end. If an - * error was found while parsing the pattern, return it. Otherwise, - * if the namespace wasn't found, just leave nsPtr NULL: we will - * return an empty list since no commands there can be found. + * pattern (no namespace qualifiers or ::'s) at the end. If an error + * was found while parsing the pattern, return it. Otherwise, if the + * namespace wasn't found, just leave nsPtr NULL: we will return an + * empty list since no commands there can be found. */ Namespace *dummy1NsPtr, *dummy2NsPtr; pattern = TclGetString(objv[2]); @@ -1631,14 +1782,14 @@ if (nsPtr == NULL) { return TCL_OK; } /* - * Scan through the effective namespace's command table and create a - * list with all procs that match the pattern. If a specific - * namespace was requested in the pattern, qualify the command names - * with the namespace name. + * Scan through the effective namespace's command table and create a list + * with all procs that match the pattern. If a specific namespace was + * requested in the pattern, qualify the command names with the namespace + * name. */ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); #ifndef INFO_PROCS_SEARCH_GLOBAL_NS if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) { @@ -1651,11 +1802,11 @@ TclGetOriginalCommand((Tcl_Command) cmdPtr); if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) { goto simpleProcOK; } } else { - simpleProcOK: + simpleProcOK: if (specificNsInPattern) { elemObjPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, elemObjPtr); } else { @@ -1679,11 +1830,11 @@ TclGetOriginalCommand((Tcl_Command) cmdPtr); if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) { goto procOK; } } else { - procOK: + procOK: if (specificNsInPattern) { elemObjPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, elemObjPtr); } else { @@ -1695,24 +1846,25 @@ entryPtr = Tcl_NextHashEntry(&search); } /* * If the effective namespace isn't the global :: namespace, and a - * specific namespace wasn't requested in the pattern, then add in - * all global :: procs that match the simple pattern. Of course, - * we add in only those procs that aren't hidden by a proc in - * the effective namespace. + * specific namespace wasn't requested in the pattern, then add in all + * global :: procs that match the simple pattern. Of course, we add in + * only those procs that aren't hidden by a proc in the effective + * namespace. */ #ifdef INFO_PROCS_SEARCH_GLOBAL_NS /* - * If "info procs" worked like "info commands", returning the - * commands also seen in the global namespace, then you would - * include this code. As this could break backwards compatibilty - * with 8.0-8.2, we decided not to "fix" it in 8.3, leaving the - * behavior slightly different. + * If "info procs" worked like "info commands", returning the commands + * also seen in the global namespace, then you would include this + * code. As this could break backwards compatibilty with 8.0-8.2, we + * decided not to "fix" it in 8.3, leaving the behavior slightly + * different. */ + if ((nsPtr != globalNsPtr) && !specificNsInPattern) { entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); while (entryPtr != NULL) { cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) @@ -1742,25 +1894,24 @@ /* *---------------------------------------------------------------------- * * InfoScriptCmd -- * - * Called to implement the "info script" command that returns the - * script file that is currently being evaluated. Handles the - * following syntax: + * Called to implement the "info script" command that returns the script + * file that is currently being evaluated. Handles the following syntax: * * info script ?newName? * * If newName is specified, it will set that as the internal name. * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. It may change the - * internal script filename. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. It may change the internal + * script filename. * *---------------------------------------------------------------------- */ static int @@ -1792,22 +1943,22 @@ /* *---------------------------------------------------------------------- * * InfoSharedlibCmd -- * - * Called to implement the "info sharedlibextension" command that - * returns the file extension used for shared libraries. Handles the - * following syntax: + * Called to implement the "info sharedlibextension" command that returns + * the file extension used for shared libraries. Handles the following + * syntax: * * info sharedlibextension * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -1831,21 +1982,21 @@ /* *---------------------------------------------------------------------- * * InfoTclVersionCmd -- * - * Called to implement the "info tclversion" command that returns the - * version number for this Tcl library. Handles the following syntax: + * Called to implement the "info tclversion" command that returns the + * version number for this Tcl library. Handles the following syntax: * * info tclversion * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -1861,11 +2012,11 @@ Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } version = Tcl_GetVar2Ex(interp, "tcl_version", NULL, - (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); + (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); if (version != NULL) { Tcl_SetObjResult(interp, version); return TCL_OK; } return TCL_ERROR; @@ -1874,25 +2025,25 @@ /* *---------------------------------------------------------------------- * * InfoVarsCmd -- * - * Called to implement the "info vars" command that returns the - * list of variables in the interpreter that match an optional pattern. - * The pattern, if any, consists of an optional sequence of namespace - * names separated by "::" qualifiers, which is followed by a - * glob-style pattern that restricts which variables are returned. - * Handles the following syntax: + * Called to implement the "info vars" command that returns the list of + * variables in the interpreter that match an optional pattern. The + * pattern, if any, consists of an optional sequence of namespace names + * separated by "::" qualifiers, which is followed by a glob-style + * pattern that restricts which variables are returned. Handles the + * following syntax: * * info vars ?pattern? * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -1908,41 +2059,41 @@ register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; Var *varPtr; Namespace *nsPtr; Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); - Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); Tcl_Obj *listPtr, *elemObjPtr; - int specificNsInPattern = 0; /* Init. to avoid compiler warning. */ + int specificNsInPattern = 0;/* Init. to avoid compiler warning. */ /* - * Get the pattern and find the "effective namespace" in which to - * list variables. We only use this effective namespace if there's - * no active Tcl procedure frame. + * Get the pattern and find the "effective namespace" in which to list + * variables. We only use this effective namespace if there's no active + * Tcl procedure frame. */ if (objc == 2) { simplePattern = NULL; nsPtr = currNsPtr; specificNsInPattern = 0; } else if (objc == 3) { /* * From the pattern, get the effective namespace and the simple - * pattern (no namespace qualifiers or ::'s) at the end. If an - * error was found while parsing the pattern, return it. Otherwise, - * if the namespace wasn't found, just leave nsPtr NULL: we will - * return an empty list since no variables there can be found. + * pattern (no namespace qualifiers or ::'s) at the end. If an error + * was found while parsing the pattern, return it. Otherwise, if the + * namespace wasn't found, just leave nsPtr NULL: we will return an + * empty list since no variables there can be found. */ Namespace *dummy1NsPtr, *dummy2NsPtr; pattern = TclGetString(objv[2]); TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); - if (nsPtr != NULL) { /* we successfully found the pattern's ns */ + if (nsPtr != NULL) { /* We successfully found the pattern's ns */ specificNsInPattern = (strcmp(simplePattern, pattern) != 0); } } else { Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); return TCL_ERROR; @@ -1957,23 +2108,22 @@ } listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); if ((iPtr->varFramePtr == NULL) - || !iPtr->varFramePtr->isProcCallFrame + || !(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC) || specificNsInPattern) { /* - * There is no frame pointer, the frame pointer was pushed only - * to activate a namespace, or we are in a procedure call frame - * but a specific namespace was specified. Create a list containing - * only the variables in the effective namespace's variable table. + * There is no frame pointer, the frame pointer was pushed only to + * activate a namespace, or we are in a procedure call frame but a + * specific namespace was specified. Create a list containing only the + * variables in the effective namespace's variable table. */ if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) { /* - * If we can just do hash lookups, that simplifies things - * a lot. + * If we can just do hash lookups, that simplifies things a lot. */ entryPtr = Tcl_FindHashEntry(&nsPtr->varTable, simplePattern); if (entryPtr != NULL) { varPtr = (Var *) Tcl_GetHashValue(entryPtr); @@ -2013,11 +2163,12 @@ varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(varName, simplePattern)) { if (specificNsInPattern) { elemObjPtr = Tcl_NewObj(); - Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, elemObjPtr); + Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, + elemObjPtr); } else { elemObjPtr = Tcl_NewStringObj(varName, -1); } Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); } @@ -2024,16 +2175,15 @@ } entryPtr = Tcl_NextHashEntry(&search); } /* - * If the effective namespace isn't the global :: - * namespace, and a specific namespace wasn't requested in - * the pattern (i.e., the pattern only specifies variable - * names), then add in all global :: variables that match - * the simple pattern. Of course, add in only those - * variables that aren't hidden by a variable in the + * If the effective namespace isn't the global :: namespace, and a + * specific namespace wasn't requested in the pattern (i.e., the + * pattern only specifies variable names), then add in all global + * :: variables that match the simple pattern. Of course, add in + * only those variables that aren't hidden by a variable in the * effective namespace. */ if ((nsPtr != globalNsPtr) && !specificNsInPattern) { entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search); @@ -2067,12 +2217,12 @@ /* *---------------------------------------------------------------------- * * Tcl_JoinObjCmd -- * - * This procedure is invoked to process the "join" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "join" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: @@ -2103,12 +2253,12 @@ Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?"); return TCL_ERROR; } /* - * Make sure the list argument is a list object and get its length and - * a pointer to its array of element pointers. + * Make sure the list argument is a list object and get its length and a + * pointer to its array of element pointers. */ result = Tcl_ListObjGetElements(interp, objv[1], &listLen, &elemPtrs); if (result != TCL_OK) { return result; @@ -2174,13 +2324,14 @@ * First assign values out of the list to variables. */ for (i=0 ; i+2 objc-2) { /* - * OK, there were left-overs. Make a list of them and slap - * that back in the interpreter result. + * OK, there were left-overs. Make a list of them and slap that back + * in the interpreter result. */ + Tcl_SetObjResult(interp, Tcl_NewListObj(listObjc - objc + 2, listObjv + objc - 2)); } return TCL_OK; @@ -2267,24 +2419,24 @@ Tcl_WrongNumArgs(interp, 1, objv, "list ?index...?"); return TCL_ERROR; } /* - * If objc==3, then objv[2] may be either a single index or a list - * of indices: go to TclLindexList to determine which. - * If objc>=4, or objc==2, then objv[2 .. objc-2] are all single - * indices and processed as such in TclLindexFlat. + * If objc==3, then objv[2] may be either a single index or a list of + * indices: go to TclLindexList to determine which. If objc>=4, or + * objc==2, then objv[2 .. objc-2] are all single indices and processed as + * such in TclLindexFlat. */ if (objc == 3) { elemPtr = TclLindexList(interp, objv[1], objv[2]); } else { elemPtr = TclLindexFlat(interp, objv[1], objc-2, objv+2); } /* - * Set the interpreter's object result to the last element extracted + * Set the interpreter's object result to the last element extracted. */ if (elemPtr == NULL) { return TCL_ERROR; } else { @@ -2300,24 +2452,24 @@ * TclLindexList -- * * This procedure handles the 'lindex' command when objc==3. * * Results: - * Returns a pointer to the object extracted, or NULL if an - * error occurred. + * Returns a pointer to the object extracted, or NULL if an error + * occurred. * * Side effects: * None. * * Notes: - * If objv[1] can be parsed as a list, TclLindexList handles - * extraction of the desired element locally. Otherwise, it - * invokes TclLindexFlat to treat objv[1] as a scalar. + * If objv[1] can be parsed as a list, TclLindexList handles extraction + * of the desired element locally. Otherwise, it invokes TclLindexFlat to + * treat objv[1] as a scalar. * - * The reference count of the returned object includes one - * reference corresponding to the pointer returned. Thus, the - * calling code will usually do something like: + * The reference count of the returned object includes one reference + * corresponding to the pointer returned. Thus, the calling code will + * usually do something like: * Tcl_SetObjResult(interp, result); * Tcl_DecrRefCount(result); * *---------------------------------------------------------------------- */ @@ -2329,52 +2481,52 @@ Tcl_Obj* argPtr; /* Index or index list */ { Tcl_Obj **elemPtrs; /* Elements of the list being manipulated. */ int listLen; /* Length of the list being manipulated. */ - int index; /* Index into the list */ - int result; /* Result returned from a Tcl library call */ - int i; /* Current index number */ - Tcl_Obj **indices; /* Array of list indices */ - int indexCount; /* Size of the array of list indices */ - Tcl_Obj *oldListPtr; /* Temp location to preserve the list - * pointer when replacing it with a sublist */ + int index; /* Index into the list. */ + int result; /* Result returned from a Tcl library call. */ + int i; /* Current index number. */ + Tcl_Obj **indices; /* Array of list indices. */ + int indexCount; /* Size of the array of list indices. */ + Tcl_Obj *oldListPtr; /* Temp location to preserve the list pointer + * when replacing it with a sublist. */ /* - * Determine whether argPtr designates a list or a single index. - * We have to be careful about the order of the checks to avoid - * repeated shimmering; see TIP#22 and TIP#33 for the details. + * Determine whether argPtr designates a list or a single index. We have + * to be careful about the order of the checks to avoid repeated + * shimmering; see TIP#22 and TIP#33 for the details. */ - if (argPtr->typePtr != &tclListType + if (argPtr->typePtr != &tclListType && TclGetIntForIndex(NULL , argPtr, 0, &index) == TCL_OK) { /* * argPtr designates a single index. */ return TclLindexFlat(interp, listPtr, 1, &argPtr); + } - } if (Tcl_ListObjGetElements(NULL, argPtr, &indexCount, &indices) != TCL_OK){ /* * argPtr designates something that is neither an index nor a - * well-formed list. Report the error via TclLindexFlat. + * well-formed list. Report the error via TclLindexFlat. */ - return TclLindexFlat( interp, listPtr, 1, &argPtr ); + return TclLindexFlat(interp, listPtr, 1, &argPtr); } /* - * Record the reference to the list that we are maintaining in - * the activation record. + * Record the reference to the list that we are maintaining in the + * activation record. */ Tcl_IncrRefCount(listPtr); /* - * argPtr designates a list, and the 'else if' above has parsed it - * into indexCount and indices. + * argPtr designates a list, and the 'else if' above has parsed it into + * indexCount and indices. */ for (i=0 ; i=listLen) { /* * Index is out of range */ + Tcl_DecrRefCount(listPtr); listPtr = Tcl_NewObj(); Tcl_IncrRefCount(listPtr); return listPtr; } /* - * Make sure listPtr still refers to a list object. - * If it shared a Tcl_Obj structure with the arguments, then - * it might have just been converted to something else. + * Make sure listPtr still refers to a list object. If it shared a + * Tcl_Obj structure with the arguments, then it might have just been + * converted to something else. */ if (listPtr->typePtr != &tclListType) { result = Tcl_ListObjGetElements(interp, listPtr, &listLen, - &elemPtrs); + &elemPtrs); if (result != TCL_OK) { Tcl_DecrRefCount(listPtr); return NULL; } } @@ -2433,27 +2586,28 @@ listPtr = elemPtrs[index]; Tcl_IncrRefCount(listPtr); Tcl_DecrRefCount(oldListPtr); /* - * The work we did above may have caused the internal rep - * of *argPtr to change to something else. Get it back. + * The work we did above may have caused the internal rep of *argPtr + * to change to something else. Get it back. */ result = Tcl_ListObjGetElements(interp, argPtr, &indexCount, &indices); if (result != TCL_OK) { - /* + /* * This can't happen unless some extension corrupted a Tcl_Obj. */ + Tcl_DecrRefCount(listPtr); return NULL; } } /* - * Return the last object extracted. Its reference count will include - * the reference being returned. + * Return the last object extracted. Its reference count will include the + * reference being returned. */ return listPtr; } @@ -2460,25 +2614,24 @@ /* *---------------------------------------------------------------------- * * TclLindexFlat -- * - * This procedure handles the 'lindex' command, given that the - * arguments to the command are known to be a flat list. + * This procedure handles the 'lindex' command, given that the arguments + * to the command are known to be a flat list. * * Results: * Returns a standard Tcl result. * * Side effects: * None. * * Notes: - * This procedure is called from either tclExecute.c or - * Tcl_LindexObjCmd whenever either is presented with objc==2 or - * objc>=4. It is also called from TclLindexList for the objc==3 - * case once it is determined that objv[2] cannot be parsed as a - * list. + * This procedure is called from either tclExecute.c or Tcl_LindexObjCmd + * whenever either is presented with objc==2 or objc>=4. It is also + * called from TclLindexList for the objc==3 case once it is determined + * that objv[2] cannot be parsed as a list. * *---------------------------------------------------------------------- */ Tcl_Obj * @@ -2486,27 +2639,26 @@ Tcl_Interp *interp; /* Tcl interpreter */ Tcl_Obj *listPtr; /* Tcl object representing the list */ int indexCount; /* Count of indices */ Tcl_Obj *CONST indexArray[]; /* Array of pointers to Tcl objects - * representing the indices in the - * list */ -{ - int i; /* Current list index */ - int result; /* Result of Tcl library calls */ - int listLen; /* Length of the current list being - * processed */ - Tcl_Obj** elemPtrs; /* Array of pointers to the elements - * of the current list */ - int index; /* Parsed version of the current element - * of indexArray */ - Tcl_Obj* oldListPtr; /* Temporary to hold listPtr so that - * its ref count can be decremented. */ - - /* - * Record the reference to the 'listPtr' object that we are - * maintaining in the C activation record. + * representing the indices in the list. */ +{ + int i; /* Current list index. */ + int result; /* Result of Tcl library calls. */ + int listLen; /* Length of the current list being + * processed. */ + Tcl_Obj** elemPtrs; /* Array of pointers to the elements of the + * current list. */ + int index; /* Parsed version of the current element of + * indexArray. */ + Tcl_Obj* oldListPtr; /* Temporary to hold listPtr so that its ref + * count can be decremented. */ + + /* + * Record the reference to the 'listPtr' object that we are maintaining in + * the C activation record. */ Tcl_IncrRefCount(listPtr); for (i=0 ; i=listLen) { /* - * Index is out of range + * Index is out of range. */ Tcl_DecrRefCount(listPtr); listPtr = Tcl_NewObj(); Tcl_IncrRefCount(listPtr); return listPtr; } /* - * Make sure listPtr still refers to a list object. - * It might have been converted to something else above - * if objv[1] overlaps with one of the other parameters. + * Make sure listPtr still refers to a list object. It might have been + * converted to something else above if objv[1] overlaps with one of + * the other parameters. */ if (listPtr->typePtr != &tclListType) { result = Tcl_ListObjGetElements(interp, listPtr, &listLen, - &elemPtrs); + &elemPtrs); if (result != TCL_OK) { Tcl_DecrRefCount(listPtr); return NULL; } } /* - * Extract the pointer to the appropriate element + * Extract the pointer to the appropriate element. */ oldListPtr = listPtr; listPtr = elemPtrs[index]; Tcl_IncrRefCount(listPtr); Tcl_DecrRefCount(oldListPtr); } return listPtr; - } /* *---------------------------------------------------------------------- * @@ -2581,12 +2732,12 @@ * * This object-based procedure is invoked to process the "linsert" Tcl * command. See the user documentation for details on what it does. * * Results: - * A new Tcl list object formed by inserting zero or more elements - * into a list. + * A new Tcl list object formed by inserting zero or more elements into a + * list. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- @@ -2612,11 +2763,11 @@ if (result != TCL_OK) { return result; } /* - * Get the index. "end" is interpreted to be the index after the last + * Get the index. "end" is interpreted to be the index after the last * element, such that using it will cause any inserted elements to be * appended to the list. */ result = TclGetIntForIndex(interp, objv[2], /*end*/ len, &index); @@ -2626,12 +2777,12 @@ if (index > len) { index = len; } /* - * If the list object is unshared we can modify it directly. Otherwise - * we create a copy to modify: this is "copy on write". + * If the list object is unshared we can modify it directly. Otherwise we + * create a copy to modify: this is "copy on write". */ listPtr = objv[1]; isDuplicate = 0; if (Tcl_IsShared(listPtr)) { @@ -2641,10 +2792,11 @@ if ((objc == 4) && (index == len)) { /* * Special case: insert one element at the end of the list. */ + result = Tcl_ListObjAppendElement(interp, listPtr, objv[3]); } else if (objc > 3) { result = Tcl_ListObjReplace(interp, listPtr, index, 0, (objc-3), &(objv[3])); } @@ -2666,12 +2818,12 @@ /* *---------------------------------------------------------------------- * * Tcl_ListObjCmd -- * - * This procedure is invoked to process the "list" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "list" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: @@ -2703,11 +2855,11 @@ *---------------------------------------------------------------------- * * Tcl_LlengthObjCmd -- * * This object-based procedure is invoked to process the "llength" Tcl - * command. See the user documentation for details on what it does. + * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: @@ -2736,11 +2888,11 @@ return result; } /* * Set the interpreter's object result to an integer object holding the - * length. + * length. */ Tcl_SetObjResult(interp, Tcl_NewIntObj(listLen)); return TCL_OK; } @@ -2748,12 +2900,12 @@ /* *---------------------------------------------------------------------- * * Tcl_LrangeObjCmd -- * - * This procedure is invoked to process the "lrange" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "lrange" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: @@ -2778,12 +2930,12 @@ Tcl_WrongNumArgs(interp, 1, objv, "list first last"); return TCL_ERROR; } /* - * Make sure the list argument is a list object and get its length and - * a pointer to its array of element pointers. + * Make sure the list argument is a list object and get its length and a + * pointer to its array of element pointers. */ listPtr = objv[1]; result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs); if (result != TCL_OK) { @@ -2817,11 +2969,11 @@ } /* * Make sure listPtr still refers to a list object. It might have been * converted to an int above if the argument objects were shared. - */ + */ if (listPtr->typePtr != &tclListType) { result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs); if (result != TCL_OK) { @@ -2828,12 +2980,12 @@ return result; } } /* - * Extract a range of fields. We modify the interpreter's result object - * to be a list object containing the specified elements. + * Extract a range of fields. We modify the interpreter's result object to + * be a list object containing the specified elements. */ numElems = (last - first + 1); Tcl_SetObjResult(interp, Tcl_NewListObj(numElems, &(elemPtrs[first]))); return TCL_OK; @@ -2842,12 +2994,12 @@ /* *---------------------------------------------------------------------- * * Tcl_LrepeatObjCmd -- * - * This procedure is invoked to process the "lrepeat" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "lrepeat" Tcl command. See + * the user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: @@ -2857,19 +3009,21 @@ */ /* ARGSUSED */ int Tcl_LrepeatObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - register int objc; /* Number of arguments. */ - register Tcl_Obj *CONST objv[]; /* The argument objects. */ + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + register int objc; /* Number of arguments. */ + register Tcl_Obj *CONST objv[]; + /* The argument objects. */ { int elementCount, i, result; - Tcl_Obj **dataArray; + Tcl_Obj *listPtr, **dataArray; + List *listRepPtr; - /* + /* * Check arguments for legality: * lrepeat posInt value ?value ...? */ if (objc < 3) { @@ -2885,88 +3039,66 @@ Tcl_AppendResult(interp, "must have a count of at least 1", NULL); return TCL_ERROR; } /* - * Skip forward to the interesting arguments now we've finished - * parsing. + * Skip forward to the interesting arguments now we've finished parsing. */ objc -= 2; objv += 2; /* - * Create workspace array large enough to hold each init value - * elementCount times. Note that we don't bother with stack - * allocation for this, as we expect this function to be used - * mainly when stack allocation would be inappropriate anyway. - * First check to see if we'd overflow and try to allocate an - * object larger than our memory allocator allows. Note that this - * is actually a fairly small value when you're on a serious - * 64-bit machine, but that requires API changes to fix. - * - * We allocate using attemptckalloc() because if we ask for - * something big but can't get it, we've still got a high chance - * of having a proper failover strategy. If *that* fails to get - * memory, Tcl_Panic() will happen just a few lines lower... + * Get an empty list object that is allocated large enough to hold each + * init value elementCount times. */ - if ((unsigned)elementCount > INT_MAX/sizeof(Tcl_Obj *)/objc) { - Tcl_AppendResult(interp, "overflow of maximum list length", NULL); - return TCL_ERROR; - } - - dataArray = (Tcl_Obj **) - attemptckalloc(elementCount * objc * sizeof(Tcl_Obj *)); - - if (dataArray == NULL) { - Tcl_AppendResult(interp, "insufficient memory to create list", NULL); - return TCL_ERROR; - } + listPtr = Tcl_NewListObj(elementCount*objc, NULL); + listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr->elemCount = elementCount*objc; + dataArray = &listRepPtr->elements; /* - * Set the elements. Note that we handle the common degenerate - * case of a single value being repeated separately to permit the - * compiler as much room as possible to optimize a loop that might - * be run a very large number of times. + * Set the elements. Note that we handle the common degenerate case of a + * single value being repeated separately to permit the compiler as much + * room as possible to optimize a loop that might be run a very large + * number of times. */ if (objc == 1) { register Tcl_Obj *tmpPtr = objv[0]; + tmpPtr->refCount += elementCount; for (i=0 ; i= listLen) && (listLen > 0)) { @@ -3034,12 +3166,12 @@ } else { numToDelete = 0; } /* - * If the list object is unshared we can modify it directly, otherwise - * we create a copy to modify: this is "copy on write". + * If the list object is unshared we can modify it directly, otherwise we + * create a copy to modify: this is "copy on write". */ listPtr = objv[1]; isDuplicate = 0; if (Tcl_IsShared(listPtr)) { @@ -3046,11 +3178,11 @@ listPtr = Tcl_DuplicateObj(listPtr); isDuplicate = 1; } if (objc > 4) { result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete, - (objc-4), &(objv[4])); + (objc-4), &(objv[4])); } else { result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete, 0, NULL); } if (result != TCL_OK) { @@ -3059,11 +3191,11 @@ } return result; } /* - * Set the interpreter's object result. + * Set the interpreter's object result. */ Tcl_SetObjResult(interp, listPtr); return TCL_OK; } @@ -3071,12 +3203,12 @@ /* *---------------------------------------------------------------------- * * Tcl_LsearchObjCmd -- * - * This procedure is invoked to process the "lsearch" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "lsearch" Tcl command. See + * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -3092,35 +3224,38 @@ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument values. */ { char *bytes, *patternBytes; int i, match, mode, index, result, listc, length, elemLen; - int dataType, isIncreasing, lower, upper, patInt, objInt; - int offset, allMatches, inlineReturn, negatedMatch, returnSubindices; + int dataType, isIncreasing, lower, upper, patInt, objInt, offset; + int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase; double patDouble, objDouble; SortInfo sortInfo; Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr; Tcl_RegExp regexp = NULL; static CONST char *options[] = { "-all", "-ascii", "-decreasing", "-dictionary", "-exact", "-glob", "-increasing", "-index", - "-inline", "-integer", "-not", "-real", - "-regexp", "-sorted", "-start", "-subindices", + "-inline", "-integer", "-nocase", "-not", + "-real", "-regexp", "-sorted", "-start", + "-subindices", NULL }; enum options { LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_DECREASING, LSEARCH_DICTIONARY, LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, LSEARCH_INDEX, - LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOT, LSEARCH_REAL, - LSEARCH_REGEXP, LSEARCH_SORTED, LSEARCH_START, LSEARCH_SUBINDICES + LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOCASE, LSEARCH_NOT, + LSEARCH_REAL, LSEARCH_REGEXP, LSEARCH_SORTED, LSEARCH_START, + LSEARCH_SUBINDICES }; enum datatypes { ASCII, DICTIONARY, INTEGER, REAL }; enum modes { EXACT, GLOB, REGEXP, SORTED }; + SortStrCmpFn_t strCmpFn = strcmp; mode = GLOB; dataType = ASCII; isIncreasing = 1; allMatches = 0; @@ -3128,10 +3263,11 @@ returnSubindices = 0; negatedMatch = 0; listPtr = NULL; startPtr = NULL; offset = 0; + noCase = 0; sortInfo.compareCmdPtr = NULL; sortInfo.isIncreasing = 0; sortInfo.sortMode = 0; sortInfo.interp = interp; sortInfo.resultCode = TCL_OK; @@ -3179,10 +3315,14 @@ case LSEARCH_INLINE: /* -inline */ inlineReturn = 1; break; case LSEARCH_INTEGER: /* -integer */ dataType = INTEGER; + break; + case LSEARCH_NOCASE: /* -nocase */ + strCmpFn = strcasecmp; + noCase = 1; break; case LSEARCH_NOT: /* -not */ negatedMatch = 1; break; case LSEARCH_REAL: /* -real */ @@ -3197,14 +3337,14 @@ case LSEARCH_SUBINDICES: /* -subindices */ returnSubindices = 1; break; case LSEARCH_START: /* -start */ /* - * If there was a previous -start option, release its saved - * index because it will either be replaced or there will be - * an error. + * If there was a previous -start option, release its saved index + * because it will either be replaced or there will be an error. */ + if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } if (i > objc-4) { if (sortInfo.indexc > 1) { @@ -3214,16 +3354,16 @@ return TCL_ERROR; } i++; if (objv[i] == objv[objc - 2]) { /* - * Take copy to prevent shimmering problems. Note - * that it does not matter if the index obj is also a - * component of the list being searched. We only need - * to copy where the list and the index are - * one-and-the-same. + * Take copy to prevent shimmering problems. Note that it + * does not matter if the index obj is also a component of the + * list being searched. We only need to copy where the list + * and the index are one-and-the-same. */ + startPtr = Tcl_DuplicateObj(objv[i]); } else { startPtr = objv[i]; Tcl_IncrRefCount(startPtr); } @@ -3244,12 +3384,12 @@ return TCL_ERROR; } /* * Store the extracted indices for processing by sublist - * extraction. Note that we don't do this using objects - * because that has shimmering problems. + * extraction. Note that we don't do this using objects because + * that has shimmering problems. */ i++; if (Tcl_ListObjGetElements(interp, objv[i], &sortInfo.indexc, &indices) != TCL_OK) { @@ -3269,28 +3409,23 @@ sortInfo.indexv = (int *) ckalloc(sizeof(int) * sortInfo.indexc); } /* - * Fill the array by parsing each index. We don't know - * whether their scale is sensible yet, but we at least - * perform the syntactic check here. + * Fill the array by parsing each index. We don't know whether + * their scale is sensible yet, but we at least perform the + * syntactic check here. */ for (j=0 ; j 1) { ckfree((char *) sortInfo.indexv); } - sprintf(buffer, "%d", j); - Tcl_AddErrorInfo(interp, - "\n (-index option item number "); - Tcl_AddErrorInfo(interp, buffer); - Tcl_AddErrorInfo(interp, ")"); + TclFormatToErrorInfo(interp, + "\n (-index option item number %d)", j); return TCL_ERROR; } } break; } @@ -3313,12 +3448,14 @@ if ((enum modes) mode == REGEXP) { /* * We can shimmer regexp/list if listv[i] == pattern, so get the * regexp rep before the list rep. */ + regexp = Tcl_GetRegExpFromObj(interp, objv[objc - 1], - TCL_REG_ADVANCED | TCL_REG_NOSUB); + TCL_REG_ADVANCED | TCL_REG_NOSUB | + (noCase ? TCL_REG_NOCASE : 0)); if (regexp == NULL) { if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } if (sortInfo.indexc > 1) { @@ -3327,12 +3464,12 @@ return TCL_ERROR; } } /* - * Make sure the list argument is a list object and get its length and - * a pointer to its array of element pointers. + * Make sure the list argument is a list object and get its length and a + * pointer to its array of element pointers. */ result = Tcl_ListObjGetElements(interp, objv[objc - 2], &listc, &listv); if (result != TCL_OK) { if (startPtr != NULL) { @@ -3345,10 +3482,11 @@ } /* * Get the user-specified start offset. */ + if (startPtr) { result = TclGetIntForIndex(interp, startPtr, listc-1, &offset); Tcl_DecrRefCount(startPtr); if (result != TCL_OK) { if (sortInfo.indexc > 1) { @@ -3394,25 +3532,25 @@ } else { patternBytes = Tcl_GetStringFromObj(patObj, &length); } /* - * Set default index value to -1, indicating failure; if we find the - * item in the course of our search, index will be set to the correct - * value. + * Set default index value to -1, indicating failure; if we find the item + * in the course of our search, index will be set to the correct value. */ + index = -1; match = 0; if ((enum modes) mode == SORTED && !allMatches && !negatedMatch) { /* - * If the data is sorted, we can do a more intelligent search. - * Note that there is no point in being smart when -all was - * specified; in that case, we have to look at all items anyway, - * and there is no sense in doing this when the match sense is - * inverted. + * If the data is sorted, we can do a more intelligent search. Note + * that there is no point in being smart when -all was specified; in + * that case, we have to look at all items anyway, and there is no + * sense in doing this when the match sense is inverted. */ + lower = offset - 1; upper = listc; while (lower + 1 != upper && sortInfo.resultCode == TCL_OK) { i = (lower + upper)/2; itemPtr = SelectObjFromSublist(listv[i], &sortInfo); @@ -3423,11 +3561,11 @@ return sortInfo.resultCode; } switch ((enum datatypes) dataType) { case ASCII: bytes = TclGetString(itemPtr); - match = strcmp(patternBytes, bytes); + match = strCmpFn(patternBytes, bytes); break; case DICTIONARY: bytes = TclGetString(itemPtr); match = DictionaryCompare(patternBytes, bytes); break; @@ -3464,21 +3602,23 @@ } break; } if (match == 0) { /* - * Normally, binary search is written to stop when it - * finds a match. If there are duplicates of an element in - * the list, our first match might not be the first occurance. - * Consider: 0 0 0 1 1 1 2 2 2 - * To maintain consistancy with standard lsearch semantics, - * we must find the leftmost occurance of the pattern in the - * list. Thus we don't just stop searching here. This + * Normally, binary search is written to stop when it finds a + * match. If there are duplicates of an element in the list, + * our first match might not be the first occurance. + * Consider: 0 0 0 1 1 1 2 2 2 + * + * To maintain consistancy with standard lsearch semantics, we + * must find the leftmost occurance of the pattern in the + * list. Thus we don't just stop searching here. This * variation means that a search always makes log n - * comparisons (normal binary search might "get lucky" with - * an early comparison). + * comparisons (normal binary search might "get lucky" with an + * early comparison). */ + index = i; upper = i; } else if (match > 0) { if (isIncreasing) { lower = i; @@ -3499,10 +3639,11 @@ * We need to do a linear search, because (at least one) of: * - our matcher can only tell equal vs. not equal * - our matching sense is negated * - we're building a list of all matched items */ + if (allMatches) { listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); } for (i = offset; i < listc; i++) { match = 0; @@ -3521,12 +3662,21 @@ case EXACT: switch ((enum datatypes) dataType) { case ASCII: bytes = Tcl_GetStringFromObj(itemPtr, &elemLen); if (length == elemLen) { - match = (memcmp(bytes, patternBytes, - (size_t) length) == 0); + /* + * This split allows for more optimal compilation of + * memcmp/ + */ + + if (noCase) { + match = (strcasecmp(bytes, patternBytes) == 0); + } else { + match = (memcmp(bytes, patternBytes, + (size_t) length) == 0); + } } break; case DICTIONARY: bytes = TclGetString(itemPtr); match = (DictionaryCompare(bytes, patternBytes) == 0); @@ -3561,11 +3711,12 @@ break; } break; case GLOB: - match = Tcl_StringMatch(TclGetString(itemPtr), patternBytes); + match = Tcl_StringCaseMatch(TclGetString(itemPtr), + patternBytes, noCase); break; case REGEXP: match = Tcl_RegExpExecObj(interp, regexp, itemPtr, 0, 0, 0); if (match < 0) { Tcl_DecrRefCount(patObj); @@ -3577,13 +3728,15 @@ } return TCL_ERROR; } break; } + /* * Invert match condition for -not */ + if (negatedMatch) { match = !match; } if (!match) { continue; @@ -3593,10 +3746,11 @@ break; } else if (inlineReturn) { /* * Note that these appends are not expected to fail. */ + if (returnSubindices) { itemPtr = SelectObjFromSublist(listv[i], &sortInfo); } else { itemPtr = listv[i]; } @@ -3616,10 +3770,11 @@ } /* * Return everything or a single value. */ + if (allMatches) { Tcl_SetObjResult(interp, listPtr); } else if (!inlineReturn) { if (returnSubindices) { int j; @@ -3632,20 +3787,23 @@ } else { Tcl_SetObjResult(interp, Tcl_NewIntObj(index)); } } else if (index < 0) { /* - * Is this superfluous? The result should be a blank object - * by default... + * Is this superfluous? The result should be a blank object by + * default... */ + Tcl_SetObjResult(interp, Tcl_NewObj()); } else { Tcl_SetObjResult(interp, listv[index]); } + /* * Cleanup the index list array. */ + if (sortInfo.indexc > 1) { ckfree((char *) sortInfo.indexv); } return TCL_OK; } @@ -3653,12 +3811,12 @@ /* *---------------------------------------------------------------------- * * Tcl_LsetObjCmd -- * - * This procedure is invoked to process the "lset" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "lset" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -3666,79 +3824,84 @@ * *---------------------------------------------------------------------- */ int -Tcl_LsetObjCmd( clientData, interp, objc, objv ) +Tcl_LsetObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument values. */ { - - Tcl_Obj* listPtr; /* Pointer to the list being altered. */ - Tcl_Obj* finalValuePtr; /* Value finally assigned to the variable */ - - /* Check parameter count */ - - if ( objc < 3 ) { - Tcl_WrongNumArgs( interp, 1, objv, "listVar index ?index...? value" ); - return TCL_ERROR; - } - - /* Look up the list variable's value */ - - listPtr = Tcl_ObjGetVar2( interp, objv[ 1 ], (Tcl_Obj*) NULL, - TCL_LEAVE_ERR_MSG ); - if ( listPtr == NULL ) { - return TCL_ERROR; - } - - /* - * Substitute the value in the value. Return either the value or - * else an unshared copy of it. - */ - - if ( objc == 4 ) { - finalValuePtr = TclLsetList( interp, listPtr, - objv[ 2 ], objv[ 3 ] ); - } else { - finalValuePtr = TclLsetFlat( interp, listPtr, - objc-3, objv+2, objv[ objc-1 ] ); + Tcl_Obj* listPtr; /* Pointer to the list being altered. */ + Tcl_Obj* finalValuePtr; /* Value finally assigned to the variable. */ + + /* + * Check parameter count. + */ + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "listVar index ?index...? value"); + return TCL_ERROR; + } + + /* + * Look up the list variable's value. + */ + + listPtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, + TCL_LEAVE_ERR_MSG); + if (listPtr == NULL) { + return TCL_ERROR; + } + + /* + * Substitute the value in the value. Return either the value or else an + * unshared copy of it. + */ + + if (objc == 4) { + finalValuePtr = TclLsetList(interp, listPtr, objv[2], objv[3]); + } else { + finalValuePtr = TclLsetFlat(interp, listPtr, objc-3, objv+2, + objv[objc-1]); } /* * If substitution has failed, bail out. */ - if ( finalValuePtr == NULL ) { + if (finalValuePtr == NULL) { return TCL_ERROR; } - /* Finally, update the variable so that traces fire. */ + /* + * Finally, update the variable so that traces fire. + */ - listPtr = Tcl_ObjSetVar2( interp, objv[1], NULL, finalValuePtr, - TCL_LEAVE_ERR_MSG ); - Tcl_DecrRefCount( finalValuePtr ); - if ( listPtr == NULL ) { + listPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, finalValuePtr, + TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(finalValuePtr); + if (listPtr == NULL) { return TCL_ERROR; } - /* Return the new value of the variable as the interpreter result. */ + /* + * Return the new value of the variable as the interpreter result. + */ - Tcl_SetObjResult( interp, listPtr ); + Tcl_SetObjResult(interp, listPtr); return TCL_OK; - } /* *---------------------------------------------------------------------- * * Tcl_LsortObjCmd -- * - * This procedure is invoked to process the "lsort" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "lsort" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -3757,22 +3920,22 @@ int i, index, unique, indices; Tcl_Obj *resultPtr; int length; Tcl_Obj *cmdPtr, **listObjPtrs; SortElement *elementArray; - SortElement *elementPtr; - SortInfo sortInfo; /* Information about this sort that - * needs to be passed to the - * comparison function */ + SortElement *elementPtr; + SortInfo sortInfo; /* Information about this sort that needs to + * be passed to the comparison function. */ static CONST char *switches[] = { "-ascii", "-command", "-decreasing", "-dictionary", "-increasing", - "-index", "-indices", "-integer", "-real", "-unique", (char *) NULL + "-index", "-indices", "-integer", "-nocase", "-real", "-unique", + (char *) NULL }; enum Lsort_Switches { LSORT_ASCII, LSORT_COMMAND, LSORT_DECREASING, LSORT_DICTIONARY, LSORT_INCREASING, LSORT_INDEX, LSORT_INDICES, LSORT_INTEGER, - LSORT_REAL, LSORT_UNIQUE + LSORT_NOCASE, LSORT_REAL, LSORT_UNIQUE }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "?options? list"); return TCL_ERROR; @@ -3782,20 +3945,21 @@ * Parse arguments to set up the mode for the sort. */ sortInfo.isIncreasing = 1; sortInfo.sortMode = SORTMODE_ASCII; + sortInfo.strCmpFn = strcmp; sortInfo.indexv = NULL; sortInfo.indexc = 0; sortInfo.interp = interp; sortInfo.resultCode = TCL_OK; cmdPtr = NULL; unique = 0; indices = 0; for (i = 1; i < objc-1; i++) { - if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index) - != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, + &index) != TCL_OK) { return TCL_ERROR; } switch ((enum Lsort_Switches) index) { case LSORT_ASCII: sortInfo.sortMode = SORTMODE_ASCII; @@ -3833,15 +3997,17 @@ if (i == (objc-2)) { Tcl_AppendResult(interp, "\"-index\" option must be ", "followed by list index", NULL); return TCL_ERROR; } + /* * Take copy to prevent shimmering problems. */ - if (Tcl_ListObjGetElements(interp, objv[i+1], - &sortInfo.indexc, &indices) != TCL_OK) { + + if (Tcl_ListObjGetElements(interp, objv[i+1], &sortInfo.indexc, + &indices) != TCL_OK) { return TCL_ERROR; } switch (sortInfo.indexc) { case 0: sortInfo.indexv = NULL; @@ -3853,37 +4019,35 @@ sortInfo.indexv = (int *) ckalloc(sizeof(int) * sortInfo.indexc); } /* - * Fill the array by parsing each index. We don't know - * whether their scale is sensible yet, but we at least - * perform the syntactic check here. + * Fill the array by parsing each index. We don't know whether + * their scale is sensible yet, but we at least perform the + * syntactic check here. */ for (j=0 ; j 1) { ckfree((char *) sortInfo.indexv); } - sprintf(buffer, "%d", j); - Tcl_AddErrorInfo(interp, - "\n (-index option item number "); - Tcl_AddErrorInfo(interp, buffer); - Tcl_AddErrorInfo(interp, ")"); + TclFormatToErrorInfo(interp, + "\n (-index option item number %d)", j); return TCL_ERROR; } } i++; break; } case LSORT_INTEGER: sortInfo.sortMode = SORTMODE_INTEGER; break; + case LSORT_NOCASE: + sortInfo.strCmpFn = strcasecmp; + break; case LSORT_REAL: sortInfo.sortMode = SORTMODE_REAL; break; case LSORT_UNIQUE: unique = 1; @@ -3894,13 +4058,12 @@ } } if (sortInfo.sortMode == SORTMODE_COMMAND) { /* - * The existing command is a list. We want to flatten it, append - * two dummy arguments on the end, and replace these arguments - * later. + * The existing command is a list. We want to flatten it, append two + * dummy arguments on the end, and replace these arguments later. */ Tcl_Obj *newCommandPtr = Tcl_DuplicateObj(cmdPtr); Tcl_Obj *newObjPtr = Tcl_NewObj(); @@ -3971,68 +4134,66 @@ if (sortInfo.sortMode == SORTMODE_COMMAND) { Tcl_DecrRefCount(sortInfo.compareCmdPtr); sortInfo.compareCmdPtr = NULL; } if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); + ckfree((char *) sortInfo.indexv); } return sortInfo.resultCode; } /* *---------------------------------------------------------------------- * * MergeSort - * - * This procedure sorts a linked list of SortElement structures - * use the merge-sort algorithm. + * This procedure sorts a linked list of SortElement structures use the + * merge-sort algorithm. * * Results: - * A pointer to the head of the list after sorting is returned. + * A pointer to the head of the list after sorting is returned. * * Side effects: - * None, unless a user-defined comparison command does something - * weird. + * None, unless a user-defined comparison command does something weird. * *---------------------------------------------------------------------- */ static SortElement * MergeSort(headPtr, infoPtr) - SortElement *headPtr; /* First element on the list */ - SortInfo *infoPtr; /* Information needed by the - * comparison operator */ + SortElement *headPtr; /* First element on the list. */ + SortInfo *infoPtr; /* Information needed by the comparison + * operator. */ { /* - * The subList array below holds pointers to temporary lists built - * during the merge sort. Element i of the array holds a list of - * length 2**i. + * The subList array below holds pointers to temporary lists built during + * the merge sort. Element i of the array holds a list of length 2**i. */ # define NUM_LISTS 30 SortElement *subList[NUM_LISTS]; SortElement *elementPtr; int i; - for(i = 0; i < NUM_LISTS; i++){ + for (i=0 ; inextPtr; elementPtr->nextPtr = 0; - for (i = 0; (i < NUM_LISTS) && (subList[i] != NULL); i++){ + for (i=0 ; i= NUM_LISTS) { i = NUM_LISTS-1; } subList[i] = elementPtr; } elementPtr = NULL; - for (i = 0; i < NUM_LISTS; i++){ + for (i=0 ; iresultCode != TCL_OK) { /* - * Once an error has occurred, skip any future comparisons so - * as to preserve the error message in sortInterp->result. + * Once an error has occurred, skip any future comparisons so as to + * preserve the error message in sortInterp->result. */ + return order; } objPtr1 = SelectObjFromSublist(objPtr1, infoPtr); if (infoPtr->resultCode != TCL_OK) { @@ -4154,11 +4312,11 @@ if (infoPtr->resultCode != TCL_OK) { return order; } if (infoPtr->sortMode == SORTMODE_ASCII) { - order = strcmp(TclGetString(objPtr1), TclGetString(objPtr2)); + order = infoPtr->strCmpFn(TclGetString(objPtr1), TclGetString(objPtr2)); } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) { order = DictionaryCompare( TclGetString(objPtr1), TclGetString(objPtr2)); } else if (infoPtr->sortMode == SORTMODE_INTEGER) { long a, b; @@ -4175,13 +4333,12 @@ order = -1; } } else if (infoPtr->sortMode == SORTMODE_REAL) { double a, b; - if ((Tcl_GetDoubleFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK) - || (Tcl_GetDoubleFromObj(infoPtr->interp, objPtr2, &b) - != TCL_OK)) { + if (Tcl_GetDoubleFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK + || Tcl_GetDoubleFromObj(infoPtr->interp,objPtr2,&b) != TCL_OK){ infoPtr->resultCode = TCL_ERROR; return order; } if (a > b) { order = 1; @@ -4193,24 +4350,24 @@ int objc; paramObjv[0] = objPtr1; paramObjv[1] = objPtr2; - /* - * We made space in the command list for the two things to - * compare. Replace them and evaluate the result. + /* + * We made space in the command list for the two things to compare. + * Replace them and evaluate the result. */ Tcl_ListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc); Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2, 2, 2, paramObjv); - Tcl_ListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr, + Tcl_ListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr, &objc, &objv); infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0); - if (infoPtr->resultCode != TCL_OK) { + if (infoPtr->resultCode != TCL_OK) { Tcl_AddErrorInfo(infoPtr->interp, "\n (-compare command)"); return order; } @@ -4236,46 +4393,45 @@ /* *---------------------------------------------------------------------- * * DictionaryCompare * - * This function compares two strings as if they were being used in - * an index or card catalog. The case of alphabetic characters is - * ignored, except to break ties. Thus "B" comes before "b" but - * after "a". Also, integers embedded in the strings compare in - * numerical order. In other words, "x10y" comes after "x9y", not - * before it as it would when using strcmp(). + * This function compares two strings as if they were being used in an + * index or card catalog. The case of alphabetic characters is ignored, + * except to break ties. Thus "B" comes before "b" but after "a". Also, + * integers embedded in the strings compare in numerical order. In other + * words, "x10y" comes after "x9y", not * before it as it would when + * using strcmp(). * * Results: - * A negative result means that the first element comes before the - * second, and a positive result means that the second element - * should come first. A result of zero means the two elements - * are equal and it doesn't matter which comes first. + * A negative result means that the first element comes before the + * second, and a positive result means that the second element should + * come first. A result of zero means the two elements are equal and it + * doesn't matter which comes first. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int DictionaryCompare(left, right) - char *left, *right; /* The strings to compare */ + char *left, *right; /* The strings to compare. */ { Tcl_UniChar uniLeft, uniRight, uniLeftLower, uniRightLower; int diff, zeros; int secondaryDiff = 0; while (1) { - if (isdigit(UCHAR(*right)) /* INTL: digit */ - && isdigit(UCHAR(*left))) { /* INTL: digit */ + if (isdigit(UCHAR(*right)) /* INTL: digit */ + && isdigit(UCHAR(*left))) { /* INTL: digit */ /* - * There are decimal numbers embedded in the two - * strings. Compare them as numbers, rather than - * strings. If one number has more leading zeros than - * the other, the number with more leading zeros sorts - * later, but only as a secondary choice. + * There are decimal numbers embedded in the two strings. Compare + * them as numbers, rather than strings. If one number has more + * leading zeros than the other, the number with more leading + * zeros sorts later, but only as a secondary choice. */ zeros = 0; while ((*right == '0') && (isdigit(UCHAR(right[1])))) { right++; @@ -4288,59 +4444,61 @@ if (secondaryDiff == 0) { secondaryDiff = zeros; } /* - * The code below compares the numbers in the two - * strings without ever converting them to integers. It - * does this by first comparing the lengths of the - * numbers and then comparing the digit values. + * The code below compares the numbers in the two strings without + * ever converting them to integers. It does this by first + * comparing the lengths of the numbers and then comparing the + * digit values. */ diff = 0; while (1) { if (diff == 0) { diff = UCHAR(*left) - UCHAR(*right); } right++; left++; - if (!isdigit(UCHAR(*right))) { /* INTL: digit */ - if (isdigit(UCHAR(*left))) { /* INTL: digit */ + if (!isdigit(UCHAR(*right))) { /* INTL: digit */ + if (isdigit(UCHAR(*left))) { /* INTL: digit */ return 1; } else { /* - * The two numbers have the same length. See - * if their values are different. + * The two numbers have the same length. See if their + * values are different. */ if (diff != 0) { return diff; } break; } - } else if (!isdigit(UCHAR(*left))) { /* INTL: digit */ + } else if (!isdigit(UCHAR(*left))) { /* INTL: digit */ return -1; } } continue; } /* - * Convert character to Unicode for comparison purposes. If either + * Convert character to Unicode for comparison purposes. If either * string is at the terminating null, do a byte-wise comparison and * bail out immediately. */ if ((*left != '\0') && (*right != '\0')) { left += Tcl_UtfToUniChar(left, &uniLeft); right += Tcl_UtfToUniChar(right, &uniRight); + /* * Convert both chars to lower for the comparison, because - * dictionary sorts are case insensitve. Covert to lower, not + * dictionary sorts are case insensitve. Covert to lower, not * upper, so chars between Z and a will sort before A (where most * other interesting punctuations occur) */ + uniLeftLower = Tcl_UniCharToLower(uniLeft); uniRightLower = Tcl_UniCharToLower(uniRight); } else { diff = UCHAR(*left) - UCHAR(*right); break; @@ -4348,12 +4506,11 @@ diff = uniLeftLower - uniRightLower; if (diff) { return diff; } else if (secondaryDiff == 0) { - if (Tcl_UniCharIsUpper(uniLeft) && - Tcl_UniCharIsLower(uniRight)) { + if (Tcl_UniCharIsUpper(uniLeft) && Tcl_UniCharIsLower(uniRight)) { secondaryDiff = -1; } else if (Tcl_UniCharIsUpper(uniRight) && Tcl_UniCharIsLower(uniLeft)) { secondaryDiff = 1; } @@ -4368,34 +4525,33 @@ /* *---------------------------------------------------------------------- * * SelectObjFromSublist -- * - * This procedure is invoked from lsearch and SortCompare. It is - * used for implementing the -index option, for the lsort and - * lsearch commands. + * This procedure is invoked from lsearch and SortCompare. It is used + * for implementing the -index option, for the lsort and lsearch + * commands. * * Results: - * Returns NULL if a failure occurs, and sets the result in the - * infoPtr. Otherwise returns the Tcl_Obj* to the item. + * Returns NULL if a failure occurs, and sets the result in the infoPtr. + * Otherwise returns the Tcl_Obj* to the item. * * Side effects: - * None. + * None. * * Note: - * No reference counting is done, as the result is only used - * internally and never passed directly to user code. + * No reference counting is done, as the result is only used internally + * and never passed directly to user code. * *---------------------------------------------------------------------- */ static Tcl_Obj* SelectObjFromSublist(objPtr, infoPtr) - Tcl_Obj *objPtr; /* Obj to select sublist from. */ - SortInfo *infoPtr; /* Information passed from the - * top-level "lsearch" or "lsort" - * command. */ + Tcl_Obj *objPtr; /* Obj to select sublist from. */ + SortInfo *infoPtr; /* Information passed from the top-level + * "lsearch" or "lsort" command. */ { int i; /* * Quick check for case when no "-index" option is there. @@ -4404,12 +4560,12 @@ if (infoPtr->indexc == 0) { return objPtr; } /* - * Iterate over the indices, traversing through the nested - * sublists as we go. + * Iterate over the indices, traversing through the nested sublists as we + * go. */ for (i=0 ; iindexc ; i++) { int listLen, index; Tcl_Obj *currentObj; @@ -4418,16 +4574,19 @@ &listLen) != TCL_OK) { infoPtr->resultCode = TCL_ERROR; return NULL; } index = infoPtr->indexv[i]; + /* * Adjust for end-based indexing. */ + if (index < SORTIDX_NONE) { index += listLen + 1; } + if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index, ¤tObj) != TCL_OK) { infoPtr->resultCode = TCL_ERROR; return NULL; } @@ -4442,5 +4601,13 @@ } objPtr = currentObj; } return objPtr; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclCmdMZ.c ================================================================== --- generic/tclCmdMZ.c +++ generic/tclCmdMZ.c @@ -1,35 +1,35 @@ -/* +/* * tclCmdMZ.c -- * - * This file contains the top-level command routines for most of - * the Tcl built-in commands whose names begin with the letters - * M to Z. It contains only commands in the generic core (i.e. - * those that don't depend much upon UNIX facilities). + * This file contains the top-level command routines for most of the Tcl + * built-in commands whose names begin with the letters M to Z. It + * contains only commands in the generic core (i.e. those that don't + * depend much upon UNIX facilities). * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 Scriptics Corporation. * Copyright (c) 2002 ActiveState Corporation. * Copyright (c) 2003 Donal K. Fellows. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * 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.115 2004/10/21 15:19:46 dgp Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.115.2.13 2005/09/15 20:58:39 dgp Exp $ */ #include "tclInt.h" #include "tclRegexp.h" - + /* *---------------------------------------------------------------------- * * Tcl_PwdObjCmd -- * - * This procedure is invoked to process the "pwd" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "pwd" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -39,14 +39,14 @@ */ /* ARGSUSED */ int Tcl_PwdObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Obj *retVal; if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); @@ -65,12 +65,12 @@ /* *---------------------------------------------------------------------- * * Tcl_RegexpObjCmd -- * - * This procedure is invoked to process the "regexp" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "regexp" Tcl command. See + * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -80,19 +80,19 @@ */ /* ARGSUSED */ int Tcl_RegexpObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { int i, indices, match, about, offset, all, doinline, numMatchesSaved; int cflags, eflags, stringLength; Tcl_RegExp regExpr; - Tcl_Obj *objPtr, *resultPtr = NULL; + Tcl_Obj *objPtr, *startIndex = NULL, *resultPtr = NULL; Tcl_RegExpInfo info; static CONST char *options[] = { "-all", "-about", "-indices", "-inline", "-expanded", "-line", "-linestop", "-lineanchor", "-nocase", "-start", "--", (char *) NULL @@ -101,18 +101,18 @@ REGEXP_ALL, REGEXP_ABOUT, REGEXP_INDICES, REGEXP_INLINE, REGEXP_EXPANDED,REGEXP_LINE, REGEXP_LINESTOP,REGEXP_LINEANCHOR, REGEXP_NOCASE, REGEXP_START, REGEXP_LAST }; - indices = 0; - about = 0; - cflags = TCL_REG_ADVANCED; - eflags = 0; - offset = 0; - all = 0; - doinline = 0; - + indices = 0; + about = 0; + cflags = TCL_REG_ADVANCED; + eflags = 0; + offset = 0; + all = 0; + doinline = 0; + for (i = 1; i < objc; i++) { char *name; int index; name = TclGetString(objv[i]); @@ -119,115 +119,125 @@ if (name[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, &index) != TCL_OK) { - return TCL_ERROR; + goto optionError; } switch ((enum options) index) { - case REGEXP_ALL: { - all = 1; - break; - } - case REGEXP_INDICES: { - indices = 1; - break; - } - case REGEXP_INLINE: { - doinline = 1; - break; - } - case REGEXP_NOCASE: { - cflags |= TCL_REG_NOCASE; - break; - } - case REGEXP_ABOUT: { - about = 1; - break; - } - case REGEXP_EXPANDED: { - cflags |= TCL_REG_EXPANDED; - break; - } - case REGEXP_LINE: { - cflags |= TCL_REG_NEWLINE; - break; - } - case REGEXP_LINESTOP: { - cflags |= TCL_REG_NLSTOP; - break; - } - case REGEXP_LINEANCHOR: { - cflags |= TCL_REG_NLANCH; - break; - } - case REGEXP_START: { - if (++i >= objc) { - goto endOfForLoop; - } - if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) { - return TCL_ERROR; - } - if (offset < 0) { - offset = 0; - } - break; - } - case REGEXP_LAST: { - i++; - goto endOfForLoop; - } - } - } - - endOfForLoop: - if ((objc - i) < (2 - about)) { - Tcl_WrongNumArgs(interp, 1, objv, - "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); - return TCL_ERROR; + case REGEXP_ALL: + all = 1; + break; + case REGEXP_INDICES: + indices = 1; + break; + case REGEXP_INLINE: + doinline = 1; + break; + case REGEXP_NOCASE: + cflags |= TCL_REG_NOCASE; + break; + case REGEXP_ABOUT: + about = 1; + break; + case REGEXP_EXPANDED: + cflags |= TCL_REG_EXPANDED; + break; + case REGEXP_LINE: + cflags |= TCL_REG_NEWLINE; + break; + case REGEXP_LINESTOP: + cflags |= TCL_REG_NLSTOP; + break; + case REGEXP_LINEANCHOR: + cflags |= TCL_REG_NLANCH; + break; + case REGEXP_START: { + int temp; + if (++i >= objc) { + goto endOfForLoop; + } + if (TclGetIntForIndex(interp, objv[i], 0, &temp) != TCL_OK) { + goto optionError; + } + if (startIndex) { + Tcl_DecrRefCount(startIndex); + } + startIndex = objv[i]; + Tcl_IncrRefCount(startIndex); + break; + } + case REGEXP_LAST: + i++; + goto endOfForLoop; + } + } + + endOfForLoop: + if ((objc - i) < (2 - about)) { + Tcl_WrongNumArgs(interp, 1, objv, + "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); + goto optionError; } objc -= i; objv += i; + /* + * Check if the user requested -inline, but specified match variables; a + * no-no. + */ + if (doinline && ((objc - 2) != 0)) { - /* - * User requested -inline, but specified match variables - a no-no. - */ Tcl_AppendResult(interp, "regexp match variables not allowed", " when using -inline", (char *) NULL); - return TCL_ERROR; + goto optionError; } /* * Handle the odd about case separately. */ + if (about) { regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); if ((regExpr == NULL) || (TclRegAbout(interp, regExpr) < 0)) { + optionError: + if (startIndex) { + Tcl_DecrRefCount(startIndex); + } return TCL_ERROR; } return TCL_OK; } /* - * Get the length of the string that we are matching against so - * we can do the termination test for -all matches. Do this before - * getting the regexp to avoid shimmering problems. + * Get the length of the string that we are matching against so we can do + * the termination test for -all matches. Do this before getting the + * regexp to avoid shimmering problems. */ + objPtr = objv[1]; stringLength = Tcl_GetCharLength(objPtr); + + if (startIndex) { + TclGetIntForIndex(NULL, startIndex, stringLength, &offset); + Tcl_DecrRefCount(startIndex); + if (offset < 0) { + offset = 0; + } + } regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); if (regExpr == NULL) { return TCL_ERROR; } if (offset > 0) { /* - * Add flag if using offset (string is part of a larger string), - * so that "^" won't match. + * Add flag if using offset (string is part of a larger string), so + * that "^" won't match. */ + eflags |= TCL_REG_NOTBOL; } objc -= 2; objv += 2; @@ -234,34 +244,35 @@ if (doinline) { /* * Save all the subexpressions, as we will return them as a list */ + numMatchesSaved = -1; } else { /* - * Save only enough subexpressions for matches we want to keep, - * expect in the case of -all, where we need to keep at least - * one to know where to move the offset. + * Save only enough subexpressions for matches we want to keep, expect + * in the case of -all, where we need to keep at least one to know + * where to move the offset. */ + numMatchesSaved = (objc == 0) ? all : objc; } /* - * The following loop is to handle multiple matches within the - * same source string; each iteration handles one match. If "-all" - * hasn't been specified then the loop body only gets executed once. - * We terminate the loop when the starting offset is past the end of the - * string. + * The following loop is to handle multiple matches within the same source + * string; each iteration handles one match. If "-all" hasn't been + * specified then the loop body only gets executed once. We terminate the + * loop when the starting offset is past the end of the string. */ while (1) { match = Tcl_RegExpExecObj(interp, regExpr, objPtr, - offset /* offset */, numMatchesSaved, eflags + offset /* offset */, numMatchesSaved, eflags | ((offset > 0 && - (Tcl_GetUniChar(objPtr,offset-1) != (Tcl_UniChar)'\n')) - ? TCL_REG_NOTBOL : 0)); + (Tcl_GetUniChar(objPtr,offset-1) != (Tcl_UniChar)'\n')) + ? TCL_REG_NOTBOL : 0)); if (match < 0) { return TCL_ERROR; } @@ -268,35 +279,38 @@ if (match == 0) { /* * We want to set the value of the intepreter result only when * this is the first time through the loop. */ + if (all <= 1) { /* - * If inlining, the interpreter's object result remains - * an empty list, otherwise set it to an integer object w/ - * value 0. + * If inlining, the interpreter's object result remains an + * empty list, otherwise set it to an integer object w/ value + * 0. */ + if (!doinline) { Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); } return TCL_OK; } break; } /* - * If additional variable names have been specified, return - * index information in those variables. + * If additional variable names have been specified, return index + * information in those variables. */ Tcl_RegExpGetInfo(regExpr, &info); if (doinline) { /* - * It's the number of substitutions, plus one for the matchVar - * at index 0 + * It's the number of substitutions, plus one for the matchVar at + * index 0 */ + objc = info.nsubs + 1; if (all <= 1) { resultPtr = Tcl_NewObj(); } } @@ -306,16 +320,17 @@ if (indices) { int start, end; Tcl_Obj *objs[2]; /* - * Only adjust the match area if there was a match for - * that area. (Scriptics Bug 4391/SF Bug #219232) + * Only adjust the match area if there was a match for that + * area. (Scriptics Bug 4391/SF Bug #219232) */ + if (i <= info.nsubs && info.matches[i].start >= 0) { start = offset + info.matches[i].start; - end = offset + info.matches[i].end; + end = offset + info.matches[i].end; /* * Adjust index so it refers to the last character in the * match instead of the first character after the match. */ @@ -323,11 +338,11 @@ if (end >= offset) { end--; } } else { start = -1; - end = -1; + end = -1; } objs[0] = Tcl_NewLongObj(start); objs[1] = Tcl_NewLongObj(end); @@ -361,19 +376,21 @@ } if (all == 0) { break; } + /* - * Adjust the offset to the character just after the last one - * in the matchVar and increment all to count how many times - * we are making a match. We always increment the offset by at least - * one to prevent endless looping (as in the case: - * regexp -all {a*} a). Otherwise, when we match the NULL string at - * the end of the input string, we will loop indefinately (because the - * length of the match is 0, so offset never changes). + * Adjust the offset to the character just after the last one in the + * matchVar and increment all to count how many times we are making a + * match. We always increment the offset by at least one to prevent + * endless looping (as in the case: regexp -all {a*} a). Otherwise, + * when we match the NULL string at the end of the input string, we + * will loop indefinately (because the length of the match is 0, so + * offset never changes). */ + if (info.matches[0].end == 0) { offset++; } offset += info.matches[0].end; all++; @@ -382,13 +399,13 @@ break; } } /* - * Set the interpreter's object result to an integer object - * with value 1 if -all wasn't specified, otherwise it's all-1 - * (the number of times through the while - 1). + * Set the interpreter's object result to an integer object with value 1 + * if -all wasn't specified, otherwise it's all-1 (the number of times + * through the while - 1). */ if (doinline) { Tcl_SetObjResult(interp, resultPtr); } else { @@ -400,12 +417,12 @@ /* *---------------------------------------------------------------------- * * Tcl_RegsubObjCmd -- * - * This procedure is invoked to process the "regsub" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "regsub" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -415,20 +432,20 @@ */ /* ARGSUSED */ int Tcl_RegsubObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { int idx, result, cflags, all, wlen, wsublen, numMatches, offset; int start, end, subStart, subEnd, match; Tcl_RegExp regExpr; Tcl_RegExpInfo info; - Tcl_Obj *resultPtr, *subPtr, *objPtr; + Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL; Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend; static CONST char *options[] = { "-all", "-nocase", "-expanded", "-line", "-linestop", "-lineanchor", "-start", @@ -446,99 +463,111 @@ resultPtr = NULL; for (idx = 1; idx < objc; idx++) { char *name; int index; - + name = TclGetString(objv[idx]); if (name[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", TCL_EXACT, &index) != TCL_OK) { - return TCL_ERROR; + goto optionError; } switch ((enum options) index) { - case REGSUB_ALL: { - all = 1; - break; - } - case REGSUB_NOCASE: { - cflags |= TCL_REG_NOCASE; - break; - } - case REGSUB_EXPANDED: { - cflags |= TCL_REG_EXPANDED; - break; - } - case REGSUB_LINE: { - cflags |= TCL_REG_NEWLINE; - break; - } - case REGSUB_LINESTOP: { - cflags |= TCL_REG_NLSTOP; - break; - } - case REGSUB_LINEANCHOR: { - cflags |= TCL_REG_NLANCH; - break; - } - case REGSUB_START: { - if (++idx >= objc) { - goto endOfForLoop; - } - if (Tcl_GetIntFromObj(interp, objv[idx], &offset) != TCL_OK) { - return TCL_ERROR; - } - if (offset < 0) { - offset = 0; - } - break; - } - case REGSUB_LAST: { - idx++; - goto endOfForLoop; - } - } - } - endOfForLoop: + case REGSUB_ALL: + all = 1; + break; + case REGSUB_NOCASE: + cflags |= TCL_REG_NOCASE; + break; + case REGSUB_EXPANDED: + cflags |= TCL_REG_EXPANDED; + break; + case REGSUB_LINE: + cflags |= TCL_REG_NEWLINE; + break; + case REGSUB_LINESTOP: + cflags |= TCL_REG_NLSTOP; + break; + case REGSUB_LINEANCHOR: + cflags |= TCL_REG_NLANCH; + break; + case REGSUB_START: { + int temp; + if (++idx >= objc) { + goto endOfForLoop; + } + if (TclGetIntForIndex(interp, objv[idx], 0, &temp) != TCL_OK) { + goto optionError; + } + if (startIndex) { + Tcl_DecrRefCount(startIndex); + } + startIndex = objv[idx]; + Tcl_IncrRefCount(startIndex); + break; + } + case REGSUB_LAST: + idx++; + goto endOfForLoop; + } + } + + endOfForLoop: if (objc-idx < 3 || objc-idx > 4) { Tcl_WrongNumArgs(interp, 1, objv, "?switches? exp string subSpec ?varName?"); + optionError: + if (startIndex) { + Tcl_DecrRefCount(startIndex); + } return TCL_ERROR; } objc -= idx; objv += idx; + + if (startIndex) { + int stringLength = Tcl_GetCharLength(objv[1]); + + TclGetIntForIndex(NULL, startIndex, stringLength, &offset); + Tcl_DecrRefCount(startIndex); + if (offset < 0) { + offset = 0; + } + } if (all && (offset == 0) && (strpbrk(TclGetString(objv[2]), "&\\") == NULL) && (strpbrk(TclGetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) { /* - * This is a simple one pair string map situation. We make use of - * a slightly modified version of the one pair STR_MAP code. + * This is a simple one pair string map situation. We make use of a + * slightly modified version of the one pair STR_MAP code. */ + int slen, nocase; - int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar *, CONST Tcl_UniChar *, - unsigned long)); + int (*strCmpFn)(CONST Tcl_UniChar*, CONST Tcl_UniChar*, unsigned long); Tcl_UniChar *p, wsrclc; numMatches = 0; - nocase = (cflags & TCL_REG_NOCASE); - strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; + nocase = (cflags & TCL_REG_NOCASE); + strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; - wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen); - wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen); + wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen); + wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen); wsubspec = Tcl_GetUnicodeFromObj(objv[2], &wsublen); - wend = wstring + wlen - (slen ? slen - 1 : 0); - result = TCL_OK; + wend = wstring + wlen - (slen ? slen - 1 : 0); + result = TCL_OK; if (slen == 0) { /* - * regsub behavior for "" matches between each character. - * 'string map' skips the "" case. + * regsub behavior for "" matches between each character. 'string + * map' skips the "" case. */ + if (wstring < wend) { resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); for (; wstring < wend; wstring++) { Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); @@ -548,14 +577,13 @@ wlen = 0; } } else { wsrclc = Tcl_UniCharToLower(*wsrc); for (p = wfirstChar = wstring; wstring < wend; wstring++) { - if (((*wstring == *wsrc) || - (nocase && (Tcl_UniCharToLower(*wstring) == - wsrclc))) && - ((slen == 1) || (strCmpFn(wstring, wsrc, + if ((*wstring == *wsrc || + (nocase && Tcl_UniCharToLower(*wstring)==wsrclc)) && + (slen==1 || (strCmpFn(wstring, wsrc, (unsigned long) slen) == 0))) { if (numMatches == 0) { resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); } @@ -585,13 +613,13 @@ if (regExpr == NULL) { return TCL_ERROR; } /* - * Make sure to avoid problems where the objects are shared. This - * can cause RegExpObj <> UnicodeObj shimmering that causes data - * corruption. [Bug #461322] + * Make sure to avoid problems where the objects are shared. This can + * cause RegExpObj <> UnicodeObj shimmering that causes data corruption. + * [Bug #461322] */ if (objv[1] == objv[0]) { objPtr = Tcl_DuplicateObj(objv[1]); } else { @@ -606,31 +634,31 @@ wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen); result = TCL_OK; /* - * The following loop is to handle multiple matches within the - * same source string; each iteration handles one match and its - * corresponding substitution. If "-all" hasn't been specified - * then the loop body only gets executed once. We must use - * 'offset <= wlen' in particular for the case where the regexp - * pattern can match the empty string - this is useful when - * doing, say, 'regsub -- ^ $str ...' when $str might be empty. + * The following loop is to handle multiple matches within the same source + * string; each iteration handles one match and its corresponding + * substitution. If "-all" hasn't been specified then the loop body only + * gets executed once. We must use 'offset <= wlen' in particular for the + * case where the regexp pattern can match the empty string - this is + * useful when doing, say, 'regsub -- ^ $str ...' when $str might be + * empty. */ numMatches = 0; for ( ; offset <= wlen; ) { /* - * The flags argument is set if string is part of a larger string, - * so that "^" won't match. + * The flags argument is set if string is part of a larger string, so + * that "^" won't match. */ match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset, 10 /* matches */, ((offset > 0 && - (wstring[offset-1] != (Tcl_UniChar)'\n')) - ? TCL_REG_NOTBOL : 0)); + (wstring[offset-1] != (Tcl_UniChar)'\n')) + ? TCL_REG_NOTBOL : 0)); if (match < 0) { result = TCL_ERROR; goto done; } @@ -640,13 +668,14 @@ if (numMatches == 0) { resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); if (offset > 0) { /* - * Copy the initial portion of the string in if an offset - * was specified. + * Copy the initial portion of the string in if an offset was + * specified. */ + Tcl_AppendUnicodeToObj(resultPtr, wstring, offset); } } numMatches++; @@ -660,11 +689,11 @@ end = info.matches[0].end; Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start); /* * Append the subSpec argument to the variable, making appropriate - * substitutions. This code is a bit hairy because of the backslash + * substitutions. This code is a bit hairy because of the backslash * conventions and because the code saves up ranges of characters in * subSpec to reduce the number of calls to Tcl_SetVar. */ wsrc = wfirstChar = wsubspec; @@ -688,34 +717,39 @@ continue; } } else { continue; } + if (wfirstChar != wsrc) { Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } + if (idx <= info.nsubs) { subStart = info.matches[idx].start; subEnd = info.matches[idx].end; if ((subStart >= 0) && (subEnd >= 0)) { Tcl_AppendUnicodeToObj(resultPtr, wstring + offset + subStart, subEnd - subStart); } } + if (*wsrc == '\\') { wsrc++; } wfirstChar = wsrc + 1; } + if (wfirstChar != wsrc) { Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } + if (end == 0) { /* - * Always consume at least one character of the input string - * in order to prevent infinite loops. + * Always consume at least one character of the input string in + * order to prevent infinite loops. */ if (offset < wlen) { Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); } @@ -722,14 +756,14 @@ offset++; } else { offset += end; if (start == end) { /* - * We matched an empty string, which means we must go - * forward one more step so we don't match again at the - * same spot. + * We matched an empty string, which means we must go forward + * one more step so we don't match again at the same spot. */ + if (offset < wlen) { Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } @@ -741,16 +775,18 @@ /* * Copy the portion of the source string after the last match to the * result variable. */ - regsubDone: + + regsubDone: if (numMatches == 0) { /* - * On zero matches, just ignore the offset, since it shouldn't - * matter to us in this case, and the user may have skewed it. + * On zero matches, just ignore the offset, since it shouldn't matter + * to us in this case, and the user may have skewed it. */ + resultPtr = objv[1]; Tcl_IncrRefCount(resultPtr); } else if (offset < wlen) { Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); } @@ -760,36 +796,43 @@ TclGetString(objv[3]), "\"", (char *) NULL); result = TCL_ERROR; } else { /* * Set the interpreter's object result to an integer object - * holding the number of matches. + * holding the number of matches. */ Tcl_SetObjResult(interp, Tcl_NewIntObj(numMatches)); } } else { /* * No varname supplied, so just return the modified string. */ + Tcl_SetObjResult(interp, resultPtr); } - done: - if (objPtr && (objv[1] == objv[0])) { Tcl_DecrRefCount(objPtr); } - if (subPtr && (objv[2] == objv[0])) { Tcl_DecrRefCount(subPtr); } - if (resultPtr) { Tcl_DecrRefCount(resultPtr); } + done: + if (objPtr && (objv[1] == objv[0])) { + Tcl_DecrRefCount(objPtr); + } + if (subPtr && (objv[2] == objv[0])) { + Tcl_DecrRefCount(subPtr); + } + if (resultPtr) { + Tcl_DecrRefCount(resultPtr); + } return result; } /* *---------------------------------------------------------------------- * * Tcl_RenameObjCmd -- * - * This procedure is invoked to process the "rename" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "rename" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: @@ -805,11 +848,11 @@ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { char *oldName, *newName; - + if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "oldName newName"); return TCL_ERROR; } @@ -848,10 +891,11 @@ /* * General syntax: [return ?-option value ...? ?result?] * An even number of words means an explicit result argument is present. */ + int explicitResult = (0 == (objc % 2)); int numOptionWords = objc - 1 - explicitResult; if (TCL_ERROR == TclMergeReturnOptions(interp, numOptionWords, objv+1, &returnOpts, &code, &level)) { @@ -868,12 +912,12 @@ /* *---------------------------------------------------------------------- * * Tcl_SourceObjCmd -- * - * This procedure is invoked to process the "source" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "source" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: @@ -895,32 +939,36 @@ if (objc != 2 && objc !=4) { Tcl_WrongNumArgs(interp, 1, objv, "?-encoding name? fileName"); return TCL_ERROR; } + fileName = objv[objc-1]; + if (objc == 4) { static CONST char *options[] = { "-encoding", (char *) NULL }; int index; + if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], options, "option", TCL_EXACT, &index)) { return TCL_ERROR; } encodingName = TclGetString(objv[2]); } + return Tcl_FSEvalFileEx(interp, fileName, encodingName); } /* *---------------------------------------------------------------------- * * Tcl_SplitObjCmd -- * - * This procedure is invoked to process the "split" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "split" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -954,11 +1002,11 @@ } stringPtr = Tcl_GetStringFromObj(objv[1], &stringLen); end = stringPtr + stringLen; listPtr = Tcl_NewObj(); - + if (stringLen == 0) { /* * Do nothing. */ } else if (splitCharLen == 0) { @@ -967,38 +1015,48 @@ int isNew; /* * Handle the special case of splitting on every character. * - * Uses a hash table to ensure that each kind of character has - * only one Tcl_Obj instance (multiply-referenced) in the - * final list. This is a *major* win when splitting on a long - * string (especially in the megabyte range!) - DKF + * Uses a hash table to ensure that each kind of character has only + * one Tcl_Obj instance (multiply-referenced) in the final list. This + * is a *major* win when splitting on a long string (especially in the + * megabyte range!) - DKF */ Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS); + for ( ; stringPtr < end; stringPtr += len) { len = TclUtfToUniChar(stringPtr, &ch); - /* Assume Tcl_UniChar is an integral type... */ + + /* + * Assume Tcl_UniChar is an integral type... + */ + hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0 + ch, &isNew); if (isNew) { objPtr = Tcl_NewStringObj(stringPtr, len); - /* Don't need to fiddle with refcount... */ + + /* + * Don't need to fiddle with refcount... + */ + Tcl_SetHashValue(hPtr, (ClientData) objPtr); } else { objPtr = (Tcl_Obj*) Tcl_GetHashValue(hPtr); } Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } Tcl_DeleteHashTable(&charReuseTable); + } else if (splitCharLen == 1) { char *p; /* - * Handle the special case of splitting on a single character. - * This is only true for the one-char ASCII case, as one unicode - * char is > 1 byte in length. + * Handle the special case of splitting on a single character. This is + * only true for the one-char ASCII case, as one unicode char is > 1 + * byte in length. */ while (*stringPtr && (p=strchr(stringPtr,(int)*splitChars)) != NULL) { objPtr = Tcl_NewStringObj(stringPtr, p - stringPtr); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); @@ -1008,14 +1066,14 @@ Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } else { char *element, *p, *splitEnd; int splitLen; Tcl_UniChar splitChar; - + /* - * Normal case: split on any of a given set of characters. - * Discard instances of the split characters. + * Normal case: split on any of a given set of characters. Discard + * instances of the split characters. */ splitEnd = splitChars + splitCharLen; for (element = stringPtr; stringPtr < end; stringPtr += len) { @@ -1028,10 +1086,11 @@ element = stringPtr + len; break; } } } + objPtr = Tcl_NewStringObj(element, stringPtr - element); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } Tcl_SetObjResult(interp, listPtr); return TCL_OK; @@ -1040,19 +1099,18 @@ /* *---------------------------------------------------------------------- * * Tcl_StringObjCmd -- * - * This procedure is invoked to process the "string" Tcl command. - * See the user documentation for details on what it does. Note - * that this command only functions correctly on properly formed - * Tcl UTF strings. - * - * Note that the primary methods here (equal, compare, match, ...) - * have bytecode equivalents. You will find the code for those in - * tclExecute.c. The code here will only be used in the non-bc - * case (like in an 'eval'). + * This procedure is invoked to process the "string" Tcl command. See the + * user documentation for details on what it does. Note that this command + * only functions correctly on properly formed Tcl UTF strings. + * + * Note that the primary methods here (equal, compare, match, ...) have + * bytecode equivalents. You will find the code for those in + * tclExecute.c. The code here will only be used in the non-bc case (like + * in an 'eval'). * * Results: * A standard Tcl result. * * Side effects: @@ -1085,1325 +1143,1302 @@ STR_INDEX, STR_IS, STR_LAST, STR_LENGTH, STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT, STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE, STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT, STR_WORDEND, STR_WORDSTART - }; + }; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); return TCL_ERROR; } - + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum options) index) { - case STR_EQUAL: - case STR_COMPARE: { - /* - * Remember to keep code here in some sync with the - * byte-compiled versions in tclExecute.c (INST_STR_EQ, - * INST_STR_NEQ and INST_STR_CMP as well as the expr string - * comparison in INST_EQ/INST_NEQ/INST_LT/...). - */ - int i, match, length, nocase = 0, reqlength = -1; - typedef int (*strCmpFn_t) _ANSI_ARGS_((const char *, const char *, - unsigned int)); - strCmpFn_t strCmpFn; - - if (objc < 4 || objc > 7) { - str_cmp_args: - Tcl_WrongNumArgs(interp, 2, objv, - "?-nocase? ?-length int? string1 string2"); - return TCL_ERROR; - } - - for (i = 2; i < objc-2; i++) { - string2 = Tcl_GetStringFromObj(objv[i], &length2); - if ((length2 > 1) - && strncmp(string2, "-nocase", (size_t)length2) == 0) { - nocase = 1; - } else if ((length2 > 1) - && strncmp(string2, "-length", (size_t)length2) == 0) { - if (i+1 >= objc-2) { - goto str_cmp_args; - } - if (Tcl_GetIntFromObj(interp, objv[++i], - &reqlength) != TCL_OK) { - return TCL_ERROR; - } - } else { - Tcl_AppendResult(interp, "bad option \"", - string2, "\": must be -nocase or -length", - (char *) NULL); - return TCL_ERROR; - } - } - - /* - * From now on, we only access the two objects at the end - * of the argument array. - */ - objv += objc-2; - - if ((reqlength == 0) || (objv[0] == objv[1])) { - /* - * Alway match at 0 chars of if it is the same obj. - */ - - Tcl_SetObjResult(interp, - Tcl_NewBooleanObj((enum options) index == STR_EQUAL)); - break; - } else if (!nocase && objv[0]->typePtr == &tclByteArrayType && - objv[1]->typePtr == &tclByteArrayType) { - /* - * Use binary versions of comparisons since that won't - * cause undue type conversions and it is much faster. - * Only do this if we're case-sensitive (which is all - * that really makes sense with byte arrays anyway, and - * we have no memcasecmp() for some reason... :^) - */ - string1 = (char*) Tcl_GetByteArrayFromObj(objv[0], &length1); - string2 = (char*) Tcl_GetByteArrayFromObj(objv[1], &length2); - strCmpFn = (strCmpFn_t) memcmp; - } else if ((objv[0]->typePtr == &tclStringType) - && (objv[1]->typePtr == &tclStringType)) { - /* - * Do a unicode-specific comparison if both of the args - * are of String type. In benchmark testing this proved - * the most efficient check between the unicode and - * string comparison operations. - */ - string1 = (char*) Tcl_GetUnicodeFromObj(objv[0], &length1); - string2 = (char*) Tcl_GetUnicodeFromObj(objv[1], &length2); - strCmpFn = (strCmpFn_t) - (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); - } else { - /* - * As a catch-all we will work with UTF-8. We cannot use - * memcmp() as that is unsafe with any string containing - * NULL (\xC0\x80 in Tcl's utf rep). We can use the more - * efficient TclpUtfNcmp2 if we are case-sensitive and no - * specific length was requested. - */ - string1 = (char*) Tcl_GetStringFromObj(objv[0], &length1); - string2 = (char*) Tcl_GetStringFromObj(objv[1], &length2); - if ((reqlength < 0) && !nocase) { - strCmpFn = (strCmpFn_t) TclpUtfNcmp2; - } else { - length1 = Tcl_NumUtfChars(string1, length1); - length2 = Tcl_NumUtfChars(string2, length2); - strCmpFn = (strCmpFn_t) - (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); - } - } - - if (((enum options) index == STR_EQUAL) - && (reqlength < 0) && (length1 != length2)) { - match = 1; /* this will be reversed below */ - } else { - length = (length1 < length2) ? length1 : length2; - if (reqlength > 0 && reqlength < length) { - length = reqlength; - } else if (reqlength < 0) { - /* - * The requested length is negative, so we ignore it by - * setting it to length + 1 so we correct the match var. - */ - reqlength = length + 1; - } - match = strCmpFn(string1, string2, (unsigned) length); - if ((match == 0) && (reqlength > length)) { - match = length1 - length2; - } - } - - if ((enum options) index == STR_EQUAL) { - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1)); - } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj( - (match > 0) ? 1 : (match < 0) ? -1 : 0)); - } - break; - } - case STR_FIRST: { - Tcl_UniChar *ustring1, *ustring2; - int match, start; - - if (objc < 4 || objc > 5) { - Tcl_WrongNumArgs(interp, 2, objv, - "subString string ?startIndex?"); - return TCL_ERROR; - } - - /* - * We are searching string2 for the sequence string1. - */ - - match = -1; - start = 0; - length2 = -1; - - ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); - ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2); - - if (objc == 5) { - /* - * If a startIndex is specified, we will need to fast - * forward to that point in the string before we think - * about a match - */ - if (TclGetIntForIndex(interp, objv[4], length2 - 1, - &start) != TCL_OK) { - return TCL_ERROR; - } - if (start >= length2) { - goto str_first_done; - } else if (start > 0) { - ustring2 += start; - length2 -= start; - } else if (start < 0) { - /* - * Invalid start index mapped to string start; - * Bug #423581 - */ - start = 0; - } - } - - if (length1 > 0) { - register Tcl_UniChar *p, *end; - - end = ustring2 + length2 - length1 + 1; - for (p = ustring2; p < end; p++) { - /* - * Scan forward to find the first character. - */ - if ((*p == *ustring1) && - (TclUniCharNcmp(ustring1, p, - (unsigned long) length1) == 0)) { - match = p - ustring2; - break; - } - } - } - /* - * Compute the character index of the matching string by - * counting the number of characters before the match. - */ - if ((match != -1) && (objc == 5)) { - match += start; - } - - str_first_done: - Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); - break; - } - case STR_INDEX: { - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "string charIndex"); - return TCL_ERROR; - } - - /* - * If we have a ByteArray object, avoid indexing in the - * Utf string since the byte array contains one byte per - * character. Otherwise, use the Unicode string rep to - * get the index'th char. - */ - - if (objv[2]->typePtr == &tclByteArrayType) { - string1 = (char *) Tcl_GetByteArrayFromObj(objv[2], &length1); - - if (TclGetIntForIndex(interp, objv[3], length1 - 1, - &index) != TCL_OK) { - return TCL_ERROR; - } - if ((index >= 0) && (index < length1)) { - Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( - (unsigned char *)(&string1[index]), 1)); - } - } else { - /* - * Get Unicode char length to calulate what 'end' means. - */ - length1 = Tcl_GetCharLength(objv[2]); - - if (TclGetIntForIndex(interp, objv[3], length1 - 1, - &index) != TCL_OK) { - return TCL_ERROR; - } - if ((index >= 0) && (index < length1)) { - char buf[TCL_UTF_MAX]; - Tcl_UniChar ch; - - ch = Tcl_GetUniChar(objv[2], index); - length1 = Tcl_UniCharToUtf(ch, buf); - Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length1)); - } - } - break; - } - case STR_IS: { - char *end; - Tcl_UniChar ch; - - /* - * The UniChar comparison function - */ - - int (*chcomp)_ANSI_ARGS_((int)) = NULL; - int i, failat = 0, result = 1, strict = 0; - Tcl_Obj *objPtr, *failVarObj = NULL; - Tcl_WideInt w; - - static CONST char *isOptions[] = { - "alnum", "alpha", "ascii", "control", - "boolean", "digit", "double", "false", - "graph", "integer", "lower", "print", - "punct", "space", "true", "upper", - "wideinteger", "wordchar", "xdigit", (char *) NULL - }; - enum isOptions { - STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, - STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_FALSE, - STR_IS_GRAPH, STR_IS_INT, STR_IS_LOWER, STR_IS_PRINT, - STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, - STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT - }; - - if (objc < 4 || objc > 7) { - Tcl_WrongNumArgs(interp, 2, objv, - "class ?-strict? ?-failindex var? str"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[2], isOptions, "class", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - if (objc != 4) { - for (i = 3; i < objc-1; i++) { - string2 = Tcl_GetStringFromObj(objv[i], &length2); - if ((length2 > 1) && - strncmp(string2, "-strict", (size_t) length2) == 0) { - strict = 1; - } else if ((length2 > 1) && - strncmp(string2, "-failindex", - (size_t) length2) == 0) { - if (i+1 >= objc-1) { - Tcl_WrongNumArgs(interp, 3, objv, - "?-strict? ?-failindex var? str"); - return TCL_ERROR; - } - failVarObj = objv[++i]; - } else { - Tcl_AppendResult(interp, "bad option \"", - string2, "\": must be -strict or -failindex", - (char *) NULL); - return TCL_ERROR; - } - } - } - - /* - * We get the objPtr so that we can short-cut for some classes - * by checking the object type (int and double), but we need - * the string otherwise, because we don't want any conversion - * of type occuring (as, for example, Tcl_Get*FromObj would do - */ - objPtr = objv[objc-1]; - string1 = Tcl_GetStringFromObj(objPtr, &length1); - if (length1 == 0) { - if (strict) { - result = 0; - } - goto str_is_done; - } - end = string1 + length1; - - /* - * When entering here, result == 1 and failat == 0 - */ - switch ((enum isOptions) index) { - case STR_IS_ALNUM: - chcomp = Tcl_UniCharIsAlnum; - break; - case STR_IS_ALPHA: - chcomp = Tcl_UniCharIsAlpha; - break; - case STR_IS_ASCII: - for (; string1 < end; string1++, failat++) { - /* - * This is a valid check in unicode, because all - * bytes < 0xC0 are single byte chars (but isascii - * limits that def'n to 0x80). - */ - if (*((unsigned char *)string1) >= 0x80) { - result = 0; - break; - } - } - break; - case STR_IS_BOOL: - case STR_IS_TRUE: - case STR_IS_FALSE: - if (objPtr->typePtr == &tclBooleanType) { - if ((((enum isOptions) index == STR_IS_TRUE) && - objPtr->internalRep.longValue == 0) || - (((enum isOptions) index == STR_IS_FALSE) && - objPtr->internalRep.longValue != 0)) { - result = 0; - } - } else if ((Tcl_GetBoolean(NULL, string1, &i) - == TCL_ERROR) || - (((enum isOptions) index == STR_IS_TRUE) && - i == 0) || - (((enum isOptions) index == STR_IS_FALSE) && - i != 0)) { - result = 0; - } - break; - case STR_IS_CONTROL: - chcomp = Tcl_UniCharIsControl; - break; - case STR_IS_DIGIT: - chcomp = Tcl_UniCharIsDigit; - break; - case STR_IS_DOUBLE: { - char *stop; - - 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. */ -#endif - if (stop == end) { - if (errno == ERANGE) { - result = 0; - failat = -1; - } - break; - } - } - errno = 0; - strtod(string1, &stop); /* INTL: Tcl source. */ - if (errno == ERANGE) { - /* - * if (errno == ERANGE), then it was an over/underflow - * problem, but in this method, we only want to know - * yes or no, so bad flow returns 0 (false) and sets - * the failVarObj to the string length. - */ - result = 0; - failat = -1; - } else if (stop == string1) { - /* - * In this case, nothing like a number was found - */ - 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; - } - break; - } - case STR_IS_GRAPH: - chcomp = Tcl_UniCharIsGraph; - break; - case STR_IS_INT: { - char *stop; - long int l = 0; - - if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &i)) { - break; - } - - /* - * Like STR_IS_DOUBLE, but we use strtoul. - * Since Tcl_GetIntFromObj already failed, - * we set result to 0. - */ - - result = 0; - errno = 0; - l = strtol(string1, &stop, 0); /* INTL: Tcl source. */ - if ((errno == ERANGE) || (l > INT_MAX) || (l < INT_MIN)) { - /* - * if (errno == ERANGE) or the long value - * won't fit in an int, then it was an - * over/underflow problem, but in this method, - * we only want to know yes or no, so bad flow - * returns 0 (false) and sets the failVarObj - * to the string length. - */ - failat = -1; - } else if (stop == string1) { - /* - * In this case, nothing like a number was found - */ - 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; - } - break; - } - case STR_IS_LOWER: - chcomp = Tcl_UniCharIsLower; - break; - case STR_IS_PRINT: - chcomp = Tcl_UniCharIsPrint; - break; - case STR_IS_PUNCT: - chcomp = Tcl_UniCharIsPunct; - break; - case STR_IS_SPACE: - chcomp = Tcl_UniCharIsSpace; - break; - case STR_IS_UPPER: - chcomp = Tcl_UniCharIsUpper; - break; - case STR_IS_WIDE: { - char *stop; - - if (TCL_OK == Tcl_GetWideIntFromObj(NULL, objPtr, &w)) { - break; - } - - /* - * Like STR_IS_DOUBLE, but we use strtoll. Since - * Tcl_GetWideIntFromObj already failed, we set - * result to 0. - */ - - result = 0; - errno = 0; - w = strtoll(string1, &stop, 0); /* INTL: Tcl source. */ - if (errno == ERANGE) { - /* - * if (errno == ERANGE), then it was an - * over/underflow problem, but in this method, - * we only want to know yes or no, so bad flow - * returns 0 (false) and sets the failVarObj - * to the string length. - */ - failat = -1; - } else if (stop == string1) { - /* - * In this case, nothing like a number was found - */ - 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; - } - break; - } - case STR_IS_WORD: - chcomp = Tcl_UniCharIsWordChar; - break; - case STR_IS_XDIGIT: { - for (; string1 < end; string1++, failat++) { - /* INTL: We assume unicode is bad for this class */ - if ((*((unsigned char *)string1) >= 0xC0) || - !isxdigit(*(unsigned char *)string1)) { - result = 0; - break; - } - } - break; - } - } - if (chcomp != NULL) { - for (; string1 < end; string1 += length2, failat++) { - length2 = TclUtfToUniChar(string1, &ch); - if (!chcomp(ch)) { - result = 0; - break; - } - } - } - str_is_done: - /* - * Only set the failVarObj when we will return 0 - * and we have indicated a valid fail index (>= 0) - */ - if ((result == 0) && (failVarObj != NULL) && - Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat), - TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); - break; - } - case STR_LAST: { - Tcl_UniChar *ustring1, *ustring2, *p; - int match, start; - - if (objc < 4 || objc > 5) { - Tcl_WrongNumArgs(interp, 2, objv, - "subString string ?startIndex?"); - return TCL_ERROR; - } - - /* - * We are searching string2 for the sequence string1. - */ - - match = -1; - start = 0; - length2 = -1; - - ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); - ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2); - - if (objc == 5) { - /* - * If a startIndex is specified, we will need to restrict - * the string range to that char index in the string - */ - if (TclGetIntForIndex(interp, objv[4], length2 - 1, - &start) != TCL_OK) { - return TCL_ERROR; - } - if (start < 0) { - goto str_last_done; - } else if (start < length2) { - p = ustring2 + start + 1 - length1; - } else { - p = ustring2 + length2 - length1; - } - } else { - p = ustring2 + length2 - length1; - } - - if (length1 > 0) { - for (; p >= ustring2; p--) { - /* - * Scan backwards to find the first character. - */ - if ((*p == *ustring1) && - (memcmp((char *) ustring1, (char *) p, (size_t) - (length1 * sizeof(Tcl_UniChar))) == 0)) { - match = p - ustring2; - break; - } - } - } - - str_last_done: - Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); - break; - } - case STR_BYTELENGTH: - case STR_LENGTH: { - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "string"); - return TCL_ERROR; - } - - if ((enum options) index == STR_BYTELENGTH) { - (void) Tcl_GetStringFromObj(objv[2], &length1); - } else { - /* - * If we have a ByteArray object, avoid recomputing the - * string since the byte array contains one byte per - * character. Otherwise, use the Unicode string rep to - * calculate the length. - */ - - if (objv[2]->typePtr == &tclByteArrayType) { - (void) Tcl_GetByteArrayFromObj(objv[2], &length1); - } else { - length1 = Tcl_GetCharLength(objv[2]); - } - } - Tcl_SetObjResult(interp, Tcl_NewIntObj(length1)); - break; - } - case STR_MAP: { - int mapElemc, nocase = 0, mapWithDict = 0, copySource = 0; - Tcl_Obj **mapElemv, *sourceObj, *resultPtr; - Tcl_UniChar *ustring1, *ustring2, *p, *end; - int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar*, - CONST Tcl_UniChar*, unsigned long)); - - if (objc < 4 || objc > 5) { - Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? charMap string"); - return TCL_ERROR; - } - - if (objc == 5) { - string2 = Tcl_GetStringFromObj(objv[2], &length2); - if ((length2 > 1) && - strncmp(string2, "-nocase", (size_t) length2) == 0) { - nocase = 1; - } else { - Tcl_AppendResult(interp, "bad option \"", - string2, "\": must be -nocase", (char *) NULL); - return TCL_ERROR; - } - } - - - /* - * This test is tricky, but has to be that way or you get - * other strange inconsistencies (see test string-10.20 - * for illustration why!) - */ - if (objv[objc-2]->typePtr == &tclDictType && - objv[objc-2]->bytes == NULL) { - int i, done; - Tcl_DictSearch search; - - /* - * We know the type exactly, so all dict operations - * will succeed for sure. This shortens this code - * quite a bit. - */ - Tcl_DictObjSize(interp, objv[objc-2], &mapElemc); - if (mapElemc == 0) { - /* - * empty charMap, just return whatever string was given - */ - Tcl_SetObjResult(interp, objv[objc-1]); - return TCL_OK; - } - mapElemc *= 2; - mapWithDict = 1; - /* - * Copy the dictionary out into an array; that's the - * easiest way to adapt this code... - */ - mapElemv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * mapElemc); - Tcl_DictObjFirst(interp, objv[objc-2], &search, - mapElemv+0, mapElemv+1, &done); - for (i=2 ; i30% faster on larger strings. - */ - int mapLen; - Tcl_UniChar *mapString, u2lc; - - ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); - p = ustring1; - if (length2 == 0) { - ustring1 = end; - } else { - mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen); - u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0); - for (; ustring1 < end; ustring1++) { - if (((*ustring1 == *ustring2) || - (nocase && (Tcl_UniCharToLower(*ustring1) == - u2lc))) && - ((length2 == 1) || strCmpFn(ustring1, ustring2, - (unsigned long) length2) == 0)) { - if (p != ustring1) { - Tcl_AppendUnicodeToObj(resultPtr, p, - ustring1 - p); - p = ustring1 + length2; - } else { - p += length2; - } - ustring1 = p - 1; - - Tcl_AppendUnicodeToObj(resultPtr, mapString, - mapLen); - } - } - } - } else { - Tcl_UniChar **mapStrings, *u2lc = NULL; - int *mapLens; - /* - * Precompute pointers to the unicode string and length. - * This saves us repeated function calls later, - * significantly speeding up the algorithm. We only need - * the lowercase first char in the nocase case. - */ - mapStrings = (Tcl_UniChar **) ckalloc((mapElemc * 2) - * sizeof(Tcl_UniChar *)); - mapLens = (int *) ckalloc((mapElemc * 2) * sizeof(int)); - if (nocase) { - u2lc = (Tcl_UniChar *) - ckalloc((mapElemc) * sizeof(Tcl_UniChar)); - } - for (index = 0; index < mapElemc; index++) { - mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], - &(mapLens[index])); - if (nocase && ((index % 2) == 0)) { - u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]); - } - } - for (p = ustring1; ustring1 < end; ustring1++) { - for (index = 0; index < mapElemc; index += 2) { - /* - * Get the key string to match on. - */ - ustring2 = mapStrings[index]; - length2 = mapLens[index]; - if ((length2 > 0) && ((*ustring1 == *ustring2) || - (nocase && (Tcl_UniCharToLower(*ustring1) == - u2lc[index/2]))) && - ((length2 == 1) || strCmpFn(ustring2, ustring1, - (unsigned long) length2) == 0)) { - if (p != ustring1) { - /* - * Put the skipped chars onto the result first - */ - Tcl_AppendUnicodeToObj(resultPtr, p, - ustring1 - p); - p = ustring1 + length2; - } else { - p += length2; - } - /* - * Adjust len to be full length of matched string - */ - ustring1 = p - 1; - - /* - * Append the map value to the unicode string - */ - Tcl_AppendUnicodeToObj(resultPtr, - mapStrings[index+1], mapLens[index+1]); - break; - } - } - } - ckfree((char *) mapStrings); - ckfree((char *) mapLens); - if (nocase) { - ckfree((char *) u2lc); - } - } - if (p != ustring1) { - /* - * Put the rest of the unmapped chars onto result - */ - Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); - } + case STR_EQUAL: + case STR_COMPARE: { + /* + * Remember to keep code here in some sync with the byte-compiled + * versions in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and + * INST_STR_CMP as well as the expr string comparison in + * INST_EQ/INST_NEQ/INST_LT/...). + */ + + int i, match, length, nocase = 0, reqlength = -1; + typedef int (*strCmpFn_t)(const char *, const char *, unsigned int); + strCmpFn_t strCmpFn; + + if (objc < 4 || objc > 7) { + str_cmp_args: + Tcl_WrongNumArgs(interp, 2, objv, + "?-nocase? ?-length int? string1 string2"); + return TCL_ERROR; + } + + for (i = 2; i < objc-2; i++) { + string2 = Tcl_GetStringFromObj(objv[i], &length2); + if ((length2 > 1) + && strncmp(string2, "-nocase", (size_t)length2) == 0) { + nocase = 1; + } else if ((length2 > 1) + && strncmp(string2, "-length", (size_t)length2) == 0) { + if (i+1 >= objc-2) { + goto str_cmp_args; + } + if (Tcl_GetIntFromObj(interp, objv[++i], + &reqlength) != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_AppendResult(interp, "bad option \"", string2, + "\": must be -nocase or -length", (char *) NULL); + return TCL_ERROR; + } + } + + /* + * From now on, we only access the two objects at the end of the + * argument array. + */ + + objv += objc-2; + + if ((reqlength == 0) || (objv[0] == objv[1])) { + /* + * Always match at 0 chars of if it is the same obj. + */ + + Tcl_SetObjResult(interp, + Tcl_NewBooleanObj((enum options) index == STR_EQUAL)); + break; + } else if (!nocase && objv[0]->typePtr == &tclByteArrayType && + objv[1]->typePtr == &tclByteArrayType) { + /* + * Use binary versions of comparisons since that won't cause undue + * type conversions and it is much faster. Only do this if we're + * case-sensitive (which is all that really makes sense with byte + * arrays anyway, and we have no memcasecmp() for some + * reason... :^) + */ + + string1 = (char*) Tcl_GetByteArrayFromObj(objv[0], &length1); + string2 = (char*) Tcl_GetByteArrayFromObj(objv[1], &length2); + strCmpFn = (strCmpFn_t) memcmp; + } else if ((objv[0]->typePtr == &tclStringType) + && (objv[1]->typePtr == &tclStringType)) { + /* + * Do a unicode-specific comparison if both of the args are of + * String type. In benchmark testing this proved the most + * efficient check between the unicode and string comparison + * operations. + */ + + string1 = (char*) Tcl_GetUnicodeFromObj(objv[0], &length1); + string2 = (char*) Tcl_GetUnicodeFromObj(objv[1], &length2); + strCmpFn = (strCmpFn_t) + (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); + } else { + /* + * As a catch-all we will work with UTF-8. We cannot use memcmp() + * as that is unsafe with any string containing NULL (\xC0\x80 in + * Tcl's utf rep). We can use the more efficient TclpUtfNcmp2 if + * we are case-sensitive and no specific length was requested. + */ + + string1 = (char*) Tcl_GetStringFromObj(objv[0], &length1); + string2 = (char*) Tcl_GetStringFromObj(objv[1], &length2); + if ((reqlength < 0) && !nocase) { + strCmpFn = (strCmpFn_t) TclpUtfNcmp2; + } else { + length1 = Tcl_NumUtfChars(string1, length1); + length2 = Tcl_NumUtfChars(string2, length2); + strCmpFn = (strCmpFn_t) + (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); + } + } + + if (((enum options) index == STR_EQUAL) + && (reqlength < 0) && (length1 != length2)) { + match = 1; /* this will be reversed below */ + } else { + length = (length1 < length2) ? length1 : length2; + if (reqlength > 0 && reqlength < length) { + length = reqlength; + } else if (reqlength < 0) { + /* + * The requested length is negative, so we ignore it by + * setting it to length + 1 so we correct the match var. + */ + + reqlength = length + 1; + } + + match = strCmpFn(string1, string2, (unsigned) length); + if ((match == 0) && (reqlength > length)) { + match = length1 - length2; + } + } + + if ((enum options) index == STR_EQUAL) { + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1)); + } else { + Tcl_SetObjResult(interp, Tcl_NewIntObj( + (match > 0) ? 1 : (match < 0) ? -1 : 0)); + } + break; + } + case STR_FIRST: { + Tcl_UniChar *ustring1, *ustring2; + int match, start; + + if (objc < 4 || objc > 5) { + Tcl_WrongNumArgs(interp, 2, objv, "subString string ?startIndex?"); + return TCL_ERROR; + } + + /* + * We are searching string2 for the sequence string1. + */ + + match = -1; + start = 0; + length2 = -1; + + ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); + ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2); + + if (objc == 5) { + /* + * If a startIndex is specified, we will need to fast forward to + * that point in the string before we think about a match. + */ + + if (TclGetIntForIndex(interp, objv[4], length2 - 1, + &start) != TCL_OK) { + return TCL_ERROR; + } + if (start >= length2) { + goto str_first_done; + } else if (start > 0) { + ustring2 += start; + length2 -= start; + } else if (start < 0) { + /* + * Invalid start index mapped to string start; Bug #423581 + */ + + start = 0; + } + } + + if (length1 > 0) { + register Tcl_UniChar *p, *end; + + end = ustring2 + length2 - length1 + 1; + for (p = ustring2; p < end; p++) { + /* + * Scan forward to find the first character. + */ + if ((*p == *ustring1) && (TclUniCharNcmp(ustring1, p, + (unsigned long) length1) == 0)) { + match = p - ustring2; + break; + } + } + } + + /* + * Compute the character index of the matching string by counting the + * number of characters before the match. + */ + + if ((match != -1) && (objc == 5)) { + match += start; + } + + str_first_done: + Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); + break; + } + case STR_INDEX: { + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "string charIndex"); + return TCL_ERROR; + } + + /* + * If we have a ByteArray object, avoid indexing in the Utf string + * since the byte array contains one byte per character. Otherwise, + * use the Unicode string rep to get the index'th char. + */ + + if (objv[2]->typePtr == &tclByteArrayType) { + string1 = (char *) Tcl_GetByteArrayFromObj(objv[2], &length1); + + if (TclGetIntForIndex(interp, objv[3], length1 - 1, + &index) != TCL_OK) { + return TCL_ERROR; + } + if ((index >= 0) && (index < length1)) { + Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( + (unsigned char *)(&string1[index]), 1)); + } + } else { + /* + * Get Unicode char length to calulate what 'end' means. + */ + + length1 = Tcl_GetCharLength(objv[2]); + + if (TclGetIntForIndex(interp, objv[3], length1 - 1, + &index) != TCL_OK) { + return TCL_ERROR; + } + if ((index >= 0) && (index < length1)) { + char buf[TCL_UTF_MAX]; + Tcl_UniChar ch; + + ch = Tcl_GetUniChar(objv[2], index); + length1 = Tcl_UniCharToUtf(ch, buf); + Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length1)); + } + } + break; + } + case STR_IS: { + char *end; + Tcl_UniChar ch; + + /* + * The UniChar comparison function + */ + + int (*chcomp)(int) = NULL; + int i, failat = 0, result = 1, strict = 0; + Tcl_Obj *objPtr, *failVarObj = NULL; + Tcl_WideInt w; + + static CONST char *isOptions[] = { + "alnum", "alpha", "ascii", "control", + "boolean", "digit", "double", "false", + "graph", "integer", "lower", "print", + "punct", "space", "true", "upper", + "wideinteger", "wordchar", "xdigit", (char *) NULL + }; + enum isOptions { + STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, + STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_FALSE, + STR_IS_GRAPH, STR_IS_INT, STR_IS_LOWER, STR_IS_PRINT, + STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, + STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT + }; + + if (objc < 4 || objc > 7) { + Tcl_WrongNumArgs(interp, 2, objv, + "class ?-strict? ?-failindex var? str"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[2], isOptions, "class", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + if (objc != 4) { + for (i = 3; i < objc-1; i++) { + string2 = Tcl_GetStringFromObj(objv[i], &length2); + if ((length2 > 1) && + strncmp(string2, "-strict", (size_t) length2) == 0) { + strict = 1; + } else if ((length2 > 1) && + strncmp(string2, "-failindex", (size_t) length2) == 0){ + if (i+1 >= objc-1) { + Tcl_WrongNumArgs(interp, 3, objv, + "?-strict? ?-failindex var? str"); + return TCL_ERROR; + } + failVarObj = objv[++i]; + } else { + Tcl_AppendResult(interp, "bad option \"", string2, + "\": must be -strict or -failindex", (char *)NULL); + return TCL_ERROR; + } + } + } + + /* + * We get the objPtr so that we can short-cut for some classes by + * checking the object type (int and double), but we need the string + * otherwise, because we don't want any conversion of type occuring + * (as, for example, Tcl_Get*FromObj would do + */ + + objPtr = objv[objc-1]; + string1 = Tcl_GetStringFromObj(objPtr, &length1); + if (length1 == 0) { + if (strict) { + result = 0; + } + goto str_is_done; + } + end = string1 + length1; + + /* + * When entering here, result == 1 and failat == 0 + */ + + switch ((enum isOptions) index) { + case STR_IS_ALNUM: + chcomp = Tcl_UniCharIsAlnum; + break; + case STR_IS_ALPHA: + chcomp = Tcl_UniCharIsAlpha; + break; + case STR_IS_ASCII: + for (; string1 < end; string1++, failat++) { + /* + * This is a valid check in unicode, because all bytes less + * than 0xC0 are single byte chars (but isascii limits that + * def'n to 0x80). + */ + + if (*((unsigned char *)string1) >= 0x80) { + result = 0; + break; + } + } + break; + case STR_IS_BOOL: + case STR_IS_TRUE: + case STR_IS_FALSE: + if (TCL_OK != Tcl_ConvertToType(NULL, objPtr, &tclBooleanType)) { + result = 0; + } else if ((((enum isOptions) index == STR_IS_TRUE) && + objPtr->internalRep.longValue == 0) || + (((enum isOptions) index == STR_IS_FALSE) && + objPtr->internalRep.longValue != 0)) { + result = 0; + } + break; + case STR_IS_CONTROL: + chcomp = Tcl_UniCharIsControl; + break; + case STR_IS_DIGIT: + chcomp = Tcl_UniCharIsDigit; + break; + case STR_IS_DOUBLE: { + char *stop; + + /* TODO */ + if ((objPtr->typePtr == &tclDoubleType) || + (objPtr->typePtr == &tclIntType) || +#ifndef NO_WIDE_TYPE + (objPtr->typePtr == &tclWideIntType) || +#endif + (objPtr->typePtr == &tclBignumType)) { + break; + } + if (TclParseNumber( NULL, objPtr, NULL, NULL, -1, + (CONST char**) &stop, 0 ) != TCL_OK) { + result = 0; + failat = 0; + } else { + failat = stop - string1; + string1 = stop; + chcomp = Tcl_UniCharIsSpace; + } + break; + } + case STR_IS_GRAPH: + chcomp = Tcl_UniCharIsGraph; + break; + case STR_IS_INT: { + char *stop; + long int l = 0; + + if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &i)) { + break; + } + + /* + * Like STR_IS_DOUBLE, but we use strtoul. Since Tcl_GetIntFromObj + * already failed, we set result to 0. + */ + + result = 0; + errno = 0; + l = strtol(string1, &stop, 0); /* INTL: Tcl source. */ + if ((errno == ERANGE) || (l > INT_MAX) || (l < INT_MIN)) { + /* + * if (errno == ERANGE) or the long value won't fit in an int, + * then it was an over/underflow problem, but in this method, + * we only want to know yes or no, so bad flow returns 0 + * (false) and sets the failVarObj to the string length. + */ + + failat = -1; + } else if (stop == string1) { + /* + * In this case, nothing like a number was found + */ + + 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; + } + break; + } + case STR_IS_LOWER: + chcomp = Tcl_UniCharIsLower; + break; + case STR_IS_PRINT: + chcomp = Tcl_UniCharIsPrint; + break; + case STR_IS_PUNCT: + chcomp = Tcl_UniCharIsPunct; + break; + case STR_IS_SPACE: + chcomp = Tcl_UniCharIsSpace; + break; + case STR_IS_UPPER: + chcomp = Tcl_UniCharIsUpper; + break; + case STR_IS_WIDE: { + char *stop; + + if (TCL_OK == Tcl_GetWideIntFromObj(NULL, objPtr, &w)) { + break; + } + + /* + * Like STR_IS_DOUBLE, but we use strtoll. Since + * Tcl_GetWideIntFromObj already failed, we set result to 0. + */ + + result = 0; + errno = 0; + w = strtoll(string1, &stop, 0); /* INTL: Tcl source. */ + if (errno == ERANGE) { + /* + * if (errno == ERANGE), then it was an over/underflow + * problem, but in this method, we only want to know yes or + * no, so bad flow returns 0 (false) and sets the failVarObj + * to the string length. + */ + + failat = -1; + } else if (stop == string1) { + /* + * In this case, nothing like a number was found + */ + 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; + } + break; + } + case STR_IS_WORD: + chcomp = Tcl_UniCharIsWordChar; + break; + case STR_IS_XDIGIT: + for (; string1 < end; string1++, failat++) { + /* INTL: We assume unicode is bad for this class */ + if ((*((unsigned char *)string1) >= 0xC0) || + !isxdigit(*(unsigned char *)string1)) { + result = 0; + break; + } + } + break; + } + if (chcomp != NULL) { + for (; string1 < end; string1 += length2, failat++) { + length2 = TclUtfToUniChar(string1, &ch); + if (!chcomp(ch)) { + result = 0; + break; + } + } + } + + /* + * Only set the failVarObj when we will return 0 and we have indicated + * a valid fail index (>= 0). + */ + + str_is_done: + if ((result == 0) && (failVarObj != NULL) && + Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat), + TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); + break; + } + case STR_LAST: { + Tcl_UniChar *ustring1, *ustring2, *p; + int match, start; + + if (objc < 4 || objc > 5) { + Tcl_WrongNumArgs(interp, 2, objv, + "subString string ?startIndex?"); + return TCL_ERROR; + } + + /* + * We are searching string2 for the sequence string1. + */ + + match = -1; + start = 0; + length2 = -1; + + ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); + ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2); + + if (objc == 5) { + /* + * If a startIndex is specified, we will need to restrict the + * string range to that char index in the string + */ + + if (TclGetIntForIndex(interp, objv[4], length2 - 1, + &start) != TCL_OK) { + return TCL_ERROR; + } + if (start < 0) { + goto str_last_done; + } else if (start < length2) { + p = ustring2 + start + 1 - length1; + } else { + p = ustring2 + length2 - length1; + } + } else { + p = ustring2 + length2 - length1; + } + + if (length1 > 0) { + for (; p >= ustring2; p--) { + /* + * Scan backwards to find the first character. + */ + + if ((*p == *ustring1) && + (memcmp((char *) ustring1, (char *) p, (size_t) + (length1 * sizeof(Tcl_UniChar))) == 0)) { + match = p - ustring2; + break; + } + } + } + + str_last_done: + Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); + break; + } + case STR_BYTELENGTH: + case STR_LENGTH: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "string"); + return TCL_ERROR; + } + + if ((enum options) index == STR_BYTELENGTH) { + (void) Tcl_GetStringFromObj(objv[2], &length1); + } else { + /* + * If we have a ByteArray object, avoid recomputing the string + * since the byte array contains one byte per character. + * Otherwise, use the Unicode string rep to calculate the length. + */ + + if (objv[2]->typePtr == &tclByteArrayType) { + (void) Tcl_GetByteArrayFromObj(objv[2], &length1); + } else { + length1 = Tcl_GetCharLength(objv[2]); + } + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(length1)); + break; + case STR_MAP: { + int mapElemc, nocase = 0, mapWithDict = 0, copySource = 0; + Tcl_Obj **mapElemv, *sourceObj, *resultPtr; + Tcl_UniChar *ustring1, *ustring2, *p, *end; + int (*strCmpFn)(CONST Tcl_UniChar*, CONST Tcl_UniChar*, unsigned long); + + if (objc < 4 || objc > 5) { + Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? charMap string"); + return TCL_ERROR; + } + + if (objc == 5) { + string2 = Tcl_GetStringFromObj(objv[2], &length2); + if ((length2 > 1) && + strncmp(string2, "-nocase", (size_t) length2) == 0) { + nocase = 1; + } else { + Tcl_AppendResult(interp, "bad option \"", string2, + "\": must be -nocase", (char *) NULL); + return TCL_ERROR; + } + } + + /* + * This test is tricky, but has to be that way or you get other + * strange inconsistencies (see test string-10.20 for illustration + * why!) + */ + + if (objv[objc-2]->typePtr == &tclDictType && + objv[objc-2]->bytes == NULL) { + int i, done; + Tcl_DictSearch search; + + /* + * We know the type exactly, so all dict operations will succeed + * for sure. This shortens this code quite a bit. + */ + + Tcl_DictObjSize(interp, objv[objc-2], &mapElemc); + if (mapElemc == 0) { + /* + * empty charMap, just return whatever string was given + */ + + Tcl_SetObjResult(interp, objv[objc-1]); + return TCL_OK; + } + + mapElemc *= 2; + mapWithDict = 1; + + /* + * Copy the dictionary out into an array; that's the easiest way + * to adapt this code... + */ + + mapElemv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * mapElemc); + Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0, + mapElemv+1, &done); + for (i=2 ; i 5) { - Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? pattern string"); - return TCL_ERROR; - } - - if (objc == 5) { - string2 = Tcl_GetStringFromObj(objv[2], &length2); - if ((length2 > 1) && - strncmp(string2, "-nocase", (size_t) length2) == 0) { - nocase = 1; - } else { - Tcl_AppendResult(interp, "bad option \"", - string2, "\": must be -nocase", (char *) NULL); - return TCL_ERROR; - } - } - ustring1 = Tcl_GetUnicodeFromObj(objv[objc-1], &length1); - ustring2 = Tcl_GetUnicodeFromObj(objv[objc-2], &length2); - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(TclUniCharMatch( - ustring1, length1, ustring2, length2, nocase))); - break; - } - case STR_RANGE: { - int first, last; - - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "string first last"); - return TCL_ERROR; - } - - /* - * If we have a ByteArray object, avoid indexing in the - * Utf string since the byte array contains one byte per - * character. Otherwise, use the Unicode string rep to - * get the range. - */ - - if (objv[2]->typePtr == &tclByteArrayType) { - string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1); - length1--; - } else { - /* - * Get the length in actual characters. - */ - string1 = NULL; - length1 = Tcl_GetCharLength(objv[2]) - 1; - } - - if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK) - || (TclGetIntForIndex(interp, objv[4], length1, - &last) != TCL_OK)) { - return TCL_ERROR; - } - - if (first < 0) { - first = 0; - } - if (last >= length1) { - last = length1; - } - if (last >= first) { - if (string1 != NULL) { - int numBytes = last - first + 1; - Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( - (unsigned char *) &string1[first], numBytes)); - } else { - Tcl_SetObjResult(interp, - Tcl_GetRange(objv[2], first, last)); - } - } - break; - } - case STR_REPEAT: { - int count; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "string count"); - return TCL_ERROR; - } - - if (Tcl_GetIntFromObj(interp, objv[3], &count) != TCL_OK) { - return TCL_ERROR; - } - - if (count == 1) { - Tcl_SetObjResult(interp, objv[2]); - } else if (count > 1) { - string1 = Tcl_GetStringFromObj(objv[2], &length1); - if (length1 > 0) { - /* - * Only build up a string that has data. Instead of - * building it up with repeated appends, we just allocate - * the necessary space once and copy the string value in. - * Check for overflow with back-division. [Bug #714106] - */ - Tcl_Obj *resultPtr; - length2 = length1 * count; - if ((length2 / count) != length1) { - char buf[TCL_INTEGER_SPACE+1]; - sprintf(buf, "%d", INT_MAX); - Tcl_AppendResult(interp, - "string size overflow, must be less than ", - buf, (char *) NULL); - return TCL_ERROR; - } - /* - * Include space for the NULL - */ - string2 = (char *) ckalloc((size_t) length2+1); - for (index = 0; index < count; index++) { - memcpy(string2 + (length1 * index), string1, - (size_t) length1); - } - string2[length2] = '\0'; - /* - * We have to directly assign this instead of using - * Tcl_SetStringObj (and indirectly TclInitStringRep) - * because that makes another copy of the data. - */ - resultPtr = Tcl_NewObj(); - resultPtr->bytes = string2; - resultPtr->length = length2; - Tcl_SetObjResult(interp, resultPtr); - } - } - break; - } - case STR_REPLACE: { - Tcl_UniChar *ustring1; - int first, last; - - if (objc < 5 || objc > 6) { - Tcl_WrongNumArgs(interp, 2, objv, - "string first last ?string?"); - return TCL_ERROR; - } - - ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); - length1--; - - if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK) - || (TclGetIntForIndex(interp, objv[4], length1, - &last) != TCL_OK)) { - return TCL_ERROR; - } - - if ((last < first) || (last < 0) || (first > length1)) { - Tcl_SetObjResult(interp, objv[2]); - } else { - Tcl_Obj *resultPtr; - if (first < 0) { - first = 0; - } - - resultPtr = Tcl_NewUnicodeObj(ustring1, first); - if (objc == 6) { - Tcl_AppendObjToObj(resultPtr, objv[5]); - } - if (last < length1) { - Tcl_AppendUnicodeToObj(resultPtr, ustring1 + last + 1, - length1 - last); - } - Tcl_SetObjResult(interp, resultPtr); - } - break; - } - case STR_TOLOWER: - case STR_TOUPPER: - case STR_TOTITLE: - if (objc < 3 || objc > 5) { - Tcl_WrongNumArgs(interp, 2, objv, "string ?first? ?last?"); - return TCL_ERROR; - } - - string1 = Tcl_GetStringFromObj(objv[2], &length1); - - if (objc == 3) { - Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1); - if ((enum options) index == STR_TOLOWER) { - length1 = Tcl_UtfToLower(TclGetString(resultPtr)); - } else if ((enum options) index == STR_TOUPPER) { - length1 = Tcl_UtfToUpper(TclGetString(resultPtr)); - } else { - length1 = Tcl_UtfToTitle(TclGetString(resultPtr)); - } - Tcl_SetObjLength(resultPtr, length1); - Tcl_SetObjResult(interp, resultPtr); - } else { - int first, last; - CONST char *start, *end; - Tcl_Obj *resultPtr; - - length1 = Tcl_NumUtfChars(string1, length1) - 1; - if (TclGetIntForIndex(interp, objv[3], length1, - &first) != TCL_OK) { - return TCL_ERROR; - } - if (first < 0) { - first = 0; - } - last = first; - if ((objc == 5) && (TclGetIntForIndex(interp, objv[4], length1, - &last) != TCL_OK)) { - return TCL_ERROR; - } - if (last >= length1) { - last = length1; - } - if (last < first) { - Tcl_SetObjResult(interp, objv[2]); - break; - } - start = Tcl_UtfAtIndex(string1, first); - end = Tcl_UtfAtIndex(start, last - first + 1); - length2 = end-start; - string2 = ckalloc((size_t) length2+1); - memcpy(string2, start, (size_t) length2); - string2[length2] = '\0'; - if ((enum options) index == STR_TOLOWER) { - length2 = Tcl_UtfToLower(string2); - } else if ((enum options) index == STR_TOUPPER) { - length2 = Tcl_UtfToUpper(string2); - } else { - length2 = Tcl_UtfToTitle(string2); - } - resultPtr = Tcl_NewStringObj(string1, start - string1); - Tcl_AppendToObj(resultPtr, string2, length2); - Tcl_AppendToObj(resultPtr, end, -1); - Tcl_SetObjResult(interp, resultPtr); - ckfree(string2); - } - break; - - case STR_TRIM: { - Tcl_UniChar ch, trim; - register CONST char *p, *end; - char *check, *checkEnd; - int offset; - - left = 1; - right = 1; - - dotrim: - if (objc == 4) { - string2 = Tcl_GetStringFromObj(objv[3], &length2); - } else if (objc == 3) { - string2 = " \t\n\r"; - length2 = strlen(string2); - } else { - Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?"); - return TCL_ERROR; - } - string1 = Tcl_GetStringFromObj(objv[2], &length1); - checkEnd = string2 + length2; - - if (left) { - end = string1 + length1; - /* - * The outer loop iterates over the string. The inner - * loop iterates over the trim characters. The loops - * terminate as soon as a non-trim character is discovered - * and string1 is left pointing at the first non-trim - * character. - */ - - for (p = string1; p < end; p += offset) { - offset = TclUtfToUniChar(p, &ch); - - for (check = string2; ; ) { - if (check >= checkEnd) { - p = end; - break; - } - check += TclUtfToUniChar(check, &trim); - if (ch == trim) { - length1 -= offset; - string1 += offset; - break; - } - } - } - } - if (right) { - end = string1; - - /* - * The outer loop iterates over the string. The inner - * loop iterates over the trim characters. The loops - * terminate as soon as a non-trim character is discovered - * and length1 marks the last non-trim character. - */ - - for (p = string1 + length1; p > end; ) { - p = Tcl_UtfPrev(p, string1); - offset = TclUtfToUniChar(p, &ch); - for (check = string2; ; ) { - if (check >= checkEnd) { - p = end; - break; - } - check += TclUtfToUniChar(check, &trim); - if (ch == trim) { - length1 -= offset; - break; - } - } - } - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1)); - break; - } - case STR_TRIMLEFT: { - left = 1; - right = 0; - goto dotrim; - } - case STR_TRIMRIGHT: { - left = 0; - right = 1; - goto dotrim; - } - case STR_WORDEND: { - int cur; - Tcl_UniChar ch; - CONST char *p, *end; - int numChars; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "string index"); - return TCL_ERROR; - } - - string1 = Tcl_GetStringFromObj(objv[2], &length1); - numChars = Tcl_NumUtfChars(string1, length1); - if (TclGetIntForIndex(interp, objv[3], numChars-1, - &index) != TCL_OK) { - return TCL_ERROR; - } - if (index < 0) { - index = 0; - } - if (index < numChars) { - p = Tcl_UtfAtIndex(string1, index); - end = string1+length1; - for (cur = index; p < end; cur++) { - p += TclUtfToUniChar(p, &ch); - if (!Tcl_UniCharIsWordChar(ch)) { - break; - } - } - if (cur == index) { - cur++; - } - } else { - cur = numChars; - } - Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); - break; - } - case STR_WORDSTART: { - int cur; - Tcl_UniChar ch; - CONST char *p; - int numChars; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "string index"); - return TCL_ERROR; - } - - string1 = Tcl_GetStringFromObj(objv[2], &length1); - numChars = Tcl_NumUtfChars(string1, length1); - if (TclGetIntForIndex(interp, objv[3], numChars-1, - &index) != TCL_OK) { - return TCL_ERROR; - } - if (index >= numChars) { - index = numChars - 1; - } - cur = 0; - if (index > 0) { - p = Tcl_UtfAtIndex(string1, index); - for (cur = index; cur >= 0; cur--) { - TclUtfToUniChar(p, &ch); - if (!Tcl_UniCharIsWordChar(ch)) { - break; - } - p = Tcl_UtfPrev(p, string1); - } - if (cur != index) { - cur += 1; - } - } - Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); - break; - } + break; + } + end = ustring1 + length1; + + strCmpFn = (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); + + /* + * Force result to be Unicode + */ + resultPtr = Tcl_NewUnicodeObj(ustring1, 0); + + if (mapElemc == 2) { + /* + * Special case for one map pair which avoids the extra for loop + * and extra calls to get Unicode data. The algorithm is otherwise + * identical to the multi-pair case. This will be >30% faster on + * larger strings. + */ + + int mapLen; + Tcl_UniChar *mapString, u2lc; + + ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); + p = ustring1; + if ((length2 > length1) || (length2 == 0)) { + /* + * Match string is either longer than input or empty. + */ + + ustring1 = end; + } else { + mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen); + u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0); + for (; ustring1 < end; ustring1++) { + if (((*ustring1 == *ustring2) || + (nocase && Tcl_UniCharToLower(*ustring1)==u2lc)) && + (length2==1 || strCmpFn(ustring1, ustring2, + (unsigned long) length2) == 0)) { + if (p != ustring1) { + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); + p = ustring1 + length2; + } else { + p += length2; + } + ustring1 = p - 1; + + Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen); + } + } + } + } else { + Tcl_UniChar **mapStrings, *u2lc = NULL; + int *mapLens; + + /* + * Precompute pointers to the unicode string and length. This + * saves us repeated function calls later, significantly speeding + * up the algorithm. We only need the lowercase first char in the + * nocase case. + */ + + mapStrings = (Tcl_UniChar **) ckalloc((mapElemc * 2) + * sizeof(Tcl_UniChar *)); + mapLens = (int *) ckalloc((mapElemc * 2) * sizeof(int)); + if (nocase) { + u2lc = (Tcl_UniChar *) + ckalloc((mapElemc) * sizeof(Tcl_UniChar)); + } + for (index = 0; index < mapElemc; index++) { + mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], + &(mapLens[index])); + if (nocase && ((index % 2) == 0)) { + u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]); + } + } + for (p = ustring1; ustring1 < end; ustring1++) { + for (index = 0; index < mapElemc; index += 2) { + /* + * Get the key string to match on. + */ + + ustring2 = mapStrings[index]; + length2 = mapLens[index]; + if ((length2 > 0) && ((*ustring1 == *ustring2) || + (nocase && (Tcl_UniCharToLower(*ustring1) == + u2lc[index/2]))) && + /* restrict max compare length */ + ((end - ustring1) >= length2) && + ((length2 == 1) || strCmpFn(ustring2, ustring1, + (unsigned long) length2) == 0)) { + if (p != ustring1) { + /* + * Put the skipped chars onto the result first. + */ + + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); + p = ustring1 + length2; + } else { + p += length2; + } + + /* + * Adjust len to be full length of matched string. + */ + + ustring1 = p - 1; + + /* + * Append the map value to the unicode string. + */ + + Tcl_AppendUnicodeToObj(resultPtr, + mapStrings[index+1], mapLens[index+1]); + break; + } + } + } + ckfree((char *) mapStrings); + ckfree((char *) mapLens); + if (nocase) { + ckfree((char *) u2lc); + } + } + if (p != ustring1) { + /* + * Put the rest of the unmapped chars onto result. + */ + + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); + } + if (mapWithDict) { + ckfree((char *) mapElemv); + } + if (copySource) { + Tcl_DecrRefCount(sourceObj); + } + Tcl_SetObjResult(interp, resultPtr); + break; + } + case STR_MATCH: { + Tcl_UniChar *ustring1, *ustring2; + int nocase = 0; + + if (objc < 4 || objc > 5) { + Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? pattern string"); + return TCL_ERROR; + } + + if (objc == 5) { + string2 = Tcl_GetStringFromObj(objv[2], &length2); + if ((length2 > 1) && + strncmp(string2, "-nocase", (size_t) length2) == 0) { + nocase = 1; + } else { + Tcl_AppendResult(interp, "bad option \"", + string2, "\": must be -nocase", (char *) NULL); + return TCL_ERROR; + } + } + ustring1 = Tcl_GetUnicodeFromObj(objv[objc-1], &length1); + ustring2 = Tcl_GetUnicodeFromObj(objv[objc-2], &length2); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(TclUniCharMatch( + ustring1, length1, ustring2, length2, nocase))); + break; + } + case STR_RANGE: { + int first, last; + + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "string first last"); + return TCL_ERROR; + } + + /* + * If we have a ByteArray object, avoid indexing in the Utf string + * since the byte array contains one byte per character. Otherwise, + * use the Unicode string rep to get the range. + */ + + if (objv[2]->typePtr == &tclByteArrayType) { + string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1); + length1--; + } else { + /* + * Get the length in actual characters. + */ + + string1 = NULL; + length1 = Tcl_GetCharLength(objv[2]) - 1; + } + + if (TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK || + TclGetIntForIndex(interp, objv[4], length1, &last) != TCL_OK) { + return TCL_ERROR; + } + + if (first < 0) { + first = 0; + } + if (last >= length1) { + last = length1; + } + if (last >= first) { + if (string1 != NULL) { + int numBytes = last - first + 1; + Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( + (unsigned char *) &string1[first], numBytes)); + } else { + Tcl_SetObjResult(interp, + Tcl_GetRange(objv[2], first, last)); + } + } + break; + } + case STR_REPEAT: { + int count; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "string count"); + return TCL_ERROR; + } + + if (Tcl_GetIntFromObj(interp, objv[3], &count) != TCL_OK) { + return TCL_ERROR; + } + + if (count == 1) { + Tcl_SetObjResult(interp, objv[2]); + } else if (count > 1) { + string1 = Tcl_GetStringFromObj(objv[2], &length1); + if (length1 > 0) { + /* + * Only build up a string that has data. Instead of building + * it up with repeated appends, we just allocate the necessary + * space once and copy the string value in. Check for overflow + * with back-division. [Bug #714106] + */ + + Tcl_Obj *resultPtr; + + length2 = length1 * count; + if ((length2 / count) != length1) { + resultPtr = Tcl_NewObj(); + TclObjPrintf(NULL, resultPtr, + "string size overflow, must be less than %d", + INT_MAX); + Tcl_SetObjResult(interp, resultPtr); + return TCL_ERROR; + } + + /* + * Include space for the NULL. + */ + + string2 = (char *) ckalloc((size_t) length2+1); + for (index = 0; index < count; index++) { + memcpy(string2 + (length1 * index), string1, + (size_t) length1); + } + string2[length2] = '\0'; + + /* + * We have to directly assign this instead of using + * Tcl_SetStringObj (and indirectly TclInitStringRep) because + * that makes another copy of the data. + */ + + TclNewObj(resultPtr); + resultPtr->bytes = string2; + resultPtr->length = length2; + Tcl_SetObjResult(interp, resultPtr); + } + } + break; + } + case STR_REPLACE: { + Tcl_UniChar *ustring1; + int first, last; + + if (objc < 5 || objc > 6) { + Tcl_WrongNumArgs(interp, 2, objv, "string first last ?string?"); + return TCL_ERROR; + } + + ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); + length1--; + + if (TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK || + TclGetIntForIndex(interp, objv[4], length1, &last) != TCL_OK) { + return TCL_ERROR; + } + + if ((last < first) || (last < 0) || (first > length1)) { + Tcl_SetObjResult(interp, objv[2]); + } else { + Tcl_Obj *resultPtr; + if (first < 0) { + first = 0; + } + + resultPtr = Tcl_NewUnicodeObj(ustring1, first); + if (objc == 6) { + Tcl_AppendObjToObj(resultPtr, objv[5]); + } + if (last < length1) { + Tcl_AppendUnicodeToObj(resultPtr, ustring1 + last + 1, + length1 - last); + } + Tcl_SetObjResult(interp, resultPtr); + } + break; + } + case STR_TOLOWER: + case STR_TOUPPER: + case STR_TOTITLE: + if (objc < 3 || objc > 5) { + Tcl_WrongNumArgs(interp, 2, objv, "string ?first? ?last?"); + return TCL_ERROR; + } + + string1 = Tcl_GetStringFromObj(objv[2], &length1); + + if (objc == 3) { + Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1); + if ((enum options) index == STR_TOLOWER) { + length1 = Tcl_UtfToLower(TclGetString(resultPtr)); + } else if ((enum options) index == STR_TOUPPER) { + length1 = Tcl_UtfToUpper(TclGetString(resultPtr)); + } else { + length1 = Tcl_UtfToTitle(TclGetString(resultPtr)); + } + Tcl_SetObjLength(resultPtr, length1); + Tcl_SetObjResult(interp, resultPtr); + } else { + int first, last; + CONST char *start, *end; + Tcl_Obj *resultPtr; + + length1 = Tcl_NumUtfChars(string1, length1) - 1; + if (TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK){ + return TCL_ERROR; + } + if (first < 0) { + first = 0; + } + last = first; + + if ((objc == 5) && (TclGetIntForIndex(interp, objv[4], length1, + &last) != TCL_OK)) { + return TCL_ERROR; + } + + if (last >= length1) { + last = length1; + } + if (last < first) { + Tcl_SetObjResult(interp, objv[2]); + break; + } + + start = Tcl_UtfAtIndex(string1, first); + end = Tcl_UtfAtIndex(start, last - first + 1); + length2 = end-start; + string2 = ckalloc((size_t) length2+1); + memcpy(string2, start, (size_t) length2); + string2[length2] = '\0'; + + if ((enum options) index == STR_TOLOWER) { + length2 = Tcl_UtfToLower(string2); + } else if ((enum options) index == STR_TOUPPER) { + length2 = Tcl_UtfToUpper(string2); + } else { + length2 = Tcl_UtfToTitle(string2); + } + + resultPtr = Tcl_NewStringObj(string1, start - string1); + Tcl_AppendToObj(resultPtr, string2, length2); + Tcl_AppendToObj(resultPtr, end, -1); + Tcl_SetObjResult(interp, resultPtr); + ckfree(string2); + } + break; + + case STR_TRIMLEFT: + left = 1; + right = 0; + goto dotrim; + case STR_TRIMRIGHT: + left = 0; + right = 1; + goto dotrim; + case STR_TRIM: { + Tcl_UniChar ch, trim; + register CONST char *p, *end; + char *check, *checkEnd; + int offset; + + left = 1; + right = 1; + + dotrim: + if (objc == 4) { + string2 = Tcl_GetStringFromObj(objv[3], &length2); + } else if (objc == 3) { + string2 = " \t\n\r"; + length2 = strlen(string2); + } else { + Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?"); + return TCL_ERROR; + } + string1 = Tcl_GetStringFromObj(objv[2], &length1); + checkEnd = string2 + length2; + + if (left) { + end = string1 + length1; + /* + * The outer loop iterates over the string. The inner loop + * iterates over the trim characters. The loops terminate as soon + * as a non-trim character is discovered and string1 is left + * pointing at the first non-trim character. + */ + + for (p = string1; p < end; p += offset) { + offset = TclUtfToUniChar(p, &ch); + + for (check = string2; ; ) { + if (check >= checkEnd) { + p = end; + break; + } + check += TclUtfToUniChar(check, &trim); + if (ch == trim) { + length1 -= offset; + string1 += offset; + break; + } + } + } + } + if (right) { + end = string1; + + /* + * The outer loop iterates over the string. The inner loop + * iterates over the trim characters. The loops terminate as soon + * as a non-trim character is discovered and length1 marks the + * last non-trim character. + */ + + for (p = string1 + length1; p > end; ) { + p = Tcl_UtfPrev(p, string1); + offset = TclUtfToUniChar(p, &ch); + for (check = string2; ; ) { + if (check >= checkEnd) { + p = end; + break; + } + check += TclUtfToUniChar(check, &trim); + if (ch == trim) { + length1 -= offset; + break; + } + } + } + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1)); + break; + } + case STR_WORDEND: { + int cur; + Tcl_UniChar ch; + CONST char *p, *end; + int numChars; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "string index"); + return TCL_ERROR; + } + + string1 = Tcl_GetStringFromObj(objv[2], &length1); + numChars = Tcl_NumUtfChars(string1, length1); + if (TclGetIntForIndex(interp, objv[3], numChars-1, &index) != TCL_OK) { + return TCL_ERROR; + } + if (index < 0) { + index = 0; + } + if (index < numChars) { + p = Tcl_UtfAtIndex(string1, index); + end = string1+length1; + for (cur = index; p < end; cur++) { + p += TclUtfToUniChar(p, &ch); + if (!Tcl_UniCharIsWordChar(ch)) { + break; + } + } + if (cur == index) { + cur++; + } + } else { + cur = numChars; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); + break; + } + case STR_WORDSTART: { + int cur; + Tcl_UniChar ch; + CONST char *p; + int numChars; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "string index"); + return TCL_ERROR; + } + + string1 = Tcl_GetStringFromObj(objv[2], &length1); + numChars = Tcl_NumUtfChars(string1, length1); + if (TclGetIntForIndex(interp, objv[3], numChars-1, &index) != TCL_OK) { + return TCL_ERROR; + } + if (index >= numChars) { + index = numChars - 1; + } + cur = 0; + if (index > 0) { + p = Tcl_UtfAtIndex(string1, index); + for (cur = index; cur >= 0; cur--) { + TclUtfToUniChar(p, &ch); + if (!Tcl_UniCharIsWordChar(ch)) { + break; + } + p = Tcl_UtfPrev(p, string1); + } + if (cur != index) { + cur += 1; + } + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); + break; + } } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_SubstObjCmd -- * - * This procedure is invoked to process the "subst" Tcl command. - * See the user documentation for details on what it does. This - * command relies on Tcl_SubstObj() for its implementation. + * This procedure is invoked to process the "subst" Tcl command. See the + * user documentation for details on what it does. This command relies on + * Tcl_SubstObj() for its implementation. * * Results: * A standard Tcl result. * * Side effects: @@ -2413,20 +2448,20 @@ */ /* ARGSUSED */ int Tcl_SubstObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { static CONST char *substOptions[] = { "-nobackslashes", "-nocommands", "-novariables", (char *) NULL }; enum substOptions { - SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS + SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS }; Tcl_Obj *resultPtr; int optionIndex, flags, i; /* @@ -2433,31 +2468,26 @@ * Parse command-line options. */ flags = TCL_SUBST_ALL; for (i = 1; i < (objc-1); i++) { - if (Tcl_GetIndexFromObj(interp, objv[i], substOptions, - "switch", 0, &optionIndex) != TCL_OK) { - + if (Tcl_GetIndexFromObj(interp, objv[i], substOptions, "switch", 0, + &optionIndex) != TCL_OK) { return TCL_ERROR; } switch (optionIndex) { - case SUBST_NOBACKSLASHES: { - flags &= ~TCL_SUBST_BACKSLASHES; - break; - } - case SUBST_NOCOMMANDS: { - flags &= ~TCL_SUBST_COMMANDS; - break; - } - case SUBST_NOVARS: { - flags &= ~TCL_SUBST_VARIABLES; - break; - } - default: { - Tcl_Panic("Tcl_SubstObjCmd: bad option index to SubstOptions"); - } + case SUBST_NOBACKSLASHES: + flags &= ~TCL_SUBST_BACKSLASHES; + break; + case SUBST_NOCOMMANDS: + flags &= ~TCL_SUBST_COMMANDS; + break; + case SUBST_NOVARS: + flags &= ~TCL_SUBST_VARIABLES; + break; + default: + Tcl_Panic("Tcl_SubstObjCmd: bad option index to SubstOptions"); } } if (i != (objc-1)) { Tcl_WrongNumArgs(interp, 1, objv, "?-nobackslashes? ?-nocommands? ?-novariables? string"); @@ -2465,10 +2495,11 @@ } /* * Perform the substitution. */ + resultPtr = Tcl_SubstObj(interp, objv[i], flags); if (resultPtr == NULL) { return TCL_ERROR; } @@ -2499,43 +2530,55 @@ ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int i, j, index, mode, result, splitObjs, numMatchesSaved; + int i,j, index, mode, foundmode, result, splitObjs, numMatchesSaved, noCase; + int patternLength; char *pattern; Tcl_Obj *stringObj, *indexVarObj, *matchVarObj; Tcl_Obj *CONST *savedObjv = objv; Tcl_RegExp regExpr = NULL; + + /* + * If you add options that make -e and -g not unique prefixes of -exact or + * -glob, you *must* fix TclCompileSwitchCmd's option parser as well. + */ + static CONST char *options[] = { - "-exact", "-glob", "-indexvar", "-matchvar", "-regexp", "--", - NULL + "-exact", "-glob", "-indexvar", "-matchvar", "-nocase", "-regexp", + "--", NULL }; enum options { - OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_REGEXP, OPT_LAST + OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_NOCASE, OPT_REGEXP, + OPT_LAST }; + typedef int (*strCmpFn_t)(const char *, const char *); + strCmpFn_t strCmpFn = strcmp; mode = OPT_EXACT; + foundmode = 0; indexVarObj = NULL; matchVarObj = NULL; numMatchesSaved = 0; + noCase = 0; for (i = 1; i < objc; i++) { if (TclGetString(objv[i])[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } if (index == OPT_LAST) { i++; break; } /* - * Check for TIP#75 options specifying the variables to write - * regexp information into. + * Check for TIP#75 options specifying the variables to write regexp + * information into. */ if (index == OPT_INDEXV) { i++; if (i == objc) { @@ -2554,11 +2597,25 @@ (char *) NULL); return TCL_ERROR; } matchVarObj = objv[i]; numMatchesSaved = -1; + } else if (index == OPT_NOCASE) { + strCmpFn = strcasecmp; + noCase = 1; } else { + if (foundmode) { + /* + * Mode already set via -exact, -glob, or -regexp. + */ + + Tcl_AppendResult(interp, "bad option \"", + TclGetString(objv[i]), "\": ", options[mode], + " option already found", (char *) NULL); + return TCL_ERROR; + } + foundmode = 1; mode = index; } } if (objc - i < 2) { @@ -2580,12 +2637,12 @@ stringObj = objv[i]; objc -= i + 1; objv += i + 1; /* - * If all of the pattern/command pairs are lumped into a single - * argument, split them out again. + * If all of the pattern/command pairs are lumped into a single argument, + * split them out again. */ splitObjs = 0; if (objc == 1) { Tcl_Obj **listv; @@ -2606,25 +2663,24 @@ objv = listv; splitObjs = 1; } /* - * Complain if there is an odd number of words in the list of - * patterns and bodies. + * Complain if there is an odd number of words in the list of patterns and + * bodies. */ if (objc % 2) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "extra switch pattern with no body", NULL); /* - * Check if this can be due to a badly placed comment - * in the switch block. + * Check if this can be due to a badly placed comment in the switch + * block. * - * The following is an heuristic to detect the infamous - * "comment in switch" error: just check if a pattern - * begins with '#'. + * The following is an heuristic to detect the infamous "comment in + * switch" error: just check if a pattern begins with '#'. */ if (splitObjs) { for (i=0 ; i= objc) { /* - * This shouldn't happen since we've checked that the - * last body is not a continuation... + * This shouldn't happen since we've checked that the last body is + * not a continuation... */ + Tcl_Panic("fall-out when searching for body to match pattern"); } if (strcmp(TclGetString(objv[j]), "-") != 0) { break; } @@ -2821,22 +2884,17 @@ result = Tcl_EvalObjEx(interp, objv[j], 0); /* * Generate an error message if necessary. */ + if (result == TCL_ERROR) { - Tcl_Obj *msg = Tcl_NewStringObj("\n (\"", -1); - Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine); - Tcl_IncrRefCount(msg); - Tcl_IncrRefCount(errorLine); - TclAppendLimitedToObj(msg, pattern, -1, 50, ""); - Tcl_AppendToObj(msg,"\" arm line ", -1); - Tcl_AppendObjToObj(msg, errorLine); - Tcl_DecrRefCount(errorLine); - Tcl_AppendToObj(msg,")", -1); - TclAppendObjToErrorInfo(interp, msg); - Tcl_DecrRefCount(msg); + int limit = 50; + int overflow = (patternLength > limit); + TclFormatToErrorInfo(interp, "\n (\"%.*s%s\" arm line %d)", + (overflow ? limit : patternLength), pattern, + (overflow ? "..." : ""), interp->errorLine); } return result; } /* @@ -2843,11 +2901,11 @@ *---------------------------------------------------------------------- * * Tcl_TimeObjCmd -- * * This object-based procedure is invoked to process the "time" Tcl - * command. See the user documentation for details on what it does. + * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: @@ -2863,15 +2921,15 @@ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { register Tcl_Obj *objPtr; + Tcl_Obj *objs[4]; register int i, result; int count; double totalMicroSec; Tcl_Time start, stop; - char buf[100]; if (objc == 2) { count = 1; } else if (objc == 3) { result = Tcl_GetIntFromObj(interp, objv[2], &count); @@ -2880,11 +2938,11 @@ } } else { Tcl_WrongNumArgs(interp, 1, objv, "command ?count?"); return TCL_ERROR; } - + objPtr = objv[1]; i = count; Tcl_GetTime(&start); while (i-- > 0) { result = Tcl_EvalObjEx(interp, objPtr, 0); @@ -2891,78 +2949,101 @@ if (result != TCL_OK) { return result; } } Tcl_GetTime(&stop); - - totalMicroSec = ( ( (double) ( stop.sec - start.sec ) ) * 1.0e6 - + ( stop.usec - start.usec ) ); - sprintf(buf, "%.0f microseconds per iteration", - ((count <= 0) ? 0 : totalMicroSec/count)); - Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1)); + + totalMicroSec = (((double) (stop.sec - start.sec))*1.0e6 + + (stop.usec - start.usec)); + + if (count <= 1) { + /* + * Use int obj since we know time is not fractional. [Bug 1202178] + */ + + objs[0] = Tcl_NewIntObj((count <= 0) ? 0 : (int) totalMicroSec); + } else { + objs[0] = Tcl_NewDoubleObj(totalMicroSec/count); + } + + /* + * Construct the result as a list because many programs have always parsed + * at such (extracting the first element, typically). + */ + + objs[1] = Tcl_NewStringObj("microseconds", -1); + objs[2] = Tcl_NewStringObj("per", -1); + objs[3] = Tcl_NewStringObj("iteration", -1); + Tcl_SetObjResult(interp, Tcl_NewListObj(4, objs)); + return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_WhileObjCmd -- * - * This procedure is invoked to process the "while" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "while" Tcl command. See the + * user documentation for details on what it does. * - * With the bytecode compiler, this procedure is only called when - * a command name is computed at runtime, and is "while" or the name - * to which "while" was renamed: e.g., "set z while; $z {$i<100} {}" + * With the bytecode compiler, this procedure is only called when a + * command name is computed at runtime, and is "while" or the name to + * which "while" was renamed: e.g., "set z while; $z {$i<100} {}" * * Results: - * A standard Tcl result. + * A standard Tcl result. * * Side effects: - * See the user documentation. + * See the user documentation. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ + /* ARGSUSED */ int Tcl_WhileObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { int result, value; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "test command"); - return TCL_ERROR; + return TCL_ERROR; } while (1) { - result = Tcl_ExprBooleanObj(interp, objv[1], &value); - if (result != TCL_OK) { - return result; - } - if (!value) { - break; - } - result = Tcl_EvalObjEx(interp, objv[2], 0); - if ((result != TCL_OK) && (result != TCL_CONTINUE)) { - if (result == TCL_ERROR) { - char msg[32 + TCL_INTEGER_SPACE]; - - sprintf(msg, "\n (\"while\" body line %d)", - interp->errorLine); - Tcl_AddErrorInfo(interp, msg); - } - break; - } - } - if (result == TCL_BREAK) { - result = TCL_OK; - } - if (result == TCL_OK) { - Tcl_ResetResult(interp); - } - return result; -} + result = Tcl_ExprBooleanObj(interp, objv[1], &value); + if (result != TCL_OK) { + return result; + } + if (!value) { + break; + } + result = Tcl_EvalObjEx(interp, objv[2], 0); + if ((result != TCL_OK) && (result != TCL_CONTINUE)) { + if (result == TCL_ERROR) { + TclFormatToErrorInfo(interp, "\n (\"while\" body line %d)", + interp->errorLine); + } + break; + } + } + if (result == TCL_BREAK) { + result = TCL_OK; + } + if (result == TCL_OK) { + Tcl_ResetResult(interp); + } + return result; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclCompCmds.c ================================================================== --- generic/tclCompCmds.c +++ generic/tclCompCmds.c @@ -1,24 +1,105 @@ -/* +/* * tclCompCmds.c -- * * This file contains compilation procedures that compile various - * Tcl commands into a sequence of instructions ("bytecodes"). + * Tcl commands into a sequence of instructions ("bytecodes"). * * Copyright (c) 1997-1998 Sun Microsystems, Inc. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2002 ActiveState Corporation. + * Copyright (c) 2004-2005 by Donal K. Fellows. * * 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.59 2004/10/18 21:15:37 dgp Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.59.2.7 2005/08/15 20:46:02 dgp Exp $ */ #include "tclInt.h" #include "tclCompile.h" +/* + * Macro that encapsulates an efficiency trick that avoids a function call for + * the simplest of compiles. The ANSI C "prototype" for this macro is: + * + * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr, + * Tcl_Interp *interp); + */ + +#define CompileWord(envPtr, tokenPtr, interp) \ + if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \ + TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \ + (tokenPtr)[1].size), (envPtr)); \ + } else { \ + TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ + (envPtr)); \ + } + +/* + * Convenience macro for use when compiling bodies of commands. The ANSI C + * "prototype" for this macro is: + * + * static void CompileBody(CompileEnv *envPtr, Tcl_Token *tokenPtr, + * Tcl_Interp *interp); + */ + +#define CompileBody(envPtr, tokenPtr, interp) \ + TclCompileCmdWord((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ + (envPtr)) + +/* + * Convenience macro for use when pushing literals. The ANSI C "prototype" for + * this macro is: + * + * static void PushLiteral(CompileEnv *envPtr, + * const char *string, int length); + */ + +#define PushLiteral(envPtr, string, length) \ + TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr)) + +/* + * Macro to advance to the next token; it is more mnemonic than the address + * arithmetic that it replaces. The ANSI C "prototype" for this macro is: + * + * static Tcl_Token * TokenAfter(Tcl_Token *tokenPtr); + */ + +#define TokenAfter(tokenPtr) \ + ((tokenPtr) + ((tokenPtr)->numComponents + 1)) + +/* + * Macro to get the offset to the next instruction to be issued. The ANSI C + * "prototype" for this macro is: + * + * static int CurrentOffset(CompileEnv *envPtr); + */ + +#define CurrentOffset(envPtr) \ + ((envPtr)->codeNext - (envPtr)->codeStart) + +/* + * static int DeclareExceptionRange(CompileEnv *envPtr, int type); + * static int ExceptionRangeStarts(CompileEnv *envPtr, int index); + * static void ExceptionRangeEnds(CompileEnv *envPtr, int index); + * static void ExceptionRangeTarget(CompileEnv *envPtr, int index, LABEL); + */ + +#define DeclareExceptionRange(envPtr, type) \ + (((envPtr)->exceptDepth++), \ + ((envPtr)->maxExceptDepth = \ + TclMax((envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \ + (TclCreateExceptRange((type), (envPtr)))) +#define ExceptionRangeStarts(envPtr, index) \ + ((envPtr)->exceptArrayPtr[(index)].codeOffset = CurrentOffset(envPtr)) +#define ExceptionRangeEnds(envPtr, index) \ + ((envPtr)->exceptArrayPtr[(index)].numCodeBytes = \ + CurrentOffset(envPtr) - (envPtr)->exceptArrayPtr[(index)].codeOffset) +#define ExceptionRangeTarget(envPtr, index, targetType) \ + ((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr)) + /* * Prototypes for procedures defined later in this file: */ static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData)); @@ -37,13 +118,13 @@ /* * The structures below define the AuxData types defined in this file. */ AuxDataType tclForeachInfoType = { - "ForeachInfo", /* name */ - DupForeachInfo, /* dupProc */ - FreeForeachInfo /* freeProc */ + "ForeachInfo", /* name */ + DupForeachInfo, /* dupProc */ + FreeForeachInfo /* freeProc */ }; /* *---------------------------------------------------------------------- * @@ -50,100 +131,89 @@ * TclCompileAppendCmd -- * * Procedure called to compile the "append" command. * * Results: - * Returns TCL_OK for a successful compile. - * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "append" command - * at runtime. + * Instructions are added to envPtr to execute the "append" command at + * runtime. * *---------------------------------------------------------------------- */ int TclCompileAppendCmd(interp, parsePtr, envPtr) Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Parse *parsePtr; /* Points to a parse structure for the - * command created by Tcl_ParseCommand. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ CompileEnv *envPtr; /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr, *valueTokenPtr; int simpleVarName, isScalar, localIndex, numWords; numWords = parsePtr->numWords; if (numWords == 1) { - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } else if (numWords == 2) { /* * append varName == set varName */ - return TclCompileSetCmd(interp, parsePtr, envPtr); + return TclCompileSetCmd(interp, parsePtr, envPtr); } else if (numWords > 3) { /* * APPEND instructions currently only handle one value */ - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } /* - * Decide if we can use a frame slot for the var/array name or if we - * need to emit code to compute and push the name at runtime. We use a - * frame slot (entry in the array of local vars) if we are compiling a - * procedure body and if the name is simple text that does not include - * namespace qualifiers. + * Decide if we can use a frame slot for the var/array name or if we need + * to emit code to compute and push the name at runtime. We use a frame + * slot (entry in the array of local vars) if we are compiling a procedure + * body and if the name is simple text that does not include namespace + * qualifiers. */ - varTokenPtr = parsePtr->tokenPtr - + (parsePtr->tokenPtr->numComponents + 1); + varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar); /* - * We are doing an assignment, otherwise TclCompileSetCmd was called, - * so push the new value. This will need to be extended to push a - * value for each argument. + * We are doing an assignment, otherwise TclCompileSetCmd was called, so + * push the new value. This will need to be extended to push a value for + * each argument. */ if (numWords > 2) { - valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); - if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - TclEmitPush(TclRegisterNewLiteral(envPtr, - valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr); - } else { - TclCompileTokens(interp, valueTokenPtr+1, - valueTokenPtr->numComponents, envPtr); - } + valueTokenPtr = TokenAfter(varTokenPtr); + CompileWord(envPtr, valueTokenPtr, interp); } /* * Emit instructions to set/get the variable. */ if (simpleVarName) { if (isScalar) { - if (localIndex >= 0) { - if (localIndex <= 255) { - TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr); - } else { - TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr); - } - } else { + if (localIndex < 0) { TclEmitOpcode(INST_APPEND_STK, envPtr); + } else if (localIndex <= 255) { + TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr); } } else { - if (localIndex >= 0) { - if (localIndex <= 255) { - TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr); - } else { - TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr); - } - } else { + if (localIndex < 0) { TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr); + } else if (localIndex <= 255) { + TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr); } } } else { TclEmitOpcode(INST_APPEND_STK, envPtr); } @@ -157,29 +227,29 @@ * TclCompileBreakCmd -- * * Procedure called to compile the "break" command. * * Results: - * Returns TCL_OK for a successful compile. - * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "break" command - * at runtime. + * Instructions are added to envPtr to execute the "break" command at + * runtime. * *---------------------------------------------------------------------- */ int TclCompileBreakCmd(interp, parsePtr, envPtr) Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Parse *parsePtr; /* Points to a parse structure for the - * command created by Tcl_ParseCommand. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ CompileEnv *envPtr; /* Holds resulting instructions. */ { if (parsePtr->numWords != 1) { - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } /* * Emit a break instruction. */ @@ -194,16 +264,16 @@ * TclCompileCatchCmd -- * * Procedure called to compile the "catch" command. * * Results: - * Returns TCL_OK for a successful compile. - * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "catch" command - * at runtime. + * Instructions are added to envPtr to execute the "catch" command at + * runtime. * *---------------------------------------------------------------------- */ int @@ -212,137 +282,174 @@ Tcl_Parse *parsePtr; /* Points to a parse structure for the * command created by Tcl_ParseCommand. */ CompileEnv *envPtr; /* Holds resulting instructions. */ { JumpFixup jumpFixup; - Tcl_Token *cmdTokenPtr, *nameTokenPtr; + Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; CONST char *name; - int localIndex, nameChars, range, startOffset; + int resultIndex, optsIndex, nameChars, range; int savedStackDepth = envPtr->currStackDepth; /* - * If syntax does not match what we expect for [catch], do not - * compile. Let runtime checks determine if syntax has changed. - */ - if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { - return TCL_OUT_LINE_COMPILE; - } - - /* - * If a variable was specified and the catch command is at global level - * (not in a procedure), don't compile it inline: the payoff is - * too small. - */ - - if ((parsePtr->numWords == 3) && (envPtr->procPtr == NULL)) { - return TCL_OUT_LINE_COMPILE; - } - - /* - * Make sure the variable name, if any, has no substitutions and just - * refers to a local scaler. - */ - - localIndex = -1; - cmdTokenPtr = parsePtr->tokenPtr - + (parsePtr->tokenPtr->numComponents + 1); - if (parsePtr->numWords == 3) { - nameTokenPtr = cmdTokenPtr + (cmdTokenPtr->numComponents + 1); - if (nameTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - name = nameTokenPtr[1].start; - nameChars = nameTokenPtr[1].size; + * If syntax does not match what we expect for [catch], do not compile. + * Let runtime checks determine if syntax has changed. + */ + if ((parsePtr->numWords < 2) || (parsePtr->numWords > 4)) { + return TCL_ERROR; + } + + /* + * If variables were specified and the catch command is at global level + * (not in a procedure), don't compile it inline: the payoff is too small. + */ + + if ((parsePtr->numWords >= 3) && (envPtr->procPtr == NULL)) { + return TCL_ERROR; + } + + /* + * Make sure the variable names, if any, have no substitutions and just + * refer to local scalars. + */ + + resultIndex = optsIndex = -1; + cmdTokenPtr = TokenAfter(parsePtr->tokenPtr); + if (parsePtr->numWords >= 3) { + resultNameTokenPtr = TokenAfter(cmdTokenPtr); + /* DGP */ + if (resultNameTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + name = resultNameTokenPtr[1].start; + nameChars = resultNameTokenPtr[1].size; + if (!TclIsLocalScalar(name, nameChars)) { + return TCL_ERROR; + } + resultIndex = TclFindCompiledLocal(resultNameTokenPtr[1].start, + resultNameTokenPtr[1].size, /*create*/ 1, VAR_SCALAR, + envPtr->procPtr); + } else { + return TCL_ERROR; + } + /* DKF */ + if (parsePtr->numWords == 4) { + optsNameTokenPtr = TokenAfter(resultNameTokenPtr); + if (optsNameTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + name = optsNameTokenPtr[1].start; + nameChars = optsNameTokenPtr[1].size; if (!TclIsLocalScalar(name, nameChars)) { - return TCL_OUT_LINE_COMPILE; - } - localIndex = TclFindCompiledLocal(nameTokenPtr[1].start, - nameTokenPtr[1].size, /*create*/ 1, - /*flags*/ VAR_SCALAR, envPtr->procPtr); - } else { - return TCL_OUT_LINE_COMPILE; - } - } - - /* - * We will compile the catch command. Emit a beginCatch instruction at - * the start of the catch body: the subcommand it controls. - */ - - envPtr->exceptDepth++; - envPtr->maxExceptDepth = - TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + return TCL_ERROR; + } + optsIndex = TclFindCompiledLocal(optsNameTokenPtr[1].start, + optsNameTokenPtr[1].size, /*create*/ 1, VAR_SCALAR, + envPtr->procPtr); + } + } + + /* + * We will compile the catch command. Emit a beginCatch instruction at the + * start of the catch body: the subcommand it controls. + */ + + range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr); /* - * If the body is a simple word, compile the instructions to - * eval it. Otherwise, compile instructions to substitute its - * text without catching, a catch instruction that resets the - * stack to what it was before substituting the body, and then - * an instruction to eval the body. Care has to be taken to - * register the correct startOffset for the catch range so that - * errors in the substitution are not catched [Bug 219184] + * If the body is a simple word, compile the instructions to eval it. + * Otherwise, compile instructions to substitute its text without + * catching, a catch instruction that resets the stack to what it was + * before substituting the body, and then an instruction to eval the body. + * Care has to be taken to register the correct startOffset for the catch + * range so that errors in the substitution are not catched [Bug 219184] */ if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - startOffset = (envPtr->codeNext - envPtr->codeStart); - TclCompileCmdWord(interp, cmdTokenPtr+1, 1, envPtr); + ExceptionRangeStarts(envPtr, range); + CompileBody(envPtr, cmdTokenPtr, interp); + ExceptionRangeEnds(envPtr, range); } else { TclCompileTokens(interp, cmdTokenPtr+1, - cmdTokenPtr->numComponents, envPtr); - startOffset = (envPtr->codeNext - envPtr->codeStart); + cmdTokenPtr->numComponents, envPtr); + ExceptionRangeStarts(envPtr, range); TclEmitOpcode(INST_EVAL_STK, envPtr); + ExceptionRangeEnds(envPtr, range); } - envPtr->exceptArrayPtr[range].codeOffset = startOffset; - envPtr->exceptArrayPtr[range].numCodeBytes = - (envPtr->codeNext - envPtr->codeStart) - startOffset; /* * The "no errors" epilogue code: store the body's result into the - * variable (if any), push "0" (TCL_OK) as the catch's "no error" - * result, and jump around the "error case" code. + * variable (if any), push "0" (TCL_OK) as the catch's "no error" result, + * and jump around the "error case" code. Note that we issue the push of + * the return options first so that if alterations happen to the current + * interpreter state during the writing of the variable, we won't see + * them; this results in a slightly complex instruction issuing flow + * (can't exchange, only duplicate and pop). */ - if (localIndex != -1) { - if (localIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr); + if (resultIndex != -1) { + if (optsIndex != -1) { + TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr); + TclEmitInstInt4(INST_OVER, 1, envPtr); + } + if (resultIndex <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1, resultIndex, envPtr); } else { - TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); + TclEmitInstInt4(INST_STORE_SCALAR4, resultIndex, envPtr); + } + if (optsIndex != -1) { + TclEmitOpcode(INST_POP, envPtr); + if (optsIndex <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1, optsIndex, envPtr); + } else { + TclEmitInstInt4(INST_STORE_SCALAR4, optsIndex, envPtr); + } + TclEmitOpcode(INST_POP, envPtr); } } TclEmitOpcode(INST_POP, envPtr); - TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr); + PushLiteral(envPtr, "0", 1); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); /* * The "error case" code: store the body's result into the variable (if * any), then push the error result code. The initial PC offset here is - * the catch's error target. + * the catch's error target. Note that if we are saving the return + * options, we do that first so the preservation cannot get affected by + * any intermediate result handling. */ envPtr->currStackDepth = savedStackDepth; - envPtr->exceptArrayPtr[range].catchOffset = - (envPtr->codeNext - envPtr->codeStart); - if (localIndex != -1) { + ExceptionRangeTarget(envPtr, range, catchOffset); + if (resultIndex != -1) { + if (optsIndex != -1) { + TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr); + } TclEmitOpcode(INST_PUSH_RESULT, envPtr); - if (localIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr); + if (resultIndex <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1, resultIndex, envPtr); } else { - TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); + TclEmitInstInt4(INST_STORE_SCALAR4, resultIndex, envPtr); } TclEmitOpcode(INST_POP, envPtr); + if (optsIndex != -1) { + if (optsIndex <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1, optsIndex, envPtr); + } else { + TclEmitInstInt4(INST_STORE_SCALAR4, optsIndex, envPtr); + } + TclEmitOpcode(INST_POP, envPtr); + } } TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr); - /* - * Update the target of the jump after the "no errors" code, then emit - * an endCatch instruction at the end of the catch command. + * Update the target of the jump after the "no errors" code, then emit an + * endCatch instruction at the end of the catch command. */ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileCatchCmd: bad jump distance %d\n", - (envPtr->codeNext - envPtr->codeStart) - jumpFixup.codeOffset); + CurrentOffset(envPtr) - jumpFixup.codeOffset); } TclEmitOpcode(INST_END_CATCH, envPtr); envPtr->currStackDepth = savedStackDepth + 1; envPtr->exceptDepth--; @@ -355,16 +462,16 @@ * TclCompileContinueCmd -- * * Procedure called to compile the "continue" command. * * Results: - * Returns TCL_OK for a successful compile. - * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "continue" command - * at runtime. + * Instructions are added to envPtr to execute the "continue" command at + * runtime. * *---------------------------------------------------------------------- */ int @@ -377,11 +484,11 @@ /* * There should be no argument after the "continue". */ if (parsePtr->numWords != 1) { - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } /* * Emit a continue instruction. */ @@ -391,21 +498,532 @@ } /* *---------------------------------------------------------------------- * + * TclCompileDictCmd -- + * + * Procedure called to compile the "dict" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "dict" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileDictCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + int numWords, size, i; + const char *cmd; + Proc *procPtr = envPtr->procPtr; + + /* + * There must be at least one argument after the command. + */ + + if (parsePtr->numWords < 2) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + numWords = parsePtr->numWords-2; + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + + /* + * The following commands are in fairly common use and are possibly worth + * bytecoding: + * dict append + * dict create [*] + * dict exists [*] + * dict for + * dict get [*] + * dict incr + * dict keys [*] + * dict lappend + * dict set + * dict unset + * In practice, those that are pure-value operators (marked with [*]) can + * probably be left alone (except perhaps [dict get] which is very very + * common) and [dict update] should be considered instead (really big + * win!) + */ + + size = tokenPtr[1].size; + cmd = tokenPtr[1].start; + if (size==3 && strncmp(cmd, "set", 3)==0) { + Tcl_Token *varTokenPtr; + int dictVarIndex, nameChars; + const char *name; + + if (numWords < 3 || procPtr == NULL) { + return TCL_ERROR; + } + varTokenPtr = TokenAfter(tokenPtr); + tokenPtr = TokenAfter(varTokenPtr); + if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + name = varTokenPtr[1].start; + nameChars = varTokenPtr[1].size; + if (!TclIsLocalScalar(name, nameChars)) { + return TCL_ERROR; + } + dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR, + procPtr); + for (i=1 ; i 3 || procPtr == NULL) { + return TCL_ERROR; + } + varTokenPtr = TokenAfter(tokenPtr); + keyTokenPtr = TokenAfter(varTokenPtr); + if (numWords == 3) { + const char *word; + int numBytes, code; + Tcl_Obj *intObj; + + incrTokenPtr = TokenAfter(keyTokenPtr); + if (incrTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + 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 + * dependencies on shared strings so we should be safe. + */ + + if (!TclLooksLikeInt(word, numBytes)) { + return TCL_ERROR; + } +#endif + + /* + * Now try to really parse the number. + */ + + intObj = Tcl_NewStringObj(word, numBytes); + Tcl_IncrRefCount(intObj); + code = Tcl_GetIntFromObj(NULL, intObj, &incrAmount); + Tcl_DecrRefCount(intObj); + if (code != TCL_OK) { + return TCL_ERROR; + } + } + if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + name = varTokenPtr[1].start; + nameChars = varTokenPtr[1].size; + if (!TclIsLocalScalar(name, nameChars)) { + return TCL_ERROR; + } + dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR, + procPtr); + CompileWord(envPtr, keyTokenPtr, interp); + TclEmitInstInt4( INST_DICT_INCR_IMM, incrAmount, envPtr); + TclEmitInt4( dictVarIndex, envPtr); + return TCL_OK; + } else if (size==3 && strncmp(cmd, "get", 3)==0) { + /* + * Only compile this because we need INST_DICT_GET anyway. + */ + if (numWords < 2) { + return TCL_ERROR; + } + for (i=0 ; icurrStackDepth; + + if (numWords != 3 || procPtr == NULL) { + return TCL_ERROR; + } + + varsTokenPtr = TokenAfter(tokenPtr); + dictTokenPtr = TokenAfter(varsTokenPtr); + bodyTokenPtr = TokenAfter(dictTokenPtr); + if (varsTokenPtr->type != TCL_TOKEN_SIMPLE_WORD || + bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + + /* + * Check we've got a pair of variables and that they are local + * variables. Then extract their indices in the LVT. + */ + + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, varsTokenPtr[1].start, + varsTokenPtr[1].size); + if (Tcl_SplitList(NULL, Tcl_DStringValue(&buffer), &numWords, + &argv) != TCL_OK) { + Tcl_DStringFree(&buffer); + return TCL_ERROR; + } + Tcl_DStringFree(&buffer); + if (numWords != 2) { + ckfree((char *) argv); + return TCL_ERROR; + } + nameChars = strlen(argv[0]); + if (!TclIsLocalScalar(argv[0], nameChars)) { + ckfree((char *) argv); + return TCL_ERROR; + } + keyVarIndex = TclFindCompiledLocal(argv[0], nameChars, 1, VAR_SCALAR, + procPtr); + nameChars = strlen(argv[1]); + if (!TclIsLocalScalar(argv[1], nameChars)) { + ckfree((char *) argv); + return TCL_ERROR; + } + valueVarIndex = TclFindCompiledLocal(argv[1], nameChars, 1, VAR_SCALAR, + procPtr); + ckfree((char *) argv); + + /* + * Allocate a temporary variable to store the iterator reference. The + * variable will contain a Tcl_DictSearch reference which will be + * allocated by INST_DICT_FIRST and disposed when the variable is + * unset (at which point it should also have been finished with). + */ + + infoIndex = TclFindCompiledLocal(NULL, 0, 1, VAR_SCALAR, procPtr); + + /* + * Preparation complete; issue instructions. Note that this code + * issues fixed-sized jumps. That simplifies things a lot! + * + * First up, get the dictionary and start the iteration. No catching + * of errors at this point. + */ + + CompileWord(envPtr, dictTokenPtr, interp); + TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); + doneTargetOffset = CurrentOffset(envPtr); + TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); + + /* + * Now we catch errors from here on so that we can finalize the search + * started by Tcl_DictObjFirst above. + */ + + catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr); + ExceptionRangeStarts(envPtr, catchRange); + + /* + * Inside the iteration, write the loop variables. + */ + + bodyTargetOffset = CurrentOffset(envPtr); + TclEmitInstInt4( INST_STORE_SCALAR4, keyVarIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitInstInt4( INST_STORE_SCALAR4, valueVarIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + + /* + * Set up the loop exception targets. + */ + + loopRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); + ExceptionRangeStarts(envPtr, loopRange); + + /* + * Compile the loop body itself. It should be stack-neutral. + */ + + CompileBody(envPtr, bodyTokenPtr, interp); + envPtr->currStackDepth = savedStackDepth + 1; + TclEmitOpcode( INST_POP, envPtr); + envPtr->currStackDepth = savedStackDepth; + + /* + * Both exception target ranges (error and loop) end here. + */ + + ExceptionRangeEnds(envPtr, loopRange); + ExceptionRangeEnds(envPtr, catchRange); + + /* + * Continue (or just normally process) by getting the next pair of + * items from the dictionary and jumping back to the code to write + * them into variables if there is another pair. + */ + + ExceptionRangeTarget(envPtr, loopRange, continueOffset); + TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr); + jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr); + TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr); + + /* + * Otherwise we're done (the jump after the DICT_FIRST points here) + * and we need to pop the bogus key/value pair (pushed to keep stack + * calculations easy!) + */ + + jumpDisplacement = CurrentOffset(envPtr) - doneTargetOffset; + TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement, + envPtr->codeStart + doneTargetOffset); + TclEmitOpcode( INST_POP, envPtr); + TclEmitOpcode( INST_POP, envPtr); + + /* + * Now do the final cleanup for the no-error case (this is where we + * break out of the loop to) by force-terminating the iteration (if + * not already terminated), ditching the exception info and jumping to + * the last instruction for this command. In theory, this could be + * done using the "finally" clause (next generated) but this is + * faster. + */ + + ExceptionRangeTarget(envPtr, loopRange, breakOffset); + TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); + endTargetOffset = CurrentOffset(envPtr); + TclEmitInstInt4( INST_JUMP4, 0, envPtr); + + /* + * Error handler "finally" clause, which force-terminates the + * iteration and rethrows the error. + */ + + ExceptionRangeTarget(envPtr, catchRange, catchOffset); + TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); + TclEmitOpcode( INST_PUSH_RESULT, envPtr); + TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); + TclEmitOpcode( INST_RETURN_STK, envPtr); + + /* + * Final stage of the command (normal case) is that we push an empty + * object. This is done last to promote peephole optimization when + * it's dropped immediately. + */ + + jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset; + TclUpdateInstInt4AtPc(INST_JUMP4, jumpDisplacement, + envPtr->codeStart + endTargetOffset); + PushLiteral(envPtr, "", 0); + envPtr->exceptDepth -= 2; + return TCL_OK; + } else if (size==6 && strncmp(cmd, "update", 6)==0) { + const char *name; + int nameChars, dictIndex, keyTmpIndex, numVars, range; + Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr; + Tcl_DString localVarsLiteral; + + /* + * Parse the command. Expect the following: + * dict update ? ...? + */ + + if (numWords < 4 || numWords & 1 || procPtr == NULL) { + return TCL_ERROR; + } + numVars = numWords/2 - 1; + dictVarTokenPtr = TokenAfter(tokenPtr); + if (dictVarTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + name = dictVarTokenPtr[1].start; + nameChars = dictVarTokenPtr[1].size; + if (!TclIsLocalScalar(name, nameChars)) { + return TCL_ERROR; + } + dictIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR, + procPtr); + + Tcl_DStringInit(&localVarsLiteral); + keyTokenPtrs = (Tcl_Token **) ckalloc(sizeof(Tcl_Token*) * numVars); + tokenPtr = TokenAfter(dictVarTokenPtr); + for (i=0 ; itype != TCL_TOKEN_SIMPLE_WORD) { + Tcl_DStringFree(&localVarsLiteral); + ckfree((char *) keyTokenPtrs); + return TCL_ERROR; + } + name = tokenPtr[1].start; + nameChars = tokenPtr[1].size; + if (!TclIsLocalScalar(name, nameChars)) { + Tcl_DStringFree(&localVarsLiteral); + ckfree((char *) keyTokenPtrs); + return TCL_ERROR; + } else { + int localVar = TclFindCompiledLocal(name, nameChars, 1, + VAR_SCALAR, procPtr); + char buf[12]; + + sprintf(buf, "%d", localVar); + Tcl_DStringAppendElement(&localVarsLiteral, buf); + } + tokenPtr = TokenAfter(tokenPtr); + } + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + Tcl_DStringFree(&localVarsLiteral); + ckfree((char *) keyTokenPtrs); + return TCL_ERROR; + } + bodyTokenPtr = tokenPtr; + + keyTmpIndex = TclFindCompiledLocal(NULL, 0, 1, VAR_SCALAR, procPtr); + + for (i=0 ; iexceptDepth--; + + TclEmitInstInt4( INST_LOAD_SCALAR4, keyTmpIndex, envPtr); + PushLiteral(envPtr, Tcl_DStringValue(&localVarsLiteral), + Tcl_DStringLength(&localVarsLiteral)); + /* + * Any literal would do, but this one is handy... + */ + TclEmitInstInt4( INST_STORE_SCALAR4, keyTmpIndex, envPtr); + TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); + + TclEmitOpcode( INST_RETURN_STK, envPtr); + + Tcl_DStringFree(&localVarsLiteral); + ckfree((char *) keyTokenPtrs); + return TCL_OK; + } else if (size==6 && strncmp(cmd, "append", 6) == 0) { + Tcl_Token *varTokenPtr; + int dictVarIndex, nameChars; + const char *name; + + /* + * Arbirary safe limit; anyone exceeding it should stop worrying about + * speed quite so much. ;-) + */ + if (numWords < 3 || numWords > 100 || procPtr == NULL) { + return TCL_ERROR; + } + varTokenPtr = TokenAfter(tokenPtr); + tokenPtr = TokenAfter(varTokenPtr); + if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + name = varTokenPtr[1].start; + nameChars = varTokenPtr[1].size; + if (!TclIsLocalScalar(name, nameChars)) { + return TCL_ERROR; + } + dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR, + procPtr); + for (i=1 ; i 3) { + TclEmitInstInt1( INST_CONCAT1, numWords-2, envPtr); + } + TclEmitInstInt4( INST_DICT_APPEND, dictVarIndex, envPtr); + return TCL_OK; + } else if (size==7 && strncmp(cmd, "lappend", 7) == 0) { + Tcl_Token *varTokenPtr, *keyTokenPtr, *valueTokenPtr; + int dictVarIndex, nameChars; + const char *name; + + if (numWords != 3 || procPtr == NULL) { + return TCL_ERROR; + } + varTokenPtr = TokenAfter(tokenPtr); + keyTokenPtr = TokenAfter(varTokenPtr); + valueTokenPtr = TokenAfter(keyTokenPtr); + if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + name = varTokenPtr[1].start; + nameChars = varTokenPtr[1].size; + if (!TclIsLocalScalar(name, nameChars)) { + return TCL_ERROR; + } + dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR, + procPtr); + CompileWord(envPtr, keyTokenPtr, interp); + CompileWord(envPtr, valueTokenPtr, interp); + TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr); + return TCL_OK; + } + + /* + * Something we do not know how to compile. + */ + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileExprCmd -- * * Procedure called to compile the "expr" command. * * Results: - * Returns TCL_OK for a successful compile. - * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "expr" command - * at runtime. + * Instructions are added to envPtr to execute the "expr" command at + * runtime. * *---------------------------------------------------------------------- */ int @@ -416,16 +1034,15 @@ CompileEnv *envPtr; /* Holds resulting instructions. */ { Tcl_Token *firstWordPtr; if (parsePtr->numWords == 1) { - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } - firstWordPtr = parsePtr->tokenPtr - + (parsePtr->tokenPtr->numComponents + 1); - TclCompileExprWords(interp, firstWordPtr, (parsePtr->numWords-1), envPtr); + firstWordPtr = TokenAfter(parsePtr->tokenPtr); + TclCompileExprWords(interp, firstWordPtr, parsePtr->numWords-1, envPtr); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -433,16 +1050,16 @@ * TclCompileForCmd -- * * Procedure called to compile the "for" command. * * Results: - * Returns TCL_OK for a successful compile. - * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "for" command - * at runtime. + * Instructions are added to envPtr to execute the "for" command at + * runtime. * *---------------------------------------------------------------------- */ int TclCompileForCmd(interp, parsePtr, envPtr) @@ -456,56 +1073,51 @@ int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist; int bodyRange, nextRange; int savedStackDepth = envPtr->currStackDepth; if (parsePtr->numWords != 5) { - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } /* * If the test expression requires substitutions, don't compile the for * command inline. E.g., the expression might cause the loop to never * execute or execute forever, as in "for {} "$x > 5" {incr x} {}". */ - startTokenPtr = parsePtr->tokenPtr - + (parsePtr->tokenPtr->numComponents + 1); - testTokenPtr = startTokenPtr + (startTokenPtr->numComponents + 1); + startTokenPtr = TokenAfter(parsePtr->tokenPtr); + testTokenPtr = TokenAfter(startTokenPtr); if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } /* * Bail out also if the body or the next expression require substitutions * in order to insure correct behaviour [Bug 219166] */ - nextTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1); - bodyTokenPtr = nextTokenPtr + (nextTokenPtr->numComponents + 1); - if ((nextTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) + nextTokenPtr = TokenAfter(testTokenPtr); + bodyTokenPtr = TokenAfter(nextTokenPtr); + if ((nextTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) { - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } /* - * Create ExceptionRange records for the body and the "next" command. - * The "next" command's ExceptionRange supports break but not continue - * (and has a -1 continueOffset). + * Create ExceptionRange records for the body and the "next" command. The + * "next" command's ExceptionRange supports break but not continue (and + * has a -1 continueOffset). */ - envPtr->exceptDepth++; - envPtr->maxExceptDepth = - TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); - bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + bodyRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); /* * Inline compile the initial command. */ - TclCompileCmdWord(interp, startTokenPtr+1, - startTokenPtr->numComponents, envPtr); + CompileBody(envPtr, startTokenPtr, interp); TclEmitOpcode(INST_POP, envPtr); /* * Jump to the evaluation of the condition. This code uses the "loop * rotation" optimisation (which eliminates one branch from the loop). @@ -522,42 +1134,35 @@ /* * Compile the loop body. */ - bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart); - - TclCompileCmdWord(interp, bodyTokenPtr+1, - bodyTokenPtr->numComponents, envPtr); + bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange); + CompileBody(envPtr, bodyTokenPtr, interp); + ExceptionRangeEnds(envPtr, bodyRange); envPtr->currStackDepth = savedStackDepth + 1; - envPtr->exceptArrayPtr[bodyRange].numCodeBytes = - (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset; TclEmitOpcode(INST_POP, envPtr); /* * Compile the "next" subcommand. */ - nextCodeOffset = (envPtr->codeNext - envPtr->codeStart); - envPtr->currStackDepth = savedStackDepth; - TclCompileCmdWord(interp, nextTokenPtr+1, - nextTokenPtr->numComponents, envPtr); + nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange); + CompileBody(envPtr, nextTokenPtr, interp); + ExceptionRangeEnds(envPtr, nextRange); envPtr->currStackDepth = savedStackDepth + 1; - envPtr->exceptArrayPtr[nextRange].numCodeBytes = - (envPtr->codeNext - envPtr->codeStart) - - nextCodeOffset; TclEmitOpcode(INST_POP, envPtr); envPtr->currStackDepth = savedStackDepth; /* * Compile the test expression then emit the conditional jump that * terminates the for. */ - testCodeOffset = (envPtr->codeNext - envPtr->codeStart); + testCodeOffset = CurrentOffset(envPtr); jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { bodyCodeOffset += 3; nextCodeOffset += 3; @@ -566,36 +1171,36 @@ envPtr->currStackDepth = savedStackDepth; TclCompileExprWords(interp, testTokenPtr, 1, envPtr); envPtr->currStackDepth = savedStackDepth + 1; - jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset; + jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; if (jumpDist > 127) { TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); } else { TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr); } /* - * Set the loop's offsets and break target. + * Fix the starting points of the exception ranges (may have moved due to + * jump type modification) and set where the exceptions target. */ envPtr->exceptArrayPtr[bodyRange].codeOffset = bodyCodeOffset; envPtr->exceptArrayPtr[bodyRange].continueOffset = nextCodeOffset; envPtr->exceptArrayPtr[nextRange].codeOffset = nextCodeOffset; - envPtr->exceptArrayPtr[bodyRange].breakOffset = - envPtr->exceptArrayPtr[nextRange].breakOffset = - (envPtr->codeNext - envPtr->codeStart); + ExceptionRangeTarget(envPtr, bodyRange, breakOffset); + ExceptionRangeTarget(envPtr, nextRange, breakOffset); /* * The for command's result is an empty string. */ envPtr->currStackDepth = savedStackDepth; - TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); + PushLiteral(envPtr, "", 0); envPtr->exceptDepth--; return TCL_OK; } @@ -605,16 +1210,16 @@ * TclCompileForeachCmd -- * * Procedure called to compile the "foreach" command. * * Results: - * Returns TCL_OK for a successful compile. - * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "foreach" command - * at runtime. + * Instructions are added to envPtr to execute the "foreach" command at + * runtime. * n*---------------------------------------------------------------------- */ int @@ -655,154 +1260,152 @@ * If the foreach command isn't in a procedure, don't compile it inline: * the payoff is too small. */ if (procPtr == NULL) { - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } numWords = parsePtr->numWords; if ((numWords < 4) || (numWords%2 != 0)) { - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } /* - * Bail out if the body requires substitutions - * in order to insure correct behaviour [Bug 219166] + * Bail out if the body requires substitutions in order to insure correct + * behaviour [Bug 219166] */ - for (i = 0, tokenPtr = parsePtr->tokenPtr; - i < numWords-1; - i++, tokenPtr += (tokenPtr->numComponents + 1)) { + for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; i++) { + tokenPtr = TokenAfter(tokenPtr); } bodyTokenPtr = tokenPtr; if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } /* * Allocate storage for the varcList and varvList arrays if necessary. */ numLists = (numWords - 2)/2; if (numLists > STATIC_VAR_LIST_SIZE) { - varcList = (int *) ckalloc(numLists * sizeof(int)); - varvList = (CONST char ***) ckalloc(numLists * sizeof(CONST char **)); + varcList = (int *) ckalloc(numLists * sizeof(int)); + varvList = (CONST char ***) ckalloc(numLists * sizeof(CONST char **)); } for (loopIndex = 0; loopIndex < numLists; loopIndex++) { - varcList[loopIndex] = 0; - varvList[loopIndex] = NULL; + varcList[loopIndex] = 0; + varvList[loopIndex] = NULL; } /* - * Set the exception stack depth. - */ - - envPtr->exceptDepth++; - envPtr->maxExceptDepth = - TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); - - /* - * Break up each var list and set the varcList and varvList arrays. - * Don't compile the foreach inline if any var name needs substitutions - * or isn't a scalar, or if any var list needs substitutions. + * Break up each var list and set the varcList and varvList arrays. Don't + * compile the foreach inline if any var name needs substitutions or isn't + * a scalar, or if any var list needs substitutions. */ loopIndex = 0; for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; - i++, tokenPtr += (tokenPtr->numComponents + 1)) { - if (i%2 == 1) { - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - code = TCL_OUT_LINE_COMPILE; - goto done; - } else { - /* Lots of copying going on here. Need a ListObj wizard - * to show a better way. */ - - Tcl_DString varList; - - Tcl_DStringInit(&varList); - Tcl_DStringAppend(&varList, tokenPtr[1].start, - tokenPtr[1].size); - code = Tcl_SplitList(interp, Tcl_DStringValue(&varList), - &varcList[loopIndex], &varvList[loopIndex]); - Tcl_DStringFree(&varList); - if (code != TCL_OK) { - code = TCL_OUT_LINE_COMPILE; - goto done; - } - numVars = varcList[loopIndex]; - for (j = 0; j < numVars; j++) { - CONST char *varName = varvList[loopIndex][j]; - if (!TclIsLocalScalar(varName, (int) strlen(varName))) { - code = TCL_OUT_LINE_COMPILE; - goto done; - } - } - } - loopIndex++; - } - } - - /* - * We will compile the foreach command. - * Reserve (numLists + 1) temporary variables: + i++, tokenPtr = TokenAfter(tokenPtr)) { + Tcl_DString varList; + + if (i%2 != 1) { + continue; + } + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + code = TCL_ERROR; + goto done; + } + + /* + * Lots of copying going on here. Need a ListObj wizard to show a + * better way. + */ + + Tcl_DStringInit(&varList); + Tcl_DStringAppend(&varList, tokenPtr[1].start, tokenPtr[1].size); + code = Tcl_SplitList(interp, Tcl_DStringValue(&varList), + &varcList[loopIndex], &varvList[loopIndex]); + Tcl_DStringFree(&varList); + if (code != TCL_OK) { + code = TCL_ERROR; + goto done; + } + numVars = varcList[loopIndex]; + for (j = 0; j < numVars; j++) { + CONST char *varName = varvList[loopIndex][j]; + if (!TclIsLocalScalar(varName, (int) strlen(varName))) { + code = TCL_ERROR; + goto done; + } + } + loopIndex++; + } + + /* + * We will compile the foreach command. Reserve (numLists + 1) temporary + * variables: * - numLists temps to hold each value list * - 1 temp for the loop counter (index of next element in each list) + * * At this time we don't try to reuse temporaries; if there are two * nonoverlapping foreach loops, they don't share any temps. */ code = TCL_OK; firstValueTemp = -1; for (loopIndex = 0; loopIndex < numLists; loopIndex++) { tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, - /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr); + /*create*/ 1, VAR_SCALAR, procPtr); if (loopIndex == 0) { firstValueTemp = tempVar; } } loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0, - /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr); + /*create*/ 1, VAR_SCALAR, procPtr); /* * Create and initialize the ForeachInfo and ForeachVarList data * structures describing this command. Then create a AuxData record * pointing to the ForeachInfo structure. */ infoPtr = (ForeachInfo *) ckalloc((unsigned) - (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *)))); + sizeof(ForeachInfo) + numLists*sizeof(ForeachVarList *)); infoPtr->numLists = numLists; infoPtr->firstValueTemp = firstValueTemp; infoPtr->loopCtTemp = loopCtTemp; for (loopIndex = 0; loopIndex < numLists; loopIndex++) { ForeachVarList *varListPtr; numVars = varcList[loopIndex]; varListPtr = (ForeachVarList *) ckalloc((unsigned) - sizeof(ForeachVarList) + (numVars * sizeof(int))); + sizeof(ForeachVarList) + numVars*sizeof(int)); varListPtr->numVars = numVars; for (j = 0; j < numVars; j++) { CONST char *varName = varvList[loopIndex][j]; int nameChars = strlen(varName); varListPtr->varIndexes[j] = TclFindCompiledLocal(varName, - nameChars, /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr); + nameChars, /*create*/ 1, VAR_SCALAR, procPtr); } infoPtr->varLists[loopIndex] = varListPtr; } infoIndex = TclCreateAuxData((ClientData) infoPtr, &tclForeachInfoType, envPtr); + /* + * Create an exception record to handle [break] and [continue]. + */ + + range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); + /* * Evaluate then store each value list in the associated temporary. */ - range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); - loopIndex = 0; for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; - i++, tokenPtr += (tokenPtr->numComponents + 1)) { + i++, tokenPtr = TokenAfter(tokenPtr)) { if ((i%2 == 0) && (i > 0)) { TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); tempVar = (firstValueTemp + loopIndex); @@ -825,39 +1428,33 @@ /* * Top of loop code: assign each loop variable and check whether * to terminate the loop. */ - envPtr->exceptArrayPtr[range].continueOffset = - (envPtr->codeNext - envPtr->codeStart); + ExceptionRangeTarget(envPtr, range, continueOffset); TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); /* * Inline compile the loop body. */ - envPtr->exceptArrayPtr[range].codeOffset = - (envPtr->codeNext - envPtr->codeStart); - TclCompileCmdWord(interp, bodyTokenPtr+1, - bodyTokenPtr->numComponents, envPtr); + ExceptionRangeStarts(envPtr, range); + CompileBody(envPtr, bodyTokenPtr, interp); + ExceptionRangeEnds(envPtr, range); envPtr->currStackDepth = savedStackDepth + 1; - envPtr->exceptArrayPtr[range].numCodeBytes = - (envPtr->codeNext - envPtr->codeStart) - - envPtr->exceptArrayPtr[range].codeOffset; TclEmitOpcode(INST_POP, envPtr); /* - * Jump back to the test at the top of the loop. Generate a 4 byte jump - * if the distance to the test is > 120 bytes. This is conservative and + * Jump back to the test at the top of the loop. Generate a 4 byte jump if + * the distance to the test is > 120 bytes. This is conservative and * ensures that we won't have to replace this jump if we later need to * replace the ifFalse jump with a 4 byte jump. */ - jumpBackOffset = (envPtr->codeNext - envPtr->codeStart); - jumpBackDist = - (jumpBackOffset - envPtr->exceptArrayPtr[range].continueOffset); + jumpBackOffset = CurrentOffset(envPtr); + jumpBackDist = jumpBackOffset-envPtr->exceptArrayPtr[range].continueOffset; if (jumpBackDist > 120) { TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr); } else { TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr); } @@ -890,30 +1487,29 @@ /* * Set the loop's break target. */ - envPtr->exceptArrayPtr[range].breakOffset = - (envPtr->codeNext - envPtr->codeStart); + ExceptionRangeTarget(envPtr, range, breakOffset); /* * The foreach command's result is an empty string. */ envPtr->currStackDepth = savedStackDepth; - TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); + PushLiteral(envPtr, "", 0); envPtr->currStackDepth = savedStackDepth + 1; - done: + done: for (loopIndex = 0; loopIndex < numLists; loopIndex++) { if (varvList[loopIndex] != (CONST char **) NULL) { ckfree((char *) varvList[loopIndex]); } } if (varcList != varcListStaticSpace) { ckfree((char *) varcList); - ckfree((char *) varvList); + ckfree((char *) varvList); } envPtr->exceptDepth--; return code; } @@ -920,22 +1516,22 @@ /* *---------------------------------------------------------------------- * * DupForeachInfo -- * - * This procedure duplicates a ForeachInfo structure created as - * auxiliary data during the compilation of a foreach command. + * This procedure duplicates a ForeachInfo structure created as auxiliary + * data during the compilation of a foreach command. * * Results: * A pointer to a newly allocated copy of the existing ForeachInfo * structure is returned. * * Side effects: * Storage for the copied ForeachInfo record is allocated. If the - * original ForeachInfo structure pointed to any ForeachVarList - * records, these structures are also copied and pointers to them - * are stored in the new ForeachInfo record. + * original ForeachInfo structure pointed to any ForeachVarList records, + * these structures are also copied and pointers to them are stored in + * the new ForeachInfo record. * *---------------------------------------------------------------------- */ static ClientData @@ -948,20 +1544,20 @@ register ForeachVarList *srcListPtr, *dupListPtr; int numLists = srcPtr->numLists; int numVars, i, j; dupPtr = (ForeachInfo *) ckalloc((unsigned) - (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *)))); + sizeof(ForeachInfo) + numLists*sizeof(ForeachVarList *)); dupPtr->numLists = numLists; dupPtr->firstValueTemp = srcPtr->firstValueTemp; dupPtr->loopCtTemp = srcPtr->loopCtTemp; for (i = 0; i < numLists; i++) { srcListPtr = srcPtr->varLists[i]; numVars = srcListPtr->numVars; dupListPtr = (ForeachVarList *) ckalloc((unsigned) - sizeof(ForeachVarList) + numVars*sizeof(int)); + sizeof(ForeachVarList) + numVars*sizeof(int)); dupListPtr->numVars = numVars; for (j = 0; j < numVars; j++) { dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j]; } dupPtr->varLists[i] = dupListPtr; @@ -1011,70 +1607,70 @@ * TclCompileIfCmd -- * * Procedure called to compile the "if" command. * * Results: - * Returns TCL_OK for a successful compile. - * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "if" command - * at runtime. + * Instructions are added to envPtr to execute the "if" command at + * runtime. * *---------------------------------------------------------------------- */ int TclCompileIfCmd(interp, parsePtr, envPtr) Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Parse *parsePtr; /* Points to a parse structure for the - * command created by Tcl_ParseCommand. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ CompileEnv *envPtr; /* Holds resulting instructions. */ { JumpFixupArray jumpFalseFixupArray; /* Used to fix the ifFalse jump after each * test when its target PC is determined. */ JumpFixupArray jumpEndFixupArray; - /* Used to fix the jump after each "then" - * body to the end of the "if" when that PC - * is determined. */ + /* Used to fix the jump after each "then" body + * to the end of the "if" when that PC is + * determined. */ Tcl_Token *tokenPtr, *testTokenPtr; int jumpFalseDist; - int jumpIndex = 0; /* avoid compiler warning. */ + int jumpIndex = 0; /* avoid compiler warning. */ int numWords, wordIdx, numBytes, j, code; CONST char *word; int savedStackDepth = envPtr->currStackDepth; - /* Saved stack depth at the start of the first + /* Saved stack depth at the start of the first * test; the envPtr current depth is restored * to this value at the start of each test. */ - int realCond = 1; /* set to 0 for static conditions: "if 0 {..}" */ - int boolVal; /* value of static condition */ - int compileScripts = 1; + int realCond = 1; /* set to 0 for static conditions: "if 0 {..}" */ + int boolVal; /* value of static condition */ + int compileScripts = 1; /* - * Only compile the "if" command if all arguments are simple - * words, in order to insure correct substitution [Bug 219166] + * Only compile the "if" command if all arguments are simple words, in + * order to insure correct substitution [Bug 219166] */ tokenPtr = parsePtr->tokenPtr; wordIdx = 0; numWords = parsePtr->numWords; for (wordIdx = 0; wordIdx < numWords; wordIdx++) { if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } - tokenPtr += 2; + tokenPtr = TokenAfter(tokenPtr); } TclInitJumpFixupArray(&jumpFalseFixupArray); TclInitJumpFixupArray(&jumpEndFixupArray); code = TCL_OK; /* - * Each iteration of this loop compiles one "if expr ?then? body" - * or "elseif expr ?then? body" clause. + * Each iteration of this loop compiles one "if expr ?then? body" or + * "elseif expr ?then? body" clause. */ tokenPtr = parsePtr->tokenPtr; wordIdx = 0; while (wordIdx < numWords) { @@ -1083,33 +1679,33 @@ */ word = tokenPtr[1].start; numBytes = tokenPtr[1].size; if ((tokenPtr == parsePtr->tokenPtr) - || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) { - tokenPtr += (tokenPtr->numComponents + 1); + || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) { + tokenPtr = TokenAfter(tokenPtr); wordIdx++; } else { break; } if (wordIdx >= numWords) { - code = TCL_OUT_LINE_COMPILE; + code = TCL_ERROR; goto done; } /* - * Compile the test expression then emit the conditional jump - * around the "then" part. + * Compile the test expression then emit the conditional jump around + * the "then" part. */ envPtr->currStackDepth = savedStackDepth; testTokenPtr = tokenPtr; if (realCond) { /* - * Find out if the condition is a constant. + * Find out if the condition is a constant. */ Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size); Tcl_IncrRefCount(boolObj); @@ -1130,34 +1726,34 @@ TclExpandJumpFixupArray(&jumpFalseFixupArray); } jumpIndex = jumpFalseFixupArray.next; jumpFalseFixupArray.next++; TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, - &(jumpFalseFixupArray.fixup[jumpIndex])); + jumpFalseFixupArray.fixup+jumpIndex); } code = TCL_OK; } /* * Skip over the optional "then" before the then clause. */ - tokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1); + tokenPtr = TokenAfter(testTokenPtr); wordIdx++; if (wordIdx >= numWords) { - code = TCL_OUT_LINE_COMPILE; + code = TCL_ERROR; goto done; } if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { word = tokenPtr[1].start; numBytes = tokenPtr[1].size; if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) { - tokenPtr += (tokenPtr->numComponents + 1); + tokenPtr = TokenAfter(tokenPtr); wordIdx++; if (wordIdx >= numWords) { - code = TCL_OUT_LINE_COMPILE; + code = TCL_ERROR; goto done; } } } @@ -1165,119 +1761,115 @@ * Compile the "then" command body. */ if (compileScripts) { envPtr->currStackDepth = savedStackDepth; - TclCompileCmdWord(interp, tokenPtr+1, - tokenPtr->numComponents, envPtr); + CompileBody(envPtr, tokenPtr, interp); } if (realCond) { /* - * Jump to the end of the "if" command. Both jumpFalseFixupArray and - * jumpEndFixupArray are indexed by "jumpIndex". + * Jump to the end of the "if" command. Both jumpFalseFixupArray + * and jumpEndFixupArray are indexed by "jumpIndex". */ if (jumpEndFixupArray.next >= jumpEndFixupArray.end) { TclExpandJumpFixupArray(&jumpEndFixupArray); } jumpEndFixupArray.next++; TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &(jumpEndFixupArray.fixup[jumpIndex])); + jumpEndFixupArray.fixup+jumpIndex); /* - * Fix the target of the jumpFalse after the test. Generate a 4 byte - * jump if the distance is > 120 bytes. This is conservative, and - * ensures that we won't have to replace this jump if we later also - * need to replace the proceeding jump to the end of the "if" with a - * 4 byte jump. + * Fix the target of the jumpFalse after the test. Generate a 4 + * byte jump if the distance is > 120 bytes. This is conservative, + * and ensures that we won't have to replace this jump if we later + * also need to replace the proceeding jump to the end of the "if" + * with a 4 byte jump. */ if (TclFixupForwardJumpToHere(envPtr, - &(jumpFalseFixupArray.fixup[jumpIndex]), 120)) { + jumpFalseFixupArray.fixup+jumpIndex, 120)) { /* * Adjust the code offset for the proceeding jump to the end * of the "if" command. */ jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3; } } else if (boolVal) { - /* - *We were processing an "if 1 {...}"; stop compiling - * scripts + /* + * We were processing an "if 1 {...}"; stop compiling scripts. */ compileScripts = 0; } else { - /* - *We were processing an "if 0 {...}"; reset so that - * the rest (elseif, else) is compiled correctly + /* + * We were processing an "if 0 {...}"; reset so that the rest + * (elseif, else) is compiled correctly. */ realCond = 1; compileScripts = 1; - } + } - tokenPtr += (tokenPtr->numComponents + 1); + tokenPtr = TokenAfter(tokenPtr); wordIdx++; } /* - * Restore the current stack depth in the environment; the - * "else" clause (or its default) will add 1 to this. + * Restore the current stack depth in the environment; the "else" clause + * (or its default) will add 1 to this. */ envPtr->currStackDepth = savedStackDepth; /* - * Check for the optional else clause. Do not compile - * anything if this was an "if 1 {...}" case. + * Check for the optional else clause. Do not compile anything if this was + * an "if 1 {...}" case. */ - if ((wordIdx < numWords) - && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { + if ((wordIdx < numWords) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { /* * There is an else clause. Skip over the optional "else" word. */ word = tokenPtr[1].start; numBytes = tokenPtr[1].size; if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) { - tokenPtr += (tokenPtr->numComponents + 1); + tokenPtr = TokenAfter(tokenPtr); wordIdx++; if (wordIdx >= numWords) { - code = TCL_OUT_LINE_COMPILE; + code = TCL_ERROR; goto done; } } if (compileScripts) { /* * Compile the else command body. */ - TclCompileCmdWord(interp, tokenPtr+1, - tokenPtr->numComponents, envPtr); + CompileBody(envPtr, tokenPtr, interp); } /* * Make sure there are no words after the else clause. */ wordIdx++; if (wordIdx < numWords) { - code = TCL_OUT_LINE_COMPILE; + code = TCL_ERROR; goto done; } } else { /* * No else clause: the "if" command's result is an empty string. */ if (compileScripts) { - TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); + PushLiteral(envPtr, "", 0); } } /* * Fix the unconditional jumps to the end of the "if" command. @@ -1284,18 +1876,18 @@ */ for (j = jumpEndFixupArray.next; j > 0; j--) { jumpIndex = (j - 1); /* i.e. process the closest jump first */ if (TclFixupForwardJumpToHere(envPtr, - &(jumpEndFixupArray.fixup[jumpIndex]), 127)) { + jumpEndFixupArray.fixup+jumpIndex, 127)) { /* - * Adjust the immediately preceeding "ifFalse" jump. We moved - * it's target (just after this jump) down three bytes. + * Adjust the immediately preceeding "ifFalse" jump. We moved it's + * target (just after this jump) down three bytes. */ unsigned char *ifFalsePc = envPtr->codeStart - + jumpFalseFixupArray.fixup[jumpIndex].codeOffset; + + jumpFalseFixupArray.fixup[jumpIndex].codeOffset; unsigned char opCode = *ifFalsePc; if (opCode == INST_JUMP_FALSE1) { jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1); jumpFalseDist += 3; TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1)); @@ -1302,20 +1894,20 @@ } else if (opCode == INST_JUMP_FALSE4) { jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1); jumpFalseDist += 3; TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); } else { - Tcl_Panic("TclCompileIfCmd: unexpected opcode updating ifFalse jump"); + Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode); } } } /* * Free the jumpFixupArray array if malloc'ed storage was used. */ - done: + done: envPtr->currStackDepth = savedStackDepth + 1; TclFreeJumpFixupArray(&jumpFalseFixupArray); TclFreeJumpFixupArray(&jumpEndFixupArray); return code; } @@ -1326,16 +1918,16 @@ * TclCompileIncrCmd -- * * Procedure called to compile the "incr" command. * * Results: - * Returns TCL_OK for a successful compile. - * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "incr" command - * at runtime. + * Instructions are added to envPtr to execute the "incr" command at + * runtime. * *---------------------------------------------------------------------- */ int @@ -1347,64 +1939,60 @@ { Tcl_Token *varTokenPtr, *incrTokenPtr; int simpleVarName, isScalar, localIndex, haveImmValue, immValue; if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } - varTokenPtr = parsePtr->tokenPtr - + (parsePtr->tokenPtr->numComponents + 1); + varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarName(interp, varTokenPtr, envPtr, - (TCL_NO_LARGE_INDEX | TCL_CREATE_VAR), + PushVarName(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX|TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar); /* * If an increment is given, push it, but see first if it's a small * integer. */ haveImmValue = 0; - immValue = 0; + immValue = 1; if (parsePtr->numWords == 3) { - incrTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + incrTokenPtr = TokenAfter(varTokenPtr); if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { CONST char *word = incrTokenPtr[1].start; int numBytes = incrTokenPtr[1].size; - int validLength = TclParseInteger(word, numBytes); - long n; - +#if 0 /* * Note there is a danger that modifying the string could have - * undesirable side effects. In this case, TclLooksLikeInt and - * TclGetLong do not have any dependencies on shared strings so we - * should be safe. + * undesirable side effects. In this case, TclLooksLikeInt has + * no dependencies on shared strings so we should be safe. */ - if (validLength == numBytes) { + if (TclLooksLikeInt(word, numBytes)) { +#endif int code; - Tcl_Obj *longObj = Tcl_NewStringObj(word, numBytes); - Tcl_IncrRefCount(longObj); - code = Tcl_GetLongFromObj(NULL, longObj, &n); - Tcl_DecrRefCount(longObj); - if ((code == TCL_OK) && (-127 <= n) && (n <= 127)) { + Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes); + Tcl_IncrRefCount(intObj); + code = Tcl_GetIntFromObj(NULL, intObj, &immValue); + Tcl_DecrRefCount(intObj); + if ((code == TCL_OK) + && (-127 <= immValue) && (immValue <= 127)) { haveImmValue = 1; - immValue = n; } +#if 0 } +#endif if (!haveImmValue) { - TclEmitPush( - TclRegisterNewLiteral(envPtr, word, numBytes), envPtr); + PushLiteral(envPtr, word, numBytes); } } else { - TclCompileTokens(interp, incrTokenPtr+1, - incrTokenPtr->numComponents, envPtr); + TclCompileTokens(interp, incrTokenPtr+1, + incrTokenPtr->numComponents, envPtr); } } else { /* no incr amount given so use 1 */ haveImmValue = 1; - immValue = 1; } /* * Emit the instruction to increment the variable. */ @@ -1458,16 +2046,16 @@ * TclCompileLappendCmd -- * * Procedure called to compile the "lappend" command. * * Results: - * Returns TCL_OK for a successful compile. - * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "lappend" command - * at runtime. + * Instructions are added to envPtr to execute the "lappend" command at + * runtime. * *---------------------------------------------------------------------- */ int @@ -1475,59 +2063,52 @@ Tcl_Interp *interp; /* Used for error reporting. */ Tcl_Parse *parsePtr; /* Points to a parse structure for the * command created by Tcl_ParseCommand. */ CompileEnv *envPtr; /* Holds resulting instructions. */ { - Tcl_Token *varTokenPtr, *valueTokenPtr; + Tcl_Token *varTokenPtr; int simpleVarName, isScalar, localIndex, numWords; /* * If we're not in a procedure, don't compile. */ if (envPtr->procPtr == NULL) { - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } numWords = parsePtr->numWords; if (numWords == 1) { - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } if (numWords != 3) { /* * LAPPEND instructions currently only handle one value appends */ - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } /* * Decide if we can use a frame slot for the var/array name or if we * need to emit code to compute and push the name at runtime. We use a * frame slot (entry in the array of local vars) if we are compiling a * procedure body and if the name is simple text that does not include - * namespace qualifiers. + * namespace qualifiers. */ - varTokenPtr = parsePtr->tokenPtr - + (parsePtr->tokenPtr->numComponents + 1); + varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar); /* - * If we are doing an assignment, push the new value. - * In the no values case, create an empty object. + * If we are doing an assignment, push the new value. In the no values + * case, create an empty object. */ if (numWords > 2) { - valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); - if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - TclEmitPush(TclRegisterNewLiteral(envPtr, - valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr); - } else { - TclCompileTokens(interp, valueTokenPtr+1, - valueTokenPtr->numComponents, envPtr); - } + Tcl_Token *valueTokenPtr = TokenAfter(varTokenPtr); + CompileWord(envPtr, valueTokenPtr, interp); } /* * Emit instructions to set/get the variable. */ @@ -1536,28 +2117,24 @@ * The *_STK opcodes should be refactored to make better use of existing * LOAD/STORE instructions. */ if (simpleVarName) { if (isScalar) { - if (localIndex >= 0) { - if (localIndex <= 255) { - TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr); - } else { - TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr); - } - } else { + if (localIndex < 0) { TclEmitOpcode(INST_LAPPEND_STK, envPtr); + } else if (localIndex <= 255) { + TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr); } } else { - if (localIndex >= 0) { - if (localIndex <= 255) { - TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr); - } else { - TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr); - } - } else { + if (localIndex < 0) { TclEmitOpcode(INST_LAPPEND_ARRAY_STK, envPtr); + } else if (localIndex <= 255) { + TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr); } } } else { TclEmitOpcode(INST_LAPPEND_STK, envPtr); } @@ -1571,16 +2148,16 @@ * TclCompileLassignCmd -- * * Procedure called to compile the "lassign" command. * * Results: - * Returns TCL_OK for a successful compile. - * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "lassign" command - * at runtime. + * Instructions are added to envPtr to execute the "lassign" command at + * runtime. * *---------------------------------------------------------------------- */ int @@ -1596,39 +2173,34 @@ numWords = parsePtr->numWords; /* * Check for command syntax error, but we'll punt that to runtime */ if (numWords < 3) { - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } /* * Generate code to push list being taken apart by [lassign]. */ - tokenPtr = parsePtr->tokenPtr + (parsePtr->tokenPtr->numComponents + 1); - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - TclEmitPush(TclRegisterNewLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size), envPtr); - } else { - TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); - } + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp); /* * Generate code to assign values from the list to variables */ for (idx=0 ; idxnumComponents + 1; + tokenPtr = TokenAfter(tokenPtr); /* * Generate the next variable name */ PushVarName(interp, tokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar); /* - * Emit instructions to get the idx'th item out of the list - * value on the stack and assign it to the variable. + * Emit instructions to get the idx'th item out of the list value on + * the stack and assign it to the variable. */ if (simpleVarName) { if (isScalar) { if (localIndex >= 0) { TclEmitOpcode(INST_DUP, envPtr); @@ -1681,61 +2253,85 @@ * TclCompileLindexCmd -- * * Procedure called to compile the "lindex" command. * * Results: - * Returns TCL_OK for a successful compile. - * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "lindex" command - * at runtime. + * Instructions are added to envPtr to execute the "lindex" command at + * runtime. * *---------------------------------------------------------------------- */ int TclCompileLindexCmd(interp, parsePtr, envPtr) Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Parse *parsePtr; /* Points to a parse structure for the - * command created by Tcl_ParseCommand. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ CompileEnv *envPtr; /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr; - int i, numWords; - numWords = parsePtr->numWords; + int i, numWords = parsePtr->numWords; /* * Quit if too few args */ if (numWords <= 1) { - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } - varTokenPtr = parsePtr->tokenPtr - + (parsePtr->tokenPtr->numComponents + 1); + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + + 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; + + tmpObj = Tcl_NewStringObj(varTokenPtr[1].start, varTokenPtr[1].size); + result = Tcl_GetIntFromObj(NULL, tmpObj, &idx); + TclDecrRefCount(tmpObj); + + if (result == TCL_OK && idx >= 0) { + /* + * All checks have been completed, and we have exactly this + * construct: + * lindex + * This is best compiled as a push of the arbitrary value followed + * by an "immediate lindex" which is the most efficient variety. + */ + + varTokenPtr = TokenAfter(varTokenPtr); + CompileWord(envPtr, varTokenPtr, interp); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + return TCL_OK; + } + + /* + * If the conversion failed or the value was negative, we just keep on + * going with the more complex compilation. + */ + } /* * Push the operands onto the stack. */ for (i=1 ; itype == TCL_TOKEN_SIMPLE_WORD) { - TclEmitPush( - TclRegisterNewLiteral(envPtr, varTokenPtr[1].start, - varTokenPtr[1].size), envPtr); - } else { - TclCompileTokens(interp, varTokenPtr+1, - varTokenPtr->numComponents, envPtr); - } - varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + CompileWord(envPtr, varTokenPtr, interp); + varTokenPtr = TokenAfter(varTokenPtr); } /* - * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI - * if there are multiple index args. + * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI if there are + * multiple index args. */ if (numWords == 3) { TclEmitOpcode(INST_LIST_INDEX, envPtr); } else { @@ -1751,60 +2347,53 @@ * TclCompileListCmd -- * * Procedure called to compile the "list" command. * * Results: - * Returns TCL_OK for a successful compile. - * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "list" command - * at runtime. + * Instructions are added to envPtr to execute the "list" command at + * runtime. * *---------------------------------------------------------------------- */ int TclCompileListCmd(interp, parsePtr, envPtr) Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Parse *parsePtr; /* Points to a parse structure for the - * command created by Tcl_ParseCommand. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ CompileEnv *envPtr; /* Holds resulting instructions. */ { /* * If we're not in a procedure, don't compile. */ if (envPtr->procPtr == NULL) { - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } if (parsePtr->numWords == 1) { /* - * Empty args case + * [list] without arguments just pushes an empty object. */ - TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); + PushLiteral(envPtr, "", 0); } else { /* * Push the all values onto the stack. */ Tcl_Token *valueTokenPtr; int i, numWords; numWords = parsePtr->numWords; - valueTokenPtr = parsePtr->tokenPtr - + (parsePtr->tokenPtr->numComponents + 1); + valueTokenPtr = TokenAfter(parsePtr->tokenPtr); for (i = 1; i < numWords; i++) { - if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - TclEmitPush(TclRegisterNewLiteral(envPtr, - valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr); - } else { - TclCompileTokens(interp, valueTokenPtr+1, - valueTokenPtr->numComponents, envPtr); - } - valueTokenPtr = valueTokenPtr + (valueTokenPtr->numComponents + 1); + CompileWord(envPtr, valueTokenPtr, interp); + valueTokenPtr = TokenAfter(valueTokenPtr); } TclEmitInstInt4(INST_LIST, numWords - 1, envPtr); } return TCL_OK; @@ -1816,46 +2405,35 @@ * TclCompileLlengthCmd -- * * Procedure called to compile the "llength" command. * * Results: - * Returns TCL_OK for a successful compile. - * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "llength" command - * at runtime. + * Instructions are added to envPtr to execute the "llength" command at + * runtime. * *---------------------------------------------------------------------- */ int TclCompileLlengthCmd(interp, parsePtr, envPtr) Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Parse *parsePtr; /* Points to a parse structure for the - * command created by Tcl_ParseCommand. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ CompileEnv *envPtr; /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr; if (parsePtr->numWords != 2) { - return TCL_OUT_LINE_COMPILE; - } - varTokenPtr = parsePtr->tokenPtr - + (parsePtr->tokenPtr->numComponents + 1); - - if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - /* - * We could simply count the number of elements here and push - * that value, but that is too rare a case to waste the code space. - */ - TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start, - varTokenPtr[1].size), envPtr); - } else { - TclCompileTokens(interp, varTokenPtr+1, - varTokenPtr->numComponents, envPtr); - } + return TCL_ERROR; + } + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + + CompileWord(envPtr, varTokenPtr, interp); TclEmitOpcode(INST_LIST_LENGTH, envPtr); return TCL_OK; } /* @@ -1864,98 +2442,88 @@ * TclCompileLsetCmd -- * * Procedure called to compile the "lset" command. * * Results: - * Returns TCL_OK for a successful compile. - * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "lset" command - * at runtime. + * Instructions are added to envPtr to execute the "lset" command at + * runtime. * * The general template for execution of the "lset" command is: - * (1) Instructions to push the variable name, unless the - * variable is local to the stack frame. - * (2) If the variable is an array element, instructions - * to push the array element name. - * (3) Instructions to push each of zero or more "index" arguments - * to the stack, followed with the "newValue" element. - * (4) Instructions to duplicate the variable name and/or array - * element name onto the top of the stack, if either was - * pushed at steps (1) and (2). - * (5) The appropriate INST_LOAD_* instruction to place the - * original value of the list variable at top of stack. + * (1) Instructions to push the variable name, unless the variable is + * local to the stack frame. + * (2) If the variable is an array element, instructions to push the + * array element name. + * (3) Instructions to push each of zero or more "index" arguments to the + * stack, followed with the "newValue" element. + * (4) Instructions to duplicate the variable name and/or array element + * name onto the top of the stack, if either was pushed at steps (1) + * and (2). + * (5) The appropriate INST_LOAD_* instruction to place the original + * value of the list variable at top of stack. * (6) At this point, the stack contains: - * varName? arrayElementName? index1 index2 ... newValue oldList + * varName? arrayElementName? index1 index2 ... newValue oldList * The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST - * according as whether there is exactly one index element (LIST) - * or either zero or else two or more (FLAT). This instruction - * removes everything from the stack except for the two names - * and pushes the new value of the variable. - * (7) Finally, INST_STORE_* stores the new value in the variable - * and cleans up the stack. + * according as whether there is exactly one index element (LIST) or + * either zero or else two or more (FLAT). This instruction removes + * everything from the stack except for the two names and pushes the + * new value of the variable. + * (7) Finally, INST_STORE_* stores the new value in the variable and + * cleans up the stack. * *---------------------------------------------------------------------- */ int TclCompileLsetCmd(interp, parsePtr, envPtr) Tcl_Interp* interp; /* Tcl interpreter for error reporting */ - Tcl_Parse* parsePtr; /* Points to a parse structure for - * the command */ + Tcl_Parse* parsePtr; /* Points to a parse structure for the + * command */ CompileEnv* envPtr; /* Holds the resulting instructions */ { - int tempDepth; /* Depth used for emitting one part - * of the code burst. */ - Tcl_Token* varTokenPtr; /* Pointer to the Tcl_Token representing - * the parse of the variable name */ + int tempDepth; /* Depth used for emitting one part of the + * code burst. */ + Tcl_Token* varTokenPtr; /* Pointer to the Tcl_Token representing the + * parse of the variable name */ int localIndex; /* Index of var in local var table */ int simpleVarName; /* Flag == 1 if var name is simple */ int isScalar; /* Flag == 1 if scalar, 0 if array */ int i; /* Check argument count */ if (parsePtr->numWords < 3) { /* Fail at run time, not in compilation */ - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } /* - * Decide if we can use a frame slot for the var/array name or if we - * need to emit code to compute and push the name at runtime. We use a - * frame slot (entry in the array of local vars) if we are compiling a - * procedure body and if the name is simple text that does not include - * namespace qualifiers. + * Decide if we can use a frame slot for the var/array name or if we need + * to emit code to compute and push the name at runtime. We use a frame + * slot (entry in the array of local vars) if we are compiling a procedure + * body and if the name is simple text that does not include namespace + * qualifiers. */ - varTokenPtr = parsePtr->tokenPtr - + (parsePtr->tokenPtr->numComponents + 1); + varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar); - /* Push the "index" args and the new element value. */ + /* + * Push the "index" args and the new element value. + */ for (i=2 ; inumWords ; ++i) { - /* Advance to next arg */ - - varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); - - /* Push an arg */ - - if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start, - varTokenPtr[1].size), envPtr); - } else { - TclCompileTokens(interp, varTokenPtr+1, - varTokenPtr->numComponents, envPtr); - } + varTokenPtr = TokenAfter(varTokenPtr); + CompileWord(envPtr, varTokenPtr, interp); } /* - * Duplicate the variable name if it's been pushed. + * Duplicate the variable name if it's been pushed. */ if (!simpleVarName || localIndex < 0) { if (!simpleVarName || isScalar) { tempDepth = parsePtr->numWords - 2; @@ -2007,11 +2575,11 @@ */ if (parsePtr->numWords == 4) { TclEmitOpcode(INST_LSET_LIST, envPtr); } else { - TclEmitInstInt4(INST_LSET_FLAT, (parsePtr->numWords - 1), envPtr); + TclEmitInstInt4(INST_LSET_FLAT, parsePtr->numWords-1, envPtr); } /* * Emit code to put the value back in the variable */ @@ -2045,91 +2613,90 @@ * TclCompileRegexpCmd -- * * Procedure called to compile the "regexp" command. * * Results: - * Returns TCL_OK for a successful compile. - * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "regexp" command - * at runtime. + * Instructions are added to envPtr to execute the "regexp" command at + * runtime. * *---------------------------------------------------------------------- */ int TclCompileRegexpCmd(interp, parsePtr, envPtr) Tcl_Interp* interp; /* Tcl interpreter for error reporting */ - Tcl_Parse* parsePtr; /* Points to a parse structure for - * the command */ + Tcl_Parse* parsePtr; /* Points to a parse structure for the + * command */ CompileEnv* envPtr; /* Holds the resulting instructions */ { - Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing - * the parse of the RE or string */ + Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the + * parse of the RE or string */ int i, len, nocase, anchorLeft, anchorRight, start; char *str; /* - * We are only interested in compiling simple regexp cases. - * Currently supported compile cases are: + * We are only interested in compiling simple regexp cases. Currently + * supported compile cases are: * regexp ?-nocase? ?--? staticString $var * regexp ?-nocase? ?--? {^staticString$} $var */ if (parsePtr->numWords < 3) { - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } nocase = 0; varTokenPtr = parsePtr->tokenPtr; /* - * We only look for -nocase and -- as options. Everything else - * gets pushed to runtime execution. This is different than regexp's - * runtime option handling, but satisfies our stricter needs. + * We only look for -nocase and -- as options. Everything else gets + * pushed to runtime execution. This is different than regexp's runtime + * option handling, but satisfies our stricter needs. */ for (i = 1; i < parsePtr->numWords - 2; i++) { - varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + varTokenPtr = TokenAfter(varTokenPtr); if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { /* Not a simple string - punt to runtime. */ - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } str = (char *) varTokenPtr[1].start; len = varTokenPtr[1].size; if ((len == 2) && (str[0] == '-') && (str[1] == '-')) { i++; break; - } else if ((len > 1) - && (strncmp(str, "-nocase", (unsigned) len) == 0)) { + } else if ((len > 1) && (strncmp(str,"-nocase",(unsigned)len) == 0)) { nocase = 1; } else { /* Not an option we recognize. */ - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } } if ((parsePtr->numWords - i) != 2) { /* We don't support capturing to variables */ - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } /* * Get the regexp string. If it is not a simple string, punt to runtime. * If it has a '-', it could be an incorrectly formed regexp command. */ - varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + varTokenPtr = TokenAfter(varTokenPtr); str = (char *) varTokenPtr[1].start; len = varTokenPtr[1].size; if ((varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || (*str == '-')) { - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } if (len == 0) { /* * The semantics of regexp are always match on re == "". */ - TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr); + PushLiteral(envPtr, "1", 1); return TCL_OK; } /* * Make a copy of the string that is null-terminated for checks which @@ -2159,41 +2726,41 @@ /* * On the first (pattern) arg, check to see if any RE special characters * are in the word. If not, this is the same as 'string equal'. */ - if ((len > (1+start)) && (str[start] == '.') && (str[start+1] == '*')) { + if ((len > 1+start) && (str[start] == '.') && (str[start+1] == '*')) { start += 2; anchorLeft = 0; } - if ((len > (2+start)) && (str[len-3] != '\\') + if ((len > 2+start) && (str[len-3] != '\\') && (str[len-2] == '.') && (str[len-1] == '*')) { len -= 2; str[len] = '\0'; anchorRight = 0; } /* - * Don't do anything with REs with other special chars. Also check if - * this is a bad RE (do this at the end because it can be expensive). - * If so, let it complain at runtime. + * Don't do anything with REs with other special chars. Also check if this + * is a bad RE (do this at the end because it can be expensive). If so, + * let it complain at runtime. */ if ((strpbrk(str + start, "*+?{}()[].\\|^$") != NULL) || (Tcl_RegExpCompile(NULL, str) == NULL)) { ckfree((char *) str); - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } if (anchorLeft && anchorRight) { - TclEmitPush(TclRegisterNewLiteral(envPtr, str+start, len-start), - envPtr); + PushLiteral(envPtr, str+start, len-start); } else { /* - * This needs to find the substring anywhere in the string, so - * use string match and *foo*, with appropriate anchoring. + * This needs to find the substring anywhere in the string, so use + * [string match] and *foo*, with appropriate anchoring. */ - char *newStr = ckalloc((unsigned) len + 3); + char *newStr = ckalloc((unsigned) len + 3); + len -= start; if (anchorLeft) { strncpy(newStr, str + start, (size_t) len); } else { newStr[0] = '*'; @@ -2201,26 +2768,21 @@ } if (!anchorRight) { newStr[len++] = '*'; } newStr[len] = '\0'; - TclEmitPush(TclRegisterNewLiteral(envPtr, newStr, len), envPtr); + PushLiteral(envPtr, newStr, len); ckfree((char *) newStr); } ckfree((char *) str); /* * Push the string arg */ - varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); - if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - TclEmitPush(TclRegisterNewLiteral(envPtr, - varTokenPtr[1].start, varTokenPtr[1].size), envPtr); - } else { - TclCompileTokens(interp, varTokenPtr+1, - varTokenPtr->numComponents, envPtr); - } + + varTokenPtr = TokenAfter(varTokenPtr); + CompileWord(envPtr, varTokenPtr, interp); if (anchorLeft && anchorRight && !nocase) { TclEmitOpcode(INST_STR_EQ, envPtr); } else { TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr); @@ -2235,16 +2797,16 @@ * TclCompileReturnCmd -- * * Procedure called to compile the "return" command. * * Results: - * Returns TCL_OK for a successful compile. - * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "return" command - * at runtime. + * Instructions are added to envPtr to execute the "return" command at + * runtime. * *---------------------------------------------------------------------- */ int @@ -2261,26 +2823,50 @@ int level, code, status = TCL_OK; int numWords = parsePtr->numWords; int explicitResult = (0 == (numWords % 2)); int numOptionWords = numWords - 1 - explicitResult; Tcl_Obj *returnOpts; - Tcl_Token *wordTokenPtr = parsePtr->tokenPtr - + (parsePtr->tokenPtr->numComponents + 1); + Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); #define NUM_STATIC_OBJS 20 int objc; Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv; + /* + * Check for special case which can always be compiled: + * return -options + * Unlike the normal [return] compilation, this version does everything at + * runtime so it can handle arbitrary words and not just literals. Note + * that if INST_RETURN_STK wasn't already needed for something else + * ('finally' clause processing) this piece of code would not be present. + */ + + if ((numWords == 4) && (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) + && (wordTokenPtr[1].size == 8) + && (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) { + Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr); + Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr); + + CompileWord(envPtr, optsTokenPtr, interp); + CompileWord(envPtr, msgTokenPtr, interp); + TclEmitOpcode(INST_RETURN_STK, envPtr); + return TCL_OK; + } + + /* + * Allocate some working space if needed + */ + if (numOptionWords > NUM_STATIC_OBJS) { objv = (Tcl_Obj **) ckalloc(numOptionWords * sizeof(Tcl_Obj *)); } else { objv = staticObjArray; } - /* - * Scan through the return options. If any are unknown at compile - * time, there is no value in bytecompiling. Save the option values - * known in an objv array for merging into a return options dictionary. + /* + * Scan through the return options. If any are unknown at compile time, + * there is no value in bytecompiling. Save the option values known in an + * objv array for merging into a return options dictionary. */ for (objc = 0; objc < numOptionWords; objc++) { objv[objc] = Tcl_NewObj(); Tcl_IncrRefCount(objv[objc]); @@ -2287,88 +2873,84 @@ if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { objc++; status = TCL_ERROR; goto cleanup; } - wordTokenPtr += wordTokenPtr->numComponents + 1; + wordTokenPtr = TokenAfter(wordTokenPtr); } status = TclMergeReturnOptions(interp, objc, objv, &returnOpts, &code, &level); -cleanup: + cleanup: while (--objc >= 0) { Tcl_DecrRefCount(objv[objc]); } if (numOptionWords > NUM_STATIC_OBJS) { ckfree((char *)objv); } if (TCL_ERROR == status) { /* - * Something was bogus in the return options. Clear the - * error message, and report back to the compiler that this - * must be interpreted at runtime. + * Something was bogus in the return options. Clear the error message, + * and report back to the compiler that this must be interpreted at + * runtime. */ Tcl_ResetResult(interp); - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } /* * All options are known at compile time, so we're going to bytecompile. * Emit instructions to push the result on the stack */ if (explicitResult) { - if (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - /* Simple word: compile quickly to a simple push */ - TclEmitPush(TclRegisterNewLiteral(envPtr, wordTokenPtr[1].start, - wordTokenPtr[1].size), envPtr); - } else { - /* More complex tokens get compiled */ - TclCompileTokens(interp, wordTokenPtr+1, - wordTokenPtr->numComponents, envPtr); - } - } else { - /* No explict result argument, so default result is empty string */ - TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); - } - - /* - * Check for optimization: When [return] is in a proc, and there's - * no enclosing [catch], and there are no return options, then the - * INST_DONE instruction is equivalent, and may be more efficient. - */ - if (numOptionWords == 0) { - /* We have default return options... */ - if (envPtr->procPtr != NULL) { - /* ... and we're in a proc ... */ - int index = envPtr->exceptArrayNext - 1; - int enclosingCatch = 0; - while (index >= 0) { - ExceptionRange range = envPtr->exceptArrayPtr[index]; - if ((range.type == CATCH_EXCEPTION_RANGE) - && (range.catchOffset == -1)) { - enclosingCatch = 1; - break; - } - index--; - } - if (!enclosingCatch) { - /* ... and there is no enclosing catch. */ - Tcl_DecrRefCount(returnOpts); - TclEmitOpcode(INST_DONE, envPtr); - return TCL_OK; - } - } - } - - /* - * Could not use the optimization, so we push the return options - * dictionary, and emit the INST_RETURN instruction with code - * and level as operands. + CompileWord(envPtr, wordTokenPtr, interp); + } else { + /* + * No explict result argument, so default result is empty string. + */ + PushLiteral(envPtr, "", 0); + } + + /* + * Check for optimization: When [return] is in a proc, and there's no + * enclosing [catch], and there are no return options, then the INST_DONE + * instruction is equivalent, and may be more efficient. + */ + + if (numOptionWords == 0 && envPtr->procPtr != NULL) { + /* + * We have default return options and we're in a proc ... + */ + int index = envPtr->exceptArrayNext - 1; + int enclosingCatch = 0; + while (index >= 0) { + ExceptionRange range = envPtr->exceptArrayPtr[index]; + if ((range.type == CATCH_EXCEPTION_RANGE) + && (range.catchOffset == -1)) { + enclosingCatch = 1; + break; + } + index--; + } + if (!enclosingCatch) { + /* + * ... and there is no enclosing catch. Issue the maximally + * efficient exit instruction. + */ + Tcl_DecrRefCount(returnOpts); + TclEmitOpcode(INST_DONE, envPtr); + return TCL_OK; + } + } + + /* + * Could not use the optimization, so we push the return options dict, and + * emit the INST_RETURN_IMM instruction with code and level as operands. */ TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr); - TclEmitInstInt4(INST_RETURN, code, envPtr); + TclEmitInstInt4(INST_RETURN_IMM, code, envPtr); TclEmitInt4(level, envPtr); return TCL_OK; } /* @@ -2377,99 +2959,87 @@ * TclCompileSetCmd -- * * Procedure called to compile the "set" command. * * Results: - * Returns TCL_OK for a successful compile. - * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "set" command - * at runtime. + * Instructions are added to envPtr to execute the "set" command at + * runtime. * *---------------------------------------------------------------------- */ int TclCompileSetCmd(interp, parsePtr, envPtr) Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Parse *parsePtr; /* Points to a parse structure for the - * command created by Tcl_ParseCommand. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ CompileEnv *envPtr; /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr, *valueTokenPtr; int isAssignment, isScalar, simpleVarName, localIndex, numWords; numWords = parsePtr->numWords; if ((numWords != 2) && (numWords != 3)) { - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } isAssignment = (numWords == 3); /* - * Decide if we can use a frame slot for the var/array name or if we - * need to emit code to compute and push the name at runtime. We use a - * frame slot (entry in the array of local vars) if we are compiling a - * procedure body and if the name is simple text that does not include - * namespace qualifiers. + * Decide if we can use a frame slot for the var/array name or if we need + * to emit code to compute and push the name at runtime. We use a frame + * slot (entry in the array of local vars) if we are compiling a procedure + * body and if the name is simple text that does not include namespace + * qualifiers. */ - varTokenPtr = parsePtr->tokenPtr - + (parsePtr->tokenPtr->numComponents + 1); - + varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar); /* * If we are doing an assignment, push the new value. */ if (isAssignment) { - valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); - if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - TclEmitPush(TclRegisterNewLiteral(envPtr, valueTokenPtr[1].start, - valueTokenPtr[1].size), envPtr); - } else { - TclCompileTokens(interp, valueTokenPtr+1, - valueTokenPtr->numComponents, envPtr); - } + valueTokenPtr = TokenAfter(varTokenPtr); + CompileWord(envPtr, valueTokenPtr, interp); } /* * Emit instructions to set/get the variable. */ if (simpleVarName) { if (isScalar) { - if (localIndex >= 0) { - if (localIndex <= 255) { - TclEmitInstInt1((isAssignment? - INST_STORE_SCALAR1 : INST_LOAD_SCALAR1), - localIndex, envPtr); - } else { - TclEmitInstInt4((isAssignment? - INST_STORE_SCALAR4 : INST_LOAD_SCALAR4), - localIndex, envPtr); - } - } else { + if (localIndex < 0) { TclEmitOpcode((isAssignment? INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), envPtr); + } else if (localIndex <= 255) { + TclEmitInstInt1((isAssignment? + INST_STORE_SCALAR1 : INST_LOAD_SCALAR1), + localIndex, envPtr); + } else { + TclEmitInstInt4((isAssignment? + INST_STORE_SCALAR4 : INST_LOAD_SCALAR4), + localIndex, envPtr); } } else { - if (localIndex >= 0) { - if (localIndex <= 255) { - TclEmitInstInt1((isAssignment? - INST_STORE_ARRAY1 : INST_LOAD_ARRAY1), - localIndex, envPtr); - } else { - TclEmitInstInt4((isAssignment? - INST_STORE_ARRAY4 : INST_LOAD_ARRAY4), - localIndex, envPtr); - } - } else { + if (localIndex < 0) { TclEmitOpcode((isAssignment? - INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr); + INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr); + } else if (localIndex <= 255) { + TclEmitInstInt1((isAssignment? + INST_STORE_ARRAY1 : INST_LOAD_ARRAY1), + localIndex, envPtr); + } else { + TclEmitInstInt4((isAssignment? + INST_STORE_ARRAY4 : INST_LOAD_ARRAY4), + localIndex, envPtr); } } } else { TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr); } @@ -2480,33 +3050,36 @@ /* *---------------------------------------------------------------------- * * TclCompileStringCmd -- * - * Procedure called to compile the "string" command. + * Procedure called to compile the "string" command. Generally speaking, + * these are mostly various kinds of peephole optimizations; most string + * operations are handled by executing the interpreted version of the + * command. * * Results: - * Returns TCL_OK for a successful compile. - * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "string" command - * at runtime. + * Instructions are added to envPtr to execute the "string" command at + * runtime. * *---------------------------------------------------------------------- */ int TclCompileStringCmd(interp, parsePtr, envPtr) Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Parse *parsePtr; /* Points to a parse structure for the - * command created by Tcl_ParseCommand. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ CompileEnv *envPtr; /* Holds resulting instructions. */ { Tcl_Token *opTokenPtr, *varTokenPtr; Tcl_Obj *opObj; - int index; + int i, index; static CONST char *options[] = { "bytelength", "compare", "equal", "first", "index", "is", "last", "length", "map", "match", "range", "repeat", @@ -2519,194 +3092,155 @@ STR_INDEX, STR_IS, STR_LAST, STR_LENGTH, STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT, STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE, STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT, STR_WORDEND, STR_WORDSTART - }; + }; if (parsePtr->numWords < 2) { /* Fail at run time, not in compilation */ - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } - opTokenPtr = parsePtr->tokenPtr - + (parsePtr->tokenPtr->numComponents + 1); + opTokenPtr = TokenAfter(parsePtr->tokenPtr); opObj = Tcl_NewStringObj(opTokenPtr->start, opTokenPtr->size); if (Tcl_GetIndexFromObj(interp, opObj, options, "option", 0, &index) != TCL_OK) { Tcl_DecrRefCount(opObj); Tcl_ResetResult(interp); - return TCL_OUT_LINE_COMPILE; - } - Tcl_DecrRefCount(opObj); - - varTokenPtr = opTokenPtr + (opTokenPtr->numComponents + 1); - - switch ((enum options) index) { - case STR_BYTELENGTH: - case STR_FIRST: - case STR_IS: - case STR_LAST: - case STR_MAP: - case STR_RANGE: - case STR_REPEAT: - case STR_REPLACE: - case STR_TOLOWER: - case STR_TOUPPER: - case STR_TOTITLE: - case STR_TRIM: - case STR_TRIMLEFT: - case STR_TRIMRIGHT: - case STR_WORDEND: - case STR_WORDSTART: - /* - * All other cases: compile out of line. - */ - return TCL_OUT_LINE_COMPILE; - - case STR_COMPARE: - case STR_EQUAL: { - int i; - /* - * If there are any flags to the command, we can't byte compile it - * because the INST_STR_EQ bytecode doesn't support flags. - */ - - if (parsePtr->numWords != 4) { - return TCL_OUT_LINE_COMPILE; - } - - /* - * Push the two operands onto the stack. - */ - - for (i = 0; i < 2; i++) { - if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - TclEmitPush(TclRegisterNewLiteral(envPtr, - varTokenPtr[1].start, varTokenPtr[1].size), envPtr); - } else { - TclCompileTokens(interp, varTokenPtr+1, - varTokenPtr->numComponents, envPtr); - } - varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); - } - - TclEmitOpcode(((((enum options) index) == STR_COMPARE) ? - INST_STR_CMP : INST_STR_EQ), envPtr); - return TCL_OK; - } - case STR_INDEX: { - int i; - - if (parsePtr->numWords != 4) { - /* Fail at run time, not in compilation */ - return TCL_OUT_LINE_COMPILE; - } - - /* - * Push the two operands onto the stack. - */ - - for (i = 0; i < 2; i++) { - if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - TclEmitPush(TclRegisterNewLiteral(envPtr, - varTokenPtr[1].start, varTokenPtr[1].size), envPtr); - } else { - TclCompileTokens(interp, varTokenPtr+1, - varTokenPtr->numComponents, envPtr); - } - varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); - } - - TclEmitOpcode(INST_STR_INDEX, envPtr); - return TCL_OK; - } - case STR_LENGTH: { - if (parsePtr->numWords != 3) { - /* Fail at run time, not in compilation */ - return TCL_OUT_LINE_COMPILE; - } - - if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - /* - * Here someone is asking for the length of a static string. - * Just push the actual character (not byte) length. - */ - char buf[TCL_INTEGER_SPACE]; - int len = Tcl_NumUtfChars(varTokenPtr[1].start, - varTokenPtr[1].size); - len = sprintf(buf, "%d", len); - TclEmitPush(TclRegisterNewLiteral(envPtr, buf, len), envPtr); - return TCL_OK; - } else { - TclCompileTokens(interp, varTokenPtr+1, - varTokenPtr->numComponents, envPtr); - } - TclEmitOpcode(INST_STR_LEN, envPtr); - return TCL_OK; - } - case STR_MATCH: { - int i, length, exactMatch = 0, nocase = 0; - CONST char *str; - - if (parsePtr->numWords < 4 || parsePtr->numWords > 5) { - /* Fail at run time, not in compilation */ - return TCL_OUT_LINE_COMPILE; - } - - if (parsePtr->numWords == 5) { - if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_OUT_LINE_COMPILE; - } - str = varTokenPtr[1].start; - length = varTokenPtr[1].size; - if ((length > 1) && - strncmp(str, "-nocase", (size_t) length) == 0) { - nocase = 1; - } else { - /* Fail at run time, not in compilation */ - return TCL_OUT_LINE_COMPILE; - } - varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); - } - - for (i = 0; i < 2; i++) { - if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - str = varTokenPtr[1].start; - length = varTokenPtr[1].size; - if (!nocase && (i == 0)) { - /* - * On the first (pattern) arg, check to see if any - * glob special characters are in the word '*[]?\\'. - * If not, this is the same as 'string equal'. We - * can use strpbrk here because the glob chars are all - * in the ascii-7 range. If -nocase was specified, - * we can't do this because INST_STR_EQ has no support - * for nocase. - */ - Tcl_Obj *copy = Tcl_NewStringObj(str, length); - Tcl_IncrRefCount(copy); - exactMatch = (strpbrk(Tcl_GetString(copy), - "*[]?\\") == NULL); - Tcl_DecrRefCount(copy); - } - TclEmitPush( - TclRegisterNewLiteral(envPtr, str, length), envPtr); - } else { - TclCompileTokens(interp, varTokenPtr+1, - varTokenPtr->numComponents, envPtr); - } - varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); - } - - if (exactMatch) { - TclEmitOpcode(INST_STR_EQ, envPtr); - } else { - TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr); - } - return TCL_OK; - } + return TCL_ERROR; + } + Tcl_DecrRefCount(opObj); + + varTokenPtr = TokenAfter(opTokenPtr); + + switch ((enum options) index) { + case STR_COMPARE: + case STR_EQUAL: + /* + * If there are any flags to the command, we can't byte compile it + * because the INST_STR_EQ bytecode doesn't support flags. + */ + + if (parsePtr->numWords != 4) { + return TCL_ERROR; + } + + /* + * Push the two operands onto the stack. + */ + + for (i = 0; i < 2; i++) { + CompileWord(envPtr, varTokenPtr, interp); + varTokenPtr = TokenAfter(varTokenPtr); + } + + TclEmitOpcode(((((enum options) index) == STR_COMPARE) ? + INST_STR_CMP : INST_STR_EQ), envPtr); + return TCL_OK; + + case STR_INDEX: + if (parsePtr->numWords != 4) { + /* Fail at run time, not in compilation */ + return TCL_ERROR; + } + + /* + * Push the two operands onto the stack. + */ + + for (i = 0; i < 2; i++) { + CompileWord(envPtr, varTokenPtr, interp); + varTokenPtr = TokenAfter(varTokenPtr); + } + + TclEmitOpcode(INST_STR_INDEX, envPtr); + return TCL_OK; + case STR_MATCH: { + int length, exactMatch = 0, nocase = 0; + CONST char *str; + + if (parsePtr->numWords < 4 || parsePtr->numWords > 5) { + /* Fail at run time, not in compilation */ + return TCL_ERROR; + } + + if (parsePtr->numWords == 5) { + if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + str = varTokenPtr[1].start; + length = varTokenPtr[1].size; + if ((length > 1) && + strncmp(str, "-nocase", (size_t) length) == 0) { + nocase = 1; + } else { + /* Fail at run time, not in compilation */ + return TCL_ERROR; + } + varTokenPtr = TokenAfter(varTokenPtr); + } + + for (i = 0; i < 2; i++) { + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + str = varTokenPtr[1].start; + length = varTokenPtr[1].size; + if (!nocase && (i == 0)) { + /* + * Trivial matches can be done by 'string equal'. If + * -nocase was specified, we can't do this because + * INST_STR_EQ has no support for nocase. + */ + Tcl_Obj *copy = Tcl_NewStringObj(str, length); + Tcl_IncrRefCount(copy); + exactMatch = TclMatchIsTrivial(Tcl_GetString(copy)); + Tcl_DecrRefCount(copy); + } + PushLiteral(envPtr, str, length); + } else { + TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + } + varTokenPtr = TokenAfter(varTokenPtr); + } + + if (exactMatch) { + TclEmitOpcode(INST_STR_EQ, envPtr); + } else { + TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr); + } + return TCL_OK; + } + case STR_LENGTH: + if (parsePtr->numWords != 3) { + /* Fail at run time, not in compilation */ + return TCL_ERROR; + } + + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + /* + * Here someone is asking for the length of a static string. Just + * push the actual character (not byte) length. + */ + char buf[TCL_INTEGER_SPACE]; + int len = Tcl_NumUtfChars(varTokenPtr[1].start, + varTokenPtr[1].size); + len = sprintf(buf, "%d", len); + PushLiteral(envPtr, buf, len); + return TCL_OK; + } else { + TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + } + TclEmitOpcode(INST_STR_LEN, envPtr); + return TCL_OK; + + default: + /* + * All other cases: compile out of line. + */ + return TCL_ERROR; } return TCL_OK; } @@ -2716,356 +3250,464 @@ * TclCompileSwitchCmd -- * * Procedure called to compile the "switch" command. * * Results: - * Returns TCL_OK for a successful compile. - * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. + * Returns TCL_OK for successful compile, or TCL_ERROR to defer + * evaluation to runtime (either when it is too complex to get the + * semantics right, or when we know for sure that it is an error but need + * the error to happen at the right time). * * Side effects: - * Instructions are added to envPtr to execute the "switch" command - * at runtime. + * Instructions are added to envPtr to execute the "switch" command at + * runtime. + * + * FIXME: + * Stack depths are probably not calculated correctly. * *---------------------------------------------------------------------- */ + int TclCompileSwitchCmd(interp, parsePtr, envPtr) Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Parse *parsePtr; /* Points to a parse structure for the - * command created by Tcl_ParseCommand. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ CompileEnv *envPtr; /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; /* Pointer to tokens in command */ + int numWords; /* Number of words in command */ + Tcl_Token *valueTokenPtr; /* Token for the value to switch on. */ - int foundDefault; /* Flag to indicate whether a "default" - * clause is present. */ enum {Switch_Exact, Switch_Glob} mode; /* What kind of switch are we doing? */ - int i, j; /* Loop counter variables. */ - Tcl_DString bodyList; /* Used for splitting the pattern list. */ - int argc; /* Number of items in pattern list. */ - CONST char **argv; /* Array of copies of items in pattern list. */ Tcl_Token *bodyTokenArray; /* Array of real pattern list items. */ - CONST char *tokenStartPtr; /* Used as part of synthesizing tokens. */ - int isTokenBraced; + Tcl_Token **bodyToken; /* Array of pointers to pattern list items. */ + int foundDefault; /* Flag to indicate whether a "default" clause + * is present. */ JumpFixup *fixupArray; /* Array of forward-jump fixup records. */ int *fixupTargetArray; /* Array of places for fixups to point at. */ int fixupCount; /* Number of places to fix up. */ - int contFixIndex; /* Where the first of the jumps due to a - * group of continuation bodies starts, - * or -1 if there aren't any. */ - int contFixCount = 0; /* Number of continuation bodies pointing - * to the current (or next) real body. */ - int codeOffset; /* Cache of current bytecode offset. */ + int contFixIndex; /* Where the first of the jumps due to a group + * of continuation bodies starts, or -1 if + * there aren't any. */ + int contFixCount; /* Number of continuation bodies pointing to + * the current (or next) real body. */ + int savedStackDepth = envPtr->currStackDepth; - - tokenPtr = parsePtr->tokenPtr; + int noCase; /* Has the -nocase flag been given? */ + int foundMode = 0; /* Have we seen a mode flag yet? */ + int i; /* * Only handle the following versions: * switch -- word {pattern body ...} - * switch -exact -- word {pattern body ...} + * switch -exact -- word {pattern body ...} * switch -glob -- word {pattern body ...} + * switch -- word simpleWordPattern simpleWordBody ... + * switch -exact -- word simpleWordPattern simpleWordBody ... + * switch -glob -- word simpleWordPattern simpleWordBody ... + * When the mode is -glob, can also handle a -nocase flag. + * + * First off, we don't care how the command's word was generated; we're + * compiling it anyway! So skip it... */ - if (parsePtr->numWords != 5 && - parsePtr->numWords != 4) { - return TCL_OUT_LINE_COMPILE; - } + tokenPtr = TokenAfter(parsePtr->tokenPtr); + numWords = parsePtr->numWords-1; /* - * We don't care how the command's word was generated; we're - * compiling it anyway! + * Check for options. There must be at least one, --, because without that + * there is no way to statically avoid the problems you get from strings- + * -to-be-matched that start with a - (the interpreted code falls apart if + * it encounters them, so we punt if we *might* encounter them as that is + * the easiest way of emulating the behaviour). */ - tokenPtr += tokenPtr->numComponents + 1; - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_OUT_LINE_COMPILE; - } else { - register int size = tokenPtr[1].size; + noCase = 0; + mode = Switch_Exact; + for (; numWords>=3 ; tokenPtr=TokenAfter(tokenPtr),numWords--) { + register unsigned size = tokenPtr[1].size; register CONST char *chrs = tokenPtr[1].start; - if (size < 2) { - return TCL_OUT_LINE_COMPILE; - } - if ((size <= 6) && (parsePtr->numWords == 5) - && !strncmp(chrs, "-exact", (unsigned) TclMin(size, 6))) { - mode = Switch_Exact; - tokenPtr += 2; - } else if ((size <= 5) && (parsePtr->numWords == 5) - && !strncmp(chrs, "-glob", (unsigned) TclMin(size, 5))) { - mode = Switch_Glob; - tokenPtr += 2; - } else if ((size == 2) && (parsePtr->numWords == 4) - && !strncmp(chrs, "--", 2)) { - /* - * If no control flag present, use exact matching (the default). - * - * We end up re-checking this word, but that's the way things are... - */ - mode = Switch_Exact; - } else { - return TCL_OUT_LINE_COMPILE; - } - } - if ((tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) - || (tokenPtr[1].size != 2) || strncmp(tokenPtr[1].start, "--", 2)) { - return TCL_OUT_LINE_COMPILE; - } - tokenPtr += 2; - - /* - * The value to test against is going to always get pushed on the - * stack. But not yet; we need to verify that the rest of the - * command is compilable too. + /* + * We only process literal options, and we assume that -e, -g and -n + * are unique prefixes of -exact, -glob and -nocase respectively (true + * at time of writing). Note that -exact and -glob may only be given + * at most once or we bail out (error case). + */ + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || size < 2) { + return TCL_ERROR; + } + + if ((size <= 6) && !memcmp(chrs, "-exact", size)) { + if (foundMode) { + return TCL_ERROR; + } + mode = Switch_Exact; + foundMode = 1; + continue; + } else if ((size <= 5) && !memcmp(chrs, "-glob", size)) { + if (foundMode) { + return TCL_ERROR; + } + mode = Switch_Glob; + foundMode = 1; + continue; + } else if ((size <= 7) && !memcmp(chrs, "-nocase", size)) { + noCase = 1; + continue; + } else if ((size == 2) && !memcmp(chrs, "--", 2)) { + break; + } + + /* + * The switch command has many flags we cannot compile at all (e.g. + * all the RE-related ones) which we must have encountered. Either + * that or we have run off the end. The action here is the same: punt + * to interpreted version. + */ + + return TCL_ERROR; + } + if (numWords < 3) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(tokenPtr); + numWords--; + if (noCase && (mode == Switch_Exact)) { + /* + * Can't compile this case; no opcode for case-insensitive equality! + */ + return TCL_ERROR; + } + + /* + * The value to test against is going to always get pushed on the stack. + * But not yet; we need to verify that the rest of the command is + * compilable too. */ valueTokenPtr = tokenPtr; - tokenPtr += tokenPtr->numComponents + 1; - - /* - * Test that we've got a suitable body list as a simple (i.e. - * braced) word, and that the elements of the body are simple - * words too. This is really rather nasty indeed. - */ - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_OUT_LINE_COMPILE; - } - Tcl_DStringInit(&bodyList); - Tcl_DStringAppend(&bodyList, tokenPtr[1].start, tokenPtr[1].size); - if (Tcl_SplitList(NULL, Tcl_DStringValue(&bodyList), &argc, - &argv) != TCL_OK) { - Tcl_DStringFree(&bodyList); - return TCL_OUT_LINE_COMPILE; - } - Tcl_DStringFree(&bodyList); - if (argc == 0 || argc % 2) { - ckfree((char *)argv); - return TCL_OUT_LINE_COMPILE; - } - bodyTokenArray = (Tcl_Token *) ckalloc(sizeof(Tcl_Token) * argc); - tokenStartPtr = tokenPtr[1].start; - while (isspace(UCHAR(*tokenStartPtr))) { - tokenStartPtr++; - } - if (*tokenStartPtr == '{') { - tokenStartPtr++; - isTokenBraced = 1; - } else { - isTokenBraced = 0; - } - for (i=0 ; i= tokenPtr[1].start+tokenPtr[1].size) { - break; - } + tokenPtr = TokenAfter(tokenPtr); + numWords--; + + /* + * Build an array of tokens for the matcher terms and script bodies. Note + * that in the case of the quoted bodies, this is tricky as we cannot use + * copies of the string from the input token for the generated tokens (it + * causes a crash during exception handling). When multiple tokens are + * available at this point, this is pretty easy. + */ + + if (numWords == 1) { + Tcl_DString bodyList; + CONST char **argv = NULL; + int isTokenBraced; + CONST char *tokenStartPtr; + + /* + * Test that we've got a suitable body list as a simple (i.e. braced) + * word, and that the elements of the body are simple words too. This + * is really rather nasty indeed. + */ + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + Tcl_DStringInit(&bodyList); + Tcl_DStringAppend(&bodyList, tokenPtr[1].start, tokenPtr[1].size); + if (Tcl_SplitList(NULL, Tcl_DStringValue(&bodyList), &numWords, + &argv) != TCL_OK) { + Tcl_DStringFree(&bodyList); + return TCL_ERROR; + } + Tcl_DStringFree(&bodyList); + + /* + * Now we know what the switch arms are, we've got to see whether we + * can synthesize tokens for the arms. First check whether we've got a + * valid number of arms since we can do that now. + */ + + if (numWords == 0 || numWords % 2) { + ckfree((char *) argv); + return TCL_ERROR; + } + + bodyTokenArray = (Tcl_Token *) ckalloc(sizeof(Tcl_Token) * numWords); + bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords); + + /* + * Locate the start of the arms within the overall word. + */ + + tokenStartPtr = tokenPtr[1].start; + while (isspace(UCHAR(*tokenStartPtr))) { + tokenStartPtr++; } if (*tokenStartPtr == '{') { tokenStartPtr++; isTokenBraced = 1; } else { isTokenBraced = 0; } - } - if (tokenStartPtr != tokenPtr[1].start+tokenPtr[1].size) { - ckfree((char *)argv); - ckfree((char *)bodyTokenArray); - fprintf(stderr, "BAD ASSUMPTION\n"); - return TCL_OUT_LINE_COMPILE; - } - - /* - * Complain if the last body is a continuation. Note that this - * check assumes that the list is non-empty! - */ - - if (argc>0 && argv[argc-1][0]=='-' && argv[argc-1]=='\0') { - ckfree((char *)argv); - ckfree((char *)bodyTokenArray); - return TCL_OUT_LINE_COMPILE; - } - - /* - * Now we commit to generating code; the parsing stage per se is - * done. - * + for (i=0 ; i= tokenPtr[1].start+tokenPtr[1].size) { + break; + } + } + if (*tokenStartPtr == '{') { + tokenStartPtr++; + isTokenBraced = 1; + } else { + isTokenBraced = 0; + } + } + ckfree((char *)argv); + + /* + * Check that we've parsed everything we thought we were going to + * parse. If not, something odd is going on (I believe it is possible + * to defeat the code above) and we should bail out. + */ + + if (tokenStartPtr != tokenPtr[1].start+tokenPtr[1].size) { + ckfree((char *) bodyToken); + ckfree((char *) bodyTokenArray); + return TCL_ERROR; + } + + } else if (numWords % 2 || numWords == 0) { + /* + * Odd number of words (>1) available, or no words at all available. + * Both are error cases, so punt and let the interpreted-version + * generate the error message. Note that the second case probably + * should get caught earlier, but it's easy to check here again anyway + * because it'd cause a nasty crash otherwise. + */ + + return TCL_ERROR; + + } else { + bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords); + bodyTokenArray = NULL; + for (i=0 ; itype != TCL_TOKEN_SIMPLE_WORD || + tokenPtr->numComponents != 1) { + ckfree((char *) bodyToken); + return TCL_ERROR; + } + bodyToken[i] = tokenPtr+1; + tokenPtr = TokenAfter(tokenPtr); + } + } + + /* + * Fall back to interpreted if the last body is a continuation (it's + * illegal, but this makes the error happen at the right time). + */ + + if (bodyToken[numWords-1]->size == 1 && + bodyToken[numWords-1]->start[0] == '-') { + ckfree((char *) bodyToken); + if (bodyTokenArray != NULL) { + ckfree((char *) bodyTokenArray); + } + return TCL_ERROR; + } + + /* + * Now we commit to generating code; the parsing stage per se is done. * First, we push the value we're matching against on the stack. */ - if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - TclEmitPush(TclRegisterNewLiteral(envPtr, valueTokenPtr[1].start, - valueTokenPtr[1].size), envPtr); - } else { - TclCompileTokens(interp, valueTokenPtr+1, - valueTokenPtr->numComponents, envPtr); - } + TclCompileTokens(interp, valueTokenPtr+1, valueTokenPtr->numComponents, + envPtr); /* * Generate a test for each arm. */ contFixIndex = -1; - fixupArray = (JumpFixup *) ckalloc(sizeof(JumpFixup) * argc); - fixupTargetArray = (int *) ckalloc(sizeof(int) * argc); - (VOID *) memset(fixupTargetArray, 0, argc * sizeof(int)); + contFixCount = 0; + fixupArray = (JumpFixup *) ckalloc(sizeof(JumpFixup) * numWords); + fixupTargetArray = (int *) ckalloc(sizeof(int) * numWords); + memset(fixupTargetArray, 0, numWords * sizeof(int)); fixupCount = 0; foundDefault = 0; - for (i=0 ; icurrStackDepth = savedStackDepth + 1; - if (argv[i][0]!='d' || strcmp(argv[i], "default") || i!=argc-2) { + if (i!=numWords-2 || bodyToken[numWords-2]->size != 7 || + memcmp(bodyToken[numWords-2]->start, "default", 7)) { + /* + * Generate the test for the arm. This code is slightly + * inefficient, but much simpler than the first version. + */ + + TclCompileTokens(interp, bodyToken[i], 1, envPtr); + TclEmitInstInt4(INST_OVER, 1, envPtr); switch (mode) { case Switch_Exact: - TclEmitOpcode(INST_DUP, envPtr); - TclEmitPush(TclRegisterNewLiteral(envPtr, argv[i], - (int) strlen(argv[i])), envPtr); TclEmitOpcode(INST_STR_EQ, envPtr); break; case Switch_Glob: - TclEmitPush(TclRegisterNewLiteral(envPtr, argv[i], - (int) strlen(argv[i])), envPtr); - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt1(INST_STR_MATCH, /*nocase*/0, envPtr); + TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr); break; default: - Tcl_Panic("unknown switch mode: %d",mode); + Tcl_Panic("unknown switch mode: %d", mode); } + /* - * Process fall-through clauses here... + * In a fall-through case, we will jump on _true_ to the place + * where the body starts (generated later, with guarantee of this + * ensured earlier; the final body is never a fall-through). */ - if (argv[i+1][0]=='-' && argv[i+1][1]=='\0') { + + if (bodyToken[i+1]->size==1 && bodyToken[i+1]->start[0]=='-') { if (contFixIndex == -1) { contFixIndex = fixupCount; contFixCount = 0; } TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, - &fixupArray[contFixIndex+contFixCount]); + fixupArray+contFixIndex+contFixCount); fixupCount++; contFixCount++; continue; } - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, - &fixupArray[fixupCount]); + + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, fixupArray+fixupCount); nextArmFixupIndex = fixupCount; fixupCount++; } else { /* - * Got a default clause; set a flag. - */ - foundDefault = 1; - /* - * Note that default clauses (which are always last - * clauses) cannot be fall-through clauses as well, - * because the last clause is never a fall-through clause. - */ - } - - /* - * Generate the body for the arm. This is guaranteed not to - * be a fall-through case, but it might have preceding - * fall-through cases, so we must process those first. + * Got a default clause; set a flag to inhibit the generation of + * the jump after the body and the cleanup of the intermediate + * value that we are switching against. + * + * Note that default clauses (which are always terminal clauses) + * cannot be fall-through clauses as well, since the last clause + * is never a fall-through clause (which we have already + * verified). + */ + + foundDefault = 1; + } + + /* + * Generate the body for the arm. This is guaranteed not to be a + * fall-through case, but it might have preceding fall-through cases, + * so we must process those first. */ if (contFixIndex != -1) { - codeOffset = envPtr->codeNext-envPtr->codeStart; + int j; for (j=0 ; jcurrStackDepth = savedStackDepth + 1; - TclCompileCmdWord(interp, bodyTokenArray+i+1, 1, envPtr); - - if (!foundDefault) { - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &fixupArray[fixupCount]); - fixupCount++; - fixupTargetArray[nextArmFixupIndex] = - envPtr->codeNext-envPtr->codeStart; - } - } - ckfree((char *)argv); - ckfree((char *)bodyTokenArray); - - /* - * Discard the value we are matching against unless we've had a - * default clause (in which case it will already be gone) and make - * the result of the command an empty string. - */ - - if (!foundDefault) { - TclEmitOpcode(INST_POP, envPtr); - TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); - } - - /* - * Do jump fixups for arms that were executed. First, fill in the - * jumps of all jumps that don't point elsewhere to point to here. - */ - codeOffset = envPtr->codeNext-envPtr->codeStart; - for (i=0 ; i=0 ; i--) { - if (TclFixupForwardJump(envPtr, &fixupArray[i], - fixupTargetArray[i]-fixupArray[i].codeOffset, 127)) { + * Now do the actual compilation. Note that we do not use CompileBody + * because we may have synthesized the tokens in a non-standard + * pattern. + */ + + TclEmitOpcode(INST_POP, envPtr); + envPtr->currStackDepth = savedStackDepth + 1; + TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); + + if (!foundDefault) { + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, + fixupArray+fixupCount); + fixupCount++; + fixupTargetArray[nextArmFixupIndex] = CurrentOffset(envPtr); + } + } + ckfree((char *) bodyToken); + if (bodyTokenArray != NULL) { + ckfree((char *) bodyTokenArray); + } + + /* + * Discard the value we are matching against unless we've had a default + * clause (in which case it will already be gone due to the code at the + * start of processing an arm, guaranteed) and make the result of the + * command an empty string. + */ + + if (!foundDefault) { + TclEmitOpcode(INST_POP, envPtr); + PushLiteral(envPtr, "", 0); + } + + /* + * Do jump fixups for arms that were executed. First, fill in the jumps + * of all jumps that don't point elsewhere to point to here. + */ + + for (i=0 ; icodeNext-envPtr->codeStart; + } + } + + /* + * Now scan backwards over all the jumps (all of which are forward jumps) + * doing each one. When we do one and there is a size changes, we must + * scan back over all the previous ones and see if they need adjusting + * before proceeding with further jump fixups (the interleaved nature of + * all the jumps makes this impossible to do without nested loops). + */ + + for (i=fixupCount-1 ; i>=0 ; i--) { + if (TclFixupForwardJump(envPtr, &fixupArray[i], + fixupTargetArray[i] - fixupArray[i].codeOffset, 127)) { + int j; for (j=i-1 ; j>=0 ; j--) { if (fixupTargetArray[j] > fixupArray[i].codeOffset) { fixupTargetArray[j] += 3; } } } } - ckfree((char *)fixupArray); - ckfree((char *)fixupTargetArray); + ckfree((char *) fixupArray); + ckfree((char *) fixupTargetArray); envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } @@ -3072,57 +3714,69 @@ /* *---------------------------------------------------------------------- * * TclCompileVariableCmd -- * - * Procedure called to reserve the local variables for the - * "variable" command. The command itself is *not* compiled. + * Procedure called to reserve the local variables for the "variable" + * command. The command itself is *not* compiled. * * Results: - * Always returns TCL_OUT_LINE_COMPILE. + * Always returns TCL_ERROR. * * Side effects: * Indexed local variables are added to the environment. * *---------------------------------------------------------------------- */ + int TclCompileVariableCmd(interp, parsePtr, envPtr) Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Parse *parsePtr; /* Points to a parse structure for the - * command created by Tcl_ParseCommand. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ CompileEnv *envPtr; /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr; int i, numWords; CONST char *varName, *tail; if (envPtr->procPtr == NULL) { - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } numWords = parsePtr->numWords; - varTokenPtr = parsePtr->tokenPtr - + (parsePtr->tokenPtr->numComponents + 1); + varTokenPtr = TokenAfter(parsePtr->tokenPtr); for (i = 1; i < numWords; i += 2) { - if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - varName = varTokenPtr[1].start; - tail = varName + varTokenPtr[1].size - 1; - if ((*tail == ')') || (tail < varName)) continue; - while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) { - tail--; - } - if ((*tail == ':') && (tail > varName)) { - tail++; - } - (void) TclFindCompiledLocal(tail, (tail-varName+1), - /*create*/ 1, /*flags*/ 0, envPtr->procPtr); - varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); - } - } - return TCL_OUT_LINE_COMPILE; + /* + * Skip non-literals. + */ + if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + continue; + } + + varName = varTokenPtr[1].start; + tail = varName + varTokenPtr[1].size - 1; + + /* + * Skip if it looks like it might be an array or an empty string. + */ + if ((*tail == ')') || (tail < varName)) { + continue; + } + + while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) { + tail--; + } + if ((*tail == ':') && (tail > varName)) { + tail++; + } + (void) TclFindCompiledLocal(tail, tail-varName+1, + /*create*/ 1, /*flags*/ 0, envPtr->procPtr); + varTokenPtr = TokenAfter(varTokenPtr); + } + return TCL_ERROR; } /* *---------------------------------------------------------------------- * @@ -3129,92 +3783,90 @@ * TclCompileWhileCmd -- * * Procedure called to compile the "while" command. * * Results: - * Returns TCL_OK for a successful compile. - * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "while" command - * at runtime. + * Instructions are added to envPtr to execute the "while" command at + * runtime. * *---------------------------------------------------------------------- */ int TclCompileWhileCmd(interp, parsePtr, envPtr) Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Parse *parsePtr; /* Points to a parse structure for the - * command created by Tcl_ParseCommand. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ CompileEnv *envPtr; /* Holds resulting instructions. */ { Tcl_Token *testTokenPtr, *bodyTokenPtr; JumpFixup jumpEvalCondFixup; int testCodeOffset, bodyCodeOffset, jumpDist; int range, code; int savedStackDepth = envPtr->currStackDepth; - int loopMayEnd = 1; /* This is set to 0 if it is recognized as - * an infinite loop. */ + int loopMayEnd = 1; /* This is set to 0 if it is recognized as an + * infinite loop. */ Tcl_Obj *boolObj; int boolVal; if (parsePtr->numWords != 3) { - return TCL_OUT_LINE_COMPILE; - } - - /* - * If the test expression requires substitutions, don't compile the - * while command inline. E.g., the expression might cause the loop to - * never execute or execute forever, as in "while "$x < 5" {}". - * - * Bail out also if the body expression requires substitutions - * in order to insure correct behaviour [Bug 219166] - */ - - testTokenPtr = parsePtr->tokenPtr - + (parsePtr->tokenPtr->numComponents + 1); - bodyTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1); + return TCL_ERROR; + } + + /* + * If the test expression requires substitutions, don't compile the while + * command inline. E.g., the expression might cause the loop to never + * execute or execute forever, as in "while "$x < 5" {}". + * + * Bail out also if the body expression requires substitutions in order to + * insure correct behaviour [Bug 219166] + */ + + testTokenPtr = TokenAfter(parsePtr->tokenPtr); + bodyTokenPtr = TokenAfter(testTokenPtr); + if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) { - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } /* - * Find out if the condition is a constant. + * Find out if the condition is a constant. */ boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size); Tcl_IncrRefCount(boolObj); code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal); Tcl_DecrRefCount(boolObj); if (code == TCL_OK) { if (boolVal) { /* - * it is an infinite loop + * It is an infinite loop; flag it so that we generate a more + * efficient body. */ - loopMayEnd = 0; + loopMayEnd = 0; } else { /* - * This is an empty loop: "while 0 {...}" or such. - * Compile no bytecodes. + * This is an empty loop: "while 0 {...}" or such. Compile no + * bytecodes. */ goto pushResult; } } - /* + /* * Create a ExceptionRange record for the loop body. This is used to * implement break and continue. */ - envPtr->exceptDepth++; - envPtr->maxExceptDepth = - TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); - range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); /* * Jump to the evaluation of the condition. This code uses the "loop * rotation" optimisation (which eliminates one branch from the loop). * "while cond body" produces then: @@ -3230,92 +3882,89 @@ if (loopMayEnd) { TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup); testCodeOffset = 0; /* avoid compiler warning */ } else { - testCodeOffset = (envPtr->codeNext - envPtr->codeStart); + testCodeOffset = CurrentOffset(envPtr); } /* * Compile the loop body. */ - bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart); - TclCompileCmdWord(interp, bodyTokenPtr+1, - bodyTokenPtr->numComponents, envPtr); + bodyCodeOffset = ExceptionRangeStarts(envPtr, range); + CompileBody(envPtr, bodyTokenPtr, interp); + ExceptionRangeEnds(envPtr, range); envPtr->currStackDepth = savedStackDepth + 1; - envPtr->exceptArrayPtr[range].numCodeBytes = - (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset; TclEmitOpcode(INST_POP, envPtr); /* * Compile the test expression then emit the conditional jump that * terminates the while. We already know it's a simple word. */ if (loopMayEnd) { - testCodeOffset = (envPtr->codeNext - envPtr->codeStart); + testCodeOffset = CurrentOffset(envPtr); jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { bodyCodeOffset += 3; testCodeOffset += 3; } envPtr->currStackDepth = savedStackDepth; TclCompileExprWords(interp, testTokenPtr, 1, envPtr); envPtr->currStackDepth = savedStackDepth + 1; - jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset; + jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; if (jumpDist > 127) { TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); } else { TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr); } } else { - jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset; + jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; if (jumpDist > 127) { TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr); } else { TclEmitInstInt1(INST_JUMP1, -jumpDist, envPtr); - } + } } /* * Set the loop's body, continue and break offsets. */ envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset; - envPtr->exceptArrayPtr[range].breakOffset = - (envPtr->codeNext - envPtr->codeStart); + ExceptionRangeTarget(envPtr, range, breakOffset); /* * The while command's result is an empty string. */ - pushResult: + pushResult: envPtr->currStackDepth = savedStackDepth; - TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); + PushLiteral(envPtr, "", 0); envPtr->exceptDepth--; return TCL_OK; } /* *---------------------------------------------------------------------- * * PushVarName -- * - * Procedure used in the compiling where pushing a variable name - * is necessary (append, lappend, set). + * Procedure used in the compiling where pushing a variable name is + * necessary (append, lappend, set). * * Results: - * Returns TCL_OK for a successful compile. - * Returns TCL_OUT_LINE_COMPILE to defer evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "set" command - * at runtime. + * Instructions are added to envPtr to execute the "set" command at + * runtime. * *---------------------------------------------------------------------- */ static int @@ -3322,12 +3971,11 @@ PushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr, simpleVarNamePtr, isScalarPtr) Tcl_Interp *interp; /* Used for error reporting. */ Tcl_Token *varTokenPtr; /* Points to a variable token. */ CompileEnv *envPtr; /* Holds resulting instructions. */ - int flags; /* takes TCL_CREATE_VAR or - * TCL_NO_LARGE_INDEX */ + int flags; /* TCL_CREATE_VAR or TCL_NO_LARGE_INDEX */ int *localIndexPtr; /* must not be NULL */ int *simpleVarNamePtr; /* must not be NULL */ int *isScalarPtr; /* must not be NULL */ { register CONST char *p; @@ -3339,26 +3987,26 @@ int elemTokenCount = 0; int allocedTokens = 0; int removedParen = 0; /* - * Decide if we can use a frame slot for the var/array name or if we - * need to emit code to compute and push the name at runtime. We use a - * frame slot (entry in the array of local vars) if we are compiling a - * procedure body and if the name is simple text that does not include - * namespace qualifiers. + * Decide if we can use a frame slot for the var/array name or if we need + * to emit code to compute and push the name at runtime. We use a frame + * slot (entry in the array of local vars) if we are compiling a procedure + * body and if the name is simple text that does not include namespace + * qualifiers. */ simpleVarName = 0; name = elName = NULL; nameChars = elNameChars = 0; localIndex = -1; /* * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether - * curly braces surround the variable name. - * This really matters for array elements to handle things like + * curly braces surround the variable name. This really matters for array + * elements to handle things like * set {x($foo)} 5 * which raises an undefined var error if we are not careful here. */ if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) && @@ -3370,11 +4018,11 @@ simpleVarName = 1; name = varTokenPtr[1].start; nameChars = varTokenPtr[1].size; if (name[nameChars-1] == ')') { - /* + /* * last char is ')' => potential array reference. */ for (i=0,p=name ; itype = TCL_TOKEN_TEXT; @@ -3400,50 +4048,50 @@ elemTokenCount = 1; } } } else if (((n = varTokenPtr->numComponents) > 1) && (varTokenPtr[1].type == TCL_TOKEN_TEXT) - && (varTokenPtr[n].type == TCL_TOKEN_TEXT) - && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) { + && (varTokenPtr[n].type == TCL_TOKEN_TEXT) + && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) { - /* + /* * Check for parentheses inside first token */ - simpleVarName = 0; - for (i = 0, p = varTokenPtr[1].start; - i < varTokenPtr[1].size; i++, p++) { - if (*p == '(') { - simpleVarName = 1; - break; - } - } - if (simpleVarName) { + simpleVarName = 0; + for (i = 0, p = varTokenPtr[1].start; + i < varTokenPtr[1].size; i++, p++) { + if (*p == '(') { + simpleVarName = 1; + break; + } + } + if (simpleVarName) { int remainingChars; /* - * Check the last token: if it is just ')', do not count - * it. Otherwise, remove the ')' and flag so that it is - * restored at the end. + * Check the last token: if it is just ')', do not count it. + * Otherwise, remove the ')' and flag so that it is restored at + * the end. */ if (varTokenPtr[n].size == 1) { --n; } else { --varTokenPtr[n].size; removedParen = n; } - name = varTokenPtr[1].start; - nameChars = p - varTokenPtr[1].start; - elName = p + 1; - remainingChars = (varTokenPtr[2].start - p) - 1; - elNameChars = (varTokenPtr[n].start - p) + varTokenPtr[n].size - 2; + name = varTokenPtr[1].start; + nameChars = p - varTokenPtr[1].start; + elName = p + 1; + remainingChars = (varTokenPtr[2].start - p) - 1; + elNameChars = (varTokenPtr[n].start - p) + varTokenPtr[n].size - 2; if (remainingChars) { /* - * Make a first token with the extra characters in the first + * Make a first token with the extra characters in the first * token. */ elemTokenPtr = (Tcl_Token *) ckalloc(n * sizeof(Tcl_Token)); allocedTokens = 1; @@ -3456,18 +4104,18 @@ /* * Copy the remaining tokens. */ memcpy((void *) (elemTokenPtr+1), (void *) (&varTokenPtr[2]), - ((n-1) * sizeof(Tcl_Token))); + (n-1) * sizeof(Tcl_Token)); } else { /* * Use the already available tokens. */ elemTokenPtr = &varTokenPtr[2]; - elemTokenCount = n - 1; + elemTokenCount = n - 1; } } } if (simpleVarName) { @@ -3482,27 +4130,27 @@ break; } } /* - * Look up the var name's index in the array of local vars in the - * proc frame. If retrieving the var's value and it doesn't already - * exist, push its name and look it up at runtime. + * Look up the var name's index in the array of local vars in the proc + * frame. If retrieving the var's value and it doesn't already exist, + * push its name and look it up at runtime. */ if ((envPtr->procPtr != NULL) && !hasNsQualifiers) { localIndex = TclFindCompiledLocal(name, nameChars, - /*create*/ (flags & TCL_CREATE_VAR), - /*flags*/ ((elName==NULL)? VAR_SCALAR : VAR_ARRAY), + /*create*/ flags & TCL_CREATE_VAR, + /*flags*/ ((elName==NULL)? VAR_SCALAR : VAR_ARRAY), envPtr->procPtr); if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) { /* we'll push the name */ localIndex = -1; } } if (localIndex < 0) { - TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameChars), envPtr); + PushLiteral(envPtr, name, nameChars); } /* * Compile the element script, if any. */ @@ -3509,28 +4157,36 @@ if (elName != NULL) { if (elNameChars) { TclCompileTokens(interp, elemTokenPtr, elemTokenCount, envPtr); } else { - TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); + PushLiteral(envPtr, "", 0); } } } else { /* * The var name isn't simple: compile and push it. */ - TclCompileTokens(interp, varTokenPtr+1, - varTokenPtr->numComponents, envPtr); + TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents, + envPtr); } if (removedParen) { ++varTokenPtr[removedParen].size; } if (allocedTokens) { ckfree((char *) elemTokenPtr); } - *localIndexPtr = localIndex; - *simpleVarNamePtr = simpleVarName; - *isScalarPtr = (elName == NULL); + *localIndexPtr = localIndex; + *simpleVarNamePtr = simpleVarName; + *isScalarPtr = (elName == NULL); return TCL_OK; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclCompExpr.c ================================================================== --- generic/tclCompExpr.c +++ generic/tclCompExpr.c @@ -1,72 +1,56 @@ -/* +/* * tclCompExpr.c -- * * This file contains the code to compile Tcl expressions. * * Copyright (c) 1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompExpr.c,v 1.25 2004/10/08 15:39:52 dkf Exp $ + * RCS: @(#) $Id: tclCompExpr.c,v 1.25.2.4 2005/08/22 03:49:39 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. + * Boolean variable that controls whether expression compilation tracing is + * enabled. */ #ifdef TCL_COMPILE_DEBUG static int traceExprComp = 0; #endif /* TCL_COMPILE_DEBUG */ /* - * The ExprInfo structure describes the state of compiling an expression. - * A pointer to an ExprInfo record is passed among the routines in - * this module. + * The ExprInfo structure describes the state of compiling an expression. A + * pointer to an ExprInfo record is passed among the routines in this module. */ typedef struct ExprInfo { Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Parse *parsePtr; /* Structure filled with information about - * the parsed expression. */ + Tcl_Parse *parsePtr; /* Structure filled with information about the + * parsed expression. */ CONST char *expr; /* The expression that was originally passed * to TclCompileExpr. */ CONST char *lastChar; /* Points just after last byte of expr. */ - int hasOperators; /* Set 1 if the expr has operators; 0 if - * expr is only a primary. If 1 after - * compiling an expr, a tryCvtToNumeric - * instruction is emitted to convert the - * primary to a number if possible. */ + int hasOperators; /* Set 1 if the expr has operators; 0 if expr + * is only a primary. If 1 after compiling an + * expr, a tryCvtToNumeric instruction is + * emitted to convert the primary to a number + * if possible. */ } ExprInfo; /* - * Definitions of numeric codes representing each expression operator. - * The order of these must match the entries in the operatorTable below. - * Also the codes for the relational operators (OP_LESS, OP_GREATER, - * OP_LE, OP_GE, OP_EQ, and OP_NE) must be consecutive and in that order. - * Note that OP_PLUS and OP_MINUS represent both unary and binary operators. + * Definitions of numeric codes representing each expression operator. The + * order of these must match the entries in the operatorTable below. Also the + * codes for the relational operators (OP_LESS, OP_GREATER, OP_LE, OP_GE, + * OP_EQ, and OP_NE) must be consecutive and in that order. Note that OP_PLUS + * and OP_MINUS represent both unary and binary operators. */ #define OP_MULT 0 #define OP_DIVIDE 1 #define OP_MOD 2 @@ -113,11 +97,11 @@ static OperatorDesc operatorTable[] = { {"*", 2, INST_MULT}, {"/", 2, INST_DIV}, {"%", 2, INST_MOD}, - {"+", 0}, + {"+", 0}, {"-", 0}, {"<<", 2, INST_LSHIFT}, {">>", 2, INST_RSHIFT}, {"<", 2, INST_LT}, {">", 2, INST_GT}, @@ -140,12 +124,12 @@ {"ni", 2, INST_LIST_NOT_IN}, {NULL} }; /* - * Hashtable used to map the names of expression operators to the index - * of their OperatorDesc description. + * Hashtable used to map the names of expression operators to the index of + * their OperatorDesc description. */ static Tcl_HashTable opHashTable; /* @@ -174,11 +158,11 @@ #ifdef TCL_COMPILE_DEBUG #define TRACE(exprBytes, exprLength, tokenBytes, tokenLength) \ if (traceExprComp) { \ fprintf(stderr, "CompileSubExpr: \"%.*s\", token \"%.*s\"\n", \ - (exprLength), (exprBytes), (tokenLength), (tokenBytes)); \ + (exprLength), (exprBytes), (tokenLength), (tokenBytes)); \ } #else #define TRACE(exprBytes, exprLength, tokenBytes, tokenLength) #endif /* TCL_COMPILE_DEBUG */ @@ -185,15 +169,15 @@ /* *---------------------------------------------------------------------- * * TclCompileExpr -- * - * This procedure compiles a string containing a Tcl expression into - * Tcl bytecodes. This procedure is the top-level interface to the - * the expression compilation module, and is used by such public - * procedures as Tcl_ExprString, Tcl_ExprStringObj, Tcl_ExprLong, - * Tcl_ExprDouble, Tcl_ExprBoolean, and Tcl_ExprBooleanObj. + * This procedure compiles a string containing a Tcl expression into Tcl + * bytecodes. This procedure is the top-level interface to the the + * expression compilation module, and is used by such public procedures + * as Tcl_ExprString, Tcl_ExprStringObj, Tcl_ExprLong, Tcl_ExprDouble, + * Tcl_ExprBoolean, and Tcl_ExprBooleanObj. * * Results: * The return value is TCL_OK on a successful compilation and TCL_ERROR * on failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. @@ -217,12 +201,12 @@ Tcl_Parse parse; Tcl_HashEntry *hPtr; int new, i, code; /* - * If this is the first time we've been called, initialize the table - * of expression operators. + * If this is the first time we've been called, initialize the table of + * expression operators. */ if (numBytes < 0) { numBytes = (script? strlen(script) : 0); } @@ -241,18 +225,18 @@ } Tcl_MutexUnlock(&opMutex); } /* - * Initialize the structure containing information abvout this - * expression compilation. + * Initialize the structure containing information abvout this expression + * compilation. */ info.interp = interp; info.parsePtr = &parse; info.expr = script; - info.lastChar = (script + numBytes); + info.lastChar = (script + numBytes); info.hasOperators = 0; /* * Parse the expression then compile it. */ @@ -265,54 +249,51 @@ code = CompileSubExpr(parse.tokenPtr, &info, envPtr); if (code != TCL_OK) { Tcl_FreeParse(&parse); goto done; } - + if (!info.hasOperators) { /* - * Attempt to convert the primary's object to an int or double. - * This is done in order to support Tcl's policy of interpreting - * operands if at all possible as first integers, else - * floating-point numbers. + * Attempt to convert the primary's object to an int or double. This + * is done in order to support Tcl's policy of interpreting operands + * if at all possible as first integers, else floating-point numbers. */ - + TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); } Tcl_FreeParse(&parse); - done: + done: return code; } /* *---------------------------------------------------------------------- * * TclFinalizeCompilation -- * - * Clean up the compilation environment so it can later be - * properly reinitialized. This procedure is called by - * TclFinalizeCompExecEnv() in tclObj.c, which in turn is called - * by Tcl_Finalize(). + * Clean up the compilation environment so it can later be properly + * reinitialized. This procedure is called by Tcl_Finalize(). * * Results: * None. * * Side effects: - * Cleans up the compilation environment. At the moment, just the - * table of expression operators is freed. + * Cleans up the compilation environment. At the moment, just the table + * of expression operators is freed. * *---------------------------------------------------------------------- */ void TclFinalizeCompilation() { Tcl_MutexLock(&opMutex); if (opTableInitialized) { - Tcl_DeleteHashTable(&opHashTable); - opTableInitialized = 0; + Tcl_DeleteHashTable(&opHashTable); + opTableInitialized = 0; } Tcl_MutexUnlock(&opMutex); } /* @@ -335,12 +316,12 @@ *---------------------------------------------------------------------- */ static int CompileSubExpr(exprTokenPtr, infoPtr, envPtr) - Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token - * to compile. */ + Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token to + * compile. */ ExprInfo *infoPtr; /* Describes the compilation state for the * expression being compiled. */ CompileEnv *envPtr; /* Holds resulting instructions. */ { Tcl_Interp *interp = infoPtr->interp; @@ -352,215 +333,207 @@ int objIndex, opIndex, length, code; char buffer[TCL_UTF_MAX]; if (exprTokenPtr->type != TCL_TOKEN_SUB_EXPR) { Tcl_Panic("CompileSubExpr: token type %d not TCL_TOKEN_SUB_EXPR\n", - exprTokenPtr->type); + exprTokenPtr->type); } code = TCL_OK; /* * Switch on the type of the first token after the subexpression token. * After processing it, advance tokenPtr to point just after the * subexpression's last token. */ - - tokenPtr = exprTokenPtr+1; - TRACE(exprTokenPtr->start, exprTokenPtr->size, - tokenPtr->start, tokenPtr->size); - switch (tokenPtr->type) { - case TCL_TOKEN_WORD: - TclCompileTokens(interp, tokenPtr+1, - tokenPtr->numComponents, envPtr); - tokenPtr += (tokenPtr->numComponents + 1); - break; - - case TCL_TOKEN_TEXT: - if (tokenPtr->size > 0) { - objIndex = TclRegisterNewLiteral(envPtr, tokenPtr->start, - tokenPtr->size); - } else { - objIndex = TclRegisterNewLiteral(envPtr, "", 0); - } - TclEmitPush(objIndex, envPtr); - tokenPtr += 1; - break; - - case TCL_TOKEN_BS: - length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, - buffer); - if (length > 0) { - objIndex = TclRegisterNewLiteral(envPtr, buffer, length); - } else { - objIndex = TclRegisterNewLiteral(envPtr, "", 0); - } - TclEmitPush(objIndex, envPtr); - tokenPtr += 1; - break; - - case TCL_TOKEN_COMMAND: - TclCompileScript(interp, tokenPtr->start+1, - tokenPtr->size-2, envPtr); - tokenPtr += 1; - break; - - case TCL_TOKEN_VARIABLE: - TclCompileTokens(interp, tokenPtr, 1, envPtr); - tokenPtr += (tokenPtr->numComponents + 1); - break; - - case TCL_TOKEN_SUB_EXPR: - code = CompileSubExpr(tokenPtr, infoPtr, envPtr); - if (code != TCL_OK) { - goto done; - } - tokenPtr += (tokenPtr->numComponents + 1); - break; - - case TCL_TOKEN_OPERATOR: - /* - * Look up the operator. If the operator isn't found, treat it - * as a math function. - */ - Tcl_DStringInit(&opBuf); - operator = Tcl_DStringAppend(&opBuf, - tokenPtr->start, tokenPtr->size); - hPtr = Tcl_FindHashEntry(&opHashTable, operator); - if (hPtr == NULL) { - code = CompileMathFuncCall(exprTokenPtr, operator, infoPtr, - envPtr, &endPtr); - Tcl_DStringFree(&opBuf); - if (code != TCL_OK) { - goto done; - } - tokenPtr = endPtr; - break; - } - Tcl_DStringFree(&opBuf); - opIndex = (int) Tcl_GetHashValue(hPtr); - opDescPtr = &(operatorTable[opIndex]); - - /* - * If the operator is "normal", compile it using information - * from the operator table. - */ - - if (opDescPtr->numOperands > 0) { - tokenPtr++; - code = CompileSubExpr(tokenPtr, infoPtr, envPtr); - if (code != TCL_OK) { - goto done; - } - tokenPtr += (tokenPtr->numComponents + 1); - - if (opDescPtr->numOperands == 2) { - code = CompileSubExpr(tokenPtr, infoPtr, envPtr); - if (code != TCL_OK) { - goto done; - } - tokenPtr += (tokenPtr->numComponents + 1); - } - TclEmitOpcode(opDescPtr->instruction, envPtr); - infoPtr->hasOperators = 1; - break; - } - - /* - * The operator requires special treatment, and is either - * "+" or "-", or one of "&&", "||" or "?". - */ - - switch (opIndex) { - case OP_PLUS: - case OP_MINUS: - tokenPtr++; - code = CompileSubExpr(tokenPtr, infoPtr, envPtr); - if (code != TCL_OK) { - goto done; - } - tokenPtr += (tokenPtr->numComponents + 1); - - /* - * Check whether the "+" or "-" is unary. - */ - - afterSubexprPtr = exprTokenPtr - + exprTokenPtr->numComponents+1; - if (tokenPtr == afterSubexprPtr) { - TclEmitOpcode(((opIndex==OP_PLUS)? - INST_UPLUS : INST_UMINUS), - envPtr); - break; - } - - /* - * The "+" or "-" is binary. - */ - - code = CompileSubExpr(tokenPtr, infoPtr, envPtr); - if (code != TCL_OK) { - goto done; - } - tokenPtr += (tokenPtr->numComponents + 1); - TclEmitOpcode(((opIndex==OP_PLUS)? INST_ADD : INST_SUB), - envPtr); - break; - - case OP_LAND: - case OP_LOR: - code = CompileLandOrLorExpr(exprTokenPtr, opIndex, - infoPtr, envPtr, &endPtr); - if (code != TCL_OK) { - goto done; - } - tokenPtr = endPtr; - break; - - case OP_QUESTY: - code = CompileCondExpr(exprTokenPtr, infoPtr, - envPtr, &endPtr); - if (code != TCL_OK) { - goto done; - } - tokenPtr = endPtr; - break; - - default: - Tcl_Panic("CompileSubExpr: unexpected operator %d requiring special treatment\n", - opIndex); - } /* end switch on operator requiring special treatment */ - infoPtr->hasOperators = 1; - break; - - default: - Tcl_Panic("CompileSubExpr: unexpected token type %d\n", - tokenPtr->type); - } - - /* - * Verify that the subexpression token had the required number of - * subtokens: that we've advanced tokenPtr just beyond the - * subexpression's last token. For example, a "*" subexpression must - * contain the tokens for exactly two operands. - */ - - if (tokenPtr != (exprTokenPtr + exprTokenPtr->numComponents+1)) { - LogSyntaxError(infoPtr); - code = TCL_ERROR; - } - - done: + + tokenPtr = exprTokenPtr+1; + TRACE(exprTokenPtr->start, exprTokenPtr->size, + tokenPtr->start, tokenPtr->size); + switch (tokenPtr->type) { + case TCL_TOKEN_WORD: + TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); + tokenPtr += (tokenPtr->numComponents + 1); + break; + + case TCL_TOKEN_TEXT: + if (tokenPtr->size > 0) { + objIndex = TclRegisterNewLiteral(envPtr, tokenPtr->start, + tokenPtr->size); + } else { + objIndex = TclRegisterNewLiteral(envPtr, "", 0); + } + TclEmitPush(objIndex, envPtr); + tokenPtr += 1; + break; + + case TCL_TOKEN_BS: + length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, buffer); + if (length > 0) { + objIndex = TclRegisterNewLiteral(envPtr, buffer, length); + } else { + objIndex = TclRegisterNewLiteral(envPtr, "", 0); + } + TclEmitPush(objIndex, envPtr); + tokenPtr += 1; + break; + + case TCL_TOKEN_COMMAND: + TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, envPtr); + tokenPtr += 1; + break; + + case TCL_TOKEN_VARIABLE: + TclCompileTokens(interp, tokenPtr, 1, envPtr); + tokenPtr += (tokenPtr->numComponents + 1); + break; + + case TCL_TOKEN_SUB_EXPR: + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; + } + tokenPtr += (tokenPtr->numComponents + 1); + break; + + case TCL_TOKEN_OPERATOR: + /* + * Look up the operator. If the operator isn't found, treat it as a + * math function. + */ + Tcl_DStringInit(&opBuf); + operator = Tcl_DStringAppend(&opBuf, tokenPtr->start, tokenPtr->size); + hPtr = Tcl_FindHashEntry(&opHashTable, operator); + if (hPtr == NULL) { + code = CompileMathFuncCall(exprTokenPtr, operator, infoPtr, envPtr, + &endPtr); + Tcl_DStringFree(&opBuf); + if (code != TCL_OK) { + goto done; + } + tokenPtr = endPtr; + break; + } + Tcl_DStringFree(&opBuf); + opIndex = (int) Tcl_GetHashValue(hPtr); + opDescPtr = &(operatorTable[opIndex]); + + /* + * If the operator is "normal", compile it using information from the + * operator table. + */ + + if (opDescPtr->numOperands > 0) { + tokenPtr++; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; + } + tokenPtr += (tokenPtr->numComponents + 1); + + if (opDescPtr->numOperands == 2) { + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; + } + tokenPtr += (tokenPtr->numComponents + 1); + } + TclEmitOpcode(opDescPtr->instruction, envPtr); + infoPtr->hasOperators = 1; + break; + } + + /* + * The operator requires special treatment, and is either "+" or "-", + * or one of "&&", "||" or "?". + */ + + switch (opIndex) { + case OP_PLUS: + case OP_MINUS: + tokenPtr++; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; + } + tokenPtr += (tokenPtr->numComponents + 1); + + /* + * Check whether the "+" or "-" is unary. + */ + + afterSubexprPtr = exprTokenPtr + exprTokenPtr->numComponents+1; + if (tokenPtr == afterSubexprPtr) { + TclEmitOpcode(((opIndex==OP_PLUS)? INST_UPLUS : INST_UMINUS), + envPtr); + break; + } + + /* + * The "+" or "-" is binary. + */ + + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; + } + tokenPtr += (tokenPtr->numComponents + 1); + TclEmitOpcode(((opIndex==OP_PLUS)? INST_ADD : INST_SUB), envPtr); + break; + + case OP_LAND: + case OP_LOR: + code = CompileLandOrLorExpr(exprTokenPtr, opIndex, infoPtr, envPtr, + &endPtr); + if (code != TCL_OK) { + goto done; + } + tokenPtr = endPtr; + break; + + case OP_QUESTY: + code = CompileCondExpr(exprTokenPtr, infoPtr, envPtr, &endPtr); + if (code != TCL_OK) { + goto done; + } + tokenPtr = endPtr; + break; + + default: + Tcl_Panic("CompileSubExpr: unexpected operator %d requiring special treatment\n", + opIndex); + } /* end switch on operator requiring special treatment */ + infoPtr->hasOperators = 1; + break; + + default: + Tcl_Panic("CompileSubExpr: unexpected token type %d\n", + tokenPtr->type); + } + + /* + * Verify that the subexpression token had the required number of + * subtokens: that we've advanced tokenPtr just beyond the subexpression's + * last token. For example, a "*" subexpression must contain the tokens + * for exactly two operands. + */ + + if (tokenPtr != (exprTokenPtr + exprTokenPtr->numComponents+1)) { + LogSyntaxError(infoPtr); + code = TCL_ERROR; + } + + done: return code; } /* *---------------------------------------------------------------------- * * CompileLandOrLorExpr -- * - * This procedure compiles a Tcl logical and ("&&") or logical or - * ("||") subexpression. + * This procedure compiles a Tcl logical and ("&&") or logical or ("||") + * subexpression. * * Results: * The return value is TCL_OK on a successful compilation and TCL_ERROR * on failure. If TCL_OK is returned, a pointer to the token just after * the last one in the subexpression is stored at the address in @@ -573,26 +546,27 @@ *---------------------------------------------------------------------- */ static int CompileLandOrLorExpr(exprTokenPtr, opIndex, infoPtr, envPtr, endPtrPtr) - Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token - * containing the "&&" or "||" operator. */ - int opIndex; /* A code describing the expression - * operator: either OP_LAND or OP_LOR. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - CompileEnv *envPtr; /* Holds resulting instructions. */ - Tcl_Token **endPtrPtr; /* If successful, a pointer to the token - * just after the last token in the - * subexpression is stored here. */ -{ - JumpFixup shortCircuitFixup; /* Used to fix up the short circuit jump - * after the first subexpression. */ - JumpFixup shortCircuitFixup2;/* Used to fix up the second jump to the - * short-circuit target. */ - JumpFixup endFixup; /* Used to fix up jump to the end. */ + Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token + * containing the "&&" or "||" operator. */ + int opIndex; /* A code describing the expression operator: + * either OP_LAND or OP_LOR. */ + ExprInfo *infoPtr; /* Describes the compilation state for the + * expression being compiled. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ + Tcl_Token **endPtrPtr; /* If successful, a pointer to the token just + * after the last token in the subexpression + * is stored here. */ +{ + JumpFixup shortCircuitFixup;/* Used to fix up the short circuit jump after + * the first subexpression. */ + JumpFixup shortCircuitFixup2; + /* Used to fix up the second jump to the + * short-circuit target. */ + JumpFixup endFixup; /* Used to fix up jump to the end. */ Tcl_Token *tokenPtr; int code; int savedStackDepth = envPtr->currStackDepth; /* @@ -621,15 +595,15 @@ code = CompileSubExpr(tokenPtr, infoPtr, envPtr); if (code != TCL_OK) { goto done; } tokenPtr += (tokenPtr->numComponents + 1); - + /* - * The result is the boolean value of the second operand. We - * code this in a somewhat contorted manner to be able to reuse - * the shortCircuit value and save one INST_JUMP. + * The result is the boolean value of the second operand. We code this in + * a somewhat contorted manner to be able to reuse the shortCircuit value + * and save one INST_JUMP. */ TclEmitForwardJump(envPtr, ((opIndex==OP_LAND)? TCL_FALSE_JUMP : TCL_TRUE_JUMP), &shortCircuitFixup2); @@ -640,20 +614,20 @@ TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr); } TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup); /* - * Fixup the short-circuit jumps and push the shortCircuit value. - * Note that shortCircuitFixup2 is always a short jump. + * Fixup the short-circuit jumps and push the shortCircuit value. Note + * that shortCircuitFixup2 is always a short jump. */ TclFixupForwardJumpToHere(envPtr, &shortCircuitFixup2, 127); if (TclFixupForwardJumpToHere(envPtr, &shortCircuitFixup, 127)) { /* * shortCircuit jump grown by 3 bytes: update endFixup. */ - + endFixup.codeOffset += 3; } if (opIndex == OP_LAND) { TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr); @@ -662,11 +636,11 @@ } TclFixupForwardJumpToHere(envPtr, &endFixup, 127); *endPtrPtr = tokenPtr; - done: + done: envPtr->currStackDepth = savedStackDepth + 1; return code; } /* @@ -695,13 +669,13 @@ Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token * containing the "?" operator. */ ExprInfo *infoPtr; /* Describes the compilation state for the * expression being compiled. */ CompileEnv *envPtr; /* Holds resulting instructions. */ - Tcl_Token **endPtrPtr; /* If successful, a pointer to the token - * just after the last token in the - * subexpression is stored here. */ + Tcl_Token **endPtrPtr; /* If successful, a pointer to the token just + * after the last token in the subexpression + * is stored here. */ { JumpFixup jumpAroundThenFixup, jumpAroundElseFixup; /* Used to update or replace one-byte jumps * around the then and else expressions when * their target PCs are determined. */ @@ -717,22 +691,22 @@ code = CompileSubExpr(tokenPtr, infoPtr, envPtr); if (code != TCL_OK) { goto done; } tokenPtr += (tokenPtr->numComponents + 1); - + /* * Emit the jump to the "else" expression if the test was false. */ - + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpAroundThenFixup); /* - * Compile the "then" expression. Note that if a subexpression is only - * a primary, we need to try to convert it to numeric. We do this to - * support Tcl's policy of interpreting operands if at all possible as - * first integers, else floating-point numbers. + * Compile the "then" expression. Note that if a subexpression is only a + * primary, we need to try to convert it to numeric. We do this to support + * Tcl's policy of interpreting operands if at all possible as first + * integers, else floating-point numbers. */ infoPtr->hasOperators = 0; code = CompileSubExpr(tokenPtr, infoPtr, envPtr); if (code != TCL_OK) { @@ -744,13 +718,12 @@ } /* * Emit an unconditional jump around the "else" condExpr. */ - - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpAroundElseFixup); + + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpAroundElseFixup); /* * Compile the "else" expression. */ @@ -772,26 +745,26 @@ dist = (envPtr->codeNext - envPtr->codeStart) - jumpAroundElseFixup.codeOffset; if (TclFixupForwardJump(envPtr, &jumpAroundElseFixup, dist, 127)) { /* - * Update the else expression's starting code offset since it - * moved down 3 bytes too. + * Update the else expression's starting code offset since it moved + * down 3 bytes too. */ - + elseCodeOffset += 3; } - + /* * Fix up the first jump to the "else" expression if the test was false. */ - + dist = (elseCodeOffset - jumpAroundThenFixup.codeOffset); TclFixupForwardJump(envPtr, &jumpAroundThenFixup, dist, 127); *endPtrPtr = tokenPtr; - done: + done: envPtr->currStackDepth = savedStackDepth + 1; return code; } /* @@ -822,103 +795,61 @@ * containing the math function call. */ CONST char *funcName; /* Name of the math function. */ ExprInfo *infoPtr; /* Describes the compilation state for the * expression being compiled. */ CompileEnv *envPtr; /* Holds resulting instructions. */ - Tcl_Token **endPtrPtr; /* If successful, a pointer to the token - * just after the last token in the - * subexpression is stored here. */ -{ - Tcl_Interp *interp = infoPtr->interp; - Interp *iPtr = (Interp *) interp; - MathFunc *mathFuncPtr; - Tcl_HashEntry *hPtr; - Tcl_Token *tokenPtr, *afterSubexprPtr; - int code, i; - - /* - * Look up the MathFunc record for the function. - */ - - code = TCL_OK; - hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName); - if (hPtr == NULL) { - Tcl_AppendResult(interp, "unknown math function \"", funcName, - "\"", (char *) NULL); - code = TCL_ERROR; - goto done; - } - mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - - /* - * If not a builtin function, push an object with the function's name. - */ - - if (mathFuncPtr->builtinFuncIndex < 0) { - TclEmitPush(TclRegisterNewLiteral(envPtr, funcName, -1), envPtr); - } + Tcl_Token **endPtrPtr; /* If successful, a pointer to the token just + * after the last token in the subexpression + * is stored here. */ +{ + Tcl_DString cmdName; + int objIndex; + Tcl_Token *tokenPtr, *afterSubexprPtr; + int argCount; + int code = TCL_OK; + + /* + * Prepend "tcl::mathfunc::" to the function name, to produce the name of + * a command that evaluates the function. Push that command name on the + * stack, in a literal registered to the namespace so that resolution can + * be cached. + */ + + Tcl_DStringInit(&cmdName); + Tcl_DStringAppend(&cmdName, "tcl::mathfunc::", -1); + Tcl_DStringAppend(&cmdName, funcName, -1); + objIndex = TclRegisterNewNSLiteral(envPtr, Tcl_DStringValue(&cmdName), + Tcl_DStringLength(&cmdName)); + TclEmitPush(objIndex, envPtr); + Tcl_DStringFree(&cmdName); /* * Compile any arguments for the function. */ + argCount = 1; tokenPtr = exprTokenPtr+2; afterSubexprPtr = exprTokenPtr + (exprTokenPtr->numComponents + 1); - if (mathFuncPtr->numArgs > 0) { - for (i = 0; i < mathFuncPtr->numArgs; i++) { - if (tokenPtr == afterSubexprPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "too few arguments for math function", -1)); - code = TCL_ERROR; - goto done; - } - code = CompileSubExpr(tokenPtr, infoPtr, envPtr); - if (code != TCL_OK) { - goto done; - } - tokenPtr += (tokenPtr->numComponents + 1); - } - if (tokenPtr != afterSubexprPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "too many arguments for math function", -1)); - code = TCL_ERROR; - goto done; - } - } else if (tokenPtr != afterSubexprPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "too many arguments for math function", -1)); - code = TCL_ERROR; - goto done; - } - - /* - * Compile the call on the math function. Note that the "objc" argument - * count for non-builtin functions is incremented by 1 to include the - * function name itself. - */ - - if (mathFuncPtr->builtinFuncIndex >= 0) { /* a builtin function */ - /* - * Adjust the current stack depth by the number of arguments - * of the builtin function. This cannot be handled by the - * TclEmitInstInt1 macro as the number of arguments is not - * passed as an operand. - */ - - if (envPtr->maxStackDepth < envPtr->currStackDepth) { - envPtr->maxStackDepth = envPtr->currStackDepth; - } - TclEmitInstInt1(INST_CALL_BUILTIN_FUNC1, - mathFuncPtr->builtinFuncIndex, envPtr); - envPtr->currStackDepth -= mathFuncPtr->numArgs; - } else { - TclEmitInstInt1(INST_CALL_FUNC1, (mathFuncPtr->numArgs+1), envPtr); - } - *endPtrPtr = afterSubexprPtr; - - done: - return code; + while (tokenPtr != afterSubexprPtr) { + ++argCount; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + return code; + } + tokenPtr += (tokenPtr->numComponents + 1); + } + + /* Invoke the function */ + + if (argCount < 255) { + TclEmitInstInt1(INST_INVOKE_STK1, argCount, envPtr); + } else { + TclEmitInstInt4(INST_INVOKE_STK4, argCount, envPtr); + } + + *endPtrPtr = afterSubexprPtr; + return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -942,11 +873,19 @@ LogSyntaxError(infoPtr) ExprInfo *infoPtr; /* Describes the compilation state for the * expression being compiled. */ { Tcl_Obj *result = - Tcl_NewStringObj("syntax error in expression \"", -1); + Tcl_NewStringObj("syntax error in expression \"", -1); TclAppendLimitedToObj(result, infoPtr->expr, - (int)(infoPtr->lastChar - infoPtr->expr), 60, ""); + (int)(infoPtr->lastChar - infoPtr->expr), 60, ""); Tcl_AppendToObj(result, "\"", -1); Tcl_SetObjResult(infoPtr->interp, result); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclCompile.c ================================================================== --- generic/tclCompile.c +++ generic/tclCompile.c @@ -1,28 +1,28 @@ -/* +/* * tclCompile.c -- * - * This file contains procedures that compile Tcl commands or parts - * of commands (like quoted strings or nested sub-commands) into a - * sequence of instructions ("bytecodes"). + * This file contains procedures that compile Tcl commands or parts of + * commands (like quoted strings or nested sub-commands) into a sequence + * of instructions ("bytecodes"). * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * Copyright (c) 2001 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. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.c,v 1.78 2004/10/08 15:39:52 dkf Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.78.2.7 2005/08/02 18:15:19 dgp Exp $ */ #include "tclInt.h" #include "tclCompile.h" /* * Table of all AuxData types. */ - + static Tcl_HashTable auxDataTypeTable; static int auxDataTypeTableInitialized; /* 0 means not yet initialized. */ TCL_DECLARE_MUTEX(tableMutex) @@ -40,300 +40,357 @@ static int traceInitialized = 0; #endif /* * A table describing the Tcl bytecode instructions. Entries in this table - * must correspond to the instruction opcode definitions in tclCompile.h. - * The names "op1" and "op4" refer to an instruction's one or four byte - * first operand. Similarly, "stktop" and "stknext" refer to the topmost - * and next to topmost stack elements. + * must correspond to the instruction opcode definitions in tclCompile.h. The + * names "op1" and "op4" refer to an instruction's one or four byte first + * operand. Similarly, "stktop" and "stknext" refer to the topmost and next to + * topmost stack elements. * * Note that the load, store, and incr instructions do not distinguish local * from global variables; the bytecode interpreter at runtime uses the * existence of a procedure call frame to distinguish these. */ InstructionDesc tclInstructionTable[] = { - /* Name Bytes stackEffect #Opnds Operand types Stack top, next */ - {"done", 1, -1, 0, {OPERAND_NONE}}, + /* Name Bytes stackEffect #Opnds Operand types */ + {"done", 1, -1, 0, {OPERAND_NONE}}, /* Finish ByteCode execution and return stktop (top stack item) */ - {"push1", 2, +1, 1, {OPERAND_UINT1}}, + {"push1", 2, +1, 1, {OPERAND_UINT1}}, /* Push object at ByteCode objArray[op1] */ - {"push4", 5, +1, 1, {OPERAND_UINT4}}, + {"push4", 5, +1, 1, {OPERAND_UINT4}}, /* Push object at ByteCode objArray[op4] */ - {"pop", 1, -1, 0, {OPERAND_NONE}}, + {"pop", 1, -1, 0, {OPERAND_NONE}}, /* Pop the topmost stack object */ - {"dup", 1, +1, 0, {OPERAND_NONE}}, + {"dup", 1, +1, 0, {OPERAND_NONE}}, /* Duplicate the topmost stack object and push the result */ - {"concat1", 2, INT_MIN, 1, {OPERAND_UINT1}}, + {"concat1", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Concatenate the top op1 items and push result */ - {"invokeStk1", 2, INT_MIN, 1, {OPERAND_UINT1}}, + {"invokeStk1", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Invoke command named objv[0]; = */ - {"invokeStk4", 5, INT_MIN, 1, {OPERAND_UINT4}}, + {"invokeStk4", 5, INT_MIN, 1, {OPERAND_UINT4}}, /* Invoke command named objv[0]; = */ - {"evalStk", 1, 0, 0, {OPERAND_NONE}}, + {"evalStk", 1, 0, 0, {OPERAND_NONE}}, /* Evaluate command in stktop using Tcl_EvalObj. */ - {"exprStk", 1, 0, 0, {OPERAND_NONE}}, + {"exprStk", 1, 0, 0, {OPERAND_NONE}}, /* Execute expression in stktop using Tcl_ExprStringObj. */ - - {"loadScalar1", 2, 1, 1, {OPERAND_UINT1}}, + + {"loadScalar1", 2, 1, 1, {OPERAND_LVT1}}, /* Load scalar variable at index op1 <= 255 in call frame */ - {"loadScalar4", 5, 1, 1, {OPERAND_UINT4}}, + {"loadScalar4", 5, 1, 1, {OPERAND_LVT4}}, /* Load scalar variable at index op1 >= 256 in call frame */ - {"loadScalarStk", 1, 0, 0, {OPERAND_NONE}}, + {"loadScalarStk", 1, 0, 0, {OPERAND_NONE}}, /* Load scalar variable; scalar's name is stktop */ - {"loadArray1", 2, 0, 1, {OPERAND_UINT1}}, + {"loadArray1", 2, 0, 1, {OPERAND_LVT1}}, /* Load array element; array at slot op1<=255, element is stktop */ - {"loadArray4", 5, 0, 1, {OPERAND_UINT4}}, + {"loadArray4", 5, 0, 1, {OPERAND_LVT4}}, /* Load array element; array at slot op1 > 255, element is stktop */ - {"loadArrayStk", 1, -1, 0, {OPERAND_NONE}}, + {"loadArrayStk", 1, -1, 0, {OPERAND_NONE}}, /* Load array element; element is stktop, array name is stknext */ - {"loadStk", 1, 0, 0, {OPERAND_NONE}}, + {"loadStk", 1, 0, 0, {OPERAND_NONE}}, /* Load general variable; unparsed variable name is stktop */ - {"storeScalar1", 2, 0, 1, {OPERAND_UINT1}}, + {"storeScalar1", 2, 0, 1, {OPERAND_LVT1}}, /* Store scalar variable at op1<=255 in frame; value is stktop */ - {"storeScalar4", 5, 0, 1, {OPERAND_UINT4}}, + {"storeScalar4", 5, 0, 1, {OPERAND_LVT4}}, /* Store scalar variable at op1 > 255 in frame; value is stktop */ - {"storeScalarStk", 1, -1, 0, {OPERAND_NONE}}, + {"storeScalarStk", 1, -1, 0, {OPERAND_NONE}}, /* Store scalar; value is stktop, scalar name is stknext */ - {"storeArray1", 2, -1, 1, {OPERAND_UINT1}}, + {"storeArray1", 2, -1, 1, {OPERAND_LVT1}}, /* Store array element; array at op1<=255, value is top then elem */ - {"storeArray4", 5, -1, 1, {OPERAND_UINT4}}, + {"storeArray4", 5, -1, 1, {OPERAND_LVT4}}, /* Store array element; array at op1>=256, value is top then elem */ - {"storeArrayStk", 1, -2, 0, {OPERAND_NONE}}, + {"storeArrayStk", 1, -2, 0, {OPERAND_NONE}}, /* Store array element; value is stktop, then elem, array names */ - {"storeStk", 1, -1, 0, {OPERAND_NONE}}, + {"storeStk", 1, -1, 0, {OPERAND_NONE}}, /* Store general variable; value is stktop, then unparsed name */ - - {"incrScalar1", 2, 0, 1, {OPERAND_UINT1}}, + + {"incrScalar1", 2, 0, 1, {OPERAND_LVT1}}, /* Incr scalar at index op1<=255 in frame; incr amount is stktop */ - {"incrScalarStk", 1, -1, 0, {OPERAND_NONE}}, + {"incrScalarStk", 1, -1, 0, {OPERAND_NONE}}, /* Incr scalar; incr amount is stktop, scalar's name is stknext */ - {"incrArray1", 2, -1, 1, {OPERAND_UINT1}}, + {"incrArray1", 2, -1, 1, {OPERAND_LVT1}}, /* Incr array elem; arr at slot op1<=255, amount is top then elem */ - {"incrArrayStk", 1, -2, 0, {OPERAND_NONE}}, + {"incrArrayStk", 1, -2, 0, {OPERAND_NONE}}, /* Incr array element; amount is top then elem then array names */ - {"incrStk", 1, -1, 0, {OPERAND_NONE}}, + {"incrStk", 1, -1, 0, {OPERAND_NONE}}, /* Incr general variable; amount is stktop then unparsed var name */ - {"incrScalar1Imm", 3, +1, 2, {OPERAND_UINT1, OPERAND_INT1}}, + {"incrScalar1Imm", 3, +1, 2, {OPERAND_LVT1, OPERAND_INT1}}, /* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */ - {"incrScalarStkImm", 2, 0, 1, {OPERAND_INT1}}, + {"incrScalarStkImm", 2, 0, 1, {OPERAND_INT1}}, /* Incr scalar; scalar name is stktop; incr amount is op1 */ - {"incrArray1Imm", 3, 0, 2, {OPERAND_UINT1, OPERAND_INT1}}, + {"incrArray1Imm", 3, 0, 2, {OPERAND_LVT1, OPERAND_INT1}}, /* Incr array elem; array at slot op1 <= 255, elem is stktop, * amount is 2nd operand byte */ - {"incrArrayStkImm", 2, -1, 1, {OPERAND_INT1}}, + {"incrArrayStkImm", 2, -1, 1, {OPERAND_INT1}}, /* Incr array element; elem is top then array name, amount is op1 */ - {"incrStkImm", 2, 0, 1, {OPERAND_INT1}}, + {"incrStkImm", 2, 0, 1, {OPERAND_INT1}}, /* Incr general variable; unparsed name is top, amount is op1 */ - - {"jump1", 2, 0, 1, {OPERAND_INT1}}, + + {"jump1", 2, 0, 1, {OPERAND_INT1}}, /* Jump relative to (pc + op1) */ - {"jump4", 5, 0, 1, {OPERAND_INT4}}, + {"jump4", 5, 0, 1, {OPERAND_INT4}}, /* Jump relative to (pc + op4) */ - {"jumpTrue1", 2, -1, 1, {OPERAND_INT1}}, + {"jumpTrue1", 2, -1, 1, {OPERAND_INT1}}, /* Jump relative to (pc + op1) if stktop expr object is true */ - {"jumpTrue4", 5, -1, 1, {OPERAND_INT4}}, + {"jumpTrue4", 5, -1, 1, {OPERAND_INT4}}, /* Jump relative to (pc + op4) if stktop expr object is true */ - {"jumpFalse1", 2, -1, 1, {OPERAND_INT1}}, + {"jumpFalse1", 2, -1, 1, {OPERAND_INT1}}, /* Jump relative to (pc + op1) if stktop expr object is false */ - {"jumpFalse4", 5, -1, 1, {OPERAND_INT4}}, + {"jumpFalse4", 5, -1, 1, {OPERAND_INT4}}, /* Jump relative to (pc + op4) if stktop expr object is false */ - {"lor", 1, -1, 0, {OPERAND_NONE}}, + {"lor", 1, -1, 0, {OPERAND_NONE}}, /* Logical or: push (stknext || stktop) */ - {"land", 1, -1, 0, {OPERAND_NONE}}, + {"land", 1, -1, 0, {OPERAND_NONE}}, /* Logical and: push (stknext && stktop) */ - {"bitor", 1, -1, 0, {OPERAND_NONE}}, + {"bitor", 1, -1, 0, {OPERAND_NONE}}, /* Bitwise or: push (stknext | stktop) */ - {"bitxor", 1, -1, 0, {OPERAND_NONE}}, + {"bitxor", 1, -1, 0, {OPERAND_NONE}}, /* Bitwise xor push (stknext ^ stktop) */ - {"bitand", 1, -1, 0, {OPERAND_NONE}}, + {"bitand", 1, -1, 0, {OPERAND_NONE}}, /* Bitwise and: push (stknext & stktop) */ - {"eq", 1, -1, 0, {OPERAND_NONE}}, + {"eq", 1, -1, 0, {OPERAND_NONE}}, /* Equal: push (stknext == stktop) */ - {"neq", 1, -1, 0, {OPERAND_NONE}}, + {"neq", 1, -1, 0, {OPERAND_NONE}}, /* Not equal: push (stknext != stktop) */ - {"lt", 1, -1, 0, {OPERAND_NONE}}, + {"lt", 1, -1, 0, {OPERAND_NONE}}, /* Less: push (stknext < stktop) */ - {"gt", 1, -1, 0, {OPERAND_NONE}}, + {"gt", 1, -1, 0, {OPERAND_NONE}}, /* Greater: push (stknext || stktop) */ - {"le", 1, -1, 0, {OPERAND_NONE}}, + {"le", 1, -1, 0, {OPERAND_NONE}}, /* Logical or: push (stknext || stktop) */ - {"ge", 1, -1, 0, {OPERAND_NONE}}, + {"ge", 1, -1, 0, {OPERAND_NONE}}, /* Logical or: push (stknext || stktop) */ - {"lshift", 1, -1, 0, {OPERAND_NONE}}, + {"lshift", 1, -1, 0, {OPERAND_NONE}}, /* Left shift: push (stknext << stktop) */ - {"rshift", 1, -1, 0, {OPERAND_NONE}}, + {"rshift", 1, -1, 0, {OPERAND_NONE}}, /* Right shift: push (stknext >> stktop) */ - {"add", 1, -1, 0, {OPERAND_NONE}}, + {"add", 1, -1, 0, {OPERAND_NONE}}, /* Add: push (stknext + stktop) */ - {"sub", 1, -1, 0, {OPERAND_NONE}}, + {"sub", 1, -1, 0, {OPERAND_NONE}}, /* Sub: push (stkext - stktop) */ - {"mult", 1, -1, 0, {OPERAND_NONE}}, + {"mult", 1, -1, 0, {OPERAND_NONE}}, /* Multiply: push (stknext * stktop) */ - {"div", 1, -1, 0, {OPERAND_NONE}}, + {"div", 1, -1, 0, {OPERAND_NONE}}, /* Divide: push (stknext / stktop) */ - {"mod", 1, -1, 0, {OPERAND_NONE}}, + {"mod", 1, -1, 0, {OPERAND_NONE}}, /* Mod: push (stknext % stktop) */ - {"uplus", 1, 0, 0, {OPERAND_NONE}}, + {"uplus", 1, 0, 0, {OPERAND_NONE}}, /* Unary plus: push +stktop */ - {"uminus", 1, 0, 0, {OPERAND_NONE}}, + {"uminus", 1, 0, 0, {OPERAND_NONE}}, /* Unary minus: push -stktop */ - {"bitnot", 1, 0, 0, {OPERAND_NONE}}, + {"bitnot", 1, 0, 0, {OPERAND_NONE}}, /* Bitwise not: push ~stktop */ - {"not", 1, 0, 0, {OPERAND_NONE}}, + {"not", 1, 0, 0, {OPERAND_NONE}}, /* Logical not: push !stktop */ - {"callBuiltinFunc1", 2, 1, 1, {OPERAND_UINT1}}, + {"callBuiltinFunc1", 2, 1, 1, {OPERAND_UINT1}}, /* Call builtin math function with index op1; any args are on stk */ - {"callFunc1", 2, INT_MIN, 1, {OPERAND_UINT1}}, + {"callFunc1", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Call non-builtin func objv[0]; = */ - {"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}}, + {"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}}, /* Try converting stktop to first int then double if possible. */ - {"break", 1, 0, 0, {OPERAND_NONE}}, + {"break", 1, 0, 0, {OPERAND_NONE}}, /* Abort closest enclosing loop; if none, return TCL_BREAK code. */ - {"continue", 1, 0, 0, {OPERAND_NONE}}, - /* Skip to next iteration of closest enclosing loop; if none, - * return TCL_CONTINUE code. */ + {"continue", 1, 0, 0, {OPERAND_NONE}}, + /* Skip to next iteration of closest enclosing loop; if none, return + * TCL_CONTINUE code. */ - {"foreach_start4", 5, 0, 1, {OPERAND_UINT4}}, + {"foreach_start4", 5, 0, 1, {OPERAND_UINT4}}, /* Initialize execution of a foreach loop. Operand is aux data index * of the ForeachInfo structure for the foreach command. */ - {"foreach_step4", 5, +1, 1, {OPERAND_UINT4}}, + {"foreach_step4", 5, +1, 1, {OPERAND_UINT4}}, /* "Step" or begin next iteration of foreach loop. Push 0 if to * terminate loop, else push 1. */ - {"beginCatch4", 5, 0, 1, {OPERAND_UINT4}}, - /* Record start of catch with the operand's exception index. - * Push the current stack depth onto a special catch stack. */ - {"endCatch", 1, 0, 0, {OPERAND_NONE}}, + {"beginCatch4", 5, 0, 1, {OPERAND_UINT4}}, + /* Record start of catch with the operand's exception index. Push the + * current stack depth onto a special catch stack. */ + {"endCatch", 1, 0, 0, {OPERAND_NONE}}, /* End of last catch. Pop the bytecode interpreter's catch stack. */ - {"pushResult", 1, +1, 0, {OPERAND_NONE}}, + {"pushResult", 1, +1, 0, {OPERAND_NONE}}, /* Push the interpreter's object result onto the stack. */ - {"pushReturnCode", 1, +1, 0, {OPERAND_NONE}}, - /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as - * a new object onto the stack. */ - {"streq", 1, -1, 0, {OPERAND_NONE}}, + {"pushReturnCode", 1, +1, 0, {OPERAND_NONE}}, + /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as a new + * object onto the stack. */ + + {"streq", 1, -1, 0, {OPERAND_NONE}}, /* Str Equal: push (stknext eq stktop) */ - {"strneq", 1, -1, 0, {OPERAND_NONE}}, + {"strneq", 1, -1, 0, {OPERAND_NONE}}, /* Str !Equal: push (stknext neq stktop) */ - {"strcmp", 1, -1, 0, {OPERAND_NONE}}, + {"strcmp", 1, -1, 0, {OPERAND_NONE}}, /* Str Compare: push (stknext cmp stktop) */ - {"strlen", 1, 0, 0, {OPERAND_NONE}}, + {"strlen", 1, 0, 0, {OPERAND_NONE}}, /* Str Length: push (strlen stktop) */ - {"strindex", 1, -1, 0, {OPERAND_NONE}}, + {"strindex", 1, -1, 0, {OPERAND_NONE}}, /* Str Index: push (strindex stknext stktop) */ - {"strmatch", 2, -1, 1, {OPERAND_INT1}}, + {"strmatch", 2, -1, 1, {OPERAND_INT1}}, /* Str Match: push (strmatch stknext stktop) opnd == nocase */ - {"list", 5, INT_MIN, 1, {OPERAND_UINT4}}, + + {"list", 5, INT_MIN, 1, {OPERAND_UINT4}}, /* List: push (stk1 stk2 ... stktop) */ - {"listIndex", 1, -1, 0, {OPERAND_NONE}}, + {"listIndex", 1, -1, 0, {OPERAND_NONE}}, /* List Index: push (listindex stknext stktop) */ - {"listLength", 1, 0, 0, {OPERAND_NONE}}, + {"listLength", 1, 0, 0, {OPERAND_NONE}}, /* List Len: push (listlength stktop) */ - {"appendScalar1", 2, 0, 1, {OPERAND_UINT1}}, + + {"appendScalar1", 2, 0, 1, {OPERAND_LVT1}}, /* Append scalar variable at op1<=255 in frame; value is stktop */ - {"appendScalar4", 5, 0, 1, {OPERAND_UINT4}}, + {"appendScalar4", 5, 0, 1, {OPERAND_LVT4}}, /* Append scalar variable at op1 > 255 in frame; value is stktop */ - {"appendArray1", 2, -1, 1, {OPERAND_UINT1}}, + {"appendArray1", 2, -1, 1, {OPERAND_LVT1}}, /* Append array element; array at op1<=255, value is top then elem */ - {"appendArray4", 5, -1, 1, {OPERAND_UINT4}}, + {"appendArray4", 5, -1, 1, {OPERAND_LVT4}}, /* Append array element; array at op1>=256, value is top then elem */ - {"appendArrayStk", 1, -2, 0, {OPERAND_NONE}}, + {"appendArrayStk", 1, -2, 0, {OPERAND_NONE}}, /* Append array element; value is stktop, then elem, array names */ - {"appendStk", 1, -1, 0, {OPERAND_NONE}}, + {"appendStk", 1, -1, 0, {OPERAND_NONE}}, /* Append general variable; value is stktop, then unparsed name */ - {"lappendScalar1", 2, 0, 1, {OPERAND_UINT1}}, + {"lappendScalar1", 2, 0, 1, {OPERAND_LVT1}}, /* Lappend scalar variable at op1<=255 in frame; value is stktop */ - {"lappendScalar4", 5, 0, 1, {OPERAND_UINT4}}, + {"lappendScalar4", 5, 0, 1, {OPERAND_LVT4}}, /* Lappend scalar variable at op1 > 255 in frame; value is stktop */ - {"lappendArray1", 2, -1, 1, {OPERAND_UINT1}}, + {"lappendArray1", 2, -1, 1, {OPERAND_LVT1}}, /* Lappend array element; array at op1<=255, value is top then elem */ - {"lappendArray4", 5, -1, 1, {OPERAND_UINT4}}, + {"lappendArray4", 5, -1, 1, {OPERAND_LVT4}}, /* Lappend array element; array at op1>=256, value is top then elem */ - {"lappendArrayStk", 1, -2, 0, {OPERAND_NONE}}, + {"lappendArrayStk", 1, -2, 0, {OPERAND_NONE}}, /* Lappend array element; value is stktop, then elem, array names */ - {"lappendStk", 1, -1, 0, {OPERAND_NONE}}, + {"lappendStk", 1, -1, 0, {OPERAND_NONE}}, /* Lappend general variable; value is stktop, then unparsed name */ - {"lindexMulti", 5, INT_MIN, 1, {OPERAND_UINT4}}, - /* Lindex with generalized args, operand is number of stacked objs - * used: (operand-1) entries from stktop are the indices; then list - * to process. */ - {"over", 5, +1, 1, {OPERAND_UINT4}}, - /* Duplicate the arg-th element from top of stack (TOS=0) */ - {"lsetList", 1, -2, 0, {OPERAND_NONE}}, - /* Four-arg version of 'lset'. stktop is old value; next is - * new element value, next is the index list; pushes new value */ - {"lsetFlat", 5, INT_MIN, 1, {OPERAND_UINT4}}, - /* Three- or >=5-arg version of 'lset', operand is number of - * stacked objs: stktop is old value, next is new element value, next - * come (operand-2) indices; pushes the new value. + + {"lindexMulti", 5, INT_MIN, 1, {OPERAND_UINT4}}, + /* Lindex with generalized args, operand is number of stacked objs + * used: (operand-1) entries from stktop are the indices; then list to + * process. */ + {"over", 5, +1, 1, {OPERAND_UINT4}}, + /* Duplicate the arg-th element from top of stack (TOS=0) */ + {"lsetList", 1, -2, 0, {OPERAND_NONE}}, + /* Four-arg version of 'lset'. stktop is old value; next is new + * element value, next is the index list; pushes new value */ + {"lsetFlat", 5, INT_MIN, 1, {OPERAND_UINT4}}, + /* Three- or >=5-arg version of 'lset', operand is number of stacked + * objs: stktop is old value, next is new element value, next come + * (operand-2) indices; pushes the new value. */ - {"return", 9, -2, 2, {OPERAND_INT4, OPERAND_UINT4}}, + + {"returnImm", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}}, /* Compiled [return], code, level are operands; options and result * are on the stack. */ {"expon", 1, -1, 0, {OPERAND_NONE}}, /* Binary exponentiation operator: push (stknext ** stktop) */ - /* - * NOTE: the stack effects of expandStkTop and invokeExpanded - * are wrong - but it cannot be done right at compile time, the stack - * effect is only known at run time. The value for invokeExpanded - * is estimated better at compile time. - * See the comments further down in this file, where INST_INVOKE_EXPANDED - * is emitted. - */ - {"expandStart", 1, 0, 0, {OPERAND_NONE}}, - /* Start of command with {expand}ed arguments */ - {"expandStkTop", 5, 0, 1, {OPERAND_INT4}}, - /* Expand the list at stacktop: push its elements on the stack */ - {"invokeExpanded", 1, 0, 0, {OPERAND_NONE}}, - /* Invoke the command marked by the last 'expandStart' */ + + /* + * NOTE: the stack effects of expandStkTop and invokeExpanded are wrong - + * but it cannot be done right at compile time, the stack effect is only + * known at run time. The value for invokeExpanded is estimated better at + * compile time. + * See the comments further down in this file, where INST_INVOKE_EXPANDED + * is emitted. + */ + {"expandStart", 1, 0, 0, {OPERAND_NONE}}, + /* Start of command with {expand}ed arguments */ + {"expandStkTop", 5, 0, 1, {OPERAND_INT4}}, + /* Expand the list at stacktop: push its elements on the stack */ + {"invokeExpanded", 1, 0, 0, {OPERAND_NONE}}, + /* Invoke the command marked by the last 'expandStart' */ + {"listIndexImm", 5, 0, 1, {OPERAND_IDX4}}, /* List Index: push (lindex stktop op4) */ {"listRangeImm", 9, 0, 2, {OPERAND_IDX4, OPERAND_IDX4}}, /* List Range: push (lrange stktop op4 op4) */ - - {"startCommand", 5, 0, 1, {OPERAND_UINT4}}, - /* Start of bytecoded command: op is the length of the cmd's code */ + {"startCommand", 5, 0, 1, {OPERAND_UINT4}}, + /* Start of bytecoded command: op is the length of the cmd's code */ {"listIn", 1, -1, 0, {OPERAND_NONE}}, /* List containment: push [lsearch stktop stknext]>=0) */ {"listNotIn", 1, -1, 0, {OPERAND_NONE}}, /* List negated containment: push [lsearch stktop stknext]<0) */ + + {"pushReturnOpts", 1, +1, 0, {OPERAND_NONE}}, + /* Push the interpreter's return option dictionary as an object on the + * stack. */ + {"returnStk", 1, -2, 0, {OPERAND_NONE}}, + /* Compiled [return]; options and result are on the stack, code and + * level are in the options. */ + + {"dictGet", 5, INT_MIN, 1, {OPERAND_UINT4}}, + /* The top op4 words (min 1) are a key path into the dictionary just + * below the keys on the stack, and all those values are replaced by + * the value read out of that key-path (like [dict get]). + * Stack: ... dict key1 ... keyN => ... value */ + {"dictSet", 5, INT_MIN, 2, {OPERAND_UINT4, OPERAND_LVT4}}, + /* Update a dictionary value such that the keys are a path pointing to + * the value. op4#1 = numKeys, op4#2 = LVTindex + * Stack: ... key1 ... keyN value => ... newDict */ + {"dictUnset", 5, INT_MIN, 2, {OPERAND_UINT4, OPERAND_LVT4}}, + /* Update a dictionary value such that the keys are not a path pointing + * to any value. op4#1 = numKeys, op4#2 = LVTindex + * Stack: ... key1 ... keyN => ... newDict */ + {"dictIncrImm", 5, 0, 2, {OPERAND_INT4, OPERAND_LVT4}}, + /* Update a dictionary value such that the value pointed to by key is + * incremented by some value (or set to it if the key isn't in the + * dictionary at all). op4#1 = incrAmount, op4#2 = LVTindex + * Stack: ... key => ... newDict */ + {"dictAppend", 5, -1, 1, {OPERAND_LVT4}}, + /* Update a dictionary value such that the value pointed to by key has + * some value string-concatenated onto it. op4 = LVTindex + * Stack: ... key valueToAppend => ... newDict */ + {"dictLappend", 5, -1, 1, {OPERAND_LVT4}}, + /* Update a dictionary value such that the value pointed to by key has + * some value list-appended onto it. op4 = LVTindex + * Stack: ... key valueToAppend => ... newDict */ + {"dictFirst", 5, +2, 1, {OPERAND_LVT4}}, + /* Begin iterating over the dictionary, using the local scalar + * indicated by op4 to hold the iterator state. If doneBool is true, + * dictDone *must* be called later on. + * Stack: ... dict => ... value key doneBool */ + {"dictNext", 5, +3, 1, {OPERAND_LVT4}}, + /* Get the next iteration from the iterator in op4's local scalar. + * Stack: ... => ... value key doneBool */ + {"dictDone", 5, 0, 1, {OPERAND_LVT4}}, + /* Terminate the iterator in op4's local scalar. */ + {"dictUpdateStart", 5, -2, 1, {OPERAND_LVT4}}, + /* Create the variables to mirror the state of the dictionary in the + * variable referred to by the immediate argument. + * Stack: ... keyList LVTindexList => ... + * Note that the list of LVT indices is assumed to be the same length + * as the keyList, and the indices should be only ever generated by the + * compiler. */ + {"dictUpdateEnd", 5, -2, 1, {OPERAND_LVT4}}, + /* Reflect the state of local variables back to the state of the + * dictionary in the variable referred to by the immediate argument. + * Stack: ... keyList LVTindexList => ... + * Same notes as in "dictUpdateStart" apply here. */ {0} }; /* * Prototypes for procedures defined later in this file: */ static void DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *copyPtr)); -static unsigned char * EncodeCmdLocMap _ANSI_ARGS_(( - CompileEnv *envPtr, ByteCode *codePtr, - unsigned char *startPtr)); -static void EnterCmdExtentData _ANSI_ARGS_(( - CompileEnv *envPtr, int cmdNumber, - int numSrcBytes, int numCodeBytes)); -static void EnterCmdStartData _ANSI_ARGS_(( - CompileEnv *envPtr, int cmdNumber, - int srcOffset, int codeOffset)); -static void FreeByteCodeInternalRep _ANSI_ARGS_(( - Tcl_Obj *objPtr)); +static unsigned char * EncodeCmdLocMap _ANSI_ARGS_((CompileEnv *envPtr, + ByteCode *codePtr, unsigned char *startPtr)); +static void EnterCmdExtentData _ANSI_ARGS_((CompileEnv *envPtr, + int cmdNumber, int numSrcBytes, int numCodeBytes)); +static void EnterCmdStartData _ANSI_ARGS_((CompileEnv *envPtr, + int cmdNumber, int srcOffset, int codeOffset)); +static void FreeByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); static int GetCmdLocEncodingSize _ANSI_ARGS_(( CompileEnv *envPtr)); #ifdef TCL_COMPILE_STATS -static void RecordByteCodeStats _ANSI_ARGS_(( - ByteCode *codePtr)); +static void RecordByteCodeStats _ANSI_ARGS_((ByteCode *codePtr)); #endif /* TCL_COMPILE_STATS */ static int SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); /* - * The structure below defines the bytecode Tcl object type by - * means of procedures that can be invoked by generic object code. + * The structure below defines the bytecode Tcl object type by means of + * procedures that can be invoked by generic object code. */ Tcl_ObjType tclByteCodeType = { "bytecode", /* name */ FreeByteCodeInternalRep, /* freeIntRepProc */ @@ -347,56 +404,55 @@ * * TclSetByteCodeFromAny -- * * Part of the bytecode Tcl object type implementation. Attempts to * generate an byte code internal form for the Tcl object "objPtr" by - * compiling its string representation. This function also takes - * a hook procedure that will be invoked to perform any needed post - * processing on the compilation results before generating byte - * codes. + * compiling its string representation. This function also takes a hook + * procedure that will be invoked to perform any needed post processing + * on the compilation results before generating byte codes. * * Results: * The return value is a standard Tcl object result. If an error occurs * during compilation, an error message is left in the interpreter's * result unless "interp" is NULL. * * Side effects: * Frees the old internal representation. If no error occurs, then the - * compiled code is stored as "objPtr"s bytecode representation. - * Also, if debugging, initializes the "tcl_traceCompile" Tcl variable - * used to trace compilations. + * compiled code is stored as "objPtr"s bytecode representation. Also, if + * debugging, initializes the "tcl_traceCompile" Tcl variable used to + * trace compilations. * *---------------------------------------------------------------------- */ int TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData) - Tcl_Interp *interp; /* The interpreter for which the code is - * being compiled. Must not be NULL. */ + Tcl_Interp *interp; /* The interpreter for which the code is being + * compiled. Must not be NULL. */ Tcl_Obj *objPtr; /* The object to make a ByteCode object. */ CompileHookProc *hookProc; /* Procedure to invoke after compilation. */ ClientData clientData; /* Hook procedure private data. */ { #ifdef TCL_COMPILE_DEBUG Interp *iPtr = (Interp *) interp; #endif /*TCL_COMPILE_DEBUG*/ - CompileEnv compEnv; /* Compilation environment structure - * allocated in frame. */ + CompileEnv compEnv; /* Compilation environment structure allocated + * in frame. */ LiteralTable *localTablePtr = &(compEnv.localLitTable); register AuxData *auxDataPtr; LiteralEntry *entryPtr; register int i; int length, result = TCL_OK; char *stringPtr; #ifdef TCL_COMPILE_DEBUG if (!traceInitialized) { - if (Tcl_LinkVar(interp, "tcl_traceCompile", - (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) { - Tcl_Panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable"); - } - traceInitialized = 1; + if (Tcl_LinkVar(interp, "tcl_traceCompile", + (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) { + Tcl_Panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable"); + } + traceInitialized = 1; } #endif stringPtr = Tcl_GetStringFromObj(objPtr, &length); TclInitCompileEnv(interp, &compEnv, stringPtr, length); @@ -411,29 +467,29 @@ /* * Invoke the compilation hook procedure if one exists. */ if (hookProc) { - result = (*hookProc)(interp, &compEnv, clientData); + result = (*hookProc)(interp, &compEnv, clientData); } /* * Change the object into a ByteCode object. Ownership of the literal * objects and aux data items is given to the ByteCode object. */ - + #ifdef TCL_COMPILE_DEBUG TclVerifyLocalLiteralTable(&compEnv); #endif /*TCL_COMPILE_DEBUG*/ TclInitByteCodeObj(objPtr, &compEnv); #ifdef TCL_COMPILE_DEBUG if (tclTraceCompile >= 2) { - TclPrintByteCodeObj(interp, objPtr); + TclPrintByteCodeObj(interp, objPtr); } #endif /* TCL_COMPILE_DEBUG */ - + if (result != TCL_OK) { /* * Handle any error from the hookProc */ @@ -453,15 +509,14 @@ } auxDataPtr++; } } - /* * Free storage allocated during compilation. */ - + if (localTablePtr->buckets != localTablePtr->staticBuckets) { ckfree((char *) localTablePtr->buckets); } TclFreeCompileEnv(&compEnv); return result; @@ -481,21 +536,21 @@ * during compilation, an error message is left in the interpreter's * result unless "interp" is NULL. * * Side effects: * Frees the old internal representation. If no error occurs, then the - * compiled code is stored as "objPtr"s bytecode representation. - * Also, if debugging, initializes the "tcl_traceCompile" Tcl variable - * used to trace compilations. + * compiled code is stored as "objPtr"s bytecode representation. Also, + * if debugging, initializes the "tcl_traceCompile" Tcl variable used to + * trace compilations. * *---------------------------------------------------------------------- */ static int SetByteCodeFromAny(interp, objPtr) - Tcl_Interp *interp; /* The interpreter for which the code is - * being compiled. Must not be NULL. */ + Tcl_Interp *interp; /* The interpreter for which the code is being + * compiled. Must not be NULL. */ Tcl_Obj *objPtr; /* The object to make a ByteCode object. */ { return TclSetByteCodeFromAny(interp, objPtr, (CompileHookProc *) NULL, (ClientData) NULL); } @@ -503,12 +558,12 @@ /* *---------------------------------------------------------------------- * * DupByteCodeInternalRep -- * - * Part of the bytecode Tcl object type implementation. However, it - * does not copy the internal representation of a bytecode Tcl_Obj, but + * Part of the bytecode Tcl object type implementation. However, it does + * not copy the internal representation of a bytecode Tcl_Obj, but * instead leaves the new object untyped (with a NULL type pointer). * Code will be compiled for the new object only if necessary. * * Results: * None. @@ -530,32 +585,31 @@ /* *---------------------------------------------------------------------- * * FreeByteCodeInternalRep -- * - * Part of the bytecode Tcl object type implementation. Frees the - * storage associated with a bytecode object's internal representation - * unless its code is actively being executed. + * Part of the bytecode Tcl object type implementation. Frees the storage + * associated with a bytecode object's internal representation unless its + * code is actively being executed. * * Results: * None. * * Side effects: - * The bytecode object's internal rep is marked invalid and its - * code gets freed unless the code is actively being executed. - * In that case the cleanup is delayed until the last execution - * of the code completes. + * The bytecode object's internal rep is marked invalid and its code gets + * freed unless the code is actively being executed. In that case the + * cleanup is delayed until the last execution of the code completes. * *---------------------------------------------------------------------- */ static void FreeByteCodeInternalRep(objPtr) register Tcl_Obj *objPtr; /* Object whose internal rep to free. */ { - register ByteCode *codePtr = - (ByteCode *) objPtr->internalRep.otherValuePtr; + register ByteCode *codePtr = (ByteCode *) + objPtr->internalRep.otherValuePtr; codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); } @@ -574,13 +628,13 @@ * * Results: * None. * * Side effects: - * Frees objPtr's bytecode internal representation and sets its type - * and objPtr->internalRep.otherValuePtr NULL. Also releases its - * literals and frees its auxiliary data items. + * Frees objPtr's bytecode internal representation and sets its type and + * objPtr->internalRep.otherValuePtr NULL. Also releases its literals and + * frees its auxiliary data items. * *---------------------------------------------------------------------- */ void @@ -604,58 +658,57 @@ statsPtr->numByteCodesFreed++; statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes; statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize; - statsPtr->currentInstBytes -= (double) codePtr->numCodeBytes; - statsPtr->currentLitBytes -= - (double) (codePtr->numLitObjects * sizeof(Tcl_Obj *)); - statsPtr->currentExceptBytes -= - (double) (codePtr->numExceptRanges * sizeof(ExceptionRange)); - statsPtr->currentAuxBytes -= - (double) (codePtr->numAuxDataItems * sizeof(AuxData)); + statsPtr->currentInstBytes -= (double) codePtr->numCodeBytes; + statsPtr->currentLitBytes -= (double) + codePtr->numLitObjects * sizeof(Tcl_Obj *); + statsPtr->currentExceptBytes -= (double) + codePtr->numExceptRanges * sizeof(ExceptionRange); + statsPtr->currentAuxBytes -= (double) + codePtr->numAuxDataItems * sizeof(AuxData); statsPtr->currentCmdMapBytes -= (double) codePtr->numCmdLocBytes; Tcl_GetTime(&destroyTime); lifetimeSec = destroyTime.sec - codePtr->createTime.sec; if (lifetimeSec > 2000) { /* avoid overflow */ lifetimeSec = 2000; } - lifetimeMicroSec = - 1000000*lifetimeSec + (destroyTime.usec - codePtr->createTime.usec); - + lifetimeMicroSec = 1000000 * lifetimeSec + + (destroyTime.usec - codePtr->createTime.usec); + log2 = TclLog2(lifetimeMicroSec); if (log2 > 31) { log2 = 31; } statsPtr->lifetimeCount[log2]++; } #endif /* TCL_COMPILE_STATS */ /* - * A single heap object holds the ByteCode structure and its code, - * object, command location, and auxiliary data arrays. This means we - * only need to 1) decrement the ref counts of the LiteralEntry's in - * its literal array, 2) call the free procs for the auxiliary data - * items, and 3) free the ByteCode structure's heap object. - * - * The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes, - * like those generated from tbcload) is special, as they doesn't - * make use of the global literal table. They instead maintain - * private references to their literals which must be decremented. - * - * In order to insure a proper and efficient cleanup of the literal - * array when it contains non-shared literals [Bug 983660], we also - * distinguish the case of an interpreter being deleted (signaled by - * interp == NULL). Also, as the interp deletion will remove the global - * literal table anyway, we avoid the extra cost of updating it for each - * literal being released. - */ - - if ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) - || (interp == NULL)) { - + * A single heap object holds the ByteCode structure and its code, object, + * command location, and auxiliary data arrays. This means we only need to + * 1) decrement the ref counts of the LiteralEntry's in its literal array, + * 2) call the free procs for the auxiliary data items, and 3) free the + * ByteCode structure's heap object. + * + * The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes, like + * those generated from tbcload) is special, as they doesn't make use of + * the global literal table. They instead maintain private references to + * their literals which must be decremented. + * + * In order to insure a proper and efficient cleanup of the literal array + * when it contains non-shared literals [Bug 983660], we also distinguish + * the case of an interpreter being deleted (signaled by interp == NULL). + * Also, as the interp deletion will remove the global literal table + * anyway, we avoid the extra cost of updating it for each literal being + * released. + */ + + if ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) || (interp == NULL)) { + objArrayPtr = codePtr->objArrayPtr; for (i = 0; i < numLitObjects; i++) { objPtr = *objArrayPtr; if (objPtr) { Tcl_DecrRefCount(objPtr); @@ -668,23 +721,23 @@ for (i = 0; i < numLitObjects; i++) { /* * TclReleaseLiteral sets a ByteCode's object array entry NULL to * indicate that it has already freed the literal. */ - + objPtr = *objArrayPtr; if (objPtr != NULL) { TclReleaseLiteral(interp, objPtr); } objArrayPtr++; } } - + auxDataPtr = codePtr->auxDataArrayPtr; for (i = 0; i < numAuxDataItems; i++) { if (auxDataPtr->type->freeProc != NULL) { - (*auxDataPtr->type->freeProc)(auxDataPtr->clientData); + (auxDataPtr->type->freeProc)(auxDataPtr->clientData); } auxDataPtr++; } TclHandleRelease(codePtr->interpHandle); @@ -716,11 +769,11 @@ * initialize. */ char *stringPtr; /* The source string to be compiled. */ int numBytes; /* Number of bytes in source string. */ { Interp *iPtr = (Interp *) interp; - + envPtr->iPtr = iPtr; envPtr->source = stringPtr; envPtr->numSrcBytes = numBytes; envPtr->procPtr = iPtr->compiledProcPtr; envPtr->numCommands = 0; @@ -737,20 +790,20 @@ envPtr->literalArrayPtr = envPtr->staticLiteralSpace; envPtr->literalArrayNext = 0; envPtr->literalArrayEnd = COMPILEENV_INIT_NUM_OBJECTS; envPtr->mallocedLiteralArray = 0; - + envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace; envPtr->exceptArrayNext = 0; envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES; envPtr->mallocedExceptArray = 0; - + envPtr->cmdMapPtr = envPtr->staticCmdMapSpace; envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE; envPtr->mallocedCmdMap = 0; - + envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace; envPtr->auxDataArrayNext = 0; envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE; envPtr->mallocedAuxDataArray = 0; } @@ -763,18 +816,18 @@ * Free the storage allocated in a CompileEnv compilation environment * structure. * * Results: * None. - * + * * Side effects: - * Allocated storage in the CompileEnv structure is freed. Note that - * its local literal table is not deleted and its literal objects are - * not released. In addition, storage referenced by its auxiliary data - * items is not freed. This is done so that, when compilation is - * successful, "ownership" of these objects and aux data items is - * handed over to the corresponding ByteCode structure. + * Allocated storage in the CompileEnv structure is freed. Note that its + * local literal table is not deleted and its literal objects are not + * released. In addition, storage referenced by its auxiliary data items + * is not freed. This is done so that, when compilation is successful, + * "ownership" of these objects and aux data items is handed over to the + * corresponding ByteCode structure. * *---------------------------------------------------------------------- */ void @@ -801,25 +854,24 @@ /* *---------------------------------------------------------------------- * * TclWordKnownAtCompileTime -- * - * Test whether the value of a token is completely known at compile - * time. + * Test whether the value of a token is completely known at compile time. * * Results: - * Returns true if the tokenPtr argument points to a word value that - * is completely known at compile time. Generally, values that are - * known at compile time can be compiled to their values, while values - * that cannot be known until substitution at runtime must be compiled - * to bytecode instructions that perform that substitution. For several - * commands, whether or not arguments are known at compile time determine - * whether it is worthwhile to compile at all. + * Returns true if the tokenPtr argument points to a word value that is + * completely known at compile time. Generally, values that are known at + * compile time can be compiled to their values, while values that cannot + * be known until substitution at runtime must be compiled to bytecode + * instructions that perform that substitution. For several commands, + * whether or not arguments are known at compile time determine whether + * it is worthwhile to compile at all. * * Side effects: - * When returning true, appends the known value of the word to - * the unshared Tcl_Obj (*valuePtr), unless valuePtr is NULL. + * When returning true, appends the known value of the word to the + * unshared Tcl_Obj (*valuePtr), unless valuePtr is NULL. * *---------------------------------------------------------------------- */ int @@ -846,30 +898,29 @@ tempPtr = Tcl_NewObj(); Tcl_IncrRefCount(tempPtr); } while (numComponents--) { switch (tokenPtr->type) { - case TCL_TOKEN_TEXT: - if (tempPtr != NULL) { - Tcl_AppendToObj(tempPtr, tokenPtr->start, tokenPtr->size); - } - break; - - case TCL_TOKEN_BS: - if (tempPtr != NULL) { - char utfBuf[TCL_UTF_MAX]; - int length = - Tcl_UtfBackslash(tokenPtr->start, NULL, utfBuf); - Tcl_AppendToObj(tempPtr, utfBuf, length); - } - break; - - default: - if (tempPtr != NULL) { - Tcl_DecrRefCount(tempPtr); - } - return 0; + case TCL_TOKEN_TEXT: + if (tempPtr != NULL) { + Tcl_AppendToObj(tempPtr, tokenPtr->start, tokenPtr->size); + } + break; + + case TCL_TOKEN_BS: + if (tempPtr != NULL) { + char utfBuf[TCL_UTF_MAX]; + int length = Tcl_UtfBackslash(tokenPtr->start, NULL, utfBuf); + Tcl_AppendToObj(tempPtr, utfBuf, length); + } + break; + + default: + if (tempPtr != NULL) { + Tcl_DecrRefCount(tempPtr); + } + return 0; } tokenPtr++; } if (valuePtr != NULL) { Tcl_AppendObjToObj(valuePtr, tempPtr); @@ -896,13 +947,13 @@ *---------------------------------------------------------------------- */ void TclCompileScript(interp, script, numBytes, envPtr) - Tcl_Interp *interp; /* Used for error and status reporting. - * Also serves as context for finding and - * compiling commands. May not be NULL. */ + Tcl_Interp *interp; /* Used for error and status reporting. Also + * serves as context for finding and compiling + * commands. May not be NULL. */ CONST char *script; /* The source script to compile. */ int numBytes; /* Number of bytes in script. If < 0, the * script consists of all bytes up to the * first null character. */ CompileEnv *envPtr; /* Holds resulting instructions. */ @@ -909,14 +960,14 @@ { Interp *iPtr = (Interp *) interp; Tcl_Parse parse; int lastTopLevelCmdIndex = -1; /* Index of most recent toplevel command in - * the command location table. Initialized - * to avoid compiler warning. */ + * the command location table. Initialized * + * to avoid compiler warning. */ int startCodeOffset = -1; /* Offset of first byte of current command's - * code. Init. to avoid compiler warning. */ + * code. Init. to avoid compiler warning. */ unsigned char *entryCodeNext = envPtr->codeNext; CONST char *p, *next; Namespace *cmdNsPtr; Command *cmdPtr; Tcl_Token *tokenPtr; @@ -933,16 +984,16 @@ isFirstCmd = 1; if (envPtr->procPtr != NULL) { cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr; } else { - cmdNsPtr = NULL; /* use current NS */ + cmdNsPtr = NULL; /* use current NS */ } /* - * Each iteration through the following loop compiles the next - * command from the script. + * Each iteration through the following loop compiles the next command + * from the script. */ p = script; bytesLeft = numBytes; gotParse = 0; @@ -960,13 +1011,13 @@ Tcl_IncrRefCount(returnCmd); Tcl_IncrRefCount(errInfo); Tcl_AppendToObj(errInfo, "\n while executing\n\"", -1); TclAppendLimitedToObj(errInfo, parse.commandStart, - /* Drop the command terminator (";" or "]") if appropriate */ - (parse.term == parse.commandStart + parse.commandSize - 1) ? - parse.commandSize - 1 : parse.commandSize, 153, NULL); + /* Drop the command terminator (";","]") if appropriate */ + (parse.term == parse.commandStart + parse.commandSize - 1)? + parse.commandSize - 1 : parse.commandSize, 153, NULL); Tcl_AppendToObj(errInfo, "\"", -1); Tcl_ListObjAppendElement(NULL, returnCmd, errInfo); for (p = envPtr->source; p != parse.commandStart; p++) { @@ -1011,23 +1062,23 @@ */ commandLength = parse.commandSize; if (parse.term == parse.commandStart + commandLength - 1) { /* - * The command terminator character (such as ; or ]) is - * the last character in the parsed command. Reduce the - * length by one so that the trace message doesn't include - * the terminator character. + * The command terminator character (such as ; or ]) is the + * last character in the parsed command. Reduce the length by + * one so that the trace message doesn't include the + * terminator character. */ - + commandLength -= 1; } #ifdef TCL_COMPILE_DEBUG /* - * If tracing, print a line for each top level command compiled. - */ + * If tracing, print a line for each top level command compiled. + */ if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { fprintf(stdout, " Compiling: "); TclPrintSource(stdout, parse.commandStart, TclMin(commandLength, 55)); @@ -1034,178 +1085,173 @@ fprintf(stdout, "\n"); } #endif /* - * Check whether expansion has been requested for any of - * the words + * Check whether expansion has been requested for any of the words */ for (wordIdx = 0, tokenPtr = parse.tokenPtr; wordIdx < parse.numWords; wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { expand = 1; - TclEmitOpcode(INST_EXPAND_START, envPtr); + TclEmitOpcode(INST_EXPAND_START, envPtr); break; } } envPtr->numCommands++; currCmdIndex = (envPtr->numCommands - 1); lastTopLevelCmdIndex = currCmdIndex; startCodeOffset = (envPtr->codeNext - envPtr->codeStart); EnterCmdStartData(envPtr, currCmdIndex, - (parse.commandStart - envPtr->source), startCodeOffset); + (parse.commandStart - envPtr->source), startCodeOffset); /* - * Each iteration of the following loop compiles one word - * from the command. + * Each iteration of the following loop compiles one word from the + * command. */ - + for (wordIdx = 0, tokenPtr = parse.tokenPtr; wordIdx < parse.numWords; wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - /* - * If this is the first word and the command has a - * compile procedure, let it compile the command. - */ - - if ((wordIdx == 0) && !expand) { - /* - * We copy the string before trying to find the command - * by name. We used to modify the string in place, but - * this is not safe because the name resolution - * handlers could have side effects that rely on the - * unmodified string. - */ - - Tcl_DStringSetLength(&ds, 0); - Tcl_DStringAppend(&ds, tokenPtr[1].start, - tokenPtr[1].size); - - cmdPtr = (Command *) Tcl_FindCommand(interp, - Tcl_DStringValue(&ds), - (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0); - - if ((cmdPtr != NULL) - && (cmdPtr->compileProc != NULL) - && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES) - && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { - int savedNumCmds = envPtr->numCommands; - unsigned int savedCodeNext = - envPtr->codeNext - envPtr->codeStart; - - /* - * Mark the start of the command; the proper - * bytecode length will be updated later. There - * is no need to do this for the first command - * in the compile env, as the check is done before - * calling TclExecuteByteCode(). Remark that we - * are compiling the first cmd in the environment - * exactly when (savedCodeNext == 0) - */ - - if (savedCodeNext != 0) { - TclEmitInstInt4(INST_START_CMD, 0, envPtr); - } - - code = (*(cmdPtr->compileProc))(interp, &parse, - envPtr); - - if (code == TCL_OK) { - if (savedCodeNext != 0) { - /* - * Fix the bytecode length. - */ - unsigned char *fixPtr = envPtr->codeStart - + savedCodeNext + 1; - unsigned int fixLen = envPtr->codeNext - - envPtr->codeStart - - savedCodeNext; - - TclStoreInt4AtPtr(fixLen, fixPtr); - } - goto finishCommand; - } else if (code == TCL_OUT_LINE_COMPILE) { - /* - * Restore numCommands and codeNext to their - * correct values, removing any commands - * compiled before TCL_OUT_LINE_COMPILE - * [Bugs 705406 and 735055] - */ - envPtr->numCommands = savedNumCmds; - envPtr->codeNext = envPtr->codeStart - + savedCodeNext; - } else { /* an error */ - Tcl_Panic("TclCompileScript: compileProc returned TCL_ERROR\n"); - } - } - - /* - * No compile procedure so push the word. If the - * command was found, push a CmdName object to - * reduce runtime lookups. - */ - - objIndex = TclRegisterNewLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); - if (cmdPtr != NULL) { - TclSetCmdNameObj(interp, - envPtr->literalArrayPtr[objIndex].objPtr, - cmdPtr); - } - if ((wordIdx == 0) && (parse.numWords == 1)) { - /* - * Single word script: unshare the command name to - * avoid shimmering between bytecode and cmdName - * representations [Bug 458361] - */ - - TclHideLiteral(interp, envPtr, objIndex); - } - } else { - objIndex = TclRegisterNewLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); - } - TclEmitPush(objIndex, envPtr); - } else { + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { /* * The word is not a simple string of characters. */ - + TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + TclEmitInstInt4(INST_EXPAND_STKTOP, + envPtr->currStackDepth, envPtr); + } + continue; } - if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - TclEmitInstInt4(INST_EXPAND_STKTOP, - envPtr->currStackDepth, envPtr); + + /* + * This is a simple string of literal characters (i.e. we know + * it absolutely and can use it directly). If this is the + * first word and the command has a compile procedure, let it + * compile the command. + */ + + if ((wordIdx == 0) && !expand) { + /* + * We copy the string before trying to find the command by + * name. We used to modify the string in place, but this + * is not safe because the name resolution handlers could + * have side effects that rely on the unmodified string. + */ + + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, tokenPtr[1].start,tokenPtr[1].size); + + cmdPtr = (Command *) Tcl_FindCommand(interp, + Tcl_DStringValue(&ds), + (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0); + + if ((cmdPtr != NULL) + && (cmdPtr->compileProc != NULL) + && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES) + && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { + int savedNumCmds = envPtr->numCommands; + unsigned int savedCodeNext = + envPtr->codeNext - envPtr->codeStart; + + /* + * Mark the start of the command; the proper bytecode + * length will be updated later. There is no need to + * do this for the first command in the compile env, + * as the check is done before calling + * TclExecuteByteCode(). Remark that we are compiling + * the first cmd in the environment exactly when + * (savedCodeNext == 0) + */ + + if (savedCodeNext != 0) { + TclEmitInstInt4(INST_START_CMD, 0, envPtr); + } + + code = (cmdPtr->compileProc)(interp, &parse, envPtr); + + if (code == TCL_OK) { + if (savedCodeNext != 0) { + /* + * Fix the bytecode length. + */ + unsigned char *fixPtr = envPtr->codeStart + + savedCodeNext + 1; + unsigned int fixLen = envPtr->codeNext + - envPtr->codeStart - savedCodeNext; + + TclStoreInt4AtPtr(fixLen, fixPtr); + } + goto finishCommand; + } else { + /* + * Restore numCommands and codeNext to their + * correct values, removing any commands compiled + * before the failure to produce bytecode got + * reported. [Bugs 705406 and 735055] + */ + envPtr->numCommands = savedNumCmds; + envPtr->codeNext = envPtr->codeStart+savedCodeNext; + } + } + + /* + * No compile procedure so push the word. If the command + * was found, push a CmdName object to reduce runtime + * lookups. Avoid sharing this literal among different + * namespaces to reduce shimmering. + */ + + objIndex = TclRegisterNewNSLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); + if (cmdPtr != NULL) { + TclSetCmdNameObj(interp, + envPtr->literalArrayPtr[objIndex].objPtr,cmdPtr); + } + if ((wordIdx == 0) && (parse.numWords == 1)) { + /* + * Single word script: unshare the command name to + * avoid shimmering between bytecode and cmdName + * representations [Bug 458361] + */ + + TclHideLiteral(interp, envPtr, objIndex); + } + } else { + objIndex = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); } + TclEmitPush(objIndex, envPtr); } /* - * Emit an invoke instruction for the command. We skip this - * if a compile procedure was found for the command. + * Emit an invoke instruction for the command. We skip this if a + * compile procedure was found for the command. */ if (expand) { /* * The stack depth during argument expansion can only be * managed at runtime, as the number of elements in the - * expanded lists is not known at compile time. - * We adjust here the stack depth estimate so that it is - * correct after the command with expanded arguments - * returns. - * The end effect of this command's invocation is that - * all the words of the command are popped from the stack, - * and the result is pushed: the stack top changes by - * (1-wordIdx). - * Note that the estimates are not correct while the - * command is being prepared and run, INST_EXPAND_STKTOP - * is not stack-neutral in general. + * expanded lists is not known at compile time. We adjust + * here the stack depth estimate so that it is correct after + * the command with expanded arguments returns. + * + * The end effect of this command's invocation is that all the + * words of the command are popped from the stack, and the + * result is pushed: the stack top changes by (1-wordIdx). + * + * Note that the estimates are not correct while the command + * is being prepared and run, INST_EXPAND_STKTOP is not + * stack-neutral in general. */ TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); TclAdjustStackDepth((1-wordIdx), envPtr); } else if (wordIdx > 0) { @@ -1212,27 +1258,27 @@ if (wordIdx <= 255) { TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); } else { TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); } - } + } /* * Update the compilation environment structure and record the * offsets of the source and code for the command. */ - finishCommand: + finishCommand: EnterCmdExtentData(envPtr, currCmdIndex, commandLength, (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); isFirstCmd = 0; } /* end if parse.numWords > 0 */ /* * Advance to the next command in the script. */ - + next = parse.commandStart + parse.commandSize; bytesLeft -= (next - p); p = next; Tcl_FreeParse(&parse); gotParse = 0; @@ -1246,15 +1292,15 @@ * shared empty string, it will otherwise be self-referential and cause * difficulties with literal management [Bugs 467523, 983660]. We used to * have special code in TclReleaseLiteral to handle this particular * self-reference, but now opt for avoiding its creation altogether. */ - + if (envPtr->codeNext == entryCodeNext) { TclEmitPush(TclAddLiteralObj(envPtr, Tcl_NewObj(), NULL), envPtr); } - + envPtr->numSrcBytes = (p - script); Tcl_DStringFree(&ds); } /* @@ -1261,30 +1307,30 @@ *---------------------------------------------------------------------- * * TclCompileTokens -- * * Given an array of tokens parsed from a Tcl command (e.g., the tokens - * that make up a word) this procedure emits instructions to evaluate - * the tokens and concatenate their values to form a single result - * value on the interpreter's runtime evaluation stack. + * that make up a word) this procedure emits instructions to evaluate the + * tokens and concatenate their values to form a single result value on + * the interpreter's runtime evaluation stack. * * Results: * The return value is a standard Tcl result. If an error occurs, an * error message is left in the interpreter's result. - * + * * Side effects: - * Instructions are added to envPtr to push and evaluate the tokens - * at runtime. + * Instructions are added to envPtr to push and evaluate the tokens at + * runtime. * *---------------------------------------------------------------------- */ void TclCompileTokens(interp, tokenPtr, count, envPtr) Tcl_Interp *interp; /* Used for error and status reporting. */ - Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens - * to compile. */ + Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens to + * compile. */ int count; /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ CompileEnv *envPtr; /* Holds the resulting instructions. */ { Tcl_DString textBuffer; /* Holds concatenated chars from adjacent @@ -1297,134 +1343,128 @@ Tcl_DStringInit(&textBuffer); numObjsToConcat = 0; for ( ; count > 0; count--, tokenPtr++) { switch (tokenPtr->type) { - case TCL_TOKEN_TEXT: - Tcl_DStringAppend(&textBuffer, tokenPtr->start, - tokenPtr->size); - break; - - case TCL_TOKEN_BS: - length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, - buffer); - Tcl_DStringAppend(&textBuffer, buffer, length); - break; - - case TCL_TOKEN_COMMAND: - /* - * Push any accumulated chars appearing before the command. - */ - - if (Tcl_DStringLength(&textBuffer) > 0) { - int literal; - - literal = TclRegisterLiteral(envPtr, - Tcl_DStringValue(&textBuffer), - Tcl_DStringLength(&textBuffer), /*onHeap*/ 0); - TclEmitPush(literal, envPtr); - numObjsToConcat++; - Tcl_DStringFree(&textBuffer); - } - - TclCompileScript(interp, tokenPtr->start+1, - tokenPtr->size-2, envPtr); - numObjsToConcat++; - break; - - case TCL_TOKEN_VARIABLE: - /* - * Push any accumulated chars appearing before the $. - */ - - if (Tcl_DStringLength(&textBuffer) > 0) { - int literal; - - literal = TclRegisterLiteral(envPtr, - Tcl_DStringValue(&textBuffer), - Tcl_DStringLength(&textBuffer), /*onHeap*/ 0); - TclEmitPush(literal, envPtr); - numObjsToConcat++; - Tcl_DStringFree(&textBuffer); - } - - /* - * Determine how the variable name should be handled: if it contains - * any namespace qualifiers it is not a local variable (localVarName=-1); - * if it looks like an array element and the token has a single component, - * it should not be created here [Bug 569438] (localVarName=0); otherwise, - * the local variable can safely be created (localVarName=1). - */ - - name = tokenPtr[1].start; - nameBytes = tokenPtr[1].size; - localVarName = -1; - if (envPtr->procPtr != NULL) { - localVarName = 1; - for (i = 0, p = name; i < nameBytes; i++, p++) { - if ((*p == ':') && (i < (nameBytes-1)) - && (*(p+1) == ':')) { - localVarName = -1; - break; - } else if ((*p == '(') - && (tokenPtr->numComponents == 1) - && (*(name + nameBytes - 1) == ')')) { - localVarName = 0; - break; - } - } - } - - /* - * Either push the variable's name, or find its index in - * the array of local variables in a procedure frame. - */ - - localVar = -1; - if (localVarName != -1) { - localVar = TclFindCompiledLocal(name, nameBytes, - localVarName, /*flags*/ 0, envPtr->procPtr); - } - if (localVar < 0) { - TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes), - envPtr); - } - - /* - * Emit instructions to load the variable. - */ - - if (tokenPtr->numComponents == 1) { - if (localVar < 0) { - TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); - } else if (localVar <= 255) { - TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, - envPtr); - } else { - TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, - envPtr); - } - } else { - TclCompileTokens(interp, tokenPtr+2, - tokenPtr->numComponents-1, envPtr); - if (localVar < 0) { - TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); - } else if (localVar <= 255) { - TclEmitInstInt1(INST_LOAD_ARRAY1, localVar, - envPtr); - } else { - TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, - envPtr); - } - } - numObjsToConcat++; - count -= tokenPtr->numComponents; - tokenPtr += tokenPtr->numComponents; - break; - - default: - Tcl_Panic("Unexpected token type in TclCompileTokens"); + case TCL_TOKEN_TEXT: + Tcl_DStringAppend(&textBuffer, tokenPtr->start, tokenPtr->size); + break; + + case TCL_TOKEN_BS: + length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, buffer); + Tcl_DStringAppend(&textBuffer, buffer, length); + break; + + case TCL_TOKEN_COMMAND: + /* + * Push any accumulated chars appearing before the command. + */ + + if (Tcl_DStringLength(&textBuffer) > 0) { + int literal; + + literal = TclRegisterNewLiteral(envPtr, + Tcl_DStringValue(&textBuffer), + Tcl_DStringLength(&textBuffer)); + TclEmitPush(literal, envPtr); + numObjsToConcat++; + Tcl_DStringFree(&textBuffer); + } + + TclCompileScript(interp, tokenPtr->start+1, + tokenPtr->size-2, envPtr); + numObjsToConcat++; + break; + + case TCL_TOKEN_VARIABLE: + /* + * Push any accumulated chars appearing before the $. + */ + + if (Tcl_DStringLength(&textBuffer) > 0) { + int literal; + + literal = TclRegisterNewLiteral(envPtr, + Tcl_DStringValue(&textBuffer), + Tcl_DStringLength(&textBuffer)); + TclEmitPush(literal, envPtr); + numObjsToConcat++; + Tcl_DStringFree(&textBuffer); + } + + /* + * Determine how the variable name should be handled: if it + * contains any namespace qualifiers it is not a local variable + * (localVarName=-1); if it looks like an array element and the + * token has a single component, it should not be created here + * [Bug 569438] (localVarName=0); otherwise, the local variable + * can safely be created (localVarName=1). + */ + + name = tokenPtr[1].start; + nameBytes = tokenPtr[1].size; + localVarName = -1; + if (envPtr->procPtr != NULL) { + localVarName = 1; + for (i = 0, p = name; i < nameBytes; i++, p++) { + if ((*p == ':') && (i < nameBytes-1) && (*(p+1) == ':')) { + localVarName = -1; + break; + } else if ((*p == '(') + && (tokenPtr->numComponents == 1) + && (*(name + nameBytes - 1) == ')')) { + localVarName = 0; + break; + } + } + } + + /* + * Either push the variable's name, or find its index in the array + * of local variables in a procedure frame. + */ + + localVar = -1; + if (localVarName != -1) { + localVar = TclFindCompiledLocal(name, nameBytes, localVarName, + /*flags*/ 0, envPtr->procPtr); + } + if (localVar < 0) { + TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes), + envPtr); + } + + /* + * Emit instructions to load the variable. + */ + + if (tokenPtr->numComponents == 1) { + if (localVar < 0) { + TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); + } else if (localVar <= 255) { + TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr); + } else { + TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, envPtr); + } + } else { + TclCompileTokens(interp, tokenPtr+2, + tokenPtr->numComponents-1, envPtr); + if (localVar < 0) { + TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); + } else if (localVar <= 255) { + TclEmitInstInt1(INST_LOAD_ARRAY1, localVar, envPtr); + } else { + TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, envPtr); + } + } + numObjsToConcat++; + count -= tokenPtr->numComponents; + tokenPtr += tokenPtr->numComponents; + break; + + default: + Tcl_Panic("Unexpected token type in TclCompileTokens"); } } /* * Push any accumulated characters appearing at the end. @@ -1431,12 +1471,12 @@ */ if (Tcl_DStringLength(&textBuffer) > 0) { int literal; - literal = TclRegisterLiteral(envPtr, Tcl_DStringValue(&textBuffer), - Tcl_DStringLength(&textBuffer), /*onHeap*/ 0); + literal = TclRegisterNewLiteral(envPtr, Tcl_DStringValue(&textBuffer), + Tcl_DStringLength(&textBuffer)); TclEmitPush(literal, envPtr); numObjsToConcat++; } /* @@ -1452,14 +1492,13 @@ } /* * If the tokens yielded no instructions, push an empty string. */ - + if (envPtr->codeNext == entryCodeNext) { - TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), - envPtr); + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); } Tcl_DStringFree(&textBuffer); } /* @@ -1468,44 +1507,44 @@ * TclCompileCmdWord -- * * Given an array of parse tokens for a word containing one or more Tcl * commands, emit inline instructions to execute them. This procedure * differs from TclCompileTokens in that a simple word such as a loop - * body enclosed in braces is not just pushed as a string, but is - * itself parsed into tokens and compiled. + * body enclosed in braces is not just pushed as a string, but is itself + * parsed into tokens and compiled. * * Results: * The return value is a standard Tcl result. If an error occurs, an * error message is left in the interpreter's result. - * + * * Side effects: * Instructions are added to envPtr to execute the tokens at runtime. * *---------------------------------------------------------------------- */ void TclCompileCmdWord(interp, tokenPtr, count, envPtr) Tcl_Interp *interp; /* Used for error and status reporting. */ - Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens - * for a command word to compile inline. */ + Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens for + * a command word to compile inline. */ int count; /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ CompileEnv *envPtr; /* Holds the resulting instructions. */ { if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) { /* - * Handle the common case: if there is a single text token, - * compile it into an inline sequence of instructions. + * Handle the common case: if there is a single text token, compile it + * into an inline sequence of instructions. */ - + TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr); } else { /* - * Multiple tokens or the single token involves substitutions. - * Emit instructions to invoke the eval command procedure at - * runtime on the result of evaluating the tokens. + * Multiple tokens or the single token involves substitutions. Emit + * instructions to invoke the eval command procedure at runtime on the + * result of evaluating the tokens. */ TclCompileTokens(interp, tokenPtr, count, envPtr); TclEmitOpcode(INST_EVAL_STK, envPtr); } @@ -1523,34 +1562,34 @@ * appear as command words. * * Results: * The return value is a standard Tcl result. If an error occurs, an * error message is left in the interpreter's result. - * + * * Side effects: * Instructions are added to envPtr to execute the expression. * *---------------------------------------------------------------------- */ void TclCompileExprWords(interp, tokenPtr, numWords, envPtr) Tcl_Interp *interp; /* Used for error and status reporting. */ - Tcl_Token *tokenPtr; /* Points to first in an array of word - * tokens tokens for the expression to - * compile inline. */ - int numWords; /* Number of word tokens starting at - * tokenPtr. Must be at least 1. Each word - * token contains one or more subtokens. */ + Tcl_Token *tokenPtr; /* Points to first in an array of word tokens + * tokens for the expression to compile + * inline. */ + int numWords; /* Number of word tokens starting at tokenPtr. + * Must be at least 1. Each word token + * contains one or more subtokens. */ CompileEnv *envPtr; /* Holds the resulting instructions. */ { Tcl_Token *wordPtr; int i, concatItems; /* - * If the expression is a single word that doesn't require - * substitutions, just compile its string into inline instructions. + * If the expression is a single word that doesn't require substitutions, + * just compile its string into inline instructions. */ if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { CONST char *script = tokenPtr[1].start; int numBytes = tokenPtr[1].size; @@ -1561,22 +1600,21 @@ return; } envPtr->numCommands = savedNumCmds; envPtr->codeNext = envPtr->codeStart + savedCodeNext; } - + /* * Emit code to call the expr command proc at runtime. Concatenate the * (already substituted once) expr tokens with a space between each. */ wordPtr = tokenPtr; for (i = 0; i < numWords; i++) { TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents, envPtr); if (i < (numWords - 1)) { - TclEmitPush(TclRegisterLiteral(envPtr, " ", 1, /*onHeap*/ 0), - envPtr); + TclEmitPush(TclRegisterNewLiteral(envPtr, " ", 1), envPtr); } wordPtr += (wordPtr->numComponents + 1); } concatItems = 2*numWords - 1; while (concatItems > 255) { @@ -1593,34 +1631,34 @@ *---------------------------------------------------------------------- * * TclInitByteCodeObj -- * * Create a ByteCode structure and initialize it from a CompileEnv - * compilation environment structure. The ByteCode structure is - * smaller and contains just that information needed to execute - * the bytecode instructions resulting from compiling a Tcl script. - * The resulting structure is placed in the specified object. + * compilation environment structure. The ByteCode structure is smaller + * and contains just that information needed to execute the bytecode + * instructions resulting from compiling a Tcl script. The resulting + * structure is placed in the specified object. * * Results: * A newly constructed ByteCode object is stored in the internal * representation of the objPtr. * * Side effects: * A single heap object is allocated to hold the new ByteCode structure - * and its code, object, command location, and aux data arrays. Note - * that "ownership" (i.e., the pointers to) the Tcl objects and aux - * data items will be handed over to the new ByteCode structure from - * the CompileEnv structure. + * and its code, object, command location, and aux data arrays. Note that + * "ownership" (i.e., the pointers to) the Tcl objects and aux data items + * will be handed over to the new ByteCode structure from the CompileEnv + * structure. * *---------------------------------------------------------------------- */ void TclInitByteCodeObj(objPtr, envPtr) - Tcl_Obj *objPtr; /* Points object that should be - * initialized, and whose string rep - * contains the source code. */ + Tcl_Obj *objPtr; /* Points object that should be initialized, + * and whose string rep contains the source + * code. */ register CompileEnv *envPtr; /* Points to the CompileEnv structure from * which to create a ByteCode structure. */ { register ByteCode *codePtr; size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes; @@ -1639,36 +1677,40 @@ codeBytes = (envPtr->codeNext - envPtr->codeStart); objArrayBytes = (envPtr->literalArrayNext * sizeof(Tcl_Obj *)); exceptArrayBytes = (envPtr->exceptArrayNext * sizeof(ExceptionRange)); auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData)); cmdLocBytes = GetCmdLocEncodingSize(envPtr); - + /* * Compute the total number of bytes needed for this bytecode. */ structureSize = sizeof(ByteCode); - structureSize += TCL_ALIGN(codeBytes); /* align object array */ - structureSize += TCL_ALIGN(objArrayBytes); /* align exc range arr */ + structureSize += TCL_ALIGN(codeBytes); /* align object array */ + structureSize += TCL_ALIGN(objArrayBytes); /* align exc range arr */ structureSize += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ structureSize += auxDataArrayBytes; structureSize += cmdLocBytes; if (envPtr->iPtr->varFramePtr != NULL) { - namespacePtr = envPtr->iPtr->varFramePtr->nsPtr; + namespacePtr = envPtr->iPtr->varFramePtr->nsPtr; } else { - namespacePtr = envPtr->iPtr->globalNsPtr; + namespacePtr = envPtr->iPtr->globalNsPtr; } - + p = (unsigned char *) ckalloc((size_t) structureSize); codePtr = (ByteCode *) p; codePtr->interpHandle = TclHandlePreserve(iPtr->handle); codePtr->compileEpoch = iPtr->compileEpoch; codePtr->nsPtr = namespacePtr; codePtr->nsEpoch = namespacePtr->resolverEpoch; codePtr->refCount = 1; - codePtr->flags = 0; + if (namespacePtr->compiledVarResProc || iPtr->resolverPtr) { + codePtr->flags = TCL_BYTECODE_RESOLVE_VARS; + } else { + codePtr->flags = 0; + } codePtr->source = envPtr->source; codePtr->procPtr = envPtr->procPtr; codePtr->numCommands = envPtr->numCommands; codePtr->numSrcBytes = envPtr->numSrcBytes; @@ -1681,64 +1723,63 @@ codePtr->maxStackDepth = envPtr->maxStackDepth; p += sizeof(ByteCode); codePtr->codeStart = p; memcpy((VOID *) p, (VOID *) envPtr->codeStart, (size_t) codeBytes); - - p += TCL_ALIGN(codeBytes); /* align object array */ + + p += TCL_ALIGN(codeBytes); /* align object array */ codePtr->objArrayPtr = (Tcl_Obj **) p; for (i = 0; i < numLitObjects; i++) { codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr; } - p += TCL_ALIGN(objArrayBytes); /* align exception range array */ + p += TCL_ALIGN(objArrayBytes); /* align exception range array */ if (exceptArrayBytes > 0) { codePtr->exceptArrayPtr = (ExceptionRange *) p; memcpy((VOID *) p, (VOID *) envPtr->exceptArrayPtr, - (size_t) exceptArrayBytes); + (size_t) exceptArrayBytes); } else { codePtr->exceptArrayPtr = NULL; } - - p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ + + p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ if (auxDataArrayBytes > 0) { codePtr->auxDataArrayPtr = (AuxData *) p; memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr, - (size_t) auxDataArrayBytes); + (size_t) auxDataArrayBytes); } else { codePtr->auxDataArrayPtr = NULL; } p += auxDataArrayBytes; #ifndef TCL_COMPILE_DEBUG EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); #else nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); - if (((size_t)(nextPtr - p)) != cmdLocBytes) { + if (((size_t)(nextPtr - p)) != cmdLocBytes) { Tcl_Panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes); } #endif - + /* * Record various compilation-related statistics about the new ByteCode * structure. Don't include overhead for statistics-related fields. */ #ifdef TCL_COMPILE_STATS codePtr->structureSize = structureSize - (sizeof(size_t) + sizeof(Tcl_Time)); Tcl_GetTime(&(codePtr->createTime)); - + RecordByteCodeStats(codePtr); #endif /* TCL_COMPILE_STATS */ - + /* - * Free the old internal rep then convert the object to a - * bytecode object by making its internal rep point to the just - * compiled ByteCode. + * Free the old internal rep then convert the object to a bytecode object + * by making its internal rep point to the just compiled ByteCode. */ - + TclFreeIntRep(objPtr); objPtr->internalRep.otherValuePtr = (VOID *) codePtr; objPtr->typePtr = &tclByteCodeType; } @@ -1754,30 +1795,29 @@ * referenced using their slot index.) * * Results: * If create is 0 and the name is non-NULL, then if the variable is * found, the index of its entry in the procedure's array of local - * variables is returned; otherwise -1 is returned. If name is NULL, - * the index of a new temporary variable is returned. Finally, if - * create is 1 and name is non-NULL, the index of a new entry is - * returned. + * variables is returned; otherwise -1 is returned. If name is NULL, the + * index of a new temporary variable is returned. Finally, if create is 1 + * and name is non-NULL, the index of a new entry is returned. * * Side effects: - * Creates and registers a new local variable if create is 1 and - * the variable is unknown, or if the name is NULL. + * Creates and registers a new local variable if create is 1 and the + * variable is unknown, or if the name is NULL. * *---------------------------------------------------------------------- */ int TclFindCompiledLocal(name, nameBytes, create, flags, procPtr) - register CONST char *name; /* Points to first character of the name of - * a scalar or array variable. If NULL, a + register CONST char *name; /* Points to first character of the name of a + * scalar or array variable. If NULL, a * temporary var should be created. */ int nameBytes; /* Number of bytes in the name. */ - int create; /* If 1, allocate a local frame entry for - * the variable if it is new. */ + int create; /* If 1, allocate a local frame entry for the + * variable if it is new. */ int flags; /* Flag bits for the compiled local if * created. Only VAR_SCALAR, VAR_ARRAY, and * VAR_LINK make sense. */ register Proc *procPtr; /* Points to structure describing procedure * containing the variable reference. */ @@ -1789,18 +1829,18 @@ /* * If not creating a temporary, does a local variable of the specified * name already exist? */ - if (name != NULL) { + if (name != NULL) { int localCt = procPtr->numCompiledLocals; localPtr = procPtr->firstLocalPtr; for (i = 0; i < localCt; i++) { if (!TclIsVarTemporary(localPtr)) { char *localName = localPtr->name; - if ((nameBytes == localPtr->nameLength) - && (strncmp(name, localName, (unsigned) nameBytes) == 0)) { + if ((nameBytes == localPtr->nameLength) && + (strncmp(name,localName,(unsigned)nameBytes) == 0)) { return i; } } localPtr = localPtr->nextPtr; } @@ -1807,16 +1847,16 @@ } /* * Create a new variable if appropriate. */ - + if (create || (name == NULL)) { localVar = procPtr->numCompiledLocals; - localPtr = (CompiledLocal *) ckalloc((unsigned) - (sizeof(CompiledLocal) - sizeof(localPtr->name) - + nameBytes+1)); + localPtr = (CompiledLocal *) ckalloc((unsigned) + (sizeof(CompiledLocal) - sizeof(localPtr->name) + + nameBytes + 1)); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { procPtr->lastLocalPtr->nextPtr = localPtr; procPtr->lastLocalPtr = localPtr; @@ -1830,239 +1870,125 @@ } localPtr->defValuePtr = NULL; localPtr->resolveInfo = NULL; if (name != NULL) { - memcpy((VOID *) localPtr->name, (VOID *) name, - (size_t) nameBytes); + memcpy((VOID *) localPtr->name, (VOID *) name, (size_t) nameBytes); } localPtr->name[nameBytes] = '\0'; procPtr->numCompiledLocals++; } return localVar; -} - -/* - *---------------------------------------------------------------------- - * - * TclInitCompiledLocals -- - * - * This routine is invoked in order to initialize the compiled - * locals table for a new call frame. - * - * Results: - * None. - * - * Side effects: - * May invoke various name resolvers in order to determine which - * variables are being referenced at runtime. - * - *---------------------------------------------------------------------- - */ - -void -TclInitCompiledLocals(interp, framePtr, nsPtr) - Tcl_Interp *interp; /* Current interpreter. */ - CallFrame *framePtr; /* Call frame to initialize. */ - Namespace *nsPtr; /* Pointer to current namespace. */ -{ - register CompiledLocal *localPtr; - Interp *iPtr = (Interp*) interp; - Tcl_ResolvedVarInfo *vinfo, *resVarInfo; - Var *varPtr = framePtr->compiledLocals; - Var *resolvedVarPtr; - ResolverScheme *resPtr; - int result; - - /* - * Initialize the array of local variables stored in the call frame. - * Some variables may have special resolution rules. In that case, - * we call their "resolver" procs to get our hands on the variable, - * and we make the compiled local a link to the real variable. - */ - - for (localPtr = framePtr->procPtr->firstLocalPtr; - localPtr != NULL; - localPtr = localPtr->nextPtr) { - - /* - * Check to see if this local is affected by namespace or - * interp resolvers. The resolver to use is cached for the - * next invocation of the procedure. - */ - - if (!(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY|VAR_RESOLVED)) - && (nsPtr->compiledVarResProc || iPtr->resolverPtr)) { - resPtr = iPtr->resolverPtr; - - if (nsPtr->compiledVarResProc) { - result = (*nsPtr->compiledVarResProc)(nsPtr->interp, - localPtr->name, localPtr->nameLength, - (Tcl_Namespace *) nsPtr, &vinfo); - } else { - result = TCL_CONTINUE; - } - - while ((result == TCL_CONTINUE) && resPtr) { - if (resPtr->compiledVarResProc) { - result = (*resPtr->compiledVarResProc)(nsPtr->interp, - localPtr->name, localPtr->nameLength, - (Tcl_Namespace *) nsPtr, &vinfo); - } - resPtr = resPtr->nextPtr; - } - if (result == TCL_OK) { - localPtr->resolveInfo = vinfo; - localPtr->flags |= VAR_RESOLVED; - } - } - - /* - * Now invoke the resolvers to determine the exact variables that - * should be used. - */ - - resVarInfo = localPtr->resolveInfo; - resolvedVarPtr = NULL; - - if (resVarInfo && resVarInfo->fetchProc) { - resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp, - resVarInfo); - } - - if (resolvedVarPtr) { - varPtr->name = localPtr->name; /* will be just '\0' if temp var */ - varPtr->nsPtr = NULL; - varPtr->hPtr = NULL; - varPtr->refCount = 0; - varPtr->tracePtr = NULL; - varPtr->searchPtr = NULL; - varPtr->flags = 0; - TclSetVarLink(varPtr); - varPtr->value.linkPtr = resolvedVarPtr; - resolvedVarPtr->refCount++; - } else { - varPtr->value.objPtr = NULL; - varPtr->name = localPtr->name; /* will be just '\0' if temp var */ - varPtr->nsPtr = NULL; - varPtr->hPtr = NULL; - varPtr->refCount = 0; - varPtr->tracePtr = NULL; - varPtr->searchPtr = NULL; - varPtr->flags = localPtr->flags; - } - varPtr++; - } -} - + +} /* *---------------------------------------------------------------------- * * TclExpandCodeArray -- * - * Procedure that uses malloc to allocate more storage for a - * CompileEnv's code array. + * Procedure that uses malloc to allocate more storage for a CompileEnv's + * code array. * * Results: - * None. + * None. * * Side effects: - * The byte code array in *envPtr is reallocated to a new array of - * double the size, and if envPtr->mallocedCodeArray is non-zero the - * old array is freed. Byte codes are copied from the old array to the - * new one. + * The byte code array in *envPtr is reallocated to a new array of double + * the size, and if envPtr->mallocedCodeArray is non-zero the old array + * is freed. Byte codes are copied from the old array to the new one. * *---------------------------------------------------------------------- */ void TclExpandCodeArray(envArgPtr) void *envArgPtr; /* Points to the CompileEnv whose code array * must be enlarged. */ { - CompileEnv *envPtr = (CompileEnv*) envArgPtr; /* Points to the CompileEnv whose code array - * must be enlarged. */ + CompileEnv *envPtr = (CompileEnv*) envArgPtr; + /* The CompileEnv containing the code array to + * be doubled in size. */ /* * envPtr->codeNext is equal to envPtr->codeEnd. The currently defined - * code bytes are stored between envPtr->codeStart and - * (envPtr->codeNext - 1) [inclusive]. + * code bytes are stored between envPtr->codeStart and envPtr->codeNext-1 + * [inclusive]. */ - + size_t currBytes = (envPtr->codeNext - envPtr->codeStart); - size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart); + size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart); unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes); /* * Copy from old code array to new, free old code array if needed, and * mark new code array as malloced. */ - + memcpy((VOID *) newPtr, (VOID *) envPtr->codeStart, currBytes); if (envPtr->mallocedCodeArray) { - ckfree((char *) envPtr->codeStart); + ckfree((char *) envPtr->codeStart); } envPtr->codeStart = newPtr; envPtr->codeNext = (newPtr + currBytes); - envPtr->codeEnd = (newPtr + newBytes); + envPtr->codeEnd = (newPtr + newBytes); envPtr->mallocedCodeArray = 1; } /* *---------------------------------------------------------------------- * * EnterCmdStartData -- * - * Registers the starting source and bytecode location of a - * command. This information is used at runtime to map between - * instruction pc and source locations. + * Registers the starting source and bytecode location of a command. This + * information is used at runtime to map between instruction pc and + * source locations. * * Results: * None. * * Side effects: * Inserts source and code location information into the compilation - * environment envPtr for the command at index cmdIndex. The - * compilation environment's CmdLocation array is grown if necessary. + * environment envPtr for the command at index cmdIndex. The compilation + * environment's CmdLocation array is grown if necessary. * *---------------------------------------------------------------------- */ static void EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset) CompileEnv *envPtr; /* Points to the compilation environment * structure in which to enter command * location information. */ - int cmdIndex; /* Index of the command whose start data - * is being set. */ + int cmdIndex; /* Index of the command whose start data is + * being set. */ int srcOffset; /* Offset of first char of the command. */ int codeOffset; /* Offset of first byte of command code. */ { CmdLocation *cmdLocPtr; - + if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { Tcl_Panic("EnterCmdStartData: bad command index %d\n", cmdIndex); } - + if (cmdIndex >= envPtr->cmdMapEnd) { /* * Expand the command location array by allocating more storage from * the heap. The currently allocated CmdLocation entries are stored * from cmdMapPtr[0] up to cmdMapPtr[envPtr->cmdMapEnd] (inclusive). */ size_t currElems = envPtr->cmdMapEnd; - size_t newElems = 2*currElems; + size_t newElems = 2*currElems; size_t currBytes = currElems * sizeof(CmdLocation); - size_t newBytes = newElems * sizeof(CmdLocation); + size_t newBytes = newElems * sizeof(CmdLocation); CmdLocation *newPtr = (CmdLocation *) ckalloc((unsigned) newBytes); - + /* * Copy from old command location array to new, free old command * location array if needed, and mark new array as malloced. */ - + memcpy((VOID *) newPtr, (VOID *) envPtr->cmdMapPtr, currBytes); if (envPtr->mallocedCmdMap) { ckfree((char *) envPtr->cmdMapPtr); } envPtr->cmdMapPtr = (CmdLocation *) newPtr; @@ -2095,36 +2021,36 @@ * Results: * None. * * Side effects: * Inserts source and code length information into the compilation - * environment envPtr for the command at index cmdIndex. Starting - * source and bytecode information for the command must already - * have been registered. + * environment envPtr for the command at index cmdIndex. Starting source + * and bytecode information for the command must already have been + * registered. * *---------------------------------------------------------------------- */ static void EnterCmdExtentData(envPtr, cmdIndex, numSrcBytes, numCodeBytes) CompileEnv *envPtr; /* Points to the compilation environment * structure in which to enter command * location information. */ - int cmdIndex; /* Index of the command whose source and - * code length data is being set. */ + int cmdIndex; /* Index of the command whose source and code + * length data is being set. */ int numSrcBytes; /* Number of command source chars. */ int numCodeBytes; /* Offset of last byte of command code. */ { CmdLocation *cmdLocPtr; if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { Tcl_Panic("EnterCmdExtentData: bad command index %d\n", cmdIndex); } - + if (cmdIndex > envPtr->cmdMapEnd) { Tcl_Panic("EnterCmdExtentData: missing start data for command %d\n", - cmdIndex); + cmdIndex); } cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]); cmdLocPtr->numSrcBytes = numSrcBytes; cmdLocPtr->numCodeBytes = numCodeBytes; @@ -2140,59 +2066,56 @@ * * Results: * Returns the index for the newly created ExceptionRange. * * Side effects: - * If there is not enough room in the CompileEnv's ExceptionRange - * array, the array in expanded: a new array of double the size is - * allocated, if envPtr->mallocedExceptArray is non-zero the old - * array is freed, and ExceptionRange entries are copied from the old - * array to the new one. + * If there is not enough room in the CompileEnv's ExceptionRange array, + * the array in expanded: a new array of double the size is allocated, if + * envPtr->mallocedExceptArray is non-zero the old array is freed, and + * ExceptionRange entries are copied from the old array to the new one. * *---------------------------------------------------------------------- */ int TclCreateExceptRange(type, envPtr) ExceptionRangeType type; /* The kind of ExceptionRange desired. */ - register CompileEnv *envPtr;/* Points to CompileEnv for which to - * create a new ExceptionRange structure. */ + register CompileEnv *envPtr;/* Points to CompileEnv for which to create a + * new ExceptionRange structure. */ { register ExceptionRange *rangePtr; int index = envPtr->exceptArrayNext; - + if (index >= envPtr->exceptArrayEnd) { - /* + /* * Expand the ExceptionRange array. The currently allocated entries * are stored between elements 0 and (envPtr->exceptArrayNext - 1) * [inclusive]. */ - + size_t currBytes = - envPtr->exceptArrayNext * sizeof(ExceptionRange); + envPtr->exceptArrayNext * sizeof(ExceptionRange); int newElems = 2*envPtr->exceptArrayEnd; size_t newBytes = newElems * sizeof(ExceptionRange); ExceptionRange *newPtr = (ExceptionRange *) - ckalloc((unsigned) newBytes); - + ckalloc((unsigned) newBytes); + /* - * Copy from old ExceptionRange array to new, free old - * ExceptionRange array if needed, and mark the new ExceptionRange - * array as malloced. + * Copy from old ExceptionRange array to new, free old ExceptionRange + * array if needed, and mark the new ExceptionRange array as malloced. */ - - memcpy((VOID *) newPtr, (VOID *) envPtr->exceptArrayPtr, - currBytes); + + memcpy((VOID *) newPtr, (VOID *) envPtr->exceptArrayPtr, currBytes); if (envPtr->mallocedExceptArray) { ckfree((char *) envPtr->exceptArrayPtr); } envPtr->exceptArrayPtr = (ExceptionRange *) newPtr; envPtr->exceptArrayEnd = newElems; envPtr->mallocedExceptArray = 1; } envPtr->exceptArrayNext++; - + rangePtr = &(envPtr->exceptArrayPtr[index]); rangePtr->type = type; rangePtr->nestingLevel = envPtr->exceptDepth; rangePtr->codeOffset = -1; rangePtr->numCodeBytes = -1; @@ -2205,69 +2128,69 @@ /* *---------------------------------------------------------------------- * * TclCreateAuxData -- * - * Procedure that allocates and initializes a new AuxData structure in - * a CompileEnv's array of compilation auxiliary data records. These + * Procedure that allocates and initializes a new AuxData structure in a + * CompileEnv's array of compilation auxiliary data records. These * AuxData records hold information created during compilation by * CompileProcs and used by instructions during execution. * * Results: * Returns the index for the newly created AuxData structure. * * Side effects: - * If there is not enough room in the CompileEnv's AuxData array, - * the AuxData array in expanded: a new array of double the size - * is allocated, if envPtr->mallocedAuxDataArray is non-zero - * the old array is freed, and AuxData entries are copied from - * the old array to the new one. + * If there is not enough room in the CompileEnv's AuxData array, the + * AuxData array in expanded: a new array of double the size is + * allocated, if envPtr->mallocedAuxDataArray is non-zero the old array + * is freed, and AuxData entries are copied from the old array to the new + * one. * *---------------------------------------------------------------------- */ int TclCreateAuxData(clientData, typePtr, envPtr) - ClientData clientData; /* The compilation auxiliary data to store - * in the new aux data record. */ - AuxDataType *typePtr; /* Pointer to the type to attach to this AuxData */ + ClientData clientData; /* The compilation auxiliary data to store in + * the new aux data record. */ + AuxDataType *typePtr; /* Pointer to the type to attach to this + * AuxData */ register CompileEnv *envPtr;/* Points to the CompileEnv for which a new * aux data structure is to be allocated. */ { int index; /* Index for the new AuxData structure. */ register AuxData *auxDataPtr; /* Points to the new AuxData structure */ - + index = envPtr->auxDataArrayNext; if (index >= envPtr->auxDataArrayEnd) { - /* + /* * Expand the AuxData array. The currently allocated entries are * stored between elements 0 and (envPtr->auxDataArrayNext - 1) * [inclusive]. */ - + size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData); int newElems = 2*envPtr->auxDataArrayEnd; size_t newBytes = newElems * sizeof(AuxData); AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes); - + /* * Copy from old AuxData array to new, free old AuxData array if * needed, and mark the new AuxData array as malloced. */ - - memcpy((VOID *) newPtr, (VOID *) envPtr->auxDataArrayPtr, - currBytes); + + memcpy((VOID *) newPtr, (VOID *) envPtr->auxDataArrayPtr, currBytes); if (envPtr->mallocedAuxDataArray) { ckfree((char *) envPtr->auxDataArrayPtr); } envPtr->auxDataArrayPtr = newPtr; envPtr->auxDataArrayEnd = newElems; envPtr->mallocedAuxDataArray = 1; } envPtr->auxDataArrayNext++; - + auxDataPtr = &(envPtr->auxDataArrayPtr[index]); auxDataPtr->clientData = clientData; auxDataPtr->type = typePtr; return index; } @@ -2275,12 +2198,12 @@ /* *---------------------------------------------------------------------- * * TclInitJumpFixupArray -- * - * Initializes a JumpFixupArray structure to hold some number of - * jump fixup entries. + * Initializes a JumpFixupArray structure to hold some number of jump + * fixup entries. * * Results: * None. * * Side effects: @@ -2290,12 +2213,12 @@ */ void TclInitJumpFixupArray(fixupArrayPtr) register JumpFixupArray *fixupArrayPtr; - /* Points to the JumpFixupArray structure - * to initialize. */ + /* Points to the JumpFixupArray structure to + * initialize. */ { fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace; fixupArrayPtr->next = 0; fixupArrayPtr->end = (JUMPFIXUP_INIT_ENTRIES - 1); fixupArrayPtr->mallocedArray = 0; @@ -2304,47 +2227,47 @@ /* *---------------------------------------------------------------------- * * TclExpandJumpFixupArray -- * - * Procedure that uses malloc to allocate more storage for a - * jump fixup array. + * Procedure that uses malloc to allocate more storage for a jump fixup + * array. * * Results: * None. * * Side effects: * The jump fixup array in *fixupArrayPtr is reallocated to a new array * of double the size, and if fixupArrayPtr->mallocedArray is non-zero - * the old array is freed. Jump fixup structures are copied from the - * old array to the new one. + * the old array is freed. Jump fixup structures are copied from the old + * array to the new one. * *---------------------------------------------------------------------- */ void TclExpandJumpFixupArray(fixupArrayPtr) register JumpFixupArray *fixupArrayPtr; - /* Points to the JumpFixupArray structure - * to enlarge. */ + /* Points to the JumpFixupArray structure + * to enlarge. */ { /* - * The currently allocated jump fixup entries are stored from fixup[0] - * up to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume + * The currently allocated jump fixup entries are stored from fixup[0] up + * to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume * fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd. */ size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup); int newElems = 2*(fixupArrayPtr->end + 1); size_t newBytes = newElems * sizeof(JumpFixup); JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes); /* - * Copy from the old array to new, free the old array if needed, - * and mark the new array as malloced. + * Copy from the old array to new, free the old array if needed, and mark + * the new array as malloced. */ - + memcpy((VOID *) newPtr, (VOID *) fixupArrayPtr->fixup, currBytes); if (fixupArrayPtr->mallocedArray) { ckfree((char *) fixupArrayPtr->fixup); } fixupArrayPtr->fixup = (JumpFixup *) newPtr; @@ -2369,12 +2292,12 @@ */ void TclFreeJumpFixupArray(fixupArrayPtr) register JumpFixupArray *fixupArrayPtr; - /* Points to the JumpFixupArray structure - * to free. */ + /* Points to the JumpFixupArray structure to + * free. */ { if (fixupArrayPtr->mallocedArray) { ckfree((char *) fixupArrayPtr->fixup); } } @@ -2385,20 +2308,20 @@ * TclEmitForwardJump -- * * Procedure to emit a two-byte forward jump of kind "jumpType". Since * the jump may later have to be grown to five bytes if the jump target * is more than, say, 127 bytes away, this procedure also initializes a - * JumpFixup record with information about the jump. + * JumpFixup record with information about the jump. * * Results: * None. * * Side effects: - * The JumpFixup record pointed to by "jumpFixupPtr" is initialized - * with information needed later if the jump is to be grown. Also, - * a two byte jump of the designated type is emitted at the current - * point in the bytecode stream. + * The JumpFixup record pointed to by "jumpFixupPtr" is initialized with + * information needed later if the jump is to be grown. Also, a two byte + * jump of the designated type is emitted at the current point in the + * bytecode stream. * *---------------------------------------------------------------------- */ void @@ -2413,19 +2336,19 @@ { /* * Initialize the JumpFixup structure: * - codeOffset is offset of first byte of jump below * - cmdIndex is index of the command after the current one - * - exceptIndex is the index of the first ExceptionRange after - * the current one. + * - exceptIndex is the index of the first ExceptionRange after the + * current one. */ - + jumpFixupPtr->jumpType = jumpType; jumpFixupPtr->codeOffset = (envPtr->codeNext - envPtr->codeStart); jumpFixupPtr->cmdIndex = envPtr->numCommands; jumpFixupPtr->exceptIndex = envPtr->exceptArrayNext; - + switch (jumpType) { case TCL_UNCONDITIONAL_JUMP: TclEmitInstInt1(INST_JUMP1, 0, envPtr); break; case TCL_TRUE_JUMP: @@ -2440,28 +2363,27 @@ /* *---------------------------------------------------------------------- * * TclFixupForwardJump -- * - * Procedure that updates a previously-emitted forward jump to jump - * a specified number of bytes, "jumpDist". If necessary, the jump is - * grown from two to five bytes; this is done if the jump distance is - * greater than "distThreshold" (normally 127 bytes). The jump is - * described by a JumpFixup record previously initialized by - * TclEmitForwardJump. + * Procedure that updates a previously-emitted forward jump to jump a + * specified number of bytes, "jumpDist". If necessary, the jump is grown + * from two to five bytes; this is done if the jump distance is greater + * than "distThreshold" (normally 127 bytes). The jump is described by a + * JumpFixup record previously initialized by TclEmitForwardJump. * * Results: * 1 if the jump was grown and subsequent instructions had to be moved; - * otherwise 0. This result is returned to allow callers to update - * any additional code offsets they may hold. + * otherwise 0. This result is returned to allow callers to update any + * additional code offsets they may hold. * * Side effects: * The jump may be grown and subsequent instructions moved. If this * happens, the code offsets for any commands and any ExceptionRange - * records between the jump and the current code address will be - * updated to reflect the moved code. Also, the bytecode instruction - * array in the CompileEnv structure may be grown and reallocated. + * records between the jump and the current code address will be updated + * to reflect the moved code. Also, the bytecode instruction array in the + * CompileEnv structure may be grown and reallocated. * *---------------------------------------------------------------------- */ int @@ -2468,19 +2390,18 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold) CompileEnv *envPtr; /* Points to the CompileEnv structure that * holds the resulting instruction. */ JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure that * describes the forward jump. */ - int jumpDist; /* Jump distance to set in jump - * instruction. */ - int distThreshold; /* Maximum distance before the two byte - * jump is grown to five bytes. */ + int jumpDist; /* Jump distance to set in jump instr. */ + int distThreshold; /* Maximum distance before the two byte jump + * is grown to five bytes. */ { unsigned char *jumpPc, *p; int firstCmd, lastCmd, firstRange, lastRange, k; unsigned int numBytes; - + if (jumpDist <= distThreshold) { jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset); switch (jumpFixupPtr->jumpType) { case TCL_UNCONDITIONAL_JUMP: TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc); @@ -2494,18 +2415,18 @@ } return 0; } /* - * We must grow the jump then move subsequent instructions down. - * Note that if we expand the space for generated instructions, - * code addresses might change; be careful about updating any of - * these addresses held in variables. + * We must grow the jump then move subsequent instructions down. Note + * that if we expand the space for generated instructions, code addresses + * might change; be careful about updating any of these addresses held in + * variables. */ - + if ((envPtr->codeNext + 3) > envPtr->codeEnd) { - TclExpandCodeArray(envPtr); + TclExpandCodeArray(envPtr); } jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset); for (numBytes = envPtr->codeNext-jumpPc-2, p = jumpPc+2+numBytes-1; numBytes > 0; numBytes--, p--) { p[3] = p[0]; @@ -2521,30 +2442,30 @@ break; default: TclUpdateInstInt4AtPc(INST_JUMP_FALSE4, jumpDist, jumpPc); break; } - + /* - * Adjust the code offsets for any commands and any ExceptionRange - * records between the jump and the current code address. + * Adjust the code offsets for any commands and any ExceptionRange records + * between the jump and the current code address. */ - + firstCmd = jumpFixupPtr->cmdIndex; - lastCmd = (envPtr->numCommands - 1); + lastCmd = (envPtr->numCommands - 1); if (firstCmd < lastCmd) { for (k = firstCmd; k <= lastCmd; k++) { (envPtr->cmdMapPtr[k]).codeOffset += 3; } } - + firstRange = jumpFixupPtr->exceptIndex; - lastRange = (envPtr->exceptArrayNext - 1); + lastRange = (envPtr->exceptArrayNext - 1); for (k = firstRange; k <= lastRange; k++) { ExceptionRange *rangePtr = &(envPtr->exceptArrayPtr[k]); rangePtr->codeOffset += 3; - + switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: rangePtr->breakOffset += 3; if (rangePtr->continueOffset != -1) { rangePtr->continueOffset += 3; @@ -2553,11 +2474,11 @@ case CATCH_EXCEPTION_RANGE: rangePtr->catchOffset += 3; break; default: Tcl_Panic("TclFixupForwardJump: bad ExceptionRange type %d\n", - rangePtr->type); + rangePtr->type); } } return 1; /* the jump was grown */ } @@ -2564,13 +2485,13 @@ /* *---------------------------------------------------------------------- * * TclGetInstructionTable -- * - * Returns a pointer to the table describing Tcl bytecode instructions. - * This procedure is defined so that clients can access the pointer from - * outside the TCL DLLs. + * Returns a pointer to the table describing Tcl bytecode instructions. + * This procedure is defined so that clients can access the pointer from + * outside the TCL DLLs. * * Results: * Returns a pointer to the global instruction table, same as the * expression (&tclInstructionTable[0]). * @@ -2589,54 +2510,54 @@ /* *-------------------------------------------------------------- * * TclRegisterAuxDataType -- * - * This procedure is called to register a new AuxData type - * in the table of all AuxData types supported by Tcl. + * This procedure is called to register a new AuxData type in the table + * of all AuxData types supported by Tcl. * * Results: * None. * * Side effects: * The type is registered in the AuxData type table. If there was already - * a type with the same name as in typePtr, it is replaced with the - * new type. + * a type with the same name as in typePtr, it is replaced with the new + * type. * *-------------------------------------------------------------- */ void TclRegisterAuxDataType(typePtr) - AuxDataType *typePtr; /* Information about object type; - * storage must be statically - * allocated (must live forever). */ + AuxDataType *typePtr; /* Information about object type; storage must + * be statically allocated (must live + * forever; will not be deallocated). */ { register Tcl_HashEntry *hPtr; int new; Tcl_MutexLock(&tableMutex); if (!auxDataTypeTableInitialized) { - TclInitAuxDataTypeTable(); + TclInitAuxDataTypeTable(); } /* * If there's already a type with the given name, remove it. */ hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typePtr->name); if (hPtr != (Tcl_HashEntry *) NULL) { - Tcl_DeleteHashEntry(hPtr); + Tcl_DeleteHashEntry(hPtr); } /* * Now insert the new object type. */ hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &new); if (new) { - Tcl_SetHashValue(hPtr, typePtr); + Tcl_SetHashValue(hPtr, typePtr); } Tcl_MutexUnlock(&tableMutex); } /* @@ -2663,16 +2584,16 @@ register Tcl_HashEntry *hPtr; AuxDataType *typePtr = NULL; Tcl_MutexLock(&tableMutex); if (!auxDataTypeTableInitialized) { - TclInitAuxDataTypeTable(); + TclInitAuxDataTypeTable(); } hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typeName); if (hPtr != (Tcl_HashEntry *) NULL) { - typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr); + typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr); } Tcl_MutexUnlock(&tableMutex); return typePtr; } @@ -2680,12 +2601,12 @@ /* *-------------------------------------------------------------- * * TclInitAuxDataTypeTable -- * - * This procedure is invoked to perform once-only initialization of - * the AuxData type table. It also registers the AuxData types defined in + * This procedure is invoked to perform once-only initialization of the + * AuxData type table. It also registers the AuxData types defined in * this file. * * Results: * None. * @@ -2716,14 +2637,14 @@ /* *---------------------------------------------------------------------- * * TclFinalizeAuxDataTypeTable -- * - * This procedure is called by Tcl_Finalize after all exit handlers - * have been run to free up storage associated with the table of AuxData - * types. This procedure is called by TclFinalizeExecution() which - * is called by Tcl_Finalize(). + * This procedure is called by Tcl_Finalize after all exit handlers have + * been run to free up storage associated with the table of AuxData + * types. This procedure is called by TclFinalizeExecution() which is + * called by Tcl_Finalize(). * * Results: * None. * * Side effects: @@ -2735,12 +2656,12 @@ void TclFinalizeAuxDataTypeTable() { Tcl_MutexLock(&tableMutex); if (auxDataTypeTableInitialized) { - Tcl_DeleteHashTable(&auxDataTypeTable); - auxDataTypeTableInitialized = 0; + Tcl_DeleteHashTable(&auxDataTypeTable); + auxDataTypeTableInitialized = 0; } Tcl_MutexUnlock(&tableMutex); } /* @@ -2760,21 +2681,21 @@ *---------------------------------------------------------------------- */ static int GetCmdLocEncodingSize(envPtr) - CompileEnv *envPtr; /* Points to compilation environment - * structure containing the CmdLocation - * structure to encode. */ + CompileEnv *envPtr; /* Points to compilation environment structure + * containing the CmdLocation structure to + * encode. */ { register CmdLocation *mapPtr = envPtr->cmdMapPtr; int numCmds = envPtr->numCommands; int codeDelta, codeLen, srcDelta, srcLen; int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext; /* The offsets in their respective byte - * sequences where the next encoded offset - * or length should go. */ + * sequences where the next encoded offset or + * length should go. */ int prevCodeOffset, prevSrcOffset, i; codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0; prevCodeOffset = prevSrcOffset = 0; for (i = 0; i < numCmds; i++) { @@ -2821,43 +2742,43 @@ /* *---------------------------------------------------------------------- * * EncodeCmdLocMap -- * - * Encode the command location information for some compiled code into - * a ByteCode structure. The encoded command location map is stored as + * Encode the command location information for some compiled code into a + * ByteCode structure. The encoded command location map is stored as * three adjacent byte sequences. * * Results: * Pointer to the first byte after the encoded command location * information. * * Side effects: - * The encoded information is stored into the block of memory headed - * by codePtr. Also records pointers to the start of the four byte - * sequences in fields in codePtr's ByteCode header structure. + * The encoded information is stored into the block of memory headed by + * codePtr. Also records pointers to the start of the four byte sequences + * in fields in codePtr's ByteCode header structure. * *---------------------------------------------------------------------- */ static unsigned char * EncodeCmdLocMap(envPtr, codePtr, startPtr) - CompileEnv *envPtr; /* Points to compilation environment - * structure containing the CmdLocation - * structure to encode. */ - ByteCode *codePtr; /* ByteCode in which to encode envPtr's + CompileEnv *envPtr; /* Points to compilation environment structure + * containing the CmdLocation structure to + * encode. */ + ByteCode *codePtr; /* ByteCode in which to encode envPtr's * command location information. */ - unsigned char *startPtr; /* Points to the first byte in codePtr's - * memory block where the location - * information is to be stored. */ + unsigned char *startPtr; /* Points to the first byte in codePtr's + * memory block where the location information + * is to be stored. */ { register CmdLocation *mapPtr = envPtr->cmdMapPtr; int numCmds = envPtr->numCommands; register unsigned char *p = startPtr; int codeDelta, codeLen, srcDelta, srcLen, prevOffset; register int i; - + /* * Encode the code offset for each command as a sequence of deltas. */ codePtr->codeDeltaStart = p; @@ -2935,22 +2856,22 @@ p++; TclStoreInt4AtPtr(srcLen, p); p += 4; } } - + return p; } #ifdef TCL_COMPILE_DEBUG /* *---------------------------------------------------------------------- * * TclPrintByteCodeObj -- * - * This procedure prints ("disassembles") the instructions of a - * bytecode object to stdout. + * This procedure prints ("disassembles") the instructions of a bytecode + * object to stdout. * * Results: * None. * * Side effects: @@ -2993,15 +2914,15 @@ fprintf(stdout, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, #ifdef TCL_COMPILE_STATS - (codePtr->numSrcBytes? - ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0)); -#else + codePtr->numSrcBytes? + codePtr->structureSize/(float)codePtr->numSrcBytes : +#endif 0.0); -#endif + #ifdef TCL_COMPILE_STATS fprintf(stdout, " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n", codePtr->structureSize, (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))), @@ -3009,38 +2930,38 @@ (codePtr->numLitObjects * sizeof(Tcl_Obj *)), (codePtr->numExceptRanges * sizeof(ExceptionRange)), (codePtr->numAuxDataItems * sizeof(AuxData)), codePtr->numCmdLocBytes); #endif /* TCL_COMPILE_STATS */ - + /* * If the ByteCode is the compiled body of a Tcl procedure, print * information about that procedure. Note that we don't know the * procedure's name since ByteCode's can be shared among procedures. */ - + if (codePtr->procPtr != NULL) { Proc *procPtr = codePtr->procPtr; int numCompiledLocals = procPtr->numCompiledLocals; fprintf(stdout, - " Proc 0x%x, refCt %d, args %d, compiled locals %d\n", + " Proc 0x%x, refCt %d, args %d, compiled locals %d\n", (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs, numCompiledLocals); if (numCompiledLocals > 0) { CompiledLocal *localPtr = procPtr->firstLocalPtr; for (i = 0; i < numCompiledLocals; i++) { - fprintf(stdout, " slot %d%s%s%s%s%s%s", i, - ((localPtr->flags & VAR_SCALAR)? ", scalar" : ""), - ((localPtr->flags & VAR_ARRAY)? ", array" : ""), - ((localPtr->flags & VAR_LINK)? ", link" : ""), - ((localPtr->flags & VAR_ARGUMENT)? ", arg" : ""), - ((localPtr->flags & VAR_TEMPORARY)? ", temp" : ""), - ((localPtr->flags & VAR_RESOLVED)? ", resolved" : "")); + fprintf(stdout, " slot %d%s%s%s%s%s%s", i, + (localPtr->flags & VAR_SCALAR) ? ", scalar" : "", + (localPtr->flags & VAR_ARRAY) ? ", array" : "", + (localPtr->flags & VAR_LINK) ? ", link" : "", + (localPtr->flags & VAR_ARGUMENT) ? ", arg" : "", + (localPtr->flags & VAR_TEMPORARY) ? ", temp" : "", + (localPtr->flags & VAR_RESOLVED) ? ", resolved" : ""); if (TclIsVarTemporary(localPtr)) { - fprintf(stdout, "\n"); + fprintf(stdout, "\n"); } else { - fprintf(stdout, ", \"%s\"\n", localPtr->name); + fprintf(stdout, ", \"%s\"\n", localPtr->name); } localPtr = localPtr->nextPtr; } } } @@ -3049,37 +2970,36 @@ * Print the ExceptionRange array. */ if (codePtr->numExceptRanges > 0) { fprintf(stdout, " Exception ranges %d, depth %d:\n", - codePtr->numExceptRanges, codePtr->maxExceptDepth); + codePtr->numExceptRanges, codePtr->maxExceptDepth); for (i = 0; i < codePtr->numExceptRanges; i++) { ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]); fprintf(stdout, " %d: level %d, %s, pc %d-%d, ", i, rangePtr->nestingLevel, - ((rangePtr->type == LOOP_EXCEPTION_RANGE) - ? "loop" : "catch"), + (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"), rangePtr->codeOffset, (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: fprintf(stdout, "continue %d, break %d\n", - rangePtr->continueOffset, rangePtr->breakOffset); + rangePtr->continueOffset, rangePtr->breakOffset); break; case CATCH_EXCEPTION_RANGE: fprintf(stdout, "catch %d\n", rangePtr->catchOffset); break; default: Tcl_Panic("TclPrintByteCodeObj: bad ExceptionRange type %d\n", - rangePtr->type); + rangePtr->type); } } } - + /* - * If there were no commands (e.g., an expression or an empty string - * was compiled), just print all instructions and return. + * If there were no commands (e.g., an expression or an empty string was + * compiled), just print all instructions and return. */ if (numCmds == 0) { pc = codeStart; while (pc < codeLimit) { @@ -3086,20 +3006,20 @@ fprintf(stdout, " "); pc += TclPrintInstruction(codePtr, pc); } return; } - + /* - * Print table showing the code offset, source offset, and source - * length for each command. These are encoded as a sequence of bytes. + * Print table showing the code offset, source offset, and source length + * for each command. These are encoded as a sequence of bytes. */ fprintf(stdout, " Commands %d:", numCmds); codeDeltaNext = codePtr->codeDeltaStart; codeLengthNext = codePtr->codeLengthStart; - srcDeltaNext = codePtr->srcDeltaStart; + srcDeltaNext = codePtr->srcDeltaStart; srcLengthNext = codePtr->srcLengthStart; codeOffset = srcOffset = 0; for (i = 0; i < numCmds; i++) { if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { codeDeltaNext++; @@ -3117,11 +3037,11 @@ codeLengthNext += 4; } else { codeLen = TclGetInt1AtPtr(codeLengthNext); codeLengthNext++; } - + if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { srcDeltaNext++; delta = TclGetInt4AtPtr(srcDeltaNext); srcDeltaNext += 4; } else { @@ -3136,28 +3056,28 @@ srcLengthNext += 4; } else { srcLen = TclGetInt1AtPtr(srcLengthNext); srcLengthNext++; } - + fprintf(stdout, "%s%4d: pc %d-%d, src %d-%d", ((i % 2)? " " : "\n "), (i+1), codeOffset, (codeOffset + codeLen - 1), srcOffset, (srcOffset + srcLen - 1)); } if (numCmds > 0) { fprintf(stdout, "\n"); } - + /* - * Print each instruction. If the instruction corresponds to the start - * of a command, print the command's source. Note that we don't need - * the code length here. + * Print each instruction. If the instruction corresponds to the start of + * a command, print the command's source. Note that we don't need the code + * length here. */ codeDeltaNext = codePtr->codeDeltaStart; - srcDeltaNext = codePtr->srcDeltaStart; + srcDeltaNext = codePtr->srcDeltaStart; srcLengthNext = codePtr->srcLengthStart; codeOffset = srcOffset = 0; pc = codeStart; for (i = 0; i < numCmds; i++) { if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { @@ -3190,19 +3110,19 @@ } /* * Print instructions before command i. */ - + while ((pc-codeStart) < codeOffset) { fprintf(stdout, " "); pc += TclPrintInstruction(codePtr, pc); } fprintf(stdout, " Command %d: ", (i+1)); TclPrintSource(stdout, (codePtr->source + srcOffset), - TclMin(srcLen, 55)); + TclMin(srcLen, 55)); fprintf(stdout, "\n"); } if (pc < codeLimit) { /* * Print instructions after the last command. @@ -3212,19 +3132,18 @@ fprintf(stdout, " "); pc += TclPrintInstruction(codePtr, pc); } } } -#endif /* TCL_COMPILE_DEBUG */ /* *---------------------------------------------------------------------- * * TclPrintInstruction -- * - * This procedure prints ("disassembles") one instruction from a - * bytecode object to stdout. + * This procedure prints ("disassembles") one instruction from a bytecode + * object to stdout. * * Results: * Returns the length in bytes of the current instruiction. * * Side effects: @@ -3242,108 +3161,102 @@ unsigned char opCode = *pc; register InstructionDesc *instDesc = &tclInstructionTable[opCode]; unsigned char *codeStart = codePtr->codeStart; unsigned int pcOffset = (pc - codeStart); int opnd, i, j, numBytes = 1; - + int localCt = procPtr ? procPtr->numCompiledLocals : 0; + CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL; + + char suffixBuffer[64]; /* Additional info to print after main opcode + * and immediates. */ + char *suffixSrc = NULL; + Tcl_Obj *suffixObj = NULL; + + suffixBuffer[0] = '\0'; fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name); for (i = 0; i < instDesc->numOperands; i++) { switch (instDesc->opTypes[i]) { case OPERAND_INT1: opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; - if ((i == 0) && ((opCode == INST_JUMP1) - || (opCode == INST_JUMP_TRUE1) - || (opCode == INST_JUMP_FALSE1))) { - fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd)); - } else { - fprintf(stdout, "%d ", opnd); + if (opCode == INST_JUMP1 || opCode == INST_JUMP_TRUE1 + || opCode == INST_JUMP_FALSE1) { + sprintf(suffixBuffer, "pc %u", pcOffset+opnd); } + fprintf(stdout, "%+d ", opnd); break; case OPERAND_INT4: opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; - if ((i == 0) && ((opCode == INST_JUMP4) - || (opCode == INST_JUMP_TRUE4) - || (opCode == INST_JUMP_FALSE4))) { - fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd)); - } else { - fprintf(stdout, "%d ", opnd); + if (opCode == INST_JUMP4 || opCode == INST_JUMP_TRUE4 + || opCode == INST_JUMP_FALSE4) { + sprintf(suffixBuffer, "pc %u", pcOffset+opnd); } + fprintf(stdout, "%+d ", opnd); break; case OPERAND_UINT1: opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; - if ((i == 0) && (opCode == INST_PUSH1)) { - fprintf(stdout, "%u # ", (unsigned int) opnd); - TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40); - } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR1) - || (opCode == INST_LOAD_ARRAY1) - || (opCode == INST_STORE_SCALAR1) - || (opCode == INST_STORE_ARRAY1))) { - int localCt = procPtr->numCompiledLocals; - CompiledLocal *localPtr = procPtr->firstLocalPtr; - if (opnd >= localCt) { - Tcl_Panic("TclPrintInstruction: bad local var index %u (%u locals)\n", - (unsigned int) opnd, localCt); - } - for (j = 0; j < opnd; j++) { - localPtr = localPtr->nextPtr; - } - if (TclIsVarTemporary(localPtr)) { - fprintf(stdout, "%u # temp var %u", - (unsigned int) opnd, (unsigned int) opnd); - } else { - fprintf(stdout, "%u # var ", (unsigned int) opnd); - TclPrintSource(stdout, localPtr->name, 40); - } - } else { - fprintf(stdout, "%u ", (unsigned int) opnd); - } + if (opCode == INST_PUSH1) { + suffixObj = codePtr->objArrayPtr[opnd]; + } + fprintf(stdout, "%u ", (unsigned int) opnd); break; case OPERAND_UINT4: opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; if (opCode == INST_PUSH4) { - fprintf(stdout, "%u # ", opnd); - TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40); - } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR4) - || (opCode == INST_LOAD_ARRAY4) - || (opCode == INST_STORE_SCALAR4) - || (opCode == INST_STORE_ARRAY4))) { - int localCt = procPtr->numCompiledLocals; - CompiledLocal *localPtr = procPtr->firstLocalPtr; - if (opnd >= localCt) { - Tcl_Panic("TclPrintInstruction: bad local var index %u (%u locals)\n", - (unsigned int) opnd, localCt); - } - for (j = 0; j < opnd; j++) { - localPtr = localPtr->nextPtr; - } - if (TclIsVarTemporary(localPtr)) { - fprintf(stdout, "%u # temp var %u", - (unsigned int) opnd, (unsigned int) opnd); - } else { - fprintf(stdout, "%u # var ", (unsigned int) opnd); - TclPrintSource(stdout, localPtr->name, 40); - } - } else { - fprintf(stdout, "%u ", (unsigned int) opnd); - } - break; - + suffixObj = codePtr->objArrayPtr[opnd]; + } else if (opCode == INST_START_CMD) { + sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd); + } + fprintf(stdout, "%u ", (unsigned int) opnd); + break; case OPERAND_IDX4: opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; if (opnd >= -1) { fprintf(stdout, "%d ", opnd); } else if (opnd == -2) { fprintf(stdout, "end "); } else { fprintf(stdout, "end-%d ", -2-opnd); - } + } break; - + case OPERAND_LVT1: + opnd = TclGetUInt1AtPtr(pc+numBytes); + numBytes++; + goto printLVTindex; + case OPERAND_LVT4: + opnd = TclGetUInt4AtPtr(pc+numBytes); + numBytes += 4; + printLVTindex: + if (localPtr != NULL) { + if (opnd >= localCt) { + Tcl_Panic("TclPrintInstruction: bad local var index %u (%u locals)\n", + (unsigned int) opnd, localCt); + } + for (j = 0; j < opnd; j++) { + localPtr = localPtr->nextPtr; + } + if (TclIsVarTemporary(localPtr)) { + sprintf(suffixBuffer, "temp var %u", (unsigned) opnd); + } else { + sprintf(suffixBuffer, "var "); + suffixSrc = localPtr->name; + } + } + fprintf(stdout, "%%v%u ", (unsigned) opnd); + break; case OPERAND_NONE: default: break; } + } + if (suffixObj) { + fprintf(stdout, "\t# "); + TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40); + } else if (suffixBuffer[0]) { + fprintf(stdout, "\t# %s", suffixBuffer); + if (suffixSrc) { + TclPrintSource(stdout, suffixSrc, 40); + } } fprintf(stdout, "\n"); return numBytes; } @@ -3350,12 +3263,12 @@ /* *---------------------------------------------------------------------- * * TclPrintObject -- * - * This procedure prints up to a specified number of characters from - * the argument Tcl object's string representation to a specified file. + * This procedure prints up to a specified number of characters from the + * argument Tcl object's string representation to a specified file. * * Results: * None. * * Side effects: @@ -3371,22 +3284,22 @@ * representation should be printed. */ int maxChars; /* Maximum number of chars to print. */ { char *bytes; int length; - + bytes = Tcl_GetStringFromObj(objPtr, &length); TclPrintSource(outFile, bytes, TclMin(length, maxChars)); } /* *---------------------------------------------------------------------- * * TclPrintSource -- * - * This procedure prints up to a specified number of characters from - * the argument string to a specified file. It tries to produce legible + * This procedure prints up to a specified number of characters from the + * argument string to a specified file. It tries to produce legible * output by adding backslashes as necessary. * * Results: * None. * @@ -3412,35 +3325,36 @@ fprintf(outFile, "\""); p = stringPtr; for (; (*p != '\0') && (i < maxChars); p++, i++) { switch (*p) { - case '"': - fprintf(outFile, "\\\""); - continue; - case '\f': - fprintf(outFile, "\\f"); - continue; - case '\n': - fprintf(outFile, "\\n"); - continue; - case '\r': - fprintf(outFile, "\\r"); - continue; - case '\t': - fprintf(outFile, "\\t"); - continue; - case '\v': - fprintf(outFile, "\\v"); - continue; - default: - fprintf(outFile, "%c", *p); - continue; + case '"': + fprintf(outFile, "\\\""); + continue; + case '\f': + fprintf(outFile, "\\f"); + continue; + case '\n': + fprintf(outFile, "\\n"); + continue; + case '\r': + fprintf(outFile, "\\r"); + continue; + case '\t': + fprintf(outFile, "\\t"); + continue; + case '\v': + fprintf(outFile, "\\v"); + continue; + default: + fprintf(outFile, "%c", *p); + continue; } } fprintf(outFile, "\""); } +#endif /* TCL_COMPILE_DEBUG */ #ifdef TCL_COMPILE_STATS /* *---------------------------------------------------------------------- * @@ -3453,12 +3367,12 @@ * Results: * None. * * Side effects: * Accumulates aggregate code-related statistics in the interpreter's - * ByteCodeStats structure. Records statistics specific to a ByteCode - * in its ByteCode structure. + * ByteCodeStats structure. Records statistics specific to a ByteCode in + * its ByteCode structure. * *---------------------------------------------------------------------- */ void @@ -3468,23 +3382,31 @@ { Interp *iPtr = (Interp *) *codePtr->interpHandle; register ByteCodeStats *statsPtr = &(iPtr->stats); statsPtr->numCompilations++; - statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes; - statsPtr->totalByteCodeBytes += (double) codePtr->structureSize; - statsPtr->currentSrcBytes += (double) codePtr->numSrcBytes; + statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes; + statsPtr->totalByteCodeBytes += (double) codePtr->structureSize; + statsPtr->currentSrcBytes += (double) codePtr->numSrcBytes; statsPtr->currentByteCodeBytes += (double) codePtr->structureSize; - + statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++; statsPtr->byteCodeCount[TclLog2((int)(codePtr->structureSize))]++; - statsPtr->currentInstBytes += (double) codePtr->numCodeBytes; - statsPtr->currentLitBytes += - (double) (codePtr->numLitObjects * sizeof(Tcl_Obj *)); - statsPtr->currentExceptBytes += - (double) (codePtr->numExceptRanges * sizeof(ExceptionRange)); - statsPtr->currentAuxBytes += - (double) (codePtr->numAuxDataItems * sizeof(AuxData)); + statsPtr->currentInstBytes += (double) codePtr->numCodeBytes; + statsPtr->currentLitBytes += (double) + codePtr->numLitObjects * sizeof(Tcl_Obj *); + statsPtr->currentExceptBytes += (double) + codePtr->numExceptRanges * sizeof(ExceptionRange); + statsPtr->currentAuxBytes += (double) + codePtr->numAuxDataItems * sizeof(AuxData); statsPtr->currentCmdMapBytes += (double) codePtr->numCmdLocBytes; } #endif /* TCL_COMPILE_STATS */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclCompile.h ================================================================== --- generic/tclCompile.h +++ generic/tclCompile.h @@ -6,11 +6,11 @@ * Copyright (c) 2001 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: tclCompile.h,v 1.51 2004/11/03 21:20:30 davygrvy Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.51.2.6 2005/08/02 18:15:21 dgp Exp $ */ #ifndef _TCLCOMPILATION #define _TCLCOMPILATION 1 @@ -32,13 +32,11 @@ * 2: display all instructions of each ByteCode compiled * This variable is linked to the Tcl variable "tcl_traceCompile". */ MODULE_SCOPE int tclTraceCompile; -#endif -#ifdef TCL_COMPILE_DEBUG /* * Variable that controls whether execution tracing is enabled and, if so, * what level of tracing is desired: * 0: no execution tracing * 1: trace invocations of Tcl procs only @@ -47,66 +45,67 @@ * This variable is linked to the Tcl variable "tcl_traceExec". */ MODULE_SCOPE int tclTraceExec; #endif - + /* *------------------------------------------------------------------------ * Data structures related to compilation. *------------------------------------------------------------------------ */ /* - * The structure used to implement Tcl "exceptions" (exceptional returns): - * for example, those generated in loops by the break and continue commands, - * and those generated by scripts and caught by the catch command. This - * ExceptionRange structure describes a range of code (e.g., a loop body), - * the kind of exceptions (e.g., a break or continue) that might occur, and - * the PC offsets to jump to if a matching exception does occur. Exception - * ranges can nest so this structure includes a nesting level that is used - * at runtime to find the closest exception range surrounding a PC. For - * example, when a break command is executed, the ExceptionRange structure - * for the most deeply nested loop, if any, is found and used. These - * structures are also generated for the "next" subcommands of for loops - * since a break there terminates the for command. This means a for command - * actually generates two LoopInfo structures. + * The structure used to implement Tcl "exceptions" (exceptional returns): for + * example, those generated in loops by the break and continue commands, and + * those generated by scripts and caught by the catch command. This + * ExceptionRange structure describes a range of code (e.g., a loop body), the + * kind of exceptions (e.g., a break or continue) that might occur, and the PC + * offsets to jump to if a matching exception does occur. Exception ranges can + * nest so this structure includes a nesting level that is used at runtime to + * find the closest exception range surrounding a PC. For example, when a + * break command is executed, the ExceptionRange structure for the most deeply + * nested loop, if any, is found and used. These structures are also generated + * for the "next" subcommands of for loops since a break there terminates the + * for command. This means a for command actually generates two LoopInfo + * structures. */ typedef enum { - LOOP_EXCEPTION_RANGE, /* Exception's range is part of a loop. - * Break and continue "exceptions" cause - * jumps to appropriate PC offsets. */ - CATCH_EXCEPTION_RANGE /* Exception's range is controlled by a - * catch command. Errors in the range cause - * a jump to a catch PC offset. */ + LOOP_EXCEPTION_RANGE, /* Exception's range is part of a loop. Break + * and continue "exceptions" cause jumps to + * appropriate PC offsets. */ + CATCH_EXCEPTION_RANGE /* Exception's range is controlled by a catch + * command. Errors in the range cause a jump + * to a catch PC offset. */ } ExceptionRangeType; typedef struct ExceptionRange { ExceptionRangeType type; /* The kind of ExceptionRange. */ - int nestingLevel; /* Static depth of the exception range. - * Used to find the most deeply-nested - * range surrounding a PC at runtime. */ - int codeOffset; /* Offset of the first instruction byte of - * the code range. */ + int nestingLevel; /* Static depth of the exception range. Used + * to find the most deeply-nested range + * surrounding a PC at runtime. */ + int codeOffset; /* Offset of the first instruction byte of the + * code range. */ int numCodeBytes; /* Number of bytes in the code range. */ int breakOffset; /* If LOOP_EXCEPTION_RANGE, the target PC * offset for a break command in the range. */ int continueOffset; /* If LOOP_EXCEPTION_RANGE and not -1, the * target PC offset for a continue command in - * the code range. Otherwise, ignore this range - * when processing a continue command. */ + * the code range. Otherwise, ignore this + * range when processing a continue + * command. */ int catchOffset; /* If a CATCH_EXCEPTION_RANGE, the target PC * offset for any "exception" in range. */ } ExceptionRange; /* * Structure used to map between instruction pc and source locations. It - * defines for each compiled Tcl command its code's starting offset and - * its source's starting offset and length. Note that the code offset - * increases monotonically: that is, the table is sorted in code offset - * order. The source offset is not monotonic. + * defines for each compiled Tcl command its code's starting offset and its + * source's starting offset and length. Note that the code offset increases + * monotonically: that is, the table is sorted in code offset order. The + * source offset is not monotonic. */ typedef struct CmdLocation { int codeOffset; /* Offset of first byte of command code. */ int numCodeBytes; /* Number of bytes for command's code. */ @@ -113,47 +112,46 @@ int srcOffset; /* Offset of first char of the command. */ int numSrcBytes; /* Number of command source chars. */ } CmdLocation; /* - * CompileProcs need the ability to record information during compilation - * that can be used by bytecode instructions during execution. The AuxData - * structure provides this "auxiliary data" mechanism. An arbitrary number - * of these structures can be stored in the ByteCode record (during - * compilation they are stored in a CompileEnv structure). Each AuxData - * record holds one word of client-specified data (often a pointer) and is - * given an index that instructions can later use to look up the structure - * and its data. + * CompileProcs need the ability to record information during compilation that + * can be used by bytecode instructions during execution. The AuxData + * structure provides this "auxiliary data" mechanism. An arbitrary number of + * these structures can be stored in the ByteCode record (during compilation + * they are stored in a CompileEnv structure). Each AuxData record holds one + * word of client-specified data (often a pointer) and is given an index that + * instructions can later use to look up the structure and its data. * * The following definitions declare the types of procedures that are called * to duplicate or free this auxiliary data when the containing ByteCode - * objects are duplicated and freed. Pointers to these procedures are kept - * in the AuxData structure. + * objects are duplicated and freed. Pointers to these procedures are kept in + * the AuxData structure. */ typedef ClientData (AuxDataDupProc) _ANSI_ARGS_((ClientData clientData)); typedef void (AuxDataFreeProc) _ANSI_ARGS_((ClientData clientData)); /* * We define a separate AuxDataType struct to hold type-related information * for the AuxData structure. This separation makes it possible for clients - * outside of the TCL core to manipulate (in a limited fashion!) AuxData; - * for example, it makes it possible to pickle and unpickle AuxData structs. + * outside of the TCL core to manipulate (in a limited fashion!) AuxData; for + * example, it makes it possible to pickle and unpickle AuxData structs. */ typedef struct AuxDataType { char *name; /* the name of the type. Types can be * registered and found by name */ - AuxDataDupProc *dupProc; /* Callback procedure to invoke when the - * aux data is duplicated (e.g., when the - * ByteCode structure containing the aux - * data is duplicated). NULL means just - * copy the source clientData bits; no - * proc need be called. */ - AuxDataFreeProc *freeProc; /* Callback procedure to invoke when the - * aux data is freed. NULL means no - * proc need be called. */ + AuxDataDupProc *dupProc; /* Callback procedure to invoke when the aux + * data is duplicated (e.g., when the ByteCode + * structure containing the aux data is + * duplicated). NULL means just copy the + * source clientData bits; no proc need be + * called. */ + AuxDataFreeProc *freeProc; /* Callback procedure to invoke when the aux + * data is freed. NULL means no proc need be + * called. */ } AuxDataType; /* * The definition of the AuxData structure that holds information created * during compilation by CompileProcs and used by instructions during @@ -178,74 +176,72 @@ #define COMPILEENV_INIT_CMD_MAP_SIZE 40 #define COMPILEENV_INIT_AUX_DATA_SIZE 5 typedef struct CompileEnv { Interp *iPtr; /* Interpreter containing the code being - * compiled. Commands and their compile - * procs are specific to an interpreter so - * the code emitted will depend on the - * interpreter. */ + * compiled. Commands and their compile procs + * are specific to an interpreter so the code + * emitted will depend on the interpreter. */ char *source; /* The source string being compiled by * SetByteCodeFromAny. This pointer is not * owned by the CompileEnv and must not be * freed or changed by it. */ int numSrcBytes; /* Number of bytes in source. */ - Proc *procPtr; /* If a procedure is being compiled, a - * pointer to its Proc structure; otherwise - * NULL. Used to compile local variables. - * Set from information provided by - * ObjInterpProc in tclProc.c. */ + Proc *procPtr; /* If a procedure is being compiled, a pointer + * to its Proc structure; otherwise NULL. Used + * to compile local variables. Set from + * information provided by ObjInterpProc in + * tclProc.c. */ int numCommands; /* Number of commands compiled. */ - int exceptDepth; /* Current exception range nesting level; - * -1 if not in any range currently. */ - int maxExceptDepth; /* Max nesting level of exception ranges; - * -1 if no ranges have been compiled. */ - int maxStackDepth; /* Maximum number of stack elements needed - * to execute the code. Set by compilation + int exceptDepth; /* Current exception range nesting level; -1 + * if not in any range currently. */ + int maxExceptDepth; /* Max nesting level of exception ranges; -1 + * if no ranges have been compiled. */ + int maxStackDepth; /* Maximum number of stack elements needed to + * execute the code. Set by compilation * procedures before returning. */ int currStackDepth; /* Current stack depth. */ - LiteralTable localLitTable; /* Contains LiteralEntry's describing - * all Tcl objects referenced by this - * compiled code. Indexed by the string - * representations of the literals. Used to - * avoid creating duplicate objects. */ + LiteralTable localLitTable; /* Contains LiteralEntry's describing all Tcl + * objects referenced by this compiled code. + * Indexed by the string representations of + * the literals. Used to avoid creating + * duplicate objects. */ unsigned char *codeStart; /* Points to the first byte of the code. */ unsigned char *codeNext; /* Points to next code array byte to use. */ - unsigned char *codeEnd; /* Points just after the last allocated - * code array byte. */ - int mallocedCodeArray; /* Set 1 if code array was expanded - * and codeStart points into the heap.*/ + unsigned char *codeEnd; /* Points just after the last allocated code + * array byte. */ + int mallocedCodeArray; /* Set 1 if code array was expanded and + * codeStart points into the heap.*/ LiteralEntry *literalArrayPtr; /* Points to start of LiteralEntry array. */ int literalArrayNext; /* Index of next free object array entry. */ int literalArrayEnd; /* Index just after last obj array entry. */ - int mallocedLiteralArray; /* 1 if object array was expanded and - * objArray points into the heap, else 0. */ + int mallocedLiteralArray; /* 1 if object array was expanded and objArray + * points into the heap, else 0. */ ExceptionRange *exceptArrayPtr; /* Points to start of the ExceptionRange * array. */ int exceptArrayNext; /* Next free ExceptionRange array index. - * exceptArrayNext is the number of ranges - * and (exceptArrayNext-1) is the index of - * the current range's array entry. */ - int exceptArrayEnd; /* Index after the last ExceptionRange - * array entry. */ - int mallocedExceptArray; /* 1 if ExceptionRange array was expanded - * and exceptArrayPtr points in heap, - * else 0. */ + * exceptArrayNext is the number of ranges and + * (exceptArrayNext-1) is the index of the + * current range's array entry. */ + int exceptArrayEnd; /* Index after the last ExceptionRange array + * entry. */ + int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and + * exceptArrayPtr points in heap, else 0. */ CmdLocation *cmdMapPtr; /* Points to start of CmdLocation array. - * numCommands is the index of the next - * entry to use; (numCommands-1) is the - * entry index for the last command. */ + * numCommands is the index of the next entry + * to use; (numCommands-1) is the entry index + * for the last command. */ int cmdMapEnd; /* Index after last CmdLocation entry. */ int mallocedCmdMap; /* 1 if command map array was expanded and * cmdMapPtr points in the heap, else 0. */ AuxData *auxDataArrayPtr; /* Points to auxiliary data array start. */ int auxDataArrayNext; /* Next free compile aux data array index. - * auxDataArrayNext is the number of aux - * data items and (auxDataArrayNext-1) is - * index of current aux data array entry. */ + * auxDataArrayNext is the number of aux data + * items and (auxDataArrayNext-1) is index of + * current aux data array entry. */ int auxDataArrayEnd; /* Index after last aux data array entry. */ int mallocedAuxDataArray; /* 1 if aux data array was expanded and * auxDataArrayPtr points in heap else 0. */ unsigned char staticCodeSpace[COMPILEENV_INIT_CODE_BYTES]; /* Initial storage for code. */ @@ -258,23 +254,30 @@ AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE]; /* Initial storage for aux data array. */ } CompileEnv; /* - * The structure defining the bytecode instructions resulting from compiling - * a Tcl script. Note that this structure is variable length: a single heap - * object is allocated to hold the ByteCode structure immediately followed - * by the code bytes, the literal object array, the ExceptionRange array, - * the CmdLocation map, and the compilation AuxData array. + * The structure defining the bytecode instructions resulting from compiling a + * Tcl script. Note that this structure is variable length: a single heap + * object is allocated to hold the ByteCode structure immediately followed by + * the code bytes, the literal object array, the ExceptionRange array, the + * CmdLocation map, and the compilation AuxData array. */ /* * A PRECOMPILED bytecode struct is one that was generated from a compiled * image rather than implicitly compiled from source */ #define TCL_BYTECODE_PRECOMPILED 0x0001 +/* + * When a bytecode is compiled, interp or namespace resolvers have not been + * applied yet: this is indicated by the TCL_BYTECODE_RESOLVE_VARS flag. + */ + +#define TCL_BYTECODE_RESOLVE_VARS 0x0002 + typedef struct ByteCode { TclHandle interpHandle; /* Handle for interpreter containing the * compiled code. Commands and their compile * procs are specific to an interpreter so the * code emitted will depend on the @@ -281,29 +284,29 @@ * interpreter. */ int compileEpoch; /* Value of iPtr->compileEpoch when this * ByteCode was compiled. Used to invalidate * code when, e.g., commands with compile * procs are redefined. */ - Namespace *nsPtr; /* Namespace context in which this code - * was compiled. If the code is executed - * if a different namespace, it must be + Namespace *nsPtr; /* Namespace context in which this code was + * compiled. If the code is executed if a + * different namespace, it must be * recompiled. */ int nsEpoch; /* Value of nsPtr->resolverEpoch when this * ByteCode was compiled. Used to invalidate * code when new namespace resolution rules * are put into effect. */ - int refCount; /* Reference count: set 1 when created - * plus 1 for each execution of the code - * currently active. This structure can be - * freed when refCount becomes zero. */ + int refCount; /* Reference count: set 1 when created plus 1 + * for each execution of the code currently + * active. This structure can be freed when + * refCount becomes zero. */ unsigned int flags; /* flags describing state for the codebyte. * this variable holds ORed values from the * TCL_BYTECODE_ masks defined above */ - char *source; /* The source string from which this - * ByteCode was compiled. Note that this - * pointer is not owned by the ByteCode and - * must not be freed or modified by it. */ + char *source; /* The source string from which this ByteCode + * was compiled. Note that this pointer is not + * owned by the ByteCode and must not be freed + * or modified by it. */ Proc *procPtr; /* If the ByteCode was compiled from a * procedure body, this is a pointer to its * Proc structure; otherwise NULL. This * pointer is also not owned by the ByteCode * and must not be freed by it. */ @@ -315,75 +318,73 @@ int numSrcBytes; /* Number of source bytes compiled. */ int numCodeBytes; /* Number of code bytes. */ int numLitObjects; /* Number of objects in literal array. */ int numExceptRanges; /* Number of ExceptionRange array elems. */ int numAuxDataItems; /* Number of AuxData items. */ - int numCmdLocBytes; /* Number of bytes needed for encoded - * command location information. */ + int numCmdLocBytes; /* Number of bytes needed for encoded command + * location information. */ int maxExceptDepth; /* Maximum nesting level of ExceptionRanges; * -1 if no ranges were compiled. */ - int maxStackDepth; /* Maximum number of stack elements needed - * to execute the code. */ - unsigned char *codeStart; /* Points to the first byte of the code. - * This is just after the final ByteCode - * member cmdMapPtr. */ - Tcl_Obj **objArrayPtr; /* Points to the start of the literal - * object array. This is just after the - * last code byte. */ + int maxStackDepth; /* Maximum number of stack elements needed to + * execute the code. */ + unsigned char *codeStart; /* Points to the first byte of the code. This + * is just after the final ByteCode member + * cmdMapPtr. */ + Tcl_Obj **objArrayPtr; /* Points to the start of the literal object + * array. This is just after the last code + * byte. */ ExceptionRange *exceptArrayPtr; /* Points to the start of the ExceptionRange - * array. This is just after the last - * object in the object array. */ + * array. This is just after the last object + * in the object array. */ AuxData *auxDataArrayPtr; /* Points to the start of the auxiliary data - * array. This is just after the last entry - * in the ExceptionRange array. */ + * array. This is just after the last entry in + * the ExceptionRange array. */ unsigned char *codeDeltaStart; - /* Points to the first of a sequence of - * bytes that encode the change in the - * starting offset of each command's code. - * If -127<=delta<=127, it is encoded as 1 - * byte, otherwise 0xFF (128) appears and - * the delta is encoded by the next 4 bytes. - * Code deltas are always positive. This - * sequence is just after the last entry in - * the AuxData array. */ + /* Points to the first of a sequence of bytes + * that encode the change in the starting + * offset of each command's code. If -127 <= + * delta <= 127, it is encoded as 1 byte, + * otherwise 0xFF (128) appears and the delta + * is encoded by the next 4 bytes. Code deltas + * are always positive. This sequence is just + * after the last entry in the AuxData + * array. */ unsigned char *codeLengthStart; - /* Points to the first of a sequence of - * bytes that encode the length of each - * command's code. The encoding is the same - * as for code deltas. Code lengths are - * always positive. This sequence is just - * after the last entry in the code delta - * sequence. */ + /* Points to the first of a sequence of bytes + * that encode the length of each command's + * code. The encoding is the same as for code + * deltas. Code lengths are always positive. + * This sequence is just after the last entry + * in the code delta sequence. */ unsigned char *srcDeltaStart; - /* Points to the first of a sequence of - * bytes that encode the change in the - * starting offset of each command's source. - * The encoding is the same as for code - * deltas. Source deltas can be negative. - * This sequence is just after the last byte - * in the code length sequence. */ + /* Points to the first of a sequence of bytes + * that encode the change in the starting + * offset of each command's source. The + * encoding is the same as for code deltas. + * Source deltas can be negative. This + * sequence is just after the last byte in the + * code length sequence. */ unsigned char *srcLengthStart; - /* Points to the first of a sequence of - * bytes that encode the length of each - * command's source. The encoding is the - * same as for code deltas. Source lengths - * are always positive. This sequence is - * just after the last byte in the source - * delta sequence. */ + /* Points to the first of a sequence of bytes + * that encode the length of each command's + * source. The encoding is the same as for + * code deltas. Source lengths are always + * positive. This sequence is just after the + * last byte in the source delta sequence. */ #ifdef TCL_COMPILE_STATS Tcl_Time createTime; /* Absolute time when the ByteCode was * created. */ #endif /* TCL_COMPILE_STATS */ } ByteCode; - + /* - * Opcodes for the Tcl bytecode instructions. These must correspond to - * the entries in the table of instruction descriptions, - * tclInstructionTable, in tclCompile.c. Also, the order and number of - * the expression opcodes (e.g., INST_LOR) must match the entries in - * the array operatorStrings in tclExecute.c. + * Opcodes for the Tcl bytecode instructions. These must correspond to the + * entries in the table of instruction descriptions, tclInstructionTable, in + * tclCompile.c. Also, the order and number of the expression opcodes (e.g., + * INST_LOR) must match the entries in the array operatorStrings in + * tclExecute.c. */ /* Opcodes 0 to 9 */ #define INST_DONE 0 #define INST_PUSH1 1 @@ -515,45 +516,64 @@ #define INST_LSET_LIST 96 #define INST_LSET_FLAT 97 /* TIP#90 - 'return' command. */ -#define INST_RETURN 98 +#define INST_RETURN_IMM 98 /* TIP#123 - exponentiation operator. */ #define INST_EXPON 99 /* TIP #157 - {expand}... language syntax support. */ -#define INST_EXPAND_START 100 -#define INST_EXPAND_STKTOP 101 -#define INST_INVOKE_EXPANDED 102 +#define INST_EXPAND_START 100 +#define INST_EXPAND_STKTOP 101 +#define INST_INVOKE_EXPANDED 102 /* * TIP #57 - 'lassign' command. Code generation requires immediate * LINDEX and LRANGE operators. */ #define INST_LIST_INDEX_IMM 103 #define INST_LIST_RANGE_IMM 104 -#define INST_START_CMD 105 +#define INST_START_CMD 105 #define INST_LIST_IN 106 #define INST_LIST_NOT_IN 107 +#define INST_PUSH_RETURN_OPTIONS 108 +#define INST_RETURN_STK 109 + +/* + * Dictionary (TIP#111) related commands. + */ + +#define INST_DICT_GET 110 +#define INST_DICT_SET 111 +#define INST_DICT_UNSET 112 +#define INST_DICT_INCR_IMM 113 +#define INST_DICT_APPEND 114 +#define INST_DICT_LAPPEND 115 +#define INST_DICT_FIRST 116 +#define INST_DICT_NEXT 117 +#define INST_DICT_DONE 118 +#define INST_DICT_UPDATE_START 119 +#define INST_DICT_UPDATE_END 120 + /* The last opcode */ -#define LAST_INST_OPCODE 107 - +#define LAST_INST_OPCODE 120 + /* - * Table describing the Tcl bytecode instructions: their name (for - * displaying code), total number of code bytes required (including - * operand bytes), and a description of the type of each operand. - * These operand types include signed and unsigned integers of length - * one and four bytes. The unsigned integers are used for indexes or - * for, e.g., the count of objects to push in a "push" instruction. + * Table describing the Tcl bytecode instructions: their name (for displaying + * code), total number of code bytes required (including operand bytes), and a + * description of the type of each operand. These operand types include signed + * and unsigned integers of length one and four bytes. The unsigned integers + * are used for indexes or for, e.g., the count of objects to push in a "push" + * instruction. */ #define MAX_INSTRUCTION_OPERANDS 2 typedef enum InstOperandType { @@ -560,99 +580,45 @@ OPERAND_NONE, OPERAND_INT1, /* One byte signed integer. */ OPERAND_INT4, /* Four byte signed integer. */ OPERAND_UINT1, /* One byte unsigned integer. */ OPERAND_UINT4, /* Four byte unsigned integer. */ - OPERAND_IDX4 /* Four byte signed index (actually an + OPERAND_IDX4, /* Four byte signed index (actually an * integer, but displayed differently.) */ + OPERAND_LVT1, /* One byte unsigned index into the local + * variable table. */ + OPERAND_LVT4 /* Four byte unsigned index into the local + * variable table. */ } InstOperandType; typedef struct InstructionDesc { char *name; /* Name of instruction. */ int numBytes; /* Total number of bytes for instruction. */ - int stackEffect; /* The worst-case balance stack effect of the - * instruction, used for stack requirements + int stackEffect; /* The worst-case balance stack effect of the + * instruction, used for stack requirements * computations. The value INT_MIN signals - * that the instruction's worst case effect - * is (1-opnd1). + * that the instruction's worst case effect is + * (1-opnd1). */ int numOperands; /* Number of operands. */ InstOperandType opTypes[MAX_INSTRUCTION_OPERANDS]; /* The type of each operand. */ } InstructionDesc; MODULE_SCOPE InstructionDesc tclInstructionTable[]; -/* - * Definitions of the values of the INST_CALL_BUILTIN_FUNC instruction's - * operand byte. Each value denotes a builtin Tcl math function. These - * values must correspond to the entries in the tclBuiltinFuncTable array - * below and to the values stored in the tclInt.h MathFunc structure's - * builtinFuncIndex field. - */ - -#define BUILTIN_FUNC_ACOS 0 -#define BUILTIN_FUNC_ASIN 1 -#define BUILTIN_FUNC_ATAN 2 -#define BUILTIN_FUNC_ATAN2 3 -#define BUILTIN_FUNC_CEIL 4 -#define BUILTIN_FUNC_COS 5 -#define BUILTIN_FUNC_COSH 6 -#define BUILTIN_FUNC_EXP 7 -#define BUILTIN_FUNC_FLOOR 8 -#define BUILTIN_FUNC_FMOD 9 -#define BUILTIN_FUNC_HYPOT 10 -#define BUILTIN_FUNC_LOG 11 -#define BUILTIN_FUNC_LOG10 12 -#define BUILTIN_FUNC_POW 13 -#define BUILTIN_FUNC_SIN 14 -#define BUILTIN_FUNC_SINH 15 -#define BUILTIN_FUNC_SQRT 16 -#define BUILTIN_FUNC_TAN 17 -#define BUILTIN_FUNC_TANH 18 -#define BUILTIN_FUNC_ABS 19 -#define BUILTIN_FUNC_DOUBLE 20 -#define BUILTIN_FUNC_INT 21 -#define BUILTIN_FUNC_RAND 22 -#define BUILTIN_FUNC_ROUND 23 -#define BUILTIN_FUNC_SRAND 24 -#define BUILTIN_FUNC_WIDE 25 - -#define LAST_BUILTIN_FUNC 25 - -/* - * Table describing the built-in math functions. Entries in this table are - * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's - * operand byte. - */ - -typedef int (CallBuiltinFuncProc) _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj **tosPtr, ClientData clientData)); - -typedef struct { - char *name; /* Name of function. */ - int numArgs; /* Number of arguments for function. */ - Tcl_ValueType argTypes[MAX_MATH_ARGS]; - /* Acceptable types for each argument. */ - CallBuiltinFuncProc *proc; /* Procedure implementing this function. */ - ClientData clientData; /* Additional argument to pass to the - * function when invoking it. */ -} BuiltinFunc; - -MODULE_SCOPE BuiltinFunc tclBuiltinFuncTable[]; - /* * Compilation of some Tcl constructs such as if commands and the logical or - * (||) and logical and (&&) operators in expressions requires the - * generation of forward jumps. Since the PC target of these jumps isn't - * known when the jumps are emitted, we record the offset of each jump in an - * array of JumpFixup structures. There is one array for each sequence of - * jumps to one target PC. When we learn the target PC, we update the jumps - * with the correct distance. Also, if the distance is too great (> 127 - * bytes), we replace the single-byte jump with a four byte jump - * instruction, move the instructions after the jump down, and update the - * code offsets for any commands between the jump and the target. + * (||) and logical and (&&) operators in expressions requires the generation + * of forward jumps. Since the PC target of these jumps isn't known when the + * jumps are emitted, we record the offset of each jump in an array of + * JumpFixup structures. There is one array for each sequence of jumps to one + * target PC. When we learn the target PC, we update the jumps with the + * correct distance. Also, if the distance is too great (> 127 bytes), we + * replace the single-byte jump with a four byte jump instruction, move the + * instructions after the jump down, and update the code offsets for any + * commands between the jump and the target. */ typedef enum { TCL_UNCONDITIONAL_JUMP, TCL_TRUE_JUMP, @@ -667,13 +633,13 @@ * for which the jump was emitted. Used to * update the code offsets for subsequent * commands if the two-byte jump at jumpPc * must be replaced with a five-byte one. */ int exceptIndex; /* Index of the first range entry in the - * ExceptionRange array after the current - * one. This field is used to adjust the - * code offsets in subsequent ExceptionRange + * ExceptionRange array after the current one. + * This field is used to adjust the code + * offsets in subsequent ExceptionRange * records when a jump is grown from 2 bytes * to 5 bytes. */ } JumpFixup; #define JUMPFIXUP_INIT_ENTRIES 10 @@ -687,25 +653,25 @@ JumpFixup staticFixupSpace[JUMPFIXUP_INIT_ENTRIES]; /* Initial storage for jump fixup array. */ } JumpFixupArray; /* - * The structure describing one variable list of a foreach command. Note - * that only foreach commands inside procedure bodies are compiled inline so - * a ForeachVarList structure always describes local variables. Furthermore, + * The structure describing one variable list of a foreach command. Note that + * only foreach commands inside procedure bodies are compiled inline so a + * ForeachVarList structure always describes local variables. Furthermore, * only scalar variables are supported for inline-compiled foreach loops. */ typedef struct ForeachVarList { int numVars; /* The number of variables in the list. */ int varIndexes[1]; /* An array of the indexes ("slot numbers") - * for each variable in the procedure's - * array of local variables. Only scalar - * variables are supported. The actual - * size of this field will be large enough - * to numVars indexes. THIS MUST BE THE - * LAST FIELD IN THE STRUCTURE! */ + * for each variable in the procedure's array + * of local variables. Only scalar variables + * are supported. The actual size of this + * field will be large enough to numVars + * indexes. THIS MUST BE THE LAST FIELD IN THE + * STRUCTURE! */ } ForeachVarList; /* * Structure used to hold information about a foreach command that is needed * during program execution. These structures are stored in CompileEnv and @@ -713,37 +679,34 @@ */ typedef struct ForeachInfo { int numLists; /* The number of both the variable and value * lists of the foreach command. */ - int firstValueTemp; /* Index of the first temp var in a proc - * frame used to point to a value list. */ - int loopCtTemp; /* Index of temp var in a proc frame - * holding the loop's iteration count. Used - * to determine next value list element to - * assign each loop var. */ + int firstValueTemp; /* Index of the first temp var in a proc frame + * used to point to a value list. */ + int loopCtTemp; /* Index of temp var in a proc frame holding + * the loop's iteration count. Used to + * determine next value list element to assign + * each loop var. */ ForeachVarList *varLists[1];/* An array of pointers to ForeachVarList * structures describing each var list. The * actual size of this field will be large - * enough to numVars indexes. THIS MUST BE - * THE LAST FIELD IN THE STRUCTURE! */ + * enough to numVars indexes. THIS MUST BE THE + * LAST FIELD IN THE STRUCTURE! */ } ForeachInfo; MODULE_SCOPE AuxDataType tclForeachInfoType; - - + /* *---------------------------------------------------------------- * Procedures exported by tclBasic.c to be used within the engine. *---------------------------------------------------------------- */ MODULE_SCOPE int TclEvalObjvInternal _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], CONST char *command, int length, int flags)); -MODULE_SCOPE int TclInterpReady _ANSI_ARGS_((Tcl_Interp *interp)); - /* *---------------------------------------------------------------- * Procedures exported by the engine to be used by tclBasic.c *---------------------------------------------------------------- @@ -752,11 +715,11 @@ /* * Declaration moved to the internal stubs table * MODULE_SCOPE int TclCompEvalObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); -*/ + */ /* *---------------------------------------------------------------- * Procedures shared among Tcl bytecode compilation and execution * modules but not used outside: @@ -809,12 +772,11 @@ MODULE_SCOPE void TclInitAuxDataTypeTable _ANSI_ARGS_((void)); MODULE_SCOPE void TclInitByteCodeObj _ANSI_ARGS_((Tcl_Obj *objPtr, CompileEnv *envPtr)); MODULE_SCOPE void TclInitCompilation _ANSI_ARGS_((void)); MODULE_SCOPE void TclInitCompileEnv _ANSI_ARGS_((Tcl_Interp *interp, - CompileEnv *envPtr, char *string, - int numBytes)); + CompileEnv *envPtr, char *string, int numBytes)); MODULE_SCOPE void TclInitJumpFixupArray _ANSI_ARGS_(( JumpFixupArray *fixupArrayPtr)); MODULE_SCOPE void TclInitLiteralTable _ANSI_ARGS_(( LiteralTable *tablePtr)); #ifdef TCL_COMPILE_STATS @@ -830,13 +792,14 @@ unsigned char *pc)); MODULE_SCOPE void TclPrintObject _ANSI_ARGS_((FILE *outFile, Tcl_Obj *objPtr, int maxChars)); MODULE_SCOPE void TclPrintSource _ANSI_ARGS_((FILE *outFile, CONST char *string, int maxChars)); -MODULE_SCOPE void TclRegisterAuxDataType _ANSI_ARGS_((AuxDataType *typePtr)); +MODULE_SCOPE void TclRegisterAuxDataType _ANSI_ARGS_(( + AuxDataType *typePtr)); MODULE_SCOPE int TclRegisterLiteral _ANSI_ARGS_((CompileEnv *envPtr, - char *bytes, int length, int onHeap)); + char *bytes, int length, int flags)); MODULE_SCOPE void TclReleaseLiteral _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); MODULE_SCOPE void TclSetCmdNameObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, Command *cmdPtr)); #ifdef TCL_COMPILE_DEBUG @@ -843,36 +806,54 @@ MODULE_SCOPE void TclVerifyGlobalLiteralTable _ANSI_ARGS_(( Interp *iPtr)); MODULE_SCOPE void TclVerifyLocalLiteralTable _ANSI_ARGS_(( CompileEnv *envPtr)); #endif -MODULE_SCOPE int TclCompileVariableCmd _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_Parse *parsePtr, CompileEnv *envPtr)); -MODULE_SCOPE int TclWordKnownAtCompileTime _ANSI_ARGS_(( - Tcl_Token *tokenPtr, Tcl_Obj *valuePtr)); - -/* - *---------------------------------------------------------------- - * Macros used by Tcl bytecode compilation and execution modules - * inside the Tcl core but not used outside. - *---------------------------------------------------------------- - */ - -/* - * Form of TclRegisterLiteral with onHeap == 0. - * In that case, it is safe to cast away CONSTness, and it - * is cleanest to do that here, all in one place. - */ - -#define TclRegisterNewLiteral(envPtr, bytes, length) \ - TclRegisterLiteral(envPtr, (char *)(bytes), length, /*onHeap*/ 0) - -/* - * Macro used to manually adjust the stack requirements; used - * in cases where the stack effect cannot be computed from - * the opcode and its operands, but is still known at - * compile time. +MODULE_SCOPE int TclCompileVariableCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, CompileEnv *envPtr)); +MODULE_SCOPE int TclWordKnownAtCompileTime _ANSI_ARGS_(( + Tcl_Token *tokenPtr, Tcl_Obj *valuePtr)); + +/* + *---------------------------------------------------------------- + * Macros and flag values used by Tcl bytecode compilation and execution + * modules inside the Tcl core but not used outside. + *---------------------------------------------------------------- + */ + +#define LITERAL_ON_HEAP 0x01 +#define LITERAL_NS_SCOPE 0x02 + +/* + * Form of TclRegisterLiteral with onHeap == 0. In that case, it is safe to + * cast away CONSTness, and it is cleanest to do that here, all in one place. + * + * int TclRegisterNewLiteral(CompileEnv *envPtr, const char *bytes, + * int length); + */ + +#define TclRegisterNewLiteral(envPtr, bytes, length) \ + TclRegisterLiteral(envPtr, (char *)(bytes), length, /*flags*/ 0) + +/* + * Form of TclRegisterNSLiteral with onHeap == 0. In that case, it is safe to + * cast away CONSTness, and it is cleanest to do that here, all in one place. + * + * int TclRegisterNewNSLiteral(CompileEnv *envPtr, const char *bytes, + * int length); + */ + +#define TclRegisterNewNSLiteral(envPtr, bytes, length) \ + TclRegisterLiteral(envPtr, (char *)(bytes), length, \ + /*flags*/ LITERAL_NS_SCOPE) + +/* + * Macro used to manually adjust the stack requirements; used in cases where + * the stack effect cannot be computed from the opcode and its operands, but + * is still known at compile time. + * + * void TclAdjustStackDepth(int delta, CompileEnv *envPtr); */ #define TclAdjustStackDepth(delta, envPtr) \ if ((delta) < 0) {\ if((envPtr)->maxStackDepth < (envPtr)->currStackDepth) {\ @@ -880,49 +861,49 @@ }\ }\ (envPtr)->currStackDepth += (delta) /* - * Macro used to update the stack requirements. - * It is called by the macros TclEmitOpCode, TclEmitInst1 and - * TclEmitInst4. - * Remark that the very last instruction of a bytecode always - * reduces the stack level: INST_DONE or INST_POP, so that the - * maxStackdepth is always updated. + * Macro used to update the stack requirements. It is called by the macros + * TclEmitOpCode, TclEmitInst1 and TclEmitInst4. + * Remark that the very last instruction of a bytecode always reduces the + * stack level: INST_DONE or INST_POP, so that the maxStackdepth is always + * updated. + * + * void TclUpdateStackReqs(unsigned char op, int i, CompileEnv *envPtr); */ #define TclUpdateStackReqs(op, i, envPtr) \ {\ int delta = tclInstructionTable[(op)].stackEffect;\ if (delta) {\ if (delta == INT_MIN) {\ delta = 1 - (i);\ }\ - TclAdjustStackDepth(delta, envPtr);\ - }\ + TclAdjustStackDepth(delta, envPtr);\ + }\ } /* - * Macro to emit an opcode byte into a CompileEnv's code array. - * The ANSI C "prototype" for this macro is: + * Macro to emit an opcode byte into a CompileEnv's code array. The ANSI C + * "prototype" for this macro is: * - * MODULE_SCOPE void TclEmitOpcode _ANSI_ARGS_((unsigned char op, - * CompileEnv *envPtr)); + * void TclEmitOpcode(unsigned char op, CompileEnv *envPtr); */ #define TclEmitOpcode(op, envPtr) \ if ((envPtr)->codeNext == (envPtr)->codeEnd) \ TclExpandCodeArray(envPtr); \ *(envPtr)->codeNext++ = (unsigned char) (op);\ TclUpdateStackReqs(op, 0, envPtr) /* - * Macros to emit an integer operand. - * The ANSI C "prototype" for these macros are: + * Macros to emit an integer operand. The ANSI C "prototype" for these macros + * are: * - * MODULE_SCOPE void TclEmitInt1 _ANSI_ARGS_((int i, CompileEnv *envPtr)); - * MODULE_SCOPE void TclEmitInt4 _ANSI_ARGS_((int i, CompileEnv *envPtr)); + * void TclEmitInt1(int i, CompileEnv *envPtr); + * void TclEmitInt4(int i, CompileEnv *envPtr); */ #define TclEmitInt1(i, envPtr) \ if ((envPtr)->codeNext == (envPtr)->codeEnd) \ TclExpandCodeArray(envPtr); \ @@ -942,19 +923,16 @@ (unsigned char) ((unsigned int) (i) ) /* * Macros to emit an instruction with signed or unsigned integer operands. * Four byte integers are stored in "big-endian" order with the high order - * byte stored at the lowest address. - * The ANSI C "prototypes" for these macros are: - * - * MODULE_SCOPE void TclEmitInstInt1 _ANSI_ARGS_((unsigned char op, int i, - * CompileEnv *envPtr)); - * MODULE_SCOPE void TclEmitInstInt4 _ANSI_ARGS_((unsigned char op, int i, - * CompileEnv *envPtr)); - */ - + * byte stored at the lowest address. The ANSI C "prototypes" for these + * macros are: + * + * void TclEmitInstInt1(unsigned char op, int i, CompileEnv *envPtr); + * void TclEmitInstInt4(unsigned char op, int i, CompileEnv *envPtr); + */ #define TclEmitInstInt1(op, i, envPtr) \ if (((envPtr)->codeNext + 2) > (envPtr)->codeEnd) { \ TclExpandCodeArray(envPtr); \ } \ @@ -977,15 +955,15 @@ (unsigned char) ((unsigned int) (i) );\ TclUpdateStackReqs(op, i, envPtr) /* * Macro to push a Tcl object onto the Tcl evaluation stack. It emits the - * object's one or four byte array index into the CompileEnv's code - * array. These support, respectively, a maximum of 256 (2**8) and 2**32 - * objects in a CompileEnv. The ANSI C "prototype" for this macro is: + * object's one or four byte array index into the CompileEnv's code array. + * These support, respectively, a maximum of 256 (2**8) and 2**32 objects in a + * CompileEnv. The ANSI C "prototype" for this macro is: * - * MODULE_SCOPE void TclEmitPush _ANSI_ARGS_((int objIndex, CompileEnv *envPtr)); + * void TclEmitPush(int objIndex, CompileEnv *envPtr); */ #define TclEmitPush(objIndex, envPtr) \ {\ register int objIndexCopy = (objIndex);\ @@ -995,16 +973,16 @@ TclEmitInstInt4(INST_PUSH4, objIndexCopy, (envPtr)); \ }\ } /* - * Macros to update a (signed or unsigned) integer starting at a pointer. - * The two variants depend on the number of bytes. The ANSI C "prototypes" - * for these macros are: + * Macros to update a (signed or unsigned) integer starting at a pointer. The + * two variants depend on the number of bytes. The ANSI C "prototypes" for + * these macros are: * - * MODULE_SCOPE void TclStoreInt1AtPtr _ANSI_ARGS_((int i, unsigned char *p)); - * MODULE_SCOPE void TclStoreInt4AtPtr _ANSI_ARGS_((int i, unsigned char *p)); + * void TclStoreInt1AtPtr(int i, unsigned char *p); + * void TclStoreInt4AtPtr(int i, unsigned char *p); */ #define TclStoreInt1AtPtr(i, p) \ *(p) = (unsigned char) ((unsigned int) (i)) @@ -1013,18 +991,16 @@ *(p+1) = (unsigned char) ((unsigned int) (i) >> 16); \ *(p+2) = (unsigned char) ((unsigned int) (i) >> 8); \ *(p+3) = (unsigned char) ((unsigned int) (i) ) /* - * Macros to update instructions at a particular pc with a new op code - * and a (signed or unsigned) int operand. The ANSI C "prototypes" for - * these macros are: - * - * MODULE_SCOPE void TclUpdateInstInt1AtPc _ANSI_ARGS_((unsigned char op, int i, - * unsigned char *pc)); - * MODULE_SCOPE void TclUpdateInstInt4AtPc _ANSI_ARGS_((unsigned char op, int i, - * unsigned char *pc)); + * Macros to update instructions at a particular pc with a new op code and a + * (signed or unsigned) int operand. The ANSI C "prototypes" for these macros + * are: + * + * void TclUpdateInstInt1AtPc(unsigned char op, int i, unsigned char *pc); + * void TclUpdateInstInt4AtPc(unsigned char op, int i, unsigned char *pc); */ #define TclUpdateInstInt1AtPc(op, i, pc) \ *(pc) = (unsigned char) (op); \ TclStoreInt1AtPtr((i), ((pc)+1)) @@ -1032,53 +1008,52 @@ #define TclUpdateInstInt4AtPc(op, i, pc) \ *(pc) = (unsigned char) (op); \ TclStoreInt4AtPtr((i), ((pc)+1)) /* - * Macro to fix up a forward jump to point to the current - * code-generation position in the bytecode being created (the most - * common case). The ANSI C "prototypes" for this macro is: + * Macro to fix up a forward jump to point to the current code-generation + * position in the bytecode being created (the most common case). The ANSI C + * "prototypes" for this macro is: * - * MODULE_SCOPE int TclFixupForwardJumpToHere _ANSI_ARGS_((CompileEnv *envPtr, - * JumpFixup *fixupPtr, int threshold)); + * int TclFixupForwardJumpToHere(CompileEnv *envPtr, JumpFixup *fixupPtr, + * int threshold); */ #define TclFixupForwardJumpToHere(envPtr, fixupPtr, threshold) \ TclFixupForwardJump((envPtr), (fixupPtr), \ (envPtr)->codeNext-(envPtr)->codeStart-(fixupPtr)->codeOffset, \ (threshold)) /* * Macros to get a signed integer (GET_INT{1,2}) or an unsigned int - * (GET_UINT{1,2}) from a pointer. There are two variants for each - * return type that depend on the number of bytes fetched. - * The ANSI C "prototypes" for these macros are: - * - * MODULE_SCOPE int TclGetInt1AtPtr _ANSI_ARGS_((unsigned char *p)); - * MODULE_SCOPE int TclGetInt4AtPtr _ANSI_ARGS_((unsigned char *p)); - * MODULE_SCOPE unsigned int TclGetUInt1AtPtr _ANSI_ARGS_((unsigned char *p)); - * MODULE_SCOPE unsigned int TclGetUInt4AtPtr _ANSI_ARGS_((unsigned char *p)); + * (GET_UINT{1,2}) from a pointer. There are two variants for each return type + * that depend on the number of bytes fetched. The ANSI C "prototypes" for + * these macros are: + * + * int TclGetInt1AtPtr(unsigned char *p); + * int TclGetInt4AtPtr(unsigned char *p); + * unsigned int TclGetUInt1AtPtr(unsigned char *p); + * unsigned int TclGetUInt4AtPtr(unsigned char *p); */ /* - * The TclGetInt1AtPtr macro is tricky because we want to do sign - * extension on the 1-byte value. Unfortunately the "char" type isn't - * signed on all platforms so sign-extension doesn't always happen - * automatically. Sometimes we can explicitly declare the pointer to be - * signed, but other times we have to explicitly sign-extend the value - * in software. + * The TclGetInt1AtPtr macro is tricky because we want to do sign extension on + * the 1-byte value. Unfortunately the "char" type isn't signed on all + * platforms so sign-extension doesn't always happen automatically. Sometimes + * we can explicitly declare the pointer to be signed, but other times we have + * to explicitly sign-extend the value in software. */ #ifndef __CHAR_UNSIGNED__ # define TclGetInt1AtPtr(p) ((int) *((char *) p)) #else # ifdef HAVE_SIGNED_CHAR # define TclGetInt1AtPtr(p) ((int) *((signed char *) p)) -# else +# else # define TclGetInt1AtPtr(p) (((int) *((char *) p)) \ | ((*(p) & 0200) ? (-256) : 0)) -# endif +# endif #endif #define TclGetInt4AtPtr(p) (((int) TclGetInt1AtPtr(p) << 24) | \ (*((p)+1) << 16) | \ (*((p)+2) << 8) | \ @@ -1089,16 +1064,16 @@ (*((p)+1) << 16) | \ (*((p)+2) << 8) | \ (*((p)+3))) /* - * Macros used to compute the minimum and maximum of two integers. - * The ANSI C "prototypes" for these macros are: + * Macros used to compute the minimum and maximum of two integers. The ANSI C + * "prototypes" for these macros are: * - * MODULE_SCOPE int TclMin _ANSI_ARGS_((int i, int j)); - * MODULE_SCOPE int TclMax _ANSI_ARGS_((int i, int j)); + * int TclMin(int i, int j); + * int TclMax(int i, int j); */ #define TclMin(i, j) ((((int) i) < ((int) j))? (i) : (j)) #define TclMax(i, j) ((((int) i) > ((int) j))? (i) : (j)) #endif /* _TCLCOMPILATION */ Index: generic/tclConfig.c ================================================================== --- generic/tclConfig.c +++ generic/tclConfig.c @@ -1,61 +1,54 @@ -/* +/* * tclConfig.c -- * * This file provides the facilities which allow Tcl and other packages * to embed configuration information into their binary libraries. * * Copyright (c) 2002 Andreas Kupries * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclConfig.c,v 1.6 2004/10/29 15:39:05 dkf Exp $ + * RCS: @(#) $Id: tclConfig.c,v 1.6.2.2 2005/08/02 18:15:22 dgp Exp $ */ #include "tclInt.h" /* * Internal structure to hold embedded configuration information. * - * Our structure is a two-level dictionary associated with the - * 'interp'. The first level is keyed with the package name and maps - * to the dictionary for that package. The package dictionary is keyed - * with metadata keys and maps to the metadata value for that - * key. This is package specific. The metadata values are in UTF8, - * converted from the external representation given to us by the - * caller. + * Our structure is a two-level dictionary associated with the 'interp'. The + * first level is keyed with the package name and maps to the dictionary for + * that package. The package dictionary is keyed with metadata keys and maps + * to the metadata value for that key. This is package specific. The metadata + * values are in UTF-8, converted from the external representation given to us + * by the caller. */ #define ASSOC_KEY "tclPackageAboutDict" /* * Static functions in this file: */ -static int -QueryConfigObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST * objv)); - -static void -QueryConfigDelete _ANSI_ARGS_((ClientData clientData)); - -static Tcl_Obj* -GetConfigDict _ANSI_ARGS_((Tcl_Interp* interp)); - -static void -ConfigDictDeleteProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp)); +static int QueryConfigObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + struct Tcl_Obj * CONST * objv)); +static void QueryConfigDelete _ANSI_ARGS_((ClientData clientData)); +static Tcl_Obj * GetConfigDict _ANSI_ARGS_((Tcl_Interp* interp)); +static void ConfigDictDeleteProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); /* *---------------------------------------------------------------------- * * Tcl_RegisterConfig -- * - * See TIP#59 for details on what this procedure does. + * See TIP#59 for details on what this function does. * * Results: * None. * * Side effects: @@ -63,114 +56,112 @@ * *---------------------------------------------------------------------- */ void -Tcl_RegisterConfig (interp, pkgName, configuration, valEncoding) - Tcl_Interp* interp; /* Interpreter the configuration - * command is registered in. */ - CONST char* pkgName; /* Name of the package registering - * the embedded configuration. ASCII, - * thus in UTF-8 too. */ - Tcl_Config* configuration; /* Embedded configuration */ - CONST char* valEncoding; /* Name of the encoding used to - * store the configuration values, - * ASCII, thus UTF-8 */ -{ - Tcl_Encoding venc = Tcl_GetEncoding (NULL, valEncoding); - Tcl_Obj* pDB = GetConfigDict (interp); - Tcl_Obj* pkg = Tcl_NewStringObj (pkgName, -1); - Tcl_Obj* pkgDict; - Tcl_DString cmdName; - Tcl_Config* cfg; - int res; +Tcl_RegisterConfig(interp, pkgName, configuration, valEncoding) + Tcl_Interp *interp; /* Interpreter the configuration command is + * registered in. */ + CONST char *pkgName; /* Name of the package registering the + * embedded configuration. ASCII, thus in + * UTF-8 too. */ + Tcl_Config *configuration; /* Embedded configuration. */ + CONST char *valEncoding; /* Name of the encoding used to store the + * configuration values, ASCII, thus UTF-8. */ +{ + Tcl_Encoding venc = Tcl_GetEncoding(NULL, valEncoding); + Tcl_Obj *pDB = GetConfigDict(interp); + Tcl_Obj *pkg = Tcl_NewStringObj(pkgName, -1); + Tcl_Obj *pkgDict; + Tcl_DString cmdName; + Tcl_Config *cfg; + int res; + + /* + * Phase I: Adding the provided information to the internal database of + * package meta data. + * + * Phase II: Create a command for querying this database, specific to the + * package registerting its configuration. This is the approved interface + * in TIP 59. In the future a more general interface should be done, as + * followup to TIP 59. Simply because our database is now general across + * packages, and not a structure tied to one package. + * + * Note, the created command will have a reference through its clientdata. + */ + + Tcl_IncrRefCount(pkg); + + /* + * Retrieve package specific configuration... + */ + + res = Tcl_DictObjGet(interp, pDB, pkg, &pkgDict); + if ((TCL_OK != res) || (pkgDict == NULL)) { + pkgDict = Tcl_NewDictObj(); + } else if (Tcl_IsShared(pkgDict)) { + pkgDict = Tcl_DuplicateObj(pkgDict); + } /* - * Phase I: Adding the provided information to the internal - * database of package meta data. - * - * Phase II: Create a command for querying this database, specific - * to the package registerting its configuration. This is the - * approved interface in TIP 59. In the future a more general - * interface should be done, as followup to TIP 59. Simply because - * our database is now general across packages, and not a - * structure tied to one package. + * Extend the package configuration... */ - /* Note, the created command will have a reference through its clientdata */ - Tcl_IncrRefCount (pkg); - - /* Retrieve package specific configuration ... */ - - res = Tcl_DictObjGet (interp, pDB, pkg, &pkgDict); - if ((TCL_OK != res) || (pkgDict == NULL)) { - pkgDict = Tcl_NewDictObj (); - } else if (Tcl_IsShared (pkgDict)) { - pkgDict = Tcl_DuplicateObj (pkgDict); - } - - /* Extend the package configuration ... */ - - for (cfg = configuration; - (cfg->key != (CONST char*) NULL) && (cfg->key [0] != '\0') ; - cfg++) { - + for (cfg=configuration ; (cfg->key!=NULL) && (cfg->key[0]!='\0') ; cfg++) { Tcl_DString conv; - CONST char* convValue = Tcl_ExternalToUtfDString (venc, cfg->value, -1, &conv); + CONST char *convValue = + Tcl_ExternalToUtfDString(venc, cfg->value, -1, &conv); /* * We know that the keys are in ASCII/UTF-8, so for them is no * conversion required. */ - Tcl_DictObjPut (interp, pkgDict, - Tcl_NewStringObj (cfg->key, -1), - Tcl_NewStringObj (convValue, -1)); - Tcl_DStringFree (&conv); + Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1), + Tcl_NewStringObj(convValue, -1)); + Tcl_DStringFree(&conv); } - /* Write the changes back into the overall database */ + /* + * Write the changes back into the overall database. + */ - Tcl_DictObjPut (interp, pDB, pkg, pkgDict); + Tcl_DictObjPut(interp, pDB, pkg, pkgDict); /* * Now create the interface command for retrieval of the package * information. */ - Tcl_DStringInit (&cmdName); - Tcl_DStringAppend (&cmdName, "::", -1); - Tcl_DStringAppend (&cmdName, pkgName, -1); + Tcl_DStringInit(&cmdName); + Tcl_DStringAppend(&cmdName, "::", -1); + Tcl_DStringAppend(&cmdName, pkgName, -1); - /* The incomplete command name is the name of the namespace to - * place it in. + /* + * The incomplete command name is the name of the namespace to place it + * in. */ - if ((Tcl_Namespace*) NULL == Tcl_FindNamespace(interp, - Tcl_DStringValue (&cmdName), NULL, TCL_GLOBAL_ONLY)) { - - if ((Tcl_Namespace*) NULL == Tcl_CreateNamespace (interp, - Tcl_DStringValue (&cmdName), (ClientData) NULL, - (Tcl_NamespaceDeleteProc *) NULL)) { - - Tcl_Panic ("%s.\n%s %s", Tcl_GetStringResult(interp), + if (Tcl_FindNamespace(interp, Tcl_DStringValue(&cmdName), NULL, + TCL_GLOBAL_ONLY) == NULL) { + if (Tcl_CreateNamespace(interp, Tcl_DStringValue(&cmdName), + (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL) == NULL) { + Tcl_Panic("%s.\n%s %s", Tcl_GetStringResult(interp), "Tcl_RegisterConfig: Unable to create namespace for", "package configuration."); } } - Tcl_DStringAppend (&cmdName, "::pkgconfig", -1); + Tcl_DStringAppend(&cmdName, "::pkgconfig", -1); - if ((Tcl_Command) NULL == Tcl_CreateObjCommand (interp, - Tcl_DStringValue (&cmdName), QueryConfigObjCmd, - (ClientData) pkg, QueryConfigDelete)) { - - Tcl_Panic ("%s %s", "Tcl_RegisterConfig: Unable to create query", + if (Tcl_CreateObjCommand(interp, Tcl_DStringValue(&cmdName), + QueryConfigObjCmd, (ClientData) pkg, QueryConfigDelete) == NULL) { + Tcl_Panic("%s %s", "Tcl_RegisterConfig: Unable to create query", "command for package configuration"); } - Tcl_DStringFree (&cmdName); + Tcl_DStringFree(&cmdName); } /* *---------------------------------------------------------------------- * @@ -188,20 +179,18 @@ *---------------------------------------------------------------------- */ static int QueryConfigObjCmd(clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - struct Tcl_Obj * CONST *objv; -{ - Tcl_Obj *pkgName = (Tcl_Obj*) clientData; - Tcl_Obj *pDB, *pkgDict, *val; - Tcl_DictSearch s; - int n, i, res, done, index; - Tcl_Obj *key, **vals; + ClientData clientData; + Tcl_Interp *interp; + int objc; + struct Tcl_Obj * CONST *objv; +{ + Tcl_Obj *pkgName = (Tcl_Obj *) clientData; + Tcl_Obj *pDB, *pkgDict, *val, *listPtr; + int n, i, res, index; static CONST char *subcmdStrings[] = { "get", "list", NULL }; enum subcmds { @@ -210,19 +199,23 @@ if ((objc < 2) || (objc > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], subcmdStrings, - "subcommand", 0, &index) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[1], subcmdStrings, "subcommand", 0, + &index) != TCL_OK) { return TCL_ERROR; } pDB = GetConfigDict(interp); res = Tcl_DictObjGet(interp, pDB, pkgName, &pkgDict); if (res!=TCL_OK || pkgDict==NULL) { - /* Maybe a Tcl_Panic is better, because the package data has to be present */ + /* + * Maybe a Tcl_Panic is better, because the package data has to be + * present. + */ + Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1)); return TCL_ERROR; } switch ((enum subcmds) index) { @@ -246,23 +239,36 @@ Tcl_WrongNumArgs(interp, 1, objv, "list"); return TCL_ERROR; } Tcl_DictObjSize(interp, pkgDict, &n); - if (n == 0) { - Tcl_SetObjResult(interp, Tcl_NewListObj(0, NULL)); - return TCL_OK; + listPtr = Tcl_NewListObj(n, NULL); + + if (!listPtr) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("insufficient memory to create list",-1)); + return TCL_ERROR; } - vals = (Tcl_Obj**) ckalloc(n * sizeof(Tcl_Obj*)); + if (n) { + List *listRepPtr = (List *) + listPtr->internalRep.twoPtrValue.ptr1; + Tcl_DictSearch s; + Tcl_Obj *key, **vals; + int done; + + listRepPtr->elemCount = n; + vals = &listRepPtr->elements; - for (i=0, Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done); - !done; Tcl_DictObjNext(&s, &key, NULL, &done), i++) { - vals[i] = key; + for (i=0, Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done); + !done; Tcl_DictObjNext(&s, &key, NULL, &done), i++) { + vals[i] = key; + Tcl_IncrRefCount(key); + } } - Tcl_SetObjResult(interp, TclNewListObjDirect(n, vals)); + Tcl_SetObjResult(interp, listPtr); return TCL_OK; default: Tcl_Panic("QueryConfigObjCmd: Unknown subcommand to 'pkgconfig'. This can't happen"); break; @@ -273,11 +279,11 @@ /* *------------------------------------------------------------------------- * * QueryConfigDelete -- * - * Command delete procedure. Cleans up after the configuration query + * Command delete function. Cleans up after the configuration query * command when it is deleted by the user or during finalization. * * Results: * None. * @@ -286,15 +292,15 @@ * *------------------------------------------------------------------------- */ static void -QueryConfigDelete (clientData) - ClientData clientData; +QueryConfigDelete(clientData) + ClientData clientData; { - Tcl_Obj* pkgName = (Tcl_Obj*) clientData; - Tcl_DecrRefCount (pkgName); + Tcl_Obj *pkgName = (Tcl_Obj *) clientData; + Tcl_DecrRefCount(pkgName); } /* *------------------------------------------------------------------------- * @@ -310,34 +316,34 @@ * May allocate a Tcl_Obj. * *------------------------------------------------------------------------- */ -static Tcl_Obj* -GetConfigDict (interp) - Tcl_Interp* interp; -{ - Tcl_Obj* pDB = Tcl_GetAssocData (interp, ASSOC_KEY, NULL); - - if (pDB == (Tcl_Obj*) NULL) { - pDB = Tcl_NewDictObj (); - Tcl_IncrRefCount (pDB); - Tcl_SetAssocData (interp, ASSOC_KEY, ConfigDictDeleteProc, pDB); - } - - return pDB; +static Tcl_Obj * +GetConfigDict(interp) + Tcl_Interp *interp; +{ + Tcl_Obj *pDB = Tcl_GetAssocData(interp, ASSOC_KEY, NULL); + + if (pDB == (Tcl_Obj *) NULL) { + pDB = Tcl_NewDictObj(); + Tcl_IncrRefCount(pDB); + Tcl_SetAssocData(interp, ASSOC_KEY, ConfigDictDeleteProc, pDB); + } + + return pDB; } /* *---------------------------------------------------------------------- * * ConfigDictDeleteProc -- * - * This procedure is associated with the "Package About dict" assoc data - * for an interpreter; it is invoked when the interpreter is - * deleted in order to free the information assoicated with any - * pending error reports. + * This function is associated with the "Package About dict" assoc data + * for an interpreter; it is invoked when the interpreter is deleted in + * order to free the information assoicated with any pending error + * reports. * * Results: * None. * * Side effects: @@ -349,8 +355,16 @@ static void ConfigDictDeleteProc(clientData, interp) ClientData clientData; /* Pointer to Tcl_Obj. */ Tcl_Interp *interp; /* Interpreter being deleted. */ { - Tcl_Obj* pDB = (Tcl_Obj*) clientData; - Tcl_DecrRefCount (pDB); + Tcl_Obj *pDB = (Tcl_Obj *) clientData; + Tcl_DecrRefCount(pDB); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclDate.c ================================================================== --- generic/tclDate.c +++ generic/tclDate.c @@ -1,9 +1,9 @@ -/* A Bison parser, made by GNU Bison 1.875. */ +/* A Bison parser, made by GNU Bison 1.875b. */ /* Skeleton parser for Yacc-like parsing with Bison, - Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002 Free Software Foundation, Inc. + Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. @@ -103,11 +103,11 @@ /* Copy the first part of user declarations. */ -#line 17 "../unix/../generic/tclGetDate.y" + /* * tclDate.c -- * * This file is generated from a yacc grammar defined in @@ -167,10 +167,12 @@ int dateHaveDay; char *dateInput; time_t *dateRelPointer; + int dateDigitCount; + } DateInfo; #define YYPARSE_PARAM info #define YYLEX_PARAM info @@ -195,10 +197,11 @@ #define yyRelMonth (((DateInfo*)info)->dateRelMonth) #define yyRelDay (((DateInfo*)info)->dateRelDay) #define yyRelSeconds (((DateInfo*)info)->dateRelSeconds) #define yyRelPointer (((DateInfo*)info)->dateRelPointer) #define yyInput (((DateInfo*)info)->dateInput) +#define yyDigitCount (((DateInfo*)info)->dateDigitCount) #define EPOCH 1970 #define START_OF_TIME 1902 #define END_OF_TIME 2037 @@ -261,17 +264,17 @@ #else # define YYERROR_VERBOSE 0 #endif #if ! defined (YYSTYPE) && ! defined (YYSTYPE_IS_DECLARED) -#line 160 "../unix/../generic/tclGetDate.y" + typedef union YYSTYPE { time_t Number; enum _MERIDIAN Meridian; } YYSTYPE; /* Line 191 of yacc.c. */ -#line 272 "../unix/../generic/tclDate.c" + # define yystype YYSTYPE /* obsolescent; will be withdrawn */ # define YYSTYPE_IS_DECLARED 1 # define YYSTYPE_IS_TRIVIAL 1 #endif @@ -279,11 +282,11 @@ /* Copy the second part of user declarations. */ /* Line 214 of yacc.c. */ -#line 284 "../unix/../generic/tclDate.c" + #if ! defined (yyoverflow) || YYERROR_VERBOSE /* The parser invokes alloca or malloc; define the necessary symbols. */ @@ -468,16 +471,16 @@ }; /* YYRLINE[YYN] -- source line where rule number YYN was defined. */ static const unsigned short yyrline[] = { - 0, 176, 176, 177, 180, 183, 186, 189, 192, 195, - 198, 202, 207, 210, 216, 222, 230, 236, 247, 251, - 255, 261, 265, 269, 273, 277, 283, 287, 292, 297, - 302, 307, 311, 316, 320, 325, 332, 336, 342, 351, - 360, 370, 383, 388, 390, 391, 392, 393, 394, 396, - 397, 399, 400, 401, 404, 423, 426 + 0, 179, 179, 180, 183, 186, 189, 192, 195, 198, + 201, 205, 210, 213, 219, 225, 233, 239, 250, 254, + 258, 264, 268, 272, 276, 280, 286, 290, 295, 300, + 305, 310, 314, 319, 323, 328, 335, 339, 345, 354, + 363, 373, 386, 391, 393, 394, 395, 396, 397, 399, + 400, 402, 403, 404, 407, 426, 429 }; #endif #if YYDEBUG || YYERROR_VERBOSE /* YYTNME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM. @@ -639,10 +642,11 @@ #define YYEOF 0 #define YYACCEPT goto yyacceptlab #define YYABORT goto yyabortlab #define YYERROR goto yyerrlab1 + /* Like YYERROR except do call yyerror. This remains here temporarily to ease the transition to the new meaning of YYERROR, for GCC. Once GCC version 2 has supplanted version 1, this can go. */ @@ -760,13 +764,13 @@ yy_reduce_print (yyrule) int yyrule; #endif { int yyi; - unsigned int yylineno = yyrline[yyrule]; + unsigned int yylno = yyrline[yyrule]; YYFPRINTF (stderr, "Reducing stack by rule %d (line %u), ", - yyrule - 1, yylineno); + yyrule - 1, yylno); /* Print the symbols being reduced, and their result. */ for (yyi = yyprhs[yyrule]; 0 <= yyrhs[yyi]; yyi++) YYFPRINTF (stderr, "%s ", yytname [yyrhs[yyi]]); YYFPRINTF (stderr, "-> %s\n", yytname [yyr1[yyrule]]); } @@ -1222,90 +1226,90 @@ YY_REDUCE_PRINT (yyn); switch (yyn) { case 4: -#line 180 "../unix/../generic/tclGetDate.y" + { yyHaveTime++; ;} break; case 5: -#line 183 "../unix/../generic/tclGetDate.y" + { yyHaveZone++; ;} break; case 6: -#line 186 "../unix/../generic/tclGetDate.y" + { yyHaveDate++; ;} break; case 7: -#line 189 "../unix/../generic/tclGetDate.y" + { yyHaveOrdinalMonth++; ;} break; case 8: -#line 192 "../unix/../generic/tclGetDate.y" + { yyHaveDay++; ;} break; case 9: -#line 195 "../unix/../generic/tclGetDate.y" + { yyHaveRel++; ;} break; case 10: -#line 198 "../unix/../generic/tclGetDate.y" + { yyHaveTime++; yyHaveDate++; ;} break; case 11: -#line 202 "../unix/../generic/tclGetDate.y" + { yyHaveTime++; yyHaveDate++; yyHaveRel++; ;} break; case 13: -#line 210 "../unix/../generic/tclGetDate.y" + { yyHour = yyvsp[-1].Number; yyMinutes = 0; yySeconds = 0; yyMeridian = yyvsp[0].Meridian; ;} break; case 14: -#line 216 "../unix/../generic/tclGetDate.y" + { yyHour = yyvsp[-3].Number; yyMinutes = yyvsp[-1].Number; yySeconds = 0; yyMeridian = yyvsp[0].Meridian; ;} break; case 15: -#line 222 "../unix/../generic/tclGetDate.y" + { yyHour = yyvsp[-4].Number; yyMinutes = yyvsp[-2].Number; yyMeridian = MER24; yyDSTmode = DSToff; @@ -1313,21 +1317,21 @@ ++yyHaveZone; ;} break; case 16: -#line 230 "../unix/../generic/tclGetDate.y" + { yyHour = yyvsp[-5].Number; yyMinutes = yyvsp[-3].Number; yySeconds = yyvsp[-1].Number; yyMeridian = yyvsp[0].Meridian; ;} break; case 17: -#line 236 "../unix/../generic/tclGetDate.y" + { yyHour = yyvsp[-6].Number; yyMinutes = yyvsp[-4].Number; yySeconds = yyvsp[-2].Number; yyMeridian = MER24; @@ -1336,178 +1340,178 @@ ++yyHaveZone; ;} break; case 18: -#line 247 "../unix/../generic/tclGetDate.y" + { yyTimezone = yyvsp[-1].Number; yyDSTmode = DSTon; ;} break; case 19: -#line 251 "../unix/../generic/tclGetDate.y" + { yyTimezone = yyvsp[0].Number; yyDSTmode = DSToff; ;} break; case 20: -#line 255 "../unix/../generic/tclGetDate.y" + { yyTimezone = yyvsp[0].Number; yyDSTmode = DSTon; ;} break; case 21: -#line 261 "../unix/../generic/tclGetDate.y" + { yyDayOrdinal = 1; yyDayNumber = yyvsp[0].Number; ;} break; case 22: -#line 265 "../unix/../generic/tclGetDate.y" + { yyDayOrdinal = 1; yyDayNumber = yyvsp[-1].Number; ;} break; case 23: -#line 269 "../unix/../generic/tclGetDate.y" + { yyDayOrdinal = yyvsp[-1].Number; yyDayNumber = yyvsp[0].Number; ;} break; case 24: -#line 273 "../unix/../generic/tclGetDate.y" + { yyDayOrdinal = yyvsp[-2].Number * yyvsp[-1].Number; yyDayNumber = yyvsp[0].Number; ;} break; case 25: -#line 277 "../unix/../generic/tclGetDate.y" + { yyDayOrdinal = 2; yyDayNumber = yyvsp[0].Number; ;} break; case 26: -#line 283 "../unix/../generic/tclGetDate.y" + { yyMonth = yyvsp[-2].Number; yyDay = yyvsp[0].Number; ;} break; case 27: -#line 287 "../unix/../generic/tclGetDate.y" + { yyMonth = yyvsp[-4].Number; yyDay = yyvsp[-2].Number; yyYear = yyvsp[0].Number; ;} break; case 28: -#line 292 "../unix/../generic/tclGetDate.y" + { yyYear = yyvsp[0].Number / 10000; yyMonth = (yyvsp[0].Number % 10000)/100; yyDay = yyvsp[0].Number % 100; ;} break; case 29: -#line 297 "../unix/../generic/tclGetDate.y" + { yyDay = yyvsp[-4].Number; yyMonth = yyvsp[-2].Number; yyYear = yyvsp[0].Number; ;} break; case 30: -#line 302 "../unix/../generic/tclGetDate.y" + { yyMonth = yyvsp[-2].Number; yyDay = yyvsp[0].Number; yyYear = yyvsp[-4].Number; ;} break; case 31: -#line 307 "../unix/../generic/tclGetDate.y" + { yyMonth = yyvsp[-1].Number; yyDay = yyvsp[0].Number; ;} break; case 32: -#line 311 "../unix/../generic/tclGetDate.y" + { yyMonth = yyvsp[-3].Number; yyDay = yyvsp[-2].Number; yyYear = yyvsp[0].Number; ;} break; case 33: -#line 316 "../unix/../generic/tclGetDate.y" + { yyMonth = yyvsp[0].Number; yyDay = yyvsp[-1].Number; ;} break; case 34: -#line 320 "../unix/../generic/tclGetDate.y" + { yyMonth = 1; yyDay = 1; yyYear = EPOCH; ;} break; case 35: -#line 325 "../unix/../generic/tclGetDate.y" + { yyMonth = yyvsp[-1].Number; yyDay = yyvsp[-2].Number; yyYear = yyvsp[0].Number; ;} break; case 36: -#line 332 "../unix/../generic/tclGetDate.y" + { yyMonthOrdinal = 1; yyMonth = yyvsp[0].Number; ;} break; case 37: -#line 336 "../unix/../generic/tclGetDate.y" + { yyMonthOrdinal = yyvsp[-1].Number; yyMonth = yyvsp[0].Number; ;} break; case 38: -#line 342 "../unix/../generic/tclGetDate.y" + { if (yyvsp[-1].Number != HOUR(- 7)) YYABORT; yyYear = yyvsp[-2].Number / 10000; yyMonth = (yyvsp[-2].Number % 10000)/100; yyDay = yyvsp[-2].Number % 100; @@ -1516,11 +1520,11 @@ yySeconds = yyvsp[0].Number % 100; ;} break; case 39: -#line 351 "../unix/../generic/tclGetDate.y" + { if (yyvsp[-5].Number != HOUR(- 7)) YYABORT; yyYear = yyvsp[-6].Number / 10000; yyMonth = (yyvsp[-6].Number % 10000)/100; yyDay = yyvsp[-6].Number % 100; @@ -1529,11 +1533,11 @@ yySeconds = yyvsp[0].Number; ;} break; case 40: -#line 360 "../unix/../generic/tclGetDate.y" + { yyYear = yyvsp[-1].Number / 10000; yyMonth = (yyvsp[-1].Number % 10000)/100; yyDay = yyvsp[-1].Number % 100; yyHour = yyvsp[0].Number / 10000; @@ -1541,11 +1545,11 @@ yySeconds = yyvsp[0].Number % 100; ;} break; case 41: -#line 370 "../unix/../generic/tclGetDate.y" + { /* * Offset computed year by -377 so that the returned years will * be in a range accessible with a 32 bit clock seconds value */ @@ -1556,76 +1560,76 @@ yyRelSeconds += yyvsp[0].Number * 144 * 60; ;} break; case 42: -#line 383 "../unix/../generic/tclGetDate.y" + { yyRelSeconds *= -1; yyRelMonth *= -1; yyRelDay *= -1; ;} break; case 44: -#line 390 "../unix/../generic/tclGetDate.y" + { *yyRelPointer += yyvsp[-2].Number * yyvsp[-1].Number * yyvsp[0].Number; ;} break; case 45: -#line 391 "../unix/../generic/tclGetDate.y" + { *yyRelPointer += yyvsp[-1].Number * yyvsp[0].Number; ;} break; case 46: -#line 392 "../unix/../generic/tclGetDate.y" + { *yyRelPointer += yyvsp[0].Number; ;} break; case 47: -#line 393 "../unix/../generic/tclGetDate.y" + { *yyRelPointer += yyvsp[-1].Number * yyvsp[0].Number; ;} break; case 48: -#line 394 "../unix/../generic/tclGetDate.y" + { *yyRelPointer += yyvsp[0].Number; ;} break; case 49: -#line 396 "../unix/../generic/tclGetDate.y" + { yyval.Number = -1; ;} break; case 50: -#line 397 "../unix/../generic/tclGetDate.y" + { yyval.Number = 1; ;} break; case 51: -#line 399 "../unix/../generic/tclGetDate.y" + { yyval.Number = yyvsp[0].Number; yyRelPointer = &yyRelSeconds; ;} break; case 52: -#line 400 "../unix/../generic/tclGetDate.y" + { yyval.Number = yyvsp[0].Number; yyRelPointer = &yyRelDay; ;} break; case 53: -#line 401 "../unix/../generic/tclGetDate.y" + { yyval.Number = yyvsp[0].Number; yyRelPointer = &yyRelMonth; ;} break; case 54: -#line 405 "../unix/../generic/tclGetDate.y" + { if (yyHaveTime && yyHaveDate && !yyHaveRel) { yyYear = yyvsp[0].Number; } else { yyHaveTime++; - if (yyvsp[0].Number < 100) { + if (yyDigitCount <= 2) { yyHour = yyvsp[0].Number; yyMinutes = 0; } else { yyHour = yyvsp[0].Number / 100; yyMinutes = yyvsp[0].Number % 100; @@ -1635,28 +1639,28 @@ } ;} break; case 55: -#line 423 "../unix/../generic/tclGetDate.y" + { yyval.Meridian = MER24; ;} break; case 56: -#line 426 "../unix/../generic/tclGetDate.y" + { yyval.Meridian = yyvsp[0].Meridian; ;} break; } -/* Line 991 of yacc.c. */ -#line 1657 "../unix/../generic/tclDate.c" +/* Line 999 of yacc.c. */ + yyvsp -= yylen; yyssp -= yylen; @@ -1693,40 +1697,52 @@ if (YYPACT_NINF < yyn && yyn < YYLAST) { YYSIZE_T yysize = 0; int yytype = YYTRANSLATE (yychar); + const char* yyprefix; char *yymsg; - int yyx, yycount; + int yyx; - yycount = 0; /* Start YYX at -YYN if negative to avoid negative indexes in YYCHECK. */ - for (yyx = yyn < 0 ? -yyn : 0; - yyx < (int) (sizeof (yytname) / sizeof (char *)); yyx++) + int yyxbegin = yyn < 0 ? -yyn : 0; + + /* Stay within bounds of both yycheck and yytname. */ + int yychecklim = YYLAST - yyn; + int yyxend = yychecklim < YYNTOKENS ? yychecklim : YYNTOKENS; + int yycount = 0; + + yyprefix = ", expecting "; + for (yyx = yyxbegin; yyx < yyxend; ++yyx) if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR) - yysize += yystrlen (yytname[yyx]) + 15, yycount++; - yysize += yystrlen ("syntax error, unexpected ") + 1; - yysize += yystrlen (yytname[yytype]); + { + yysize += yystrlen (yyprefix) + yystrlen (yytname [yyx]); + yycount += 1; + if (yycount == 5) + { + yysize = 0; + break; + } + } + yysize += (sizeof ("syntax error, unexpected ") + + yystrlen (yytname[yytype])); yymsg = (char *) YYSTACK_ALLOC (yysize); if (yymsg != 0) { char *yyp = yystpcpy (yymsg, "syntax error, unexpected "); yyp = yystpcpy (yyp, yytname[yytype]); if (yycount < 5) { - yycount = 0; - for (yyx = yyn < 0 ? -yyn : 0; - yyx < (int) (sizeof (yytname) / sizeof (char *)); - yyx++) + yyprefix = ", expecting "; + for (yyx = yyxbegin; yyx < yyxend; ++yyx) if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR) { - const char *yyq = ! yycount ? ", expecting " : " or "; - yyp = yystpcpy (yyp, yyq); + yyp = yystpcpy (yyp, yyprefix); yyp = yystpcpy (yyp, yytname[yyx]); - yycount++; + yyprefix = " or "; } } yyerror (yymsg); YYSTACK_FREE (yymsg); } @@ -1766,34 +1782,17 @@ } /* Else will try to reuse lookahead token after shifting the error token. */ - goto yyerrlab2; + goto yyerrlab1; /*----------------------------------------------------. | yyerrlab1 -- error raised explicitly by an action. | `----------------------------------------------------*/ yyerrlab1: - - /* Suppress GCC warning that yyerrlab1 is unused when no action - invokes YYERROR. Doesn't work in C++ */ -#ifndef __cplusplus -#if defined (__GNUC_MINOR__) && 2093 <= (__GNUC__ * 1000 + __GNUC_MINOR__) - __attribute__ ((__unused__)) -#endif -#endif - - - goto yyerrlab2; - - -/*---------------------------------------------------------------. -| yyerrlab2 -- pop states until the error token can be shifted. | -`---------------------------------------------------------------*/ -yyerrlab2: yyerrstatus = 3; /* Each real token shifted decrements this. */ for (;;) { yyn = yypact[yystate]; @@ -1863,11 +1862,11 @@ #endif return yyresult; } -#line 431 "../unix/../generic/tclGetDate.y" + /* * Month and day table. */ @@ -2237,10 +2236,11 @@ isdigit(UCHAR(c = *yyInput++)); ) { /* INTL: digit */ yylval.Number = 10 * yylval.Number + c - '0'; Count++; } yyInput--; + yyDigitCount = Count; /* A number with 6 or more digits is considered an ISO 8601 base */ if (Count >= 6) { return tISOBASE; } else { return tUNUMBER; Index: generic/tclDecls.h ================================================================== --- generic/tclDecls.h +++ generic/tclDecls.h @@ -6,11 +6,11 @@ * Copyright (c) 1998-1999 by Scriptics Corporation. * * 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.107 2004/11/13 00:19:07 dgp Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.107.2.9 2005/09/20 14:11:51 dgp Exp $ */ #ifndef _TCLDECLS #define _TCLDECLS @@ -53,11 +53,11 @@ ClientData * clientDataPtr)); #endif #ifndef Tcl_Panic_TCL_DECLARED #define Tcl_Panic_TCL_DECLARED /* 2 */ -EXTERN void Tcl_Panic _ANSI_ARGS_(TCL_VARARGS(CONST char *,format)); +EXTERN void Tcl_Panic _ANSI_ARGS_((CONST char *format, ...)); #endif #ifndef Tcl_Alloc_TCL_DECLARED #define Tcl_Alloc_TCL_DECLARED /* 3 */ EXTERN char * Tcl_Alloc _ANSI_ARGS_((unsigned int size)); @@ -129,11 +129,11 @@ Tcl_Interp * interp, Tcl_Obj * objPtr)); #endif #ifndef Tcl_AppendStringsToObj_TCL_DECLARED #define Tcl_AppendStringsToObj_TCL_DECLARED /* 15 */ -EXTERN void Tcl_AppendStringsToObj _ANSI_ARGS_(TCL_VARARGS(Tcl_Obj *,objPtr)); +EXTERN void Tcl_AppendStringsToObj _ANSI_ARGS_((Tcl_Obj *objPtr, ...)); #endif #ifndef Tcl_AppendToObj_TCL_DECLARED #define Tcl_AppendToObj_TCL_DECLARED /* 16 */ EXTERN void Tcl_AppendToObj _ANSI_ARGS_((Tcl_Obj* objPtr, @@ -225,11 +225,11 @@ #endif #ifndef Tcl_GetBoolean_TCL_DECLARED #define Tcl_GetBoolean_TCL_DECLARED /* 31 */ EXTERN int Tcl_GetBoolean _ANSI_ARGS_((Tcl_Interp * interp, - CONST char * str, int * boolPtr)); + CONST char * src, int * boolPtr)); #endif #ifndef Tcl_GetBooleanFromObj_TCL_DECLARED #define Tcl_GetBooleanFromObj_TCL_DECLARED /* 32 */ EXTERN int Tcl_GetBooleanFromObj _ANSI_ARGS_(( @@ -244,11 +244,11 @@ #endif #ifndef Tcl_GetDouble_TCL_DECLARED #define Tcl_GetDouble_TCL_DECLARED /* 34 */ EXTERN int Tcl_GetDouble _ANSI_ARGS_((Tcl_Interp * interp, - CONST char * str, double * doublePtr)); + CONST char * src, double * doublePtr)); #endif #ifndef Tcl_GetDoubleFromObj_TCL_DECLARED #define Tcl_GetDoubleFromObj_TCL_DECLARED /* 35 */ EXTERN int Tcl_GetDoubleFromObj _ANSI_ARGS_(( @@ -264,11 +264,11 @@ #endif #ifndef Tcl_GetInt_TCL_DECLARED #define Tcl_GetInt_TCL_DECLARED /* 37 */ EXTERN int Tcl_GetInt _ANSI_ARGS_((Tcl_Interp * interp, - CONST char * str, int * intPtr)); + CONST char * src, int * intPtr)); #endif #ifndef Tcl_GetIntFromObj_TCL_DECLARED #define Tcl_GetIntFromObj_TCL_DECLARED /* 38 */ EXTERN int Tcl_GetIntFromObj _ANSI_ARGS_((Tcl_Interp * interp, @@ -454,16 +454,16 @@ #endif #ifndef Tcl_AppendElement_TCL_DECLARED #define Tcl_AppendElement_TCL_DECLARED /* 69 */ EXTERN void Tcl_AppendElement _ANSI_ARGS_((Tcl_Interp * interp, - CONST char * string)); + CONST char * element)); #endif #ifndef Tcl_AppendResult_TCL_DECLARED #define Tcl_AppendResult_TCL_DECLARED /* 70 */ -EXTERN void Tcl_AppendResult _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); +EXTERN void Tcl_AppendResult _ANSI_ARGS_((Tcl_Interp *interp, ...)); #endif #ifndef Tcl_AsyncCreate_TCL_DECLARED #define Tcl_AsyncCreate_TCL_DECLARED /* 71 */ EXTERN Tcl_AsyncHandler Tcl_AsyncCreate _ANSI_ARGS_((Tcl_AsyncProc * proc, @@ -770,17 +770,17 @@ #endif #ifndef Tcl_DStringAppend_TCL_DECLARED #define Tcl_DStringAppend_TCL_DECLARED /* 117 */ EXTERN char * Tcl_DStringAppend _ANSI_ARGS_((Tcl_DString * dsPtr, - CONST char * str, int length)); + CONST char * bytes, int length)); #endif #ifndef Tcl_DStringAppendElement_TCL_DECLARED #define Tcl_DStringAppendElement_TCL_DECLARED /* 118 */ EXTERN char * Tcl_DStringAppendElement _ANSI_ARGS_(( - Tcl_DString * dsPtr, CONST char * string)); + Tcl_DString * dsPtr, CONST char * element)); #endif #ifndef Tcl_DStringEndSublist_TCL_DECLARED #define Tcl_DStringEndSublist_TCL_DECLARED /* 119 */ EXTERN void Tcl_DStringEndSublist _ANSI_ARGS_(( @@ -837,11 +837,11 @@ #endif #ifndef Tcl_Eval_TCL_DECLARED #define Tcl_Eval_TCL_DECLARED /* 129 */ EXTERN int Tcl_Eval _ANSI_ARGS_((Tcl_Interp * interp, - CONST char * string)); + CONST char * script)); #endif #ifndef Tcl_EvalFile_TCL_DECLARED #define Tcl_EvalFile_TCL_DECLARED /* 130 */ EXTERN int Tcl_EvalFile _ANSI_ARGS_((Tcl_Interp * interp, @@ -874,11 +874,11 @@ #endif #ifndef Tcl_ExprBoolean_TCL_DECLARED #define Tcl_ExprBoolean_TCL_DECLARED /* 135 */ EXTERN int Tcl_ExprBoolean _ANSI_ARGS_((Tcl_Interp * interp, - CONST char * str, int * ptr)); + CONST char * expr, int * ptr)); #endif #ifndef Tcl_ExprBooleanObj_TCL_DECLARED #define Tcl_ExprBooleanObj_TCL_DECLARED /* 136 */ EXTERN int Tcl_ExprBooleanObj _ANSI_ARGS_((Tcl_Interp * interp, @@ -886,11 +886,11 @@ #endif #ifndef Tcl_ExprDouble_TCL_DECLARED #define Tcl_ExprDouble_TCL_DECLARED /* 137 */ EXTERN int Tcl_ExprDouble _ANSI_ARGS_((Tcl_Interp * interp, - CONST char * str, double * ptr)); + CONST char * expr, double * ptr)); #endif #ifndef Tcl_ExprDoubleObj_TCL_DECLARED #define Tcl_ExprDoubleObj_TCL_DECLARED /* 138 */ EXTERN int Tcl_ExprDoubleObj _ANSI_ARGS_((Tcl_Interp * interp, @@ -898,11 +898,11 @@ #endif #ifndef Tcl_ExprLong_TCL_DECLARED #define Tcl_ExprLong_TCL_DECLARED /* 139 */ EXTERN int Tcl_ExprLong _ANSI_ARGS_((Tcl_Interp * interp, - CONST char * str, long * ptr)); + CONST char * expr, long * ptr)); #endif #ifndef Tcl_ExprLongObj_TCL_DECLARED #define Tcl_ExprLongObj_TCL_DECLARED /* 140 */ EXTERN int Tcl_ExprLongObj _ANSI_ARGS_((Tcl_Interp * interp, @@ -916,11 +916,11 @@ #endif #ifndef Tcl_ExprString_TCL_DECLARED #define Tcl_ExprString_TCL_DECLARED /* 142 */ EXTERN int Tcl_ExprString _ANSI_ARGS_((Tcl_Interp * interp, - CONST char * string)); + CONST char * expr)); #endif #ifndef Tcl_Finalize_TCL_DECLARED #define Tcl_Finalize_TCL_DECLARED /* 143 */ EXTERN void Tcl_Finalize _ANSI_ARGS_((void)); @@ -1066,11 +1066,11 @@ #if !defined(__WIN32__) /* UNIX */ #ifndef Tcl_GetOpenFile_TCL_DECLARED #define Tcl_GetOpenFile_TCL_DECLARED /* 167 */ EXTERN int Tcl_GetOpenFile _ANSI_ARGS_((Tcl_Interp * interp, - CONST char * str, int forWriting, + CONST char * chanID, int forWriting, int checkUsage, ClientData * filePtr)); #endif #endif /* UNIX */ #ifndef Tcl_GetPathType_TCL_DECLARED #define Tcl_GetPathType_TCL_DECLARED @@ -1289,11 +1289,11 @@ double value, char * dst)); #endif #ifndef Tcl_PutEnv_TCL_DECLARED #define Tcl_PutEnv_TCL_DECLARED /* 203 */ -EXTERN int Tcl_PutEnv _ANSI_ARGS_((CONST char * string)); +EXTERN int Tcl_PutEnv _ANSI_ARGS_((CONST char * assignment)); #endif #ifndef Tcl_PosixError_TCL_DECLARED #define Tcl_PosixError_TCL_DECLARED /* 204 */ EXTERN CONST84_RETURN char * Tcl_PosixError _ANSI_ARGS_((Tcl_Interp * interp)); @@ -1351,24 +1351,24 @@ #endif #ifndef Tcl_RegExpCompile_TCL_DECLARED #define Tcl_RegExpCompile_TCL_DECLARED /* 212 */ EXTERN Tcl_RegExp Tcl_RegExpCompile _ANSI_ARGS_((Tcl_Interp * interp, - CONST char * string)); + CONST char * pattern)); #endif #ifndef Tcl_RegExpExec_TCL_DECLARED #define Tcl_RegExpExec_TCL_DECLARED /* 213 */ EXTERN int Tcl_RegExpExec _ANSI_ARGS_((Tcl_Interp * interp, - Tcl_RegExp regexp, CONST char * str, + Tcl_RegExp regexp, CONST char * text, CONST char * start)); #endif #ifndef Tcl_RegExpMatch_TCL_DECLARED #define Tcl_RegExpMatch_TCL_DECLARED /* 214 */ EXTERN int Tcl_RegExpMatch _ANSI_ARGS_((Tcl_Interp * interp, - CONST char * str, CONST char * pattern)); + CONST char * text, CONST char * pattern)); #endif #ifndef Tcl_RegExpRange_TCL_DECLARED #define Tcl_RegExpRange_TCL_DECLARED /* 215 */ EXTERN void Tcl_RegExpRange _ANSI_ARGS_((Tcl_RegExp regexp, @@ -1448,11 +1448,11 @@ EXTERN void Tcl_SetErrno _ANSI_ARGS_((int err)); #endif #ifndef Tcl_SetErrorCode_TCL_DECLARED #define Tcl_SetErrorCode_TCL_DECLARED /* 228 */ -EXTERN void Tcl_SetErrorCode _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); +EXTERN void Tcl_SetErrorCode _ANSI_ARGS_((Tcl_Interp *interp, ...)); #endif #ifndef Tcl_SetMaxBlockTime_TCL_DECLARED #define Tcl_SetMaxBlockTime_TCL_DECLARED /* 229 */ EXTERN void Tcl_SetMaxBlockTime _ANSI_ARGS_((Tcl_Time * timePtr)); @@ -1471,11 +1471,11 @@ #endif #ifndef Tcl_SetResult_TCL_DECLARED #define Tcl_SetResult_TCL_DECLARED /* 232 */ EXTERN void Tcl_SetResult _ANSI_ARGS_((Tcl_Interp * interp, - char * str, Tcl_FreeProc * freeProc)); + char * result, Tcl_FreeProc * freeProc)); #endif #ifndef Tcl_SetServiceMode_TCL_DECLARED #define Tcl_SetServiceMode_TCL_DECLARED /* 233 */ EXTERN int Tcl_SetServiceMode _ANSI_ARGS_((int mode)); @@ -1651,11 +1651,11 @@ int flags)); #endif #ifndef Tcl_VarEval_TCL_DECLARED #define Tcl_VarEval_TCL_DECLARED /* 260 */ -EXTERN int Tcl_VarEval _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); +EXTERN int Tcl_VarEval _ANSI_ARGS_((Tcl_Interp *interp, ...)); #endif #ifndef Tcl_VarTraceInfo_TCL_DECLARED #define Tcl_VarTraceInfo_TCL_DECLARED /* 261 */ EXTERN ClientData Tcl_VarTraceInfo _ANSI_ARGS_((Tcl_Interp * interp, @@ -1716,11 +1716,11 @@ #endif #ifndef Tcl_ParseVar_TCL_DECLARED #define Tcl_ParseVar_TCL_DECLARED /* 270 */ EXTERN CONST84_RETURN char * Tcl_ParseVar _ANSI_ARGS_((Tcl_Interp * interp, - CONST char * str, CONST84 char ** termPtr)); + CONST char * start, CONST84 char ** termPtr)); #endif #ifndef Tcl_PkgPresent_TCL_DECLARED #define Tcl_PkgPresent_TCL_DECLARED /* 271 */ EXTERN CONST84_RETURN char * Tcl_PkgPresent _ANSI_ARGS_((Tcl_Interp * interp, @@ -1968,11 +1968,11 @@ #endif #ifndef Tcl_NumUtfChars_TCL_DECLARED #define Tcl_NumUtfChars_TCL_DECLARED /* 312 */ EXTERN int Tcl_NumUtfChars _ANSI_ARGS_((CONST char * src, - int len)); + int length)); #endif #ifndef Tcl_ReadChars_TCL_DECLARED #define Tcl_ReadChars_TCL_DECLARED /* 313 */ EXTERN int Tcl_ReadChars _ANSI_ARGS_((Tcl_Channel channel, @@ -2050,11 +2050,11 @@ #endif #ifndef Tcl_UtfCharComplete_TCL_DECLARED #define Tcl_UtfCharComplete_TCL_DECLARED /* 326 */ EXTERN int Tcl_UtfCharComplete _ANSI_ARGS_((CONST char * src, - int len)); + int length)); #endif #ifndef Tcl_UtfBackslash_TCL_DECLARED #define Tcl_UtfBackslash_TCL_DECLARED /* 327 */ EXTERN int Tcl_UtfBackslash _ANSI_ARGS_((CONST char * src, @@ -2195,30 +2195,32 @@ EXTERN int Tcl_UniCharIsWordChar _ANSI_ARGS_((int ch)); #endif #ifndef Tcl_UniCharLen_TCL_DECLARED #define Tcl_UniCharLen_TCL_DECLARED /* 352 */ -EXTERN int Tcl_UniCharLen _ANSI_ARGS_((CONST Tcl_UniChar * str)); +EXTERN int Tcl_UniCharLen _ANSI_ARGS_(( + CONST Tcl_UniChar * uniStr)); #endif #ifndef Tcl_UniCharNcmp_TCL_DECLARED #define Tcl_UniCharNcmp_TCL_DECLARED /* 353 */ -EXTERN int Tcl_UniCharNcmp _ANSI_ARGS_((CONST Tcl_UniChar * cs, - CONST Tcl_UniChar * ct, unsigned long n)); +EXTERN int Tcl_UniCharNcmp _ANSI_ARGS_((CONST Tcl_UniChar * ucs, + CONST Tcl_UniChar * uct, + unsigned long numChars)); #endif #ifndef Tcl_UniCharToUtfDString_TCL_DECLARED #define Tcl_UniCharToUtfDString_TCL_DECLARED /* 354 */ EXTERN char * Tcl_UniCharToUtfDString _ANSI_ARGS_(( - CONST Tcl_UniChar * string, int numChars, + CONST Tcl_UniChar * uniStr, int uniLength, Tcl_DString * dsPtr)); #endif #ifndef Tcl_UtfToUniCharDString_TCL_DECLARED #define Tcl_UtfToUniCharDString_TCL_DECLARED /* 355 */ EXTERN Tcl_UniChar * Tcl_UtfToUniCharDString _ANSI_ARGS_(( - CONST char * string, int length, + CONST char * src, int length, Tcl_DString * dsPtr)); #endif #ifndef Tcl_GetRegExpFromObj_TCL_DECLARED #define Tcl_GetRegExpFromObj_TCL_DECLARED /* 356 */ @@ -2246,41 +2248,41 @@ #endif #ifndef Tcl_ParseBraces_TCL_DECLARED #define Tcl_ParseBraces_TCL_DECLARED /* 360 */ EXTERN int Tcl_ParseBraces _ANSI_ARGS_((Tcl_Interp * interp, - CONST char * string, int numBytes, + CONST char * start, int numBytes, Tcl_Parse * parsePtr, int append, CONST84 char ** termPtr)); #endif #ifndef Tcl_ParseCommand_TCL_DECLARED #define Tcl_ParseCommand_TCL_DECLARED /* 361 */ EXTERN int Tcl_ParseCommand _ANSI_ARGS_((Tcl_Interp * interp, - CONST char * string, int numBytes, - int nested, Tcl_Parse * parsePtr)); + CONST char * start, int numBytes, int nested, + Tcl_Parse * parsePtr)); #endif #ifndef Tcl_ParseExpr_TCL_DECLARED #define Tcl_ParseExpr_TCL_DECLARED /* 362 */ EXTERN int Tcl_ParseExpr _ANSI_ARGS_((Tcl_Interp * interp, - CONST char * string, int numBytes, + CONST char * start, int numBytes, Tcl_Parse * parsePtr)); #endif #ifndef Tcl_ParseQuotedString_TCL_DECLARED #define Tcl_ParseQuotedString_TCL_DECLARED /* 363 */ EXTERN int Tcl_ParseQuotedString _ANSI_ARGS_(( - Tcl_Interp * interp, CONST char * string, + Tcl_Interp * interp, CONST char * start, int numBytes, Tcl_Parse * parsePtr, int append, CONST84 char ** termPtr)); #endif #ifndef Tcl_ParseVarName_TCL_DECLARED #define Tcl_ParseVarName_TCL_DECLARED /* 364 */ EXTERN int Tcl_ParseVarName _ANSI_ARGS_((Tcl_Interp * interp, - CONST char * string, int numBytes, + CONST char * start, int numBytes, Tcl_Parse * parsePtr, int append)); #endif #ifndef Tcl_GetCwd_TCL_DECLARED #define Tcl_GetCwd_TCL_DECLARED /* 365 */ @@ -2343,11 +2345,11 @@ #endif #ifndef Tcl_RegExpExecObj_TCL_DECLARED #define Tcl_RegExpExecObj_TCL_DECLARED /* 376 */ EXTERN int Tcl_RegExpExecObj _ANSI_ARGS_((Tcl_Interp * interp, - Tcl_RegExp regexp, Tcl_Obj * objPtr, + Tcl_RegExp regexp, Tcl_Obj * textObj, int offset, int nmatches, int flags)); #endif #ifndef Tcl_RegExpGetInfo_TCL_DECLARED #define Tcl_RegExpGetInfo_TCL_DECLARED /* 377 */ @@ -2396,11 +2398,11 @@ #endif #ifndef Tcl_RegExpMatchObj_TCL_DECLARED #define Tcl_RegExpMatchObj_TCL_DECLARED /* 385 */ EXTERN int Tcl_RegExpMatchObj _ANSI_ARGS_((Tcl_Interp * interp, - Tcl_Obj * stringObj, Tcl_Obj * patternObj)); + Tcl_Obj * textObj, Tcl_Obj * patternObj)); #endif #ifndef Tcl_SetNotifier_TCL_DECLARED #define Tcl_SetNotifier_TCL_DECLARED /* 386 */ EXTERN void Tcl_SetNotifier _ANSI_ARGS_(( @@ -2595,19 +2597,20 @@ #endif #ifndef Tcl_UniCharNcasecmp_TCL_DECLARED #define Tcl_UniCharNcasecmp_TCL_DECLARED /* 419 */ EXTERN int Tcl_UniCharNcasecmp _ANSI_ARGS_(( - CONST Tcl_UniChar * cs, - CONST Tcl_UniChar * ct, unsigned long n)); + CONST Tcl_UniChar * ucs, + CONST Tcl_UniChar * uct, + unsigned long numChars)); #endif #ifndef Tcl_UniCharCaseMatch_TCL_DECLARED #define Tcl_UniCharCaseMatch_TCL_DECLARED /* 420 */ EXTERN int Tcl_UniCharCaseMatch _ANSI_ARGS_(( - CONST Tcl_UniChar * ustr, - CONST Tcl_UniChar * pattern, int nocase)); + CONST Tcl_UniChar * uniStr, + CONST Tcl_UniChar * uniPattern, int nocase)); #endif #ifndef Tcl_FindHashEntry_TCL_DECLARED #define Tcl_FindHashEntry_TCL_DECLARED /* 421 */ EXTERN Tcl_HashEntry * Tcl_FindHashEntry _ANSI_ARGS_(( @@ -3353,10 +3356,179 @@ #define Tcl_GetReturnOptions_TCL_DECLARED /* 539 */ EXTERN Tcl_Obj * Tcl_GetReturnOptions _ANSI_ARGS_(( Tcl_Interp * interp, int result)); #endif +#ifndef Tcl_IsEnsemble_TCL_DECLARED +#define Tcl_IsEnsemble_TCL_DECLARED +/* 540 */ +EXTERN int Tcl_IsEnsemble _ANSI_ARGS_((Tcl_Command token)); +#endif +#ifndef Tcl_CreateEnsemble_TCL_DECLARED +#define Tcl_CreateEnsemble_TCL_DECLARED +/* 541 */ +EXTERN Tcl_Command Tcl_CreateEnsemble _ANSI_ARGS_((Tcl_Interp * interp, + CONST char * name, + Tcl_Namespace * namespacePtr, int flags)); +#endif +#ifndef Tcl_FindEnsemble_TCL_DECLARED +#define Tcl_FindEnsemble_TCL_DECLARED +/* 542 */ +EXTERN Tcl_Command Tcl_FindEnsemble _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_Obj * cmdNameObj, int flags)); +#endif +#ifndef Tcl_SetEnsembleSubcommandList_TCL_DECLARED +#define Tcl_SetEnsembleSubcommandList_TCL_DECLARED +/* 543 */ +EXTERN int Tcl_SetEnsembleSubcommandList _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Command token, + Tcl_Obj * subcmdList)); +#endif +#ifndef Tcl_SetEnsembleMappingDict_TCL_DECLARED +#define Tcl_SetEnsembleMappingDict_TCL_DECLARED +/* 544 */ +EXTERN int Tcl_SetEnsembleMappingDict _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Command token, + Tcl_Obj * mapDict)); +#endif +#ifndef Tcl_SetEnsembleUnknownHandler_TCL_DECLARED +#define Tcl_SetEnsembleUnknownHandler_TCL_DECLARED +/* 545 */ +EXTERN int Tcl_SetEnsembleUnknownHandler _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Command token, + Tcl_Obj * unknownList)); +#endif +#ifndef Tcl_SetEnsembleFlags_TCL_DECLARED +#define Tcl_SetEnsembleFlags_TCL_DECLARED +/* 546 */ +EXTERN int Tcl_SetEnsembleFlags _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Command token, + int flags)); +#endif +#ifndef Tcl_GetEnsembleSubcommandList_TCL_DECLARED +#define Tcl_GetEnsembleSubcommandList_TCL_DECLARED +/* 547 */ +EXTERN int Tcl_GetEnsembleSubcommandList _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Command token, + Tcl_Obj ** subcmdListPtr)); +#endif +#ifndef Tcl_GetEnsembleMappingDict_TCL_DECLARED +#define Tcl_GetEnsembleMappingDict_TCL_DECLARED +/* 548 */ +EXTERN int Tcl_GetEnsembleMappingDict _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Command token, + Tcl_Obj ** mapDictPtr)); +#endif +#ifndef Tcl_GetEnsembleUnknownHandler_TCL_DECLARED +#define Tcl_GetEnsembleUnknownHandler_TCL_DECLARED +/* 549 */ +EXTERN int Tcl_GetEnsembleUnknownHandler _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Command token, + Tcl_Obj ** unknownListPtr)); +#endif +#ifndef Tcl_GetEnsembleFlags_TCL_DECLARED +#define Tcl_GetEnsembleFlags_TCL_DECLARED +/* 550 */ +EXTERN int Tcl_GetEnsembleFlags _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Command token, + int * flagsPtr)); +#endif +#ifndef Tcl_GetEnsembleNamespace_TCL_DECLARED +#define Tcl_GetEnsembleNamespace_TCL_DECLARED +/* 551 */ +EXTERN int Tcl_GetEnsembleNamespace _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Command token, + Tcl_Namespace ** namespacePtrPtr)); +#endif +#ifndef Tcl_SetTimeProc_TCL_DECLARED +#define Tcl_SetTimeProc_TCL_DECLARED +/* 552 */ +EXTERN void Tcl_SetTimeProc _ANSI_ARGS_(( + Tcl_GetTimeProc* getProc, + Tcl_ScaleTimeProc* scaleProc, + ClientData clientData)); +#endif +#ifndef Tcl_QueryTimeProc_TCL_DECLARED +#define Tcl_QueryTimeProc_TCL_DECLARED +/* 553 */ +EXTERN void Tcl_QueryTimeProc _ANSI_ARGS_(( + Tcl_GetTimeProc** getProc, + Tcl_ScaleTimeProc** scaleProc, + ClientData* clientData)); +#endif +#ifndef Tcl_ChannelThreadActionProc_TCL_DECLARED +#define Tcl_ChannelThreadActionProc_TCL_DECLARED +/* 554 */ +EXTERN Tcl_DriverThreadActionProc * Tcl_ChannelThreadActionProc _ANSI_ARGS_(( + Tcl_ChannelType * chanTypePtr)); +#endif +#ifndef Tcl_NewBignumObj_TCL_DECLARED +#define Tcl_NewBignumObj_TCL_DECLARED +/* 555 */ +EXTERN Tcl_Obj* Tcl_NewBignumObj _ANSI_ARGS_((mp_int* value)); +#endif +#ifndef Tcl_DbNewBignumObj_TCL_DECLARED +#define Tcl_DbNewBignumObj_TCL_DECLARED +/* 556 */ +EXTERN Tcl_Obj* Tcl_DbNewBignumObj _ANSI_ARGS_((mp_int* value, + CONST char* file, int line)); +#endif +#ifndef Tcl_SetBignumObj_TCL_DECLARED +#define Tcl_SetBignumObj_TCL_DECLARED +/* 557 */ +EXTERN void Tcl_SetBignumObj _ANSI_ARGS_((Tcl_Obj* obj, + mp_int* value)); +#endif +#ifndef Tcl_GetBignumFromObj_TCL_DECLARED +#define Tcl_GetBignumFromObj_TCL_DECLARED +/* 558 */ +EXTERN int Tcl_GetBignumFromObj _ANSI_ARGS_((Tcl_Interp* interp, + Tcl_Obj* obj, mp_int* value)); +#endif +#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 +/* 560 */ +EXTERN int Tcl_TruncateChannel _ANSI_ARGS_((Tcl_Channel chan, + Tcl_WideInt length)); +#endif +#ifndef Tcl_ChannelTruncateProc_TCL_DECLARED +#define Tcl_ChannelTruncateProc_TCL_DECLARED +/* 561 */ +EXTERN Tcl_DriverTruncateProc * Tcl_ChannelTruncateProc _ANSI_ARGS_(( + Tcl_ChannelType * chanTypePtr)); +#endif +#ifndef Tcl_SetChannelErrorInterp_TCL_DECLARED +#define Tcl_SetChannelErrorInterp_TCL_DECLARED +/* 562 */ +EXTERN void Tcl_SetChannelErrorInterp _ANSI_ARGS_(( + Tcl_Interp* interp, Tcl_Obj* msg)); +#endif +#ifndef Tcl_GetChannelErrorInterp_TCL_DECLARED +#define Tcl_GetChannelErrorInterp_TCL_DECLARED +/* 563 */ +EXTERN void Tcl_GetChannelErrorInterp _ANSI_ARGS_(( + Tcl_Interp* interp, Tcl_Obj** msg)); +#endif +#ifndef Tcl_SetChannelError_TCL_DECLARED +#define Tcl_SetChannelError_TCL_DECLARED +/* 564 */ +EXTERN void Tcl_SetChannelError _ANSI_ARGS_((Tcl_Channel chan, + Tcl_Obj* msg)); +#endif +#ifndef Tcl_GetChannelError_TCL_DECLARED +#define Tcl_GetChannelError_TCL_DECLARED +/* 565 */ +EXTERN void Tcl_GetChannelError _ANSI_ARGS_((Tcl_Channel chan, + Tcl_Obj** msg)); +#endif typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; struct TclIntStubs *tclIntStubs; struct TclIntPlatStubs *tclIntPlatStubs; @@ -3366,11 +3538,11 @@ int magic; struct TclStubHooks *hooks; int (*tcl_PkgProvideEx) _ANSI_ARGS_((Tcl_Interp* interp, CONST char* name, CONST char* version, ClientData clientData)); /* 0 */ CONST84_RETURN char * (*tcl_PkgRequireEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact, ClientData * clientDataPtr)); /* 1 */ - void (*tcl_Panic) _ANSI_ARGS_(TCL_VARARGS(CONST char *,format)); /* 2 */ + void (*tcl_Panic) _ANSI_ARGS_((CONST char *format, ...)); /* 2 */ char * (*tcl_Alloc) _ANSI_ARGS_((unsigned int size)); /* 3 */ void (*tcl_Free) _ANSI_ARGS_((char * ptr)); /* 4 */ char * (*tcl_Realloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 5 */ char * (*tcl_DbCkalloc) _ANSI_ARGS_((unsigned int size, CONST char * file, int line)); /* 6 */ int (*tcl_DbCkfree) _ANSI_ARGS_((char * ptr, CONST char * file, int line)); /* 7 */ @@ -3389,11 +3561,11 @@ #endif /* __WIN32__ */ void (*tcl_SetTimer) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 11 */ void (*tcl_Sleep) _ANSI_ARGS_((int ms)); /* 12 */ int (*tcl_WaitForEvent) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 13 */ int (*tcl_AppendAllObjTypes) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 14 */ - void (*tcl_AppendStringsToObj) _ANSI_ARGS_(TCL_VARARGS(Tcl_Obj *,objPtr)); /* 15 */ + void (*tcl_AppendStringsToObj) _ANSI_ARGS_((Tcl_Obj *objPtr, ...)); /* 15 */ void (*tcl_AppendToObj) _ANSI_ARGS_((Tcl_Obj* objPtr, CONST char* bytes, int length)); /* 16 */ Tcl_Obj * (*tcl_ConcatObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[])); /* 17 */ int (*tcl_ConvertToType) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_ObjType * typePtr)); /* 18 */ void (*tcl_DbDecrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 19 */ void (*tcl_DbIncrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 20 */ @@ -3405,17 +3577,17 @@ Tcl_Obj * (*tcl_DbNewLongObj) _ANSI_ARGS_((long longValue, CONST char * file, int line)); /* 26 */ Tcl_Obj * (*tcl_DbNewObj) _ANSI_ARGS_((CONST char * file, int line)); /* 27 */ Tcl_Obj * (*tcl_DbNewStringObj) _ANSI_ARGS_((CONST char * bytes, int length, CONST char * file, int line)); /* 28 */ Tcl_Obj * (*tcl_DuplicateObj) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 29 */ void (*tclFreeObj) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 30 */ - int (*tcl_GetBoolean) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * boolPtr)); /* 31 */ + int (*tcl_GetBoolean) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * src, int * boolPtr)); /* 31 */ int (*tcl_GetBooleanFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * boolPtr)); /* 32 */ unsigned char * (*tcl_GetByteArrayFromObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int * lengthPtr)); /* 33 */ - int (*tcl_GetDouble) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, double * doublePtr)); /* 34 */ + int (*tcl_GetDouble) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * src, double * doublePtr)); /* 34 */ int (*tcl_GetDoubleFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, double * doublePtr)); /* 35 */ int (*tcl_GetIndexFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CONST84 char ** tablePtr, CONST char * msg, int flags, int * indexPtr)); /* 36 */ - int (*tcl_GetInt) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * intPtr)); /* 37 */ + int (*tcl_GetInt) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * src, int * intPtr)); /* 37 */ int (*tcl_GetIntFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * intPtr)); /* 38 */ int (*tcl_GetLongFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * longPtr)); /* 39 */ Tcl_ObjType * (*tcl_GetObjType) _ANSI_ARGS_((CONST char * typeName)); /* 40 */ char * (*tcl_GetStringFromObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int * lengthPtr)); /* 41 */ void (*tcl_InvalidateStringRep) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 42 */ @@ -3443,12 +3615,12 @@ void (*tcl_SetObjLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 64 */ void (*tcl_SetStringObj) _ANSI_ARGS_((Tcl_Obj* objPtr, CONST char* bytes, int length)); /* 65 */ void (*tcl_AddErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message)); /* 66 */ void (*tcl_AddObjErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message, int length)); /* 67 */ void (*tcl_AllowExceptions) _ANSI_ARGS_((Tcl_Interp * interp)); /* 68 */ - void (*tcl_AppendElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 69 */ - void (*tcl_AppendResult) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 70 */ + void (*tcl_AppendElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * element)); /* 69 */ + void (*tcl_AppendResult) _ANSI_ARGS_((Tcl_Interp *interp, ...)); /* 70 */ Tcl_AsyncHandler (*tcl_AsyncCreate) _ANSI_ARGS_((Tcl_AsyncProc * proc, ClientData clientData)); /* 71 */ void (*tcl_AsyncDelete) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 72 */ int (*tcl_AsyncInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int code)); /* 73 */ void (*tcl_AsyncMark) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 74 */ int (*tcl_AsyncReady) _ANSI_ARGS_((void)); /* 75 */ @@ -3496,12 +3668,12 @@ void (*tcl_DeleteTimerHandler) _ANSI_ARGS_((Tcl_TimerToken token)); /* 112 */ void (*tcl_DeleteTrace) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Trace trace)); /* 113 */ void (*tcl_DontCallWhenDeleted) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 114 */ int (*tcl_DoOneEvent) _ANSI_ARGS_((int flags)); /* 115 */ void (*tcl_DoWhenIdle) _ANSI_ARGS_((Tcl_IdleProc * proc, ClientData clientData)); /* 116 */ - char * (*tcl_DStringAppend) _ANSI_ARGS_((Tcl_DString * dsPtr, CONST char * str, int length)); /* 117 */ - char * (*tcl_DStringAppendElement) _ANSI_ARGS_((Tcl_DString * dsPtr, CONST char * string)); /* 118 */ + char * (*tcl_DStringAppend) _ANSI_ARGS_((Tcl_DString * dsPtr, CONST char * bytes, int length)); /* 117 */ + char * (*tcl_DStringAppendElement) _ANSI_ARGS_((Tcl_DString * dsPtr, CONST char * element)); /* 118 */ void (*tcl_DStringEndSublist) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 119 */ void (*tcl_DStringFree) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 120 */ void (*tcl_DStringGetResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * dsPtr)); /* 121 */ void (*tcl_DStringInit) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 122 */ void (*tcl_DStringResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * dsPtr)); /* 123 */ @@ -3508,24 +3680,24 @@ void (*tcl_DStringSetLength) _ANSI_ARGS_((Tcl_DString * dsPtr, int length)); /* 124 */ void (*tcl_DStringStartSublist) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 125 */ int (*tcl_Eof) _ANSI_ARGS_((Tcl_Channel chan)); /* 126 */ CONST84_RETURN char * (*tcl_ErrnoId) _ANSI_ARGS_((void)); /* 127 */ CONST84_RETURN char * (*tcl_ErrnoMsg) _ANSI_ARGS_((int err)); /* 128 */ - int (*tcl_Eval) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 129 */ + int (*tcl_Eval) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * script)); /* 129 */ int (*tcl_EvalFile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * fileName)); /* 130 */ int (*tcl_EvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 131 */ void (*tcl_EventuallyFree) _ANSI_ARGS_((ClientData clientData, Tcl_FreeProc * freeProc)); /* 132 */ void (*tcl_Exit) _ANSI_ARGS_((int status)); /* 133 */ int (*tcl_ExposeCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * hiddenCmdToken, CONST char * cmdName)); /* 134 */ - int (*tcl_ExprBoolean) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * ptr)); /* 135 */ + int (*tcl_ExprBoolean) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * expr, int * ptr)); /* 135 */ int (*tcl_ExprBooleanObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * ptr)); /* 136 */ - int (*tcl_ExprDouble) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, double * ptr)); /* 137 */ + int (*tcl_ExprDouble) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * expr, double * ptr)); /* 137 */ int (*tcl_ExprDoubleObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, double * ptr)); /* 138 */ - int (*tcl_ExprLong) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, long * ptr)); /* 139 */ + int (*tcl_ExprLong) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * expr, long * ptr)); /* 139 */ int (*tcl_ExprLongObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * ptr)); /* 140 */ int (*tcl_ExprObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_Obj ** resultPtrPtr)); /* 141 */ - int (*tcl_ExprString) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 142 */ + int (*tcl_ExprString) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * expr)); /* 142 */ void (*tcl_Finalize) _ANSI_ARGS_((void)); /* 143 */ void (*tcl_FindExecutable) _ANSI_ARGS_((CONST char * argv0)); /* 144 */ Tcl_HashEntry * (*tcl_FirstHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, Tcl_HashSearch * searchPtr)); /* 145 */ int (*tcl_Flush) _ANSI_ARGS_((Tcl_Channel chan)); /* 146 */ void (*tcl_FreeResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 147 */ @@ -3547,11 +3719,11 @@ int (*tcl_GetInterpPath) _ANSI_ARGS_((Tcl_Interp * askInterp, Tcl_Interp * slaveInterp)); /* 163 */ Tcl_Interp * (*tcl_GetMaster) _ANSI_ARGS_((Tcl_Interp * interp)); /* 164 */ CONST char * (*tcl_GetNameOfExecutable) _ANSI_ARGS_((void)); /* 165 */ Tcl_Obj * (*tcl_GetObjResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 166 */ #if !defined(__WIN32__) /* UNIX */ - int (*tcl_GetOpenFile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int forWriting, int checkUsage, ClientData * filePtr)); /* 167 */ + int (*tcl_GetOpenFile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * chanID, int forWriting, int checkUsage, ClientData * filePtr)); /* 167 */ #endif /* UNIX */ #ifdef __WIN32__ void *reserved167; #endif /* __WIN32__ */ Tcl_PathType (*tcl_GetPathType) _ANSI_ARGS_((CONST char * path)); /* 168 */ @@ -3592,11 +3764,11 @@ Tcl_Channel (*tcl_OpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * fileName, CONST char * modeString, int permissions)); /* 198 */ Tcl_Channel (*tcl_OpenTcpClient) _ANSI_ARGS_((Tcl_Interp * interp, int port, CONST char * address, CONST char * myaddr, int myport, int async)); /* 199 */ Tcl_Channel (*tcl_OpenTcpServer) _ANSI_ARGS_((Tcl_Interp * interp, int port, CONST char * host, Tcl_TcpAcceptProc * acceptProc, ClientData callbackData)); /* 200 */ void (*tcl_Preserve) _ANSI_ARGS_((ClientData data)); /* 201 */ void (*tcl_PrintDouble) _ANSI_ARGS_((Tcl_Interp * interp, double value, char * dst)); /* 202 */ - int (*tcl_PutEnv) _ANSI_ARGS_((CONST char * string)); /* 203 */ + int (*tcl_PutEnv) _ANSI_ARGS_((CONST char * assignment)); /* 203 */ CONST84_RETURN char * (*tcl_PosixError) _ANSI_ARGS_((Tcl_Interp * interp)); /* 204 */ void (*tcl_QueueEvent) _ANSI_ARGS_((Tcl_Event * evPtr, Tcl_QueuePosition position)); /* 205 */ int (*tcl_Read) _ANSI_ARGS_((Tcl_Channel chan, char * bufPtr, int toRead)); /* 206 */ #if !defined(__WIN32__) /* UNIX */ void (*tcl_ReapDetachedProcs) _ANSI_ARGS_((void)); /* 207 */ @@ -3606,13 +3778,13 @@ #endif /* __WIN32__ */ int (*tcl_RecordAndEval) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmd, int flags)); /* 208 */ int (*tcl_RecordAndEvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * cmdPtr, int flags)); /* 209 */ void (*tcl_RegisterChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 210 */ void (*tcl_RegisterObjType) _ANSI_ARGS_((Tcl_ObjType * typePtr)); /* 211 */ - Tcl_RegExp (*tcl_RegExpCompile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 212 */ - int (*tcl_RegExpExec) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp regexp, CONST char * str, CONST char * start)); /* 213 */ - int (*tcl_RegExpMatch) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, CONST char * pattern)); /* 214 */ + Tcl_RegExp (*tcl_RegExpCompile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * pattern)); /* 212 */ + int (*tcl_RegExpExec) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp regexp, CONST char * text, CONST char * start)); /* 213 */ + int (*tcl_RegExpMatch) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * text, CONST char * pattern)); /* 214 */ void (*tcl_RegExpRange) _ANSI_ARGS_((Tcl_RegExp regexp, int index, CONST84 char ** startPtr, CONST84 char ** endPtr)); /* 215 */ void (*tcl_Release) _ANSI_ARGS_((ClientData clientData)); /* 216 */ void (*tcl_ResetResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 217 */ int (*tcl_ScanElement) _ANSI_ARGS_((CONST char * str, int * flagPtr)); /* 218 */ int (*tcl_ScanCountedElement) _ANSI_ARGS_((CONST char * str, int length, int * flagPtr)); /* 219 */ @@ -3622,15 +3794,15 @@ void (*tcl_SetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 223 */ void (*tcl_SetChannelBufferSize) _ANSI_ARGS_((Tcl_Channel chan, int sz)); /* 224 */ int (*tcl_SetChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, CONST char * optionName, CONST char * newValue)); /* 225 */ int (*tcl_SetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, CONST Tcl_CmdInfo * infoPtr)); /* 226 */ void (*tcl_SetErrno) _ANSI_ARGS_((int err)); /* 227 */ - void (*tcl_SetErrorCode) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 228 */ + void (*tcl_SetErrorCode) _ANSI_ARGS_((Tcl_Interp *interp, ...)); /* 228 */ void (*tcl_SetMaxBlockTime) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 229 */ void (*tcl_SetPanicProc) _ANSI_ARGS_((Tcl_PanicProc * panicProc)); /* 230 */ int (*tcl_SetRecursionLimit) _ANSI_ARGS_((Tcl_Interp * interp, int depth)); /* 231 */ - void (*tcl_SetResult) _ANSI_ARGS_((Tcl_Interp * interp, char * str, Tcl_FreeProc * freeProc)); /* 232 */ + void (*tcl_SetResult) _ANSI_ARGS_((Tcl_Interp * interp, char * result, Tcl_FreeProc * freeProc)); /* 232 */ int (*tcl_SetServiceMode) _ANSI_ARGS_((int mode)); /* 233 */ void (*tcl_SetObjErrorCode) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * errorObjPtr)); /* 234 */ void (*tcl_SetObjResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * resultObjPtr)); /* 235 */ void (*tcl_SetStdChannel) _ANSI_ARGS_((Tcl_Channel channel, int type)); /* 236 */ CONST84_RETURN char * (*tcl_SetVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, CONST char * newValue, int flags)); /* 237 */ @@ -3654,21 +3826,21 @@ void (*tcl_UntraceVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 255 */ void (*tcl_UntraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 256 */ void (*tcl_UpdateLinkedVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName)); /* 257 */ int (*tcl_UpVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * varName, CONST char * localName, int flags)); /* 258 */ int (*tcl_UpVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * part1, CONST char * part2, CONST char * localName, int flags)); /* 259 */ - int (*tcl_VarEval) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 260 */ + int (*tcl_VarEval) _ANSI_ARGS_((Tcl_Interp *interp, ...)); /* 260 */ ClientData (*tcl_VarTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 261 */ ClientData (*tcl_VarTraceInfo2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 262 */ int (*tcl_Write) _ANSI_ARGS_((Tcl_Channel chan, CONST char * s, int slen)); /* 263 */ void (*tcl_WrongNumArgs) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], CONST char * message)); /* 264 */ int (*tcl_DumpActiveMemory) _ANSI_ARGS_((CONST char * fileName)); /* 265 */ void (*tcl_ValidateAllMemory) _ANSI_ARGS_((CONST char * file, int line)); /* 266 */ void (*tcl_AppendResultVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 267 */ void (*tcl_AppendStringsToObjVA) _ANSI_ARGS_((Tcl_Obj * objPtr, va_list argList)); /* 268 */ CONST84_RETURN char * (*tcl_HashStats) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 269 */ - CONST84_RETURN char * (*tcl_ParseVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, CONST84 char ** termPtr)); /* 270 */ + CONST84_RETURN char * (*tcl_ParseVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * start, CONST84 char ** termPtr)); /* 270 */ CONST84_RETURN char * (*tcl_PkgPresent) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact)); /* 271 */ CONST84_RETURN char * (*tcl_PkgPresentEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact, ClientData * clientDataPtr)); /* 272 */ int (*tcl_PkgProvide) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version)); /* 273 */ CONST84_RETURN char * (*tcl_PkgRequire) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact)); /* 274 */ void (*tcl_SetErrorCodeVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 275 */ @@ -3706,11 +3878,11 @@ ClientData (*tcl_InitNotifier) _ANSI_ARGS_((void)); /* 307 */ void (*tcl_MutexLock) _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); /* 308 */ void (*tcl_MutexUnlock) _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); /* 309 */ void (*tcl_ConditionNotify) _ANSI_ARGS_((Tcl_Condition * condPtr)); /* 310 */ void (*tcl_ConditionWait) _ANSI_ARGS_((Tcl_Condition * condPtr, Tcl_Mutex * mutexPtr, Tcl_Time * timePtr)); /* 311 */ - int (*tcl_NumUtfChars) _ANSI_ARGS_((CONST char * src, int len)); /* 312 */ + int (*tcl_NumUtfChars) _ANSI_ARGS_((CONST char * src, int length)); /* 312 */ int (*tcl_ReadChars) _ANSI_ARGS_((Tcl_Channel channel, Tcl_Obj * objPtr, int charsToRead, int appendFlag)); /* 313 */ void (*tcl_RestoreResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_SavedResult * statePtr)); /* 314 */ void (*tcl_SaveResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_SavedResult * statePtr)); /* 315 */ int (*tcl_SetSystemEncoding) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 316 */ Tcl_Obj * (*tcl_SetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, Tcl_Obj * newValuePtr, int flags)); /* 317 */ @@ -3720,11 +3892,11 @@ Tcl_UniChar (*tcl_UniCharToLower) _ANSI_ARGS_((int ch)); /* 321 */ Tcl_UniChar (*tcl_UniCharToTitle) _ANSI_ARGS_((int ch)); /* 322 */ Tcl_UniChar (*tcl_UniCharToUpper) _ANSI_ARGS_((int ch)); /* 323 */ int (*tcl_UniCharToUtf) _ANSI_ARGS_((int ch, char * buf)); /* 324 */ CONST84_RETURN char * (*tcl_UtfAtIndex) _ANSI_ARGS_((CONST char * src, int index)); /* 325 */ - int (*tcl_UtfCharComplete) _ANSI_ARGS_((CONST char * src, int len)); /* 326 */ + int (*tcl_UtfCharComplete) _ANSI_ARGS_((CONST char * src, int length)); /* 326 */ int (*tcl_UtfBackslash) _ANSI_ARGS_((CONST char * src, int * readPtr, char * dst)); /* 327 */ CONST84_RETURN char * (*tcl_UtfFindFirst) _ANSI_ARGS_((CONST char * src, int ch)); /* 328 */ CONST84_RETURN char * (*tcl_UtfFindLast) _ANSI_ARGS_((CONST char * src, int ch)); /* 329 */ CONST84_RETURN char * (*tcl_UtfNext) _ANSI_ARGS_((CONST char * src)); /* 330 */ CONST84_RETURN char * (*tcl_UtfPrev) _ANSI_ARGS_((CONST char * src, CONST char * start)); /* 331 */ @@ -3746,23 +3918,23 @@ int (*tcl_UniCharIsDigit) _ANSI_ARGS_((int ch)); /* 347 */ int (*tcl_UniCharIsLower) _ANSI_ARGS_((int ch)); /* 348 */ int (*tcl_UniCharIsSpace) _ANSI_ARGS_((int ch)); /* 349 */ int (*tcl_UniCharIsUpper) _ANSI_ARGS_((int ch)); /* 350 */ int (*tcl_UniCharIsWordChar) _ANSI_ARGS_((int ch)); /* 351 */ - int (*tcl_UniCharLen) _ANSI_ARGS_((CONST Tcl_UniChar * str)); /* 352 */ - int (*tcl_UniCharNcmp) _ANSI_ARGS_((CONST Tcl_UniChar * cs, CONST Tcl_UniChar * ct, unsigned long n)); /* 353 */ - char * (*tcl_UniCharToUtfDString) _ANSI_ARGS_((CONST Tcl_UniChar * string, int numChars, Tcl_DString * dsPtr)); /* 354 */ - Tcl_UniChar * (*tcl_UtfToUniCharDString) _ANSI_ARGS_((CONST char * string, int length, Tcl_DString * dsPtr)); /* 355 */ + int (*tcl_UniCharLen) _ANSI_ARGS_((CONST Tcl_UniChar * uniStr)); /* 352 */ + int (*tcl_UniCharNcmp) _ANSI_ARGS_((CONST Tcl_UniChar * ucs, CONST Tcl_UniChar * uct, unsigned long numChars)); /* 353 */ + char * (*tcl_UniCharToUtfDString) _ANSI_ARGS_((CONST Tcl_UniChar * uniStr, int uniLength, Tcl_DString * dsPtr)); /* 354 */ + Tcl_UniChar * (*tcl_UtfToUniCharDString) _ANSI_ARGS_((CONST char * src, int length, Tcl_DString * dsPtr)); /* 355 */ Tcl_RegExp (*tcl_GetRegExpFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * patObj, int flags)); /* 356 */ Tcl_Obj * (*tcl_EvalTokens) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Token * tokenPtr, int count)); /* 357 */ void (*tcl_FreeParse) _ANSI_ARGS_((Tcl_Parse * parsePtr)); /* 358 */ void (*tcl_LogCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * script, CONST char * command, int length)); /* 359 */ - int (*tcl_ParseBraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr, int append, CONST84 char ** termPtr)); /* 360 */ - int (*tcl_ParseCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, int nested, Tcl_Parse * parsePtr)); /* 361 */ - int (*tcl_ParseExpr) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr)); /* 362 */ - int (*tcl_ParseQuotedString) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr, int append, CONST84 char ** termPtr)); /* 363 */ - int (*tcl_ParseVarName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr, int append)); /* 364 */ + int (*tcl_ParseBraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * start, int numBytes, Tcl_Parse * parsePtr, int append, CONST84 char ** termPtr)); /* 360 */ + int (*tcl_ParseCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * start, int numBytes, int nested, Tcl_Parse * parsePtr)); /* 361 */ + int (*tcl_ParseExpr) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * start, int numBytes, Tcl_Parse * parsePtr)); /* 362 */ + int (*tcl_ParseQuotedString) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * start, int numBytes, Tcl_Parse * parsePtr, int append, CONST84 char ** termPtr)); /* 363 */ + int (*tcl_ParseVarName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * start, int numBytes, Tcl_Parse * parsePtr, int append)); /* 364 */ char * (*tcl_GetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 365 */ int (*tcl_Chdir) _ANSI_ARGS_((CONST char * dirName)); /* 366 */ int (*tcl_Access) _ANSI_ARGS_((CONST char * path, int mode)); /* 367 */ int (*tcl_Stat) _ANSI_ARGS_((CONST char * path, struct stat * bufPtr)); /* 368 */ int (*tcl_UtfNcmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); /* 369 */ @@ -3770,20 +3942,20 @@ int (*tcl_StringCaseMatch) _ANSI_ARGS_((CONST char * str, CONST char * pattern, int nocase)); /* 371 */ int (*tcl_UniCharIsControl) _ANSI_ARGS_((int ch)); /* 372 */ int (*tcl_UniCharIsGraph) _ANSI_ARGS_((int ch)); /* 373 */ int (*tcl_UniCharIsPrint) _ANSI_ARGS_((int ch)); /* 374 */ int (*tcl_UniCharIsPunct) _ANSI_ARGS_((int ch)); /* 375 */ - int (*tcl_RegExpExecObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp regexp, Tcl_Obj * objPtr, int offset, int nmatches, int flags)); /* 376 */ + int (*tcl_RegExpExecObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp regexp, Tcl_Obj * textObj, int offset, int nmatches, int flags)); /* 376 */ void (*tcl_RegExpGetInfo) _ANSI_ARGS_((Tcl_RegExp regexp, Tcl_RegExpInfo * infoPtr)); /* 377 */ Tcl_Obj * (*tcl_NewUnicodeObj) _ANSI_ARGS_((CONST Tcl_UniChar * unicode, int numChars)); /* 378 */ void (*tcl_SetUnicodeObj) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST Tcl_UniChar * unicode, int numChars)); /* 379 */ int (*tcl_GetCharLength) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 380 */ Tcl_UniChar (*tcl_GetUniChar) _ANSI_ARGS_((Tcl_Obj * objPtr, int index)); /* 381 */ Tcl_UniChar * (*tcl_GetUnicode) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 382 */ Tcl_Obj * (*tcl_GetRange) _ANSI_ARGS_((Tcl_Obj * objPtr, int first, int last)); /* 383 */ void (*tcl_AppendUnicodeToObj) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST Tcl_UniChar * unicode, int length)); /* 384 */ - int (*tcl_RegExpMatchObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * stringObj, Tcl_Obj * patternObj)); /* 385 */ + int (*tcl_RegExpMatchObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * textObj, Tcl_Obj * patternObj)); /* 385 */ void (*tcl_SetNotifier) _ANSI_ARGS_((Tcl_NotifierProcs * notifierProcPtr)); /* 386 */ Tcl_Mutex * (*tcl_GetAllocMutex) _ANSI_ARGS_((void)); /* 387 */ int (*tcl_GetChannelNames) _ANSI_ARGS_((Tcl_Interp * interp)); /* 388 */ int (*tcl_GetChannelNamesEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * pattern)); /* 389 */ int (*tcl_ProcObjCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 390 */ @@ -3813,12 +3985,12 @@ int (*tcl_IsChannelRegistered) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Channel channel)); /* 414 */ void (*tcl_CutChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 415 */ void (*tcl_SpliceChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 416 */ void (*tcl_ClearChannelHandlers) _ANSI_ARGS_((Tcl_Channel channel)); /* 417 */ int (*tcl_IsChannelExisting) _ANSI_ARGS_((CONST char* channelName)); /* 418 */ - int (*tcl_UniCharNcasecmp) _ANSI_ARGS_((CONST Tcl_UniChar * cs, CONST Tcl_UniChar * ct, unsigned long n)); /* 419 */ - int (*tcl_UniCharCaseMatch) _ANSI_ARGS_((CONST Tcl_UniChar * ustr, CONST Tcl_UniChar * pattern, int nocase)); /* 420 */ + int (*tcl_UniCharNcasecmp) _ANSI_ARGS_((CONST Tcl_UniChar * ucs, CONST Tcl_UniChar * uct, unsigned long numChars)); /* 419 */ + int (*tcl_UniCharCaseMatch) _ANSI_ARGS_((CONST Tcl_UniChar * uniStr, CONST Tcl_UniChar * uniPattern, int nocase)); /* 420 */ Tcl_HashEntry * (*tcl_FindHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, CONST char * key)); /* 421 */ Tcl_HashEntry * (*tcl_CreateHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, CONST char * key, int * newPtr)); /* 422 */ void (*tcl_InitCustomHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr, int keyType, Tcl_HashKeyType * typePtr)); /* 423 */ void (*tcl_InitObjHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 424 */ ClientData (*tcl_CommandTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_CommandTraceProc * procPtr, ClientData prevClientData)); /* 425 */ @@ -3934,10 +4106,36 @@ Tcl_InterpState (*tcl_SaveInterpState) _ANSI_ARGS_((Tcl_Interp * interp, int status)); /* 535 */ int (*tcl_RestoreInterpState) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_InterpState state)); /* 536 */ void (*tcl_DiscardInterpState) _ANSI_ARGS_((Tcl_InterpState state)); /* 537 */ int (*tcl_SetReturnOptions) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * options)); /* 538 */ Tcl_Obj * (*tcl_GetReturnOptions) _ANSI_ARGS_((Tcl_Interp * interp, int result)); /* 539 */ + int (*tcl_IsEnsemble) _ANSI_ARGS_((Tcl_Command token)); /* 540 */ + Tcl_Command (*tcl_CreateEnsemble) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * namespacePtr, int flags)); /* 541 */ + Tcl_Command (*tcl_FindEnsemble) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * cmdNameObj, int flags)); /* 542 */ + int (*tcl_SetEnsembleSubcommandList) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, Tcl_Obj * subcmdList)); /* 543 */ + int (*tcl_SetEnsembleMappingDict) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, Tcl_Obj * mapDict)); /* 544 */ + int (*tcl_SetEnsembleUnknownHandler) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, Tcl_Obj * unknownList)); /* 545 */ + int (*tcl_SetEnsembleFlags) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, int flags)); /* 546 */ + int (*tcl_GetEnsembleSubcommandList) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, Tcl_Obj ** subcmdListPtr)); /* 547 */ + int (*tcl_GetEnsembleMappingDict) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, Tcl_Obj ** mapDictPtr)); /* 548 */ + int (*tcl_GetEnsembleUnknownHandler) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, Tcl_Obj ** unknownListPtr)); /* 549 */ + int (*tcl_GetEnsembleFlags) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, int * flagsPtr)); /* 550 */ + int (*tcl_GetEnsembleNamespace) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, Tcl_Namespace ** namespacePtrPtr)); /* 551 */ + void (*tcl_SetTimeProc) _ANSI_ARGS_((Tcl_GetTimeProc* getProc, Tcl_ScaleTimeProc* scaleProc, ClientData clientData)); /* 552 */ + void (*tcl_QueryTimeProc) _ANSI_ARGS_((Tcl_GetTimeProc** getProc, Tcl_ScaleTimeProc** scaleProc, ClientData* clientData)); /* 553 */ + Tcl_DriverThreadActionProc * (*tcl_ChannelThreadActionProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 554 */ + Tcl_Obj* (*tcl_NewBignumObj) _ANSI_ARGS_((mp_int* value)); /* 555 */ + Tcl_Obj* (*tcl_DbNewBignumObj) _ANSI_ARGS_((mp_int* value, CONST char* file, int line)); /* 556 */ + void (*tcl_SetBignumObj) _ANSI_ARGS_((Tcl_Obj* obj, mp_int* value)); /* 557 */ + int (*tcl_GetBignumFromObj) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value)); /* 558 */ + 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 extern "C" { #endif @@ -6134,10 +6332,114 @@ #endif #ifndef Tcl_GetReturnOptions #define Tcl_GetReturnOptions \ (tclStubsPtr->tcl_GetReturnOptions) /* 539 */ #endif +#ifndef Tcl_IsEnsemble +#define Tcl_IsEnsemble \ + (tclStubsPtr->tcl_IsEnsemble) /* 540 */ +#endif +#ifndef Tcl_CreateEnsemble +#define Tcl_CreateEnsemble \ + (tclStubsPtr->tcl_CreateEnsemble) /* 541 */ +#endif +#ifndef Tcl_FindEnsemble +#define Tcl_FindEnsemble \ + (tclStubsPtr->tcl_FindEnsemble) /* 542 */ +#endif +#ifndef Tcl_SetEnsembleSubcommandList +#define Tcl_SetEnsembleSubcommandList \ + (tclStubsPtr->tcl_SetEnsembleSubcommandList) /* 543 */ +#endif +#ifndef Tcl_SetEnsembleMappingDict +#define Tcl_SetEnsembleMappingDict \ + (tclStubsPtr->tcl_SetEnsembleMappingDict) /* 544 */ +#endif +#ifndef Tcl_SetEnsembleUnknownHandler +#define Tcl_SetEnsembleUnknownHandler \ + (tclStubsPtr->tcl_SetEnsembleUnknownHandler) /* 545 */ +#endif +#ifndef Tcl_SetEnsembleFlags +#define Tcl_SetEnsembleFlags \ + (tclStubsPtr->tcl_SetEnsembleFlags) /* 546 */ +#endif +#ifndef Tcl_GetEnsembleSubcommandList +#define Tcl_GetEnsembleSubcommandList \ + (tclStubsPtr->tcl_GetEnsembleSubcommandList) /* 547 */ +#endif +#ifndef Tcl_GetEnsembleMappingDict +#define Tcl_GetEnsembleMappingDict \ + (tclStubsPtr->tcl_GetEnsembleMappingDict) /* 548 */ +#endif +#ifndef Tcl_GetEnsembleUnknownHandler +#define Tcl_GetEnsembleUnknownHandler \ + (tclStubsPtr->tcl_GetEnsembleUnknownHandler) /* 549 */ +#endif +#ifndef Tcl_GetEnsembleFlags +#define Tcl_GetEnsembleFlags \ + (tclStubsPtr->tcl_GetEnsembleFlags) /* 550 */ +#endif +#ifndef Tcl_GetEnsembleNamespace +#define Tcl_GetEnsembleNamespace \ + (tclStubsPtr->tcl_GetEnsembleNamespace) /* 551 */ +#endif +#ifndef Tcl_SetTimeProc +#define Tcl_SetTimeProc \ + (tclStubsPtr->tcl_SetTimeProc) /* 552 */ +#endif +#ifndef Tcl_QueryTimeProc +#define Tcl_QueryTimeProc \ + (tclStubsPtr->tcl_QueryTimeProc) /* 553 */ +#endif +#ifndef Tcl_ChannelThreadActionProc +#define Tcl_ChannelThreadActionProc \ + (tclStubsPtr->tcl_ChannelThreadActionProc) /* 554 */ +#endif +#ifndef Tcl_NewBignumObj +#define Tcl_NewBignumObj \ + (tclStubsPtr->tcl_NewBignumObj) /* 555 */ +#endif +#ifndef Tcl_DbNewBignumObj +#define Tcl_DbNewBignumObj \ + (tclStubsPtr->tcl_DbNewBignumObj) /* 556 */ +#endif +#ifndef Tcl_SetBignumObj +#define Tcl_SetBignumObj \ + (tclStubsPtr->tcl_SetBignumObj) /* 557 */ +#endif +#ifndef Tcl_GetBignumFromObj +#define Tcl_GetBignumFromObj \ + (tclStubsPtr->tcl_GetBignumFromObj) /* 558 */ +#endif +#ifndef Tcl_GetBignumAndClearObj +#define Tcl_GetBignumAndClearObj \ + (tclStubsPtr->tcl_GetBignumAndClearObj) /* 559 */ +#endif +#ifndef Tcl_TruncateChannel +#define Tcl_TruncateChannel \ + (tclStubsPtr->tcl_TruncateChannel) /* 560 */ +#endif +#ifndef Tcl_ChannelTruncateProc +#define Tcl_ChannelTruncateProc \ + (tclStubsPtr->tcl_ChannelTruncateProc) /* 561 */ +#endif +#ifndef Tcl_SetChannelErrorInterp +#define Tcl_SetChannelErrorInterp \ + (tclStubsPtr->tcl_SetChannelErrorInterp) /* 562 */ +#endif +#ifndef Tcl_GetChannelErrorInterp +#define Tcl_GetChannelErrorInterp \ + (tclStubsPtr->tcl_GetChannelErrorInterp) /* 563 */ +#endif +#ifndef Tcl_SetChannelError +#define Tcl_SetChannelError \ + (tclStubsPtr->tcl_SetChannelError) /* 564 */ +#endif +#ifndef Tcl_GetChannelError +#define Tcl_GetChannelError \ + (tclStubsPtr->tcl_GetChannelError) /* 565 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ /* !END!: Do not edit above this line. */ Index: generic/tclDictObj.c ================================================================== --- generic/tclDictObj.c +++ generic/tclDictObj.c @@ -7,47 +7,21 @@ * Copyright (c) 2002 by Donal K. Fellows. * * 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.27 2004/11/13 00:19:09 dgp Exp $ + * RCS: @(#) $Id: tclDictObj.c,v 1.27.2.5 2005/09/15 20:58:39 dgp Exp $ */ #include "tclInt.h" +#include "tommath.h" /* * Forward declaration. */ struct Dict; -/* - * Flag values for TraceDictPath(). - * - * DICT_PATH_READ indicates that all entries on the path must exist - * but no updates will be needed. - * - * DICT_PATH_UPDATE indicates that we are going to be doing an update - * at the tip of the path, so duplication of shared objects should be - * done along the way. - * - * DICT_PATH_EXISTS indicates that we are performing an existance test - * and a lookup failure should therefore not be an error. If (and - * only if) this flag is set, TraceDictPath() will return the special - * value DICT_PATH_NON_EXISTENT if the path is not traceable. - * - * DICT_PATH_CREATE (which also requires the DICT_PATH_UPDATE bit to - * be set) indicates that we are to create non-existant dictionaries - * on the path. - */ - -#define DICT_PATH_READ 0 -#define DICT_PATH_UPDATE 1 -#define DICT_PATH_EXISTS 2 -#define DICT_PATH_CREATE 5 - -#define DICT_PATH_NON_EXISTENT ((Tcl_Obj *) (void *) 1) - /* * Prototypes for procedures defined later in this file: */ static void DeleteDict _ANSI_ARGS_((struct Dict *dict)); @@ -93,13 +67,10 @@ Tcl_Obj *copyPtr)); static void FreeDictInternalRep _ANSI_ARGS_((Tcl_Obj *dictPtr)); static void InvalidateDictChain _ANSI_ARGS_((Tcl_Obj *dictObj)); static int SetDictFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); -static Tcl_Obj * TraceDictPath _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *rootPtr, int keyc, Tcl_Obj *CONST keyv[], - int flags)); static void UpdateStringOfDict _ANSI_ARGS_((Tcl_Obj *dictPtr)); /* * Internal representation of a dictionary. * @@ -586,11 +557,11 @@ } /* *---------------------------------------------------------------------- * - * TraceDictPath -- + * TclTraceDictPath -- * * Trace through a tree of dictionaries using the array of keys * given. If the flags argument has the DICT_PATH_UPDATE flag is * set, a backward-pointing chain of dictionaries is also built * (in the Dict's chain field) and the chained dictionaries are @@ -617,12 +588,12 @@ * dictionary, resulting in the path being built. * *---------------------------------------------------------------------- */ -static Tcl_Obj * -TraceDictPath(interp, dictPtr, keyc, keyv, flags) +Tcl_Obj * +TclTraceDictPath(interp, dictPtr, keyc, keyv, flags) Tcl_Interp *interp; Tcl_Obj *dictPtr, *CONST keyv[]; int keyc, flags; { Dict *dict, *newDict; @@ -695,12 +666,12 @@ *---------------------------------------------------------------------- * * InvalidateDictChain -- * * Go through a dictionary chain (built by an updating invokation - * of TraceDictPath) and invalidate the string representations of - * all the dictionaries on the chain. + * of TclTraceDictPath) and invalidate the string representations + * of all the dictionaries on the chain. * * Results: * None * * Side effects: @@ -1133,11 +1104,11 @@ } if (keyc < 1) { Tcl_Panic("Tcl_DictObjPutKeyList called with empty key list"); } - dictPtr = TraceDictPath(interp, dictPtr, keyc-1, keyv, DICT_PATH_CREATE); + dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_CREATE); if (dictPtr == NULL) { return TCL_ERROR; } dict = (Dict *) dictPtr->internalRep.otherValuePtr; @@ -1189,11 +1160,11 @@ } if (keyc < 1) { Tcl_Panic("Tcl_DictObjRemoveKeyList called with empty key list"); } - dictPtr = TraceDictPath(interp, dictPtr, keyc-1, keyv, DICT_PATH_UPDATE); + dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_UPDATE); if (dictPtr == NULL) { return TCL_ERROR; } dict = (Dict *) dictPtr->internalRep.otherValuePtr; @@ -1424,11 +1395,11 @@ * we looked up (in case the value was not the last one and we are * going through a chain of searches.) Note that this loop always * executes at least once. */ - dictPtr = TraceDictPath(interp, objv[2], objc-4, objv+3, DICT_PATH_READ); + dictPtr = TclTraceDictPath(interp, objv[2], objc-4,objv+3, DICT_PATH_READ); if (dictPtr == NULL) { return TCL_ERROR; } result = Tcl_DictObjGet(interp, dictPtr, objv[objc-1], &valuePtr); if (result != TCL_OK) { @@ -1669,18 +1640,27 @@ } if (objc == 4) { pattern = TclGetString(objv[3]); } listPtr = Tcl_NewListObj(0, NULL); + if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { + Tcl_Obj *valuePtr = NULL; + Tcl_DictObjGet(interp, objv[2], objv[3], &valuePtr); + if (valuePtr != NULL) { + Tcl_ListObjAppendElement(interp, listPtr, objv[3]); + } + goto searchDone; + } for (; !done ; Tcl_DictObjNext(&search, &keyPtr, NULL, &done)) { if (pattern==NULL || Tcl_StringMatch(TclGetString(keyPtr), pattern)) { /* * Assume this operation always succeeds. */ Tcl_ListObjAppendElement(interp, listPtr, keyPtr); } } +searchDone: Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* @@ -1804,11 +1784,12 @@ if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "dictionary key ?key ...?"); return TCL_ERROR; } - dictPtr = TraceDictPath(interp, objv[2], objc-4, objv+3, DICT_PATH_EXISTS); + dictPtr = TclTraceDictPath(interp, objv[2], objc-4, objv+3, + DICT_PATH_EXISTS); if (dictPtr == NULL) { return TCL_ERROR; } if (dictPtr == DICT_PATH_NON_EXISTENT) { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); @@ -1891,21 +1872,27 @@ DictIncrCmd(interp, objc, objv) Tcl_Interp *interp; 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; } else if (objv[4]->typePtr == &tclWideIntType) { wideIncrValue = objv[4]->internalRep.wideValue; @@ -2058,10 +2045,71 @@ if (resultPtr == NULL) { return TCL_ERROR; } 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 } /* *---------------------------------------------------------------------- * @@ -2245,11 +2293,11 @@ DictForCmd(interp, objc, objv) Tcl_Interp *interp; int objc; Tcl_Obj *CONST *objv; { - Tcl_Obj *dictObj, *scriptObj, *keyVarObj, *valueVarObj; + Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj; Tcl_Obj **varv, *keyObj, *valueObj; Tcl_DictSearch search; int varc, done, result; if (objc != 5) { @@ -2266,27 +2314,21 @@ "must have exactly two variable names", -1)); return TCL_ERROR; } keyVarObj = varv[0]; valueVarObj = varv[1]; - dictObj = objv[3]; scriptObj = objv[4]; /* - * Make sure that these objects (which we need throughout the body - * of the loop) don't vanish. Note that we also care that the - * dictObj remains a dictionary, which requires slightly more - * elaborate precautions. That we achieve by making sure that the - * type is static throughout and that the hash is the same hash - * throughout; taking a copy of the whole thing would be easier, - * but much less efficient. + * Make sure that these objects (which we need throughout the body of the + * loop) don't vanish. Note that the dictionary internal rep is locked + * internally so that updates, shimmering, etc are not a problem. */ Tcl_IncrRefCount(keyVarObj); Tcl_IncrRefCount(valueVarObj); - Tcl_IncrRefCount(dictObj); Tcl_IncrRefCount(scriptObj); - result = Tcl_DictObjFirst(interp, dictObj, + result = Tcl_DictObjFirst(interp, objv[3], &search, &keyObj, &valueObj, &done); if (result != TCL_OK) { goto doneFor; } @@ -2318,15 +2360,12 @@ result = TCL_OK; } else if (result != TCL_OK) { if (result == TCL_BREAK) { result = TCL_OK; } else if (result == TCL_ERROR) { - char msg[32 + TCL_INTEGER_SPACE]; - - sprintf(msg, "\n (\"dict for\" body line %d)", - interp->errorLine); - Tcl_AddObjErrorInfo(interp, msg, -1); + TclFormatToErrorInfo(interp, + "\n (\"dict for\" body line %d)", interp->errorLine); } break; } Tcl_DictObjNext(&search, &keyObj, &valueObj, &done); @@ -2336,11 +2375,10 @@ /* * Stop holding a reference to these objects. */ TclDecrRefCount(keyVarObj); TclDecrRefCount(valueVarObj); - TclDecrRefCount(dictObj); TclDecrRefCount(scriptObj); Tcl_DictObjDone(&search); if (result == TCL_OK) { Tcl_ResetResult(interp); @@ -2497,16 +2535,15 @@ "key", "script", "value", NULL }; enum FilterTypes { FILTER_KEYS, FILTER_SCRIPT, FILTER_VALUES }; - Tcl_Obj *dictObj, *scriptObj, *keyVarObj, *valueVarObj; + Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj; Tcl_Obj **varv, *keyObj, *valueObj, *resultObj, *boolObj; Tcl_DictSearch search; int index, varc, done, result, satisfied; char *pattern; - char msg[32 + TCL_INTEGER_SPACE]; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "dictionary filterType ..."); return TCL_ERROR; } @@ -2529,15 +2566,22 @@ &keyObj, &valueObj, &done) != TCL_OK) { return TCL_ERROR; } pattern = TclGetString(objv[4]); resultObj = Tcl_NewDictObj(); - while (!done) { - if (Tcl_StringMatch(TclGetString(keyObj), pattern)) { - Tcl_DictObjPut(interp, resultObj, keyObj, valueObj); + if (TclMatchIsTrivial(pattern)) { + Tcl_DictObjGet(interp, objv[2], objv[4], &valueObj); + if (valueObj != NULL) { + Tcl_DictObjPut(interp, resultObj, objv[4], valueObj); } - Tcl_DictObjNext(&search, &keyObj, &valueObj, &done); + } else { + while (!done) { + if (Tcl_StringMatch(TclGetString(keyObj), pattern)) { + Tcl_DictObjPut(interp, resultObj, keyObj, valueObj); + } + Tcl_DictObjNext(&search, &keyObj, &valueObj, &done); + } } Tcl_SetObjResult(interp, resultObj); return TCL_OK; case FILTER_VALUES: @@ -2586,32 +2630,26 @@ "must have exactly two variable names", -1)); return TCL_ERROR; } keyVarObj = varv[0]; valueVarObj = varv[1]; - dictObj = objv[2]; scriptObj = objv[5]; /* - * Make sure that these objects (which we need throughout the - * body of the loop) don't vanish. Note that we also care - * that the dictObj remains a dictionary, which requires - * slightly more elaborate precautions. That we achieve by - * making sure that the type is static throughout and that the - * hash is the same hash throughout; taking a copy of the - * whole thing would be easier, but much less efficient. + * Make sure that these objects (which we need throughout the body of + * the loop) don't vanish. Note that the dictionary internal rep is + * locked internally so that updates, shimmering, etc are not a + * problem. */ Tcl_IncrRefCount(keyVarObj); Tcl_IncrRefCount(valueVarObj); - Tcl_IncrRefCount(dictObj); Tcl_IncrRefCount(scriptObj); - result = Tcl_DictObjFirst(interp, dictObj, + result = Tcl_DictObjFirst(interp, objv[2], &search, &keyObj, &valueObj, &done); if (result != TCL_OK) { TclDecrRefCount(keyVarObj); TclDecrRefCount(valueVarObj); - TclDecrRefCount(dictObj); TclDecrRefCount(scriptObj); return TCL_ERROR; } resultObj = Tcl_NewDictObj(); @@ -2653,26 +2691,26 @@ } TclDecrRefCount(boolObj); if (satisfied) { Tcl_DictObjPut(interp, resultObj, keyObj, valueObj); } - case TCL_CONTINUE: - result = TCL_OK; break; case TCL_BREAK: /* - * Force loop termination. Has to be done with a jump - * so we remove references to the dictionary correctly. + * Force loop termination by calling Tcl_DictObjDone; this + * makes the next Tcl_DictObjNext say there is nothing more to + * do. */ Tcl_ResetResult(interp); Tcl_DictObjDone(&search); + case TCL_CONTINUE: result = TCL_OK; break; case TCL_ERROR: - sprintf(msg, "\n (\"dict filter\" script line %d)", + TclFormatToErrorInfo(interp, + "\n (\"dict filter\" script line %d)", interp->errorLine); - Tcl_AddObjErrorInfo(interp, msg, -1); default: goto abnormalResult; } TclDecrRefCount(keyObj); @@ -2684,35 +2722,32 @@ /* * Stop holding a reference to these objects. */ TclDecrRefCount(keyVarObj); TclDecrRefCount(valueVarObj); - TclDecrRefCount(dictObj); TclDecrRefCount(scriptObj); Tcl_DictObjDone(&search); if (result == TCL_OK) { Tcl_SetObjResult(interp, resultObj); } else { TclDecrRefCount(resultObj); } return result; + abnormalResult: + Tcl_DictObjDone(&search); + TclDecrRefCount(keyObj); + TclDecrRefCount(valueObj); + TclDecrRefCount(keyVarObj); + TclDecrRefCount(valueVarObj); + TclDecrRefCount(scriptObj); + TclDecrRefCount(resultObj); + return result; } Tcl_Panic("unexpected fallthrough"); /* Control never reaches this point. */ return TCL_ERROR; - - abnormalResult: - Tcl_DictObjDone(&search); - TclDecrRefCount(keyObj); - TclDecrRefCount(valueObj); - TclDecrRefCount(keyVarObj); - TclDecrRefCount(valueVarObj); - TclDecrRefCount(dictObj); - TclDecrRefCount(scriptObj); - TclDecrRefCount(resultObj); - return result; } /* *---------------------------------------------------------------------- * @@ -2877,11 +2912,11 @@ dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, TCL_LEAVE_ERR_MSG); if (dictPtr == NULL) { return TCL_ERROR; } if (objc > 4) { - dictPtr = TraceDictPath(interp, dictPtr, objc-4, objv+3, + dictPtr = TclTraceDictPath(interp, dictPtr, objc-4, objv+3, DICT_PATH_READ); if (dictPtr == NULL) { return TCL_ERROR; } } @@ -2896,25 +2931,22 @@ if (Tcl_DictObjFirst(interp, dictPtr, &s, &keyPtr, &valPtr, &done) != TCL_OK) { return TCL_ERROR; } - Tcl_IncrRefCount(dictPtr); TclNewObj(keysPtr); Tcl_IncrRefCount(keysPtr); for (; !done ; Tcl_DictObjNext(&s, &keyPtr, &valPtr, &done)) { Tcl_ListObjAppendElement(NULL, keysPtr, keyPtr); if (Tcl_ObjSetVar2(interp, keyPtr, NULL, valPtr, TCL_LEAVE_ERR_MSG) == NULL) { - TclDecrRefCount(dictPtr); TclDecrRefCount(keysPtr); Tcl_DictObjDone(&s); return TCL_ERROR; } } - TclDecrRefCount(dictPtr); /* * Execute the body. */ @@ -2958,11 +2990,11 @@ * that the same as a non-existant variable. Luckily, the * de-sharing operation isn't deeply damaging if we don't go * on to update; it's just less than perfectly efficient (but * no memory should be leaked). */ - leafPtr = TraceDictPath(interp, dictPtr, objc-4, objv+3, + leafPtr = TclTraceDictPath(interp, dictPtr, objc-4, objv+3, DICT_PATH_EXISTS | DICT_PATH_UPDATE); if (leafPtr == NULL) { TclDecrRefCount(keysPtr); if (allocdict) { TclDecrRefCount(dictPtr); Index: generic/tclEncoding.c ================================================================== --- generic/tclEncoding.c +++ generic/tclEncoding.c @@ -6,20 +6,20 @@ * Copyright (c) 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclEncoding.c,v 1.29 2004/12/01 23:18:50 dgp Exp $ + * RCS: @(#) $Id: tclEncoding.c,v 1.29.2.6 2005/09/09 18:48:40 dgp Exp $ */ #include "tclInt.h" typedef size_t (LengthProc)_ANSI_ARGS_((CONST char *src)); /* - * The following data structure represents an encoding, which describes how - * to convert between various character sets and UTF-8. + * The following data structure represents an encoding, which describes how to + * convert between various character sets and UTF-8. */ typedef struct Encoding { char *name; /* Name of encoding. Malloced because (1) * hash table entry that owns this encoding @@ -26,12 +26,12 @@ * may be freed prior to this encoding being * freed, (2) string passed in the * Tcl_EncodingType structure may not be * persistent. */ Tcl_EncodingConvertProc *toUtfProc; - /* Procedure to convert from external - * encoding into UTF-8. */ + /* Procedure to convert from external encoding + * into UTF-8. */ Tcl_EncodingConvertProc *fromUtfProc; /* Procedure to convert from UTF-8 into * external encoding. */ Tcl_EncodingFreeProc *freeProc; /* If non-NULL, procedure to call when this @@ -59,23 +59,24 @@ * Unicode and a single-byte, double-byte, or multibyte (1 or 2 bytes only) * encoding. */ typedef struct TableEncodingData { - int fallback; /* Character (in this encoding) to - * substitute when this encoding cannot - * represent a UTF-8 character. */ + int fallback; /* Character (in this encoding) to substitute + * when this encoding cannot represent a UTF-8 + * character. */ char prefixBytes[256]; /* If a byte in the input stream is a lead * byte for a 2-byte sequence, the * corresponding entry in this array is 1, * otherwise it is 0. */ unsigned short **toUnicode; /* Two dimensional sparse matrix to map * characters from the encoding to Unicode. * Each element of the toUnicode array points * to an array of 256 shorts. If there is no * corresponding character in Unicode, the - * value in the matrix is 0x0000. malloc'd. */ + * value in the matrix is 0x0000. + * malloc'd. */ unsigned short **fromUnicode; /* Two dimensional sparse matrix to map * characters from Unicode to the encoding. * Each element of the fromUnicode array * points to an array of 256 shorts. If there @@ -84,15 +85,15 @@ * malloc'd. */ } TableEncodingData; /* * The following structures is the clientData for a dynamically-loaded, - * escape-driven encoding that is itself comprised of other simpler - * encodings. An example is "iso-2022-jp", which uses escape sequences to - * switch between ascii, jis0208, jis0212, gb2312, and ksc5601. Note that - * "escape-driven" does not necessarily mean that the ESCAPE character is - * the character used for switching character sets. + * escape-driven encoding that is itself comprised of other simpler encodings. + * An example is "iso-2022-jp", which uses escape sequences to switch between + * ascii, jis0208, jis0212, gb2312, and ksc5601. Note that "escape-driven" + * does not necessarily mean that the ESCAPE character is the character used + * for switching character sets. */ typedef struct EscapeSubTable { unsigned int sequenceLen; /* Length of following string. */ char sequence[16]; /* Escape code that marks this encoding. */ @@ -101,29 +102,29 @@ * if this sub-encoding has not been needed * yet. */ } EscapeSubTable; typedef struct EscapeEncodingData { - int fallback; /* Character (in this encoding) to - * substitute when this encoding cannot - * represent a UTF-8 character. */ + int fallback; /* Character (in this encoding) to substitute + * when this encoding cannot represent a UTF-8 + * character. */ unsigned int initLen; /* Length of following string. */ char init[16]; /* String to emit or expect before first char * in conversion. */ unsigned int finalLen; /* Length of following string. */ - char final[16]; /* String to emit or expect after last char - * in conversion. */ - char prefixBytes[256]; /* If a byte in the input stream is the - * first character of one of the escape - * sequences in the following array, the - * corresponding entry in this array is 1, - * otherwise it is 0. */ + char final[16]; /* String to emit or expect after last char in + * conversion. */ + char prefixBytes[256]; /* If a byte in the input stream is the first + * character of one of the escape sequences in + * the following array, the corresponding + * entry in this array is 1, otherwise it is + * 0. */ int numSubTables; /* Length of following array. */ - EscapeSubTable subTables[1];/* Information about each EscapeSubTable - * used by this encoding type. The actual - * size will be as large as necessary to - * hold all EscapeSubTables. */ + EscapeSubTable subTables[1];/* Information about each EscapeSubTable used + * by this encoding type. The actual size + * will be as large as necessary to hold all + * EscapeSubTables. */ } EscapeEncodingData; /* * Constants used when loading an encoding file to identify the type of the * file. @@ -133,54 +134,55 @@ #define ENCODING_DOUBLEBYTE 1 #define ENCODING_MULTIBYTE 2 #define ENCODING_ESCAPE 3 /* - * A list of directories in which Tcl should look for *.enc files. - * This list is shared by all threads. Access is governed by a - * mutex lock. - */ - -static TclInitProcessGlobalValueProc InitializeEncodingSearchPath; -static ProcessGlobalValue encodingSearchPath = - {0, 0, NULL, NULL, InitializeEncodingSearchPath, NULL, NULL}; - -/* - * A map from encoding names to the directories in which their data - * files have been seen. The string value of the map is shared by all - * threads. Access to the shared string is governed by a mutex lock. - */ - -static TclInitProcessGlobalValueProc InitializeEncodingFileMap; -static ProcessGlobalValue encodingFileMap = - {0, 0, NULL, NULL, InitializeEncodingFileMap, NULL, NULL}; - -/* - * A list of directories making up the "library path". Historically - * this search path has served many uses, but the only one remaining - * is a base for the encodingSearchPath above. If the application - * does not explicitly set the encodingSearchPath, then it will be - * initialized by appending /encoding to each directory in this - * "libraryPath". - */ -static ProcessGlobalValue libraryPath = - {0, 0, NULL, NULL, TclpInitLibraryPath, NULL, NULL}; + * A list of directories in which Tcl should look for *.enc files. This list + * is shared by all threads. Access is governed by a mutex lock. + */ + +static TclInitProcessGlobalValueProc InitializeEncodingSearchPath; +static ProcessGlobalValue encodingSearchPath = { + 0, 0, NULL, NULL, InitializeEncodingSearchPath, NULL, NULL +}; + +/* + * A map from encoding names to the directories in which their data files have + * been seen. The string value of the map is shared by all threads. Access + * to the shared string is governed by a mutex lock. + */ + +static ProcessGlobalValue encodingFileMap = { + 0, 0, NULL, NULL, NULL, NULL, NULL +}; + +/* + * A list of directories making up the "library path". Historically this + * search path has served many uses, but the only one remaining is a base for + * the encodingSearchPath above. If the application does not explicitly set + * the encodingSearchPath, then it will be initialized by appending /encoding + * to each directory in this "libraryPath". + */ + +static ProcessGlobalValue libraryPath = { + 0, 0, NULL, NULL, TclpInitLibraryPath, NULL, NULL +}; static int encodingsInitialized = 0; /* - * Hash table that keeps track of all loaded Encodings. Keys are - * the string names that represent the encoding, values are (Encoding *). + * Hash table that keeps track of all loaded Encodings. Keys are the string + * names that represent the encoding, values are (Encoding *). */ - + static Tcl_HashTable encodingTable; TCL_DECLARE_MUTEX(encodingMutex) /* - * The following are used to hold the default and current system encodings. - * If NULL is passed to one of the conversion routines, the current setting - * of the system encoding will be used to perform the conversion. + * The following are used to hold the default and current system encodings. + * If NULL is passed to one of the conversion routines, the current setting of + * the system encoding will be used to perform the conversion. */ static Tcl_Encoding defaultEncoding; static Tcl_Encoding systemEncoding; @@ -198,10 +200,12 @@ static int BinaryProc _ANSI_ARGS_((ClientData clientData, CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)); +static void DupEncodingIntRep _ANSI_ARGS_((Tcl_Obj *srcPtr, + Tcl_Obj *dupPtr)); static void EscapeFreeProc _ANSI_ARGS_((ClientData clientData)); static int EscapeFromUtfProc _ANSI_ARGS_((ClientData clientData, CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, @@ -211,19 +215,21 @@ Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)); static void FillEncodingFileMap (); static void FreeEncoding _ANSI_ARGS_((Tcl_Encoding encoding)); +static void FreeEncodingIntRep _ANSI_ARGS_((Tcl_Obj *objPtr)); static Encoding * GetTableEncoding _ANSI_ARGS_(( EscapeEncodingData *dataPtr, int state)); static Tcl_Encoding LoadEncodingFile _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name)); static Tcl_Encoding LoadTableEncoding _ANSI_ARGS_((CONST char *name, int type, Tcl_Channel chan)); -static Tcl_Encoding LoadEscapeEncoding _ANSI_ARGS_((CONST char *name, +static Tcl_Encoding LoadEscapeEncoding _ANSI_ARGS_((CONST char *name, Tcl_Channel chan)); -static Tcl_Obj * MakeFileMap (); +static Tcl_Channel OpenEncodingFileChannel _ANSI_ARGS_(( + Tcl_Interp *interp, CONST char *name)); static void TableFreeProc _ANSI_ARGS_((ClientData clientData)); static int TableFromUtfProc _ANSI_ARGS_((ClientData clientData, CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, @@ -258,22 +264,106 @@ CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)); +/* + * A Tcl_ObjType for holding a cached Tcl_Encoding as the intrep. This should + * help the lifetime of encodings be more useful. See concerns raised in [Bug + * 1077262]. + */ + +static Tcl_ObjType EncodingType = { + "encoding", FreeEncodingIntRep, DupEncodingIntRep, NULL, NULL +}; + +/* + *---------------------------------------------------------------------- + * + * TclGetEncodingFromObj -- + * + * Writes to (*encodingPtr) the Tcl_Encoding value of (*objPtr), if + * possible, and returns TCL_OK. If no such encoding exists, TCL_ERROR + * is returned, and if interp is non-NULL, an error message is written + * there. + * + * Results: + * Standard Tcl return code. + * + * Side effects: + * Caches the Tcl_Encoding value as the internal rep of (*objPtr). + * + *---------------------------------------------------------------------- + */ + +int +TclGetEncodingFromObj(interp, objPtr, encodingPtr) + Tcl_Interp *interp; + Tcl_Obj *objPtr; + Tcl_Encoding *encodingPtr; +{ + CONST char *name = Tcl_GetString(objPtr); + if (objPtr->typePtr != &EncodingType) { + Tcl_Encoding encoding = Tcl_GetEncoding(interp, name); + + if (encoding == NULL) { + return TCL_ERROR; + } + TclFreeIntRep(objPtr); + objPtr->internalRep.otherValuePtr = (VOID *) encoding; + objPtr->typePtr = &EncodingType; + } + *encodingPtr = Tcl_GetEncoding(NULL, name); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FreeEncodingIntRep -- + * + * The Tcl_FreeInternalRepProc for the "encoding" Tcl_ObjType. + * + *---------------------------------------------------------------------- + */ + +static void +FreeEncodingIntRep(objPtr) + Tcl_Obj *objPtr; +{ + Tcl_FreeEncoding((Tcl_Encoding) objPtr->internalRep.otherValuePtr); +} + +/* + *---------------------------------------------------------------------- + * + * DupEncodingIntRep -- + * + * The Tcl_DupInternalRepProc for the "encoding" Tcl_ObjType. + * + *---------------------------------------------------------------------- + */ + +static void +DupEncodingIntRep(srcPtr, dupPtr) + Tcl_Obj *srcPtr; + Tcl_Obj *dupPtr; +{ + dupPtr->internalRep.otherValuePtr = (VOID *) + Tcl_GetEncoding(NULL, srcPtr->bytes); +} /* *---------------------------------------------------------------------- * * TclGetEncodingSearchPath -- * - * Keeps the per-thread copy of the encoding search path current - * with changes to the global copy. + * Keeps the per-thread copy of the encoding search path current with + * changes to the global copy. * * Results: - * Returns a "list" (Tcl_Obj *) that contains the encoding - * search path. + * Returns a "list" (Tcl_Obj *) that contains the encoding search path. * *---------------------------------------------------------------------- */ Tcl_Obj * @@ -284,40 +374,39 @@ /* *---------------------------------------------------------------------- * * TclSetEncodingSearchPath -- * - * Keeps the per-thread copy of the encoding search path current - * with changes to the global copy. + * Keeps the per-thread copy of the encoding search path current with + * changes to the global copy. * *---------------------------------------------------------------------- */ -int +int TclSetEncodingSearchPath(searchPath) - Tcl_Obj *searchPath; + Tcl_Obj *searchPath; { int dummy; if (TCL_ERROR == Tcl_ListObjLength(NULL, searchPath, &dummy)) { return TCL_ERROR; } TclSetProcessGlobalValue(&encodingSearchPath, searchPath, NULL); - FillEncodingFileMap(); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclGetLibraryPath -- * - * Keeps the per-thread copy of the library path current - * with changes to the global copy. + * Keeps the per-thread copy of the library path current with changes to + * the global copy. * * Results: - * Returns a "list" (Tcl_Obj *) that contains the library path. + * Returns a "list" (Tcl_Obj *) that contains the library path. * *---------------------------------------------------------------------- */ Tcl_Obj * @@ -328,23 +417,23 @@ /* *---------------------------------------------------------------------- * * TclSetLibraryPath -- * - * Keeps the per-thread copy of the library path current - * with changes to the global copy. + * Keeps the per-thread copy of the library path current with changes to + * the global copy. * - * NOTE: this routine returns void, so there's no way to - * report the error that searchPath is not a valid list. - * In that case, this routine will silently do nothing. + * NOTE: this routine returns void, so there's no way to report the error + * that searchPath is not a valid list. In that case, this routine will + * silently do nothing. * *---------------------------------------------------------------------- */ void TclSetLibraryPath(path) - Tcl_Obj *path; + Tcl_Obj *path; { int dummy; if (TCL_ERROR == Tcl_ListObjLength(NULL, path, &dummy)) { return; @@ -353,21 +442,23 @@ } /* *--------------------------------------------------------------------------- * - * MakeFileMap -- - * - * Scan the directories on the encoding search path, find the - * *.enc files, and store the found pathnames in a map associated - * with the encoding name. - * - * In particular, if $dir is on the encoding search path, and the - * file $dir/foo.enc is found, then store a "foo" -> $dir entry - * in the map. Later, any need for the "foo" encoding will quickly - * be able to construct the $dir/foo.enc pathname for reading the - * encoding data. + * FillEncodingFileMap -- + * + * Called to bring the encoding file map in sync with the current value + * of the encoding search path. + * + * Scan the directories on the encoding search path, find the *.enc + * files, and store the found pathnames in a map associated with the + * encoding name. + * + * In particular, if $dir is on the encoding search path, and the file + * $dir/foo.enc is found, then store a "foo" -> $dir entry in the map. + * Later, any need for the "foo" encoding will quickly * be able to + * construct the $dir/foo.enc pathname for reading the encoding data. * * Results: * None. * * Side effects: @@ -374,80 +465,55 @@ * Entries are added to the encoding file map. * *--------------------------------------------------------------------------- */ -static Tcl_Obj * -MakeFileMap() +static void +FillEncodingFileMap() { int i, numDirs = 0; Tcl_Obj *map, *searchPath; searchPath = TclGetEncodingSearchPath(); Tcl_IncrRefCount(searchPath); Tcl_ListObjLength(NULL, searchPath, &numDirs); map = Tcl_NewDictObj(); Tcl_IncrRefCount(map); + for (i = numDirs-1; i >= 0; i--) { - /* - * Iterate backwards through the search path so as we - * overwrite entries found, we favor files earlier on - * the search path. + /* + * Iterate backwards through the search path so as we overwrite + * entries found, we favor files earlier on the search path. */ + int j, numFiles; Tcl_Obj *directory, *matchFileList = Tcl_NewObj(); Tcl_Obj **filev; - Tcl_GlobTypeData readableFiles = - {TCL_GLOB_TYPE_FILE, TCL_GLOB_PERM_R, NULL, NULL}; + Tcl_GlobTypeData readableFiles = { + TCL_GLOB_TYPE_FILE, TCL_GLOB_PERM_R, NULL, NULL + }; Tcl_ListObjIndex(NULL, searchPath, i, &directory); Tcl_IncrRefCount(directory); Tcl_IncrRefCount(matchFileList); - Tcl_FSMatchInDirectory(NULL, matchFileList, - directory, "*.enc", &readableFiles); + Tcl_FSMatchInDirectory(NULL, matchFileList, directory, "*.enc", + &readableFiles); Tcl_ListObjGetElements(NULL, matchFileList, &numFiles, &filev); for (j=0; jrefCount++; Tcl_MutexUnlock(&encodingMutex); return (Tcl_Encoding) encodingPtr; } Tcl_MutexUnlock(&encodingMutex); + return LoadEncodingFile(interp, name); } /* *--------------------------------------------------------------------------- @@ -680,12 +749,12 @@ * * Results: * None. * * Side effects: - * The reference count associated with the encoding is decremented - * and the encoding may be deleted if nothing is using it anymore. + * The reference count associated with the encoding is decremented and + * the encoding may be deleted if nothing is using it anymore. * *--------------------------------------------------------------------------- */ void @@ -700,29 +769,29 @@ /* *---------------------------------------------------------------------- * * FreeEncoding -- * - * This procedure is called to release an encoding by procedures - * that already have the encodingMutex. + * This procedure is called to release an encoding by procedures that + * already have the encodingMutex. * * Results: * None. * * Side effects: - * The reference count associated with the encoding is decremented - * and the encoding may be deleted if nothing is using it anymore. + * The reference count associated with the encoding is decremented and + * the encoding may be deleted if nothing is using it anymore. * *---------------------------------------------------------------------- */ static void FreeEncoding(encoding) Tcl_Encoding encoding; { Encoding *encodingPtr; - + encodingPtr = (Encoding *) encoding; if (encodingPtr == NULL) { return; } encodingPtr->refCount--; @@ -741,12 +810,12 @@ /* *------------------------------------------------------------------------- * * Tcl_GetEncodingName -- * - * Given an encoding, return the name that was used to constuct - * the encoding. + * Given an encoding, return the name that was used to constuct the + * encoding. * * Results: * The name of the encoding. * * Side effects: @@ -757,26 +826,24 @@ CONST char * Tcl_GetEncodingName(encoding) Tcl_Encoding encoding; /* The encoding whose name to fetch. */ { - Encoding *encodingPtr; - if (encoding == NULL) { encoding = systemEncoding; } - encodingPtr = (Encoding *) encoding; - return encodingPtr->name; + + return ((Encoding *) encoding)->name; } /* *------------------------------------------------------------------------- * * Tcl_GetEncodingNames -- * - * Get the list of all known encodings, including the ones stored - * as files on disk in the encoding path. + * Get the list of all known encodings, including the ones stored as + * files on disk in the encoding path. * * Results: * Modifies interp's result object to hold a list of all the available * encodings. * @@ -797,11 +864,14 @@ Tcl_DictSearch mapSearch; int dummy, done = 0; Tcl_InitObjHashTable(&table); - /* Copy encoding names from loaded encoding table to table */ + /* + * Copy encoding names from loaded encoding table to table. + */ + Tcl_MutexLock(&encodingMutex); for (hPtr = Tcl_FirstHashEntry(&encodingTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { Encoding *encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr); Tcl_CreateHashEntry(&table, @@ -810,20 +880,26 @@ Tcl_MutexUnlock(&encodingMutex); FillEncodingFileMap(); map = TclGetProcessGlobalValue(&encodingFileMap); - /* Copy encoding names from encoding file map to table */ + /* + * Copy encoding names from encoding file map to table. + */ + Tcl_DictObjFirst(NULL, map, &mapSearch, &name, NULL, &done); for (; !done; Tcl_DictObjNext(&mapSearch, &name, NULL, &done)) { Tcl_CreateHashEntry(&table, (char *) name, &dummy); } - /* Pull all encoding names from table into the result list */ + /* + * Pull all encoding names from table into the result list. + */ + for (hPtr = Tcl_FirstHashEntry(&table, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - Tcl_ListObjAppendElement(NULL, result, + Tcl_ListObjAppendElement(NULL, result, (Tcl_Obj *) Tcl_GetHashKey(&table, hPtr)); } Tcl_SetObjResult(interp, result); Tcl_DeleteHashTable(&table); } @@ -831,25 +907,25 @@ /* *------------------------------------------------------------------------ * * Tcl_SetSystemEncoding -- * - * Sets the default encoding that should be used whenever the user - * passes a NULL value in to one of the conversion routines. - * If the supplied name is NULL, the system encoding is reset to the - * default system encoding. + * Sets the default encoding that should be used whenever the user passes + * a NULL value in to one of the conversion routines. If the supplied + * name is NULL, the system encoding is reset to the default system + * encoding. * * Results: - * The return value is TCL_OK if the system encoding was successfully - * set to the encoding specified by name, TCL_ERROR otherwise. If - * TCL_ERROR is returned, an error message is left in interp's result - * object, unless interp was NULL. + * The return value is TCL_OK if the system encoding was successfully set + * to the encoding specified by name, TCL_ERROR otherwise. If TCL_ERROR + * is returned, an error message is left in interp's result object, + * unless interp was NULL. * * Side effects: - * The reference count of the new system encoding is incremented. - * The reference count of the old system encoding is decremented and - * it may be freed. + * The reference count of the new system encoding is incremented. The + * reference count of the old system encoding is decremented and it may + * be freed. * *------------------------------------------------------------------------ */ int @@ -886,29 +962,29 @@ *--------------------------------------------------------------------------- * * Tcl_CreateEncoding -- * * This procedure is called to define a new encoding and the procedures - * that are used to convert between the specified encoding and Unicode. + * that are used to convert between the specified encoding and Unicode. * * Results: - * Returns a token that represents the encoding. If an encoding with - * the same name already existed, the old encoding token remains - * valid and continues to behave as it used to, and will eventually - * be garbage collected when the last reference to it goes away. Any - * subsequent calls to Tcl_GetEncoding with the specified name will - * retrieve the most recent encoding token. + * Returns a token that represents the encoding. If an encoding with the + * same name already existed, the old encoding token remains valid and + * continues to behave as it used to, and will eventually be garbage + * collected when the last reference to it goes away. Any subsequent + * calls to Tcl_GetEncoding with the specified name will retrieve the + * most recent encoding token. * * Side effects: * The new encoding type is entered into a table visible to all - * interpreters, keyed off the encoding's name. For each call to - * this procedure, there should eventually be a call to - * Tcl_FreeEncoding, so that the database can be cleaned up when - * encodings aren't needed anymore. + * interpreters, keyed off the encoding's name. For each call to this + * procedure, there should eventually be a call to Tcl_FreeEncoding, so + * that the database can be cleaned up when encodings aren't needed + * anymore. * *--------------------------------------------------------------------------- - */ + */ Tcl_Encoding Tcl_CreateEncoding(typePtr) Tcl_EncodingType *typePtr; /* The encoding type. */ { @@ -919,20 +995,20 @@ Tcl_MutexLock(&encodingMutex); hPtr = Tcl_CreateHashEntry(&encodingTable, typePtr->encodingName, &new); if (new == 0) { /* - * Remove old encoding from hash table, but don't delete it until - * last reference goes away. + * Remove old encoding from hash table, but don't delete it until last + * reference goes away. */ - + encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr); encodingPtr->hPtr = NULL; } name = ckalloc((unsigned) strlen(typePtr->encodingName) + 1); - + encodingPtr = (Encoding *) ckalloc(sizeof(Encoding)); encodingPtr->name = strcpy(name, typePtr->encodingName); encodingPtr->toUtfProc = typePtr->toUtfProc; encodingPtr->fromUtfProc = typePtr->fromUtfProc; encodingPtr->freeProc = typePtr->freeProc; @@ -955,45 +1031,45 @@ /* *------------------------------------------------------------------------- * * Tcl_ExternalToUtfDString -- * - * Convert a source buffer from the specified encoding into UTF-8. - * If any of the bytes in the source buffer are invalid or cannot - * be represented in the target encoding, a default fallback - * character will be substituted. + * Convert a source buffer from the specified encoding into UTF-8. If any + * of the bytes in the source buffer are invalid or cannot be represented + * in the target encoding, a default fallback character will be + * substituted. * * Results: * The converted bytes are stored in the DString, which is then NULL - * terminated. The return value is a pointer to the value stored - * in the DString. + * terminated. The return value is a pointer to the value stored in the + * DString. * * Side effects: * None. * *------------------------------------------------------------------------- */ -char * +char * Tcl_ExternalToUtfDString(encoding, src, srcLen, dstPtr) - Tcl_Encoding encoding; /* The encoding for the source string, or - * NULL for the default system encoding. */ + Tcl_Encoding encoding; /* The encoding for the source string, or NULL + * for the default system encoding. */ CONST char *src; /* Source string in specified encoding. */ int srcLen; /* Source string length in bytes, or < 0 for * encoding-specific string length. */ - Tcl_DString *dstPtr; /* Uninitialized or free DString in which - * the converted string is stored. */ + Tcl_DString *dstPtr; /* Uninitialized or free DString in which the + * converted string is stored. */ { char *dst; Tcl_EncodingState state; Encoding *encodingPtr; int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars; Tcl_DStringInit(dstPtr); dst = Tcl_DStringValue(dstPtr); dstLen = dstPtr->spaceAvl - 1; - + if (encoding == NULL) { encoding = systemEncoding; } encodingPtr = (Encoding *) encoding; @@ -1000,20 +1076,24 @@ if (src == NULL) { srcLen = 0; } else if (srcLen < 0) { srcLen = (*encodingPtr->lengthProc)(src); } + flags = TCL_ENCODING_START | TCL_ENCODING_END; + while (1) { result = (*encodingPtr->toUtfProc)(encodingPtr->clientData, src, srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote, &dstChars); soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); + if (result != TCL_CONVERT_NOSPACE) { Tcl_DStringSetLength(dstPtr, soFar); return Tcl_DStringValue(dstPtr); } + flags &= ~TCL_ENCODING_START; src += srcRead; srcLen -= srcRead; if (Tcl_DStringLength(dstPtr) == 0) { Tcl_DStringSetLength(dstPtr, dstLen); @@ -1031,36 +1111,36 @@ * * Convert a source buffer from the specified encoding into UTF-8. * * Results: * The return value is one of TCL_OK, TCL_CONVERT_MULTIBYTE, - * TCL_CONVERT_SYNTAX, TCL_CONVERT_UNKNOWN, or TCL_CONVERT_NOSPACE, - * as documented in tcl.h. + * TCL_CONVERT_SYNTAX, TCL_CONVERT_UNKNOWN, or TCL_CONVERT_NOSPACE, as + * documented in tcl.h. * * Side effects: - * The converted bytes are stored in the output buffer. + * The converted bytes are stored in the output buffer. * *------------------------------------------------------------------------- */ int Tcl_ExternalToUtf(interp, encoding, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) Tcl_Interp *interp; /* Interp for error return, if not NULL. */ - Tcl_Encoding encoding; /* The encoding for the source string, or - * NULL for the default system encoding. */ + Tcl_Encoding encoding; /* The encoding for the source string, or NULL + * for the default system encoding. */ CONST char *src; /* Source string in specified encoding. */ int srcLen; /* Source string length in bytes, or < 0 for * encoding-specific string length. */ int flags; /* Conversion control flags. */ - Tcl_EncodingState *statePtr;/* Place for conversion routine to store - * state information used during a piecewise + Tcl_EncodingState *statePtr;/* Place for conversion routine to store state + * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ - char *dst; /* Output buffer in which converted string - * is stored. */ + char *dst; /* Output buffer in which converted string is + * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the * source string that were converted. This * may be less than the original source length @@ -1074,11 +1154,11 @@ * output buffer. */ { Encoding *encodingPtr; int result, srcRead, dstWrote, dstChars; Tcl_EncodingState state; - + if (encoding == NULL) { encoding = systemEncoding; } encodingPtr = (Encoding *) encoding; @@ -1101,58 +1181,59 @@ dstCharsPtr = &dstChars; } /* * If there are any null characters in the middle of the buffer, they will - * converted to the UTF-8 null character (\xC080). To get the actual - * \0 at the end of the destination buffer, we need to append it manually. + * converted to the UTF-8 null character (\xC080). To get the actual \0 at + * the end of the destination buffer, we need to append it manually. */ dstLen--; result = (*encodingPtr->toUtfProc)(encodingPtr->clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr); dst[*dstWrotePtr] = '\0'; + return result; } /* *------------------------------------------------------------------------- * * Tcl_UtfToExternalDString -- * - * Convert a source buffer from UTF-8 into the specified encoding. - * If any of the bytes in the source buffer are invalid or cannot - * be represented in the target encoding, a default fallback - * character will be substituted. + * Convert a source buffer from UTF-8 into the specified encoding. If + * any of the bytes in the source buffer are invalid or cannot be + * represented in the target encoding, a default fallback character will + * be substituted. * * Results: - * The converted bytes are stored in the DString, which is then - * NULL terminated in an encoding-specific manner. The return value - * is a pointer to the value stored in the DString. + * The converted bytes are stored in the DString, which is then NULL + * terminated in an encoding-specific manner. The return value is a + * pointer to the value stored in the DString. * * Side effects: * None. * *------------------------------------------------------------------------- */ char * Tcl_UtfToExternalDString(encoding, src, srcLen, dstPtr) - Tcl_Encoding encoding; /* The encoding for the converted string, - * or NULL for the default system encoding. */ + Tcl_Encoding encoding; /* The encoding for the converted string, or + * NULL for the default system encoding. */ CONST char *src; /* Source string in UTF-8. */ int srcLen; /* Source string length in bytes, or < 0 for * strlen(). */ - Tcl_DString *dstPtr; /* Uninitialized or free DString in which - * the converted string is stored. */ + Tcl_DString *dstPtr; /* Uninitialized or free DString in which the + * converted string is stored. */ { char *dst; Tcl_EncodingState state; Encoding *encodingPtr; int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars; - + Tcl_DStringInit(dstPtr); dst = Tcl_DStringValue(dstPtr); dstLen = dstPtr->spaceAvl - 1; if (encoding == NULL) { @@ -1169,17 +1250,19 @@ while (1) { result = (*encodingPtr->fromUtfProc)(encodingPtr->clientData, src, srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote, &dstChars); soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); + if (result != TCL_CONVERT_NOSPACE) { if (encodingPtr->nullSize == 2) { - Tcl_DStringSetLength(dstPtr, soFar + 1); + Tcl_DStringSetLength(dstPtr, soFar + 1); } Tcl_DStringSetLength(dstPtr, soFar); return Tcl_DStringValue(dstPtr); } + flags &= ~TCL_ENCODING_START; src += srcRead; srcLen -= srcRead; if (Tcl_DStringLength(dstPtr) == 0) { Tcl_DStringSetLength(dstPtr, dstLen); @@ -1197,31 +1280,31 @@ * * Convert a buffer from UTF-8 into the specified encoding. * * Results: * The return value is one of TCL_OK, TCL_CONVERT_MULTIBYTE, - * TCL_CONVERT_SYNTAX, TCL_CONVERT_UNKNOWN, or TCL_CONVERT_NOSPACE, - * as documented in tcl.h. + * TCL_CONVERT_SYNTAX, TCL_CONVERT_UNKNOWN, or TCL_CONVERT_NOSPACE, as + * documented in tcl.h. * * Side effects: - * The converted bytes are stored in the output buffer. + * The converted bytes are stored in the output buffer. * *------------------------------------------------------------------------- */ int Tcl_UtfToExternal(interp, encoding, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) Tcl_Interp *interp; /* Interp for error return, if not NULL. */ - Tcl_Encoding encoding; /* The encoding for the converted string, - * or NULL for the default system encoding. */ + Tcl_Encoding encoding; /* The encoding for the converted string, or + * NULL for the default system encoding. */ CONST char *src; /* Source string in UTF-8. */ int srcLen; /* Source string length in bytes, or < 0 for * strlen(). */ int flags; /* Conversion control flags. */ - Tcl_EncodingState *statePtr;/* Place for conversion routine to store - * state information used during a piecewise + Tcl_EncodingState *statePtr;/* Place for conversion routine to store state + * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ char *dst; /* Output buffer in which converted string * is stored. */ @@ -1240,11 +1323,11 @@ * output buffer. */ { Encoding *encodingPtr; int result, srcRead, dstWrote, dstChars; Tcl_EncodingState state; - + if (encoding == NULL) { encoding = systemEncoding; } encodingPtr = (Encoding *) encoding; @@ -1273,11 +1356,11 @@ dstCharsPtr); if (encodingPtr->nullSize == 2) { dst[*dstWrotePtr + 1] = '\0'; } dst[*dstWrotePtr] = '\0'; - + return result; } /* *--------------------------------------------------------------------------- @@ -1289,12 +1372,12 @@ * * Results: * None. * * Side effects: - * The absolute pathname for the application is computed and stored - * to be returned later be [info nameofexecutable]. + * The absolute pathname for the application is computed and stored to be + * returned later be [info nameofexecutable]. * *--------------------------------------------------------------------------- */ void @@ -1301,76 +1384,162 @@ Tcl_FindExecutable(argv0) CONST char *argv0; /* The value of the application's argv[0] * (native). */ { TclInitSubsystems(); + TclpSetInitialEncodings(); TclpFindExecutable(argv0); } + +/* + *--------------------------------------------------------------------------- + * + * OpenEncodingFileChannel -- + * + * Open the file believed to hold data for the encoding, "name". + * + * Results: + * Returns the readable Tcl_Channel from opening the file, or NULL if the + * file could not be successfully opened. If NULL was * returned, an + * error message is left in interp's result object, * unless interp was + * NULL. + * + * Side effects: + * Channel may be opened. Information about the filesystem may be cached + * to speed later calls. + * + *--------------------------------------------------------------------------- + */ + +static Tcl_Channel +OpenEncodingFileChannel(interp, name) + Tcl_Interp *interp; /* Interp for error reporting, if not NULL. */ + CONST char *name; /* The name of the encoding file on disk and + * also the name for new encoding. */ +{ + Tcl_Obj *nameObj = Tcl_NewStringObj(name, -1); + Tcl_Obj *fileNameObj = Tcl_DuplicateObj(nameObj); + Tcl_Obj *searchPath = Tcl_DuplicateObj(TclGetEncodingSearchPath()); + Tcl_Obj *map = TclGetProcessGlobalValue(&encodingFileMap); + Tcl_Obj **dir, *path, *directory = NULL; + Tcl_Channel chan = NULL; + int i, numDirs; + + Tcl_ListObjGetElements(NULL, searchPath, &numDirs, &dir); + Tcl_IncrRefCount(nameObj); + Tcl_AppendToObj(fileNameObj, ".enc", -1); + Tcl_IncrRefCount(fileNameObj); + Tcl_DictObjGet(NULL, map, nameObj, &directory); + + /* + * Check that any cached directory is still on the encoding search path. + */ + + if (NULL != directory) { + int verified = 0; + + for (i=0; ifallback = fallback; /* * Read the table that maps characters to Unicode. Performs a single - * malloc to get the memory for the array and all the pages needed by - * the array. + * malloc to get the memory for the array and all the pages needed by the + * array. */ size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE; dataPtr->toUnicode = (unsigned short **) ckalloc(size); memset(dataPtr->toUnicode, 0, size); @@ -1522,29 +1681,29 @@ int ch; char *p; Tcl_ReadChars(chan, objPtr, 3 + 16 * (16 * 4 + 1), 0); p = Tcl_GetString(objPtr); - hi = (staticHex[(unsigned int)p[0]] << 4) + staticHex[(unsigned int)p[1]]; + hi = (staticHex[UCHAR(p[0])] << 4) + staticHex[UCHAR(p[1])]; dataPtr->toUnicode[hi] = pageMemPtr; p += 2; for (lo = 0; lo < 256; lo++) { if ((lo & 0x0f) == 0) { p++; } - ch = (staticHex[(unsigned int)p[0]] << 12) + (staticHex[(unsigned int)p[1]] << 8) - + (staticHex[(unsigned int)p[2]] << 4) + staticHex[(unsigned int)p[3]]; + ch = (staticHex[UCHAR(p[0])] << 12) + (staticHex[UCHAR(p[1])] << 8) + + (staticHex[UCHAR(p[2])] << 4) + staticHex[UCHAR(p[3])]; if (ch != 0) { used[ch >> 8] = 1; } *pageMemPtr = (unsigned short) ch; pageMemPtr++; p += 4; } } TclDecrRefCount(objPtr); - + if (type == ENCODING_DOUBLEBYTE) { memset(dataPtr->prefixBytes, 1, sizeof(dataPtr->prefixBytes)); } else { for (hi = 1; hi < 256; hi++) { if (dataPtr->toUnicode[hi] != NULL) { @@ -1553,13 +1712,13 @@ } } /* * Invert toUnicode array to produce the fromUnicode array. Performs a - * single malloc to get the memory for the array and all the pages - * needed by the array. While reading in the toUnicode array, we - * remembered what pages that would be needed for the fromUnicode array. + * single malloc to get the memory for the array and all the pages needed + * by the array. While reading in the toUnicode array, we remembered what + * pages that would be needed for the fromUnicode array. */ if (symbol) { used[0] = 1; } @@ -1582,11 +1741,11 @@ int ch; ch = dataPtr->toUnicode[hi][lo]; if (ch != 0) { unsigned short *page; - + page = dataPtr->fromUnicode[ch >> 8]; if (page == NULL) { page = pageMemPtr; pageMemPtr += 256; dataPtr->fromUnicode[ch >> 8] = page; @@ -1610,20 +1769,19 @@ } } } if (symbol) { unsigned short *page; - + /* * Make a special symbol encoding that not only maps the symbol * characters from their Unicode code points down into page 0, but - * also ensure that the characters on page 0 map to themselves. - * This is so that a symbol font can be used to display a simple - * string like "abcd" and have alpha, beta, chi, delta show up, - * rather than have "unknown" chars show up because strictly - * speaking the symbol font doesn't have glyphs for those low ascii - * chars. + * also ensure that the characters on page 0 map to themselves. This + * is so that a symbol font can be used to display a simple string + * like "abcd" and have alpha, beta, chi, delta show up, rather than + * have "unknown" chars show up because strictly speaking the symbol + * font doesn't have glyphs for those low ascii chars. */ page = dataPtr->fromUnicode[0]; if (page == NULL) { page = pageMemPtr; @@ -1638,37 +1796,45 @@ for (hi = 0; hi < 256; hi++) { if (dataPtr->fromUnicode[hi] == NULL) { dataPtr->fromUnicode[hi] = emptyPage; } } + /* * For trailing 'R'everse encoding, see [Patch #689341] */ + Tcl_DStringInit(&lineString); do { int len; - /* skip leading empty lines */ + + /* + * Skip leading empty lines. + */ + while ((len = Tcl_Gets(chan, &lineString)) == 0) ; + if (len < 0) { break; } line = Tcl_DStringValue(&lineString); if (line[0] != 'R') { break; } for (Tcl_DStringSetLength(&lineString, 0); - (len = Tcl_Gets(chan, &lineString)) >= 0; - Tcl_DStringSetLength(&lineString, 0)) { + (len = Tcl_Gets(chan, &lineString)) >= 0; + Tcl_DStringSetLength(&lineString, 0)) { unsigned char* p; int to, from; + if (len < 5) { continue; } p = (unsigned char*) Tcl_DStringValue(&lineString); to = (staticHex[p[0]] << 12) + (staticHex[p[1]] << 8) - + (staticHex[p[2]] << 4) + staticHex[p[3]]; + + (staticHex[p[2]] << 4) + staticHex[p[3]]; if (to == 0) { continue; } for (p += 5, len -= 5; len >= 0 && *p; p += 5, len -= 5) { from = (staticHex[p[0]] << 12) + (staticHex[p[1]] << 8) @@ -1686,28 +1852,29 @@ encType.toUtfProc = TableToUtfProc; encType.fromUtfProc = TableFromUtfProc; encType.freeProc = TableFreeProc; encType.nullSize = (type == ENCODING_DOUBLEBYTE) ? 2 : 1; encType.clientData = (ClientData) dataPtr; + return Tcl_CreateEncoding(&encType); } /* *------------------------------------------------------------------------- * * LoadEscapeEncoding -- * - * Helper function for LoadEncodingTable(). Loads a state machine - * that converts between Unicode and some other encoding. + * Helper function for LoadEncodingTable(). Loads a state machine that + * converts between Unicode and some other encoding. * - * File contains text data that describes the escape sequences that - * are used to choose an encoding and the associated names for the + * File contains text data that describes the escape sequences that are + * used to choose an encoding and the associated names for the * sub-encodings. * * Results: - * The return value is the new encoding, or NULL if the encoding - * could not be created (because the file contained invalid data). + * The return value is the new encoding, or NULL if the encoding could + * not be created (because the file contained invalid data). * * Side effects: * None. * *------------------------------------------------------------------------- @@ -1732,17 +1899,17 @@ while (1) { int argc; CONST char **argv; char *line; Tcl_DString lineString; - + Tcl_DStringInit(&lineString); if (Tcl_Gets(chan, &lineString) < 0) { break; } line = Tcl_DStringValue(&lineString); - if (Tcl_SplitList(NULL, line, &argc, &argv) != TCL_OK) { + if (Tcl_SplitList(NULL, line, &argc, &argv) != TCL_OK) { continue; } if (argc >= 2) { if (strcmp(argv[0], "name") == 0) { ; @@ -1760,11 +1927,14 @@ est.sequenceLen = strlen(est.sequence); strncpy(est.name, argv[0], sizeof(est.name)); est.name[sizeof(est.name) - 1] = '\0'; - /* To avoid infinite recursion in [encoding system iso2022-*]*/ + /* + * To avoid infinite recursion in [encoding system iso2022-*] + */ + Tcl_GetEncoding(NULL, est.name); est.encodingPtr = NULL; Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est)); } @@ -1771,18 +1941,19 @@ } ckfree((char *) argv); Tcl_DStringFree(&lineString); } - size = sizeof(EscapeEncodingData) - - sizeof(EscapeSubTable) + Tcl_DStringLength(&escapeData); + size = sizeof(EscapeEncodingData) - sizeof(EscapeSubTable) + + Tcl_DStringLength(&escapeData); dataPtr = (EscapeEncodingData *) ckalloc(size); dataPtr->initLen = strlen(init); strcpy(dataPtr->init, init); dataPtr->finalLen = strlen(final); strcpy(dataPtr->final, final); - dataPtr->numSubTables = Tcl_DStringLength(&escapeData) / sizeof(EscapeSubTable); + dataPtr->numSubTables = + Tcl_DStringLength(&escapeData) / sizeof(EscapeSubTable); memcpy((VOID *) dataPtr->subTables, (VOID *) Tcl_DStringValue(&escapeData), (size_t) Tcl_DStringLength(&escapeData)); Tcl_DStringFree(&escapeData); memset(dataPtr->prefixBytes, 0, sizeof(dataPtr->prefixBytes)); @@ -1809,13 +1980,13 @@ /* *------------------------------------------------------------------------- * * BinaryProc -- * - * The default conversion when no other conversion is specified. - * No translation is done; source bytes are copied directly to - * destination bytes. + * The default conversion when no other conversion is specified. No + * translation is done; source bytes are copied directly to destination + * bytes. * * Results: * Returns TCL_OK if conversion was successful. * * Side effects: @@ -1829,17 +2000,17 @@ srcReadPtr, dstWrotePtr, dstCharsPtr) ClientData clientData; /* Not used. */ CONST char *src; /* Source string (unknown encoding). */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ - Tcl_EncodingState *statePtr;/* Place for conversion routine to store - * state information used during a piecewise + Tcl_EncodingState *statePtr;/* Place for conversion routine to store state + * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ - char *dst; /* Output buffer in which converted string - * is stored. */ + char *dst; /* Output buffer in which converted string is + * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the * source string that were converted. */ int *dstWrotePtr; /* Filled with the number of bytes that were @@ -1868,18 +2039,17 @@ *dst++ = *src++; } return result; } - /* *------------------------------------------------------------------------- * * UtfExtToUtfIntProc -- * - * Convert from UTF-8 to UTF-8. While converting null-bytes from - * the Tcl's internal representation (0xc0, 0x80) to the official + * Convert from UTF-8 to UTF-8. While converting null-bytes from the + * Tcl's internal representation (0xc0, 0x80) to the official * representation (0x00). See UtfToUtfProc for details. * * Results: * Returns TCL_OK if conversion was successful. * @@ -1886,19 +2056,20 @@ * Side effects: * None. * *------------------------------------------------------------------------- */ -static int + +static int UtfIntToUtfExtProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, - srcReadPtr, dstWrotePtr, dstCharsPtr) + srcReadPtr, dstWrotePtr, dstCharsPtr) ClientData clientData; /* Not used. */ CONST char *src; /* Source string in UTF-8. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ - Tcl_EncodingState *statePtr;/* Place for conversion routine to store - * state information used during a piecewise + Tcl_EncodingState *statePtr;/* Place for conversion routine to store state + * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ char *dst; /* Output buffer in which converted string * is stored. */ @@ -1915,11 +2086,11 @@ int *dstCharsPtr; /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ { return UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, - srcReadPtr, dstWrotePtr, dstCharsPtr, 1); + srcReadPtr, dstWrotePtr, dstCharsPtr, 1); } /* *------------------------------------------------------------------------- * @@ -1935,24 +2106,24 @@ * Side effects: * None. * *------------------------------------------------------------------------- */ -static int +static int UtfExtToUtfIntProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, - srcReadPtr, dstWrotePtr, dstCharsPtr) + srcReadPtr, dstWrotePtr, dstCharsPtr) ClientData clientData; /* Not used. */ CONST char *src; /* Source string in UTF-8. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ - Tcl_EncodingState *statePtr;/* Place for conversion routine to store - * state information used during a piecewise + Tcl_EncodingState *statePtr;/* Place for conversion routine to store state + * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ - char *dst; /* Output buffer in which converted string - * is stored. */ + char *dst; /* Output buffer in which converted string is + * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the * source string that were converted. This * may be less than the original source length @@ -1964,21 +2135,21 @@ int *dstCharsPtr; /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ { return UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, - srcReadPtr, dstWrotePtr, dstCharsPtr, 0); + srcReadPtr, dstWrotePtr, dstCharsPtr, 0); } /* *------------------------------------------------------------------------- * * UtfToUtfProc -- * - * Convert from UTF-8 to UTF-8. Note that the UTF-8 to UTF-8 - * translation is not a no-op, because it will turn a stream of - * improperly formed UTF-8 into a properly formed stream. + * Convert from UTF-8 to UTF-8. Note that the UTF-8 to UTF-8 translation + * is not a no-op, because it will turn a stream of improperly formed + * UTF-8 into a properly formed stream. * * Results: * Returns TCL_OK if conversion was successful. * * Side effects: @@ -1985,49 +2156,48 @@ * None. * *------------------------------------------------------------------------- */ -static int +static int UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, - srcReadPtr, dstWrotePtr, dstCharsPtr, pureNullMode) + srcReadPtr, dstWrotePtr, dstCharsPtr, pureNullMode) ClientData clientData; /* Not used. */ CONST char *src; /* Source string in UTF-8. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ - Tcl_EncodingState *statePtr;/* Place for conversion routine to store - * state information used during a piecewise + Tcl_EncodingState *statePtr;/* Place for conversion routine to store state + * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ - char *dst; /* Output buffer in which converted string - * is stored. */ + char *dst; /* Output buffer in which converted string is + * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the - * source string that were converted. This - * may be less than the original source length - * if there was a problem converting some - * source characters. */ + * source string that were converted. This may + * be less than the original source length if + * there was a problem converting some source + * characters. */ int *dstWrotePtr; /* Filled with the number of bytes that were * stored in the output buffer as a result of * the conversion. */ int *dstCharsPtr; /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ - int pureNullMode; /* Convert embedded nulls from - * internal representation to real - * null-bytes or vice versa */ - + int pureNullMode; /* Convert embedded nulls from internal + * representation to real null-bytes or vice + * versa. */ { CONST char *srcStart, *srcEnd, *srcClose; char *dstStart, *dstEnd; int result, numChars; Tcl_UniChar ch; result = TCL_OK; - + srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; if ((flags & TCL_ENCODING_END) == 0) { srcClose -= TCL_UTF_MAX; @@ -2048,23 +2218,23 @@ } if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } - if (UCHAR(*src) < 0x80 && - !(UCHAR(*src) == 0 && pureNullMode == 0)) { + if (UCHAR(*src) < 0x80 && !(UCHAR(*src) == 0 && pureNullMode == 0)) { /* - * Copy 7bit chatacters, but skip null-bytes when we are - * in input mode, so that they get converted to 0xc080. + * Copy 7bit chatacters, but skip null-bytes when we are in input + * mode, so that they get converted to 0xc080. */ + *dst++ = *src++; - } else if (pureNullMode == 1 && - UCHAR(*src) == 0xc0 && - UCHAR(*(src+1)) == 0x80) { - /* + } else if (pureNullMode == 1 && UCHAR(*src) == 0xc0 && + UCHAR(*(src+1)) == 0x80) { + /* * Convert 0xc080 to real nulls when we are in output mode. */ + *dst++ = 0; src += 2; } else { src += Tcl_UtfToUniChar(src, &ch); dst += Tcl_UniCharToUtf(ch, dst); @@ -2091,24 +2261,24 @@ * None. * *------------------------------------------------------------------------- */ -static int +static int UnicodeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) ClientData clientData; /* Not used. */ CONST char *src; /* Source string in Unicode. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ - Tcl_EncodingState *statePtr;/* Place for conversion routine to store - * state information used during a piecewise + Tcl_EncodingState *statePtr;/* Place for conversion routine to store state + * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ - char *dst; /* Output buffer in which converted string - * is stored. */ + char *dst; /* Output buffer in which converted string is + * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the * source string that were converted. This * may be less than the original source length @@ -2122,11 +2292,11 @@ * output buffer. */ { CONST Tcl_UniChar *wSrc, *wSrcStart, *wSrcEnd; char *dstEnd, *dstStart; int result, numChars; - + result = TCL_OK; if ((srcLen % sizeof(Tcl_UniChar)) != 0) { result = TCL_CONVERT_MULTIBYTE; srcLen /= sizeof(Tcl_UniChar); srcLen *= sizeof(Tcl_UniChar); @@ -2143,13 +2313,15 @@ for (numChars = 0; wSrc < wSrcEnd; numChars++) { if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } + /* * Special case for 1-byte utf chars for speed. */ + if (*wSrc && *wSrc < 0x80) { *dst++ = (char) *wSrc; } else { dst += Tcl_UniCharToUtf(*wSrc, dst); } @@ -2176,24 +2348,25 @@ * None. * *------------------------------------------------------------------------- */ -static int +static int UtfToUnicodeProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) - ClientData clientData; /* TableEncodingData that specifies encoding. */ + ClientData clientData; /* TableEncodingData that specifies + * encoding. */ CONST char *src; /* Source string in UTF-8. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ - Tcl_EncodingState *statePtr;/* Place for conversion routine to store - * state information used during a piecewise + Tcl_EncodingState *statePtr;/* Place for conversion routine to store state + * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ - char *dst; /* Output buffer in which converted string - * is stored. */ + char *dst; /* Output buffer in which converted string is + * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the * source string that were converted. This * may be less than the original source length @@ -2207,11 +2380,11 @@ * output buffer. */ { CONST char *srcStart, *srcEnd, *srcClose; Tcl_UniChar *wDst, *wDstStart, *wDstEnd; int result, numChars; - + srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; if ((flags & TCL_ENCODING_END) == 0) { srcClose -= TCL_UTF_MAX; @@ -2233,14 +2406,15 @@ break; } if (wDst > wDstEnd) { result = TCL_CONVERT_NOSPACE; break; - } + } src += TclUtfToUniChar(src, wDst); wDst++; } + *srcReadPtr = src - srcStart; *dstWrotePtr = (char *) wDst - (char *) wDstStart; *dstCharsPtr = numChars; return result; } @@ -2260,25 +2434,25 @@ * None. * *------------------------------------------------------------------------- */ -static int +static int TableToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) ClientData clientData; /* TableEncodingData that specifies * encoding. */ CONST char *src; /* Source string in specified encoding. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ - Tcl_EncodingState *statePtr;/* Place for conversion routine to store - * state information used during a piecewise + Tcl_EncodingState *statePtr;/* Place for conversion routine to store state + * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ - char *dst; /* Output buffer in which converted string - * is stored. */ + char *dst; /* Output buffer in which converted string is + * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the * source string that were converted. This * may be less than the original source length @@ -2296,11 +2470,11 @@ int result, byte, numChars; Tcl_UniChar ch; unsigned short **toUnicode; unsigned short *pageZero; TableEncodingData *dataPtr; - + srcStart = src; srcEnd = src + srcLen; dstStart = dst; dstEnd = dst + dstLen - TCL_UTF_MAX; @@ -2310,14 +2484,14 @@ prefixBytes = dataPtr->prefixBytes; pageZero = toUnicode[0]; result = TCL_OK; for (numChars = 0; src < srcEnd; numChars++) { - if (dst > dstEnd) { - result = TCL_CONVERT_NOSPACE; - break; - } + if (dst > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } byte = *((unsigned char *) src); if (prefixBytes[byte]) { src++; if (src >= srcEnd) { src--; @@ -2344,12 +2518,13 @@ if (ch && ch < 0x80) { *dst++ = (char) ch; } else { dst += Tcl_UniCharToUtf(ch, dst); } - src++; + src++; } + *srcReadPtr = src - srcStart; *dstWrotePtr = dst - dstStart; *dstCharsPtr = numChars; return result; } @@ -2369,25 +2544,25 @@ * None. * *------------------------------------------------------------------------- */ -static int +static int TableFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) ClientData clientData; /* TableEncodingData that specifies * encoding. */ CONST char *src; /* Source string in UTF-8. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ - Tcl_EncodingState *statePtr;/* Place for conversion routine to store - * state information used during a piecewise + Tcl_EncodingState *statePtr;/* Place for conversion routine to store state + * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ - char *dst; /* Output buffer in which converted string - * is stored. */ + char *dst; /* Output buffer in which converted string is + * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the * source string that were converted. This * may be less than the original source length @@ -2404,17 +2579,17 @@ char *dstStart, *dstEnd, *prefixBytes; Tcl_UniChar ch; int result, len, word, numChars; TableEncodingData *dataPtr; unsigned short **fromUnicode; - - result = TCL_OK; + + result = TCL_OK; dataPtr = (TableEncodingData *) clientData; prefixBytes = dataPtr->prefixBytes; fromUnicode = dataPtr->fromUnicode; - + srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; if ((flags & TCL_ENCODING_END) == 0) { srcClose -= TCL_UTF_MAX; @@ -2435,13 +2610,14 @@ } len = TclUtfToUniChar(src, &ch); #if TCL_UTF_MAX > 3 /* - * This prevents a crash condition. More evaluation is required - * for full support of int Tcl_UniChar. [Bug 1004065] + * This prevents a crash condition. More evaluation is required for + * full support of int Tcl_UniChar. [Bug 1004065] */ + if (ch & 0xffff0000) { word = 0; } else #endif word = fromUnicode[(ch >> 8)][ch & 0xff]; @@ -2449,11 +2625,11 @@ if ((word == 0) && (ch != 0)) { if (flags & TCL_ENCODING_STOPONERROR) { result = TCL_CONVERT_UNKNOWN; break; } - word = dataPtr->fallback; + word = dataPtr->fallback; } if (prefixBytes[(word >> 8)] != 0) { if (dst + 1 > dstEnd) { result = TCL_CONVERT_NOSPACE; break; @@ -2466,13 +2642,14 @@ result = TCL_CONVERT_NOSPACE; break; } dst[0] = (char) word; dst++; - } + } src += len; } + *srcReadPtr = src - srcStart; *dstWrotePtr = dst - dstStart; *dstCharsPtr = numChars; return result; } @@ -2480,12 +2657,12 @@ /* *--------------------------------------------------------------------------- * * TableFreeProc -- * - * This procedure is invoked when an encoding is deleted. It deletes - * the memory used by the TableEncodingData. + * This procedure is invoked when an encoding is deleted. It deletes the + * memory used by the TableEncodingData. * * Results: * None. * * Side effects: @@ -2526,25 +2703,25 @@ * None. * *------------------------------------------------------------------------- */ -static int +static int EscapeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) ClientData clientData; /* EscapeEncodingData that specifies * encoding. */ CONST char *src; /* Source string in specified encoding. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ - Tcl_EncodingState *statePtr;/* Place for conversion routine to store - * state information used during a piecewise + Tcl_EncodingState *statePtr;/* Place for conversion routine to store state + * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ - char *dst; /* Output buffer in which converted string - * is stored. */ + char *dst; /* Output buffer in which converted string is + * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the * source string that were converted. This * may be less than the original source length @@ -2586,67 +2763,69 @@ } for (numChars = 0; src < srcEnd; ) { int byte, hi, lo, ch; - if (dst > dstEnd) { - result = TCL_CONVERT_NOSPACE; - break; - } + if (dst > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } byte = *((unsigned char *) src); if (prefixBytes[byte]) { unsigned int left, len, longest; int checked, i; EscapeSubTable *subTablePtr; - + /* - * Saw the beginning of an escape sequence. + * Saw the beginning of an escape sequence. */ - + left = srcEnd - src; len = dataPtr->initLen; longest = len; checked = 0; + if (len <= left) { checked++; - if ((len > 0) && - (memcmp(src, dataPtr->init, len) == 0)) { + if ((len > 0) && (memcmp(src, dataPtr->init, len) == 0)) { /* * If we see initialization string, skip it, even if we're - * not at the beginning of the buffer. + * not at the beginning of the buffer. */ - + src += len; continue; } } + len = dataPtr->finalLen; if (len > longest) { longest = len; } + if (len <= left) { checked++; - if ((len > 0) && - (memcmp(src, dataPtr->final, len) == 0)) { + if ((len > 0) && (memcmp(src, dataPtr->final, len) == 0)) { /* * If we see finalization string, skip it, even if we're - * not at the end of the buffer. + * not at the end of the buffer. */ - + src += len; continue; } } + subTablePtr = dataPtr->subTables; for (i = 0; i < dataPtr->numSubTables; i++) { len = subTablePtr->sequenceLen; if (len > longest) { longest = len; } if (len <= left) { checked++; - if ((len > 0) && + if ((len > 0) && (memcmp(src, subTablePtr->sequence, len) == 0)) { state = i; encodingPtr = NULL; subTablePtr = NULL; src += len; @@ -2653,10 +2832,11 @@ break; } } subTablePtr++; } + if (subTablePtr == NULL) { /* * A match was found, the escape sequence was consumed, and * the state was updated. */ @@ -2664,12 +2844,12 @@ continue; } /* * We have a split-up or unrecognized escape sequence. If we - * checked all the sequences, then it's a syntax error, - * otherwise we need more bytes to determine a match. + * checked all the sequences, then it's a syntax error, otherwise + * we need more bytes to determine a match. */ if ((checked == dataPtr->numSubTables + 2) || (flags & TCL_ENCODING_END)) { if ((flags & TCL_ENCODING_STOPONERROR) == 0) { @@ -2693,10 +2873,11 @@ encodingPtr = GetTableEncoding(dataPtr, state); tableDataPtr = (TableEncodingData *) encodingPtr->clientData; tablePrefixBytes = tableDataPtr->prefixBytes; tableToUnicode = tableDataPtr->toUnicode; } + if (tablePrefixBytes[byte]) { src++; if (src >= srcEnd) { src--; result = TCL_CONVERT_MULTIBYTE; @@ -2706,10 +2887,11 @@ lo = *((unsigned char *) src); } else { hi = 0; lo = byte; } + ch = tableToUnicode[hi][lo]; dst += Tcl_UniCharToUtf(ch, dst); src++; numChars++; } @@ -2736,32 +2918,32 @@ * None. * *------------------------------------------------------------------------- */ -static int +static int EscapeFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) ClientData clientData; /* EscapeEncodingData that specifies * encoding. */ CONST char *src; /* Source string in UTF-8. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ - Tcl_EncodingState *statePtr;/* Place for conversion routine to store - * state information used during a piecewise + Tcl_EncodingState *statePtr;/* Place for conversion routine to store state + * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ - char *dst; /* Output buffer in which converted string - * is stored. */ + char *dst; /* Output buffer in which converted string is + * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the - * source string that were converted. This - * may be less than the original source length - * if there was a problem converting some - * source characters. */ + * source string that were converted. This may + * be less than the original source length if + * there was a problem converting some source + * characters. */ int *dstWrotePtr; /* Filled with the number of bytes that were * stored in the output buffer as a result of * the conversion. */ int *dstCharsPtr; /* Filled with the number of characters that * correspond to the bytes stored in the @@ -2773,12 +2955,12 @@ char *dstStart, *dstEnd; int state, result, numChars; TableEncodingData *tableDataPtr; char *tablePrefixBytes; unsigned short **tableFromUnicode; - - result = TCL_OK; + + result = TCL_OK; dataPtr = (EscapeEncodingData *) clientData; srcStart = src; srcEnd = src + srcLen; @@ -2800,15 +2982,14 @@ if (dst + dataPtr->initLen > dstEnd) { *srcReadPtr = 0; *dstWrotePtr = 0; return TCL_CONVERT_NOSPACE; } - memcpy((VOID *) dst, (VOID *) dataPtr->init, - (size_t) dataPtr->initLen); + memcpy((VOID *)dst, (VOID *)dataPtr->init, (size_t)dataPtr->initLen); dst += dataPtr->initLen; } else { - state = (int) *statePtr; + state = (int) *statePtr; } encodingPtr = GetTableEncoding(dataPtr, state); tableDataPtr = (TableEncodingData *) encodingPtr->clientData; tablePrefixBytes = tableDataPtr->prefixBytes; @@ -2816,11 +2997,11 @@ for (numChars = 0; src < srcEnd; numChars++) { unsigned int len; int word; Tcl_UniChar ch; - + if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { /* * If there is more string to follow, this will ensure that the * last UTF-8 character in the source buffer hasn't been cut off. */ @@ -2832,11 +3013,11 @@ word = tableFromUnicode[(ch >> 8)][ch & 0xff]; if ((word == 0) && (ch != 0)) { int oldState; EscapeSubTable *subTablePtr; - + oldState = state; for (state = 0; state < dataPtr->numSubTables; state++) { encodingPtr = GetTableEncoding(dataPtr, state); tableDataPtr = (TableEncodingData *) encodingPtr->clientData; word = tableDataPtr->fromUnicode[(ch >> 8)][ch & 0xff]; @@ -2852,29 +3033,31 @@ break; } encodingPtr = GetTableEncoding(dataPtr, state); tableDataPtr = (TableEncodingData *) encodingPtr->clientData; word = tableDataPtr->fallback; - } - + } + tablePrefixBytes = tableDataPtr->prefixBytes; tableFromUnicode = tableDataPtr->fromUnicode; /* * The state variable has the value of oldState when word is 0. - * In this case, the escape sequense should not be copied to dst + * In this case, the escape sequense should not be copied to dst * because the current character set is not changed. */ + if (state != oldState) { subTablePtr = &dataPtr->subTables[state]; if ((dst + subTablePtr->sequenceLen) > dstEnd) { /* * If there is no space to write the escape sequence, the * state variable must be changed to the value of oldState * variable because this escape sequence must be written * in the next conversion. */ + state = oldState; result = TCL_CONVERT_NOSPACE; break; } memcpy((VOID *) dst, (VOID *) subTablePtr->sequence, @@ -2896,11 +3079,11 @@ result = TCL_CONVERT_NOSPACE; break; } dst[0] = (char) word; dst++; - } + } src += len; } if ((result == TCL_OK) && (flags & TCL_ENCODING_END)) { unsigned int len = dataPtr->subTables[0].sequenceLen; @@ -2928,11 +3111,11 @@ /* *--------------------------------------------------------------------------- * * EscapeFreeProc -- * - * This procedure is invoked when an EscapeEncodingData encoding is + * This procedure is invoked when an EscapeEncodingData encoding is * deleted. It deletes the memory used by the encoding. * * Results: * None. * @@ -2973,13 +3156,13 @@ * * Results: * The return value is the encoding. * * Side effects: - * If the encoding that represents the specified state has not - * already been used by this EscapeEncoding, it will be loaded - * and cached in the dataPtr. + * If the encoding that represents the specified state has not already + * been used by this EscapeEncoding, it will be loaded and cached in the + * dataPtr. * *--------------------------------------------------------------------------- */ static Encoding * @@ -2987,32 +3170,34 @@ EscapeEncodingData *dataPtr;/* Contains names of encodings. */ int state; /* Index in dataPtr of desired Encoding. */ { EscapeSubTable *subTablePtr; Encoding *encodingPtr; - + subTablePtr = &dataPtr->subTables[state]; encodingPtr = subTablePtr->encodingPtr; + if (encodingPtr == NULL) { encodingPtr = (Encoding *) Tcl_GetEncoding(NULL, subTablePtr->name); - if ((encodingPtr == NULL) + if ((encodingPtr == NULL) || (encodingPtr->toUtfProc != TableToUtfProc)) { Tcl_Panic("EscapeToUtfProc: invalid sub table"); } subTablePtr->encodingPtr = encodingPtr; } + return encodingPtr; } /* *--------------------------------------------------------------------------- * * unilen -- * - * A helper function for the Tcl_ExternalToUtf functions. This - * function is similar to strlen for double-byte characters: it - * returns the number of bytes in a 0x0000 terminated string. + * A helper function for the Tcl_ExternalToUtf functions. This function + * is similar to strlen for double-byte characters: it returns the number + * of bytes in a 0x0000 terminated string. * * Results: * As above. * * Side effects: @@ -3037,32 +3222,31 @@ /* *------------------------------------------------------------------------- * * InitializeEncodingSearchPath -- * - * This is the fallback routine that sets the default value - * of the encoding search path if the application has not set - * one via a call to TclSetEncodingSearchPath() by the first - * time the search path is needed to load encoding data. - * - * The default encoding search path is produced by taking each - * directory in the library path, appending a subdirectory - * named "encoding", and if the resulting directory exists, - * adding it to the encoding search path. + * This is the fallback routine that sets the default value of the + * encoding search path if the application has not set one via a call to + * TclSetEncodingSearchPath() by the first time the search path is needed + * to load encoding data. + * + * The default encoding search path is produced by taking each directory + * in the library path, appending a subdirectory named "encoding", and if + * the resulting directory exists, adding it to the encoding search path. * * Results: * None. * * Side effects: - * Sets the encoding search path to an initial value. + * Sets the encoding search path to an initial value. * *------------------------------------------------------------------------- */ -void +static void InitializeEncodingSearchPath(valuePtr, lengthPtr, encodingPtr) - char **valuePtr; + char **valuePtr; int *lengthPtr; Tcl_Encoding *encodingPtr; { char *bytes; int i, numDirs, numBytes; @@ -3072,69 +3256,40 @@ Tcl_IncrRefCount(encodingObj); Tcl_IncrRefCount(searchPath); libPath = TclGetLibraryPath(); Tcl_IncrRefCount(libPath); Tcl_ListObjLength(NULL, libPath, &numDirs); + for (i = 0; i < numDirs; i++) { Tcl_Obj *directory, *path; Tcl_StatBuf stat; Tcl_ListObjIndex(NULL, libPath, i, &directory); - path = Tcl_FSJoinToPath(directory, 1, &encodingObj); + path = Tcl_FSJoinToPath(directory, 1, &encodingObj); Tcl_IncrRefCount(path); if ((0 == Tcl_FSStat(path, &stat)) && S_ISDIR(stat.st_mode)) { Tcl_ListObjAppendElement(NULL, searchPath, path); } - Tcl_IncrRefCount(path); + Tcl_DecrRefCount(path); } + Tcl_DecrRefCount(libPath); Tcl_DecrRefCount(encodingObj); *encodingPtr = libraryPath.encoding; if (*encodingPtr) { ((Encoding *)(*encodingPtr))->refCount++; } bytes = Tcl_GetStringFromObj(searchPath, &numBytes); + *lengthPtr = numBytes; *valuePtr = ckalloc((unsigned int) numBytes + 1); memcpy((VOID *) *valuePtr, (VOID *) bytes, (size_t) numBytes + 1); Tcl_DecrRefCount(searchPath); } /* - *------------------------------------------------------------------------- - * - * InitializeEncodingFileMap -- - * - * This is the fallback routine that fills the encoding data - * file map if the application has not set up an encoding - * search path by the first time the file map is needed to - * load encoding data. - * - * Results: - * None. - * - * Side effects: - * Fills the encoding data file map. - * - *------------------------------------------------------------------------- + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: */ - -void -InitializeEncodingFileMap(valuePtr, lengthPtr, encodingPtr) - char **valuePtr; - int *lengthPtr; - Tcl_Encoding *encodingPtr; -{ - char *bytes; - int numBytes; - Tcl_Obj *map = MakeFileMap(); - - *encodingPtr = encodingSearchPath.encoding; - if (*encodingPtr) { - ((Encoding *)(*encodingPtr))->refCount++; - } - bytes = Tcl_GetStringFromObj(map, &numBytes); - *lengthPtr = numBytes; - *valuePtr = ckalloc((unsigned int) numBytes + 1); - memcpy((VOID *) *valuePtr, (VOID *) bytes, (size_t) numBytes + 1); - Tcl_DecrRefCount(map); -} Index: generic/tclEnv.c ================================================================== --- generic/tclEnv.c +++ generic/tclEnv.c @@ -1,20 +1,20 @@ -/* +/* * tclEnv.c -- * - * Tcl support for environment variables, including a setenv - * procedure. This file contains the generic portion of the - * environment module. It is primarily responsible for keeping - * the "env" arrays in sync with the system environment variables. + * Tcl support for environment variables, including a setenv function. + * This file contains the generic portion of the environment module. It + * is primarily responsible for keeping the "env" arrays in sync with the + * system environment variables. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclEnv.c,v 1.22 2004/04/06 22:25:50 dgp Exp $ + * RCS: @(#) $Id: tclEnv.c,v 1.22.2.3 2005/10/08 13:44:37 dgp Exp $ */ #include "tclInt.h" TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ */ @@ -23,10 +23,15 @@ static char **environCache = NULL; /* Array containing all of the environment * strings that Tcl has allocated. */ #ifndef USE_PUTENV +static char **ourEnviron = NULL;/* Cache of the array that we allocate. + * We need to track this in case another + * subsystem swaps around the environ array + * like we do. + */ static int environSize = 0; /* Non-zero means that the environ array was * malloced and has this many total entries * allocated to it (not all may be in use at * once). Zero means that the environment * array is in its original static state. */ @@ -39,15 +44,15 @@ #include char **environ = NULL; #endif /* - * Declarations for local procedures defined in this file: + * Declarations for local functions defined in this file: */ static char * EnvTraceProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, CONST char *name1, + Tcl_Interp *interp, CONST char *name1, CONST char *name2, int flags)); static void ReplaceString _ANSI_ARGS_((CONST char *oldStr, char *newStr)); void TclSetEnv _ANSI_ARGS_((CONST char *name, CONST char *value)); @@ -60,24 +65,23 @@ /* *---------------------------------------------------------------------- * * TclSetupEnv -- * - * This procedure is invoked for an interpreter to make environment - * variables accessible from that interpreter via the "env" - * associative array. + * This function is invoked for an interpreter to make environment + * variables accessible from that interpreter via the "env" associative + * array. * * Results: * None. * * Side effects: - * The interpreter is added to a list of interpreters managed - * by us, so that its view of envariables can be kept consistent - * with the view in other interpreters. If this is the first - * call to TclSetupEnv, then additional initialization happens, - * such as copying the environment to dynamically-allocated space - * for ease of management. + * The interpreter is added to a list of interpreters managed by us, so + * that its view of envariables can be kept consistent with the view in + * other interpreters. If this is the first call to TclSetupEnv, then + * additional initialization happens, such as copying the environment to + * dynamically-allocated space for ease of management. * *---------------------------------------------------------------------- */ void @@ -95,32 +99,32 @@ #if defined(__APPLE__) && defined(__DYNAMIC__) environ = *_NSGetEnviron(); #endif /* - * Synchronize the values in the environ array with the contents - * of the Tcl "env" variable. To do this: + * Synchronize the values in the environ array with the contents of the + * Tcl "env" variable. To do this: * 1) Remove the trace that fires when the "env" var is unset. * 2) Unset the "env" variable. - * 3) If there are no environ variables, create an empty "env" - * array. Otherwise populate the array with current values. + * 3) If there are no environ variables, create an empty "env" array. + * Otherwise populate the array with current values. * 4) Add a trace that synchronizes the "env" array. */ - + Tcl_UntraceVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, (ClientData) NULL); - - Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY); - + + Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY); + if (environ[0] == NULL) { Tcl_Obj *varNamePtr; - + varNamePtr = Tcl_NewStringObj("env", -1); Tcl_IncrRefCount(varNamePtr); - TclArraySet(interp, varNamePtr, NULL); + TclArraySet(interp, varNamePtr, NULL); Tcl_DecrRefCount(varNamePtr); } else { Tcl_MutexLock(&envMutex); for (i = 0; environ[i] != NULL; i++) { p1 = Tcl_ExternalToUtfDString(NULL, environ[i], -1, &envString); @@ -128,16 +132,16 @@ if (p2 == NULL) { /* * This condition seem to happen occasionally under some * versions of Solaris; ignore the entry. */ - + continue; } p2++; p2[-1] = '\0'; - Tcl_SetVar2(interp, "env", p1, p2, TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "env", p1, p2, TCL_GLOBAL_ONLY); Tcl_DStringFree(&envString); } Tcl_MutexUnlock(&envMutex); } @@ -150,16 +154,16 @@ /* *---------------------------------------------------------------------- * * TclSetEnv -- * - * Set an environment variable, replacing an existing value - * or creating a new variable if there doesn't exist a variable - * by the given name. This procedure is intended to be a - * stand-in for the UNIX "setenv" procedure so that applications - * using that procedure will interface properly to Tcl. To make - * it a stand-in, the Makefile must define "TclSetEnv" to "setenv". + * Set an environment variable, replacing an existing value or creating a + * new variable if there doesn't exist a variable by the given name. + * This function is intended to be a stand-in for the UNIX "setenv" + * function so that applications using that function will interface + * properly to Tcl. To make it a stand-in, the Makefile must define + * "TclSetEnv" to "setenv". * * Results: * None. * * Side effects: @@ -168,63 +172,68 @@ *---------------------------------------------------------------------- */ void TclSetEnv(name, value) - CONST char *name; /* Name of variable whose value is to be - * set (UTF-8). */ + CONST char *name; /* Name of variable whose value is to be set + * (UTF-8). */ CONST char *value; /* New value for variable (UTF-8). */ { Tcl_DString envString; int index, length, nameLength; char *p, *oldValue; CONST char *p2; /* - * Figure out where the entry is going to go. If the name doesn't - * already exist, enlarge the array if necessary to make room. If the - * name exists, free its old entry. + * Figure out where the entry is going to go. If the name doesn't already + * exist, enlarge the array if necessary to make room. If the name exists, + * free its old entry. */ Tcl_MutexLock(&envMutex); index = TclpFindVariable(name, &length); if (index == -1) { #ifndef USE_PUTENV - if ((length + 2) > environSize) { + /* + * We need to handle the case where the environment may be changed + * outside our control. environSize is only valid if the current + * environment is the one we allocated. [Bug 979640] + */ + if ((ourEnviron != environ) || ((length + 2) > environSize)) { char **newEnviron; newEnviron = (char **) ckalloc((unsigned) ((length + 5) * sizeof(char *))); memcpy((VOID *) newEnviron, (VOID *) environ, length*sizeof(char *)); - if (environSize != 0) { - ckfree((char *) environ); + if ((environSize != 0) && (ourEnviron != NULL)) { + ckfree((char *) ourEnviron); } - environ = newEnviron; + environ = ourEnviron = newEnviron; environSize = length + 5; #if defined(__APPLE__) && defined(__DYNAMIC__) { - char ***e = _NSGetEnviron(); - *e = environ; + char ***e = _NSGetEnviron(); + *e = environ; } -#endif +#endif /* __APPLE__ && __DYNAMIC__ */ } index = length; environ[index + 1] = NULL; -#endif +#endif /* USE_PUTENV */ oldValue = NULL; nameLength = strlen(name); } else { CONST char *env; /* - * Compare the new value to the existing value. If they're - * the same then quit immediately (e.g. don't rewrite the - * value or propagate it to other interpreters). Otherwise, - * when there are N interpreters there will be N! propagations - * of the same value among the interpreters. + * Compare the new value to the existing value. If they're the same + * then quit immediately (e.g. don't rewrite the value or propagate it + * to other interpreters). Otherwise, when there are N interpreters + * there will be N! propagations of the same value among the + * interpreters. */ env = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envString); if (strcmp(value, (env + length + 1)) == 0) { Tcl_DStringFree(&envString); @@ -234,16 +243,15 @@ Tcl_DStringFree(&envString); oldValue = environ[index]; nameLength = length; } - /* - * Create a new entry. Build a complete UTF string that contains - * a "name=value" pattern. Then convert the string to the native - * encoding, and set the environ array value. + * Create a new entry. Build a complete UTF string that contains a + * "name=value" pattern. Then convert the string to the native encoding, + * and set the environ array value. */ p = (char *) ckalloc((unsigned) (nameLength + strlen(value) + 2)); strcpy(p, name); p[nameLength] = '='; @@ -251,11 +259,11 @@ p2 = Tcl_UtfToExternalDString(NULL, p, -1, &envString); /* * Copy the native string to heap memory. */ - + p = (char *) ckrealloc(p, (unsigned) (strlen(p2) + 1)); strcpy(p, p2); Tcl_DStringFree(&envString); #ifdef USE_PUTENV @@ -268,79 +276,80 @@ #else environ[index] = p; #endif /* - * Watch out for versions of putenv that copy the string (e.g. VC++). - * In this case we need to free the string immediately. Otherwise - * update the string in the cache. + * Watch out for versions of putenv that copy the string (e.g. VC++). In + * this case we need to free the string immediately. Otherwise update the + * string in the cache. */ if ((index != -1) && (environ[index] == p)) { ReplaceString(oldValue, p); #ifdef HAVE_PUTENV_THAT_COPIES } else { - /* This putenv() copies instead of taking ownership */ + /* + * This putenv() copies instead of taking ownership. + */ + ckfree(p); #endif } Tcl_MutexUnlock(&envMutex); - + if (!strcmp(name, "HOME")) { - /* - * If the user's home directory has changed, we must invalidate - * the filesystem cache, because '~' expansions will now be - * incorrect. + /* + * If the user's home directory has changed, we must invalidate the + * filesystem cache, because '~' expansions will now be incorrect. */ - Tcl_FSMountsChanged(NULL); + + Tcl_FSMountsChanged(NULL); } } /* *---------------------------------------------------------------------- * * Tcl_PutEnv -- * - * Set an environment variable. Similar to setenv except that - * the information is passed in a single string of the form - * NAME=value, rather than as separate name strings. This procedure - * is intended to be a stand-in for the UNIX "putenv" procedure - * so that applications using that procedure will interface - * properly to Tcl. To make it a stand-in, the Makefile will - * define "Tcl_PutEnv" to "putenv". + * Set an environment variable. Similar to setenv except that the + * information is passed in a single string of the form NAME=value, + * rather than as separate name strings. This function is intended to be + * a stand-in for the UNIX "putenv" function so that applications using + * that function will interface properly to Tcl. To make it a stand-in, + * the Makefile will define "Tcl_PutEnv" to "putenv". * * Results: * None. * * Side effects: - * The environ array gets updated, as do all of the interpreters - * that we manage. + * The environ array gets updated, as do all of the interpreters that we + * manage. * *---------------------------------------------------------------------- */ int -Tcl_PutEnv(string) - CONST char *string; /* Info about environment variable in the - * form NAME=value. (native) */ +Tcl_PutEnv(assignment) + CONST char *assignment; /* Info about environment variable in the form + * NAME=value. (native) */ { - Tcl_DString nameString; + Tcl_DString nameString; CONST char *name; char *value; - if (string == NULL) { + if (assignment == NULL) { return 0; } /* - * First convert the native string to UTF. Then separate the - * string into name and value parts, and call TclSetEnv to do - * all of the real work. + * First convert the native string to UTF. Then separate the string into + * name and value parts, and call TclSetEnv to do all of the real work. */ - name = Tcl_ExternalToUtfDString(NULL, string, -1, &nameString); + name = Tcl_ExternalToUtfDString(NULL, assignment, -1, &nameString); value = strchr(name, '='); if ((value != NULL) && (value != name)) { value[0] = '\0'; TclSetEnv(name, value+1); @@ -353,15 +362,14 @@ /* *---------------------------------------------------------------------- * * TclUnsetEnv -- * - * Remove an environment variable, updating the "env" arrays - * in all interpreters managed by us. This function is intended - * to replace the UNIX "unsetenv" function (but to do this the - * Makefile must be modified to redefine "TclUnsetEnv" to - * "unsetenv". + * Remove an environment variable, updating the "env" arrays in all + * interpreters managed by us. This function is intended to replace the + * UNIX "unsetenv" function (but to do this the Makefile must be modified + * to redefine "TclUnsetEnv" to "unsetenv". * * Results: * None. * * Side effects: @@ -375,11 +383,11 @@ CONST char *name; /* Name of variable to remove (UTF-8). */ { char *oldValue; int length; int index; -#ifdef USE_PUTENV +#ifdef USE_PUTENV_FOR_UNSET Tcl_DString envString; char *string; #else char **envPtr; #endif @@ -386,14 +394,14 @@ Tcl_MutexLock(&envMutex); index = TclpFindVariable(name, &length); /* - * First make sure that the environment variable exists to avoid - * doing needless work and to avoid recursion on the unset. + * First make sure that the environment variable exists to avoid doing + * needless work and to avoid recursion on the unset. */ - + if (index == -1) { Tcl_MutexUnlock(&envMutex); return; } /* @@ -401,38 +409,51 @@ */ oldValue = environ[index]; /* - * Update the system environment. This must be done before we - * update the interpreters or we will recurse. + * Update the system environment. This must be done before we update the + * interpreters or we will recurse. + */ + +#ifdef USE_PUTENV_FOR_UNSET + /* + * For those platforms that support putenv to unset, Linux indicates + * that no = should be included, and Windows requires it. */ - -#ifdef USE_PUTENV +#ifdef WIN32 string = ckalloc((unsigned int) length+2); memcpy((VOID *) string, (VOID *) name, (size_t) length); string[length] = '='; string[length+1] = '\0'; - +#else + string = ckalloc((unsigned int) length+1); + memcpy((VOID *) string, (VOID *) name, (size_t) length); + string[length] = '\0'; +#endif + Tcl_UtfToExternalDString(NULL, string, -1, &envString); string = ckrealloc(string, (unsigned) (Tcl_DStringLength(&envString)+1)); strcpy(string, Tcl_DStringValue(&envString)); Tcl_DStringFree(&envString); putenv(string); /* - * Watch out for versions of putenv that copy the string (e.g. VC++). - * In this case we need to free the string immediately. Otherwise - * update the string in the cache. + * Watch out for versions of putenv that copy the string (e.g. VC++). In + * this case we need to free the string immediately. Otherwise update the + * string in the cache. */ if (environ[index] == string) { ReplaceString(oldValue, string); #ifdef HAVE_PUTENV_THAT_COPIES } else { - /* This putenv() copies instead of taking ownership */ + /* + * This putenv() copies instead of taking ownership. + */ + ckfree(string); #endif } #else for (envPtr = environ+index+1; ; envPtr++) { @@ -454,14 +475,14 @@ * * Retrieve the value of an environment variable. * * Results: * The result is a pointer to a string specifying the value of the - * environment variable, or NULL if that environment variable does - * not exist. Storage for the result string is allocated in valuePtr; - * the caller must call Tcl_DStringFree() when the result is no - * longer needed. + * environment variable, or NULL if that environment variable does not + * exist. Storage for the result string is allocated in valuePtr; the + * caller must call Tcl_DStringFree() when the result is no longer + * needed. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -469,12 +490,12 @@ CONST char * TclGetEnv(name, valuePtr) CONST char *name; /* Name of environment variable to find * (UTF-8). */ - Tcl_DString *valuePtr; /* Uninitialized or free DString in which - * the value of the environment variable is + Tcl_DString *valuePtr; /* Uninitialized or free DString in which the + * value of the environment variable is * stored. */ { int length, index; CONST char *result; @@ -481,11 +502,11 @@ Tcl_MutexLock(&envMutex); index = TclpFindVariable(name, &length); result = NULL; if (index != -1) { Tcl_DString envStr; - + result = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envStr); result += length; if (*result == '=') { result++; Tcl_DStringInit(valuePtr); @@ -503,35 +524,34 @@ /* *---------------------------------------------------------------------- * * EnvTraceProc -- * - * This procedure is invoked whenever an environment variable - * is read, modified or deleted. It propagates the change to the global - * "environ" array. + * This function is invoked whenever an environment variable is read, + * modified or deleted. It propagates the change to the global "environ" + * array. * * Results: * Always returns NULL to indicate success. * * Side effects: - * Environment variable changes get propagated. If the whole - * "env" array is deleted, then we stop managing things for - * this interpreter (usually this happens because the whole - * interpreter is being deleted). + * Environment variable changes get propagated. If the whole "env" array + * is deleted, then we stop managing things for this interpreter (usually + * this happens because the whole interpreter is being deleted). * *---------------------------------------------------------------------- */ /* ARGSUSED */ static char * EnvTraceProc(clientData, interp, name1, name2, flags) ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Interpreter whose "env" variable is - * being modified. */ + Tcl_Interp *interp; /* Interpreter whose "env" variable is being + * modified. */ CONST char *name1; /* Better be "env". */ - CONST char *name2; /* Name of variable being modified, or NULL - * if whole array is being deleted (UTF-8). */ + CONST char *name2; /* Name of variable being modified, or NULL if + * whole array is being deleted (UTF-8). */ int flags; /* Indicates what's happening. */ { /* * For array traces, let TclSetupEnv do all the work. */ @@ -542,11 +562,11 @@ } /* * If name2 is NULL, then return and do nothing. */ - + if (name2 == NULL) { return NULL; } /* @@ -553,11 +573,11 @@ * If a value is being set, call TclSetEnv to do all of the work. */ if (flags & TCL_TRACE_WRITES) { CONST char *value; - + value = Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY); TclSetEnv(name2, value); } /* @@ -589,13 +609,13 @@ /* *---------------------------------------------------------------------- * * ReplaceString -- * - * Replace one string with another in the environment variable - * cache. The cache keeps track of all of the environment - * variables that Tcl has modified so they can be freed later. + * Replace one string with another in the environment variable cache. + * The cache keeps track of all of the environment variables that Tcl has + * modified so they can be freed later. * * Results: * None. * * Side effects: @@ -611,14 +631,14 @@ { int i; char **newCache; /* - * Check to see if the old value was allocated by Tcl. If so, - * it needs to be deallocated to avoid memory leaks. Note that this - * algorithm is O(n), not O(1). This will result in n-squared behavior - * if lots of environment changes are being made. + * Check to see if the old value was allocated by Tcl. If so, it needs to + * be deallocated to avoid memory leaks. Note that this algorithm is O(n), + * not O(1). This will result in n-squared behavior if lots of environment + * changes are being made. */ for (i = 0; i < cacheSize; i++) { if ((environCache[i] == oldStr) || (environCache[i] == NULL)) { break; @@ -630,29 +650,29 @@ */ if (environCache[i]) { ckfree(environCache[i]); } - + if (newStr) { environCache[i] = newStr; } else { for (; i < cacheSize-1; i++) { environCache[i] = environCache[i+1]; } environCache[cacheSize-1] = NULL; } - } else { - int allocatedSize = (cacheSize + 5) * sizeof(char *); + } else { + int allocatedSize = (cacheSize + 5) * sizeof(char *); /* * We need to grow the cache in order to hold the new string. */ newCache = (char **) ckalloc((unsigned) allocatedSize); - (VOID *) memset(newCache, (int) 0, (size_t) allocatedSize); - + (VOID *) memset(newCache, (int) 0, (size_t) allocatedSize); + if (environCache) { memcpy((VOID *) newCache, (VOID *) environCache, (size_t) (cacheSize * sizeof(char*))); ckfree((char *) environCache); } @@ -666,13 +686,13 @@ /* *---------------------------------------------------------------------- * * TclFinalizeEnvironment -- * - * This function releases any storage allocated by this module - * that isn't still in use by the global environment. Any - * strings that are still in the environment will be leaked. + * This function releases any storage allocated by this module that isn't + * still in use by the global environment. Any strings that are still in + * the environment will be leaked. * * Results: * None. * * Side effects: @@ -684,22 +704,22 @@ void TclFinalizeEnvironment() { /* * For now we just deallocate the cache array and none of the environment - * strings. This may leak more memory that strictly necessary, since some - * of the strings may no longer be in the environment. However, + * strings. This may leak more memory that strictly necessary, since some + * of the strings may no longer be in the environment. However, * determining which ones are ok to delete is n-squared, and is pretty * unlikely, so we don't bother. */ if (environCache) { ckfree((char *) environCache); environCache = NULL; - cacheSize = 0; + cacheSize = 0; #ifndef USE_PUTENV - environSize = 0; + environSize = 0; #endif } } #if defined(__CYGWIN__) && defined(__WIN32__) @@ -717,30 +737,37 @@ TclCygwinPutenv(str) const char *str; { char *name, *value; - /* Get the name and value, so that we can change the environment - variable for Windows. */ - name = (char *) alloca (strlen (str) + 1); - strcpy (name, str); - for (value = name; *value != '=' && *value != '\0'; ++value) - ; + /* + * Get the name and value, so that we can change the environment variable + * for Windows. + */ + + name = (char *) alloca(strlen(str) + 1); + strcpy(name, str); + for (value=name ; *value!='=' && *value!='\0' ; ++value) { + /* Empty body */ + } if (*value == '\0') { - /* Can't happen. */ - return; - } + /* Can't happen. */ + return; + } *value = '\0'; ++value; if (*value == '\0') { value = NULL; } - /* Set the cygwin environment variable. */ + /* + * Set the cygwin environment variable. + */ + #undef putenv if (value == NULL) { - unsetenv (name); + unsetenv(name); } else { putenv(str); } /* @@ -749,36 +776,51 @@ * * FIXME: The calling program may know it is running under windows, and * may have set the path to a Windows path, or, worse, appended or * prepended a Windows path to PATH. */ - if (strcmp (name, "PATH") != 0) { - /* If this is Path, eliminate any PATH variable, to prevent any - confusion. */ - if (strcmp (name, "Path") == 0) { - SetEnvironmentVariable ("PATH", (char *) NULL); - unsetenv ("PATH"); + + if (strcmp(name, "PATH") != 0) { + /* + * If this is Path, eliminate any PATH variable, to prevent any + * confusion. + */ + + if (strcmp(name, "Path") == 0) { + SetEnvironmentVariable("PATH", (char *) NULL); + unsetenv("PATH"); } - SetEnvironmentVariable (name, value); + SetEnvironmentVariable(name, value); } else { char *buf; - /* Eliminate any Path variable, to prevent any confusion. */ - SetEnvironmentVariable ("Path", (char *) NULL); - unsetenv ("Path"); + /* + * Eliminate any Path variable, to prevent any confusion. + */ + + SetEnvironmentVariable("Path", (char *) NULL); + unsetenv("Path"); if (value == NULL) { buf = NULL; } else { int size; - size = cygwin_posix_to_win32_path_list_buf_size (value); - buf = (char *) alloca (size + 1); - cygwin_posix_to_win32_path_list (value, buf); + size = cygwin_posix_to_win32_path_list_buf_size(value); + buf = (char *) alloca(size + 1); + cygwin_posix_to_win32_path_list(value, buf); } - SetEnvironmentVariable (name, buf); + SetEnvironmentVariable(name, buf); } } #endif /* __CYGWIN__ && __WIN32__ */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclEvent.c ================================================================== --- generic/tclEvent.c +++ generic/tclEvent.c @@ -1,45 +1,44 @@ /* * tclEvent.c -- * * This file implements some general event related interfaces including - * background errors, exit handlers, and the "vwait" and "update" - * command procedures. + * background errors, exit handlers, and the "vwait" and "update" command + * procedures. * * Copyright (c) 1990-1994 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 2004 by Zoran Vasiljevic. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclEvent.c,v 1.54 2004/12/01 23:18:50 dgp Exp $ + * RCS: @(#) $Id: tclEvent.c,v 1.54.2.8 2005/08/25 15:46:30 dgp Exp $ */ #include "tclInt.h" /* - * The data structure below is used to report background errors. One - * such structure is allocated for each error; it holds information - * about the interpreter and the error until an idle handler command - * can be invoked. + * The data structure below is used to report background errors. One such + * structure is allocated for each error; it holds information about the + * interpreter and the error until an idle handler command can be invoked. */ typedef struct BgError { Tcl_Obj *errorMsg; /* Copy of the error message (the interp's * result when the error occurred). */ - Tcl_Obj *returnOpts; /* Active return options when the - * error occurred */ - struct BgError *nextPtr; /* Next in list of all pending error - * reports for this interpreter, or NULL - * for end of list. */ + Tcl_Obj *returnOpts; /* Active return options when the error + * occurred */ + struct BgError *nextPtr; /* Next in list of all pending error reports + * for this interpreter, or NULL for end of + * list. */ } BgError; /* - * One of the structures below is associated with the "tclBgError" - * assoc data for each interpreter. It keeps track of the head and - * tail of the list of pending background errors for the interpreter. + * One of the structures below is associated with the "tclBgError" assoc data + * for each interpreter. It keeps track of the head and tail of the list of + * pending background errors for the interpreter. */ typedef struct ErrAssocData { Tcl_Interp *interp; /* Interpreter in which error occurred. */ Tcl_Obj *cmdPrefix; /* First word(s) of the handler command */ @@ -57,30 +56,29 @@ */ typedef struct ExitHandler { Tcl_ExitProc *proc; /* Procedure to call when process exits. */ ClientData clientData; /* One word of information to pass to proc. */ - struct ExitHandler *nextPtr;/* Next in list of all exit handlers for - * this application, or NULL for end of list. */ + struct ExitHandler *nextPtr;/* Next in list of all exit handlers for this + * application, or NULL for end of list. */ } ExitHandler; /* - * There is both per-process and per-thread exit handlers. - * The first list is controlled by a mutex. The other is in - * thread local storage. + * There is both per-process and per-thread exit handlers. The first list is + * controlled by a mutex. The other is in thread local storage. */ static ExitHandler *firstExitPtr = NULL; /* First in list of all exit handlers for * application. */ TCL_DECLARE_MUTEX(exitMutex) /* * This variable is set to 1 when Tcl_Finalize is called, and at the end of - * its work, it is reset to 0. The variable is checked by TclInExit() to - * allow different behavior for exit-time processing, e.g. in closing of - * files and pipes. + * its work, it is reset to 0. The variable is checked by TclInExit() to allow + * different behavior for exit-time processing, e.g. in closing of files and + * pipes. */ static int inFinalize = 0; static int subsystemsInitialized = 0; @@ -91,15 +89,15 @@ */ static Tcl_ExitProc *appExitPtr = NULL; typedef struct ThreadSpecificData { - ExitHandler *firstExitPtr; /* First in list of all exit handlers for - * this thread. */ - int inExit; /* True when this thread is exiting. This - * is used as a hack to decide to close - * the standard channels. */ + ExitHandler *firstExitPtr; /* First in list of all exit handlers for this + * thread. */ + int inExit; /* True when this thread is exiting. This is + * used as a hack to decide to close the + * standard channels. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; #ifdef TCL_THREADS @@ -106,11 +104,11 @@ typedef struct { Tcl_ThreadCreateProc *proc; /* Main() function of the thread */ ClientData clientData; /* The one argument to Main() */ } ThreadClientData; static Tcl_ThreadCreateType NewThreadProc _ANSI_ARGS_(( - ClientData clientData)); + ClientData clientData)); #endif /* * Prototypes for procedures referenced only in this file: */ @@ -125,21 +123,19 @@ /* *---------------------------------------------------------------------- * * Tcl_BackgroundError -- * - * This procedure is invoked to handle errors that occur in Tcl - * commands that are invoked in "background" (e.g. from event or - * timer bindings). + * This procedure is invoked to handle errors that occur in Tcl commands + * that are invoked in "background" (e.g. from event or timer bindings). * * Results: * None. * * Side effects: - * A handler command is invoked later as an idle handler to - * process the error, passing it the interp result and return - * options. + * A handler command is invoked later as an idle handler to process the + * error, passing it the interp result and return options. * *---------------------------------------------------------------------- */ void @@ -173,12 +169,12 @@ /* *---------------------------------------------------------------------- * * HandleBgErrors -- * - * This procedure is invoked as an idle handler to process all of - * the accumulated background errors. + * This procedure is invoked as an idle handler to process all of the + * accumulated background errors. * * Results: * None. * * Side effects: @@ -194,14 +190,14 @@ ErrAssocData *assocPtr = (ErrAssocData *) clientData; Tcl_Interp *interp = assocPtr->interp; BgError *errPtr; /* - * Not bothering to save/restore the interp state. Assume that - * any code that has interp state it needs to keep will make - * its own Tcl_SaveInterpState call before calling something like - * Tcl_DoOneEvent() that could lead us here. + * Not bothering to save/restore the interp state. Assume that any code + * that has interp state it needs to keep will make its own + * Tcl_SaveInterpState call before calling something like Tcl_DoOneEvent() + * that could lead us here. */ Tcl_Preserve((ClientData) assocPtr); Tcl_Preserve((ClientData) interp); while (assocPtr->firstBgPtr != NULL) { @@ -209,12 +205,12 @@ Tcl_Obj **prefixObjv, **tempObjv; errPtr = assocPtr->firstBgPtr; Tcl_IncrRefCount(assocPtr->cmdPrefix); - Tcl_ListObjGetElements(NULL, assocPtr->cmdPrefix, - &prefixObjc, &prefixObjv); + Tcl_ListObjGetElements(NULL, assocPtr->cmdPrefix, &prefixObjc, + &prefixObjv); tempObjv = (Tcl_Obj **) ckalloc((prefixObjc+2)*sizeof(Tcl_Obj *)); memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *)); tempObjv[prefixObjc] = errPtr->errorMsg; tempObjv[prefixObjc+1] = errPtr->returnOpts; Tcl_AllowExceptions(interp); @@ -259,11 +255,11 @@ Tcl_WriteObj(errChannel, valuePtr); } else { Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); } Tcl_WriteChars(errChannel, "\n", 1); - Tcl_Flush(errChannel); + Tcl_Flush(errChannel); } } } assocPtr->lastBgPtr = NULL; Tcl_Release((ClientData) interp); @@ -273,14 +269,13 @@ /* *---------------------------------------------------------------------- * * TclDefaultBgErrorHandlerObjCmd -- * - * This procedure is invoked to process the "::tcl::Bgerror" Tcl - * command. It is the default handler command registered with - * [interp bgerror] for the sake of compatibility with older Tcl - * releases. + * This procedure is invoked to process the "::tcl::Bgerror" Tcl command. + * It is the default handler command registered with [interp bgerror] for + * the sake of compatibility with older Tcl releases. * * Results: * A standard Tcl object result. * * Side effects: @@ -289,14 +284,14 @@ *---------------------------------------------------------------------- */ int TclDefaultBgErrorHandlerObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Obj *keyPtr, *valuePtr; Tcl_Obj *tempObjv[2]; int code; @@ -304,16 +299,16 @@ Tcl_WrongNumArgs(interp, 1, objv, "msg options"); return TCL_ERROR; } /* - * Restore important state variables to what they were at - * the time the error occurred. + * Restore important state variables to what they were at the time the + * error occurred. * - * Need to set the variables, not the interp fields, because - * Tcl_EvalObjv() calls Tcl_ResetResult() which would destroy - * anything we write to the interp fields. + * Need to set the variables, not the interp fields, because Tcl_EvalObjv + * calls Tcl_ResetResult which would destroy anything we write to the + * interp fields. */ keyPtr = Tcl_NewStringObj("-errorcode", -1); Tcl_IncrRefCount(keyPtr); Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); @@ -328,56 +323,57 @@ Tcl_DecrRefCount(keyPtr); if (valuePtr) { Tcl_SetVar2Ex(interp, "errorInfo", NULL, valuePtr, TCL_GLOBAL_ONLY); } - /* Create and invoke the bgerror command. */ + /* + * Create and invoke the bgerror command. + */ tempObjv[0] = Tcl_NewStringObj("bgerror", -1); Tcl_IncrRefCount(tempObjv[0]); tempObjv[1] = objv[1]; Tcl_AllowExceptions(interp); code = Tcl_EvalObjv(interp, 2, tempObjv, TCL_EVAL_GLOBAL); if (code == TCL_ERROR) { - /* - * If the interpreter is safe, we look for a hidden command - * named "bgerror" and call that with the error information. - * Otherwise, simply ignore the error. The rationale is that - * this could be an error caused by a malicious applet trying - * to cause an infinite barrage of error messages. The hidden - * "bgerror" command can be used by a security policy to - * interpose on such attacks and e.g. kill the applet after a - * few attempts. - */ + /* + * If the interpreter is safe, we look for a hidden command named + * "bgerror" and call that with the error information. Otherwise, + * simply ignore the error. The rationale is that this could be an + * error caused by a malicious applet trying to cause an infinite + * barrage of error messages. The hidden "bgerror" command can be used + * by a security policy to interpose on such attacks and e.g. kill the + * applet after a few attempts. + */ + if (Tcl_IsSafe(interp)) { Tcl_ResetResult(interp); TclObjInvoke(interp, 2, tempObjv, TCL_INVOKE_HIDDEN); } else { Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR); if (errChannel != (Tcl_Channel) NULL) { Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(resultPtr); - if (Tcl_FindCommand(interp, "bgerror", - NULL, TCL_GLOBAL_ONLY) == NULL) { + if (Tcl_FindCommand(interp, "bgerror", NULL, + TCL_GLOBAL_ONLY) == NULL) { if (valuePtr) { Tcl_WriteObj(errChannel, valuePtr); Tcl_WriteChars(errChannel, "\n", -1); } - } else { + } else { Tcl_WriteChars(errChannel, "bgerror failed to handle background error.\n", -1); Tcl_WriteChars(errChannel, " Original error: ", -1); Tcl_WriteObj(errChannel, objv[1]); Tcl_WriteChars(errChannel, "\n", -1); - Tcl_WriteChars(errChannel, - " Error in bgerror: ", -1); + Tcl_WriteChars(errChannel, " Error in bgerror: ", -1); Tcl_WriteObj(errChannel, resultPtr); Tcl_WriteChars(errChannel, "\n", -1); - } + } Tcl_DecrRefCount(resultPtr); - Tcl_Flush(errChannel); + Tcl_Flush(errChannel); } } code = TCL_OK; } Tcl_DecrRefCount(tempObjv[0]); @@ -388,12 +384,12 @@ /* *---------------------------------------------------------------------- * * TclSetBgErrorHandler -- * - * This procedure sets the command prefix to be used to handle - * background errors in interp. + * This procedure sets the command prefix to be used to handle background + * errors in interp. * * Results: * None. * * Side effects: @@ -433,12 +429,12 @@ /* *---------------------------------------------------------------------- * * TclGetBgErrorHandler -- * - * This procedure retrieves the command prefix currently used - * to handle background errors in interp. + * This procedure retrieves the command prefix currently used to handle + * background errors in interp. * * Results: * A (Tcl_Obj *) to a list of words (command prefix). * * Side effects: @@ -465,21 +461,20 @@ /* *---------------------------------------------------------------------- * * BgErrorDeleteProc -- * - * This procedure is associated with the "tclBgError" assoc data - * for an interpreter; it is invoked when the interpreter is - * deleted in order to free the information assoicated with any - * pending error reports. + * This procedure is associated with the "tclBgError" assoc data for an + * interpreter; it is invoked when the interpreter is deleted in order to + * free the information assoicated with any pending error reports. * * Results: * None. * * Side effects: - * Background error information is freed: if there were any - * pending error reports, they are cancelled. + * Background error information is freed: if there were any pending error + * reports, they are cancelled. * *---------------------------------------------------------------------- */ static void @@ -512,12 +507,12 @@ * * Results: * None. * * Side effects: - * Proc will be invoked with clientData as argument when the - * application exits. + * Proc will be invoked with clientData as argument when the application + * exits. * *---------------------------------------------------------------------- */ void @@ -539,20 +534,19 @@ /* *---------------------------------------------------------------------- * * Tcl_DeleteExitHandler -- * - * This procedure cancels an existing exit handler matching proc - * and clientData, if such a handler exits. + * This procedure cancels an existing exit handler matching proc and + * clientData, if such a handler exits. * * Results: * None. * * Side effects: - * If there is an exit handler corresponding to proc and clientData - * then it is cancelled; if no such handler exists then nothing - * happens. + * If there is an exit handler corresponding to proc and clientData then + * it is cancelled; if no such handler exists then nothing happens. * *---------------------------------------------------------------------- */ void @@ -583,19 +577,19 @@ /* *---------------------------------------------------------------------- * * Tcl_CreateThreadExitHandler -- * - * Arrange for a given procedure to be invoked just before the - * current thread exits. + * Arrange for a given procedure to be invoked just before the current + * thread exits. * * Results: * None. * * Side effects: - * Proc will be invoked with clientData as argument when the - * application exits. + * Proc will be invoked with clientData as argument when the application + * exits. * *---------------------------------------------------------------------- */ void @@ -616,20 +610,19 @@ /* *---------------------------------------------------------------------- * * Tcl_DeleteThreadExitHandler -- * - * This procedure cancels an existing exit handler matching proc - * and clientData, if such a handler exits. + * This procedure cancels an existing exit handler matching proc and + * clientData, if such a handler exits. * * Results: * None. * * Side effects: - * If there is an exit handler corresponding to proc and clientData - * then it is cancelled; if no such handler exists then nothing - * happens. + * If there is an exit handler corresponding to proc and clientData then + * it is cancelled; if no such handler exists then nothing happens. * *---------------------------------------------------------------------- */ void @@ -658,14 +651,13 @@ /* *---------------------------------------------------------------------- * * Tcl_SetExitProc -- * - * This procedure sets the application wide exit handler that - * will be called by Tcl_Exit in place of the C-runtime exit. If - * the application wide exit handler is NULL, the C-runtime exit - * will be used instead. + * This procedure sets the application wide exit handler that will be + * called by Tcl_Exit in place of the C-runtime exit. If the application + * wide exit handler is NULL, the C-runtime exit will be used instead. * * Results: * The previously set application wide exit handler. * * Side effects: @@ -679,12 +671,12 @@ Tcl_ExitProc *proc; /* new exit handler for app or NULL */ { Tcl_ExitProc *prevExitProc; /* - * Swap the old exit proc for the new one, saving the old one for - * our return value. + * Swap the old exit proc for the new one, saving the old one for our + * return value. */ Tcl_MutexLock(&exitMutex); prevExitProc = appExitPtr; appExitPtr = proc; @@ -702,12 +694,11 @@ * * Results: * None. * * Side effects: - * All existing exit handlers are invoked, then the application - * ends. + * All existing exit handlers are invoked, then the application ends. * *---------------------------------------------------------------------- */ void @@ -721,14 +712,15 @@ currentAppExitPtr = appExitPtr; Tcl_MutexUnlock(&exitMutex); if (currentAppExitPtr) { /* - * Warning: this code SHOULD NOT return, as there is code that - * depends on Tcl_Exit never returning. In fact, we will - * Tcl_Panic if anyone returns, so critical is this dependcy. + * Warning: this code SHOULD NOT return, as there is code that depends + * on Tcl_Exit never returning. In fact, we will Tcl_Panic if anyone + * returns, so critical is this dependcy. */ + currentAppExitPtr((ClientData) status); Tcl_Panic("AppExitProc returned unexpectedly"); } else { /* use default handling */ Tcl_Finalize(); @@ -740,21 +732,20 @@ /* *------------------------------------------------------------------------- * * TclInitSubsystems -- * - * Initialize various subsytems in Tcl. This should be called the - * first time an interp is created, or before any of the subsystems - * are used. This function ensures an order for the initialization - * of subsystems: - * - * 1. that cannot be initialized in lazy order because they are - * mutually dependent. - * - * 2. so that they can be finalized in a known order w/o causing - * the subsequent re-initialization of a subsystem in the act of - * shutting down another. + * Initialize various subsytems in Tcl. This should be called the first + * time an interp is created, or before any of the subsystems are used. + * This function ensures an order for the initialization of subsystems: + * + * 1. that cannot be initialized in lazy order because they are mutually + * dependent. + * + * 2. so that they can be finalized in a known order w/o causing the + * subsequent re-initialization of a subsystem in the act of shutting + * down another. * * Results: * None. * * Side effects: @@ -770,40 +761,47 @@ Tcl_Panic("TclInitSubsystems called while finalizing"); } if (subsystemsInitialized == 0) { /* - * Double check inside the mutex. There are definitly calls - * back into this routine from some of the procedures below. + * Double check inside the mutex. There are definitly calls back into + * this routine from some of the procedures below. */ TclpInitLock(); if (subsystemsInitialized == 0) { /* - * Have to set this bit here to avoid deadlock with the - * routines below us that call into TclInitSubsystems. + * Have to set this bit here to avoid deadlock with the routines + * below us that call into TclInitSubsystems. */ subsystemsInitialized = 1; /* * Initialize locks used by the memory allocators before anything * interesting happens so we can use the allocators in the * implementation of self-initializing locks. */ + + TclInitThreadStorage(); /* Creates master hash table for + * thread local storage */ #if USE_TCLALLOC - TclInitAlloc(); /* process wide mutex init */ + TclInitAlloc(); /* Process wide mutex init */ #endif #ifdef TCL_MEM_DEBUG - TclInitDbCkalloc(); /* process wide mutex init */ + TclInitDbCkalloc(); /* Process wide mutex init */ #endif - TclpInitPlatform(); /* creates signal handler(s) */ - TclInitObjSubsystem(); /* register obj types, create mutexes */ - TclInitIOSubsystem(); /* inits a tsd key (noop) */ - TclInitEncodingSubsystem(); /* process wide encoding init */ - TclInitNamespaceSubsystem(); /* register ns obj type (mutexed) */ + TclpInitPlatform(); /* Creates signal handler(s) */ + TclInitDoubleConversion(); /* Initializes constants for + * converting to/from double. */ + TclInitObjSubsystem(); /* Register obj types, create + * mutexes. */ + TclInitIOSubsystem(); /* Inits a tsd key (noop). */ + TclInitEncodingSubsystem(); /* Process wide encoding init. */ + TclpSetInterfaces(); + TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */ } TclpInitUnlock(); } TclInitNotifier(); } @@ -811,14 +809,13 @@ /* *---------------------------------------------------------------------- * * Tcl_Finalize -- * - * Shut down Tcl. First calls registered exit handlers, then - * carefully shuts down various subsystems. - * Called by Tcl_Exit or when the Tcl shared library is being - * unloaded. + * Shut down Tcl. First calls registered exit handlers, then carefully + * shuts down various subsystems. Called by Tcl_Exit or when the Tcl + * shared library is being unloaded. * * Results: * None. * * Side effects: @@ -838,14 +835,13 @@ Tcl_MutexLock(&exitMutex); inFinalize = 1; for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) { /* - * Be careful to remove the handler from the list before - * invoking its callback. This protects us against - * double-freeing if the callback should call - * Tcl_DeleteExitHandler on itself. + * Be careful to remove the handler from the list before invoking its + * callback. This protects us against double-freeing if the callback + * should call Tcl_DeleteExitHandler on itself. */ firstExitPtr = exitPtr->nextPtr; Tcl_MutexUnlock(&exitMutex); (*exitPtr->proc)(exitPtr->clientData); @@ -858,94 +854,130 @@ TclpInitLock(); if (subsystemsInitialized != 0) { subsystemsInitialized = 0; /* - * Ensure the thread-specific data is initialised as it is - * used in Tcl_FinalizeThread() + * Ensure the thread-specific data is initialised as it is used in + * Tcl_FinalizeThread() */ (void) TCL_TSD_INIT(&dataKey); /* - * Clean up after the current thread now, after exit handlers. - * In particular, the testexithandler command sets up something - * that writes to standard output, which gets closed. - * Note that there is no thread-local storage after this call. + * Clean up after the current thread now, after exit handlers. In + * particular, the testexithandler command sets up something that + * writes to standard output, which gets closed. Note that there is + * no thread-local storage after this call. */ Tcl_FinalizeThread(); /* - * Now finalize the Tcl execution environment. Note that this - * must be done after the exit handlers, because there are - * order dependencies. + * Now finalize the Tcl execution environment. Note that this must be + * done after the exit handlers, because there are order dependencies. */ - TclFinalizeCompExecEnv(); + TclFinalizeCompilation(); + TclFinalizeExecution(); TclFinalizeEnvironment(); /* - * Finalizing the filesystem must come after anything which - * might conceivably interact with the 'Tcl_FS' API. + * Finalizing the filesystem must come after anything which might + * conceivably interact with the 'Tcl_FS' API. */ + TclFinalizeFilesystem(); + /* + * Undo all Tcl_ObjType registrations, and reset the master list + * of free Tcl_Obj's. After this returns, no more Tcl_Obj's should + * be allocated or freed. + * + * Note in particular that TclFinalizeObjects() must follow + * TclFinalizeFilesystem() because TclFinalizeFilesystem free's + * the Tcl_Obj that holds the path of the current working directory. + */ + + TclFinalizeObjects(); + /* - * We must be sure the encoding finalization doesn't need - * to examine the filesystem in any way. Since it only - * needs to clean up internal data structures, this is - * fine. + * We must be sure the encoding finalization doesn't need to examine + * the filesystem in any way. Since it only needs to clean up + * internal data structures, this is fine. */ + TclFinalizeEncodingSubsystem(); Tcl_SetPanicProc(NULL); /* - * Repeat finalization of the thread local storage once more. - * Although this step is already done by the Tcl_FinalizeThread - * call above, series of events happening afterwards may - * re-initialize TSD slots. Those need to be finalized again, - * otherwise we're leaking memory chunks. - * Very important to note is that things happening afterwards - * should not reference anything which may re-initialize TSD's. - * This includes freeing Tcl_Objs's, among other things. + * Repeat finalization of the thread local storage once more. Although + * this step is already done by the Tcl_FinalizeThread call above, + * series of events happening afterwards may re-initialize TSD slots. + * Those need to be finalized again, otherwise we're leaking memory + * chunks. Very important to note is that things happening afterwards + * should not reference anything which may re-initialize TSD's. This + * includes freeing Tcl_Objs's, among other things. * * This fixes the Tcl Bug #990552. */ + TclFinalizeThreadData(); + /* + * Now we can free constants for conversions to/from double. + */ + + TclFinalizeDoubleConversion(); + + /* + * There have been several bugs in the past that cause exit handlers + * to be established during Tcl_Finalize processing. Such exit + * handlers leave malloc'ed memory, and Tcl_FinalizeThreadAlloc or + * Tcl_FinalizeMemorySubsystem will result in a corrupted heap. The + * result can be a mysterious crash on process exit. Check here that + * nobody's done this. + */ + + if (firstExitPtr != NULL) { + Tcl_Panic("exit handlers were created during Tcl_Finalize"); + } + + TclFinalizePreserve(); + /* * Free synchronization objects. There really should only be one * thread alive at this moment. */ + TclFinalizeSynchronization(); - /* - * We defer unloading of packages until very late - * to avoid memory access issues. Both exit callbacks and - * synchronization variables may be stored in packages. - * - * Note that TclFinalizeLoad unloads packages in the reverse - * of the order they were loaded in (i.e. last to be loaded - * is the first to be unloaded). This can be important for - * correct unloading when dependencies exist. - * - * Once load has been finalized, we will have deleted any - * temporary copies of shared libraries and can therefore - * reset the filesystem to its original state. +#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) + TclFinalizeThreadAlloc(); +#endif + /* + * We defer unloading of packages until very late to avoid memory + * access issues. Both exit callbacks and synchronization variables + * may be stored in packages. + * + * Note that TclFinalizeLoad unloads packages in the reverse of the + * order they were loaded in (i.e. last to be loaded is the first to + * be unloaded). This can be important for correct unloading when + * dependencies exist. + * + * Once load has been finalized, we will have deleted any temporary + * copies of shared libraries and can therefore reset the filesystem + * to its original state. */ TclFinalizeLoad(); TclResetFilesystem(); - + /* - * There shouldn't be any malloc'ed memory after this. + * At this point, there should no longer be any ckalloc'ed memory. */ -#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) - TclFinalizeThreadAlloc(); -#endif + TclFinalizeMemorySubsystem(); inFinalize = 0; } TclFinalizeLock(); } @@ -953,12 +985,12 @@ /* *---------------------------------------------------------------------- * * Tcl_FinalizeThread -- * - * Runs the exit handlers to allow Tcl to clean up its state - * about a particular thread. + * Runs the exit handlers to allow Tcl to clean up its state about a + * particular thread. * * Results: * None. * * Side effects: @@ -969,10 +1001,17 @@ void Tcl_FinalizeThread() { ExitHandler *exitPtr; + + /* + * We use TclThreadDataKeyGet here, rather than Tcl_GetThreadData, + * because we don't want to initialize the data block if it hasn't + * been initialized already. + */ + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); if (tsdPtr != NULL) { tsdPtr->inExit = 1; @@ -995,18 +1034,18 @@ } /* * Blow away all thread local storage blocks. * - * Note that Tcl API allows creation of threads which do not use any - * Tcl interp or other Tcl subsytems. Those threads might, however, - * use thread local storage, so we must unconditionally finalize it. + * Note that Tcl API allows creation of threads which do not use any Tcl + * interp or other Tcl subsytems. Those threads might, however, use thread + * local storage, so we must unconditionally finalize it. * * Fix [Bug #571002] */ - TclFinalizeThreadData(); + TclFinalizeThreadData(); } /* *---------------------------------------------------------------------- * @@ -1060,12 +1099,12 @@ /* *---------------------------------------------------------------------- * * Tcl_VwaitObjCmd -- * - * This procedure is invoked to process the "vwait" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "vwait" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -1084,11 +1123,11 @@ { int done, foundEvent; char *nameString; if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name"); + Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } nameString = Tcl_GetString(objv[1]); if (Tcl_TraceVar(interp, nameString, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, @@ -1098,20 +1137,22 @@ done = 0; foundEvent = 1; while (!done && foundEvent) { foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS); if (Tcl_LimitExceeded(interp)) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "limit exceeded", NULL); return TCL_ERROR; } } Tcl_UntraceVar(interp, nameString, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, VwaitVarProc, (ClientData) &done); /* - * Clear out the interpreter's result, since it may have been set - * by event handlers. + * Clear out the interpreter's result, since it may have been set by event + * handlers. */ Tcl_ResetResult(interp); if (!foundEvent) { Tcl_AppendResult(interp, "can't wait for variable \"", nameString, @@ -1139,12 +1180,12 @@ /* *---------------------------------------------------------------------- * * Tcl_UpdateObjCmd -- * - * This procedure is invoked to process the "update" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "update" Tcl command. See + * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -1172,38 +1213,38 @@ if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions, "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } switch ((enum updateOptions) optionIndex) { - case REGEXP_IDLETASKS: { - flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT; - break; - } - default: { - Tcl_Panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions"); - } + case REGEXP_IDLETASKS: + flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT; + break; + default: + Tcl_Panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions"); } } else { - Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?"); + Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?"); return TCL_ERROR; } while (Tcl_DoOneEvent(flags) != 0) { if (Tcl_LimitExceeded(interp)) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "limit exceeded", NULL); return TCL_ERROR; } } /* - * Must clear the interpreter's result because event handlers could - * have executed commands. + * Must clear the interpreter's result because event handlers could have + * executed commands. */ Tcl_ResetResult(interp); return TCL_OK; } - + #ifdef TCL_THREADS /* *----------------------------------------------------------------------------- * * NewThreadProc -- @@ -1234,22 +1275,23 @@ (*threadProc)(threadClientData); TCL_THREAD_CREATE_RETURN; } #endif + /* *---------------------------------------------------------------------- * * Tcl_CreateThread -- * - * This procedure creates a new thread. This actually belongs - * to the tclThread.c file but since we use some private - * data structures local to this file, it is placed here. + * This procedure creates a new thread. This actually belongs to the + * tclThread.c file but since we use some private data structures local + * to this file, it is placed here. * * Results: - * TCL_OK if the thread could be created. The thread ID is - * returned in a parameter. + * TCL_OK if the thread could be created. The thread ID is returned in a + * parameter. * * Side effects: * A new thread is created. * *---------------------------------------------------------------------- @@ -1259,21 +1301,29 @@ Tcl_CreateThread(idPtr, proc, clientData, stackSize, flags) Tcl_ThreadId *idPtr; /* Return, the ID of the thread */ Tcl_ThreadCreateProc proc; /* Main() function of the thread */ ClientData clientData; /* The one argument to Main() */ int stackSize; /* Size of stack for the new thread */ - int flags; /* Flags controlling behaviour of - * the new thread */ + int flags; /* Flags controlling behaviour of the + * new thread. */ { #ifdef TCL_THREADS ThreadClientData *cdPtr; - cdPtr = (ThreadClientData*)Tcl_Alloc(sizeof(ThreadClientData)); + cdPtr = (ThreadClientData *) Tcl_Alloc(sizeof(ThreadClientData)); cdPtr->proc = proc; cdPtr->clientData = clientData; return TclpThreadCreate(idPtr, NewThreadProc, (ClientData)cdPtr, - stackSize, flags); + stackSize, flags); #else return TCL_ERROR; #endif /* TCL_THREADS */ } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclExecute.c ================================================================== --- generic/tclExecute.c +++ generic/tclExecute.c @@ -1,32 +1,43 @@ -/* +/* * tclExecute.c -- * - * This file contains procedures that execute byte-compiled Tcl - * commands. + * This file contains procedures that execute byte-compiled Tcl commands. * * Copyright (c) 1996-1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. + * Copyright (c) 2002-2005 by Miguel Sofer. + * Copyright (c) 2005 by Donal K. Fellows. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.167 2004/11/12 19:16:50 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.167.2.57 2005/10/08 06:43:18 dgp Exp $ */ #include "tclInt.h" #include "tclCompile.h" +#include "tommath.h" -#ifndef TCL_NO_MATH -# include +#include +#include + +/* + * Hack to determine whether we may expect IEEE floating point. The hack is + * formally incorrect in that non-IEEE platforms might have the same precision + * and range, but VAX, IBM, and Cray do not; are there any other floating + * point units that we might care about? + */ + +#if ( FLT_RADIX == 2 ) && ( DBL_MANT_DIG == 53 ) && ( DBL_MAX_EXP == 1024 ) +#define IEEE_FLOATING_POINT #endif /* - * The stuff below is a bit of a hack so that this file can be used - * in environments that include no UNIX, i.e. no errno. Just define - * errno here. + * 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 define errno here. */ #ifdef TCL_GENERIC_ONLY # ifndef NO_FLOAT_H # include @@ -36,35 +47,22 @@ # endif /* !NO_VALUES_H */ # endif /* !NO_FLOAT_H */ # 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 */ - -/* - * A mask (should be 2**n-1) that is used to work out when the - * bytecode engine should call Tcl_AsyncReady() to see whether there - * is a signal that needs handling. +#endif + +/* + * A mask (should be 2**n-1) that is used to work out when the bytecode engine + * should call Tcl_AsyncReady() to see whether there is a signal that needs + * handling. */ #ifndef ASYNC_CHECK_COUNT_MASK # define ASYNC_CHECK_COUNT_MASK 63 #endif /* !ASYNC_CHECK_COUNT_MASK */ @@ -108,11 +106,11 @@ "", "", "", "", "", "", "", "", "eq", "ne" }; /* * Mapping from Tcl result codes to strings; used for error and debugging - * messages. + * messages. */ #ifdef TCL_COMPILE_DEBUG static char *resultStrings[] = { "TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE" @@ -129,62 +127,52 @@ #define TCL_MAX_SHARED_OBJ_STATS 5 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. - */ - -#define IS_NAN(v) ((v) != (v)) -#define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX)) - -/* - * 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 at runtime for variable (nCleanup). + * 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 + * at runtime for variable (nCleanup). * * ARGUMENTS: * pcAdjustment: how much to increment pc * nCleanup: how many objects to remove from the stack - * resultHandling: 0 indicates no object should be pushed on the - * stack; otherwise, push objResultPtr. If (result < 0), - * objResultPtr already has the correct reference count. + * resultHandling: 0 indicates no object should be pushed on the stack; + * otherwise, push objResultPtr. If (result < 0), objResultPtr already + * has the correct reference count. */ #define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \ - if (nCleanup == 0) {\ - if (resultHandling != 0) {\ - if ((resultHandling) > 0) {\ - PUSH_OBJECT(objResultPtr);\ - } else {\ - *(++tosPtr) = objResultPtr;\ - }\ - } \ - pc += (pcAdjustment);\ - goto cleanup0;\ - } else if (resultHandling != 0) {\ - if ((resultHandling) > 0) {\ - Tcl_IncrRefCount(objResultPtr);\ - }\ - pc += (pcAdjustment);\ - switch (nCleanup) {\ - case 1: goto cleanup1_pushObjResultPtr;\ - case 2: goto cleanup2_pushObjResultPtr;\ - default: Tcl_Panic("ERROR: bad usage of macro NEXT_INST_F");\ - }\ - } else {\ - pc += (pcAdjustment);\ - switch (nCleanup) {\ - case 1: goto cleanup1;\ - case 2: goto cleanup2;\ - default: Tcl_Panic("ERROR: bad usage of macro NEXT_INST_F");\ - }\ - } + if (nCleanup == 0) {\ + if (resultHandling != 0) {\ + if ((resultHandling) > 0) {\ + PUSH_OBJECT(objResultPtr);\ + } else {\ + *(++tosPtr) = objResultPtr;\ + }\ + } \ + pc += (pcAdjustment);\ + goto cleanup0;\ + } else if (resultHandling != 0) {\ + if ((resultHandling) > 0) {\ + Tcl_IncrRefCount(objResultPtr);\ + }\ + pc += (pcAdjustment);\ + switch (nCleanup) {\ + case 1: goto cleanup1_pushObjResultPtr;\ + case 2: goto cleanup2_pushObjResultPtr;\ + default: Tcl_Panic("ERROR: bad usage of macro NEXT_INST_F");\ + }\ + } else {\ + pc += (pcAdjustment);\ + switch (nCleanup) {\ + case 1: goto cleanup1;\ + case 2: goto cleanup2;\ + default: Tcl_Panic("ERROR: bad usage of macro NEXT_INST_F");\ + }\ + } #define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \ pc += (pcAdjustment);\ cleanup = (nCleanup);\ if (resultHandling) {\ @@ -207,81 +195,84 @@ #define CACHE_STACK_INFO() \ tosPtr = eePtr->tosPtr #define DECACHE_STACK_INFO() \ - eePtr->tosPtr = tosPtr + eePtr->tosPtr = tosPtr;\ + checkInterp = 1 /* * Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT * increments the object's ref count since it makes the stack have another * reference pointing to the object. However, POP_OBJECT does not decrement - * the ref count. This is because the stack may hold the only reference to - * the object, so the object would be destroyed if its ref count were - * decremented before the caller had a chance to, e.g., store it in a - * variable. It is the caller's responsibility to decrement the ref count - * when it is finished with an object. + * the ref count. This is because the stack may hold the only reference to the + * object, so the object would be destroyed if its ref count were decremented + * before the caller had a chance to, e.g., store it in a variable. It is the + * caller's responsibility to decrement the ref count when it is finished with + * an object. * * WARNING! It is essential that objPtr only appear once in the PUSH_OBJECT - * macro. The actual parameter might be an expression with side effects, - * and this ensures that it will be executed only once. + * macro. The actual parameter might be an expression with side effects, and + * this ensures that it will be executed only once. */ - + #define PUSH_OBJECT(objPtr) \ Tcl_IncrRefCount(*(++tosPtr) = (objPtr)) - + #define POP_OBJECT() \ *(tosPtr--) /* * Macros used to trace instruction execution. The macros TRACE, - * TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode. - * O2S is only used in TRACE* calls to get a string from an object. + * TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode. O2S is + * only used in TRACE* calls to get a string from an object. */ #ifdef TCL_COMPILE_DEBUG # define TRACE(a) \ if (traceInstructions) { \ - fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ - (tosPtr - eePtr->stackPtr), \ - (unsigned int)(pc - codePtr->codeStart), \ - GetOpcodeName(pc)); \ + fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ + (tosPtr - eePtr->stackPtr), \ + (unsigned int)(pc - codePtr->codeStart), \ + GetOpcodeName(pc)); \ printf a; \ } # define TRACE_APPEND(a) \ if (traceInstructions) { \ printf a; \ } # define TRACE_WITH_OBJ(a, objPtr) \ if (traceInstructions) { \ - fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ - (tosPtr - eePtr->stackPtr), \ - (unsigned int)(pc - codePtr->codeStart), \ - GetOpcodeName(pc)); \ + fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ + (tosPtr - eePtr->stackPtr), \ + (unsigned int)(pc - codePtr->codeStart), \ + GetOpcodeName(pc)); \ printf a; \ - TclPrintObject(stdout, objPtr, 30); \ - fprintf(stdout, "\n"); \ + TclPrintObject(stdout, objPtr, 30); \ + fprintf(stdout, "\n"); \ } # define O2S(objPtr) \ (objPtr ? TclGetString(objPtr) : "") #else /* !TCL_COMPILE_DEBUG */ # define TRACE(a) -# define TRACE_APPEND(a) +# define TRACE_APPEND(a) # define TRACE_WITH_OBJ(a, objPtr) # 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 integer constants between LONG_MIN and - * LONG_MAX (inclusive) are represented by normal longs, and integer - * constants outside that range are represented by wide ints. + * 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 + * integer constants between LONG_MIN and LONG_MAX (inclusive) are represented + * by normal longs, and integer constants outside that range are represented + * by wide ints. * * 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)); \ if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \ && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \ @@ -296,20 +287,21 @@ && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \ (objPtr)->typePtr = &tclIntType; \ (objPtr)->internalRep.longValue = (longVar) \ = Tcl_WideAsLong(wideVar); \ } +#endif /* - * Combined with REQUIRE_WIDE_OR_INT, this gets a long value from - * an obj. + * 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) #define W0 Tcl_LongAsWide(0) /* @@ -335,49 +327,117 @@ (doubleVar) = (double) (objPtr)->internalRep.longValue; \ } else { \ (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", + NULL, NULL, NULL, NULL +}; /* * Declarations for local procedures to this file: */ static int TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp, ByteCode *codePtr)); -static int ExprAbsFunc _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj **tosPtr, ClientData clientData)); -static int ExprBinaryFunc _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj **tosPtr, ClientData clientData)); -static int ExprCallMathFunc _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj **objv)); -static int ExprDoubleFunc _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj **tosPtr, ClientData clientData)); -static int ExprIntFunc _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj **tosPtr, ClientData clientData)); -static int ExprRandFunc _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj **tosPtr, ClientData clientData)); -static int ExprRoundFunc _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj **tosPtr, ClientData clientData)); -static int ExprSrandFunc _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj **tosPtr, ClientData clientData)); -static int ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj **tosPtr, ClientData clientData)); -static int ExprWideFunc _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj **tosPtr, ClientData clientData)); #ifdef TCL_COMPILE_STATS -static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, +static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); #endif /* TCL_COMPILE_STATS */ #ifdef TCL_COMPILE_DEBUG static char * GetOpcodeName _ANSI_ARGS_((unsigned char *pc)); #endif /* TCL_COMPILE_DEBUG */ static ExceptionRange * GetExceptRangeForPc _ANSI_ARGS_((unsigned char *pc, int catchOnly, ByteCode* codePtr)); static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc, - ByteCode* codePtr, int *lengthPtr)); + ByteCode* codePtr, int *lengthPtr)); static void GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr)); static void IllegalExprOperandType _ANSI_ARGS_(( Tcl_Interp *interp, unsigned char *pc, Tcl_Obj *opndPtr)); static void InitByteCodeExecution _ANSI_ARGS_(( @@ -385,57 +445,20 @@ #ifdef TCL_COMPILE_DEBUG static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr)); static char * StringForResultCode _ANSI_ARGS_((int result)); static void ValidatePcAndStackTop _ANSI_ARGS_(( ByteCode *codePtr, unsigned char *pc, - int stackTop, int stackLowerBound, + int stackTop, int stackLowerBound, int checkStack)); #endif /* TCL_COMPILE_DEBUG */ -static int VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); +#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)); - -/* - * Table describing the built-in math functions. Entries in this table are - * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's - * operand byte. - */ - -BuiltinFunc tclBuiltinFuncTable[] = { -#ifndef TCL_NO_MATH - {"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos}, - {"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin}, - {"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan}, - {"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2}, - {"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil}, - {"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos}, - {"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cosh}, - {"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) exp}, - {"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) floor}, - {"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) fmod}, - {"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) hypot}, - {"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log}, - {"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log10}, - {"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) pow}, - {"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sin}, - {"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sinh}, - {"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sqrt}, - {"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tan}, - {"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tanh}, -#endif - {"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0}, - {"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0}, - {"int", 1, {TCL_EITHER}, ExprIntFunc, 0}, - {"rand", 0, {TCL_EITHER}, ExprRandFunc, 0}, /* NOTE: rand takes no args. */ - {"round", 1, {TCL_EITHER}, ExprRoundFunc, 0}, - {"srand", 1, {TCL_INT}, ExprSrandFunc, 0}, - {"wide", 1, {TCL_EITHER}, ExprWideFunc, 0}, - {0}, -}; +#endif + /* *---------------------------------------------------------------------- * * InitByteCodeExecution -- @@ -446,14 +469,14 @@ * Results: * None. * * Side effects: * This procedure initializes the array of instruction names. If - * compiling with the TCL_COMPILE_STATS flag, it initializes the - * array that counts the executions of each instruction and it - * creates the "evalstats" command. It also establishes the link - * between the Tcl "tcl_traceExec" and C "tclTraceExec" variables. + * compiling with the TCL_COMPILE_STATS flag, it initializes the array + * that counts the executions of each instruction and it creates the + * "evalstats" command. It also establishes the link between the Tcl + * "tcl_traceExec" and C "tclTraceExec" variables. * *---------------------------------------------------------------------- */ static void @@ -462,15 +485,15 @@ * "tcl_traceExec" is linked to control * instruction tracing. */ { #ifdef TCL_COMPILE_DEBUG if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec, - TCL_LINK_INT) != TCL_OK) { + TCL_LINK_INT) != TCL_OK) { Tcl_Panic("InitByteCodeExecution: can't create link for tcl_traceExec variable"); } #endif -#ifdef TCL_COMPILE_STATS +#ifdef TCL_COMPILE_STATS Tcl_CreateObjCommand(interp, "evalstats", EvalStatsCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); #endif /* TCL_COMPILE_STATS */ } @@ -478,22 +501,22 @@ *---------------------------------------------------------------------- * * TclCreateExecEnv -- * * This procedure creates a new execution environment for Tcl bytecode - * execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv - * is typically created once for each Tcl interpreter (Interp - * structure) and recursively passed to TclExecuteByteCode to execute - * ByteCode sequences for nested commands. + * execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv is + * typically created once for each Tcl interpreter (Interp structure) and + * recursively passed to TclExecuteByteCode to execute ByteCode sequences + * for nested commands. * * Results: * A newly allocated ExecEnv is returned. This points to an empty * evaluation stack of the standard initial size. * * Side effects: - * The bytecode interpreter is also initialized here, as this - * procedure will be called before any call to TclExecuteByteCode. + * The bytecode interpreter is also initialized here, as this procedure + * will be called before any call to TclExecuteByteCode. * *---------------------------------------------------------------------- */ #define TCL_STACK_INITIAL_SIZE 2000 @@ -505,23 +528,28 @@ { ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv)); Tcl_Obj **stackPtr; stackPtr = (Tcl_Obj **) - ckalloc((size_t) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *))); + ckalloc((size_t) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *))); /* - * Use the bottom pointer to keep a reference count; the - * execution environment holds a reference. + * Use the bottom pointer to keep a reference count; the execution + * environment holds a reference. */ stackPtr++; eePtr->stackPtr = stackPtr; stackPtr[-1] = (Tcl_Obj *) ((char *) 1); eePtr->tosPtr = stackPtr - 1; eePtr->endPtr = stackPtr + (TCL_STACK_INITIAL_SIZE - 2); + + TclNewBooleanObj(eePtr->constants[0], 0); + Tcl_IncrRefCount(eePtr->constants[0]); + TclNewBooleanObj(eePtr->constants[1], 1); + Tcl_IncrRefCount(eePtr->constants[1]); Tcl_MutexLock(&execMutex); if (!execInitialized) { TclInitAuxDataTypeTable(); InitByteCodeExecution(interp); @@ -542,12 +570,12 @@ * * Results: * None. * * Side effects: - * Storage for an ExecEnv and its contained storage (e.g. the - * evaluation stack) is freed. + * Storage for an ExecEnv and its contained storage (e.g. the evaluation + * stack) is freed. * *---------------------------------------------------------------------- */ void @@ -557,27 +585,29 @@ if (eePtr->stackPtr[-1] == (Tcl_Obj *) ((char *) 1)) { ckfree((char *) (eePtr->stackPtr-1)); } else { Tcl_Panic("ERROR: freeing an execEnv whose stack is still in use.\n"); } + TclDecrRefCount(eePtr->constants[0]); + TclDecrRefCount(eePtr->constants[1]); ckfree((char *) eePtr); } /* *---------------------------------------------------------------------- * * TclFinalizeExecution -- * - * Finalizes the execution environment setup so that it can be - * later reinitialized. + * Finalizes the execution environment setup so that it can be later + * reinitialized. * * Results: * None. * * Side effects: - * After this call, the next time TclCreateExecEnv will be called - * it will call InitByteCodeExecution. + * After this call, the next time TclCreateExecEnv will be called it will + * call InitByteCodeExecution. * *---------------------------------------------------------------------- */ void @@ -605,16 +635,16 @@ *---------------------------------------------------------------------- */ static void GrowEvaluationStack(eePtr) - register ExecEnv *eePtr; /* Points to the ExecEnv with an evaluation - * stack to enlarge. */ + register ExecEnv *eePtr; /* Points to the ExecEnv with an evaluation + * stack to enlarge. */ { /* - * The current Tcl stack elements are stored from *(eePtr->stackPtr) - * to *(eePtr->endPtr) (inclusive). + * The current Tcl stack elements are stored from *(eePtr->stackPtr) to + * *(eePtr->endPtr) (inclusive). */ int currElems = (eePtr->endPtr - eePtr->stackPtr + 1); int newElems = 2*currElems; int currBytes = currElems * sizeof(Tcl_Obj *); @@ -621,41 +651,119 @@ int newBytes = 2*currBytes; Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes); Tcl_Obj **oldStackPtr = eePtr->stackPtr; /* - * We keep the stack reference count as a (char *), as that - * works nicely as a portable pointer-sized counter. + * We keep the stack reference count as a (char *), as that works nicely + * as a portable pointer-sized counter. */ char *refCount = (char *) oldStackPtr[-1]; /* * Copy the existing stack items to the new stack space, free the old - * storage if appropriate, and record the refCount of the new stack - * held by the environment. + * storage if appropriate, and record the refCount of the new stack held + * by the environment. */ - + newStackPtr++; memcpy((VOID *) newStackPtr, (VOID *) oldStackPtr, (size_t) currBytes); if (refCount == (char *) 1) { ckfree((VOID *) (oldStackPtr-1)); } else { /* - * Remove the reference corresponding to the - * environment pointer. + * Remove the reference corresponding to the environment pointer. */ - + oldStackPtr[-1] = (Tcl_Obj *) (refCount-1); } eePtr->stackPtr = newStackPtr; eePtr->endPtr = newStackPtr + (newElems - 2); /* index of last usable item */ eePtr->tosPtr += (newStackPtr - oldStackPtr); - newStackPtr[-1] = (Tcl_Obj *) ((char *) 1); + newStackPtr[-1] = (Tcl_Obj *) ((char *) 1); +} + +/* + *-------------------------------------------------------------- + * + * TclStackAlloc -- + * + * Allocate memory from the execution stack; it has to be returned later + * with a call to TclStackFree + * + * Results: + * A pointer to the first byte allocated, or panics if the allocation did + * not succeed. + * + * Side effects: + * The execution stack may be grown. + * + *-------------------------------------------------------------- + */ + +char * +TclStackAlloc(interp, numBytes) + Tcl_Interp *interp; + int numBytes; +{ + Interp *iPtr = (Interp *) interp; + ExecEnv *eePtr = iPtr->execEnvPtr; + int numWords; + Tcl_Obj **tosPtr = eePtr->tosPtr; + char **stackRefCountPtr; + + /* + * Add two words to store + * - a pointer to the used execution stack + * - the number of words reserved + * These will be used later by TclStackFree. + */ + + numWords = (numBytes + 3*sizeof(void *) - 1)/sizeof(void *); + + while ((tosPtr + numWords) > eePtr->endPtr) { + GrowEvaluationStack(eePtr); + tosPtr = eePtr->tosPtr; + } + + /* + * Increase the stack's reference count, to make sure it is not freed + * prematurely. + */ + + stackRefCountPtr = (char **) (eePtr->stackPtr-1); + ++*stackRefCountPtr; + + /* + * Reserve the space in the exec stack, and store the data for freeing. + */ + + eePtr->tosPtr += numWords; + *(eePtr->tosPtr-1) = (Tcl_Obj *) stackRefCountPtr; + *(eePtr->tosPtr) = (Tcl_Obj *) numWords; + + return (char *) (tosPtr+1); +} + +void +TclStackFree(interp) + Tcl_Interp *interp; +{ + Interp *iPtr = (Interp *) interp; + ExecEnv *eePtr = iPtr->execEnvPtr; + char **stackRefCountPtr; + + stackRefCountPtr = (char **) *(eePtr->tosPtr-1); + eePtr->tosPtr -= (int) *(eePtr->tosPtr); + + --*stackRefCountPtr; + if (*stackRefCountPtr == (char *) 0) { + ckfree((VOID *) stackRefCountPtr); + } } /* *-------------------------------------------------------------- * @@ -662,45 +770,44 @@ * Tcl_ExprObj -- * * Evaluate an expression in a Tcl_Obj. * * Results: - * A standard Tcl object result. If the result is other than TCL_OK, - * then the interpreter's result contains an error message. If the - * result is TCL_OK, then a pointer to the expression's result value - * object is stored in resultPtrPtr. In that case, the object's ref - * count is incremented to reflect the reference returned to the - * caller; the caller is then responsible for the resulting object - * and must, for example, decrement the ref count when it is finished - * with the object. + * A standard Tcl object result. If the result is other than TCL_OK, then + * the interpreter's result contains an error message. If the result is + * TCL_OK, then a pointer to the expression's result value object is + * stored in resultPtrPtr. In that case, the object's ref count is + * incremented to reflect the reference returned to the caller; the + * caller is then responsible for the resulting object and must, for + * example, decrement the ref count when it is finished with the object. * * Side effects: - * Any side effects caused by subcommands in the expression, if any. - * The interpreter result is not modified unless there is an error. + * Any side effects caused by subcommands in the expression, if any. The + * interpreter result is not modified unless there is an error. * *-------------------------------------------------------------- */ int Tcl_ExprObj(interp, objPtr, resultPtrPtr) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ - register Tcl_Obj *objPtr; /* Points to Tcl object containing - * expression to evaluate. */ + register Tcl_Obj *objPtr; /* Points to Tcl object containing expression + * to evaluate. */ Tcl_Obj **resultPtrPtr; /* Where the Tcl_Obj* that is the expression * result is stored if no errors occur. */ { Interp *iPtr = (Interp *) interp; - CompileEnv compEnv; /* Compilation environment structure - * allocated in frame. */ + CompileEnv compEnv; /* Compilation environment structure allocated + * in frame. */ LiteralTable *localTablePtr = &(compEnv.localLitTable); register ByteCode *codePtr = NULL; - /* Tcl Internal type of bytecode. - * Initialized to avoid compiler warning. */ + /* Tcl Internal type of bytecode. Initialized + * to avoid compiler warning. */ AuxData *auxDataPtr; LiteralEntry *entryPtr; - Tcl_Obj *saveObjPtr; + Tcl_Obj *saveObjPtr, *resultPtr; char *string; int length, i, result; /* * First handle some common expressions specially. @@ -707,41 +814,43 @@ */ string = Tcl_GetStringFromObj(objPtr, &length); if (length == 1) { if (*string == '0') { - *resultPtrPtr = Tcl_NewLongObj(0); - Tcl_IncrRefCount(*resultPtrPtr); + TclNewBooleanObj(resultPtr, 0); + Tcl_IncrRefCount(resultPtr); + *resultPtrPtr = resultPtr; return TCL_OK; } else if (*string == '1') { - *resultPtrPtr = Tcl_NewLongObj(1); - Tcl_IncrRefCount(*resultPtrPtr); + TclNewBooleanObj(resultPtr, 1); + Tcl_IncrRefCount(resultPtr); + *resultPtrPtr = resultPtr; return TCL_OK; } } else if ((length == 2) && (*string == '!')) { if (*(string+1) == '0') { - *resultPtrPtr = Tcl_NewLongObj(1); - Tcl_IncrRefCount(*resultPtrPtr); + TclNewBooleanObj(resultPtr, 1); + Tcl_IncrRefCount(resultPtr); + *resultPtrPtr = resultPtr; return TCL_OK; } else if (*(string+1) == '1') { - *resultPtrPtr = Tcl_NewLongObj(0); - Tcl_IncrRefCount(*resultPtrPtr); + TclNewBooleanObj(resultPtr, 0); + Tcl_IncrRefCount(resultPtr); + *resultPtrPtr = resultPtr; return TCL_OK; } } /* * Get the ByteCode from the object. If it exists, make sure it hasn't - * been invalidated by, e.g., someone redefining a command with a - * compile procedure (this might make the compiled code wrong). If - * necessary, convert the object to be a ByteCode object and compile it. - * Also, if the code was compiled in/for a different interpreter, we - * recompile it. - * - * Precompiled expressions, however, are immutable and therefore - * they are not recompiled, even if the epoch has changed. - * + * been invalidated by, e.g., someone redefining a command with a compile + * procedure (this might make the compiled code wrong). If necessary, + * convert the object to be a ByteCode object and compile it. Also, if + * the code was compiled in/for a different interpreter, we recompile it. + * + * Precompiled expressions, however, are immutable and therefore they are + * not recompiled, even if the epoch has changed. */ if (objPtr->typePtr == &tclByteCodeType) { codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; if (((Interp *) *codePtr->interpHandle != iPtr) @@ -760,18 +869,18 @@ if (objPtr->typePtr != &tclByteCodeType) { TclInitCompileEnv(interp, &compEnv, string, length); result = TclCompileExpr(interp, string, length, &compEnv); /* - * Free the compilation environment's literal table bucket array if - * it was dynamically allocated. + * Free the compilation environment's literal table bucket array if it + * was dynamically allocated. */ if (localTablePtr->buckets != localTablePtr->staticBuckets) { ckfree((char *) localTablePtr->buckets); } - + if (result != TCL_OK) { /* * Compilation errors. Free storage allocated for compilation. */ @@ -797,23 +906,23 @@ TclFreeCompileEnv(&compEnv); return result; } /* - * Successful compilation. If the expression yielded no - * instructions, push an zero object as the expression's result. + * Successful compilation. If the expression yielded no instructions, + * push an zero object as the expression's result. */ - + if (compEnv.codeNext == compEnv.codeStart) { - TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, /*onHeap*/ 0), + TclEmitPush(TclRegisterNewLiteral(&compEnv, "0", 1), &compEnv); } /* * Add a "done" instruction as the last instruction and change the - * object into a ByteCode object. Ownership of the literal objects - * and aux data items is given to the ByteCode object. + * object into a ByteCode object. Ownership of the literal objects and + * aux data items is given to the ByteCode object. */ TclEmitOpcode(INST_DONE, &compEnv); TclInitByteCodeObj(objPtr, &compEnv); TclFreeCompileEnv(&compEnv); @@ -826,42 +935,42 @@ } /* * Execute the expression after first saving the interpreter's result. */ - + saveObjPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(saveObjPtr); Tcl_ResetResult(interp); /* * Increment the code's ref count while it is being executed. If * afterwards no references to it remain, free the code. */ - + codePtr->refCount++; result = TclExecuteByteCode(interp, codePtr); codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); objPtr->typePtr = NULL; objPtr->internalRep.otherValuePtr = NULL; } - + /* - * If the expression evaluated successfully, store a pointer to its - * value object in resultPtrPtr then restore the old interpreter result. - * We increment the object's ref count to reflect the reference that we - * are returning to the caller. We also decrement the ref count of the - * interpreter's result object after calling Tcl_SetResult since we - * next store into that field directly. + * If the expression evaluated successfully, store a pointer to its value + * object in resultPtrPtr then restore the old interpreter result. We + * increment the object's ref count to reflect the reference that we are + * returning to the caller. We also decrement the ref count of the + * interpreter's result object after calling Tcl_SetResult since we next + * store into that field directly. */ - + if (result == TCL_OK) { *resultPtrPtr = iPtr->objResultPtr; Tcl_IncrRefCount(iPtr->objResultPtr); - + Tcl_SetObjResult(interp, saveObjPtr); } TclDecrRefCount(saveObjPtr); return result; } @@ -869,18 +978,17 @@ /* *---------------------------------------------------------------------- * * TclCompEvalObj -- * - * This procedure evaluates the script contained in a Tcl_Obj by - * first compiling it and then passing it to TclExecuteByteCode. + * This procedure evaluates the script contained in a Tcl_Obj by first + * compiling it and then passing it to TclExecuteByteCode. * * Results: - * The return value is one of the return codes defined in tcl.h - * (such as TCL_OK), and interp->objResultPtr refers to a Tcl object - * that either contains the result of executing the code or an - * error message. + * The return value is one of the return codes defined in tcl.h (such as + * TCL_OK), and interp->objResultPtr refers to a Tcl object that either + * contains the result of executing the code or an error message. * * Side effects: * Almost certainly, depending on the ByteCode's instructions. * *---------------------------------------------------------------------- @@ -910,44 +1018,41 @@ namespacePtr = iPtr->varFramePtr->nsPtr; } else { namespacePtr = iPtr->globalNsPtr; } - /* - * If the object is not already of tclByteCodeType, compile it (and - * reset the compilation flags in the interpreter; this should be - * done after any compilation). - * Otherwise, check that it is "fresh" enough. + /* + * If the object is not already of tclByteCodeType, compile it (and reset + * the compilation flags in the interpreter; this should be done after any + * compilation). Otherwise, check that it is "fresh" enough. */ if (objPtr->typePtr != &tclByteCodeType) { - recompileObj: - iPtr->errorLine = 1; + recompileObj: + iPtr->errorLine = 1; result = tclByteCodeType.setFromAnyProc(interp, objPtr); if (result != TCL_OK) { iPtr->numLevels--; return result; } - iPtr->evalFlags = 0; codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; } else { /* - * Make sure the Bytecode hasn't been invalidated by, e.g., someone - * redefining a command with a compile procedure (this might make the - * compiled code wrong). - * The object needs to be recompiled if it was compiled in/for a - * different interpreter, or for a different namespace, or for the - * same namespace but with different name resolution rules. - * Precompiled objects, however, are immutable and therefore - * they are not recompiled, even if the epoch has changed. + * Make sure the Bytecode hasn't been invalidated by, e.g., someone + * redefining a command with a compile procedure (this might make the + * compiled code wrong). The object needs to be recompiled if it was + * compiled in/for a different interpreter, or for a different + * namespace, or for the same namespace but with different name + * resolution rules. Precompiled objects, however, are immutable and + * therefore they are not recompiled, even if the epoch has changed. * * To be pedantically correct, we should also check that the * originating procPtr is the same as the current context procPtr - * (assuming one exists at all - none for global level). This - * code is #def'ed out because [info body] was changed to never - * return a bytecode type object, which should obviate us from - * the extra checks here. + * (assuming one exists at all - none for global level). This code is + * #def'ed out because [info body] was changed to never return a + * bytecode type object, which should obviate us from the extra checks + * here. */ codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) #ifdef CHECK_PROC_ORIGINATION /* [Bug: 3412 Pedantic] */ @@ -987,81 +1092,153 @@ } /* *---------------------------------------------------------------------- * + * 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 returns when a "done" instruction is executed or an error occurs. + * This procedure executes the instructions of a ByteCode structure. It + * returns when a "done" instruction is executed or an error occurs. * * Results: - * The return value is one of the return codes defined in tcl.h - * (such as TCL_OK), and interp->objResultPtr refers to a Tcl object - * that either contains the result of executing the code or an - * error message. + * The return value is one of the return codes defined in tcl.h (such as + * TCL_OK), and interp->objResultPtr refers to a Tcl object that either + * contains the result of executing the code or an error message. * * Side effects: * Almost certainly, depending on the ByteCode's instructions. * *---------------------------------------------------------------------- */ - + static int TclExecuteByteCode(interp, codePtr) Tcl_Interp *interp; /* Token for command interpreter. */ ByteCode *codePtr; /* The bytecode sequence to interpret. */ { /* * Compiler cast directive - not a real variable. - * Interp *iPtr = (Interp *) interp; + * Interp *iPtr = (Interp *) interp; */ #define iPtr ((Interp *) interp) /* - * Constants: variables that do not change during the execution, - * used sporadically. + * Constants: variables that do not change during the execution, used + * sporadically. */ - ExecEnv *eePtr; /* Points to the execution environment. */ - int initStackTop; /* Stack top at start of execution. */ - int initCatchTop; /* Catch stack top at start of execution. */ + ExecEnv *eePtr; /* Points to the execution environment. */ + int initStackTop; /* Stack top at start of execution. */ + int initCatchTop; /* Catch stack top at start of execution. */ Var *compiledLocals; Namespace *namespacePtr; /* - * Globals: variables that store state, must remain valid at - * all times. + * Globals: variables that store state, must remain valid at all times. */ - + int catchTop; register Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation stack. */ register unsigned char *pc = codePtr->codeStart; /* The current program counter. */ - int instructionCount = 0; /* Counter that is used to work out - * when to call Tcl_AsyncReady() */ + int instructionCount = 0; /* Counter that is used to work out when to + * call Tcl_AsyncReady() */ Tcl_Obj *expandNestList = NULL; + int checkInterp = 0; /* Indicates when a check of interp readyness + * is necessary. Set by DECACHE_STACK_INFO() */ /* - * Transfer variables - needed only between opcodes, but not - * while executing an instruction. + * Transfer variables - needed only between opcodes, but not while + * executing an instruction. */ register int cleanup; Tcl_Obj *objResultPtr; - /* - * Result variable - needed only when going to checkForcatch or - * other error handlers; also used as local in some opcodes. + * Result variable - needed only when going to checkForcatch or other + * error handlers; also used as local in some opcodes. */ int result = TCL_OK; /* Return code returned after execution. */ /* - * Locals - variables that are used within opcodes or bounded sections - * of the file (jumps between opcodes within a family). + * Locals - variables that are used within opcodes or bounded sections of + * the file (jumps between opcodes within a family). * NOTE: These are now defined locally where needed. */ #ifdef TCL_COMPILE_DEBUG int traceInstructions = (tclTraceExec == 3); @@ -1070,23 +1247,23 @@ /* * The execution uses a unified stack: first the catch stack, immediately * above it the execution stack. * - * Make sure the catch stack is large enough to hold the maximum number - * of catch commands that could ever be executing at the same time (this - * will be no more than the exception range array's depth). - * Make sure the execution stack is large enough to execute this ByteCode. + * Make sure the catch stack is large enough to hold the maximum number of + * catch commands that could ever be executing at the same time (this will + * be no more than the exception range array's depth). Make sure the + * execution stack is large enough to execute this ByteCode. */ eePtr = iPtr->execEnvPtr; initCatchTop = eePtr->tosPtr - eePtr->stackPtr; catchTop = initCatchTop; tosPtr = eePtr->tosPtr + codePtr->maxExceptDepth; while ((tosPtr + codePtr->maxStackDepth) > eePtr->endPtr) { - GrowEvaluationStack(eePtr); + GrowEvaluationStack(eePtr); tosPtr = eePtr->tosPtr + codePtr->maxExceptDepth; } initStackTop = tosPtr - eePtr->stackPtr; #ifdef TCL_COMPILE_DEBUG @@ -1094,1566 +1271,1538 @@ PrintByteCodeInfo(codePtr); fprintf(stdout, " Starting stack top=%d\n", initStackTop); fflush(stdout); } #endif - + #ifdef TCL_COMPILE_STATS iPtr->stats.numExecutions++; #endif if (iPtr->varFramePtr != NULL) { - namespacePtr = iPtr->varFramePtr->nsPtr; - compiledLocals = iPtr->varFramePtr->compiledLocals; - } else { - namespacePtr = iPtr->globalNsPtr; - compiledLocals = NULL; - } - - /* - * Loop executing instructions until a "done" instruction, a - * TCL_RETURN, or some error. - */ - - goto cleanup0; - - - /* - * Targets for standard instruction endings; unrolled - * for speed in the most frequent cases (instructions that - * consume up to two stack elements). - * - * This used to be a "for(;;)" loop, with each instruction doing - * its own cleanup. - */ - - { - Tcl_Obj *valuePtr; - - cleanupV_pushObjResultPtr: - switch (cleanup) { - case 0: - *(++tosPtr) = (objResultPtr); - goto cleanup0; - default: - cleanup -= 2; - while (cleanup--) { - valuePtr = POP_OBJECT(); - TclDecrRefCount(valuePtr); - } - case 2: - cleanup2_pushObjResultPtr: - valuePtr = POP_OBJECT(); - TclDecrRefCount(valuePtr); - case 1: - cleanup1_pushObjResultPtr: - valuePtr = *tosPtr; - TclDecrRefCount(valuePtr); - } - *tosPtr = objResultPtr; - goto cleanup0; - - cleanupV: - switch (cleanup) { - default: - cleanup -= 2; - while (cleanup--) { - valuePtr = POP_OBJECT(); - TclDecrRefCount(valuePtr); - } - case 2: - cleanup2: - valuePtr = POP_OBJECT(); - TclDecrRefCount(valuePtr); - case 1: - cleanup1: - valuePtr = POP_OBJECT(); - TclDecrRefCount(valuePtr); - case 0: - /* - * We really want to do nothing now, but this is needed - * for some compilers (SunPro CC) - */ - break; - } - } - cleanup0: - + namespacePtr = iPtr->varFramePtr->nsPtr; + compiledLocals = iPtr->varFramePtr->compiledLocals; + } else { + namespacePtr = iPtr->globalNsPtr; + compiledLocals = NULL; + } + + /* + * Loop executing instructions until a "done" instruction, a TCL_RETURN, + * or some error. + */ + + goto cleanup0; + + /* + * Targets for standard instruction endings; unrolled for speed in the + * most frequent cases (instructions that consume up to two stack + * elements). + * + * This used to be a "for(;;)" loop, with each instruction doing its own + * cleanup. + */ + + { + Tcl_Obj *valuePtr; + + cleanupV_pushObjResultPtr: + switch (cleanup) { + case 0: + *(++tosPtr) = (objResultPtr); + goto cleanup0; + default: + cleanup -= 2; + while (cleanup--) { + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + } + case 2: + cleanup2_pushObjResultPtr: + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + case 1: + cleanup1_pushObjResultPtr: + valuePtr = *tosPtr; + TclDecrRefCount(valuePtr); + } + *tosPtr = objResultPtr; + goto cleanup0; + + cleanupV: + switch (cleanup) { + default: + cleanup -= 2; + while (cleanup--) { + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + } + case 2: + cleanup2: + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + case 1: + cleanup1: + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + case 0: + /* + * We really want to do nothing now, but this is needed for some + * compilers (SunPro CC) + */ + break; + } + } + cleanup0: + #ifdef TCL_COMPILE_DEBUG /* * Skip the stack depth check if an expansion is in progress */ ValidatePcAndStackTop(codePtr, pc, (tosPtr - eePtr->stackPtr), - initStackTop, /*checkStack*/ (expandNestList == NULL)); + initStackTop, /*checkStack*/ (expandNestList == NULL)); if (traceInstructions) { fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (tosPtr - eePtr->stackPtr)); TclPrintInstruction(codePtr, pc); fflush(stdout); } #endif /* TCL_COMPILE_DEBUG */ - -#ifdef TCL_COMPILE_STATS + +#ifdef TCL_COMPILE_STATS iPtr->stats.instructionCount[*pc]++; #endif /* - * Check for asynchronous handlers [Bug 746722]; we - * do the check every ASYNC_CHECK_COUNT_MASK instruction, - * of the form (2**n-1). + * Check for asynchronous handlers [Bug 746722]; we do the check every + * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1). */ if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) { if (Tcl_AsyncReady()) { + int localResult; DECACHE_STACK_INFO(); - result = Tcl_AsyncInvoke(interp, result); + localResult = Tcl_AsyncInvoke(interp, result); CACHE_STACK_INFO(); - if (result == TCL_ERROR) { + if (localResult == TCL_ERROR) { + result = localResult; goto checkForCatch; } } if (Tcl_LimitReady(interp)) { + int localResult; DECACHE_STACK_INFO(); - result = Tcl_LimitCheck(interp); + localResult = Tcl_LimitCheck(interp); CACHE_STACK_INFO(); - if (result == TCL_ERROR) { + if (localResult == TCL_ERROR) { + result = localResult; goto checkForCatch; } } } switch (*pc) { - case INST_RETURN: - { - int code = TclGetInt4AtPtr(pc+1); - int level = TclGetUInt4AtPtr(pc+5); - Tcl_Obj *returnOpts = POP_OBJECT(); - - result = TclProcessReturn(interp, code, level, returnOpts); - Tcl_DecrRefCount(returnOpts); - if (result != TCL_OK) { - Tcl_SetObjResult(interp, *tosPtr); - cleanup = 1; - goto processExceptionReturn; - } - NEXT_INST_F(9, 0, 0); - } + case INST_RETURN_IMM: { + int code = TclGetInt4AtPtr(pc+1); + int level = TclGetUInt4AtPtr(pc+5); + Tcl_Obj *returnOpts; + + TRACE(("%u %u => ", code, level)); + returnOpts = POP_OBJECT(); + result = TclProcessReturn(interp, code, level, returnOpts); + Tcl_DecrRefCount(returnOpts); + if (result != TCL_OK) { + Tcl_SetObjResult(interp, *tosPtr); + cleanup = 1; + goto processExceptionReturn; + } + TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")", + O2S(objResultPtr))); + NEXT_INST_F(9, 0, 0); + } + + case INST_RETURN_STK: + TRACE(("=> ")); + objResultPtr = POP_OBJECT(); + result = Tcl_SetReturnOptions(interp, POP_OBJECT()); + if (result != TCL_OK) { + Tcl_SetObjResult(interp, objResultPtr); + Tcl_DecrRefCount(objResultPtr); + cleanup = 0; + goto processExceptionReturn; + } + TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")", + O2S(objResultPtr))); + NEXT_INST_F(1, 0, -1); case INST_DONE: if (tosPtr <= eePtr->stackPtr + initStackTop) { tosPtr--; goto abnormalReturn; } - + /* - * Set the interpreter's object result to point to the - * topmost object from the stack, and check for a possible - * [catch]. The stackTop's level and refCount will be handled - * by "processCatch" or "abnormalReturn". + * Set the interpreter's object result to point to the topmost object + * from the stack, and check for a possible [catch]. The stackTop's + * level and refCount will be handled by "processCatch" or + * "abnormalReturn". */ Tcl_SetObjResult(interp, *tosPtr); -#ifdef TCL_COMPILE_DEBUG +#ifdef TCL_COMPILE_DEBUG TRACE_WITH_OBJ(("=> return code=%d, result=", result), - iPtr->objResultPtr); + iPtr->objResultPtr); if (traceInstructions) { fprintf(stdout, "\n"); } #endif goto checkForCatch; - + case INST_PUSH1: - objResultPtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]; - TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), objResultPtr); - NEXT_INST_F(2, 0, 1); +#if !TCL_COMPILE_DEBUG + instPush1Peephole: +#endif + PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]); + TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), *tosPtr); + pc += 2; +#if !TCL_COMPILE_DEBUG + /* + * Runtime peephole optimisation: check if we are pushing again. + */ + + if (*pc == INST_PUSH1) { + goto instPush1Peephole; + } +#endif + NEXT_INST_F(0, 0, 0); case INST_PUSH4: objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)]; TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr); NEXT_INST_F(5, 0, 1); - case INST_POP: - { - Tcl_Obj *valuePtr; - - TRACE_WITH_OBJ(("=> discarding "), *tosPtr); - valuePtr = POP_OBJECT(); - TclDecrRefCount(valuePtr); - } + case INST_POP: { + Tcl_Obj *valuePtr; + + TRACE_WITH_OBJ(("=> discarding "), *tosPtr); + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); /* - * Runtime peephole optimisation: an INST_POP is scheduled - * at the end of most commands. If the next instruction is an - * INST_START_CMD, fall through to it. + * Runtime peephole optimisation: an INST_POP is scheduled at the end + * of most commands. If the next instruction is an INST_START_CMD, + * fall through to it. */ + pc++; - if (*pc != INST_START_CMD) { - NEXT_INST_F(0, 0, 0); +#if !TCL_COMPILE_DEBUG + if (*pc == INST_START_CMD) { + goto instStartCmdPeephole; } - +#endif + NEXT_INST_F(0, 0, 0); + } + case INST_START_CMD: +#if !TCL_COMPILE_DEBUG + instStartCmdPeephole: +#endif /* - * Remark that if the interpreter is marked for deletion - * its compileEpoch is modified, so that the epoch - * check also verifies that the interp is not deleted. + * Remark that if the interpreter is marked for deletion its + * compileEpoch is modified, so that the epoch check also verifies + * that the interp is not deleted. If no outside call has been made + * since the last check, it is safe to omit the check. */ iPtr->cmdCount++; - if (((codePtr->compileEpoch == iPtr->compileEpoch) - && (codePtr->nsEpoch == namespacePtr->resolverEpoch)) - || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { + if (!checkInterp || + (((codePtr->compileEpoch == iPtr->compileEpoch) + && (codePtr->nsEpoch == namespacePtr->resolverEpoch)) + || (codePtr->flags & TCL_BYTECODE_PRECOMPILED))) { +#if !TCL_COMPILE_DEBUG + /* + * Peephole optimisations: check if there are several + * INST_START_CMD in a row. Many commands start by pushing a + * literal argument or command name; optimise that case too. + */ + + while (*(pc += 5) == INST_START_CMD) { + iPtr->cmdCount++; + } + if (*pc == INST_PUSH1) { + goto instPush1Peephole; + } + NEXT_INST_F(0, 0, 0); +#else NEXT_INST_F(5, 0, 0); +#endif } else { char *bytes; int length, opnd; Tcl_Obj *newObjResultPtr; - + bytes = GetSrcInfoForPc(pc, codePtr, &length); - DECACHE_STACK_INFO(); + DECACHE_STACK_INFO(); result = Tcl_EvalEx(interp, bytes, length, 0); CACHE_STACK_INFO(); if (result != TCL_OK) { cleanup = 0; goto processExceptionReturn; } opnd = TclGetUInt4AtPtr(pc+1); objResultPtr = Tcl_GetObjResult(interp); - { - TclNewObj(newObjResultPtr); - Tcl_IncrRefCount(newObjResultPtr); - iPtr->objResultPtr = newObjResultPtr; - } - NEXT_INST_V(opnd, 0, -1); - } - - case INST_DUP: - objResultPtr = *tosPtr; - TRACE_WITH_OBJ(("=> "), objResultPtr); - NEXT_INST_F(1, 0, 1); - - case INST_OVER: - { - int opnd; - - opnd = TclGetUInt4AtPtr(pc+1); - objResultPtr = *(tosPtr - opnd); - TRACE_WITH_OBJ(("=> "), objResultPtr); - NEXT_INST_F(5, 0, 1); - } - - case INST_CONCAT1: - { - int opnd, length, appendLen = 0; - char *bytes, *p; - Tcl_Obj **currPtr; - - opnd = TclGetUInt1AtPtr(pc+1); - - /* - * Compute the length to be appended. - */ - - for (currPtr = tosPtr - (opnd-2); currPtr <= tosPtr; - currPtr++) { - bytes = Tcl_GetStringFromObj(*currPtr, &length); - if (bytes != NULL) { - appendLen += length; - } - } - - /* - * If nothing is to be appended, just return the first - * object by dropping all the others from the stack; this - * saves both the computation and copy of the string rep - * of the first object, enabling the fast '$x[set x {}]' - * idiom for 'K $x [set x{}]'. - */ - - if (appendLen == 0) { - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); - NEXT_INST_V(2, (opnd-1), 0); - } - - /* - * If the first object is shared, we need a new obj for - * the result; otherwise, we can reuse the first object. - * In any case, make sure it has enough room to accomodate - * all the concatenated bytes. Note that if it is unshared - * its bytes are already copied by Tcl_SetObjectLength, so - * that we set the loop parameters to avoid copying them - * again: p points to the end of the already copied bytes, - * currPtr to the second object. - */ - - objResultPtr = *(tosPtr-(opnd-1)); - bytes = Tcl_GetStringFromObj(objResultPtr, &length); -#if !TCL_COMPILE_DEBUG - if (!Tcl_IsShared(objResultPtr)) { - Tcl_SetObjLength(objResultPtr, (length + appendLen)); - p = TclGetString(objResultPtr) + length; - currPtr = tosPtr - (opnd - 2); - } else { -#endif - p = (char *) ckalloc((unsigned) (length + appendLen + 1)); - TclNewObj(objResultPtr); - objResultPtr->bytes = p; - objResultPtr->length = length + appendLen; - currPtr = tosPtr - (opnd - 1); -#if !TCL_COMPILE_DEBUG - } -#endif - - /* - * Append the remaining characters. - */ - - for (; currPtr <= tosPtr; currPtr++) { - bytes = Tcl_GetStringFromObj(*currPtr, &length); - if (bytes != NULL) { - memcpy((VOID *) p, (VOID *) bytes, - (size_t) length); - p += length; - } - } - *p = '\0'; - - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); - NEXT_INST_V(2, opnd, 1); - } - - case INST_EXPAND_START: - /* - * Push an element to the expandNestList. This records - * the current tosPtr - i.e., the point in the stack - * where the expanded command starts. - * - * Use a Tcl_Obj as linked list element; slight mem waste, - * but faster allocation than ckalloc. This also abuses - * the Tcl_Obj structure, as we do not define a special - * tclObjType for it. It is not dangerous as the obj is - * never passed anywhere, so that all manipulations are - * performed here and in INST_INVOKE_EXPANDED (in case of - * an expansion error, also in INST_EXPAND_STKTOP). - */ - - { - Tcl_Obj *objPtr; - - TclNewObj(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) (tosPtr - eePtr->stackPtr); - objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) expandNestList; - expandNestList = objPtr; - NEXT_INST_F(1, 0, 0); - } - - case INST_EXPAND_STKTOP: - { - int objc, length, i; - Tcl_Obj **objv, *valuePtr, *objPtr; - - /* - * Make sure that the element at stackTop is a list; if not, - * remove the element from the expand link list and leave. - */ - - - valuePtr = *tosPtr; - result = Tcl_ListObjGetElements(interp, valuePtr, &objc, &objv); - if (result != TCL_OK) { - TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), - Tcl_GetObjResult(interp)); - objPtr = expandNestList; - expandNestList = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2; - TclDecrRefCount(objPtr); - goto checkForCatch; - } - tosPtr--; - - /* - * Make sure there is enough room in the stack to expand - * this list *and* process the rest of the command (at least - * up to the next argument expansion or command end). - * The operand is the current stack depth, as seen by the - * compiler. - */ - - length = objc + codePtr->maxStackDepth - TclGetInt4AtPtr(pc+1); - while ((tosPtr + length) > eePtr->endPtr) { - DECACHE_STACK_INFO(); - GrowEvaluationStack(eePtr); - CACHE_STACK_INFO(); - } - - /* - * Expand the list at stacktop onto the stack; free the list. - */ - - for (i = 0; i < objc; i++) { - PUSH_OBJECT(objv[i]); - } - TclDecrRefCount(valuePtr); - NEXT_INST_F(5, 0, 0); - } - - { - /* - * INVOCATION BLOCK - */ - - int objc, pcAdjustment; - - case INST_INVOKE_EXPANDED: - { - Tcl_Obj *objPtr; - - objPtr = expandNestList; - expandNestList = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2; - objc = tosPtr - eePtr->stackPtr - - (ptrdiff_t) objPtr->internalRep.twoPtrValue.ptr1; - TclDecrRefCount(objPtr); - } - - if (objc == 0) { - /* - * Nothing was expanded, return {}. - */ - - TclNewObj(objResultPtr); - NEXT_INST_F(1, 0, 1); - } - - pcAdjustment = 1; - goto doInvocation; - - case INST_INVOKE_STK4: - objc = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - goto doInvocation; - - case INST_INVOKE_STK1: - objc = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - - doInvocation: - { - Tcl_Obj **objv = (tosPtr - (objc-1)); - int length; - char *bytes; - - /* - * We keep the stack reference count as a (char *), as that - * works nicely as a portable pointer-sized counter. - */ - - char **preservedStackRefCountPtr; - -#ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { - int i; - - if (traceInstructions) { - strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - TRACE(("%u => call ", objc)); - } else { - fprintf(stdout, "%d: (%u) invoking ", - iPtr->numLevels, - (unsigned int)(pc - codePtr->codeStart)); - } - for (i = 0; i < objc; i++) { - TclPrintObject(stdout, objv[i], 15); - fprintf(stdout, " "); - } - fprintf(stdout, "\n"); - fflush(stdout); - } -#endif /*TCL_COMPILE_DEBUG*/ - - /* - * If trace procedures will be called, we need a - * command string to pass to TclEvalObjvInternal; note - * that a copy of the string will be made there to - * include the ending \0. - */ - - bytes = NULL; - length = 0; - if (iPtr->tracePtr != NULL) { - Trace *tracePtr, *nextTracePtr; - - for (tracePtr = iPtr->tracePtr; tracePtr != NULL; - tracePtr = nextTracePtr) { - nextTracePtr = tracePtr->nextPtr; - if (tracePtr->level == 0 || - iPtr->numLevels <= tracePtr->level) { - /* - * Traces will be called: get command string - */ - - bytes = GetSrcInfoForPc(pc, codePtr, &length); - break; - } - } - } else { - Command *cmdPtr; - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); - if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { - bytes = GetSrcInfoForPc(pc, codePtr, &length); - } - } - - /* - * A reference to part of the stack vector itself - * escapes our control: increase its refCount - * to stop it from being deallocated by a recursive - * call to ourselves. The extra variable is needed - * because all others are liable to change due to the - * trace procedures. - */ - - preservedStackRefCountPtr = (char **) (eePtr->stackPtr-1); - ++*preservedStackRefCountPtr; - - /* - * Reset the instructionCount variable, since we're about - * to check for async stuff anyway while processing - * TclEvalObjvInternal. - */ - - instructionCount = 1; - - /* - * Finally, let TclEvalObjvInternal handle the command. - */ - - DECACHE_STACK_INFO(); - Tcl_ResetResult(interp); - result = TclEvalObjvInternal(interp, objc, objv, bytes, length, 0); - CACHE_STACK_INFO(); - - /* - * If the old stack is going to be released, it is - * safe to do so now, since no references to objv are - * going to be used from now on. - */ - - --*preservedStackRefCountPtr; - if (*preservedStackRefCountPtr == (char *) 0) { - ckfree((VOID *) preservedStackRefCountPtr); - } - - if (result == TCL_OK) { - /* - * Push the call's object result and continue execution - * with the next instruction. - */ - - TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=", - objc, cmdNameBuf), Tcl_GetObjResult(interp)); - - objResultPtr = Tcl_GetObjResult(interp); - - /* - * Reset the interp's result to avoid possible duplications - * of large objects [Bug 781585]. We do not call - * Tcl_ResetResult() to avoid any side effects caused by - * the resetting of errorInfo and errorCode [Bug 804681], - * which are not needed here. We chose instead to manipulate - * the interp's object result directly. - * - * Note that the result object is now in objResultPtr, it - * keeps the refCount it had in its role of iPtr->objResultPtr. - */ - { - Tcl_Obj *objPtr; - - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - iPtr->objResultPtr = objPtr; - } - - NEXT_INST_V(pcAdjustment, objc, -1); - } else { - cleanup = objc; - goto processExceptionReturn; - } - } - } - - - case INST_EVAL_STK: - /* - * Note to maintainers: it is important that INST_EVAL_STK - * pop its argument from the stack before jumping to - * checkForCatch! DO NOT OPTIMISE! - */ - - { - Tcl_Obj *objPtr; - - objPtr = *tosPtr; - DECACHE_STACK_INFO(); - result = TclCompEvalObj(interp, objPtr); - CACHE_STACK_INFO(); - if (result == TCL_OK) { - /* - * Normal return; push the eval's object result. - */ - - objResultPtr = Tcl_GetObjResult(interp); - TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), - Tcl_GetObjResult(interp)); - - /* - * Reset the interp's result to avoid possible duplications - * of large objects [Bug 781585]. We do not call - * Tcl_ResetResult() to avoid any side effects caused by - * the resetting of errorInfo and errorCode [Bug 804681], - * which are not needed here. We chose instead to manipulate - * the interp's object result directly. - * - * Note that the result object is now in objResultPtr, it - * keeps the refCount it had in its role of iPtr->objResultPtr. - */ - - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - iPtr->objResultPtr = objPtr; - NEXT_INST_F(1, 1, -1); - } else { - cleanup = 1; - goto processExceptionReturn; - } - } - - case INST_EXPR_STK: - { - Tcl_Obj *objPtr, *valuePtr; - - objPtr = *tosPtr; - DECACHE_STACK_INFO(); - Tcl_ResetResult(interp); - result = Tcl_ExprObj(interp, objPtr, &valuePtr); - CACHE_STACK_INFO(); - if (result != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)), - Tcl_GetObjResult(interp)); - goto checkForCatch; - } - objResultPtr = valuePtr; - TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); - NEXT_INST_F(1, 1, -1); /* already has right refct */ - } - - /* - * --------------------------------------------------------- - * Start of INST_LOAD instructions. - * - * WARNING: more 'goto' here than your doctor recommended! - * The different instructions set the value of some variables - * and then jump to somme common execution code. - */ - { - int opnd, pcAdjustment; - char *part1, *part2; - Var *varPtr, *arrayPtr; - Tcl_Obj *objPtr; - - case INST_LOAD_SCALAR1: - opnd = TclGetUInt1AtPtr(pc+1); - varPtr = &(compiledLocals[opnd]); - part1 = varPtr->name; - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%u => ", opnd)); - if (TclIsVarDirectReadable(varPtr)) { - /* - * No errors, no traces: just get the value. - */ - objResultPtr = varPtr->value.objPtr; - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(2, 0, 1); - } - pcAdjustment = 2; - cleanup = 0; - arrayPtr = NULL; - part2 = NULL; - goto doCallPtrGetVar; - - case INST_LOAD_SCALAR4: - opnd = TclGetUInt4AtPtr(pc+1); - varPtr = &(compiledLocals[opnd]); - part1 = varPtr->name; - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%u => ", opnd)); - if (TclIsVarDirectReadable(varPtr)) { - /* - * No errors, no traces: just get the value. - */ - objResultPtr = varPtr->value.objPtr; - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(5, 0, 1); - } - pcAdjustment = 5; - cleanup = 0; - arrayPtr = NULL; - part2 = NULL; - goto doCallPtrGetVar; - - case INST_LOAD_ARRAY_STK: - cleanup = 2; - part2 = Tcl_GetString(*tosPtr); /* element name */ - objPtr = *(tosPtr - 1); /* array name */ - TRACE(("\"%.30s(%.30s)\" => ", O2S(objPtr), part2)); - goto doLoadStk; - - case INST_LOAD_STK: - case INST_LOAD_SCALAR_STK: - cleanup = 1; - part2 = NULL; - objPtr = *tosPtr; /* variable name */ - TRACE(("\"%.30s\" => ", O2S(objPtr))); - - doLoadStk: - part1 = TclGetString(objPtr); - varPtr = TclObjLookupVar(interp, objPtr, part2, - TCL_LEAVE_ERR_MSG, "read", - /*createPart1*/ 0, - /*createPart2*/ 1, &arrayPtr); - if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - result = TCL_ERROR; - goto checkForCatch; - } - if (TclIsVarDirectReadable(varPtr) - && ((arrayPtr == NULL) - || TclIsVarUntraced(arrayPtr))) { - /* - * No errors, no traces: just get the value. - */ - objResultPtr = varPtr->value.objPtr; - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(1, cleanup, 1); - } - pcAdjustment = 1; - goto doCallPtrGetVar; - - case INST_LOAD_ARRAY4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - goto doLoadArray; - - case INST_LOAD_ARRAY1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - - doLoadArray: - part2 = TclGetString(*tosPtr); - arrayPtr = &(compiledLocals[opnd]); - part1 = arrayPtr->name; - while (TclIsVarLink(arrayPtr)) { - arrayPtr = arrayPtr->value.linkPtr; - } - TRACE(("%u \"%.30s\" => ", opnd, part2)); - varPtr = TclLookupArrayElement(interp, part1, part2, - TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr); - if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - result = TCL_ERROR; - goto checkForCatch; - } - if (TclIsVarDirectReadable(varPtr) - && ((arrayPtr == NULL) - || TclIsVarUntraced(arrayPtr))) { - /* - * No errors, no traces: just get the value. - */ - objResultPtr = varPtr->value.objPtr; - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(pcAdjustment, 1, 1); - } - cleanup = 1; - goto doCallPtrGetVar; - - doCallPtrGetVar: - /* - * There are either errors or the variable is traced: - * call TclPtrGetVar to process fully. - */ - - DECACHE_STACK_INFO(); - objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, - part2, TCL_LEAVE_ERR_MSG); + TclNewObj(newObjResultPtr); + Tcl_IncrRefCount(newObjResultPtr); + iPtr->objResultPtr = newObjResultPtr; + NEXT_INST_V(opnd, 0, -1); + } + + case INST_DUP: + objResultPtr = *tosPtr; + TRACE_WITH_OBJ(("=> "), objResultPtr); + NEXT_INST_F(1, 0, 1); + + case INST_OVER: { + int opnd; + + opnd = TclGetUInt4AtPtr(pc+1); + objResultPtr = *(tosPtr - opnd); + TRACE_WITH_OBJ(("=> "), objResultPtr); + NEXT_INST_F(5, 0, 1); + } + + case INST_CONCAT1: { + int opnd, length, appendLen = 0; + char *bytes, *p; + Tcl_Obj **currPtr; + + opnd = TclGetUInt1AtPtr(pc+1); + + /* + * Compute the length to be appended. + */ + + for (currPtr = tosPtr - (opnd-2); currPtr <= tosPtr; currPtr++) { + bytes = Tcl_GetStringFromObj(*currPtr, &length); + if (bytes != NULL) { + appendLen += length; + } + } + + /* + * If nothing is to be appended, just return the first object by + * dropping all the others from the stack; this saves both the + * computation and copy of the string rep of the first object, + * enabling the fast '$x[set x {}]' idiom for 'K $x [set x{}]'. + */ + + if (appendLen == 0) { + TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); + NEXT_INST_V(2, (opnd-1), 0); + } + + /* + * If the first object is shared, we need a new obj for the result; + * otherwise, we can reuse the first object. In any case, make sure + * it has enough room to accomodate all the concatenated bytes. Note + * that if it is unshared its bytes are already copied by + * Tcl_SetObjectLength, so that we set the loop parameters to avoid + * copying them again: p points to the end of the already copied + * bytes, currPtr to the second object. + */ + + objResultPtr = *(tosPtr-(opnd-1)); + bytes = Tcl_GetStringFromObj(objResultPtr, &length); +#if !TCL_COMPILE_DEBUG + if (!Tcl_IsShared(objResultPtr)) { + Tcl_SetObjLength(objResultPtr, (length + appendLen)); + p = TclGetString(objResultPtr) + length; + currPtr = tosPtr - (opnd - 2); + } else { +#endif + p = (char *) ckalloc((unsigned) (length + appendLen + 1)); + TclNewObj(objResultPtr); + objResultPtr->bytes = p; + objResultPtr->length = length + appendLen; + currPtr = tosPtr - (opnd - 1); +#if !TCL_COMPILE_DEBUG + } +#endif + + /* + * Append the remaining characters. + */ + + for (; currPtr <= tosPtr; currPtr++) { + bytes = Tcl_GetStringFromObj(*currPtr, &length); + if (bytes != NULL) { + memcpy((VOID *) p, (VOID *) bytes, (size_t) length); + p += length; + } + } + *p = '\0'; + + TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); + NEXT_INST_V(2, opnd, 1); + } + + case INST_EXPAND_START: { + /* + * Push an element to the expandNestList. This records the current + * tosPtr - i.e., the point in the stack where the expanded command + * starts. + * + * Use a Tcl_Obj as linked list element; slight mem waste, but faster + * allocation than ckalloc. This also abuses the Tcl_Obj structure, as + * we do not define a special tclObjType for it. It is not dangerous + * as the obj is never passed anywhere, so that all manipulations are + * performed here and in INST_INVOKE_EXPANDED (in case of an expansion + * error, also in INST_EXPAND_STKTOP). + */ + + Tcl_Obj *objPtr; + + TclNewObj(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) + (tosPtr - eePtr->stackPtr); + objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) expandNestList; + expandNestList = objPtr; + NEXT_INST_F(1, 0, 0); + } + + case INST_EXPAND_STKTOP: { + int objc, length, i; + Tcl_Obj **objv, *valuePtr, *objPtr; + + /* + * Make sure that the element at stackTop is a list; if not, remove + * the element from the expand link list and leave. + */ + + valuePtr = *tosPtr; + if (Tcl_ListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { + result = TCL_ERROR; + TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), + Tcl_GetObjResult(interp)); + objPtr = expandNestList; + expandNestList = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2; + TclDecrRefCount(objPtr); + goto checkForCatch; + } + tosPtr--; + + /* + * Make sure there is enough room in the stack to expand this list + * *and* process the rest of the command (at least up to the next + * argument expansion or command end). The operand is the current + * stack depth, as seen by the compiler. + */ + + length = objc + codePtr->maxStackDepth - TclGetInt4AtPtr(pc+1); + while ((tosPtr + length) > eePtr->endPtr) { + DECACHE_STACK_INFO(); + GrowEvaluationStack(eePtr); + CACHE_STACK_INFO(); + } + + /* + * Expand the list at stacktop onto the stack; free the list. + */ + + for (i = 0; i < objc; i++) { + PUSH_OBJECT(objv[i]); + } + TclDecrRefCount(valuePtr); + NEXT_INST_F(5, 0, 0); + } + + { + /* + * INVOCATION BLOCK + */ + + int objc, pcAdjustment; + + case INST_INVOKE_EXPANDED: + { + Tcl_Obj *objPtr; + + objPtr = expandNestList; + expandNestList = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2; + objc = tosPtr - eePtr->stackPtr + - (ptrdiff_t) objPtr->internalRep.twoPtrValue.ptr1; + TclDecrRefCount(objPtr); + } + + if (objc == 0) { + /* + * Nothing was expanded, return {}. + */ + + TclNewObj(objResultPtr); + NEXT_INST_F(1, 0, 1); + } + + pcAdjustment = 1; + goto doInvocation; + + case INST_INVOKE_STK4: + objc = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + goto doInvocation; + + case INST_INVOKE_STK1: + objc = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + + doInvocation: + { + Tcl_Obj **objv = (tosPtr - (objc-1)); + int length; + char *bytes; + + /* + * We keep the stack reference count as a (char *), as that works + * nicely as a portable pointer-sized counter. + */ + + char **preservedStackRefCountPtr; + +#ifdef TCL_COMPILE_DEBUG + if (tclTraceExec >= 2) { + int i; + + if (traceInstructions) { + strncpy(cmdNameBuf, TclGetString(objv[0]), 20); + TRACE(("%u => call ", objc)); + } else { + fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels, + (unsigned int)(pc - codePtr->codeStart)); + } + for (i = 0; i < objc; i++) { + TclPrintObject(stdout, objv[i], 15); + fprintf(stdout, " "); + } + fprintf(stdout, "\n"); + fflush(stdout); + } +#endif /*TCL_COMPILE_DEBUG*/ + + /* + * If trace procedures will be called, we need a command string to + * pass to TclEvalObjvInternal; note that a copy of the string + * will be made there to include the ending \0. + */ + + bytes = NULL; + length = 0; + if (iPtr->tracePtr != NULL) { + Trace *tracePtr, *nextTracePtr; + + for (tracePtr = iPtr->tracePtr; tracePtr != NULL; + tracePtr = nextTracePtr) { + nextTracePtr = tracePtr->nextPtr; + if (tracePtr->level == 0 || + iPtr->numLevels <= tracePtr->level) { + /* + * Traces will be called: get command string + */ + + bytes = GetSrcInfoForPc(pc, codePtr, &length); + break; + } + } + } else { + Command *cmdPtr; + + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); + if ((cmdPtr!=NULL) && (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { + bytes = GetSrcInfoForPc(pc, codePtr, &length); + } + } + + /* + * A reference to part of the stack vector itself escapes our + * control: increase its refCount to stop it from being + * deallocated by a recursive call to ourselves. The extra + * variable is needed because all others are liable to change due + * to the trace procedures. + */ + + preservedStackRefCountPtr = (char **) (eePtr->stackPtr-1); + ++*preservedStackRefCountPtr; + + /* + * Reset the instructionCount variable, since we're about to check + * for async stuff anyway while processing TclEvalObjvInternal. + */ + + instructionCount = 1; + + /* + * Finally, let TclEvalObjvInternal handle the command. + */ + + DECACHE_STACK_INFO(); + Tcl_ResetResult(interp); + result = TclEvalObjvInternal(interp, objc, objv, bytes, length, 0); + CACHE_STACK_INFO(); + + /* + * If the old stack is going to be released, it is safe to do so + * now, since no references to objv are going to be used from now + * on. + */ + + --*preservedStackRefCountPtr; + if (*preservedStackRefCountPtr == (char *) 0) { + ckfree((VOID *) preservedStackRefCountPtr); + } + + if (result == TCL_OK) { + Tcl_Obj *objPtr; + /* + * Push the call's object result and continue execution with + * the next instruction. + */ + + TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=", + objc, cmdNameBuf), Tcl_GetObjResult(interp)); + + objResultPtr = Tcl_GetObjResult(interp); + + /* + * Reset the interp's result to avoid possible duplications of + * large objects [Bug 781585]. We do not call Tcl_ResetResult + * to avoid any side effects caused by the resetting of + * errorInfo and errorCode [Bug 804681], which are not needed + * here. We chose instead to manipulate the interp's object + * result directly. + * + * Note that the result object is now in objResultPtr, it + * keeps the refCount it had in its role of + * iPtr->objResultPtr. + */ + + TclNewObj(objPtr); + Tcl_IncrRefCount(objPtr); + iPtr->objResultPtr = objPtr; + NEXT_INST_V(pcAdjustment, objc, -1); + } else { + cleanup = objc; + goto processExceptionReturn; + } + } + } + + case INST_EVAL_STK: { + /* + * Note to maintainers: it is important that INST_EVAL_STK pop its + * argument from the stack before jumping to checkForCatch! DO NOT + * OPTIMISE! + */ + + Tcl_Obj *objPtr; + + objPtr = *tosPtr; + DECACHE_STACK_INFO(); + result = TclCompEvalObj(interp, objPtr); + CACHE_STACK_INFO(); + if (result == TCL_OK) { + /* + * Normal return; push the eval's object result. + */ + + objResultPtr = Tcl_GetObjResult(interp); + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), + Tcl_GetObjResult(interp)); + + /* + * Reset the interp's result to avoid possible duplications of + * large objects [Bug 781585]. We do not call Tcl_ResetResult to + * avoid any side effects caused by the resetting of errorInfo and + * errorCode [Bug 804681], which are not needed here. We chose + * instead to manipulate the interp's object result directly. + * + * Note that the result object is now in objResultPtr, it keeps + * the refCount it had in its role of iPtr->objResultPtr. + */ + + TclNewObj(objPtr); + Tcl_IncrRefCount(objPtr); + iPtr->objResultPtr = objPtr; + NEXT_INST_F(1, 1, -1); + } else { + cleanup = 1; + goto processExceptionReturn; + } + } + + case INST_EXPR_STK: { + Tcl_Obj *objPtr, *valuePtr; + + objPtr = *tosPtr; + DECACHE_STACK_INFO(); + Tcl_ResetResult(interp); + result = Tcl_ExprObj(interp, objPtr, &valuePtr); + CACHE_STACK_INFO(); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)), + Tcl_GetObjResult(interp)); + goto checkForCatch; + } + objResultPtr = valuePtr; + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); + NEXT_INST_F(1, 1, -1); /* already has right refct */ + } + + /* + * --------------------------------------------------------- + * Start of INST_LOAD instructions. + * + * WARNING: more 'goto' here than your doctor recommended! The different + * instructions set the value of some variables and then jump to somme + * common execution code. + */ + { + int opnd, pcAdjustment; + char *part1, *part2; + Var *varPtr, *arrayPtr; + Tcl_Obj *objPtr; + + case INST_LOAD_SCALAR1: + opnd = TclGetUInt1AtPtr(pc+1); + varPtr = &(compiledLocals[opnd]); + part1 = varPtr->name; + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + TRACE(("%u => ", opnd)); + if (TclIsVarDirectReadable(varPtr)) { + /* + * No errors, no traces: just get the value. + */ + objResultPtr = varPtr->value.objPtr; + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(2, 0, 1); + } + pcAdjustment = 2; + cleanup = 0; + arrayPtr = NULL; + part2 = NULL; + goto doCallPtrGetVar; + + case INST_LOAD_SCALAR4: + opnd = TclGetUInt4AtPtr(pc+1); + varPtr = &(compiledLocals[opnd]); + part1 = varPtr->name; + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + TRACE(("%u => ", opnd)); + if (TclIsVarDirectReadable(varPtr)) { + /* + * No errors, no traces: just get the value. + */ + objResultPtr = varPtr->value.objPtr; + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(5, 0, 1); + } + pcAdjustment = 5; + cleanup = 0; + arrayPtr = NULL; + part2 = NULL; + goto doCallPtrGetVar; + + case INST_LOAD_ARRAY_STK: + cleanup = 2; + part2 = Tcl_GetString(*tosPtr); /* element name */ + objPtr = *(tosPtr - 1); /* array name */ + TRACE(("\"%.30s(%.30s)\" => ", O2S(objPtr), part2)); + goto doLoadStk; + + case INST_LOAD_STK: + case INST_LOAD_SCALAR_STK: + cleanup = 1; + part2 = NULL; + objPtr = *tosPtr; /* variable name */ + TRACE(("\"%.30s\" => ", O2S(objPtr))); + + doLoadStk: + part1 = TclGetString(objPtr); + varPtr = TclObjLookupVar(interp, objPtr, part2, TCL_LEAVE_ERR_MSG, + "read", /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; + } + if (TclIsVarDirectReadable(varPtr) + && ((arrayPtr == NULL) || TclIsVarUntraced(arrayPtr))) { + /* + * No errors, no traces: just get the value. + */ + objResultPtr = varPtr->value.objPtr; + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(1, cleanup, 1); + } + pcAdjustment = 1; + goto doCallPtrGetVar; + + case INST_LOAD_ARRAY4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + goto doLoadArray; + + case INST_LOAD_ARRAY1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + + doLoadArray: + part2 = TclGetString(*tosPtr); + arrayPtr = &(compiledLocals[opnd]); + part1 = arrayPtr->name; + while (TclIsVarLink(arrayPtr)) { + arrayPtr = arrayPtr->value.linkPtr; + } + TRACE(("%u \"%.30s\" => ", opnd, part2)); + varPtr = TclLookupArrayElement(interp, part1, part2, + TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr); + if (varPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; + } + if (TclIsVarDirectReadable(varPtr) + && ((arrayPtr == NULL) || TclIsVarUntraced(arrayPtr))) { + /* + * No errors, no traces: just get the value. + */ + objResultPtr = varPtr->value.objPtr; + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(pcAdjustment, 1, 1); + } + cleanup = 1; + goto doCallPtrGetVar; + + doCallPtrGetVar: + /* + * There are either errors or the variable is traced: call + * TclPtrGetVar to process fully. + */ + + DECACHE_STACK_INFO(); + objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, + TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (objResultPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(pcAdjustment, cleanup, 1); + } + + /* + * End of INST_LOAD instructions. + * --------------------------------------------------------- + */ + + /* + * --------------------------------------------------------- + * Start of INST_STORE and related instructions. + * + * WARNING: more 'goto' here than your doctor recommended! The different + * instructions set the value of some variables and then jump to somme + * common execution code. + */ + + { + int opnd, pcAdjustment, storeFlags; + char *part1, *part2; + Var *varPtr, *arrayPtr; + Tcl_Obj *objPtr, *valuePtr; + + case INST_LAPPEND_STK: + valuePtr = *tosPtr; /* value to append */ + part2 = NULL; + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE + | TCL_LIST_ELEMENT | TCL_TRACE_READS); + goto doStoreStk; + + case INST_LAPPEND_ARRAY_STK: + valuePtr = *tosPtr; /* value to append */ + part2 = TclGetString(*(tosPtr - 1)); + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE + | TCL_LIST_ELEMENT | TCL_TRACE_READS); + goto doStoreStk; + + case INST_APPEND_STK: + valuePtr = *tosPtr; /* value to append */ + part2 = NULL; + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); + goto doStoreStk; + + case INST_APPEND_ARRAY_STK: + valuePtr = *tosPtr; /* value to append */ + part2 = TclGetString(*(tosPtr - 1)); + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); + goto doStoreStk; + + case INST_STORE_ARRAY_STK: + valuePtr = *tosPtr; + part2 = TclGetString(*(tosPtr - 1)); + storeFlags = TCL_LEAVE_ERR_MSG; + goto doStoreStk; + + case INST_STORE_STK: + case INST_STORE_SCALAR_STK: + valuePtr = *tosPtr; + part2 = NULL; + storeFlags = TCL_LEAVE_ERR_MSG; + + doStoreStk: + objPtr = *(tosPtr - 1 - (part2 != NULL)); /* variable name */ + part1 = TclGetString(objPtr); +#ifdef TCL_COMPILE_DEBUG + if (part2 == NULL) { + TRACE(("\"%.30s\" <- \"%.30s\" =>", part1, O2S(valuePtr))); + } else { + TRACE(("\"%.30s(%.30s)\" <- \"%.30s\" => ", + part1, part2, O2S(valuePtr))); + } +#endif + varPtr = TclObjLookupVar(interp, objPtr, part2, TCL_LEAVE_ERR_MSG, + "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; + } + cleanup = ((part2 == NULL)? 2 : 3); + pcAdjustment = 1; + goto doCallPtrSetVar; + + case INST_LAPPEND_ARRAY4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE + | TCL_LIST_ELEMENT | TCL_TRACE_READS); + goto doStoreArray; + + case INST_LAPPEND_ARRAY1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE + | TCL_LIST_ELEMENT | TCL_TRACE_READS); + goto doStoreArray; + + case INST_APPEND_ARRAY4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); + goto doStoreArray; + + case INST_APPEND_ARRAY1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); + goto doStoreArray; + + case INST_STORE_ARRAY4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + storeFlags = TCL_LEAVE_ERR_MSG; + goto doStoreArray; + + case INST_STORE_ARRAY1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + storeFlags = TCL_LEAVE_ERR_MSG; + + doStoreArray: + valuePtr = *tosPtr; + part2 = TclGetString(*(tosPtr - 1)); + arrayPtr = &(compiledLocals[opnd]); + part1 = arrayPtr->name; + TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, part2, O2S(valuePtr))); + while (TclIsVarLink(arrayPtr)) { + arrayPtr = arrayPtr->value.linkPtr; + } + varPtr = TclLookupArrayElement(interp, part1, part2, + TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr); + if (varPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; + } + cleanup = 2; + goto doCallPtrSetVar; + + case INST_LAPPEND_SCALAR4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE + | TCL_LIST_ELEMENT | TCL_TRACE_READS); + goto doStoreScalar; + + case INST_LAPPEND_SCALAR1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE + | TCL_LIST_ELEMENT | TCL_TRACE_READS); + goto doStoreScalar; + + case INST_APPEND_SCALAR4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); + goto doStoreScalar; + + case INST_APPEND_SCALAR1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); + goto doStoreScalar; + + case INST_STORE_SCALAR4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + storeFlags = TCL_LEAVE_ERR_MSG; + goto doStoreScalar; + + case INST_STORE_SCALAR1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + storeFlags = TCL_LEAVE_ERR_MSG; + + doStoreScalar: + valuePtr = *tosPtr; + varPtr = &(compiledLocals[opnd]); + part1 = varPtr->name; + TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + cleanup = 1; + arrayPtr = NULL; + part2 = NULL; + + doCallPtrSetVar: + if ((storeFlags == TCL_LEAVE_ERR_MSG) + && TclIsVarDirectWritable(varPtr) + && ((arrayPtr == NULL) || TclIsVarUntraced(arrayPtr))) { + /* + * No traces, no errors, plain 'set': we can safely inline. The + * value *will* be set to what's requested, so that the stack top + * remains pointing to the same Tcl_Obj. + */ + valuePtr = varPtr->value.objPtr; + objResultPtr = *tosPtr; + if (valuePtr != objResultPtr) { + if (valuePtr != NULL) { + TclDecrRefCount(valuePtr); + } else { + TclSetVarScalar(varPtr); + TclClearVarUndefined(varPtr); + } + varPtr->value.objPtr = objResultPtr; + Tcl_IncrRefCount(objResultPtr); + } +#ifndef TCL_COMPILE_DEBUG + if (*(pc+pcAdjustment) == INST_POP) { + NEXT_INST_V((pcAdjustment+1), cleanup, 0); + } +#else + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); +#endif + NEXT_INST_V(pcAdjustment, cleanup, 1); + } else { + DECACHE_STACK_INFO(); + objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr, + part1, part2, valuePtr, storeFlags); CACHE_STACK_INFO(); if (objResultPtr == NULL) { TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); result = TCL_ERROR; goto checkForCatch; } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(pcAdjustment, cleanup, 1); - } - - /* - * End of INST_LOAD instructions. - * --------------------------------------------------------- - */ - - /* - * --------------------------------------------------------- - * Start of INST_STORE and related instructions. - * - * WARNING: more 'goto' here than your doctor recommended! - * The different instructions set the value of some variables - * and then jump to somme common execution code. - */ - - { - int opnd, pcAdjustment, storeFlags; - char *part1, *part2; - Var *varPtr, *arrayPtr; - Tcl_Obj *objPtr, *valuePtr; - - case INST_LAPPEND_STK: - valuePtr = *tosPtr; /* value to append */ - part2 = NULL; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT | TCL_TRACE_READS); - goto doStoreStk; - - case INST_LAPPEND_ARRAY_STK: - valuePtr = *tosPtr; /* value to append */ - part2 = TclGetString(*(tosPtr - 1)); - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT | TCL_TRACE_READS); - goto doStoreStk; - - case INST_APPEND_STK: - valuePtr = *tosPtr; /* value to append */ - part2 = NULL; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); - goto doStoreStk; - - case INST_APPEND_ARRAY_STK: - valuePtr = *tosPtr; /* value to append */ - part2 = TclGetString(*(tosPtr - 1)); - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); - goto doStoreStk; - - case INST_STORE_ARRAY_STK: - valuePtr = *tosPtr; - part2 = TclGetString(*(tosPtr - 1)); - storeFlags = TCL_LEAVE_ERR_MSG; - goto doStoreStk; - - case INST_STORE_STK: - case INST_STORE_SCALAR_STK: - valuePtr = *tosPtr; - part2 = NULL; - storeFlags = TCL_LEAVE_ERR_MSG; - - doStoreStk: - objPtr = *(tosPtr - 1 - (part2 != NULL)); /* variable name */ - part1 = TclGetString(objPtr); -#ifdef TCL_COMPILE_DEBUG - if (part2 == NULL) { - TRACE(("\"%.30s\" <- \"%.30s\" =>", - part1, O2S(valuePtr))); - } else { - TRACE(("\"%.30s(%.30s)\" <- \"%.30s\" => ", - part1, part2, O2S(valuePtr))); - } -#endif - varPtr = TclObjLookupVar(interp, objPtr, part2, - TCL_LEAVE_ERR_MSG, "set", - /*createPart1*/ 1, - /*createPart2*/ 1, &arrayPtr); - if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - result = TCL_ERROR; - goto checkForCatch; - } - cleanup = ((part2 == NULL)? 2 : 3); - pcAdjustment = 1; - goto doCallPtrSetVar; - - case INST_LAPPEND_ARRAY4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT | TCL_TRACE_READS); - goto doStoreArray; - - case INST_LAPPEND_ARRAY1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT | TCL_TRACE_READS); - goto doStoreArray; - - case INST_APPEND_ARRAY4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); - goto doStoreArray; - - case INST_APPEND_ARRAY1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); - goto doStoreArray; - - case INST_STORE_ARRAY4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - storeFlags = TCL_LEAVE_ERR_MSG; - goto doStoreArray; - - case INST_STORE_ARRAY1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - storeFlags = TCL_LEAVE_ERR_MSG; - - doStoreArray: - valuePtr = *tosPtr; - part2 = TclGetString(*(tosPtr - 1)); - arrayPtr = &(compiledLocals[opnd]); - part1 = arrayPtr->name; - TRACE(("%u \"%.30s\" <- \"%.30s\" => ", - opnd, part2, O2S(valuePtr))); - while (TclIsVarLink(arrayPtr)) { - arrayPtr = arrayPtr->value.linkPtr; - } - varPtr = TclLookupArrayElement(interp, part1, part2, - TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr); - if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - result = TCL_ERROR; - goto checkForCatch; - } - cleanup = 2; - goto doCallPtrSetVar; - - case INST_LAPPEND_SCALAR4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT | TCL_TRACE_READS); - goto doStoreScalar; - - case INST_LAPPEND_SCALAR1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT | TCL_TRACE_READS); - goto doStoreScalar; - - case INST_APPEND_SCALAR4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); - goto doStoreScalar; - - case INST_APPEND_SCALAR1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); - goto doStoreScalar; - - case INST_STORE_SCALAR4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - storeFlags = TCL_LEAVE_ERR_MSG; - goto doStoreScalar; - - case INST_STORE_SCALAR1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - storeFlags = TCL_LEAVE_ERR_MSG; - - doStoreScalar: - valuePtr = *tosPtr; - varPtr = &(compiledLocals[opnd]); - part1 = varPtr->name; - TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - cleanup = 1; - arrayPtr = NULL; - part2 = NULL; - - doCallPtrSetVar: - if ((storeFlags == TCL_LEAVE_ERR_MSG) - && TclIsVarDirectWritable(varPtr) - && ((arrayPtr == NULL) - || TclIsVarUntraced(arrayPtr))) { - /* - * No traces, no errors, plain 'set': we can safely inline. - * The value *will* be set to what's requested, so that - * the stack top remains pointing to the same Tcl_Obj. - */ - valuePtr = varPtr->value.objPtr; - objResultPtr = *tosPtr; - if (valuePtr != objResultPtr) { - if (valuePtr != NULL) { - TclDecrRefCount(valuePtr); - } else { - TclSetVarScalar(varPtr); - TclClearVarUndefined(varPtr); - } - varPtr->value.objPtr = objResultPtr; - Tcl_IncrRefCount(objResultPtr); - } -#ifndef TCL_COMPILE_DEBUG - if (*(pc+pcAdjustment) == INST_POP) { - NEXT_INST_V((pcAdjustment+1), cleanup, 0); - } -#else - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); -#endif - NEXT_INST_V(pcAdjustment, cleanup, 1); - } else { - DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr, - part1, part2, valuePtr, storeFlags); - CACHE_STACK_INFO(); - if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - result = TCL_ERROR; - goto checkForCatch; - } - } -#ifndef TCL_COMPILE_DEBUG - if (*(pc+pcAdjustment) == INST_POP) { - NEXT_INST_V((pcAdjustment+1), cleanup, 0); - } -#endif - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(pcAdjustment, cleanup, 1); - } - - /* - * End of INST_STORE and related instructions. - * --------------------------------------------------------- - */ - - /* - * --------------------------------------------------------- - * Start of INST_INCR instructions. - * - * WARNING: more 'goto' here than your doctor recommended! - * The different instructions set the value of some variables - * and then jump to somme common execution code. - */ - - { - Tcl_Obj *objPtr; - int opnd, pcAdjustment, isWide; - long i; - Tcl_WideInt w; - char *part1, *part2; - Var *varPtr, *arrayPtr; - - case INST_INCR_SCALAR1: - case INST_INCR_ARRAY1: - case INST_INCR_ARRAY_STK: - case INST_INCR_SCALAR_STK: - case INST_INCR_STK: - opnd = TclGetUInt1AtPtr(pc+1); - objPtr = *tosPtr; - if (objPtr->typePtr == &tclIntType) { - i = objPtr->internalRep.longValue; - isWide = 0; - } else if (objPtr->typePtr == &tclWideIntType) { - i = 0; /* lint */ - w = objPtr->internalRep.wideValue; - isWide = 1; - } else { - i = 0; /* lint */ - REQUIRE_WIDE_OR_INT(result, objPtr, i, w); - if (result != TCL_OK) { - TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ", - opnd, O2S(objPtr)), Tcl_GetObjResult(interp)); - Tcl_AddErrorInfo(interp, "\n (reading increment)"); - goto checkForCatch; - } - isWide = (objPtr->typePtr == &tclWideIntType); - } - tosPtr--; - TclDecrRefCount(objPtr); - switch (*pc) { - case INST_INCR_SCALAR1: - pcAdjustment = 2; - goto doIncrScalar; - case INST_INCR_ARRAY1: - pcAdjustment = 2; - goto doIncrArray; - default: - pcAdjustment = 1; - goto doIncrStk; - } - - case INST_INCR_ARRAY_STK_IMM: - case INST_INCR_SCALAR_STK_IMM: - case INST_INCR_STK_IMM: - i = TclGetInt1AtPtr(pc+1); - isWide = 0; - pcAdjustment = 2; - - doIncrStk: - if ((*pc == INST_INCR_ARRAY_STK_IMM) - || (*pc == INST_INCR_ARRAY_STK)) { - part2 = TclGetString(*tosPtr); - objPtr = *(tosPtr - 1); - TRACE(("\"%.30s(%.30s)\" (by %ld) => ", - O2S(objPtr), part2, i)); - } else { - part2 = NULL; - objPtr = *tosPtr; - TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), i)); - } - part1 = TclGetString(objPtr); - - varPtr = TclObjLookupVar(interp, objPtr, part2, - TCL_LEAVE_ERR_MSG, "read", 0, 1, &arrayPtr); - if (varPtr == NULL) { - Tcl_AddObjErrorInfo(interp, - "\n (reading value of variable to increment)", -1); - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - result = TCL_ERROR; - goto checkForCatch; - } - cleanup = ((part2 == NULL)? 1 : 2); - goto doIncrVar; - - case INST_INCR_ARRAY1_IMM: - opnd = TclGetUInt1AtPtr(pc+1); - i = TclGetInt1AtPtr(pc+2); - isWide = 0; - pcAdjustment = 3; - - doIncrArray: - part2 = TclGetString(*tosPtr); - arrayPtr = &(compiledLocals[opnd]); - part1 = arrayPtr->name; - while (TclIsVarLink(arrayPtr)) { - arrayPtr = arrayPtr->value.linkPtr; - } - TRACE(("%u \"%.30s\" (by %ld) => ", - opnd, part2, i)); - varPtr = TclLookupArrayElement(interp, part1, part2, - TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr); - if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - result = TCL_ERROR; - goto checkForCatch; - } - cleanup = 1; - goto doIncrVar; - - case INST_INCR_SCALAR1_IMM: - opnd = TclGetUInt1AtPtr(pc+1); - i = TclGetInt1AtPtr(pc+2); - isWide = 0; - pcAdjustment = 3; - - doIncrScalar: - varPtr = &(compiledLocals[opnd]); - part1 = varPtr->name; - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - arrayPtr = NULL; - part2 = NULL; - cleanup = 0; - TRACE(("%u %ld => ", opnd, i)); - - - doIncrVar: - objPtr = varPtr->value.objPtr; - if (TclIsVarDirectReadable(varPtr) - && ((arrayPtr == NULL) - || TclIsVarUntraced(arrayPtr))) { - if (objPtr->typePtr == &tclIntType && !isWide) { - /* - * No errors, no traces, the variable already has an - * integer value: inline processing. - */ - - i += objPtr->internalRep.longValue; - if (Tcl_IsShared(objPtr)) { - objResultPtr = Tcl_NewLongObj(i); - TclDecrRefCount(objPtr); - Tcl_IncrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr; - } else { - Tcl_SetLongObj(objPtr, i); - objResultPtr = objPtr; - } - goto doneIncr; - } else if (objPtr->typePtr == &tclWideIntType && isWide) { - /* - * No errors, no traces, the variable already has a - * wide integer value: inline processing. - */ - - w += objPtr->internalRep.wideValue; - if (Tcl_IsShared(objPtr)) { - objResultPtr = Tcl_NewWideIntObj(w); - TclDecrRefCount(objPtr); - Tcl_IncrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr; - } else { - Tcl_SetWideIntObj(objPtr, w); - objResultPtr = objPtr; - } - goto doneIncr; - } - } - DECACHE_STACK_INFO(); - if (isWide) { - objResultPtr = TclPtrIncrWideVar(interp, varPtr, arrayPtr, part1, - part2, w, TCL_LEAVE_ERR_MSG); - } else { - objResultPtr = TclPtrIncrVar(interp, varPtr, arrayPtr, part1, - part2, i, TCL_LEAVE_ERR_MSG); - } - CACHE_STACK_INFO(); - if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - result = TCL_ERROR; - goto checkForCatch; - } - doneIncr: - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); -#ifndef TCL_COMPILE_DEBUG - if (*(pc+pcAdjustment) == INST_POP) { - NEXT_INST_V((pcAdjustment+1), cleanup, 0); - } -#endif - NEXT_INST_V(pcAdjustment, cleanup, 1); - } - - /* - * End of INST_INCR instructions. + } +#ifndef TCL_COMPILE_DEBUG + if (*(pc+pcAdjustment) == INST_POP) { + NEXT_INST_V((pcAdjustment+1), cleanup, 0); + } +#endif + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(pcAdjustment, cleanup, 1); + } + + /* + * End of INST_STORE and related instructions. + * --------------------------------------------------------- + */ + + /* + * --------------------------------------------------------- + * Start of INST_INCR instructions. + * + * WARNING: more 'goto' here than your doctor recommended! The different + * instructions set the value of some variables and then jump to somme + * common execution code. + */ + +/*TODO: Consider more untangling here; merge with LOAD and STORE ? */ + + { + Tcl_Obj *objPtr, *incrPtr; + int opnd, pcAdjustment; +#if 0 + int isWide; + Tcl_WideInt w; +#endif + long i; + char *part1, *part2; + Var *varPtr, *arrayPtr; + + case INST_INCR_SCALAR1: + case INST_INCR_ARRAY1: + case INST_INCR_ARRAY_STK: + 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; + isWide = 0; + } else if (objPtr->typePtr == &tclWideIntType) { + i = 0; /* lint */ + w = objPtr->internalRep.wideValue; + isWide = 1; + } else { + i = 0; /* lint */ + REQUIRE_WIDE_OR_INT(result, objPtr, i, w); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ", + opnd, O2S(objPtr)), Tcl_GetObjResult(interp)); + Tcl_AddErrorInfo(interp, "\n (reading increment)"); + goto checkForCatch; + } + isWide = (objPtr->typePtr == &tclWideIntType); + } + tosPtr--; + TclDecrRefCount(objPtr); +#else + incrPtr = *tosPtr; + tosPtr--; +#endif + switch (*pc) { + case INST_INCR_SCALAR1: + pcAdjustment = 2; + goto doIncrScalar; + case INST_INCR_ARRAY1: + pcAdjustment = 2; + goto doIncrArray; + default: + pcAdjustment = 1; + goto doIncrStk; + } + + case INST_INCR_ARRAY_STK_IMM: + 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: + if ((*pc == INST_INCR_ARRAY_STK_IMM) + || (*pc == INST_INCR_ARRAY_STK)) { + part2 = TclGetString(*tosPtr); + objPtr = *(tosPtr - 1); + TRACE(("\"%.30s(%.30s)\" (by %ld) => ", + O2S(objPtr), part2, i)); + } else { + part2 = NULL; + objPtr = *tosPtr; + TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), i)); + } + part1 = TclGetString(objPtr); + + varPtr = TclObjLookupVar(interp, objPtr, part2, + TCL_LEAVE_ERR_MSG, "read", 0, 1, &arrayPtr); + if (varPtr == NULL) { + Tcl_AddObjErrorInfo(interp, + "\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); + goto doIncrVar; + + 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: + part2 = TclGetString(*tosPtr); + arrayPtr = &(compiledLocals[opnd]); + part1 = arrayPtr->name; + while (TclIsVarLink(arrayPtr)) { + arrayPtr = arrayPtr->value.linkPtr; + } + TRACE(("%u \"%.30s\" (by %ld) => ", opnd, part2, i)); + varPtr = TclLookupArrayElement(interp, part1, part2, + TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr); + if (varPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + Tcl_DecrRefCount(incrPtr); + goto checkForCatch; + } + cleanup = 1; + goto doIncrVar; + + 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: + varPtr = &(compiledLocals[opnd]); + part1 = varPtr->name; + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + arrayPtr = NULL; + part2 = NULL; + cleanup = 0; + TRACE(("%u %ld => ", opnd, i)); + + doIncrVar: +#if 0 + objPtr = varPtr->value.objPtr; + if (TclIsVarDirectReadable(varPtr) + && ((arrayPtr == NULL) || TclIsVarUntraced(arrayPtr))) { + if (objPtr->typePtr == &tclIntType && !isWide) { + /* + * No errors, no traces, the variable already has an integer + * value: inline processing. + */ + + i += objPtr->internalRep.longValue; + if (Tcl_IsShared(objPtr)) { + objPtr->refCount--; /* we know it is shared */ + TclNewLongObj(objResultPtr, i); + Tcl_IncrRefCount(objResultPtr); + varPtr->value.objPtr = objResultPtr; + } else { + TclSetLongObj(objPtr, i); + objResultPtr = objPtr; + } + goto doneIncr; + } else if (objPtr->typePtr == &tclWideIntType && isWide) { + /* + * No errors, no traces, the variable already has a wide + * integer value: inline processing. + */ + + w += objPtr->internalRep.wideValue; + if (Tcl_IsShared(objPtr)) { + objPtr->refCount--; /* we know it is shared */ + TclNewWideIntObj(objResultPtr, w); + Tcl_IncrRefCount(objResultPtr); + varPtr->value.objPtr = objResultPtr; + } else { + TclSetWideIntObj(objPtr, w); + objResultPtr = objPtr; + } + goto doneIncr; + } + } + DECACHE_STACK_INFO(); + if (isWide) { + objResultPtr = TclPtrIncrWideVar(interp, varPtr, arrayPtr, part1, + part2, w, TCL_LEAVE_ERR_MSG); + } else { + objResultPtr = TclPtrIncrVar(interp, varPtr, arrayPtr, part1, + 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) { + NEXT_INST_V((pcAdjustment+1), cleanup, 0); + } +#endif + NEXT_INST_V(pcAdjustment, cleanup, 1); + } + + /* + * End of INST_INCR instructions. * --------------------------------------------------------- */ case INST_JUMP1: - { + { int opnd; - + opnd = TclGetInt1AtPtr(pc+1); TRACE(("%d => new pc %u\n", opnd, (unsigned int)(pc + opnd - codePtr->codeStart))); NEXT_INST_F(opnd, 0, 0); } case INST_JUMP4: - { + { int opnd; - + opnd = TclGetInt4AtPtr(pc+1); TRACE(("%d => new pc %u\n", opnd, (unsigned int)(pc + opnd - codePtr->codeStart))); NEXT_INST_F(opnd, 0, 0); - } - - { - int trueJmp, falseJmp; - - - case INST_JUMP_FALSE4: - trueJmp = 5; - falseJmp = TclGetInt4AtPtr(pc+1); - goto doJumpTrue; - - case INST_JUMP_TRUE4: - trueJmp = TclGetInt4AtPtr(pc+1); - falseJmp = 5; - goto doJumpTrue; - - case INST_JUMP_FALSE1: - trueJmp = 2; - falseJmp = TclGetInt1AtPtr(pc+1); - goto doJumpTrue; - - case INST_JUMP_TRUE1: - trueJmp = TclGetInt1AtPtr(pc+1); - falseJmp = 2; - - doJumpTrue: - { - int b; - Tcl_Obj *valuePtr; - - valuePtr = *tosPtr; - - /* - * The following will be partially resolved at compile - * time and optimised away. - */ - if (((sizeof(long) == sizeof(int)) && - (valuePtr->typePtr == &tclIntType)) - || (valuePtr->typePtr == &tclBooleanType)) { - b = (int) valuePtr->internalRep.longValue; - } else if ((sizeof(long) != sizeof(int)) && - (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)) { - trueJmp = falseJmp; - } - TRACE_WITH_OBJ(("%d => ERROR: ", trueJmp), Tcl_GetObjResult(interp)); - goto checkForCatch; - } - b = b1; - } -#ifndef TCL_COMPILE_DEBUG - NEXT_INST_F((b? trueJmp : falseJmp), 1, 0); -#else - if (b) { - if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { - TRACE(("%d => %.20s true, new pc %u\n", trueJmp, O2S(valuePtr), - (unsigned int)(pc+trueJmp - codePtr->codeStart))); - } else { - TRACE(("%d => %.20s true\n", falseJmp, O2S(valuePtr))); - } - NEXT_INST_F(trueJmp, 1, 0); - } else { - if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { - TRACE(("%d => %.20s false\n", falseJmp, O2S(valuePtr))); - } else { - TRACE(("%d => %.20s false, new pc %u\n", falseJmp, O2S(valuePtr), - (unsigned int)(pc + falseJmp - codePtr->codeStart))); - } - NEXT_INST_F(falseJmp, 1, 0); - } -#endif - } - } - - /* - * These two instructions are now redundant: the complete logic of the - * LOR and LAND is now handled by the expression compiler. + } + + { + int jmpOffset[2]; + 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*/ + goto doCondJump; + + case INST_JUMP_TRUE4: + jmpOffset[0] = 5; + jmpOffset[1] = TclGetInt4AtPtr(pc+1); + goto doCondJump; + + case INST_JUMP_FALSE1: + jmpOffset[0] = TclGetInt1AtPtr(pc+1); + jmpOffset[1] = 2; + goto doCondJump; + + case INST_JUMP_TRUE1: + jmpOffset[0] = 2; + jmpOffset[1] = TclGetInt1AtPtr(pc+1); + + doCondJump: + valuePtr = *tosPtr; + + /* 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; + } + +#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), + (unsigned int)(pc+jmpOffset[1] - codePtr->codeStart))); + } else { + TRACE(("%d => %.20s true\n", jmpOffset[0], O2S(valuePtr))); + } + } else { + if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { + TRACE(("%d => %.20s false\n", jmpOffset[0], O2S(valuePtr))); + } else { + TRACE(("%d => %.20s false, new pc %u\n", jmpOffset[0], O2S(valuePtr), + (unsigned int)(pc + jmpOffset[1] - codePtr->codeStart))); + } + } +#endif + NEXT_INST_F(jmpOffset[b], 1, 0); + } + + /* + * These two instructions are now redundant: the complete logic of the LOR + * and LAND is now handled by the expression compiler. */ case INST_LOR: case INST_LAND: { /* - * Operands must be boolean or numeric. No int->double - * conversions are 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) || (t1Ptr == &tclBooleanType)) { - 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; - - GET_WIDE_OR_INT(result, valuePtr, i, w); - if (valuePtr->typePtr == &tclIntType) { - i1 = (i != 0); - } else { - i1 = (w != W0); - } - } else { - result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, - valuePtr, &i1); - i1 = (i1 != 0); - } - if (result != TCL_OK) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), - (t1Ptr? t1Ptr->name : "null"))); - IllegalExprOperandType(interp, pc, valuePtr); - goto checkForCatch; - } - } - - if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) { - 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((Tcl_Interp *) 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; - } - } - - /* - * Reuse the valuePtr object already on stack if possible. - */ - + * Operands must be boolean or numeric. No int->double conversions are + * performed. + */ + + int i1, i2, iResult; + Tcl_Obj *value2Ptr = *tosPtr; + Tcl_Obj *valuePtr = *(tosPtr - 1); + + 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; + } + + 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; + } + if (*pc == INST_LOR) { iResult = (i1 || i2); } else { iResult = (i1 && i2); } - if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_NewLongObj(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)); - Tcl_SetLongObj(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); } /* * --------------------------------------------------------- - * Start of INST_LIST and related instructions. - */ - - case INST_LIST: - { - /* - * Pop the opnd (objc) top stack elements into a new list obj - * and then decrement their ref counts. - */ - int opnd; - - opnd = TclGetUInt4AtPtr(pc+1); - objResultPtr = Tcl_NewListObj(opnd, (tosPtr - (opnd-1))); - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); - NEXT_INST_V(5, opnd, 1); - } - - case INST_LIST_LENGTH: - { - Tcl_Obj *valuePtr; - int length; - - valuePtr = *tosPtr; - - result = Tcl_ListObjLength(interp, valuePtr, &length); - if (result != TCL_OK) { - TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), - Tcl_GetObjResult(interp)); - goto checkForCatch; - } - objResultPtr = Tcl_NewIntObj(length); - TRACE(("%.20s => %d\n", O2S(valuePtr), length)); - NEXT_INST_F(1, 1, 1); - } - - case INST_LIST_INDEX: - { - /*** lindex with objc == 3 ***/ - - Tcl_Obj *valuePtr, *value2Ptr; - - /* - * Pop the two operands - */ - value2Ptr = *tosPtr; - valuePtr = *(tosPtr - 1); - - /* - * Extract the desired list element - */ - objResultPtr = TclLindexList(interp, valuePtr, value2Ptr); - if (objResultPtr == NULL) { - TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr), O2S(value2Ptr)), - Tcl_GetObjResult(interp)); - result = TCL_ERROR; - goto checkForCatch; - } - - /* - * Stash the list element on the stack - */ - TRACE(("%.20s %.20s => %s\n", - O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr))); - NEXT_INST_F(1, 2, -1); /* already has the correct refCount */ - } - - case INST_LIST_INDEX_IMM: - { + * Start of INST_LIST and related instructions. + */ + + case INST_LIST: { + /* + * Pop the opnd (objc) top stack elements into a new list obj and then + * decrement their ref counts. + */ + + int opnd; + + opnd = TclGetUInt4AtPtr(pc+1); + objResultPtr = Tcl_NewListObj(opnd, (tosPtr - (opnd-1))); + TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); + NEXT_INST_V(5, opnd, 1); + } + + case INST_LIST_LENGTH: { + Tcl_Obj *valuePtr; + int length; + + valuePtr = *tosPtr; + + result = Tcl_ListObjLength(interp, valuePtr, &length); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), + Tcl_GetObjResult(interp)); + goto checkForCatch; + } + TclNewIntObj(objResultPtr, length); + TRACE(("%.20s => %d\n", O2S(valuePtr), length)); + NEXT_INST_F(1, 1, 1); + } + + case INST_LIST_INDEX: { + /*** lindex with objc == 3 ***/ + + Tcl_Obj *valuePtr, *value2Ptr; + + /* + * Pop the two operands + */ + + value2Ptr = *tosPtr; + valuePtr = *(tosPtr - 1); + + /* + * Extract the desired list element + */ + + objResultPtr = TclLindexList(interp, valuePtr, value2Ptr); + if (objResultPtr == NULL) { + TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr), O2S(value2Ptr)), + Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; + } + + /* + * Stash the list element on the stack + */ + + TRACE(("%.20s %.20s => %s\n", + O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr))); + NEXT_INST_F(1, 2, -1); /* already has the correct refCount */ + } + + case INST_LIST_INDEX_IMM: { /*** lindex with objc==3 and index in bytecode stream ***/ int listc, idx, opnd; Tcl_Obj **listv; Tcl_Obj *valuePtr; - + /* * Pop the list and get the index */ + valuePtr = *tosPtr; opnd = TclGetInt4AtPtr(pc+1); /* - * Get the contents of the list, making sure that it - * really is a list in the process. + * Get the contents of the list, making sure that it really is a list + * in the process. */ + result = Tcl_ListObjGetElements(interp, valuePtr, &listc, &listv); if (result != TCL_OK) { TRACE_WITH_OBJ(("\"%.30s\" %d => ERROR: ", O2S(valuePtr), opnd), Tcl_GetObjResult(interp)); goto checkForCatch; } /* - * Select the list item based on the index. Negative - * operand == end-based indexing. + * Select the list item based on the index. Negative operand means + * end-based indexing. */ + if (opnd < -1) { idx = opnd+1 + listc; } else { idx = opnd; } @@ -2665,12 +2814,11 @@ TRACE_WITH_OBJ(("\"%.30s\" %d => ", O2S(valuePtr), opnd), objResultPtr); NEXT_INST_F(5, 1, 1); } - case INST_LIST_INDEX_MULTI: - { + case INST_LIST_INDEX_MULTI: { /* * 'lindex' with multiple index args: * * Determine the count of index args. */ @@ -2681,12 +2829,13 @@ numIdx = opnd-1; /* * Do the 'lindex' operation. */ + objResultPtr = TclLindexFlat(interp, *(tosPtr - numIdx), - numIdx, tosPtr - numIdx + 1); + numIdx, tosPtr - numIdx + 1); /* * Check for errors */ if (objResultPtr == NULL) { @@ -2700,26 +2849,24 @@ */ TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); NEXT_INST_V(5, opnd, -1); } - case INST_LSET_FLAT: - { + case INST_LSET_FLAT: { /* - * Lset with 3, 5, or more args. Get the number - * of index args. + * Lset with 3, 5, or more args. Get the number of index args. */ int numIdx,opnd; Tcl_Obj *valuePtr, *value2Ptr; opnd = TclGetUInt4AtPtr(pc + 1); numIdx = opnd - 2; /* - * Get the old value of variable, and remove the stack ref. - * This is safe because the variable still references the - * object; the ref count will never go zero here. + * Get the old value of variable, and remove the stack ref. This is + * safe because the variable still references the object; the ref + * count will never go zero here. */ value2Ptr = POP_OBJECT(); TclDecrRefCount(value2Ptr); /* This one should be done here */ /* @@ -2729,11 +2876,11 @@ /* * Compute the new variable value */ objResultPtr = TclLsetFlat(interp, value2Ptr, numIdx, - tosPtr - numIdx, valuePtr); + tosPtr - numIdx, valuePtr); /* * Check for errors */ if (objResultPtr == NULL) { @@ -2747,32 +2894,31 @@ */ TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); NEXT_INST_V(5, (numIdx+1), -1); } - case INST_LSET_LIST: - { + case INST_LSET_LIST: { /* * 'lset' with 4 args. */ Tcl_Obj *objPtr, *valuePtr, *value2Ptr; - + /* - * Get the old value of variable, and remove the stack ref. - * This is safe because the variable still references the - * object; the ref count will never go zero here. + * Get the old value of variable, and remove the stack ref. This is + * safe because the variable still references the object; the ref + * count will never go zero here. */ - objPtr = POP_OBJECT(); + objPtr = POP_OBJECT(); TclDecrRefCount(objPtr); /* This one should be done here */ - + /* * Get the new element value, and the index list */ valuePtr = *tosPtr; value2Ptr = *(tosPtr - 1); - + /* * Compute the new variable value */ objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr); @@ -2779,11 +2925,11 @@ /* * Check for errors */ if (objResultPtr == NULL) { TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)), - Tcl_GetObjResult(interp)); + Tcl_GetObjResult(interp)); result = TCL_ERROR; goto checkForCatch; } /* @@ -2790,40 +2936,39 @@ * Set result */ TRACE(("=> %s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, -1); } - - case INST_LIST_RANGE_IMM: - { + + case INST_LIST_RANGE_IMM: { /*** lrange with objc==4 and both indices in bytecode stream ***/ int listc, fromIdx, toIdx; Tcl_Obj **listv; Tcl_Obj *valuePtr; - + /* * Pop the list and get the indices */ valuePtr = *tosPtr; fromIdx = TclGetInt4AtPtr(pc+1); toIdx = TclGetInt4AtPtr(pc+5); /* - * Get the contents of the list, making sure that it - * really is a list in the process. + * Get the contents of the list, making sure that it really is a list + * in the process. */ result = Tcl_ListObjGetElements(interp, valuePtr, &listc, &listv); if (result != TCL_OK) { TRACE_WITH_OBJ(("\"%.30s\" %d %d => ERROR: ", O2S(valuePtr), fromIdx, toIdx), Tcl_GetObjResult(interp)); goto checkForCatch; } /* - * Skip a lot of work if we're about to throw the result away - * (common with uses of [lassign].) + * Skip a lot of work if we're about to throw the result away (common + * with uses of [lassign].) */ #ifndef TCL_COMPILE_DEBUG if (*(pc+9) == INST_POP) { NEXT_INST_F(10, 1, 0); } @@ -2848,12 +2993,12 @@ } else if (toIdx > listc) { toIdx = listc; } /* - * Check if we are referring to a valid, non-empty list range, - * and if so, build the list of elements in that range. + * Check if we are referring to a valid, non-empty list range, and if + * so, build the list of elements in that range. */ if (fromIdx<=toIdx && fromIdx=0) { if (fromIdx<0) { fromIdx = 0; } @@ -2880,10 +3025,11 @@ char *s1, *s2; 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) { TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ERROR: ", O2S(valuePtr), O2S(value2Ptr)), Tcl_GetObjResult(interp)); @@ -2912,12 +3058,13 @@ } TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), found)); /* - * Peep-hole optimisation: if you're about to jump, do jump - * from here. + * 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++; #ifndef TCL_COMPILE_DEBUG switch (*pc) { @@ -2929,35 +3076,35 @@ NEXT_INST_F((found ? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); case INST_JUMP_TRUE4: NEXT_INST_F((found ? TclGetInt4AtPtr(pc+1) : 5), 2, 0); } #endif - objResultPtr = Tcl_NewBooleanObj(found); + objResultPtr = eePtr->constants[found]; NEXT_INST_F(0, 2, 1); } /* - * End of INST_LIST and related instructions. + * End of INST_LIST and related instructions. * --------------------------------------------------------- */ case INST_STR_EQ: - case INST_STR_NEQ: - { + case INST_STR_NEQ: { /* * String (in)equality check + * TODO: Consider merging into INST_STR_CMP */ int iResult; Tcl_Obj *valuePtr, *value2Ptr; value2Ptr = *tosPtr; valuePtr = *(tosPtr - 1); if (valuePtr == value2Ptr) { /* - * On the off-chance that the objects are the same, - * we don't really have to think hard about equality. + * On the off-chance that the objects are the same, we don't + * really have to think hard about equality. */ iResult = (*pc == INST_STR_EQ); } else { char *s1, *s2; int s1len, s2len; @@ -2964,12 +3111,12 @@ s1 = Tcl_GetStringFromObj(valuePtr, &s1len); s2 = Tcl_GetStringFromObj(value2Ptr, &s2len); if (s1len == s2len) { /* - * We only need to check (in)equality when - * we have equal length strings. + * We only need to check (in)equality when we have equal + * length strings. */ if (*pc == INST_STR_NEQ) { iResult = (strcmp(s1, s2) != 0); } else { /* INST_STR_EQ */ @@ -2981,61 +3128,60 @@ } TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult)); /* - * Peep-hole optimisation: if you're about to jump, do jump - * from here. + * Peep-hole optimisation: if you're about to jump, do jump from here. */ pc++; #ifndef TCL_COMPILE_DEBUG switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0); + case INST_JUMP_FALSE1: + NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); + case INST_JUMP_TRUE1: + NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0); + case INST_JUMP_FALSE4: + NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); + case INST_JUMP_TRUE4: + NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0); } #endif - objResultPtr = Tcl_NewIntObj(iResult); + objResultPtr = eePtr->constants[iResult]; NEXT_INST_F(0, 2, 1); } - case INST_STR_CMP: - { + case INST_STR_CMP: { /* * String compare */ CONST char *s1, *s2; int s1len, s2len, iResult; Tcl_Obj *valuePtr, *value2Ptr; - + + stringCompare: value2Ptr = *tosPtr; valuePtr = *(tosPtr - 1); /* - * The comparison function should compare up to the - * minimum byte length only. + * The comparison function should compare up to the minimum byte + * length only. */ if (valuePtr == value2Ptr) { /* - * In the pure equality case, set lengths too for - * the checks below (or we could goto beyond it). + * In the pure equality case, set lengths too for the checks below + * (or we could goto beyond it). */ iResult = s1len = s2len = 0; } else if ((valuePtr->typePtr == &tclByteArrayType) - && (value2Ptr->typePtr == &tclByteArrayType)) { + && (value2Ptr->typePtr == &tclByteArrayType)) { s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len); s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); - iResult = memcmp(s1, s2, - (size_t) ((s1len < s2len) ? s1len : s2len)); + iResult = memcmp(s1, s2, + (size_t) ((s1len < s2len) ? s1len : s2len)); } else if (((valuePtr->typePtr == &tclStringType) - && (value2Ptr->typePtr == &tclStringType))) { + && (value2Ptr->typePtr == &tclStringType))) { /* * Do a unicode-specific comparison if both of the args are of * String type. If the char length == byte length, we can do a * memcmp. In benchmark testing this proved the most efficient * check between the unicode and string comparison operations. @@ -3051,71 +3197,94 @@ Tcl_GetUnicode(value2Ptr), (unsigned) ((s1len < s2len) ? s1len : s2len)); } } else { /* - * We can't do a simple memcmp in order to handle the - * special Tcl \xC0\x80 null encoding for utf-8. + * We can't do a simple memcmp in order to handle the special Tcl + * \xC0\x80 null encoding for utf-8. */ s1 = Tcl_GetStringFromObj(valuePtr, &s1len); s2 = Tcl_GetStringFromObj(value2Ptr, &s2len); iResult = TclpUtfNcmp2(s1, s2, - (size_t) ((s1len < s2len) ? s1len : s2len)); + (size_t) ((s1len < s2len) ? s1len : s2len)); } /* * 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))); } - objResultPtr = Tcl_NewIntObj(iResult); - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult)); NEXT_INST_F(1, 2, 1); } - case INST_STR_LEN: - { + case INST_STR_LEN: { int length; Tcl_Obj *valuePtr; - + valuePtr = *tosPtr; if (valuePtr->typePtr == &tclByteArrayType) { (void) Tcl_GetByteArrayFromObj(valuePtr, &length); } else { length = Tcl_GetCharLength(valuePtr); } - objResultPtr = Tcl_NewIntObj(length); + TclNewIntObj(objResultPtr, length); TRACE(("%.20s => %d\n", O2S(valuePtr), length)); NEXT_INST_F(1, 1, 1); } - - case INST_STR_INDEX: - { + + case INST_STR_INDEX: { /* * String compare */ int index, length; char *bytes; Tcl_Obj *valuePtr, *value2Ptr; - + bytes = NULL; /* lint */ value2Ptr = *tosPtr; valuePtr = *(tosPtr - 1); /* - * If we have a ByteArray object, avoid indexing in the - * Utf string since the byte array contains one byte per - * character. Otherwise, use the Unicode string rep to - * get the index'th char. + * If we have a ByteArray object, avoid indexing in the Utf string + * since the byte array contains one byte per character. Otherwise, + * use the Unicode string rep to get the index'th char. */ if (valuePtr->typePtr == &tclByteArrayType) { bytes = (char *)Tcl_GetByteArrayFromObj(valuePtr, &length); } else { @@ -3131,53 +3300,51 @@ } if ((index >= 0) && (index < length)) { if (valuePtr->typePtr == &tclByteArrayType) { objResultPtr = Tcl_NewByteArrayObj((unsigned char *) - (&bytes[index]), 1); + (&bytes[index]), 1); } else if (valuePtr->bytes && length == valuePtr->length) { objResultPtr = Tcl_NewStringObj((CONST char *) - (&valuePtr->bytes[index]), 1); + (&valuePtr->bytes[index]), 1); } else { char buf[TCL_UTF_MAX]; Tcl_UniChar ch; ch = Tcl_GetUniChar(valuePtr, index); /* - * This could be: - * Tcl_NewUnicodeObj((CONST Tcl_UniChar *)&ch, 1) - * but creating the object as a string seems to be - * faster in practical use. + * This could be: Tcl_NewUnicodeObj((CONST Tcl_UniChar *)&ch, + * 1) but creating the object as a string seems to be faster + * in practical use. */ length = Tcl_UniCharToUtf(ch, buf); objResultPtr = Tcl_NewStringObj(buf, length); } } else { TclNewObj(objResultPtr); } - TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr), - O2S(objResultPtr))); + TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr), + O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } - case INST_STR_MATCH: - { + case INST_STR_MATCH: { int nocase, match; Tcl_Obj *valuePtr, *value2Ptr; nocase = TclGetInt1AtPtr(pc+1); - valuePtr = *tosPtr; /* String */ + valuePtr = *tosPtr; /* String */ value2Ptr = *(tosPtr - 1); /* Pattern */ /* - * Check that at least one of the objects is Unicode before - * promoting both. + * Check that at least one of the objects is Unicode before promoting + * both. */ if ((valuePtr->typePtr == &tclStringType) - || (value2Ptr->typePtr == &tclStringType)) { + || (value2Ptr->typePtr == &tclStringType)) { Tcl_UniChar *ustring1, *ustring2; int length1, length2; ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length1); ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); @@ -3187,334 +3354,798 @@ match = Tcl_StringCaseMatch(TclGetString(valuePtr), TclGetString(value2Ptr), nocase); } /* - * Reuse value2Ptr object already on stack if possible. - * Adjustment is 2 due to the nocase byte + * 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)); - if (Tcl_IsShared(value2Ptr)) { - objResultPtr = Tcl_NewIntObj(match); - NEXT_INST_F(2, 2, 1); - } else { /* reuse the valuePtr object */ - Tcl_SetIntObj(value2Ptr, match); - NEXT_INST_F(2, 1, 0); - } + objResultPtr = eePtr->constants[match]; + NEXT_INST_F(2, 2, 1); } case INST_EQ: case INST_NEQ: case INST_LT: 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; + case INST_GE: { + 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); - } else { - (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, - valuePtr, &d1); - } - 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); - } else { - (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, - value2Ptr, &d2); - } - t2Ptr = value2Ptr->typePtr; - } - } - 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); - } else { - iResult = 0; - } - break; - case INST_NEQ: - if (s1len == s2len) { - iResult = (strcmp(s1, s2) != 0); - } else { - iResult = 1; - } - 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; - } - } 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; - } - } 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); - } else { - TclGetWide(w,valuePtr); - TclGetWide(w2,value2Ptr); - } - 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; - break; - } - } - - TRACE(("%.20s %.20s => %ld\n", O2S(valuePtr), O2S(value2Ptr), iResult)); - - /* - * Peep-hole optimisation: if you're about to jump, do jump - * from here. - */ - - foundResult: + 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 { + Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2); + } + if (mp_cmp_d(&big2, 0) == MP_LT) { + compare = MP_GT; + } else { + compare = MP_LT; + } + mp_clear(&big2); + } + 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 { + Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2); + } + if (mp_cmp_d(&big2, 0) == MP_LT) { + compare = MP_GT; + } else { + compare = MP_LT; + } + mp_clear(&big2); + } + 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; + } + break; + + case TCL_NUMBER_BIG: + if (Tcl_IsShared(valuePtr)) { + Tcl_GetBignumFromObj(NULL, valuePtr, &big1); + } else { + Tcl_GetBignumAndClearObj(NULL, valuePtr, &big1); + } + 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); + } + } + + /* 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. + */ + + foundResult: pc++; #ifndef TCL_COMPILE_DEBUG switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0); + case INST_JUMP_FALSE1: + NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); + case INST_JUMP_TRUE1: + NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0); + case INST_JUMP_FALSE4: + NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); + case INST_JUMP_TRUE4: + NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0); } #endif - objResultPtr = Tcl_NewIntObj(iResult); + objResultPtr = eePtr->constants[iResult]; 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< ", 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<0) ? l : ~l) + & -(1<<(CHAR_BIT*sizeof(long)-1-shift)))) { + TclNewLongObj(objResultPtr, (l< ", 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: + 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. */ - long i = 0, i2 = 0, rem, negative; + long i = 0, i2 = 0, rem, neg_divisor = 0; long iResult = 0; /* Init. avoids compiler warning. */ Tcl_WideInt w, w2, wResult = W0; int doWide = 0; Tcl_Obj *valuePtr, *value2Ptr; - + value2Ptr = *tosPtr; - valuePtr = *(tosPtr - 1); + valuePtr = *(tosPtr - 1); if (valuePtr->typePtr == &tclIntType) { i = valuePtr->internalRep.longValue; } else if (valuePtr->typePtr == &tclWideIntType) { TclGetWide(w,valuePtr); } else { /* try to convert to int */ REQUIRE_WIDE_OR_INT(result, valuePtr, i, w); if (result != TCL_OK) { TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", - O2S(valuePtr), O2S(value2Ptr), - (valuePtr->typePtr? - valuePtr->typePtr->name : "null"))); + O2S(valuePtr), O2S(value2Ptr), + (valuePtr->typePtr? + valuePtr->typePtr->name : "null"))); IllegalExprOperandType(interp, pc, valuePtr); goto checkForCatch; } } if (value2Ptr->typePtr == &tclIntType) { @@ -3523,25 +4154,24 @@ TclGetWide(w2,value2Ptr); } else { REQUIRE_WIDE_OR_INT(result, value2Ptr, i2, w2); if (result != TCL_OK) { TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", - O2S(valuePtr), O2S(value2Ptr), - (value2Ptr->typePtr? + O2S(valuePtr), O2S(value2Ptr), + (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); IllegalExprOperandType(interp, pc, value2Ptr); goto checkForCatch; } } - switch (*pc) { - case INST_MOD: + do { /* - * This code is tricky: C doesn't guarantee much about - * the quotient or remainder, but Tcl does. The - * remainder always has the same sign as the divisor and - * a smaller absolute value. + * This code is tricky: C doesn't guarantee much about the + * quotient or remainder, and results with a negative divisor are + * not specified. Tcl guarantees that the remainder will have the + * same sign as the divisor and a smaller absolute value. */ if (value2Ptr->typePtr == &tclWideIntType && w2 == W0) { if (valuePtr->typePtr == &tclIntType) { TRACE(("%ld "LLD" => DIVIDE BY ZERO\n", i, w2)); } else { @@ -3555,296 +4185,452 @@ } else { TRACE((LLD" %ld => DIVIDE BY ZERO\n", w, i2)); } goto divideByZero; } - negative = 0; if (valuePtr->typePtr == &tclWideIntType - || value2Ptr->typePtr == &tclWideIntType) { + || value2Ptr->typePtr == &tclWideIntType) { Tcl_WideInt wRemainder; /* * Promote to wide */ if (valuePtr->typePtr == &tclIntType) { w = Tcl_LongAsWide(i); } else if (value2Ptr->typePtr == &tclIntType) { w2 = Tcl_LongAsWide(i2); } - if (w2 < 0) { - w2 = -w2; - w = -w; - negative = 1; - } - wRemainder = w % w2; - if (wRemainder < 0) { - wRemainder += w2; - } - if (negative) { + if ( w == LLONG_MIN && w2 == -1 ) { + /* Integer overflow could happen with (LLONG_MIN % -1) + * even though it is not possible in the code below. */ + wRemainder = 0; + } else if ( w == LLONG_MIN && w2 == LLONG_MAX ) { + wRemainder = LLONG_MAX - 1; + } else if ( w2 == LLONG_MIN ) { + /* + * In C, a modulus operation is not well defined when the + * divisor is a negative number. So w % LLONG_MIN is not + * well defined in the code below because -LLONG_MIN is + * still a negative number. + */ + if (w == 0 || w == LLONG_MIN) { + wRemainder = 0; + } else if (w < 0) { + wRemainder = w; + } else { + wRemainder = LLONG_MIN + w; + } + neg_divisor = 1; + } else { + if (w2 < 0) { + w2 = -w2; + w = -w; /* Note: -LLONG_MIN == LLONG_MIN */ + neg_divisor = 1; + } + wRemainder = w % w2; + + /* + * remainder is (remainder + divisor) when the remainder + * is negative. Watch out for the special case of a + * LLONG_MIN dividend and a negative divisor. Don't add + * the divisor in that case because the remainder should + * not be negative. + */ + if (wRemainder < 0 && !(neg_divisor && (w == LLONG_MIN))) { + wRemainder += w2; + } + } + if ((neg_divisor && (wRemainder > 0)) || + (!neg_divisor && (wRemainder < 0))) { wRemainder = -wRemainder; } wResult = wRemainder; doWide = 1; break; } - if (i2 < 0) { - i2 = -i2; - i = -i; - negative = 1; - } - rem = i % i2; - if (rem < 0) { - rem += i2; - } - if (negative) { + + if ( i == LONG_MIN && i2 == -1 ) { + /* + * Integer overflow could happen with (LONG_MIN % -1) even + * though it is not possible in the code below. + */ + rem = 0; + } else if ( i == LONG_MIN && i2 == LONG_MAX ) { + rem = LONG_MAX - 1; + } else if ( i2 == LONG_MIN ) { + /* + * In C, a modulus operation is not well defined when the + * divisor is a negative number. So i % LONG_MIN is not well + * defined in the code below because -LONG_MIN is still a + * negative number. + */ + if (i == 0 || i == LONG_MIN) { + rem = 0; + } else if (i < 0) { + rem = i; + } else { + rem = LONG_MIN + i; + } + neg_divisor = 1; + } else { + if (i2 < 0) { + i2 = -i2; + i = -i; /* Note: -LONG_MIN == LONG_MIN */ + neg_divisor = 1; + } + rem = i % i2; + + /* + * remainder is (remainder + divisor) when the remainder is + * negative. Watch out for the special case of a LONG_MIN + * dividend and a negative divisor. Don't add the divisor in + * that case because the remainder should not be negative. + */ + if (rem < 0 && !(neg_divisor && (i == LONG_MIN))) { + rem += i2; + } + } + + if ((neg_divisor && (rem > 0)) || + (!neg_divisor && (rem < 0))) { 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. */ - + if (Tcl_IsShared(valuePtr)) { if (doWide) { - objResultPtr = Tcl_NewWideIntObj(wResult); + TclNewWideIntObj(objResultPtr, wResult); TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); } else { - objResultPtr = Tcl_NewLongObj(iResult); + TclNewLongObj(objResultPtr, iResult); TRACE(("%ld %ld => %ld\n", i, i2, iResult)); } NEXT_INST_F(1, 2, 1); } else { /* reuse the valuePtr object */ if (doWide) { TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); - Tcl_SetWideIntObj(valuePtr, wResult); + TclSetWideIntObj(valuePtr, wResult); } else { TRACE(("%ld %ld => %ld\n", i, i2, iResult)); - Tcl_SetLongObj(valuePtr, iResult); + TclSetLongObj(valuePtr, iResult); } NEXT_INST_F(1, 1, 0); } + } +#endif + + case INST_ADD: + case INST_SUB: + 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_ADD: - case INST_SUB: - case INST_MULT: - case INST_DIV: - case INST_EXPON: - { + case INST_MOD: + case INST_EXPON: { /* - * Operands must be numeric and ints get converted to floats - * if necessary. We compute value op value2. + * 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, rem; /* 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, wrem; - Tcl_WideInt wResult = W0; /* Init. avoids compiler warning. */ - int doWide = 0; /* 1 if doing wide arithmetic. */ - Tcl_Obj *valuePtr,*value2Ptr; + long i = 0, i2 = 0, quot; /* Init. avoids compiler warning. */ + long iResult = 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. */ int length; - + value2Ptr = *tosPtr; valuePtr = *(tosPtr - 1); t1Ptr = valuePtr->typePtr; t2Ptr = value2Ptr->typePtr; - + if (t1Ptr == &tclIntType) { i = valuePtr->internalRep.longValue; } else if (t1Ptr == &tclWideIntType) { TclGetWide(w,valuePtr); - } else if ((t1Ptr == &tclDoubleType) - && (valuePtr->bytes == NULL)) { + } else if ((t1Ptr == &tclDoubleType) && (valuePtr->bytes == NULL)) { /* - * We can only use the internal rep directly if there is - * no string rep. Otherwise the string rep might actually - * look like an integer, which is preferred. + * We can only use the internal rep directly if there is no string + * rep. Otherwise the string rep might actually look like an + * integer, which is preferred. */ d1 = valuePtr->internalRep.doubleValue; } else { 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, &d1); + valuePtr, &d1); } if (result != TCL_OK) { TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", - s, O2S(valuePtr), - (valuePtr->typePtr? - valuePtr->typePtr->name : "null"))); + s, O2S(valuePtr), + (valuePtr->typePtr? valuePtr->typePtr->name: "null"))); IllegalExprOperandType(interp, pc, valuePtr); goto checkForCatch; } t1Ptr = valuePtr->typePtr; } @@ -3851,31 +4637,30 @@ if (t2Ptr == &tclIntType) { i2 = value2Ptr->internalRep.longValue; } else if (t2Ptr == &tclWideIntType) { TclGetWide(w2,value2Ptr); - } else if ((t2Ptr == &tclDoubleType) - && (value2Ptr->bytes == NULL)) { + } else if ((t2Ptr == &tclDoubleType) && (value2Ptr->bytes == NULL)) { /* - * We can only use the internal rep directly if there is - * no string rep. Otherwise the string rep might actually - * look like an integer, which is preferred. + * We can only use the internal rep directly if there is no string + * rep. Otherwise the string rep might actually look like an + * integer, which is preferred. */ d2 = value2Ptr->internalRep.doubleValue; } else { char *s = Tcl_GetStringFromObj(value2Ptr, &length); if (TclLooksLikeInt(s, length)) { GET_WIDE_OR_INT(result, value2Ptr, i2, w2); } else { result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, - value2Ptr, &d2); + value2Ptr, &d2); } if (result != TCL_OK) { TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", - O2S(value2Ptr), s, - (value2Ptr->typePtr? + O2S(value2Ptr), s, + (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); IllegalExprOperandType(interp, pc, value2Ptr); goto checkForCatch; } t2Ptr = value2Ptr->typePtr; @@ -3885,57 +4670,49 @@ /* * Do double arithmetic. */ doDouble = 1; if (t1Ptr == &tclIntType) { - d1 = i; /* promote value 1 to double */ + d1 = i; /* promote value 1 to double */ } else if (t2Ptr == &tclIntType) { - d2 = i2; /* promote value 2 to double */ + d2 = i2; /* promote value 2 to double */ } else if (t1Ptr == &tclWideIntType) { d1 = Tcl_WideAsDouble(w); } else if (t2Ptr == &tclWideIntType) { d2 = Tcl_WideAsDouble(w2); } 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: - if (d2 == 0.0) { - TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2)); - goto divideByZero; - } - dResult = d1 / d2; - break; - 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_ADD: + dResult = d1 + d2; + break; + case INST_SUB: + dResult = d1 - d2; + break; + case INST_MULT: + dResult = d1 * d2; + break; + 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; + } + /* * Check now for IEEE floating-point error. */ - - if (IS_NAN(dResult) || IS_INF(dResult)) { + + if (IS_NAN(dResult)) { TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n", - O2S(valuePtr), O2S(value2Ptr))); + O2S(valuePtr), O2S(value2Ptr))); TclExprFloatError(interp, dResult); result = TCL_ERROR; goto checkForCatch; } - } else if ((t1Ptr == &tclWideIntType) - || (t2Ptr == &tclWideIntType)) { + } else if ((t1Ptr == &tclWideIntType) || (t2Ptr == &tclWideIntType)) { /* * Do wide integer arithmetic. */ doWide = 1; if (t1Ptr == &tclIntType) { @@ -3942,550 +4719,570 @@ w = Tcl_LongAsWide(i); } else if (t2Ptr == &tclIntType) { w2 = Tcl_LongAsWide(i2); } switch (*pc) { - case INST_ADD: - wResult = w + w2; - break; - case INST_SUB: - wResult = w - w2; - break; - case INST_MULT: - wResult = w * w2; - break; - case INST_DIV: - /* - * This code is tricky: C doesn't guarantee much - * about the quotient or remainder, but Tcl does. - * The remainder always has the same sign as the - * divisor and a smaller absolute value. - */ - if (w2 == W0) { - TRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2)); - goto divideByZero; - } - if (w2 < 0) { - w2 = -w2; - w = -w; - } + case INST_ADD: + wResult = w + w2; + break; + case INST_SUB: + wResult = w - w2; + break; + case INST_MULT: + wResult = w * w2; + break; + case INST_DIV: + /* + * When performing integer division, protect against integer + * overflow. Round towards zero when the quotient is positive, + * otherwise round towards -Infinity. + */ + if (w2 == W0) { + TRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2)); + goto divideByZero; + } + if (w == LLONG_MIN && w2 == -1) { + /* Avoid integer overflow on (LLONG_MIN / -1) */ + wquot = LLONG_MIN; + } else { wquot = w / w2; - wrem = w % w2; - if (wrem < W0) { + /* + * Round down to a smaller negative number if there is a + * remainder and the quotient is negative or zero and the + * signs don't match. Note that we don't use a modulus to + * find the remainder since it is not well defined in C + * when the divisor is negative. + */ + if (((wquot < 0) || ((wquot == 0) && + ((w < 0 && w2 > 0) || (w > 0 && w2 < 0)))) && + ((wquot * w2) != w)) { wquot -= 1; } - wResult = wquot; - break; - case INST_EXPON: { - int errExpon; - - wResult = ExponWide(w, w2, &errExpon); - if (errExpon) { - TRACE((LLD" "LLD" => EXPONENT OF ZERO\n", w, w2)); - goto exponOfZero; - } - break; - } + } + wResult = wquot; + break; + case INST_EXPON: { + int errExpon; + + wResult = ExponWide(w, w2, &errExpon); + if (errExpon) { + TRACE((LLD" "LLD" => EXPONENT OF ZERO\n", w, w2)); + goto exponOfZero; + } + break; + } } } else { /* * Do integer arithmetic. */ switch (*pc) { - case INST_ADD: - iResult = i + i2; - break; - case INST_SUB: - iResult = i - i2; - break; - case INST_MULT: - iResult = i * i2; - break; - case INST_DIV: - /* - * This code is tricky: C doesn't guarantee much - * about the quotient or remainder, but Tcl does. - * The remainder always has the same sign as the - * divisor and a smaller absolute value. - */ - if (i2 == 0) { - TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2)); - goto divideByZero; - } - if (i2 < 0) { - i2 = -i2; - i = -i; - } + case INST_ADD: + iResult = i + i2; + break; + case INST_SUB: + iResult = i - i2; + break; + case INST_MULT: + iResult = i * i2; + break; + case INST_DIV: + /* + * When performing integer division, protect against integer + * overflow. Round towards zero when the quotient is positive, + * otherwise round towards -Infinity. + */ + if (i2 == 0) { + TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2)); + goto divideByZero; + } + if (i == LONG_MIN && i2 == -1) { + /* Avoid integer overflow on (LONG_MIN / -1) */ + quot = LONG_MIN; + } else { quot = i / i2; - rem = i % i2; - if (rem < 0) { + /* + * Round down to a smaller negative number if there is a + * remainder and the quotient is negative or zero and the + * signs don't match. Note that we don't use a modulus to + * find the remainder since it is not well defined in C + * when the divisor is negative. + */ + if (((quot < 0) || ((quot == 0) && + ((i<0 && i2>0) || (i>0 && i2<0)))) && + ((quot * i2) != i)) { quot -= 1; } - iResult = quot; - break; - case INST_EXPON: { - int errExpon; - - iResult = ExponLong(i, i2, &errExpon); - if (errExpon) { - TRACE(("%ld %ld => EXPONENT OF ZERO\n", i, i2)); - goto exponOfZero; - } - break; - } + } + iResult = quot; + break; + case INST_EXPON: { + int errExpon; + + iResult = ExponLong(i, i2, &errExpon); + if (errExpon) { + TRACE(("%ld %ld => EXPONENT OF ZERO\n", i, i2)); + goto exponOfZero; + } + break; + } } } /* * Reuse the valuePtr object already on stack if possible. */ - + if (Tcl_IsShared(valuePtr)) { if (doDouble) { - objResultPtr = Tcl_NewDoubleObj(dResult); + TclNewDoubleObj(objResultPtr, dResult); TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult)); } else if (doWide) { - objResultPtr = Tcl_NewWideIntObj(wResult); + TclNewWideIntObj(objResultPtr, wResult); TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); } else { - objResultPtr = Tcl_NewLongObj(iResult); + TclNewLongObj(objResultPtr, iResult); TRACE(("%ld %ld => %ld\n", i, i2, iResult)); - } + } NEXT_INST_F(1, 2, 1); } else { /* reuse the valuePtr object */ if (doDouble) { /* NB: stack top is off by 1 */ TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult)); - Tcl_SetDoubleObj(valuePtr, dResult); - } else if (doWide) { - TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); - Tcl_SetWideIntObj(valuePtr, wResult); - } else { - TRACE(("%ld %ld => %ld\n", i, i2, iResult)); - Tcl_SetLongObj(valuePtr, iResult); - } - 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; - } - tPtr = valuePtr->typePtr; - } - - /* - * 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) { - objResultPtr = Tcl_NewLongObj(valuePtr->internalRep.longValue); - } else if (tPtr == &tclWideIntType) { - Tcl_WideInt w; - - TclGetWide(w,valuePtr); - objResultPtr = Tcl_NewWideIntObj(w); - } else { - objResultPtr = Tcl_NewDoubleObj(valuePtr->internalRep.doubleValue); - } - TRACE_WITH_OBJ(("%s => ", O2S(objResultPtr)), objResultPtr); - NEXT_INST_F(1, 1, 1); - } else { - Tcl_InvalidateStringRep(valuePtr); - TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr); - NEXT_INST_F(1, 0, 0); - } - } - - 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; - 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 { - /* - * Otherwise, we need to generate a numeric internal rep. - * from the string rep. - */ - if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) { - valuePtr->typePtr = &tclIntType; - } else { - int length; - 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_ERROR && *pc == INST_LNOT) { - result = Tcl_GetBooleanFromObj((Tcl_Interp *)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); - goto checkForCatch; - } - } - tPtr = valuePtr->typePtr; - } - - if (Tcl_IsShared(valuePtr)) { - /* - * Create a new object. - */ - if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) { - i = valuePtr->internalRep.longValue; - objResultPtr = Tcl_NewLongObj( - (*pc == INST_UMINUS)? -i : !i); - TRACE_WITH_OBJ(("%ld => ", i), objResultPtr); - } else if (tPtr == &tclWideIntType) { - TclGetWide(w,valuePtr); - if (*pc == INST_UMINUS) { - objResultPtr = Tcl_NewWideIntObj(-w); - } else { - objResultPtr = Tcl_NewLongObj(w == W0); - } - TRACE_WITH_OBJ((LLD" => ", w), objResultPtr); - } else { - d = valuePtr->internalRep.doubleValue; - if (*pc == INST_UMINUS) { - objResultPtr = Tcl_NewDoubleObj(-d); - } else { - /* - * Should be able to use "!d", but apparently - * some compilers can't handle it. - */ - objResultPtr = Tcl_NewLongObj((d==0.0)? 1 : 0); - } - TRACE_WITH_OBJ(("%.6g => ", d), objResultPtr); - } - NEXT_INST_F(1, 1, 1); - } else { - /* - * valuePtr is unshared. Modify it directly. - */ - if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) { - i = valuePtr->internalRep.longValue; - Tcl_SetLongObj(valuePtr, - (*pc == INST_UMINUS)? -i : !i); - TRACE_WITH_OBJ(("%ld => ", i), valuePtr); - } else if (tPtr == &tclWideIntType) { - TclGetWide(w,valuePtr); - if (*pc == INST_UMINUS) { - Tcl_SetWideIntObj(valuePtr, -w); - } else { - Tcl_SetLongObj(valuePtr, w == W0); - } - TRACE_WITH_OBJ((LLD" => ", w), valuePtr); - } else { - d = valuePtr->internalRep.doubleValue; - if (*pc == INST_UMINUS) { - Tcl_SetDoubleObj(valuePtr, -d); - } else { - /* - * Should be able to use "!d", but apparently - * some compilers can't handle it. - */ - Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0); - } - TRACE_WITH_OBJ(("%.6g => ", d), valuePtr); - } - NEXT_INST_F(1, 0, 0); - } - } - - 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. - */ - - Tcl_ObjType *tPtr; - Tcl_Obj *valuePtr; - Tcl_WideInt w; - long i; - - 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; - } - } - - if (valuePtr->typePtr == &tclWideIntType) { - TclGetWide(w,valuePtr); - if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_NewWideIntObj(~w); - TRACE(("0x%llx => (%llu)\n", w, ~w)); - NEXT_INST_F(1, 1, 1); - } else { - /* - * valuePtr is unshared. Modify it directly. - */ - Tcl_SetWideIntObj(valuePtr, ~w); - TRACE(("0x%llx => (%llu)\n", w, ~w)); - NEXT_INST_F(1, 0, 0); - } - } else { - i = valuePtr->internalRep.longValue; - if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_NewLongObj(~i); - TRACE(("0x%lx => (%lu)\n", i, ~i)); - NEXT_INST_F(1, 1, 1); - } else { - /* - * valuePtr is unshared. Modify it directly. - */ - Tcl_SetLongObj(valuePtr, ~i); - TRACE(("0x%lx => (%lu)\n", i, ~i)); - NEXT_INST_F(1, 0, 0); - } - } - } - - case INST_CALL_BUILTIN_FUNC1: - { - int opnd; - BuiltinFunc *mathFuncPtr; - - /* - * Call one of the built-in Tcl math functions. - */ - - opnd = TclGetUInt1AtPtr(pc+1); - if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) { - TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd)); - Tcl_Panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd); - } - mathFuncPtr = &(tclBuiltinFuncTable[opnd]); - result = (*mathFuncPtr->proc)(interp, tosPtr, - mathFuncPtr->clientData); - if (result != TCL_OK) { - goto checkForCatch; - } - tosPtr -= (mathFuncPtr->numArgs - 1); - TRACE_WITH_OBJ(("%d => ", opnd), *tosPtr); - } - NEXT_INST_F(2, 0, 0); - - case INST_CALL_FUNC1: - { - /* - * Call a non-builtin Tcl math function previously - * registered by a call to Tcl_CreateMathFunc. - */ - - int objc; /* Number of arguments. The function name - * is the 0-th argument. */ - Tcl_Obj **objv; /* The array of arguments. The function - * name is objv[0]. */ - - objc = TclGetUInt1AtPtr(pc+1); - objv = (tosPtr - (objc-1)); /* "objv[0]" */ - DECACHE_STACK_INFO(); - result = ExprCallMathFunc(interp, objc, objv); - CACHE_STACK_INFO(); - if (result != TCL_OK) { - goto checkForCatch; - } - tosPtr = objv; - TRACE_WITH_OBJ(("%d => ", objc), *tosPtr); - } - NEXT_INST_F(2, 0, 0); - - 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. - */ - - double d; - char *s; - Tcl_ObjType *tPtr; - int converted, needNew, length; - Tcl_Obj *valuePtr; - long i; - Tcl_WideInt w; - - 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. - */ - if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) { - valuePtr->typePtr = &tclIntType; - converted = 1; - } else { - 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) { - converted = 1; - } - result = TCL_OK; /* reset the result variable */ - } - tPtr = valuePtr->typePtr; - } - - /* - * 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. - */ - - 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; - objResultPtr = Tcl_NewLongObj(i); - } else if (tPtr == &tclWideIntType) { - TclGetWide(w,valuePtr); - objResultPtr = Tcl_NewWideIntObj(w); - } else { - d = valuePtr->internalRep.doubleValue; - objResultPtr = Tcl_NewDoubleObj(d); - } - tPtr = objResultPtr->typePtr; - } - } else { - Tcl_InvalidateStringRep(valuePtr); - } - - if (tPtr == &tclDoubleType) { - d = objResultPtr->internalRep.doubleValue; - if (IS_NAN(d) || IS_INF(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 (needNew) { - NEXT_INST_F(1, 1, 1); - } else { - NEXT_INST_F(1, 0, 0); - } - } - + TclSetDoubleObj(valuePtr, dResult); + } else if (doWide) { + TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); + TclSetWideIntObj(valuePtr, wResult); + } else { + TRACE(("%ld %ld => %ld\n", i, i2, iResult)); + TclSetLongObj(valuePtr, iResult); + } + NEXT_INST_F(1, 1, 0); + } +#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); + } +#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; + } + result = Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2); + if (result != TCL_OK) { +#ifdef ACCEPT_NAN + if (value2Ptr->typePtr == &tclDoubleType) { + /* NaN second argument -> result is also NaN */ + objResultPtr = value2Ptr; + result = TCL_OK; + NEXT_INST_F(1, 2, 1); + } +#endif + TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", + O2S(value2Ptr), O2S(valuePtr), + (value2Ptr->typePtr? value2Ptr->typePtr->name: "null"))); + IllegalExprOperandType(interp, pc, value2Ptr); + goto checkForCatch; + } + 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 + /* + * 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 + if (Tcl_IsShared(valuePtr)) { + 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; + } + mp_clear(&big1); + mp_clear(&big2); + objResultPtr = eePtr->constants[0]; + NEXT_INST_F(1, 2, 1); + } + 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); + } + } + mp_clear(&big1); + mp_clear(&big2); + NEXT_INST_F(1, 2, 1); + } + 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; + } + 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); + } +#endif + } + + case INST_LNOT: { + int b; + Tcl_Obj *valuePtr = *tosPtr; + + /* 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); + } + + 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); + } +#ifndef NO_WIDE_TYPE + if (type == TCL_NUMBER_LONG) { + Tcl_WideInt w = *((CONST Tcl_WideInt *)ptr); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewWideIntObj(~w); + NEXT_INST_F(1, 1, 1); + } + Tcl_SetWideIntObj(valuePtr, ~w); + NEXT_INST_F(1, 0, 0); + } +#endif + if (Tcl_IsShared(valuePtr)) { + Tcl_GetBignumFromObj(NULL, valuePtr, &big); + } else { + 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)) { + 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 { + 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); + } + } + + case INST_CALL_BUILTIN_FUNC1: { + Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found"); + } + + case INST_CALL_FUNC1: { + 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 numeric object. + * This is done in order to support [expr]'s policy of interpreting + * operands if at all possible as numbers first, then strings. + */ + + ClientData ptr; + int type; + Tcl_Obj *valuePtr = *tosPtr; + + 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 { + /* ... TryConvertToNumeric($NonNumeric) is acceptable */ + TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); + } + } +#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)); + } + goto checkForCatch; + } +#endif + + /* + * 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. + */ + if (valuePtr->bytes == NULL) { + TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); + } + 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); + } + TclInvalidateStringRep(valuePtr); + TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); + } + case INST_BREAK: DECACHE_STACK_INFO(); Tcl_ResetResult(interp); CACHE_STACK_INFO(); result = TCL_BREAK; @@ -4498,213 +5295,210 @@ CACHE_STACK_INFO(); result = TCL_CONTINUE; cleanup = 0; goto processExceptionReturn; - case INST_FOREACH_START4: - { - /* - * Initialize the temporary local var that holds the count - * of the number of iterations of the loop body to -1. - */ - - int opnd; - ForeachInfo *infoPtr; - int iterTmpIndex; - Var *iterVarPtr; - Tcl_Obj *oldValuePtr; - - opnd = TclGetUInt4AtPtr(pc+1); - infoPtr = (ForeachInfo *) - codePtr->auxDataArrayPtr[opnd].clientData; - iterTmpIndex = infoPtr->loopCtTemp; - iterVarPtr = &(compiledLocals[iterTmpIndex]); - oldValuePtr = iterVarPtr->value.objPtr; - - if (oldValuePtr == NULL) { - iterVarPtr->value.objPtr = Tcl_NewLongObj(-1); - Tcl_IncrRefCount(iterVarPtr->value.objPtr); - } else { - Tcl_SetLongObj(oldValuePtr, -1); - } - TclSetVarScalar(iterVarPtr); - TclClearVarUndefined(iterVarPtr); - TRACE(("%u => loop iter count temp %d\n", - opnd, iterTmpIndex)); - } - + case INST_FOREACH_START4: { + /* + * Initialize the temporary local var that holds the count of the + * number of iterations of the loop body to -1. + */ + + int opnd; + ForeachInfo *infoPtr; + int iterTmpIndex; + Var *iterVarPtr; + Tcl_Obj *oldValuePtr; + + opnd = TclGetUInt4AtPtr(pc+1); + infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData; + iterTmpIndex = infoPtr->loopCtTemp; + iterVarPtr = &(compiledLocals[iterTmpIndex]); + oldValuePtr = iterVarPtr->value.objPtr; + + if (oldValuePtr == NULL) { + TclNewLongObj(iterVarPtr->value.objPtr, -1); + Tcl_IncrRefCount(iterVarPtr->value.objPtr); + } else { + TclSetLongObj(oldValuePtr, -1); + } + TclSetVarScalar(iterVarPtr); + TclClearVarUndefined(iterVarPtr); + TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex)); + #ifndef TCL_COMPILE_DEBUG - /* - * Remark that the compiler ALWAYS sets INST_FOREACH_STEP4 - * immediately after INST_FOREACH_START4 - let us just fall - * through instead of jumping back to the top. + /* + * Remark that the compiler ALWAYS sets INST_FOREACH_STEP4 immediately + * after INST_FOREACH_START4 - let us just fall through instead of + * jumping back to the top. */ pc += 5; #else NEXT_INST_F(5, 0, 0); -#endif - case INST_FOREACH_STEP4: - { - /* - * "Step" a foreach loop (i.e., begin its next iteration) by - * assigning the next value list element to each loop var. - */ - - int opnd; - ForeachInfo *infoPtr; - ForeachVarList *varListPtr; - int numLists; - Tcl_Obj *listPtr,*valuePtr, *value2Ptr; - List *listRepPtr; - Var *iterVarPtr, *listVarPtr; - int iterNum, listTmpIndex, listLen, numVars; - int varIndex, valIndex, continueLoop, j; - long i; - Var *varPtr; - char *part1; - - opnd = TclGetUInt4AtPtr(pc+1); - infoPtr = (ForeachInfo *) - codePtr->auxDataArrayPtr[opnd].clientData; - numLists = infoPtr->numLists; - - /* - * Increment the temp holding the loop iteration number. - */ - - iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]); - valuePtr = iterVarPtr->value.objPtr; - iterNum = (valuePtr->internalRep.longValue + 1); - Tcl_SetLongObj(valuePtr, iterNum); - - /* - * Check whether all value lists are exhausted and we should - * stop the loop. - */ - - continueLoop = 0; - listTmpIndex = infoPtr->firstValueTemp; - for (i = 0; i < numLists; i++) { - varListPtr = infoPtr->varLists[i]; - numVars = varListPtr->numVars; - - listVarPtr = &(compiledLocals[listTmpIndex]); - listPtr = listVarPtr->value.objPtr; - result = Tcl_ListObjLength(interp, listPtr, &listLen); - if (result != TCL_OK) { - TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ", - opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp)); - goto checkForCatch; - } - if (listLen > (iterNum * numVars)) { - continueLoop = 1; - } - listTmpIndex++; - } - - /* - * If some var in some var list still has a remaining list - * element iterate one more time. Assign to var the next - * element from its value list. We already checked above - * that each list temp holds a valid list object. - */ - - if (continueLoop) { - listTmpIndex = infoPtr->firstValueTemp; - for (i = 0; i < numLists; i++) { - varListPtr = infoPtr->varLists[i]; - numVars = varListPtr->numVars; - - listVarPtr = &(compiledLocals[listTmpIndex]); - listPtr = listVarPtr->value.objPtr; - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; - listLen = listRepPtr->elemCount; - - valIndex = (iterNum * numVars); - for (j = 0; j < numVars; j++) { - int setEmptyStr = 0; - if (valIndex >= listLen) { - setEmptyStr = 1; - TclNewObj(valuePtr); - } else { - valuePtr = listRepPtr->elements[valIndex]; - } - - varIndex = varListPtr->varIndexes[j]; - varPtr = &(compiledLocals[varIndex]); - part1 = varPtr->name; - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - if (TclIsVarDirectWritable(varPtr)) { - value2Ptr = varPtr->value.objPtr; - if (valuePtr != value2Ptr) { - if (value2Ptr != NULL) { - TclDecrRefCount(value2Ptr); - } else { - TclSetVarScalar(varPtr); - TclClearVarUndefined(varPtr); - } - varPtr->value.objPtr = valuePtr; - Tcl_IncrRefCount(valuePtr); - } - } else { - DECACHE_STACK_INFO(); - value2Ptr = TclPtrSetVar(interp, varPtr, NULL, part1, - NULL, valuePtr, TCL_LEAVE_ERR_MSG); - CACHE_STACK_INFO(); - if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ", - opnd, varIndex), - Tcl_GetObjResult(interp)); - if (setEmptyStr) { - TclDecrRefCount(valuePtr); - } - result = TCL_ERROR; - goto checkForCatch; - } - } - valIndex++; - } - listTmpIndex++; - } - } - TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists, - iterNum, (continueLoop? "continue" : "exit"))); - - /* - * Run-time peep-hole optimisation: the compiler ALWAYS follows - * INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that - * instruction and jump direct from here. - */ - - pc += 5; - if (*pc == INST_JUMP_FALSE1) { - NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0); - } else { - NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0); - } - } - - case INST_BEGIN_CATCH4: - /* - * Record start of the catch command with exception range index - * equal to the operand. Push the current stack depth onto the - * special catch stack. - */ - eePtr->stackPtr[++catchTop] = (Tcl_Obj *) (tosPtr - eePtr->stackPtr); - TRACE(("%u => catchTop=%d, stackTop=%d\n", - TclGetUInt4AtPtr(pc+1), (catchTop - initCatchTop - 1), tosPtr - eePtr->stackPtr)); +#endif + } + + case INST_FOREACH_STEP4: { + /* + * "Step" a foreach loop (i.e., begin its next iteration) by assigning + * the next value list element to each loop var. + */ + + int opnd; + ForeachInfo *infoPtr; + ForeachVarList *varListPtr; + int numLists; + Tcl_Obj *listPtr,*valuePtr, *value2Ptr; + Tcl_Obj **elements; + Var *iterVarPtr, *listVarPtr; + int iterNum, listTmpIndex, listLen, numVars; + int varIndex, valIndex, continueLoop, j; + long i; + Var *varPtr; + char *part1; + + opnd = TclGetUInt4AtPtr(pc+1); + infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData; + numLists = infoPtr->numLists; + + /* + * Increment the temp holding the loop iteration number. + */ + + iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]); + valuePtr = iterVarPtr->value.objPtr; + iterNum = (valuePtr->internalRep.longValue + 1); + TclSetLongObj(valuePtr, iterNum); + + /* + * Check whether all value lists are exhausted and we should stop the + * loop. + */ + + continueLoop = 0; + listTmpIndex = infoPtr->firstValueTemp; + for (i = 0; i < numLists; i++) { + varListPtr = infoPtr->varLists[i]; + numVars = varListPtr->numVars; + + listVarPtr = &(compiledLocals[listTmpIndex]); + listPtr = listVarPtr->value.objPtr; + result = Tcl_ListObjLength(interp, listPtr, &listLen); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ", + opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp)); + goto checkForCatch; + } + if (listLen > (iterNum * numVars)) { + continueLoop = 1; + } + listTmpIndex++; + } + + /* + * If some var in some var list still has a remaining list element + * iterate one more time. Assign to var the next element from its + * value list. We already checked above that each list temp holds a + * valid list object (by calling Tcl_ListObjLength), but cannot rely + * on that check remaining valid: one list could have been shimmered + * as a side effect of setting a traced variable. + */ + + if (continueLoop) { + listTmpIndex = infoPtr->firstValueTemp; + for (i = 0; i < numLists; i++) { + varListPtr = infoPtr->varLists[i]; + numVars = varListPtr->numVars; + + listVarPtr = &(compiledLocals[listTmpIndex]); + listPtr = listVarPtr->value.objPtr; + Tcl_ListObjGetElements(interp, listPtr, &listLen, &elements); + + valIndex = (iterNum * numVars); + for (j = 0; j < numVars; j++) { + int setEmptyStr = 0; + if (valIndex >= listLen) { + setEmptyStr = 1; + TclNewObj(valuePtr); + } else { + valuePtr = elements[valIndex]; + } + + varIndex = varListPtr->varIndexes[j]; + varPtr = &(compiledLocals[varIndex]); + part1 = varPtr->name; + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + if (TclIsVarDirectWritable(varPtr)) { + value2Ptr = varPtr->value.objPtr; + if (valuePtr != value2Ptr) { + if (value2Ptr != NULL) { + TclDecrRefCount(value2Ptr); + } else { + TclSetVarScalar(varPtr); + TclClearVarUndefined(varPtr); + } + varPtr->value.objPtr = valuePtr; + Tcl_IncrRefCount(valuePtr); + } + } else { + DECACHE_STACK_INFO(); + value2Ptr = TclPtrSetVar(interp, varPtr, NULL, part1, + NULL, valuePtr, TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ", + opnd, varIndex), Tcl_GetObjResult(interp)); + if (setEmptyStr) { + TclDecrRefCount(valuePtr); + } + result = TCL_ERROR; + goto checkForCatch; + } + } + valIndex++; + } + listTmpIndex++; + } + } + TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists, + iterNum, (continueLoop? "continue" : "exit"))); + + /* + * Run-time peep-hole optimisation: the compiler ALWAYS follows + * INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that + * instruction and jump direct from here. + */ + + pc += 5; + if (*pc == INST_JUMP_FALSE1) { + NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0); + } else { + NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0); + } + } + + case INST_BEGIN_CATCH4: + /* + * Record start of the catch command with exception range index equal + * to the operand. Push the current stack depth onto the special catch + * stack. + */ + eePtr->stackPtr[++catchTop] = (Tcl_Obj *) (tosPtr - eePtr->stackPtr); + TRACE(("%u => catchTop=%d, stackTop=%d\n", + TclGetUInt4AtPtr(pc+1), (catchTop - initCatchTop - 1), + tosPtr - eePtr->stackPtr)); NEXT_INST_F(5, 0, 0); case INST_END_CATCH: catchTop--; result = TCL_OK; TRACE(("=> catchTop=%d\n", (catchTop - initCatchTop - 1))); NEXT_INST_F(1, 0, 0); - + case INST_PUSH_RESULT: objResultPtr = Tcl_GetObjResult(interp); TRACE_WITH_OBJ(("=> "), objResultPtr); /* @@ -4718,34 +5512,538 @@ } NEXT_INST_F(1, 0, -1); case INST_PUSH_RETURN_CODE: - objResultPtr = Tcl_NewLongObj(result); + TclNewIntObj(objResultPtr, result); TRACE(("=> %u\n", result)); NEXT_INST_F(1, 0, 1); + + case INST_PUSH_RETURN_OPTIONS: + objResultPtr = Tcl_GetReturnOptions(interp, result); + TRACE_WITH_OBJ(("=> "), objResultPtr); + NEXT_INST_F(1, 0, 1); + +/* TODO: normalize "valPtr" to "valuePtr" */ + { + int opnd, opnd2, allocateDict; + Tcl_Obj *dictPtr, *valPtr; + Var *varPtr; + char *part1; + + case INST_DICT_GET: + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ", opnd)); + dictPtr = *(tosPtr - opnd); + if (opnd > 1) { + dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1, + tosPtr - (opnd-1), DICT_PATH_READ); + if (dictPtr == NULL) { + TRACE_WITH_OBJ(( + "%u => ERROR tracing dictionary path into \"%s\": ", + opnd, O2S(*(tosPtr - opnd))), + Tcl_GetObjResult(interp)); + result = TCL_ERROR; + cleanup = opnd + 1; + goto checkForCatch; + } + } + result = Tcl_DictObjGet(interp, dictPtr, *tosPtr, &objResultPtr); + if (result != TCL_OK) { + TRACE_WITH_OBJ(( + "%u => ERROR reading leaf dictionary key \"%s\": ", + opnd, O2S(dictPtr)), Tcl_GetObjResult(interp)); + cleanup = opnd + 1; + goto checkForCatch; + } + if (objResultPtr == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "key \"", TclGetString(*tosPtr), + "\" not known in dictionary", NULL); + TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp)); + result = TCL_ERROR; + cleanup = opnd + 1; + goto checkForCatch; + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(5, opnd+1, 1); + + case INST_DICT_SET: + case INST_DICT_UNSET: + case INST_DICT_INCR_IMM: + opnd = TclGetUInt4AtPtr(pc+1); + opnd2 = TclGetUInt4AtPtr(pc+5); + + varPtr = &(compiledLocals[opnd2]); + part1 = varPtr->name; + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + TRACE(("%u %u => ", opnd, opnd2)); + if (TclIsVarDirectReadable(varPtr)) { + dictPtr = varPtr->value.objPtr; + } else { + DECACHE_STACK_INFO(); + dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL, 0); + CACHE_STACK_INFO(); + } + if (dictPtr == NULL) { + TclNewObj(dictPtr); + allocateDict = 1; + } else { + allocateDict = Tcl_IsShared(dictPtr); + if (allocateDict) { + dictPtr = Tcl_DuplicateObj(dictPtr); + } + } + + switch (*pc) { + case INST_DICT_SET: + cleanup = opnd + 1; + result = Tcl_DictObjPutKeyList(interp, dictPtr, opnd, tosPtr-opnd, + *tosPtr); + break; + case INST_DICT_INCR_IMM: + cleanup = 1; + opnd = TclGetInt4AtPtr(pc+1); + result = Tcl_DictObjGet(interp, dictPtr, *tosPtr, &valPtr); + if (result != TCL_OK) { + break; + } + if (valPtr == NULL) { + Tcl_DictObjPut(NULL, dictPtr, *tosPtr, Tcl_NewIntObj(opnd)); + } else { + Tcl_Obj *incrPtr = Tcl_NewIntObj(opnd); + Tcl_IncrRefCount(incrPtr); + if (Tcl_IsShared(valPtr)) { + valPtr = Tcl_DuplicateObj(valPtr); + Tcl_DictObjPut(NULL, dictPtr, *tosPtr, valPtr); + } + result = TclIncrObj(interp, valPtr, incrPtr); + if (result == TCL_OK) { + Tcl_InvalidateStringRep(dictPtr); + } + Tcl_DecrRefCount(incrPtr); + } + break; + case INST_DICT_UNSET: + cleanup = opnd; + result = Tcl_DictObjRemoveKeyList(interp, dictPtr, opnd, + tosPtr - (opnd-1)); + break; + default: + cleanup = 0; /* stop compiler warning */ + Tcl_Panic("Should not happen!"); + } + + if (result != TCL_OK) { + if (allocateDict) { + Tcl_DecrRefCount(dictPtr); + } + TRACE_WITH_OBJ(("%u %u => ERROR updating dictionary: ",opnd,opnd2), + Tcl_GetObjResult(interp)); + goto checkForCatch; + } + + if (TclIsVarDirectWritable(varPtr)) { + if (allocateDict) { + Tcl_Obj *oldValuePtr = varPtr->value.objPtr; + + Tcl_IncrRefCount(dictPtr); + if (oldValuePtr != NULL) { + Tcl_DecrRefCount(oldValuePtr); + } else { + TclSetVarScalar(varPtr); + TclClearVarUndefined(varPtr); + } + varPtr->value.objPtr = dictPtr; + } + objResultPtr = dictPtr; + } else { + Tcl_IncrRefCount(dictPtr); + DECACHE_STACK_INFO(); + objResultPtr = TclPtrSetVar(interp, varPtr, NULL, part1, NULL, + dictPtr, TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + Tcl_DecrRefCount(dictPtr); + if (objResultPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n",O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; + } + } +#ifndef TCL_COMPILE_DEBUG + if (*(pc+9) == INST_POP) { + NEXT_INST_V(10, cleanup, 0); + } +#endif + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(9, cleanup, 1); + + case INST_DICT_APPEND: + case INST_DICT_LAPPEND: + opnd = TclGetUInt4AtPtr(pc+1); + cleanup = 2; + + varPtr = &(compiledLocals[opnd]); + part1 = varPtr->name; + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + TRACE(("%u => ", opnd)); + if (TclIsVarDirectReadable(varPtr)) { + dictPtr = varPtr->value.objPtr; + } else { + DECACHE_STACK_INFO(); + dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL, 0); + CACHE_STACK_INFO(); + } + if (dictPtr == NULL) { + TclNewObj(dictPtr); + allocateDict = 1; + } else { + allocateDict = Tcl_IsShared(dictPtr); + if (allocateDict) { + dictPtr = Tcl_DuplicateObj(dictPtr); + } + } + + result = Tcl_DictObjGet(interp, dictPtr, *(tosPtr - 1), &valPtr); + if (result != TCL_OK) { + if (allocateDict) { + Tcl_DecrRefCount(dictPtr); + } + goto checkForCatch; + } + + /* + * Note that a non-existent key results in a NULL valPtr, which is a + * case handled separately below. What we *can* say at this point is + * that the write-back will always succeed. + */ + + switch (*pc) { + case INST_DICT_APPEND: + if (valPtr == NULL) { + valPtr = *tosPtr; + } else { + if (Tcl_IsShared(valPtr)) { + valPtr = Tcl_DuplicateObj(valPtr); + } + Tcl_AppendObjToObj(valPtr, *tosPtr); + } + break; + case INST_DICT_LAPPEND: + /* + * More complex because list-append can fail. + */ + if (valPtr == NULL) { + valPtr = Tcl_NewListObj(1, tosPtr); + } else if (Tcl_IsShared(valPtr)) { + valPtr = Tcl_DuplicateObj(valPtr); + result = Tcl_ListObjAppendElement(interp, valPtr, *tosPtr); + if (result != TCL_OK) { + Tcl_DecrRefCount(valPtr); + if (allocateDict) { + Tcl_DecrRefCount(dictPtr); + } + goto checkForCatch; + } + } else { + result = Tcl_ListObjAppendElement(interp, valPtr, *tosPtr); + if (result != TCL_OK) { + if (allocateDict) { + Tcl_DecrRefCount(dictPtr); + } + goto checkForCatch; + } + } + break; + default: + Tcl_Panic("Should not happen!"); + } + + Tcl_DictObjPut(NULL, dictPtr, *(tosPtr - 1), valPtr); + + if (TclIsVarDirectWritable(varPtr)) { + if (allocateDict) { + Tcl_Obj *oldValuePtr = varPtr->value.objPtr; + + Tcl_IncrRefCount(dictPtr); + if (oldValuePtr != NULL) { + Tcl_DecrRefCount(oldValuePtr); + } else { + TclSetVarScalar(varPtr); + TclClearVarUndefined(varPtr); + } + varPtr->value.objPtr = dictPtr; + } + objResultPtr = dictPtr; + } else { + Tcl_IncrRefCount(dictPtr); + DECACHE_STACK_INFO(); + objResultPtr = TclPtrSetVar(interp, varPtr, NULL, part1, NULL, + dictPtr, TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + Tcl_DecrRefCount(dictPtr); + if (objResultPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n",O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; + } + } +#ifndef TCL_COMPILE_DEBUG + if (*(pc+9) == INST_POP) { + NEXT_INST_F(6, 2, 0); + } +#endif + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(5, 2, 1); + } + + { + int opnd, done; + Tcl_Obj *statePtr, *dictPtr, *keyPtr, *valuePtr, *emptyPtr; + Var *varPtr; + Tcl_DictSearch *searchPtr; + + case INST_DICT_FIRST: + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ", opnd)); + dictPtr = POP_OBJECT(); + searchPtr = (Tcl_DictSearch *) ckalloc(sizeof(Tcl_DictSearch)); + result = Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr, + &valuePtr, &done); + Tcl_DecrRefCount(dictPtr); + if (result != TCL_OK) { + ckfree((char *) searchPtr); + cleanup = 0; + goto checkForCatch; + } + TclNewObj(statePtr); + statePtr->typePtr = &dictIteratorType; + statePtr->internalRep.otherValuePtr = (void *) searchPtr; + varPtr = compiledLocals + opnd; + if (varPtr->value.objPtr == NULL) { + TclSetVarScalar(compiledLocals + opnd); + TclClearVarUndefined(compiledLocals + opnd); + } else if (varPtr->value.objPtr->typePtr == &dictIteratorType) { + Tcl_Panic("mis-issued dictFirst!"); + } else { + Tcl_DecrRefCount(varPtr->value.objPtr); + } + varPtr->value.objPtr = statePtr; + Tcl_IncrRefCount(statePtr); + goto pushDictIteratorResult; + + case INST_DICT_NEXT: + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ", opnd)); + statePtr = compiledLocals[opnd].value.objPtr; + if (statePtr == NULL || statePtr->typePtr != &dictIteratorType) { + Tcl_Panic("mis-issued dictNext!"); + } + searchPtr = (Tcl_DictSearch *) statePtr->internalRep.otherValuePtr; + Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done); + pushDictIteratorResult: + if (done) { + TclNewObj(emptyPtr); + PUSH_OBJECT(emptyPtr); + PUSH_OBJECT(emptyPtr); + } else { + PUSH_OBJECT(valuePtr); + PUSH_OBJECT(keyPtr); + } + TRACE_APPEND(("\"%.30s\" \"%.30s\" %d", + O2S(*(tosPtr-1)), O2S(*tosPtr), done)); + objResultPtr = eePtr->constants[done]; + /*TODO: consider opt like INST_FOREACH_STEP4 */ + NEXT_INST_F(5, 0, 1); + + case INST_DICT_DONE: + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ", opnd)); + statePtr = compiledLocals[opnd].value.objPtr; + if (statePtr == NULL) { + Tcl_Panic("mis-issued dictDone!"); + } + if (statePtr->typePtr == &dictIteratorType) { + searchPtr = (Tcl_DictSearch *) statePtr->internalRep.otherValuePtr; + Tcl_DictObjDone(searchPtr); + ckfree((char *) searchPtr); + } + /* + * Set the internal variable to an empty object to signify + * that we don't hold an iterator. + */ + Tcl_DecrRefCount(statePtr); + TclNewObj(emptyPtr); + compiledLocals[opnd].value.objPtr = emptyPtr; + Tcl_IncrRefCount(emptyPtr); + NEXT_INST_F(5, 0, 0); + } + + { + int opnd, i, length, length2, allocdict; + Tcl_Obj **keyPtrPtr, **varIdxPtrPtr, *dictPtr; + Var *varPtr; + char *part1; + + case INST_DICT_UPDATE_START: + opnd = TclGetUInt4AtPtr(pc+1); + varPtr = &(compiledLocals[opnd]); + part1 = varPtr->name; + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + TRACE(("%u => ", opnd)); + if (TclIsVarDirectReadable(varPtr)) { + dictPtr = varPtr->value.objPtr; + } else { + DECACHE_STACK_INFO(); + dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL, + TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (dictPtr == NULL) { + goto dictUpdateStartFailed; + } + } + if (Tcl_ListObjGetElements(interp, *(tosPtr - 1), &length, + &keyPtrPtr) != TCL_OK || + Tcl_ListObjGetElements(interp, *tosPtr, &length2, + &varIdxPtrPtr) != TCL_OK) { + goto dictUpdateStartFailed; + } + if (length != length2) { + Tcl_Panic("dictUpdateStart argument length mismatch"); + } + for (i=0 ; iname; + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + DECACHE_STACK_INFO(); + if (valPtr == NULL) { + Tcl_UnsetVar(interp, part1, 0); + } else if (TclPtrSetVar(interp, varPtr, NULL, part1, NULL, + valPtr, TCL_LEAVE_ERR_MSG) == NULL) { + CACHE_STACK_INFO(); + dictUpdateStartFailed: + cleanup = 2; + result = TCL_ERROR; + goto checkForCatch; + } + CACHE_STACK_INFO(); + } + NEXT_INST_F(5, 2, 0); + + case INST_DICT_UPDATE_END: + opnd = TclGetUInt4AtPtr(pc+1); + varPtr = &(compiledLocals[opnd]); + part1 = varPtr->name; + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + TRACE(("%u => ", opnd)); + if (TclIsVarDirectReadable(varPtr)) { + dictPtr = varPtr->value.objPtr; + } else { + DECACHE_STACK_INFO(); + dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL, 0); + CACHE_STACK_INFO(); + } + if (dictPtr == NULL) { + NEXT_INST_F(5, 2, 0); + } + if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK || + Tcl_ListObjGetElements(interp, *(tosPtr - 1), &length, + &keyPtrPtr) != TCL_OK || + Tcl_ListObjGetElements(interp, *tosPtr, &length2, + &varIdxPtrPtr) != TCL_OK) { + cleanup = 2; + result = TCL_ERROR; + goto checkForCatch; + } + allocdict = Tcl_IsShared(dictPtr); + if (allocdict) { + dictPtr = Tcl_DuplicateObj(dictPtr); + } + for (i=0 ; iname; + while (TclIsVarLink(var2Ptr)) { + var2Ptr = var2Ptr->value.linkPtr; + } + if (TclIsVarDirectReadable(var2Ptr)) { + valPtr = var2Ptr->value.objPtr; + } else { + DECACHE_STACK_INFO(); + valPtr = TclPtrGetVar(interp, var2Ptr, NULL, part1a, NULL, 0); + CACHE_STACK_INFO(); + } + if (valPtr == NULL) { + Tcl_DictObjRemove(interp, dictPtr, keyPtrPtr[i]); + } else { + Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], valPtr); + } + } + if (TclIsVarDirectWritable(varPtr)) { + Tcl_IncrRefCount(dictPtr); + Tcl_DecrRefCount(varPtr->value.objPtr); + varPtr->value.objPtr = dictPtr; + } else { + DECACHE_STACK_INFO(); + objResultPtr = TclPtrSetVar(interp, varPtr, NULL, part1, NULL, + dictPtr, TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (objResultPtr == NULL) { + if (allocdict) { + Tcl_DecrRefCount(dictPtr); + } + cleanup = 2; + result = TCL_ERROR; + goto checkForCatch; + } + } + NEXT_INST_F(5, 2, 0); + } default: Tcl_Panic("TclExecuteByteCode: unrecognized opCode %u", *pc); } /* end of switch on opCode */ /* - * Division by zero in an expression. Control only reaches this - * point by "goto divideByZero". + * Division by zero in an expression. Control only reaches this point by + * "goto divideByZero". */ - + divideByZero: Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1)); Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", - (char *) NULL); + (char *) NULL); result = TCL_ERROR; goto checkForCatch; /* - * Exponentiation of zero by negative number in an expression. - * Control only reaches this point by "goto exponOfZero". + * Exponentiation of zero by negative number in an expression. Control + * only reaches this point by "goto exponOfZero". */ exponOfZero: Tcl_SetObjResult(interp, Tcl_NewStringObj( "exponentiation of zero by negative power", -1)); @@ -4755,61 +6053,60 @@ goto checkForCatch; /* * Block for variables needed to process exception returns */ - + { - ExceptionRange *rangePtr; /* Points to closest loop or catch * exception range enclosing the pc. Used * by various instructions and processCatch * to process break, continue, and - * errors. */ + * errors. */ Tcl_Obj *valuePtr; char *bytes; int length; #if TCL_COMPILE_DEBUG int opnd; #endif - /* - * An external evaluation (INST_INVOKE or INST_EVAL) returned - * something different from TCL_OK, or else INST_BREAK or + /* + * An external evaluation (INST_INVOKE or INST_EVAL) returned + * something different from TCL_OK, or else INST_BREAK or * INST_CONTINUE were called. */ - processExceptionReturn: -#if TCL_COMPILE_DEBUG + processExceptionReturn: +#if TCL_COMPILE_DEBUG switch (*pc) { - case INST_INVOKE_STK1: - opnd = TclGetUInt1AtPtr(pc+1); - TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf)); - break; - case INST_INVOKE_STK4: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf)); - break; - case INST_EVAL_STK: - /* - * Note that the object at stacktop has to be used - * before doing the cleanup. - */ - - TRACE(("\"%.30s\" => ", O2S(*tosPtr))); - break; - default: - TRACE(("=> ")); - } -#endif + case INST_INVOKE_STK1: + opnd = TclGetUInt1AtPtr(pc+1); + TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf)); + break; + case INST_INVOKE_STK4: + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf)); + break; + case INST_EVAL_STK: + /* + * Note that the object at stacktop has to be used before doing + * the cleanup. + */ + + TRACE(("\"%.30s\" => ", O2S(*tosPtr))); + break; + default: + TRACE(("=> ")); + } +#endif if ((result == TCL_CONTINUE) || (result == TCL_BREAK)) { rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr); if (rangePtr == NULL) { TRACE_APPEND(("no encl. loop or catch, returning %s\n", - StringForResultCode(result))); + StringForResultCode(result))); goto abnormalReturn; - } + } if (rangePtr->type == CATCH_EXCEPTION_RANGE) { TRACE_APPEND(("%s ...\n", StringForResultCode(result))); goto processCatch; } while (cleanup--) { @@ -4818,48 +6115,48 @@ } if (result == TCL_BREAK) { result = TCL_OK; pc = (codePtr->codeStart + rangePtr->breakOffset); TRACE_APPEND(("%s, range at %d, new pc %d\n", - StringForResultCode(result), - rangePtr->codeOffset, rangePtr->breakOffset)); + StringForResultCode(result), + rangePtr->codeOffset, rangePtr->breakOffset)); NEXT_INST_F(0, 0, 0); } else { if (rangePtr->continueOffset == -1) { TRACE_APPEND(("%s, loop w/o continue, checking for catch\n", - StringForResultCode(result))); + StringForResultCode(result))); goto checkForCatch; - } + } result = TCL_OK; pc = (codePtr->codeStart + rangePtr->continueOffset); TRACE_APPEND(("%s, range at %d, new pc %d\n", - StringForResultCode(result), - rangePtr->codeOffset, rangePtr->continueOffset)); + StringForResultCode(result), + rangePtr->codeOffset, rangePtr->continueOffset)); NEXT_INST_F(0, 0, 0); } -#if TCL_COMPILE_DEBUG +#if TCL_COMPILE_DEBUG } else if (traceInstructions) { if ((result != TCL_ERROR) && (result != TCL_RETURN)) { Tcl_Obj *objPtr = Tcl_GetObjResult(interp); - TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ", + TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ", result, O2S(objPtr))); } else { Tcl_Obj *objPtr = Tcl_GetObjResult(interp); - TRACE_APPEND(("%s, result= \"%s\"\n", + TRACE_APPEND(("%s, result= \"%s\"\n", StringForResultCode(result), O2S(objPtr))); } #endif } - + /* * Execution has generated an "exception" such as TCL_ERROR. If the * exception is an error, record information about what was being - * executed when the error occurred. Find the closest enclosing - * catch range, if any. If no enclosing catch range is found, stop - * execution and return the "exception" code. + * executed when the error occurred. Find the closest enclosing catch + * range, if any. If no enclosing catch range is found, stop execution + * and return the "exception" code. */ - + checkForCatch: if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { bytes = GetSrcInfoForPc(pc, codePtr, &length); if (bytes != NULL) { Tcl_LogCommandInfo(interp, codePtr->source, bytes, length); @@ -4867,25 +6164,25 @@ } iPtr->flags &= ~ERR_ALREADY_LOGGED; /* * Clear all expansions that may have started after the last - * INST_BEGIN_CATCH. + * INST_BEGIN_CATCH. */ while ((expandNestList != NULL) && ((catchTop == initCatchTop) || ((ptrdiff_t) eePtr->stackPtr[catchTop] <= - (ptrdiff_t) expandNestList->internalRep.twoPtrValue.ptr1))) { + (ptrdiff_t) expandNestList->internalRep.twoPtrValue.ptr1))) { Tcl_Obj *objPtr = expandNestList->internalRep.twoPtrValue.ptr2; TclDecrRefCount(expandNestList); expandNestList = objPtr; } /* - * We must not catch an exceeded limit. Instead, it blows - * outwards until we either hit another interpreter (presumably - * where the limit is not exceeded) or we get to the top-level. + * We must not catch an exceeded limit. Instead, it blows outwards + * until we either hit another interpreter (presumably where the limit + * is not exceeded) or we get to the top-level. */ if (Tcl_LimitExceeded(interp)) { #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { fprintf(stdout, " ... limit exceeded, returning %s\n", @@ -4905,11 +6202,11 @@ } rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr); if (rangePtr == NULL) { /* * This is only possible when compiling a [catch] that sends its - * script to INST_EVAL. Cannot correct the compiler without + * script to INST_EVAL. Cannot correct the compiler without * breakingcompat with previous .tbc compiled scripts. */ #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { fprintf(stdout, " ... no enclosing catch, returning %s\n", @@ -4916,18 +6213,17 @@ StringForResultCode(result)); } #endif goto abnormalReturn; } - + /* * A catch exception range (rangePtr) was found to handle an - * "exception". It was found either by checkForCatch just above or - * by an instruction during break, continue, or error processing. - * Jump to its catchOffset after unwinding the operand stack to - * the depth it had when starting to execute the range's catch - * command. + * "exception". It was found either by checkForCatch just above or by + * an instruction during break, continue, or error processing. Jump + * to its catchOffset after unwinding the operand stack to the depth + * it had when starting to execute the range's catch command. */ processCatch: while (tosPtr > ((ptrdiff_t) (eePtr->stackPtr[catchTop])) + eePtr->stackPtr) { valuePtr = POP_OBJECT(); @@ -4934,33 +6230,44 @@ TclDecrRefCount(valuePtr); } #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { fprintf(stdout, " ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n", - rangePtr->codeOffset, (catchTop - initCatchTop - 1), + rangePtr->codeOffset, (catchTop - initCatchTop - 1), (int) eePtr->stackPtr[catchTop], (unsigned int)(rangePtr->catchOffset)); } -#endif +#endif pc = (codePtr->codeStart + rangePtr->catchOffset); NEXT_INST_F(0, 0, 0); /* restart the execution loop at pc */ - - /* + + /* * end of infinite loop dispatching on instructions. */ - + /* - * Abnormal return code. Restore the stack to state it had when starting - * to execute the ByteCode. Panic if the stack is below the initial level. + * Abnormal return code. Restore the stack to state it had when + * starting to execute the ByteCode. Panic if the stack is below the + * initial level. */ - + abnormalReturn: { Tcl_Obj **initTosPtr = eePtr->stackPtr + initStackTop; while (tosPtr > initTosPtr) { - valuePtr = POP_OBJECT(); - TclDecrRefCount(valuePtr); + Tcl_Obj *objPtr = POP_OBJECT(); + TclDecrRefCount(objPtr); + } + + /* + * Clear all expansions. + */ + + while (expandNestList) { + Tcl_Obj *objPtr = expandNestList->internalRep.twoPtrValue.ptr2; + TclDecrRefCount(expandNestList); + expandNestList = objPtr; } if (tosPtr < initTosPtr) { fprintf(stderr, "\nTclExecuteByteCode: abnormal return at pc %u: stack top %d < entry stack top %d\n", (unsigned int)(pc - codePtr->codeStart), (unsigned int) (tosPtr - eePtr->stackPtr), @@ -4978,13 +6285,13 @@ /* *---------------------------------------------------------------------- * * PrintByteCodeInfo -- * - * This procedure prints a summary about a bytecode object to stdout. - * It is called by TclExecuteByteCode when starting to execute the - * bytecode object if tclTraceExec has the value 2 or more. + * This procedure prints a summary about a bytecode object to stdout. It + * is called by TclExecuteByteCode when starting to execute the bytecode + * object if tclTraceExec has the value 2 or more. * * Results: * None. * * Side effects: @@ -4993,34 +6300,34 @@ *---------------------------------------------------------------------- */ static void PrintByteCodeInfo(codePtr) - register ByteCode *codePtr; /* The bytecode whose summary is printed - * to stdout. */ + register ByteCode *codePtr; /* The bytecode whose summary is printed to + * stdout. */ { Proc *procPtr = codePtr->procPtr; Interp *iPtr = (Interp *) *codePtr->interpHandle; fprintf(stdout, "\nExecuting ByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n", (unsigned int) codePtr, codePtr->refCount, codePtr->compileEpoch, (unsigned int) iPtr, iPtr->compileEpoch); - + fprintf(stdout, " Source: "); TclPrintSource(stdout, codePtr->source, 60); fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", - codePtr->numCommands, codePtr->numSrcBytes, + codePtr->numCommands, codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, #ifdef TCL_COMPILE_STATS - (codePtr->numSrcBytes? - ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0)); -#else + codePtr->numSrcBytes? + ((float)codePtr->structureSize)/codePtr->numSrcBytes : +#endif 0.0); -#endif + #ifdef TCL_COMPILE_STATS fprintf(stdout, " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n", codePtr->structureSize, (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))), codePtr->numCodeBytes, @@ -5049,32 +6356,32 @@ * * Results: * None. * * Side effects: - * Prints a message to stderr and panics if either the pc or stack - * top are invalid. + * Prints a message to stderr and panics if either the pc or stack top + * are invalid. * *---------------------------------------------------------------------- */ #ifdef TCL_COMPILE_DEBUG static void ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, checkStack) - register ByteCode *codePtr; /* The bytecode whose summary is printed - * to stdout. */ + register ByteCode *codePtr; /* The bytecode whose summary is printed to + * stdout. */ unsigned char *pc; /* Points to first byte of a bytecode * instruction. The program counter. */ int stackTop; /* Current stack top. Must be between * stackLowerBound and stackUpperBound * (inclusive). */ int stackLowerBound; /* Smallest legal value for stackTop. */ - int checkStack; /* 0 if the stack depth check should be + int checkStack; /* 0 if the stack depth check should be * skipped. */ { - int stackUpperBound = stackLowerBound + codePtr->maxStackDepth; - /* Greatest legal value for stackTop. */ + int stackUpperBound = stackLowerBound + codePtr->maxStackDepth; + /* Greatest legal value for stackTop. */ unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart); unsigned int codeStart = (unsigned int) codePtr->codeStart; unsigned int codeEnd = (unsigned int) (codePtr->codeStart + codePtr->numCodeBytes); unsigned char opCode = *pc; @@ -5085,17 +6392,17 @@ Tcl_Panic("TclExecuteByteCode execution failure: bad pc"); } if ((unsigned int) opCode > LAST_INST_OPCODE) { fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n", (unsigned int) opCode, relativePc); - Tcl_Panic("TclExecuteByteCode execution failure: bad opcode"); + Tcl_Panic("TclExecuteByteCode execution failure: bad opcode"); } - if (checkStack && - ((stackTop < stackLowerBound) || (stackTop > stackUpperBound))) { + if (checkStack && + ((stackTop < stackLowerBound) || (stackTop > stackUpperBound))) { int numChars; char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars); - + fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode (min %i, max %i)", stackTop, relativePc, stackLowerBound, stackUpperBound); if (cmd != NULL) { Tcl_Obj *message = Tcl_NewStringObj("\n executing ", -1); Tcl_IncrRefCount(message); @@ -5113,14 +6420,13 @@ /* *---------------------------------------------------------------------- * * IllegalExprOperandType -- * - * Used by TclExecuteByteCode to append an error message to - * the interp result when an illegal operand type is detected by an - * expression instruction. The argument opndPtr holds the operand - * object in error. + * Used by TclExecuteByteCode to append an error message to the interp + * result when an illegal operand type is detected by an expression + * instruction. The argument opndPtr holds the operand object in error. * * Results: * None. * * Side effects: @@ -5136,120 +6442,42 @@ unsigned char *pc; /* Points to the instruction being executed * when the illegal type was found. */ 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); - } - } 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"; - } - } - makeErrorMessage: - Tcl_AppendResult(interp, "can't use ", msg, " as operand of \"", - operator, "\"", (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 { + description = "non-numeric string"; + } + } 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); } /* *---------------------------------------------------------------------- * @@ -5261,14 +6489,14 @@ * characters. * * Results: * If a command is found that encloses the program counter value, a * pointer to the command's source is returned and the length of the - * source is stored at *lengthPtr. If multiple commands resulted in - * code at pc, information about the closest enclosing command is - * returned. If no matching command is found, NULL is returned and - * *lengthPtr is unchanged. + * source is stored at *lengthPtr. If multiple commands resulted in code + * at pc, information about the closest enclosing command is returned. If + * no matching command is found, NULL is returned and *lengthPtr is + * unchanged. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -5276,17 +6504,17 @@ static char * GetSrcInfoForPc(pc, codePtr, lengthPtr) unsigned char *pc; /* The program counter value for which to * return the closest command's source info. - * This points to a bytecode instruction - * in codePtr's code. */ - ByteCode *codePtr; /* The bytecode sequence in which to look - * up the command source for the pc. */ - int *lengthPtr; /* If non-NULL, the location where the - * length of the command's source should be - * stored. If NULL, no length is stored. */ + * This points to a bytecode instruction in + * codePtr's code. */ + ByteCode *codePtr; /* The bytecode sequence in which to look up + * the command source for the pc. */ + int *lengthPtr; /* If non-NULL, the location where the length + * of the command's source should be stored. + * If NULL, no length is stored. */ { register int pcOffset = (pc - codePtr->codeStart); int numCmds = codePtr->numCommands; unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; @@ -5347,12 +6575,12 @@ srcLengthNext += 4; } else { srcLen = TclGetInt1AtPtr(srcLengthNext); srcLengthNext++; } - - if (codeOffset > pcOffset) { /* best cmd already found */ + + if (codeOffset > pcOffset) { /* best cmd already found */ break; } else if (pcOffset <= codeEnd) { /* this cmd's code encloses pc */ int dist = (pcOffset - codeOffset); if (dist <= bestDist) { bestDist = dist; @@ -5363,11 +6591,11 @@ } if (bestDist == INT_MAX) { return NULL; } - + if (lengthPtr != NULL) { *lengthPtr = bestSrcLength; } return (codePtr->source + bestSrcOffset); } @@ -5379,19 +6607,18 @@ * * Given a program counter value, return the closest enclosing * ExceptionRange. * * Results: - * In the normal case, catchOnly is 0 (false) and this procedure - * returns a pointer to the most closely enclosing ExceptionRange - * structure regardless of whether it is a loop or catch exception - * range. This is appropriate when processing a TCL_BREAK or - * TCL_CONTINUE, which will be "handled" either by a loop exception - * range or a closer catch range. If catchOnly is nonzero, this - * procedure ignores loop exception ranges and returns a pointer to the - * closest catch range. If no matching ExceptionRange is found that - * encloses pc, a NULL is returned. + * In the normal case, catchOnly is 0 (false) and this procedure returns + * a pointer to the most closely enclosing ExceptionRange structure + * regardless of whether it is a loop or catch exception range. This is + * appropriate when processing a TCL_BREAK or TCL_CONTINUE, which will be + * "handled" either by a loop exception range or a closer catch range. If + * catchOnly is nonzero, this procedure ignores loop exception ranges and + * returns a pointer to the closest catch range. If no matching + * ExceptionRange is found that encloses pc, a NULL is returned. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -5403,12 +6630,12 @@ * search for a closest enclosing exception * range. This points to a bytecode * instruction in codePtr's code. */ int catchOnly; /* If 0, consider either loop or catch * ExceptionRanges in search. If nonzero - * consider only catch ranges (and ignore - * any closer loop ranges). */ + * consider only catch ranges (and ignore any + * closer loop ranges). */ ByteCode* codePtr; /* Points to the ByteCode in which to search * for the enclosing ExceptionRange. */ { ExceptionRange *rangeArrayPtr; int numRanges = codePtr->numExceptRanges; @@ -5418,23 +6645,22 @@ if (numRanges == 0) { return NULL; } - /* - * This exploits peculiarities of our compiler: nested ranges - * are always *after* their containing ranges, so that by scanning - * backwards we are sure that the first matching range is indeed - * the deepest. + /* + * This exploits peculiarities of our compiler: nested ranges are always + * *after* their containing ranges, so that by scanning backwards we are + * sure that the first matching range is indeed the deepest. */ rangeArrayPtr = codePtr->exceptArrayPtr; rangePtr = rangeArrayPtr + numRanges; while (--rangePtr >= rangeArrayPtr) { start = rangePtr->codeOffset; if ((start <= pcOffset) && - (pcOffset < (start + rangePtr->numCodeBytes))) { + (pcOffset < (start + rangePtr->numCodeBytes))) { if ((!catchOnly) || (rangePtr->type == CATCH_EXCEPTION_RANGE)) { return rangePtr; } } @@ -5445,13 +6671,13 @@ /* *---------------------------------------------------------------------- * * GetOpcodeName -- * - * This procedure is called by the TRACE and TRACE_WITH_OBJ macros - * used in TclExecuteByteCode when debugging. It returns the name of - * the bytecode instruction at a specified instruction pc. + * This procedure is called by the TRACE and TRACE_WITH_OBJ macros used + * in TclExecuteByteCode when debugging. It returns the name of the + * bytecode instruction at a specified instruction pc. * * Results: * A character string for the instruction. * * Side effects: @@ -5461,780 +6687,27 @@ */ #ifdef TCL_COMPILE_DEBUG static char * GetOpcodeName(pc) - unsigned char *pc; /* Points to the instruction whose name - * should be returned. */ + unsigned char *pc; /* Points to the instruction whose name should + * be returned. */ { unsigned char opCode = *pc; - + return tclInstructionTable[opCode].name; } #endif /* TCL_COMPILE_DEBUG */ -/* - *---------------------------------------------------------------------- - * - * VerifyExprObjType -- - * - * This procedure is called by the math functions to verify that - * the object is either an int or double, coercing it if necessary. - * If an error occurs during conversion, an error message is left - * in the interpreter's result unless "interp" is NULL. - * - * Results: - * TCL_OK if it was int or double, TCL_ERROR otherwise - * - * Side effects: - * objPtr is ensured to be of tclIntType, tclWideIntType or - * tclDoubleType. - * - *---------------------------------------------------------------------- - */ - -static int -VerifyExprObjType(interp, objPtr) - Tcl_Interp *interp; /* The interpreter in which to execute the - * function. */ - Tcl_Obj *objPtr; /* Points to the object to type check. */ -{ - if (IS_NUMERIC_TYPE(objPtr->typePtr)) { - return TCL_OK; - } else { - int length, result = TCL_OK; - char *s = Tcl_GetStringFromObj(objPtr, &length); - - if (TclLooksLikeInt(s, length)) { - long i; /* Set but never used, needed in GET_WIDE_OR_INT */ - Tcl_WideInt w; - GET_WIDE_OR_INT(result, objPtr, i, w); - } else { - double d; - result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, objPtr, &d); - } - if ((result != TCL_OK) && (interp != NULL)) { - if (TclCheckBadOctal((Tcl_Interp *) NULL, s)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "argument to math function was an invalid octal number", - -1)); - } else { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "argument to math function didn't have numeric value", - -1)); - } - } - return result; - } -} - -/* - *---------------------------------------------------------------------- - * - * Math Functions -- - * - * This page contains the procedures that implement all of the - * built-in math functions for expressions. - * - * Results: - * Each procedure returns TCL_OK if it succeeds and pushes an - * Tcl object holding the result. If it fails it returns TCL_ERROR - * and leaves an error message in the interpreter's result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -ExprUnaryFunc(interp, tosPtr, clientData) - Tcl_Interp *interp; /* The interpreter in which to execute the - * function. */ - Tcl_Obj **tosPtr; /* Points to top of evaluation stack. */ - ClientData clientData; /* Contains the address of a procedure that - * takes one double argument and returns a - * double result. */ -{ - register Tcl_Obj *valuePtr; - double d, dResult; - - double (*func) _ANSI_ARGS_((double)) = - (double (*)_ANSI_ARGS_((double))) clientData; - - /* - * Pop the function's argument from the evaluation stack. Convert it - * to a double if necessary. - */ - - valuePtr = POP_OBJECT(); - - if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { - return TCL_ERROR; - } - - GET_DOUBLE_VALUE(d, valuePtr, valuePtr->typePtr); - - errno = 0; - dResult = (*func)(d); - if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) { - TclExprFloatError(interp, dResult); - return TCL_ERROR; - } - - /* - * Push a Tcl object holding the result. - */ - - PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); - TclDecrRefCount(valuePtr); - return TCL_OK; -} - -static int -ExprBinaryFunc(interp, tosPtr, clientData) - Tcl_Interp *interp; /* The interpreter in which to execute the - * function. */ - Tcl_Obj **tosPtr; /* Points to top of evaluation stack. */ - ClientData clientData; /* Contains the address of a procedure that - * takes two double arguments and - * returns a double result. */ -{ - register Tcl_Obj *valuePtr, *value2Ptr; - double d1, d2, dResult; - - double (*func) _ANSI_ARGS_((double, double)) - = (double (*)_ANSI_ARGS_((double, double))) clientData; - - /* - * Pop the function's two arguments from the evaluation stack. Convert - * them to doubles if necessary. - */ - - value2Ptr = POP_OBJECT(); - valuePtr = POP_OBJECT(); - - if ((VerifyExprObjType(interp, valuePtr) != TCL_OK) || - (VerifyExprObjType(interp, value2Ptr) != TCL_OK)) { - return TCL_ERROR; - } - - GET_DOUBLE_VALUE(d1, valuePtr, valuePtr->typePtr); - GET_DOUBLE_VALUE(d2, value2Ptr, value2Ptr->typePtr); - - errno = 0; - dResult = (*func)(d1, d2); - if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) { - TclExprFloatError(interp, dResult); - return TCL_ERROR; - } - - /* - * Push a Tcl object holding the result. - */ - - PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); - TclDecrRefCount(valuePtr); - TclDecrRefCount(value2Ptr); - return TCL_OK; -} - -static int -ExprAbsFunc(interp, tosPtr, clientData) - Tcl_Interp *interp; /* The interpreter in which to execute the - * function. */ - Tcl_Obj **tosPtr; /* Points to top of evaluation stack. */ - ClientData clientData; /* Ignored. */ -{ - register Tcl_Obj *valuePtr; - long i, iResult; - double d, dResult; - - /* - * Pop the argument from the evaluation stack. - */ - - valuePtr = POP_OBJECT(); - - if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Push a Tcl object with the result. - */ - if (valuePtr->typePtr == &tclIntType) { - i = valuePtr->internalRep.longValue; - if (i < 0) { - iResult = -i; - if (iResult < 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent", -1)); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - "integer value too large to represent", (char *) NULL); - return TCL_ERROR; - } - } else { - iResult = i; - } - PUSH_OBJECT(Tcl_NewLongObj(iResult)); - } else if (valuePtr->typePtr == &tclWideIntType) { - Tcl_WideInt wResult, w; - TclGetWide(w,valuePtr); - if (w < W0) { - wResult = -w; - if (wResult < 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent", -1)); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - "integer value too large to represent", (char *) NULL); - return TCL_ERROR; - } - } else { - wResult = w; - } - PUSH_OBJECT(Tcl_NewWideIntObj(wResult)); - } else { - d = valuePtr->internalRep.doubleValue; - if (d < 0.0) { - dResult = -d; - } else { - dResult = d; - } - if (IS_NAN(dResult) || IS_INF(dResult)) { - TclExprFloatError(interp, dResult); - return TCL_ERROR; - } - PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); - } - - TclDecrRefCount(valuePtr); - return TCL_OK; -} - -static int -ExprDoubleFunc(interp, tosPtr, clientData) - Tcl_Interp *interp; /* The interpreter in which to execute the - * function. */ - Tcl_Obj **tosPtr; /* Points to top of evaluation stack. */ - ClientData clientData; /* Ignored. */ -{ - register Tcl_Obj *valuePtr; - double dResult; - - /* - * Pop the argument from the evaluation stack. - */ - - valuePtr = POP_OBJECT(); - - if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { - return TCL_ERROR; - } - - GET_DOUBLE_VALUE(dResult, valuePtr, valuePtr->typePtr); - - /* - * Push a Tcl object with the result. - */ - - PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); - - TclDecrRefCount(valuePtr); - return TCL_OK; -} - -static int -ExprIntFunc(interp, tosPtr, clientData) - Tcl_Interp *interp; /* The interpreter in which to execute the - * function. */ - Tcl_Obj **tosPtr; /* Points to top of evaluation stack. */ - ClientData clientData; /* Ignored. */ -{ - register Tcl_Obj *valuePtr; - long iResult; - double d; - - /* - * Pop the argument from the evaluation stack. - */ - - valuePtr = POP_OBJECT(); - - if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { - return TCL_ERROR; - } - - if (valuePtr->typePtr == &tclIntType) { - iResult = valuePtr->internalRep.longValue; - } else if (valuePtr->typePtr == &tclWideIntType) { - TclGetLongFromWide(iResult,valuePtr); - } else { - d = valuePtr->internalRep.doubleValue; - if (d < 0.0) { - if (d < (double) (long) LONG_MIN) { - tooLarge: - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent", -1)); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - "integer value too large to represent", (char *) NULL); - return TCL_ERROR; - } - } else { - if (d > (double) LONG_MAX) { - goto tooLarge; - } - } - if (IS_NAN(d) || IS_INF(d)) { - TclExprFloatError(interp, d); - return TCL_ERROR; - } - iResult = (long) d; - } - - /* - * Push a Tcl object with the result. - */ - - PUSH_OBJECT(Tcl_NewLongObj(iResult)); - TclDecrRefCount(valuePtr); - return TCL_OK; -} - -static int -ExprWideFunc(interp, tosPtr, clientData) - Tcl_Interp *interp; /* The interpreter in which to execute the - * function. */ - Tcl_Obj **tosPtr; /* Points to top of evaluation stack. */ - ClientData clientData; /* Ignored. */ -{ - register Tcl_Obj *valuePtr; - Tcl_WideInt wResult; - double d; - - /* - * Pop the argument from the evaluation stack. - */ - - valuePtr = POP_OBJECT(); - - if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { - return TCL_ERROR; - } - - if (valuePtr->typePtr == &tclWideIntType) { - TclGetWide(wResult,valuePtr); - } else if (valuePtr->typePtr == &tclIntType) { - wResult = Tcl_LongAsWide(valuePtr->internalRep.longValue); - } else { - d = valuePtr->internalRep.doubleValue; - if (d < 0.0) { - if (d < Tcl_WideAsDouble(LLONG_MIN)) { - tooLarge: - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent", -1)); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - "integer value too large to represent", (char *) NULL); - return TCL_ERROR; - } - } else { - if (d > Tcl_WideAsDouble(LLONG_MAX)) { - goto tooLarge; - } - } - if (IS_NAN(d) || IS_INF(d)) { - TclExprFloatError(interp, d); - return TCL_ERROR; - } - wResult = Tcl_DoubleAsWide(d); - } - - /* - * Push a Tcl object with the result. - */ - - PUSH_OBJECT(Tcl_NewWideIntObj(wResult)); - TclDecrRefCount(valuePtr); - return TCL_OK; -} - -static int -ExprRandFunc(interp, tosPtr, clientData) - Tcl_Interp *interp; /* The interpreter in which to execute the - * function. */ - Tcl_Obj **tosPtr; /* Points to top of evaluation stack. */ - ClientData clientData; /* Ignored. */ -{ - Interp *iPtr = (Interp *) interp; - double dResult; - long tmp; /* Algorithm assumes at least 32 bits. - * Only long guarantees that. See below. */ - - if (!(iPtr->flags & RAND_SEED_INITIALIZED)) { - iPtr->flags |= RAND_SEED_INITIALIZED; - - /* - * Take into consideration the thread this interp is running in order - * to insure different seeds in different threads (bug #416643) - */ - - iPtr->randSeed = TclpGetClicks() + ((long)Tcl_GetCurrentThread()<<12); - - /* - * Make sure 1 <= randSeed <= (2^31) - 2. See below. - */ - - iPtr->randSeed &= (unsigned long) 0x7fffffff; - if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { - iPtr->randSeed ^= 123459876; - } - } - - /* - * Generate the random number using the linear congruential - * generator defined by the following recurrence: - * seed = ( IA * seed ) mod IM - * where IA is 16807 and IM is (2^31) - 1. The recurrence maps - * a seed in the range [1, IM - 1] to a new seed in that same range. - * The recurrence maps IM to 0, and maps 0 back to 0, so those two - * values must not be allowed as initial values of seed. - * - * In order to avoid potential problems with integer overflow, the - * recurrence is implemented in terms of additional constants - * IQ and IR such that - * IM = IA*IQ + IR - * None of the operations in the implementation overflows a 32-bit - * signed integer, and the C type long is guaranteed to be at least - * 32 bits wide. - * - * For more details on how this algorithm works, refer to the following - * papers: - * - * S.K. Park & K.W. Miller, "Random number generators: good ones - * are hard to find," Comm ACM 31(10):1192-1201, Oct 1988 - * - * W.H. Press & S.A. Teukolsky, "Portable random number - * generators," Computers in Physics 6(5):522-524, Sep/Oct 1992. - */ - -#define RAND_IA 16807 -#define RAND_IM 2147483647 -#define RAND_IQ 127773 -#define RAND_IR 2836 -#define RAND_MASK 123459876 - - tmp = iPtr->randSeed/RAND_IQ; - iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp; - if (iPtr->randSeed < 0) { - iPtr->randSeed += RAND_IM; - } - - /* - * Since the recurrence keeps seed values in the range [1, RAND_IM - 1], - * dividing by RAND_IM yields a double in the range (0, 1). - */ - - dResult = iPtr->randSeed * (1.0/RAND_IM); - - /* - * Push a Tcl object with the result. - */ - - PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); - return TCL_OK; -} - -static int -ExprRoundFunc(interp, tosPtr, clientData) - Tcl_Interp *interp; /* The interpreter in which to execute the - * function. */ - Tcl_Obj **tosPtr; /* Points to top of evaluation stack. */ - ClientData clientData; /* Ignored. */ -{ - Tcl_Obj *valuePtr, *resPtr; - double d; - - /* - * Pop the argument from the evaluation stack. - */ - - valuePtr = POP_OBJECT(); - - if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { - return TCL_ERROR; - } - - if ((valuePtr->typePtr == &tclIntType) || - (valuePtr->typePtr == &tclWideIntType)) { - return TCL_OK; - } - - d = valuePtr->internalRep.doubleValue; - if (d < 0.0) { - if (d <= Tcl_WideAsDouble(LLONG_MIN)-0.5) { - goto tooLarge; - } else if (d <= (((double) (long) LONG_MIN) - 0.5)) { - resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(d - 0.5)); - } else { - resPtr = Tcl_NewLongObj((long) (d - 0.5)); - } - } else { - if (d >= Tcl_WideAsDouble(LLONG_MAX)+0.5) { - goto tooLarge; - } else if (d >= (((double) LONG_MAX + 0.5))) { - resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(d + 0.5)); - } else { - resPtr = Tcl_NewLongObj((long) (d + 0.5)); - } - } - - /* - * Free the argument Tcl_Obj and push the result object. - */ - - TclDecrRefCount(valuePtr); - PUSH_OBJECT(resPtr); - return TCL_OK; - - /* - * Error return: result cannot be represented as an integer. - */ - - tooLarge: - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent", -1)); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - "integer value too large to represent", - (char *) NULL); - return TCL_ERROR; -} - -static int -ExprSrandFunc(interp, tosPtr, clientData) - Tcl_Interp *interp; /* The interpreter in which to execute the - * function. */ - Tcl_Obj **tosPtr; /* Points to top of evaluation stack. */ - ClientData clientData; /* Ignored. */ -{ - Interp *iPtr = (Interp *) interp; - Tcl_Obj *valuePtr; - long i = 0; /* Initialized to avoid compiler warning. */ - - /* - * Pop the argument from the evaluation stack. Use the value - * to reset the random number seed. - */ - - valuePtr = POP_OBJECT(); - - if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { - return TCL_ERROR; - } - - if (valuePtr->typePtr == &tclIntType) { - i = valuePtr->internalRep.longValue; - } else if (valuePtr->typePtr == &tclWideIntType) { - TclGetLongFromWide(i,valuePtr); - } else { - /* - * At this point, the only other possible type is double - */ - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't use floating-point value as argument to srand", -1)); - return TCL_ERROR; - } - - /* - * Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2. - * See comments in ExprRandFunc() for more details. - */ - - iPtr->flags |= RAND_SEED_INITIALIZED; - iPtr->randSeed = i; - iPtr->randSeed &= (unsigned long) 0x7fffffff; - if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { - iPtr->randSeed ^= 123459876; - } - - /* - * To avoid duplicating the random number generation code we simply - * clean up our state and call the real random number function. That - * function will always succeed. - */ - - TclDecrRefCount(valuePtr); - ExprRandFunc(interp, tosPtr, clientData); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ExprCallMathFunc -- - * - * This procedure is invoked to call a non-builtin math function - * during the execution of an expression. - * - * Results: - * TCL_OK is returned if all went well and the function's value - * was computed successfully. If an error occurred, TCL_ERROR - * is returned and an error message is left in the interpreter's - * result. After a successful return this procedure pops its - * objc arguments and pushes a Tcl object holding the result. - * - * Side effects: - * None, unless the called math function has side effects. - * - *---------------------------------------------------------------------- - */ - -static int -ExprCallMathFunc(interp, objc, objv) - Tcl_Interp *interp; /* The interpreter in which to execute the - * function. */ - int objc; /* Number of arguments. The function name is - * the 0-th argument. */ - Tcl_Obj **objv; /* The array of arguments. The function name - * is objv[0]. */ -{ - Interp *iPtr = (Interp *) interp; - char *funcName; - Tcl_HashEntry *hPtr; - MathFunc *mathFuncPtr; /* Information about math function. */ - Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */ - Tcl_Value funcResult; /* Result of function call as Tcl_Value. */ - register Tcl_Obj *valuePtr; - long i; - double d; - int j, k, result; - - Tcl_ResetResult(interp); - - /* - * Look up the MathFunc record for the function. - */ - - funcName = TclGetString(objv[0]); - hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName); - if (hPtr == NULL) { - Tcl_AppendResult(interp, "unknown math function \"", funcName, - "\"", (char *) NULL); - return TCL_ERROR; - } - mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - if (mathFuncPtr->numArgs != (objc-1)) { - Tcl_Panic("ExprCallMathFunc: expected number of args %d != actual number %d", - mathFuncPtr->numArgs, objc); - return TCL_ERROR; - } - - /* - * Collect the arguments for the function, if there are any, into the - * array "args". Note that args[0] will have the Tcl_Value that - * corresponds to objv[1]. - */ - - for (j = 1, k = 0; j < objc; j++, k++) { - valuePtr = objv[j]; - - if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Copy the object's numeric value to the argument record, - * converting it if necessary. - */ - - if (valuePtr->typePtr == &tclIntType) { - i = valuePtr->internalRep.longValue; - if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) { - args[k].type = TCL_DOUBLE; - args[k].doubleValue = i; - } else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) { - args[k].type = TCL_WIDE_INT; - args[k].wideValue = Tcl_LongAsWide(i); - } else { - args[k].type = TCL_INT; - args[k].intValue = i; - } - } else if (valuePtr->typePtr == &tclWideIntType) { - Tcl_WideInt w; - TclGetWide(w,valuePtr); - if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) { - args[k].type = TCL_DOUBLE; - args[k].doubleValue = Tcl_WideAsDouble(w); - } else if (mathFuncPtr->argTypes[k] == TCL_INT) { - args[k].type = TCL_INT; - args[k].intValue = Tcl_WideAsLong(w); - } else { - args[k].type = TCL_WIDE_INT; - args[k].wideValue = w; - } - } else { - d = valuePtr->internalRep.doubleValue; - if (mathFuncPtr->argTypes[k] == TCL_INT) { - args[k].type = TCL_INT; - args[k].intValue = (long) d; - } else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) { - args[k].type = TCL_WIDE_INT; - args[k].wideValue = Tcl_DoubleAsWide(d); - } else { - args[k].type = TCL_DOUBLE; - args[k].doubleValue = d; - } - } - } - - /* - * Invoke the function and copy its result back into valuePtr. - */ - - result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args, - &funcResult); - if (result != TCL_OK) { - return result; - } - - /* - * Pop the objc top stack elements and decrement their ref counts. - */ - - for (k = 0; k < objc; k++) { - valuePtr = objv[k]; - TclDecrRefCount(valuePtr); - } - - /* - * Push the call's object result. - */ - - if (funcResult.type == TCL_INT) { - objv[0] = Tcl_NewLongObj(funcResult.intValue); - } else if (funcResult.type == TCL_WIDE_INT) { - objv[0] = Tcl_NewWideIntObj(funcResult.wideValue); - } else { - d = funcResult.doubleValue; - if (IS_NAN(d) || IS_INF(d)) { - TclExprFloatError(interp, d); - return TCL_ERROR; - } - objv[0] = Tcl_NewDoubleObj(d); - } - Tcl_IncrRefCount(objv[0]); - - return result; -} - + /* *---------------------------------------------------------------------- * * TclExprFloatError -- * - * This procedure is called when an error occurs during a - * floating-point operation. It reads errno and sets - * interp->objResultPtr accordingly. + * This procedure is called when an error occurs during a floating-point + * operation. It reads errno and sets interp->objResultPtr accordingly. * * Results: * interp->objResultPtr is set to hold an error message. * * Side effects: @@ -6244,20 +6717,20 @@ */ void TclExprFloatError(interp, value) Tcl_Interp *interp; /* Where to store error message. */ - double value; /* Value returned after error; used to + double value; /* Value returned after error; used to * distinguish underflows from overflows. */ { 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)); Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL); } else { @@ -6264,15 +6737,16 @@ s = "floating-point value too large to represent"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL); } } else { - char msg[64 + TCL_INTEGER_SPACE]; - - sprintf(msg, "unknown floating-point error, errno = %d", errno); - Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1)); - Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", msg, (char *) NULL); + Tcl_Obj *objPtr = Tcl_NewObj(); + TclObjPrintf(NULL, objPtr, + "unknown floating-point error, errno = %d", errno); + Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", + Tcl_GetString(objPtr), (char *) NULL); + Tcl_SetObjResult(interp, objPtr); } } #ifdef TCL_COMPILE_STATS /* @@ -6282,23 +6756,23 @@ * * Procedure used while collecting compilation statistics to determine * the log base 2 of an integer. * * Results: - * Returns the log base 2 of the operand. If the argument is less - * than or equal to zero, a zero is returned. + * Returns the log base 2 of the operand. If the argument is less than or + * equal to zero, a zero is returned. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclLog2(value) - register int value; /* The integer for which to compute the - * log base 2. */ + register int value; /* The integer for which to compute the log + * base 2. */ { register int n = value; register int result = 0; while (n > 1) { @@ -6347,13 +6821,13 @@ char *litTableStats; LiteralEntry *entryPtr; numInstructions = 0.0; for (i = 0; i < 256; i++) { - if (statsPtr->instructionCount[i] != 0) { - numInstructions += statsPtr->instructionCount[i]; - } + if (statsPtr->instructionCount[i] != 0) { + numInstructions += statsPtr->instructionCount[i]; + } } totalLiteralBytes = sizeof(LiteralTable) + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *) + (statsPtr->numLiteralsCreated * sizeof(LiteralEntry)) @@ -6370,11 +6844,11 @@ + (iPtr->literalTable.numEntries * sizeof(LiteralEntry)); currentLiteralBytes = literalMgmtBytes + iPtr->literalTable.numEntries * sizeof(Tcl_Obj) + statsPtr->currentLitStringBytes; currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes; - + /* * Summary statistics, total and current source and ByteCode sizes. */ fprintf(stdout, "\n----------------------------------------------------------------\n"); @@ -6386,11 +6860,11 @@ statsPtr->numExecutions); fprintf(stdout, "Number ByteCodes compiled %ld\n", statsPtr->numCompilations); fprintf(stdout, " Mean executions/compile %.1f\n", ((float)statsPtr->numExecutions) / ((float)statsPtr->numCompilations)); - + fprintf(stdout, "\nInstructions executed %.0f\n", numInstructions); fprintf(stdout, " Mean inst/compile %.0f\n", numInstructions / statsPtr->numCompilations); fprintf(stdout, " Mean inst/execution %.0f\n", @@ -6440,13 +6914,12 @@ (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0); /* * Tcl_IsShared statistics check * - * This gives the refcount of each obj as Tcl_IsShared was called - * for it. Shared objects must be duplicated before they can be - * modified. + * This gives the refcount of each obj as Tcl_IsShared was called for it. + * Shared objects must be duplicated before they can be modified. */ numSharedMultX = 0; fprintf(stdout, "\nTcl_IsShared object check (all objects):\n"); fprintf(stdout, " Object had refcount <=1 (not shared) %ld\n", @@ -6474,11 +6947,11 @@ strBytesIfUnshared = 0.0; strBytesSharedMultX = 0.0; strBytesSharedOnce = 0.0; for (i = 0; i < globalTablePtr->numBuckets; i++) { for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL; - entryPtr = entryPtr->nextPtr) { + entryPtr = entryPtr->nextPtr) { if (entryPtr->objPtr->typePtr == &tclByteCodeType) { numByteCodeLits++; } (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length); refCountSum += entryPtr->refCount; @@ -6543,11 +7016,11 @@ iPtr->literalTable.numEntries * sizeof(LiteralEntry)); /* * Breakdown of current ByteCode space requirements. */ - + fprintf(stdout, "\nBreakdown of current ByteCode requirements:\n"); fprintf(stdout, " Bytes Pct of Avg per\n"); fprintf(stdout, " total ByteCode\n"); fprintf(stdout, "Total %12.6g 100.00%% %8.1f\n", statsPtr->currentByteCodeBytes, @@ -6578,31 +7051,31 @@ statsPtr->currentCmdMapBytes / numCurrentByteCodes); /* * Detailed literal statistics. */ - + fprintf(stdout, "\nLiteral string sizes:\n"); fprintf(stdout, " Up to length Percentage\n"); maxSizeDecade = 0; for (i = 31; i >= 0; i--) { - if (statsPtr->literalCount[i] > 0) { - maxSizeDecade = i; + if (statsPtr->literalCount[i] > 0) { + maxSizeDecade = i; break; - } + } } sum = 0; for (i = 0; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->literalCount[i]; - fprintf(stdout, " %10d %8.0f%%\n", + fprintf(stdout, " %10d %8.0f%%\n", decadeHigh, (sum * 100.0) / statsPtr->numLiteralsCreated); } litTableStats = TclLiteralStats(globalTablePtr); fprintf(stdout, "\nCurrent literal table statistics:\n%s\n", - litTableStats); + litTableStats); ckfree((char *) litTableStats); /* * Source and ByteCode size distributions. */ @@ -6609,72 +7082,72 @@ fprintf(stdout, "\nSource sizes:\n"); fprintf(stdout, " Up to size Percentage\n"); minSizeDecade = maxSizeDecade = 0; for (i = 0; i < 31; i++) { - if (statsPtr->srcCount[i] > 0) { + if (statsPtr->srcCount[i] > 0) { minSizeDecade = i; break; - } + } } for (i = 31; i >= 0; i--) { - if (statsPtr->srcCount[i] > 0) { - maxSizeDecade = i; + if (statsPtr->srcCount[i] > 0) { + maxSizeDecade = i; break; - } + } } sum = 0; for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->srcCount[i]; - fprintf(stdout, " %10d %8.0f%%\n", + fprintf(stdout, " %10d %8.0f%%\n", decadeHigh, (sum * 100.0) / statsPtr->numCompilations); } fprintf(stdout, "\nByteCode sizes:\n"); fprintf(stdout, " Up to size Percentage\n"); minSizeDecade = maxSizeDecade = 0; for (i = 0; i < 31; i++) { - if (statsPtr->byteCodeCount[i] > 0) { + if (statsPtr->byteCodeCount[i] > 0) { minSizeDecade = i; break; - } + } } for (i = 31; i >= 0; i--) { - if (statsPtr->byteCodeCount[i] > 0) { - maxSizeDecade = i; + if (statsPtr->byteCodeCount[i] > 0) { + maxSizeDecade = i; break; - } + } } sum = 0; for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->byteCodeCount[i]; - fprintf(stdout, " %10d %8.0f%%\n", + fprintf(stdout, " %10d %8.0f%%\n", decadeHigh, (sum * 100.0) / statsPtr->numCompilations); } fprintf(stdout, "\nByteCode longevity (excludes Current ByteCodes):\n"); fprintf(stdout, " Up to ms Percentage\n"); minSizeDecade = maxSizeDecade = 0; for (i = 0; i < 31; i++) { - if (statsPtr->lifetimeCount[i] > 0) { + if (statsPtr->lifetimeCount[i] > 0) { minSizeDecade = i; break; - } + } } for (i = 31; i >= 0; i--) { - if (statsPtr->lifetimeCount[i] > 0) { - maxSizeDecade = i; + if (statsPtr->lifetimeCount[i] > 0) { + maxSizeDecade = i; break; - } + } } sum = 0; for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->lifetimeCount[i]; - fprintf(stdout, " %12.3f %8.0f%%\n", + fprintf(stdout, " %12.3f %8.0f%%\n", decadeHigh / 1000.0, (sum * 100.0) / statsPtr->numByteCodesFreed); } /* @@ -6681,23 +7154,23 @@ * Instruction counts. */ fprintf(stdout, "\nInstruction counts:\n"); for (i = 0; i <= LAST_INST_OPCODE; i++) { - if (statsPtr->instructionCount[i]) { - fprintf(stdout, "%20s %8ld %6.1f%%\n", + if (statsPtr->instructionCount[i]) { + fprintf(stdout, "%20s %8ld %6.1f%%\n", tclInstructionTable[i].name, statsPtr->instructionCount[i], (statsPtr->instructionCount[i]*100.0) / numInstructions); - } + } } fprintf(stdout, "\nInstructions NEVER executed:\n"); for (i = 0; i <= LAST_INST_OPCODE; i++) { - if (statsPtr->instructionCount[i] == 0) { - fprintf(stdout, "%20s\n", tclInstructionTable[i].name); - } + if (statsPtr->instructionCount[i] == 0) { + fprintf(stdout, "%20s\n", tclInstructionTable[i].name); + } } #ifdef TCL_MEM_DEBUG fprintf(stdout, "\nHeap Statistics:\n"); TclDumpMemoryInfo(stdout); @@ -6711,52 +7184,52 @@ /* *---------------------------------------------------------------------- * * StringForResultCode -- * - * Procedure that returns a human-readable string representing a - * Tcl result code such as TCL_ERROR. + * Procedure that returns a human-readable string representing a Tcl + * result code such as TCL_ERROR. * * Results: - * If the result code is one of the standard Tcl return codes, the - * result is a string representing that code such as "TCL_ERROR". - * Otherwise, the result string is that code formatted as a - * sequence of decimal digit characters. Note that the resulting - * string must not be modified by the caller. + * If the result code is one of the standard Tcl return codes, the result + * is a string representing that code such as "TCL_ERROR". Otherwise, + * the result string is that code formatted as a sequence of decimal + * digit characters. Note that the resulting string must not be modified + * by the caller. * * Side effects: * None. * *---------------------------------------------------------------------- */ static char * StringForResultCode(result) - int result; /* The Tcl result code for which to - * generate a string. */ + int result; /* The Tcl result code for which to generate a + * string. */ { static char buf[TCL_INTEGER_SPACE]; - + if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) { return resultStrings[result]; } TclFormatInt(buf, result); return buf; } #endif /* TCL_COMPILE_DEBUG */ +#if 0 /* *---------------------------------------------------------------------- * * ExponWide -- * * Procedure to return w**w2 as wide integer * * Results: - * Return value is w to the power w2, unless the computation - * makes no sense mathematically. In that case *errExpon is - * set to 1. + * Return value is w to the power w2, unless the computation makes no + * sense mathematically. In that case *errExpon is set to 1. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -6790,18 +7263,18 @@ } else if (w2 == 0) { return Tcl_LongAsWide(1); } } else if (w == -1) { return (w2 & 1) ? Tcl_LongAsWide(-1) : Tcl_LongAsWide(1); - } else if (w == 1) { + } else if ((w == 1) || (w2 == 0)) { return Tcl_LongAsWide(1); } else if (w>1 && w2<0) { return W0; } /* - * The general case. + * The general case. */ result = Tcl_LongAsWide(1); for (; w2>Tcl_LongAsWide(1) ; w*=w,w2/=2) { if (w2 & 1) { @@ -6814,19 +7287,18 @@ /* *---------------------------------------------------------------------- * * ExponLong -- * - * Procedure to return i**i2 as long integer + * Procedure to return i**i2 as long integer * * Results: - * Return value is i to the power i2, unless the computation - * makes no sense mathematically. In that case *errExpon is - * set to 1. + * Return value is i to the power i2, unless the computation makes no + * sense mathematically. In that case *errExpon is set to 1. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ static long @@ -6842,32 +7314,32 @@ /* * Check for possible errors and simple cases */ if (i == 0) { - if (i2 < 0) { - *errExpon = 1; - return 0L; - } else if (i2 > 0) { - return 0L; - } + if (i2 < 0) { + *errExpon = 1; + return 0L; + } else if (i2 > 0) { + return 0L; + } /* * By definition and analysis, 0**0 is 1. */ return 1L; } else if (i < -1) { - if (i2 < 0) { - return 0L; - } else if (i2 == 0) { + if (i2 < 0) { + return 0L; + } else if (i2 == 0) { return 1L; - } + } } else if (i == -1) { - return (i2&1) ? -1L : 1L; - } else if (i == 1) { - return 1L; + return (i2&1) ? -1L : 1L; + } else if ((i == 1) || (i2 == 0)) { + return 1L; } else if (i > 1 && i2 < 0) { - return 0L; + return 0L; } /* * The general case */ @@ -6878,5 +7350,6 @@ result *= i; } } return result * i; } +#endif Index: generic/tclFCmd.c ================================================================== --- generic/tclFCmd.c +++ generic/tclFCmd.c @@ -1,27 +1,27 @@ /* * tclFCmd.c * - * This file implements the generic portion of file manipulation - * subcommands of the "file" command. + * This file implements the generic portion of file manipulation + * subcommands of the "file" command. * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclFCmd.c,v 1.29 2004/10/19 21:54:07 dgp Exp $ + * RCS: @(#) $Id: tclFCmd.c,v 1.29.2.3 2005/08/02 18:15:27 dgp Exp $ */ #include "tclInt.h" /* - * Declarations for local procedures defined in this file: + * Declarations for local functions defined in this file: */ static int CopyRenameOneFile _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, + Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, int copyFlag, int force)); static Tcl_Obj * FileBasename _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr)); static int FileCopyRename _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int copyFlag)); @@ -31,14 +31,14 @@ /* *--------------------------------------------------------------------------- * * TclFileRenameCmd * - * This procedure implements the "rename" subcommand of the "file" - * command. Filename arguments need to be translated to native - * format before being passed to platform-specific code that - * implements rename functionality. + * This function implements the "rename" subcommand of the "file" + * command. Filename arguments need to be translated to native format + * before being passed to platform-specific code that implements rename + * functionality. * * Results: * A standard Tcl result. * * Side effects: @@ -59,14 +59,13 @@ /* *--------------------------------------------------------------------------- * * TclFileCopyCmd * - * This procedure implements the "copy" subcommand of the "file" - * command. Filename arguments need to be translated to native - * format before being passed to platform-specific code that - * implements copy functionality. + * This function implements the "copy" subcommand of the "file" command. + * Filename arguments need to be translated to native format before being + * passed to platform-specific code that implements copy functionality. * * Results: * A standard Tcl result. * * Side effects: @@ -87,12 +86,12 @@ /* *--------------------------------------------------------------------------- * * FileCopyRename -- * - * Performs the work of TclFileRenameCmd and TclFileCopyCmd. - * See comments for those procedures. + * Performs the work of TclFileRenameCmd and TclFileCopyCmd. See + * comments for those functions. * * Results: * See above. * * Side effects: @@ -104,26 +103,26 @@ static int FileCopyRename(interp, objc, objv, copyFlag) Tcl_Interp *interp; /* Used for error reporting. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ - int copyFlag; /* If non-zero, copy source(s). Otherwise, + int copyFlag; /* If non-zero, copy source(s). Otherwise, * rename them. */ { int i, result, force; - Tcl_StatBuf statBuf; + Tcl_StatBuf statBuf; Tcl_Obj *target; i = FileForceOption(interp, objc - 2, objv + 2, &force); if (i < 0) { return TCL_ERROR; } i += 2; if ((objc - i) < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - Tcl_GetString(objv[0]), " ", Tcl_GetString(objv[1]), - " ?options? source ?source ...? target\"", + Tcl_AppendResult(interp, "wrong # args: should be \"", + TclGetString(objv[0]), " ", TclGetString(objv[1]), + " ?options? source ?source ...? target\"", (char *) NULL); return TCL_ERROR; } /* @@ -149,36 +148,36 @@ if ((objc - i) > 2) { errno = ENOTDIR; Tcl_PosixError(interp); Tcl_AppendResult(interp, "error ", ((copyFlag) ? "copying" : "renaming"), ": target \"", - Tcl_GetString(target), "\" is not a directory", + TclGetString(target), "\" is not a directory", (char *) NULL); result = TCL_ERROR; } else { /* - * Even though already have target == translated(objv[i+1]), - * pass the original argument down, so if there's an error, the - * error message will reflect the original arguments. + * Even though already have target == translated(objv[i+1]), pass + * the original argument down, so if there's an error, the error + * message will reflect the original arguments. */ result = CopyRenameOneFile(interp, objv[i], objv[i + 1], copyFlag, force); } return result; } - + /* - * Move each source file into target directory. Extract the basename - * from each source, and append it to the end of the target path. + * Move each source file into target directory. Extract the basename from + * each source, and append it to the end of the target path. */ - for ( ; i < objc - 1; i++) { + for ( ; i 20) { - /* Too many links */ + /* + * Too many links. + */ + Tcl_SetErrno(EMLINK); errfile = source; goto done; } } @@ -635,37 +687,38 @@ if (S_ISDIR(sourceStatBuf.st_mode)) { result = Tcl_FSCopyDirectory(actualSource, target, &errorBuffer); if (result != TCL_OK) { if (errno == EXDEV) { - /* + /* * The copy failed because we're trying to do a - * cross-filesystem copy. We do this through our Tcl - * library. + * cross-filesystem copy. We do this through our Tcl library. */ + Tcl_Obj *copyCommand = Tcl_NewListObj(0,NULL); Tcl_IncrRefCount(copyCommand); - Tcl_ListObjAppendElement(interp, copyCommand, + Tcl_ListObjAppendElement(interp, copyCommand, Tcl_NewStringObj("::tcl::CopyDirectory",-1)); if (copyFlag) { - Tcl_ListObjAppendElement(interp, copyCommand, - Tcl_NewStringObj("copying",-1)); + Tcl_ListObjAppendElement(interp, copyCommand, + Tcl_NewStringObj("copying",-1)); } else { - Tcl_ListObjAppendElement(interp, copyCommand, - Tcl_NewStringObj("renaming",-1)); + Tcl_ListObjAppendElement(interp, copyCommand, + Tcl_NewStringObj("renaming",-1)); } Tcl_ListObjAppendElement(interp, copyCommand, source); Tcl_ListObjAppendElement(interp, copyCommand, target); - result = Tcl_EvalObjEx(interp, copyCommand, - TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + result = Tcl_EvalObjEx(interp, copyCommand, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); Tcl_DecrRefCount(copyCommand); if (result != TCL_OK) { - /* - * There was an error in the Tcl-level copy. - * We will pass on the Tcl error message and - * can ensure this by setting errfile to NULL + /* + * There was an error in the Tcl-level copy. We will pass + * on the Tcl error message and can ensure this by setting + * errfile to NULL */ + errfile = NULL; } } else { errfile = errorBuffer; if (Tcl_FSEqualPaths(errfile, source)) { @@ -679,23 +732,26 @@ result = Tcl_FSCopyFile(actualSource, target); if ((result != TCL_OK) && (errno == EXDEV)) { result = TclCrossFilesystemCopy(interp, source, target); } if (result != TCL_OK) { - /* - * We could examine 'errno' to double-check if the problem - * was with the target, but we checked the source above, - * so it should be quite clear + /* + * We could examine 'errno' to double-check if the problem was + * with the target, but we checked the source above, so it should + * be quite clear */ + errfile = target; - /* - * We now need to reset the result, because the above call, - * if it failed, may have put an error message in place. - * (Ideally we would prefer not to pass an interpreter in - * above, but the channel IO code used by - * TclCrossFilesystemCopy currently requires one) + + /* + * We now need to reset the result, because the above call, if it + * failed, may have put an error message in place. (Ideally we + * would prefer not to pass an interpreter in above, but the + * channel IO code used by TclCrossFilesystemCopy currently + * requires one). */ + Tcl_ResetResult(interp); } } if ((copyFlag == 0) && (result == TCL_OK)) { if (S_ISDIR(sourceStatBuf.st_mode)) { @@ -710,35 +766,34 @@ if (result != TCL_OK) { errfile = source; } } if (result != TCL_OK) { - Tcl_AppendResult(interp, "can't unlink \"", - Tcl_GetString(errfile), "\": ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_AppendResult(interp, "can't unlink \"", TclGetString(errfile), + "\": ", Tcl_PosixError(interp), (char *) NULL); errfile = NULL; } } - - done: + + done: if (errfile != NULL) { - Tcl_AppendResult(interp, + Tcl_AppendResult(interp, ((copyFlag) ? "error copying \"" : "error renaming \""), - Tcl_GetString(source), (char *) NULL); + TclGetString(source), (char *) NULL); if (errfile != source) { - Tcl_AppendResult(interp, "\" to \"", Tcl_GetString(target), - (char *) NULL); + Tcl_AppendResult(interp, "\" to \"", TclGetString(target), + (char *) NULL); if (errfile != target) { - Tcl_AppendResult(interp, "\": \"", Tcl_GetString(errfile), - (char *) NULL); + Tcl_AppendResult(interp, "\": \"", TclGetString(errfile), + (char *) NULL); } } Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp), (char *) NULL); } if (errorBuffer != NULL) { - Tcl_DecrRefCount(errorBuffer); + Tcl_DecrRefCount(errorBuffer); } if (actualSource != NULL) { Tcl_DecrRefCount(actualSource); } return result; @@ -747,18 +802,17 @@ /* *--------------------------------------------------------------------------- * * FileForceOption -- * - * Helps parse command line options for file commands that take - * the "-force" and "--" options. + * Helps parse command line options for file commands that take the + * "-force" and "--" options. * * Results: - * The return value is how many arguments from argv were consumed - * by this function, or -1 if there was an error parsing the - * options. If an error occurred, an error message is left in the - * interp's result. + * The return value is how many arguments from argv were consumed by this + * function, or -1 if there was an error parsing the options. If an error + * occurred, an error message is left in the interp's result. * * Side effects: * None. * *--------------------------------------------------------------------------- @@ -768,27 +822,27 @@ FileForceOption(interp, objc, objv, forcePtr) Tcl_Interp *interp; /* Interp, for error return. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument strings. First command line * option, if it exists, begins at 0. */ - int *forcePtr; /* If the "-force" was specified, *forcePtr - * is filled with 1, otherwise with 0. */ + int *forcePtr; /* If the "-force" was specified, *forcePtr is + * filled with 1, otherwise with 0. */ { int force, i; - + force = 0; for (i = 0; i < objc; i++) { - if (Tcl_GetString(objv[i])[0] != '-') { + if (TclGetString(objv[i])[0] != '-') { break; } - if (strcmp(Tcl_GetString(objv[i]), "-force") == 0) { + if (strcmp(TclGetString(objv[i]), "-force") == 0) { force = 1; - } else if (strcmp(Tcl_GetString(objv[i]), "--") == 0) { + } else if (strcmp(TclGetString(objv[i]), "--") == 0) { i++; break; } else { - Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[i]), + Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[i]), "\": should be -force or --", (char *)NULL); return -1; } } *forcePtr = force; @@ -799,17 +853,16 @@ * * FileBasename -- * * Given a path in either tcl format (with / separators), or in the * platform-specific format for the current platform, return all the - * characters in the path after the last directory separator. But, - * if path is the root directory, returns no characters. + * characters in the path after the last directory separator. But, if + * path is the root directory, returns no characters. * * Results: - * Returns the string object that represents the basename. If there - * is an error, an error message is left in interp, and NULL is - * returned. + * Returns the string object that represents the basename. If there is an + * error, an error message is left in interp, and NULL is returned. * * Side effects: * None. * *--------------------------------------------------------------------------- @@ -821,16 +874,16 @@ Tcl_Obj *pathPtr; /* Path whose basename to extract. */ { int objc; Tcl_Obj *splitPtr; Tcl_Obj *resultPtr = NULL; - + splitPtr = Tcl_FSSplitPath(pathPtr, &objc); Tcl_IncrRefCount(splitPtr); - + if (objc != 0) { - if ((objc == 1) && (*Tcl_GetString(pathPtr) == '~')) { + if ((objc == 1) && (*TclGetString(pathPtr) == '~')) { Tcl_DecrRefCount(splitPtr); if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { return NULL; } splitPtr = Tcl_FSSplitPath(pathPtr, &objc); @@ -843,11 +896,11 @@ */ if (objc > 0) { Tcl_ListObjIndex(NULL, splitPtr, objc-1, &resultPtr); if ((objc == 1) && - (Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) { + (Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) { resultPtr = NULL; } } } if (resultPtr == NULL) { @@ -861,37 +914,35 @@ /* *---------------------------------------------------------------------- * * TclFileAttrsCmd -- * - * Sets or gets the platform-specific attributes of a file. The - * objc-objv points to the file name with the rest of the command - * line following. This routine uses platform-specific tables of - * option strings and callbacks. The callback to get the - * attributes take three parameters: - * Tcl_Interp *interp; The interp to report errors with. - * Since this is an object-based API, - * the object form of the result should - * be used. + * Sets or gets the platform-specific attributes of a file. The objc-objv + * points to the file name with the rest of the command line following. + * This routine uses platform-specific tables of option strings and + * callbacks. The callback to get the attributes take three parameters: + * Tcl_Interp *interp; The interp to report errors with. Since + * this is an object-based API, the object + * form of the result should be used. * CONST char *fileName; This is extracted using * Tcl_TranslateFileName. - * TclObj **attrObjPtrPtr; A new object to hold the attribute - * is allocated and put here. + * TclObj **attrObjPtrPtr; A new object to hold the attribute is + * allocated and put here. * The first two parameters of the callback used to write out the * attributes are the same. The third parameter is: - * CONST *attrObjPtr; A pointer to the object that has - * the new attribute. - * They both return standard TCL errors; if the routine to get - * an attribute fails, no object is allocated and *attrObjPtrPtr - * is unchanged. + * CONST *attrObjPtr; A pointer to the object that has the new + * attribute. + * They both return standard TCL errors; if the routine to get an + * attribute fails, no object is allocated and *attrObjPtrPtr is + * unchanged. * * Results: - * Standard TCL error. + * Standard TCL error. * * Side effects: - * May set file attributes for the file name. - * + * May set file attributes for the file name. + * *---------------------------------------------------------------------- */ int TclFileAttrsCmd(interp, objc, objv) @@ -902,11 +953,11 @@ int result; CONST char ** attributeStrings; Tcl_Obj* objStrings = NULL; int numObjStrings = -1; Tcl_Obj *filePtr; - + if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "name ?option? ?value? ?option value ...?"); return TCL_ERROR; } @@ -913,43 +964,53 @@ filePtr = objv[2]; if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) { return TCL_ERROR; } - + objc -= 3; objv += 3; result = TCL_ERROR; Tcl_SetErrno(0); + attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings); if (attributeStrings == NULL) { int index; Tcl_Obj *objPtr; + if (objStrings == NULL) { if (Tcl_GetErrno() != 0) { - /* - * There was an error, probably that the filePtr is - * not accepted by any filesystem + /* + * There was an error, probably that the filePtr is not + * accepted by any filesystem */ Tcl_AppendResult(interp, "could not read \"", - Tcl_GetString(filePtr), "\": ", Tcl_PosixError(interp), + TclGetString(filePtr), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } goto end; } - /* We own the object now */ + + /* + * We own the object now. + */ + Tcl_IncrRefCount(objStrings); - /* Use objStrings as a list object */ + + /* + * Use objStrings as a list object. + */ + if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) { goto end; } attributeStrings = (CONST char **) - ckalloc ((1+numObjStrings) * sizeof(char*)); + ckalloc((1+numObjStrings) * sizeof(char*)); for (index = 0; index < numObjStrings; index++) { Tcl_ListObjIndex(interp, objStrings, index, &objPtr); - attributeStrings[index] = Tcl_GetString(objPtr); + attributeStrings[index] = TclGetString(objPtr); } attributeStrings[index] = NULL; } if (objc == 0) { /* @@ -956,32 +1017,43 @@ * Get all attributes. */ int index, res = TCL_OK, nbAtts = 0; Tcl_Obj *listPtr; - + listPtr = Tcl_NewListObj(0, NULL); for (index = 0; attributeStrings[index] != NULL; index++) { Tcl_Obj *objPtrAttr; - + if (res != TCL_OK) { - /* Clear the error from the last iteration */ - Tcl_ResetResult(interp); + /* + * Clear the error from the last iteration. + */ + + Tcl_ResetResult(interp); } + res = Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtrAttr); if (res == TCL_OK) { - Tcl_Obj *objPtr = Tcl_NewStringObj(attributeStrings[index], -1); - Tcl_ListObjAppendElement(interp, listPtr, objPtr); - Tcl_ListObjAppendElement(interp, listPtr, objPtrAttr); - nbAtts++; + Tcl_Obj *objPtr = + Tcl_NewStringObj(attributeStrings[index], -1); + + Tcl_ListObjAppendElement(interp, listPtr, objPtr); + Tcl_ListObjAppendElement(interp, listPtr, objPtrAttr); + nbAtts++; } } + if (index > 0 && nbAtts == 0) { - /* Error: no valid attributes found */ + /* + * Error: no valid attributes found. + */ + Tcl_DecrRefCount(listPtr); goto end; } + Tcl_SetObjResult(interp, listPtr); } else if (objc == 1) { /* * Get one attribute. */ @@ -988,13 +1060,13 @@ int index; Tcl_Obj *objPtr = NULL; if (numObjStrings == 0) { - Tcl_AppendResult(interp, "bad option \"", - Tcl_GetString(objv[0]), "\", there are no file attributes" - " in this filesystem.", (char *) NULL); + Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]), + "\", there are no file attributes in this filesystem.", + (char *) NULL); goto end; } if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings, "option", 0, &index) != TCL_OK) { @@ -1009,15 +1081,15 @@ /* * Set option/value pairs. */ int i, index; - + if (numObjStrings == 0) { - Tcl_AppendResult(interp, "bad option \"", - Tcl_GetString(objv[0]), "\", there are no file attributes" - " in this filesystem.", (char *) NULL); + Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]), + "\", there are no file attributes in this filesystem.", + (char *) NULL); goto end; } for (i = 0; i < objc ; i += 2) { if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings, @@ -1024,12 +1096,11 @@ "option", 0, &index) != TCL_OK) { goto end; } if (i + 1 == objc) { Tcl_AppendResult(interp, "value for \"", - Tcl_GetString(objv[i]), "\" missing", - (char *) NULL); + TclGetString(objv[i]), "\" missing", (char *) NULL); goto end; } if (Tcl_FSFileAttrsSet(interp, index, filePtr, objv[i + 1]) != TCL_OK) { goto end; @@ -1036,19 +1107,31 @@ } } } result = TCL_OK; - end: + end: if (numObjStrings != -1) { - /* Free up the array we allocated */ + /* + * Free up the array we allocated. + */ + ckfree((char*)attributeStrings); - /* - * We don't need this object that was passed to us - * any more. + + /* + * We don't need this object that was passed to us any more. */ + if (objStrings != NULL) { Tcl_DecrRefCount(objStrings); } } return result; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclFileName.c ================================================================== --- generic/tclFileName.c +++ generic/tclFileName.c @@ -1,27 +1,27 @@ /* * tclFileName.c -- * - * This file contains routines for converting file names betwen - * native and network form. + * This file contains routines for converting file names betwen native + * and network form. * * Copyright (c) 1995-1998 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclFileName.c,v 1.60 2004/10/07 14:50:21 vincentdarley Exp $ + * RCS: @(#) $Id: tclFileName.c,v 1.60.2.8 2005/08/02 18:15:28 dgp Exp $ */ #include "tclInt.h" #include "tclRegexp.h" #include "tclFileSystem.h" /* For TclGetPathType() */ /* - * The following variable is set in the TclPlatformInit call to one - * of: TCL_PLATFORM_UNIX or TCL_PLATFORM_WINDOWS. + * The following variable is set in the TclPlatformInit call to one of: + * TCL_PLATFORM_UNIX or TCL_PLATFORM_WINDOWS. */ TclPlatformType tclPlatform = TCL_PLATFORM_UNIX; /* @@ -34,29 +34,27 @@ Tcl_DString *resultPtr, int offset, Tcl_PathType *typePtr)); static int SkipToChar _ANSI_ARGS_((char **stringPtr, int match)); static Tcl_Obj* SplitWinPath _ANSI_ARGS_((CONST char *path)); static Tcl_Obj* SplitUnixPath _ANSI_ARGS_((CONST char *path)); -static int DoGlob _ANSI_ARGS_((Tcl_Interp *interp, +static int DoGlob _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *resultPtr, char *separators, Tcl_Obj *pathPtr, int flags, char *pattern, Tcl_GlobTypeData *types)); - /* *---------------------------------------------------------------------- * * ExtractWinRoot -- * - * Matches the root portion of a Windows path and appends it - * to the specified Tcl_DString. + * Matches the root portion of a Windows path and appends it to the + * specified Tcl_DString. * * Results: - * Returns the position in the path immediately after the root - * including any trailing slashes. - * Appends a cleaned up version of the root to the Tcl_DString - * at the specified offest. + * Returns the position in the path immediately after the root including + * any trailing slashes. Appends a cleaned up version of the root to the + * Tcl_DString at the specified offest. * * Side effects: * Modifies the specified Tcl_DString. * *---------------------------------------------------------------------- @@ -69,22 +67,29 @@ int offset; /* Offset in buffer where result should be * stored. */ Tcl_PathType *typePtr; /* Where to store pathType result */ { if (path[0] == '/' || path[0] == '\\') { - /* Might be a UNC or Vol-Relative path */ + /* + * Might be a UNC or Vol-Relative path. + */ + CONST char *host, *share, *tail; int hlen, slen; + if (path[1] != '/' && path[1] != '\\') { Tcl_DStringSetLength(resultPtr, offset); *typePtr = TCL_PATH_VOLUME_RELATIVE; Tcl_DStringAppend(resultPtr, "/", 1); return &path[1]; } host = &path[2]; - /* Skip separators */ + /* + * Skip separators. + */ + while (host[0] == '/' || host[0] == '\\') { host++; } for (hlen = 0; host[hlen];hlen++) { @@ -92,29 +97,30 @@ break; } } if (host[hlen] == 0 || host[hlen+1] == 0) { /* - * The path given is simply of the form - * '/foo', '//foo', '/////foo' or the same - * with backslashes. If there is exactly - * one leading '/' the path is volume relative - * (see filename man page). If there are more - * than one, we are simply assuming they - * are superfluous and we trim them away. - * (An alternative interpretation would - * be that it is a host name, but we have + * The path given is simply of the form '/foo', '//foo', + * '/////foo' or the same with backslashes. If there is exactly + * one leading '/' the path is volume relative (see filename man + * page). If there are more than one, we are simply assuming they + * are superfluous and we trim them away. (An alternative + * interpretation would be that it is a host name, but we have * been documented that that is not the case). */ + *typePtr = TCL_PATH_VOLUME_RELATIVE; Tcl_DStringAppend(resultPtr, "/", 1); return &path[2]; } Tcl_DStringSetLength(resultPtr, offset); share = &host[hlen]; - /* Skip separators */ + /* + * Skip separators. + */ + while (share[0] == '/' || share[0] == '\\') { share++; } for (slen=0; share[slen]; slen++) { @@ -127,29 +133,38 @@ Tcl_DStringAppend(resultPtr, "/", 1); Tcl_DStringAppend(resultPtr, share, slen); tail = &share[slen]; - /* Skip separators */ + /* + * Skip separators. + */ + while (tail[0] == '/' || tail[0] == '\\') { tail++; } *typePtr = TCL_PATH_ABSOLUTE; return tail; } else if (*path && path[1] == ':') { - /* Might be a drive sep */ + /* + * Might be a drive separator. + */ + Tcl_DStringSetLength(resultPtr, offset); if (path[2] != '/' && path[2] != '\\') { *typePtr = TCL_PATH_VOLUME_RELATIVE; Tcl_DStringAppend(resultPtr, path, 2); return &path[2]; } else { char *tail = (char*)&path[3]; - /* Skip separators */ + /* + * Skip separators. + */ + while (*tail && (tail[0] == '/' || tail[0] == '\\')) { tail++; } *typePtr = TCL_PATH_ABSOLUTE; @@ -158,67 +173,109 @@ return tail; } } else { int abs = 0; - if (path[0] == 'c' && path[1] == 'o') { - if (path[2] == 'm' && path[3] >= '1' && path[3] <= '9') { - /* May have match for 'com[1-9]:?', which is a serial port */ + + /* + * Check for Windows devices. + */ + + if ((path[0] == 'c' || path[0] == 'C') + && (path[1] == 'o' || path[1] == 'O')) { + if ((path[2] == 'm' || path[2] == 'M') + && path[3] >= '1' && path[3] <= '4') { + /* + * May have match for 'com[1-4]:?', which is a serial port. + */ + if (path[4] == '\0') { abs = 4; } else if (path [4] == ':' && path[5] == '\0') { abs = 5; } - } else if (path[2] == 'n' && path[3] == '\0') { - /* Have match for 'con' */ + + } else if ((path[2] == 'n' || path[2] == 'N') && path[3] == '\0') { + /* + * Have match for 'con'. + */ + abs = 3; } - } else if (path[0] == 'l' && path[1] == 'p' && path[2] == 't') { - if (path[3] >= '1' && path[3] <= '9') { - /* May have match for 'lpt[1-9]:?' */ + + } else if ((path[0] == 'l' || path[0] == 'L') + && (path[1] == 'p' || path[1] == 'P') + && (path[2] == 't' || path[2] == 'T')) { + if (path[3] >= '1' && path[3] <= '3') { + /* + * May have match for 'lpt[1-3]:?' + */ + if (path[4] == '\0') { abs = 4; } else if (path [4] == ':' && path[5] == '\0') { abs = 5; } } - } else if (path[0] == 'p' && path[1] == 'r' - && path[2] == 'n' && path[3] == '\0') { - /* Have match for 'prn' */ - abs = 3; - } else if (path[0] == 'n' && path[1] == 'u' - && path[2] == 'l' && path[3] == '\0') { - /* Have match for 'nul' */ - abs = 3; - } else if (path[0] == 'a' && path[1] == 'u' - && path[2] == 'x' && path[3] == '\0') { - /* Have match for 'aux' */ + + } else if ((path[0] == 'p' || path[0] == 'P') + && (path[1] == 'r' || path[1] == 'R') + && (path[2] == 'n' || path[2] == 'N') + && path[3] == '\0') { + /* + * Have match for 'prn'. + */ + abs = 3; + + } else if ((path[0] == 'n' || path[0] == 'N') + && (path[1] == 'u' || path[1] == 'U') + && (path[2] == 'l' || path[2] == 'L') + && path[3] == '\0') { + /* + * Have match for 'nul'. + */ + + abs = 3; + + } else if ((path[0] == 'a' || path[0] == 'A') + && (path[1] == 'u' || path[1] == 'U') + && (path[2] == 'x' || path[2] == 'X') + && path[3] == '\0') { + /* + * Have match for 'aux'. + */ + abs = 3; } + if (abs != 0) { *typePtr = TCL_PATH_ABSOLUTE; Tcl_DStringSetLength(resultPtr, offset); Tcl_DStringAppend(resultPtr, path, abs); return path + abs; } } - /* Anything else is treated as relative */ + + /* + * Anything else is treated as relative. + */ + *typePtr = TCL_PATH_RELATIVE; return path; } /* *---------------------------------------------------------------------- * * Tcl_GetPathType -- * - * Determines whether a given path is relative to the current - * directory, relative to the current volume, or absolute. + * Determines whether a given path is relative to the current directory, + * relative to the current volume, or absolute. * - * The objectified Tcl_FSGetPathType should be used in - * preference to this function (as you can see below, this - * is just a wrapper around that other function). + * The objectified Tcl_FSGetPathType should be used in preference to this + * function (as you can see below, this is just a wrapper around that + * other function). * * Results: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or * TCL_PATH_VOLUME_RELATIVE. * @@ -232,10 +289,11 @@ Tcl_GetPathType(path) CONST char *path; { Tcl_PathType type; Tcl_Obj *tempObj = Tcl_NewStringObj(path,-1); + Tcl_IncrRefCount(tempObj); type = Tcl_FSGetPathType(tempObj); Tcl_DecrRefCount(tempObj); return type; } @@ -243,22 +301,22 @@ /* *---------------------------------------------------------------------- * * TclpGetNativePathType -- * - * Determines whether a given path is relative to the current - * directory, relative to the current volume, or absolute, but - * ONLY FOR THE NATIVE FILESYSTEM. This function is called from - * tclIOUtil.c (but needs to be here due to its dependence on - * static variables/functions in this file). The exported - * function Tcl_FSGetPathType should be used by extensions. - * - * Note that '~' paths are always considered TCL_PATH_ABSOLUTE, - * even though expanding the '~' could lead to any possible - * path type. This function should therefore be considered a - * low-level, string-manipulation function only -- it doesn't - * actually do any expansion in making its determination. + * Determines whether a given path is relative to the current directory, + * relative to the current volume, or absolute, but ONLY FOR THE NATIVE + * FILESYSTEM. This function is called from tclIOUtil.c (but needs to be + * here due to its dependence on static variables/functions in this + * file). The exported function Tcl_FSGetPathType should be used by + * extensions. + * + * Note that '~' paths are always considered TCL_PATH_ABSOLUTE, even + * though expanding the '~' could lead to any possible path type. This + * function should therefore be considered a low-level, string + * manipulation function only -- it doesn't actually do any expansion in + * making its determination. * * Results: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or * TCL_PATH_VOLUME_RELATIVE. * @@ -268,24 +326,25 @@ *---------------------------------------------------------------------- */ Tcl_PathType TclpGetNativePathType(pathPtr, driveNameLengthPtr, driveNameRef) - Tcl_Obj *pathPtr; /* Native path of interest */ - int *driveNameLengthPtr; /* Returns length of drive, if non-NULL - * and path was absolute */ + Tcl_Obj *pathPtr; /* Native path of interest */ + int *driveNameLengthPtr; /* Returns length of drive, if non-NULL and + * path was absolute */ Tcl_Obj **driveNameRef; { Tcl_PathType type = TCL_PATH_ABSOLUTE; int pathLen; char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); if (path[0] == '~') { /* - * This case is common to all platforms. - * Paths that begin with ~ are absolute. + * This case is common to all platforms. Paths that begin with ~ are + * absolute. */ + if (driveNameLengthPtr != NULL) { char *end = path + 1; while ((*end != '\0') && (*end != '/')) { end++; } @@ -313,13 +372,13 @@ } #endif if (path[0] == '/') { if (driveNameLengthPtr != NULL) { /* - * We need this addition in case the QNX code - * was used + * We need this addition in case the QNX code was used. */ + *driveNameLengthPtr = (1 + path - origPath); } } else { type = TCL_PATH_RELATIVE; } @@ -350,22 +409,21 @@ /* *--------------------------------------------------------------------------- * * TclpNativeSplitPath -- * - * This function takes the given Tcl_Obj, which should be a valid - * path, and returns a Tcl List object containing each segment - * of that path as an element. + * This function takes the given Tcl_Obj, which should be a valid path, + * and returns a Tcl List object containing each segment of that path as + * an element. * - * Note this function currently calls the older Split(Plat)Path - * functions, which require more memory allocation than is - * desirable. + * Note this function currently calls the older Split(Plat)Path + * functions, which require more memory allocation than is desirable. * * Results: - * Returns list object with refCount of zero. If the passed in - * lenPtr is non-NULL, we use it to return the number of elements - * in the returned list. + * Returns list object with refCount of zero. If the passed in lenPtr is + * non-NULL, we use it to return the number of elements in the returned + * list. * * Side effects: * None. * *--------------------------------------------------------------------------- @@ -405,24 +463,23 @@ /* *---------------------------------------------------------------------- * * Tcl_SplitPath -- * - * Split a path into a list of path components. The first element - * of the list will have the same path type as the original path. + * Split a path into a list of path components. The first element of the + * list will have the same path type as the original path. * * Results: - * Returns a standard Tcl result. The interpreter result contains - * a list of path components. - * *argvPtr will be filled in with the address of an array - * whose elements point to the elements of path, in order. - * *argcPtr will get filled in with the number of valid elements - * in the array. A single block of memory is dynamically allocated - * to hold both the argv array and a copy of the path elements. - * The caller must eventually free this memory by calling ckfree() - * on *argvPtr. Note: *argvPtr and *argcPtr are only modified - * if the procedure returns normally. + * Returns a standard Tcl result. The interpreter result contains a list + * of path components. *argvPtr will be filled in with the address of an + * array whose elements point to the elements of path, in order. + * *argcPtr will get filled in with the number of valid elements in the + * array. A single block of memory is dynamically allocated to hold both + * the argv array and a copy of the path elements. The caller must + * eventually free this memory by calling ckfree() on *argvPtr. Note: + * *argvPtr and *argcPtr are only modified if the procedure returns + * normally. * * Side effects: * Allocates memory. * *---------------------------------------------------------------------- @@ -429,12 +486,12 @@ */ void Tcl_SplitPath(path, argcPtr, argvPtr) CONST char *path; /* Pointer to string containing a path. */ - int *argcPtr; /* Pointer to location to fill in with - * the number of elements in the path. */ + int *argcPtr; /* Pointer to location to fill in with the + * number of elements in the path. */ CONST char ***argvPtr; /* Pointer to place to store pointer to array * of pointers to path elements. */ { Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */ Tcl_Obj *tmpPtr, *eltPtr; @@ -449,30 +506,32 @@ Tcl_IncrRefCount(tmpPtr); resultPtr = Tcl_FSSplitPath(tmpPtr, argcPtr); Tcl_IncrRefCount(resultPtr); Tcl_DecrRefCount(tmpPtr); - /* Calculate space required for the result */ + /* + * Calculate space required for the result. + */ size = 1; for (i = 0; i < *argcPtr; i++) { Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); Tcl_GetStringFromObj(eltPtr, &len); size += len + 1; } /* - * Allocate a buffer large enough to hold the contents of all of - * the list plus the argv pointers and the terminating NULL pointer. + * Allocate a buffer large enough to hold the contents of all of the list + * plus the argv pointers and the terminating NULL pointer. */ *argvPtr = (CONST char **) ckalloc((unsigned) ((((*argcPtr) + 1) * sizeof(char *)) + size)); /* - * Position p after the last argv pointer and copy the contents of - * the list in, piece by piece. + * Position p after the last argv pointer and copy the contents of the + * list in, piece by piece. */ p = (char *) &(*argvPtr)[(*argcPtr) + 1]; for (i = 0; i < *argcPtr; i++) { Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); @@ -503,12 +562,12 @@ /* *---------------------------------------------------------------------- * * SplitUnixPath -- * - * This routine is used by Tcl_(FS)SplitPath to handle splitting - * Unix paths. + * This routine is used by Tcl_(FS)SplitPath to handle splitting Unix + * paths. * * Results: * Returns a newly allocated Tcl list object. * * Side effects: @@ -574,19 +633,18 @@ break; } } return result; } - /* *---------------------------------------------------------------------- * * SplitWinPath -- * - * This routine is used by Tcl_(FS)SplitPath to handle splitting - * Windows paths. + * This routine is used by Tcl_(FS)SplitPath to handle splitting Windows + * paths. * * Results: * Returns a newly allocated Tcl list object. * * Side effects: @@ -617,12 +675,13 @@ Tcl_DStringValue(&buf), Tcl_DStringLength(&buf))); } Tcl_DStringFree(&buf); /* - * Split on slashes. Embedded elements that start with tilde will be - * prefixed with "./" so they are not affected by tilde substitution. + * Split on slashes. Embedded elements that start with tilde or a drive + * letter will be prefixed with "./" so they are not affected by tilde + * substitution. */ do { elementStart = p; while ((*p != '\0') && (*p != '/') && (*p != '\\')) { @@ -629,11 +688,14 @@ p++; } length = p - elementStart; if (length > 0) { Tcl_Obj *nextElt; - if ((elementStart[0] == '~') && (elementStart != path)) { + if ((elementStart != path) + && ((elementStart[0] == '~') + || (isalpha(UCHAR(elementStart[0])) + && elementStart[1] == ':'))) { nextElt = Tcl_NewStringObj("./",2); Tcl_AppendToObj(nextElt, elementStart, length); } else { nextElt = Tcl_NewStringObj(elementStart, length); } @@ -647,34 +709,33 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSJoinToPath -- * - * This function takes the given object, which should usually be a - * valid path or NULL, and joins onto it the array of paths - * segments given. - * - * The objects in the array given will temporarily have their - * refCount increased by one, and then decreased by one when this - * function exits (which means if they had zero refCount when we - * were called, they will be freed). + * This function takes the given object, which should usually be a valid + * path or NULL, and joins onto it the array of paths segments given. + * + * The objects in the array given will temporarily have their refCount + * increased by one, and then decreased by one when this function exits + * (which means if they had zero refCount when we were called, they will + * be freed). * * Results: - * Returns object owned by the caller (which should increment its - * refCount) - typically an object with refCount of zero. + * Returns object owned by the caller (which should increment its + * refCount) - typically an object with refCount of zero. * * Side effects: * None. * *--------------------------------------------------------------------------- */ -Tcl_Obj* +Tcl_Obj * Tcl_FSJoinToPath(pathPtr, objc, objv) - Tcl_Obj *pathPtr; /* Valid path or NULL. */ - int objc; /* Number of array elements to join */ - Tcl_Obj *CONST objv[]; /* Path elements to join. */ + Tcl_Obj *pathPtr; /* Valid path or NULL. */ + int objc; /* Number of array elements to join */ + Tcl_Obj *CONST objv[]; /* Path elements to join. */ { int i; Tcl_Obj *lobj, *ret; if (pathPtr == NULL) { @@ -685,18 +746,19 @@ for (i = 0; irefCount--; return ret; } @@ -704,14 +766,14 @@ /* *--------------------------------------------------------------------------- * * TclpNativeJoinPath -- * - * 'prefix' is absolute, 'joining' is relative to prefix. + * 'prefix' is absolute, 'joining' is relative to prefix. * * Results: - * modifies prefix + * modifies prefix * * Side effects: * None. * *--------------------------------------------------------------------------- @@ -718,30 +780,31 @@ */ void TclpNativeJoinPath(prefix, joining) Tcl_Obj *prefix; - char* joining; + char *joining; { int length, needsSep; char *dest, *p, *start; start = Tcl_GetStringFromObj(prefix, &length); /* - * Remove the ./ from tilde prefixed elements unless - * it is the first component. + * Remove the ./ from tilde prefixed elements, and drive-letter prefixed + * elements on Windows, unless it is the first component. */ p = joining; if (length != 0) { - if ((p[0] == '.') && (p[1] == '/') && (p[2] == '~')) { + if ((p[0] == '.') && (p[1] == '/') && ((p[2] == '~') + || (tclPlatform==TCL_PLATFORM_WINDOWS && isalpha(UCHAR(p[2])) + && (p[3] == ':')))) { p += 2; } } - if (*p == '\0') { return; } switch (tclPlatform) { @@ -755,12 +818,11 @@ length++; } needsSep = 0; /* - * Append the element, eliminating duplicate and trailing - * slashes. + * Append the element, eliminating duplicate and trailing slashes. */ Tcl_SetObjLength(prefix, length + (int) strlen(p)); dest = Tcl_GetString(prefix) + length; @@ -792,12 +854,11 @@ length++; } needsSep = 0; /* - * Append the element, eliminating duplicate and - * trailing slashes. + * Append the element, eliminating duplicate and trailing slashes. */ Tcl_SetObjLength(prefix, length + (int) strlen(p)); dest = Tcl_GetString(prefix) + length; for (; *p != '\0'; p++) { @@ -823,18 +884,17 @@ /* *---------------------------------------------------------------------- * * Tcl_JoinPath -- * - * Combine a list of paths in a platform specific manner. The - * function 'Tcl_FSJoinPath' should be used in preference where - * possible. + * Combine a list of paths in a platform specific manner. The function + * 'Tcl_FSJoinPath' should be used in preference where possible. * * Results: - * Appends the joined path to the end of the specified - * Tcl_DString returning a pointer to the resulting string. Note - * that the Tcl_DString must already be initialized. + * Appends the joined path to the end of the specified Tcl_DString + * returning a pointer to the resulting string. Note that the + * Tcl_DString must already be initialized. * * Side effects: * Modifies the Tcl_DString. * *---------------------------------------------------------------------- @@ -849,67 +909,79 @@ int i, len; Tcl_Obj *listObj = Tcl_NewObj(); Tcl_Obj *resultObj; char *resultStr; - /* Build the list of paths */ + /* + * Build the list of paths. + */ + for (i = 0; i < argc; i++) { - Tcl_ListObjAppendElement(NULL, listObj, + Tcl_ListObjAppendElement(NULL, listObj, Tcl_NewStringObj(argv[i], -1)); } - /* Ask the objectified code to join the paths */ + /* + * Ask the objectified code to join the paths. + */ + Tcl_IncrRefCount(listObj); resultObj = Tcl_FSJoinPath(listObj, argc); Tcl_IncrRefCount(resultObj); Tcl_DecrRefCount(listObj); - /* Store the result */ + /* + * Store the result. + */ + resultStr = Tcl_GetStringFromObj(resultObj, &len); Tcl_DStringAppend(resultPtr, resultStr, len); Tcl_DecrRefCount(resultObj); - /* Return a pointer to the result */ + /* + * Return a pointer to the result. + */ + return Tcl_DStringValue(resultPtr); } /* *--------------------------------------------------------------------------- * * Tcl_TranslateFileName -- * * Converts a file name into a form usable by the native system - * interfaces. If the name starts with a tilde, it will produce a - * name where the tilde and following characters have been replaced - * by the home directory location for the named user. + * interfaces. If the name starts with a tilde, it will produce a name + * where the tilde and following characters have been replaced by the + * home directory location for the named user. * * Results: - * The return value is a pointer to a string containing the name - * after tilde substitution. If there was no tilde substitution, - * the return value is a pointer to a copy of the original string. - * If there was an error in processing the name, then an error - * message is left in the interp's result (if interp was not NULL) - * and the return value is NULL. Space for the return value is - * allocated in bufferPtr; the caller must call Tcl_DStringFree() - * to free the space if the return value was not NULL. + * The return value is a pointer to a string containing the name after + * tilde substitution. If there was no tilde substitution, the return + * value is a pointer to a copy of the original string. If there was an + * error in processing the name, then an error message is left in the + * interp's result (if interp was not NULL) and the return value is NULL. + * Space for the return value is allocated in bufferPtr; the caller must + * call Tcl_DStringFree() to free the space if the return value was not + * NULL. * * Side effects: * None. * *---------------------------------------------------------------------- */ char * Tcl_TranslateFileName(interp, name, bufferPtr) - Tcl_Interp *interp; /* Interpreter in which to store error - * message (if necessary). */ + Tcl_Interp *interp; /* Interpreter in which to store error message + * (if necessary). */ CONST char *name; /* File name, which may begin with "~" (to * indicate current user's home directory) or * "~" (to indicate any user's home * directory). */ - Tcl_DString *bufferPtr; /* Uninitialized or free DString filled - * with name after tilde substitution. */ + Tcl_DString *bufferPtr; /* Uninitialized or free DString filled with + * name after tilde substitution. */ { Tcl_Obj *path = Tcl_NewStringObj(name, -1); Tcl_Obj *transPtr; Tcl_IncrRefCount(path); @@ -923,12 +995,12 @@ Tcl_DStringAppend(bufferPtr, Tcl_GetString(transPtr), -1); Tcl_DecrRefCount(path); Tcl_DecrRefCount(transPtr); /* - * Convert forward slashes to backslashes in Windows paths because - * some system interfaces don't accept forward slashes. + * Convert forward slashes to backslashes in Windows paths because some + * system interfaces don't accept forward slashes. */ if (tclPlatform == TCL_PLATFORM_WINDOWS) { register char *p; for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) { @@ -935,20 +1007,21 @@ if (*p == '/') { *p = '\\'; } } } + return Tcl_DStringValue(bufferPtr); } /* *---------------------------------------------------------------------- * * TclGetExtension -- * - * This function returns a pointer to the beginning of the - * extension part of a file name. + * This function returns a pointer to the beginning of the extension part + * of a file name. * * Results: * Returns a pointer into name which indicates where the extension * starts. If there is no extension, returns NULL. * @@ -1006,30 +1079,29 @@ * Given a string following a tilde, this routine returns the * corresponding home directory. * * Results: * The result is a pointer to a static string containing the home - * directory in native format. If there was an error in processing - * the substitution, then an error message is left in the interp's - * result and the return value is NULL. On success, the results - * are appended to resultPtr, and the contents of resultPtr are - * returned. + * directory in native format. If there was an error in processing the + * substitution, then an error message is left in the interp's result and + * the return value is NULL. On success, the results are appended to + * resultPtr, and the contents of resultPtr are returned. * * Side effects: * Information may be left in resultPtr. * *---------------------------------------------------------------------- */ static CONST char * DoTildeSubst(interp, user, resultPtr) - Tcl_Interp *interp; /* Interpreter in which to store error - * message (if necessary). */ + Tcl_Interp *interp; /* Interpreter in which to store error message + * (if necessary). */ CONST char *user; /* Name of user whose home directory should be * substituted, or "" for current user. */ - Tcl_DString *resultPtr; /* Initialized DString filled with name - * after tilde substitution. */ + Tcl_DString *resultPtr; /* Initialized DString filled with name after + * tilde substitution. */ { CONST char *dir; if (*user == '\0') { Tcl_DString dirString; @@ -1059,12 +1131,12 @@ /* *---------------------------------------------------------------------- * * Tcl_GlobObjCmd -- * - * This procedure is invoked to process the "glob" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "glob" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -1105,23 +1177,26 @@ if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { string = Tcl_GetStringFromObj(objv[i], &length); if (string[0] == '-') { /* - * It looks like the command contains an option so signal - * an error + * It looks like the command contains an option so signal an + * error. */ + return TCL_ERROR; } else { /* - * This clearly isn't an option; assume it's the first - * glob pattern. We must clear the error + * This clearly isn't an option; assume it's the first glob + * pattern. We must clear the error. */ + Tcl_ResetResult(interp); break; } } + switch (index) { case GLOB_NOCOMPLAIN: /* -nocomplain */ globFlags |= TCL_GLOBMODE_NO_COMPLAIN; break; case GLOB_DIR: /* -dir */ @@ -1176,17 +1251,18 @@ case GLOB_LAST: /* -- */ i++; goto endOfForLoop; } } + endOfForLoop: if (objc - i < 1) { - Tcl_WrongNumArgs(interp, 1, objv, "?switches? name ?name ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "?switches? name ?name ...?"); return TCL_ERROR; } if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) { - Tcl_AppendResult(interp, + Tcl_AppendResult(interp, "\"-tails\" must be used with either ", "\"-directory\" or \"-path\"", NULL); return TCL_ERROR; } @@ -1197,58 +1273,73 @@ break; case TCL_PLATFORM_WINDOWS: separators = "/\\:"; break; } + if (dir == PATH_GENERAL) { int pathlength; char *last; char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength); /* * Find the last path separator in the path */ + last = first + pathlength; for (; last != first; last--) { if (strchr(separators, *(last-1)) != NULL) { break; } } + if (last == first + pathlength) { - /* It's really a directory */ + /* + * It's really a directory. + */ + dir = PATH_DIR; + } else { Tcl_DString pref; char *search, *find; Tcl_DStringInit(&pref); if (last == first) { /* - * The whole thing is a prefix. This means we must - * remove any 'tails' flag too, since it is irrelevant - * now (the same effect will happen without it), but in - * particular its use in TclGlob requires a non-NULL - * pathOrDir. + * The whole thing is a prefix. This means we must remove any + * 'tails' flag too, since it is irrelevant now (the same + * effect will happen without it), but in particular its use + * in TclGlob requires a non-NULL pathOrDir. */ + Tcl_DStringAppend(&pref, first, -1); globFlags &= ~TCL_GLOBMODE_TAILS; pathOrDir = NULL; } else { - /* Have to split off the end */ + /* + * Have to split off the end. + */ + Tcl_DStringAppend(&pref, last, first+pathlength-last); pathOrDir = Tcl_NewStringObj(first, last-first-1); + /* - * We must ensure that we haven't cut off too much, - * and turned a valid path like '/' or 'C:/' into - * an incorrect path like '' or 'C:'. The way we - * do this is to add a separator if there are none - * presently in the prefix. + * We must ensure that we haven't cut off too much, and turned + * a valid path like '/' or 'C:/' into an incorrect path like + * '' or 'C:'. The way we do this is to add a separator if + * there are none presently in the prefix. */ + if (strpbrk(Tcl_GetString(pathOrDir), "\\/") == NULL) { Tcl_AppendToObj(pathOrDir, last-1, 1); } } - /* Need to quote 'prefix' */ + + /* + * Need to quote 'prefix'. + */ + Tcl_DStringInit(&prefix); search = Tcl_DStringValue(&pref); while ((find = (strpbrk(search, "\\[]*?{}"))) != NULL) { Tcl_DStringAppend(&prefix, search, find-search); Tcl_DStringAppend(&prefix, "\\", 1); @@ -1269,23 +1360,26 @@ Tcl_IncrRefCount(pathOrDir); } if (typePtr != NULL) { /* - * The rest of the possible type arguments (except 'd') are - * platform specific. We don't complain when they are used - * on an incompatible platform. + * The rest of the possible type arguments (except 'd') are platform + * specific. We don't complain when they are used on an incompatible + * platform. */ + Tcl_ListObjLength(interp, typePtr, &length); globTypes = (Tcl_GlobTypeData*) ckalloc(sizeof(Tcl_GlobTypeData)); globTypes->type = 0; globTypes->perm = 0; globTypes->macType = NULL; globTypes->macCreator = NULL; + while (--length >= 0) { int len; char *str; + Tcl_ListObjIndex(interp, typePtr, length, &look); str = Tcl_GetStringFromObj(look, &len); if (strcmp("readonly", str) == 0) { globTypes->perm |= TCL_GLOB_PERM_RONLY; } else if (strcmp("hidden", str) == 0) { @@ -1323,19 +1417,25 @@ globTypes->type |= TCL_GLOB_TYPE_SOCK; break; default: goto badTypesArg; } + } else if (len == 4) { - /* This is assumed to be a MacOS file type */ + /* + * This is assumed to be a MacOS file type. + */ + if (globTypes->macType != NULL) { goto badMacTypesArg; } globTypes->macType = look; Tcl_IncrRefCount(look); + } else { Tcl_Obj* item; + if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) && (len == 3)) { Tcl_ListObjIndex(interp, look, 0, &item); if (!strcmp("macintosh", Tcl_GetString(item))) { Tcl_ListObjIndex(interp, look, 1, &item); @@ -1356,24 +1456,26 @@ Tcl_IncrRefCount(item); continue; } } } + /* - * Error cases. We reset - * the 'join' flag to zero, since we haven't yet - * made use of it. + * Error cases. We reset the 'join' flag to zero, since we + * haven't yet made use of it. */ - badTypesArg: + + badTypesArg: TclNewObj(resultPtr); Tcl_AppendToObj(resultPtr, "bad argument to \"-types\": ", -1); Tcl_AppendObjToObj(resultPtr, look); Tcl_SetObjResult(interp, resultPtr); result = TCL_ERROR; join = 0; goto endOfGlob; - badMacTypesArg: + + badMacTypesArg: Tcl_SetObjResult(interp, Tcl_NewStringObj( "only one MacOS type or creator argument" " to \"-types\" allowed", -1)); result = TCL_ERROR; join = 0; @@ -1381,18 +1483,19 @@ } } } /* - * Now we perform the actual glob below. This may involve joining - * together the pattern arguments, dealing with particular file types - * etc. We use a 'goto' to ensure we free any memory allocated along - * the way. + * Now we perform the actual glob below. This may involve joining together + * the pattern arguments, dealing with particular file types etc. We use a + * 'goto' to ensure we free any memory allocated along the way. */ + objc -= i; objv += i; result = TCL_OK; + if (join) { if (dir != PATH_GENERAL) { Tcl_DStringInit(&prefix); } for (i = 0; i < objc; i++) { @@ -1400,52 +1503,56 @@ Tcl_DStringAppend(&prefix, string, length); if (i != objc -1) { Tcl_DStringAppend(&prefix, separators, 1); } } - if (TclGlob(interp, Tcl_DStringValue(&prefix), pathOrDir, - globFlags, globTypes) != TCL_OK) { - result = TCL_ERROR; - goto endOfGlob; - } - } else { - if (dir == PATH_GENERAL) { - Tcl_DString str; - for (i = 0; i < objc; i++) { - Tcl_DStringInit(&str); - if (dir == PATH_GENERAL) { - Tcl_DStringAppend(&str, Tcl_DStringValue(&prefix), - Tcl_DStringLength(&prefix)); - } - string = Tcl_GetStringFromObj(objv[i], &length); - Tcl_DStringAppend(&str, string, length); - if (TclGlob(interp, Tcl_DStringValue(&str), pathOrDir, - globFlags, globTypes) != TCL_OK) { - result = TCL_ERROR; - Tcl_DStringFree(&str); - goto endOfGlob; - } - } - Tcl_DStringFree(&str); - } else { - for (i = 0; i < objc; i++) { - string = Tcl_GetString(objv[i]); - if (TclGlob(interp, string, pathOrDir, - globFlags, globTypes) != TCL_OK) { - result = TCL_ERROR; - goto endOfGlob; - } - } - } - } + if (TclGlob(interp, Tcl_DStringValue(&prefix), pathOrDir, globFlags, + globTypes) != TCL_OK) { + result = TCL_ERROR; + goto endOfGlob; + } + } else if (dir == PATH_GENERAL) { + Tcl_DString str; + + for (i = 0; i < objc; i++) { + Tcl_DStringInit(&str); + if (dir == PATH_GENERAL) { + Tcl_DStringAppend(&str, Tcl_DStringValue(&prefix), + Tcl_DStringLength(&prefix)); + } + string = Tcl_GetStringFromObj(objv[i], &length); + Tcl_DStringAppend(&str, string, length); + if (TclGlob(interp, Tcl_DStringValue(&str), pathOrDir, globFlags, + globTypes) != TCL_OK) { + result = TCL_ERROR; + Tcl_DStringFree(&str); + goto endOfGlob; + } + } + Tcl_DStringFree(&str); + } else { + for (i = 0; i < objc; i++) { + string = Tcl_GetString(objv[i]); + if (TclGlob(interp, string, pathOrDir, globFlags, + globTypes) != TCL_OK) { + result = TCL_ERROR; + goto endOfGlob; + } + } + } + if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) { if (Tcl_ListObjLength(interp, Tcl_GetObjResult(interp), &length) != TCL_OK) { - /* This should never happen. Maybe we should be more dramatic */ + /* + * This should never happen. Maybe we should be more dramatic. + */ + result = TCL_ERROR; goto endOfGlob; } + if (length == 0) { Tcl_AppendResult(interp, "no files matched glob pattern", (join || (objc == 1)) ? " \"" : "s \"", (char *) NULL); if (join) { Tcl_AppendResult(interp, Tcl_DStringValue(&prefix), @@ -1460,10 +1567,11 @@ } Tcl_AppendResult(interp, "\"", (char *) NULL); result = TCL_ERROR; } } + endOfGlob: if (join || (dir == PATH_GENERAL)) { Tcl_DStringFree(&prefix); } if (pathOrDir != NULL) { @@ -1484,32 +1592,30 @@ /* *---------------------------------------------------------------------- * * TclGlob -- * - * This procedure prepares arguments for the DoGlob call. - * It sets the separator string based on the platform, performs - * tilde substitution, and calls DoGlob. - * - * The interpreter's result, on entry to this function, must - * be a valid Tcl list (e.g. it could be empty), since we will - * lappend any new results to that list. If it is not a valid - * list, this function will fail to do anything very meaningful. - * - * Note that if globFlags contains 'TCL_GLOBMODE_TAILS' then - * pathPrefix cannot be NULL (it is only allowed with -dir or - * -path). + * This procedure prepares arguments for the DoGlob call. It sets the + * separator string based on the platform, performs * tilde substitution, + * and calls DoGlob. + * + * The interpreter's result, on entry to this function, must be a valid + * Tcl list (e.g. it could be empty), since we will lappend any new + * results to that list. If it is not a valid list, this function will + * fail to do anything very meaningful. + * + * Note that if globFlags contains 'TCL_GLOBMODE_TAILS' then pathPrefix + * cannot be NULL (it is only allowed with -dir or -path). * * Results: - * The return value is a standard Tcl result indicating whether - * an error occurred in globbing. After a normal return the - * result in interp (set by DoGlob) holds all of the file names - * given by the pattern and pathPrefix arguments. After an - * error the result in interp will hold an error message, unless - * the 'TCL_GLOBMODE_NO_COMPLAIN' flag was given, in which case - * an error results in a TCL_OK return leaving the interpreter's - * result unmodified. + * The return value is a standard Tcl result indicating whether an error + * occurred in globbing. After a normal return the result in interp (set + * by DoGlob) holds all of the file names given by the pattern and + * pathPrefix arguments. After an error the result in interp will hold + * an error message, unless the 'TCL_GLOBMODE_NO_COMPLAIN' flag was + * given, in which case an error results in a TCL_OK return leaving the + * interpreter's result unmodified. * * Side effects: * The 'pattern' is written to. * *---------------------------------------------------------------------- @@ -1516,19 +1622,19 @@ */ /* ARGSUSED */ int TclGlob(interp, pattern, pathPrefix, globFlags, types) - Tcl_Interp *interp; /* Interpreter for returning error message - * or appending list of matching file names. */ - char *pattern; /* Glob pattern to match. Must not refer - * to a static string. */ + Tcl_Interp *interp; /* Interpreter for returning error message or + * appending list of matching file names. */ + char *pattern; /* Glob pattern to match. Must not refer to a + * static string. */ Tcl_Obj *pathPrefix; /* Path prefix to glob pattern, if non-null, - * which is considered literally. */ + * which is considered literally. */ int globFlags; /* Stores or'ed combination of flags */ - Tcl_GlobTypeData *types; /* Struct containing acceptable types. - * May be NULL. */ + Tcl_GlobTypeData *types; /* Struct containing acceptable types. May be + * NULL. */ { char *separators; CONST char *head; char *tail, *start; int result; @@ -1548,19 +1654,20 @@ char c; Tcl_DString buffer; Tcl_DStringInit(&buffer); start = pattern; + /* * Perform tilde substitution, if needed. */ if (start[0] == '~') { - /* * Find the first path separator after the tilde. */ + for (tail = start; *tail != '\0'; tail++) { if (*tail == '\\') { if (strchr(separators, tail[1]) != NULL) { break; } @@ -1575,12 +1682,12 @@ c = *tail; *tail = '\0'; if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) { /* - * We will ignore any error message here, and we - * don't want to mess up the interpreter's result. + * We will ignore any error message here, and we don't want to + * mess up the interpreter's result. */ head = DoTildeSubst(NULL, start+1, &buffer); } else { head = DoTildeSubst(interp, start+1, &buffer); } @@ -1594,11 +1701,11 @@ } if (head != Tcl_DStringValue(&buffer)) { Tcl_DStringAppend(&buffer, head, -1); } pathPrefix = Tcl_NewStringObj(Tcl_DStringValue(&buffer), - Tcl_DStringLength(&buffer)); + Tcl_DStringLength(&buffer)); Tcl_IncrRefCount(pathPrefix); globFlags |= TCL_GLOBMODE_DIR; if (c != '\0') { tail++; } @@ -1611,17 +1718,16 @@ tail = pattern; } /* * Handling empty path prefixes with glob patterns like 'C:' or - * 'c:////////' is a pain on Windows if we leave it too late, since - * these aren't really patterns at all! We therefore check the head - * of the pattern now for such cases, if we don't have an unquoted - * prefix yet. + * 'c:////////' is a pain on Windows if we leave it too late, since these + * aren't really patterns at all! We therefore check the head of the + * pattern now for such cases, if we don't have an unquoted prefix yet. * - * Similarly on Unix with '/' at the head of the pattern -- it - * just indicates the root volume, so we treat it as such. + * Similarly on Unix with '/' at the head of the pattern -- it just + * indicates the root volume, so we treat it as such. */ if (tclPlatform == TCL_PLATFORM_WINDOWS) { if (pathPrefix == NULL && tail[0] != '\0' && tail[1] == ':') { char *p = tail + 1; @@ -1647,24 +1753,25 @@ } tail = p; Tcl_IncrRefCount(pathPrefix); } else if (pathPrefix == NULL && (tail[0] == '/' || (tail[0] == '\\' && tail[1] == '\\'))) { - int driveNameLen; - Tcl_Obj *driveName; - Tcl_Obj *temp = Tcl_NewStringObj(tail, -1); - Tcl_IncrRefCount(temp); + int driveNameLen; + Tcl_Obj *driveName; + Tcl_Obj *temp = Tcl_NewStringObj(tail, -1); + Tcl_IncrRefCount(temp); - switch (TclGetPathType(temp, NULL, &driveNameLen, &driveName)) { + switch (TclGetPathType(temp, NULL, &driveNameLen, &driveName)) { case TCL_PATH_VOLUME_RELATIVE: { /* - * Volume relative path which is equivalent to a path in - * the root of the cwd's volume. We will actually return + * Volume relative path which is equivalent to a path in the + * root of the cwd's volume. We will actually return * non-volume-relative paths here. i.e. 'glob /foo*' will - * return 'C:/foobar'. This is much the same as globbing - * for a path with '\\' will return one with '/' on Windows. + * return 'C:/foobar'. This is much the same as globbing for + * a path with '\\' will return one with '/' on Windows. */ + Tcl_Obj *cwd = Tcl_FSGetCwd(interp); if (cwd == NULL) { Tcl_DecrRefCount(temp); if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) { @@ -1683,39 +1790,42 @@ Tcl_IncrRefCount(pathPrefix); break; } case TCL_PATH_ABSOLUTE: /* - * Absolute, possibly network path //Machine/Share. - * Use that as the path prefix (it already has a - * refCount). + * Absolute, possibly network path //Machine/Share. Use that + * as the path prefix (it already has a refCount). */ + pathPrefix = driveName; tail += driveNameLen; break; case TCL_PATH_RELATIVE: /* Do nothing */ break; - } - Tcl_DecrRefCount(temp); + } + Tcl_DecrRefCount(temp); } + /* - * ':' no longer needed as a separator. It is only relevant - * to the beginning of the path. + * ':' no longer needed as a separator. It is only relevant to the + * beginning of the path. */ + separators = "/\\"; + } else if (tclPlatform == TCL_PLATFORM_UNIX) { if (pathPrefix == NULL && tail[0] == '/') { pathPrefix = Tcl_NewStringObj(tail, 1); tail++; Tcl_IncrRefCount(pathPrefix); } } /* - * Finally if we still haven't managed to generate a path - * prefix, check if the path starts with a current volume. + * Finally if we still haven't managed to generate a path prefix, check if + * the path starts with a current volume. */ if (pathPrefix == NULL) { int driveNameLen; Tcl_Obj *driveName; @@ -1725,24 +1835,24 @@ tail += driveNameLen; } } /* - * To process a [glob] invokation, this function may be called - * multiple times. Each time, the previously discovered filenames - * are in the interpreter result. We stash that away here so the - * result is free for error messsages. + * To process a [glob] invokation, this function may be called multiple + * times. Each time, the previously discovered filenames are in the + * interpreter result. We stash that away here so the result is free for + * error messsages. */ savedResultObj = Tcl_GetObjResult(interp); Tcl_IncrRefCount(savedResultObj); Tcl_ResetResult(interp); TclNewObj(filenamesObj); /* - * Now we do the actual globbing, adding filenames as we go to - * buffer in filenamesObj + * Now we do the actual globbing, adding filenames as we go to buffer in + * filenamesObj */ if (*tail == '\0' && pathPrefix != NULL) { /* * An empty pattern @@ -1768,41 +1878,40 @@ TclDecrRefCount(savedResultObj); return result; } /* - * If we only want the tails, we must strip off the prefix now. - * It may seem more efficient to pass the tails flag down into - * DoGlob, Tcl_FSMatchInDirectory, but those functions are - * continually adjusting the prefix as the various pieces of - * the pattern are assimilated, so that would add a lot of - * complexity to the code. This way is a little slower (when - * the -tails flag is given), but much simpler to code. + * If we only want the tails, we must strip off the prefix now. It may + * seem more efficient to pass the tails flag down into DoGlob, + * Tcl_FSMatchInDirectory, but those functions are continually adjusting + * the prefix as the various pieces of the pattern are assimilated, so + * that would add a lot of complexity to the code. This way is a little + * slower (when the -tails flag is given), but much simpler to code. * * We do it by rewriting the result list in-place. */ if (globFlags & TCL_GLOBMODE_TAILS) { int objc, i; Tcl_Obj **objv; int prefixLen; - /* If this length has never been set, set it here */ + /* + * If this length has never been set, set it here. + */ + CONST char *pre = Tcl_GetStringFromObj(pathPrefix, &prefixLen); - if (prefixLen > 0 - && (strchr(separators, pre[prefixLen-1]) == NULL)) { - - /* - * If we're on Windows and the prefix is a volume - * relative one like 'C:', then there won't be - * a path separator in between, so no need to - * skip it here. + if (prefixLen > 0 + && (strchr(separators, pre[prefixLen-1]) == NULL)) { + /* + * If we're on Windows and the prefix is a volume relative one + * like 'C:', then there won't be a path separator in between, so + * no need to skip it here. */ - - if ((tclPlatform != TCL_PLATFORM_WINDOWS) - || (prefixLen != 2) - || (pre[1] != ':')) { + + if ((tclPlatform != TCL_PLATFORM_WINDOWS) || (prefixLen != 2) + || (pre[1] != ':')) { prefixLen++; } } Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv); @@ -1817,22 +1926,20 @@ elems[0] = Tcl_NewStringObj(".", 1); } else { elems[0] = Tcl_NewStringObj("/", 1); } } else { - elems[0] = Tcl_NewStringObj(oldStr + prefixLen, - len - prefixLen); + elems[0] = Tcl_NewStringObj(oldStr+prefixLen, len-prefixLen); } Tcl_ListObjReplace(interp, filenamesObj, i, 1, 1, elems); } } /* - * Now we have a list of discovered filenames in filenamesObj and - * a list of previously discovered (saved earlier from the - * interpreter result) in savedResultObj. Merge them and put them - * back in the interpreter result. + * Now we have a list of discovered filenames in filenamesObj and a list + * of previously discovered (saved earlier from the interpreter result) in + * savedResultObj. Merge them and put them back in the interpreter result. */ if (Tcl_IsShared(savedResultObj)) { TclDecrRefCount(savedResultObj); savedResultObj = Tcl_DuplicateObj(savedResultObj); @@ -1852,18 +1959,17 @@ /* *---------------------------------------------------------------------- * * SkipToChar -- * - * This function traverses a glob pattern looking for the next - * unquoted occurance of the specified character at the same braces - * nesting level. + * This function traverses a glob pattern looking for the next unquoted + * occurance of the specified character at the same braces nesting level. * * Results: - * Updates stringPtr to point to the matching character, or to - * the end of the string if nothing matched. The return value - * is 1 if a match was found at the top level, otherwise it is 0. + * Updates stringPtr to point to the matching character, or to the end of + * the string if nothing matched. The return value is 1 if a match was + * found at the top level, otherwise it is 0. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -1904,26 +2010,25 @@ /* *---------------------------------------------------------------------- * * DoGlob -- * - * This recursive procedure forms the heart of the globbing code. - * It performs a depth-first traversal of the tree given by the - * path name to be globbed and the pattern. The directory and - * remainder are assumed to be native format paths. The prefix - * contained in 'pathPtr' is either a directory or path from which - * to start the search (or NULL). If pathPtr is NULL, then the - * pattern must not start with an absolute path specification - * (that case should be handled by moving the absolute path + * This recursive procedure forms the heart of the globbing code. It + * performs a depth-first traversal of the tree given by the path name to + * be globbed and the pattern. The directory and remainder are assumed to + * be native format paths. The prefix contained in 'pathPtr' is either a + * directory or path from which to start the search (or NULL). If pathPtr + * is NULL, then the pattern must not start with an absolute path + * specification (that case should be handled by moving the absolute path * prefix into pathPtr before calling DoGlob). * * Results: - * The return value is a standard Tcl result indicating whether - * an error occurred in globbing. After a normal return the - * result in interp will be set to hold all of the file names - * given by the dir and remaining arguments. After an error the - * result in interp will hold an error message. + * The return value is a standard Tcl result indicating whether an error + * occurred in globbing. After a normal return the result in interp will + * be set to hold all of the file names given by the dir and remaining + * arguments. After an error the result in interp will hold an error + * message. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -1931,46 +2036,46 @@ static int DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) Tcl_Interp *interp; /* Interpreter to use for error reporting * (e.g. unmatched brace). */ - Tcl_Obj *matchesObj; /* Unshared list object in which to place all + Tcl_Obj *matchesObj; /* Unshared list object in which to place all * resulting filenames. Caller allocates and * deallocates; DoGlob must not touch the * refCount of this object. */ - char *separators; /* String containing separator characters - * that should be used to identify globbing + char *separators; /* String containing separator characters that + * should be used to identify globbing * boundaries. */ - Tcl_Obj *pathPtr; /* Completely expanded prefix. */ - int flags; /* If non-zero then pathPtr is a - * directory */ - char *pattern; /* The pattern to match against. - * Must not be a pointer to a static string. */ + Tcl_Obj *pathPtr; /* Completely expanded prefix. */ + int flags; /* If non-zero then pathPtr is a directory */ + char *pattern; /* The pattern to match against. Must not be + * a pointer to a static string. */ Tcl_GlobTypeData *types; /* List object containing list of acceptable * types. May be NULL. */ { int baseLength, quoted, count; int result = TCL_OK; char *name, *p, *openBrace, *closeBrace, *firstSpecialChar; Tcl_Obj *joinedPtr; /* - * Consume any leading directory separators, leaving pattern pointing - * just past the last initial separator. + * Consume any leading directory separators, leaving pattern pointing just + * past the last initial separator. */ count = 0; name = pattern; for (; *pattern != '\0'; pattern++) { if (*pattern == '\\') { /* * If the first character is escaped, either we have a directory * separator, or we have any other character. In the latter case - * the rest is a pattern, and we must break from the loop. - * This is particularly important on Windows where '\' is both - * the escaping character and a directory separator. + * the rest is a pattern, and we must break from the loop. This + * is particularly important on Windows where '\' is both the + * escaping character and a directory separator. */ + if (strchr(separators, pattern[1]) != NULL) { pattern++; } else { break; } @@ -1979,36 +2084,37 @@ } count++; } /* - * This block of code is not exercised by the Tcl test suite as of - * Tcl 8.5a0. Simplifications to the calling paths suggest it may - * not be necessary any more, since path separators are handled - * elsewhere. It is left in place in case new bugs are reported + * This block of code is not exercised by the Tcl test suite as of Tcl + * 8.5a0. Simplifications to the calling paths suggest it may not be + * necessary any more, since path separators are handled elsewhere. It is + * left in place in case new bugs are reported */ #if 0 /* PROBABLY_OBSOLETE */ /* * Deal with path separators. */ + if (pathPtr == NULL) { /* - * Length used to be the length of the prefix, and lastChar - * the lastChar of the prefix. But, none of this is used - * any more. + * Length used to be the length of the prefix, and lastChar the + * lastChar of the prefix. But, none of this is used any more. */ + int length = 0; char lastChar = 0; switch (tclPlatform) { case TCL_PLATFORM_WINDOWS: /* * If this is a drive relative path, add the colon and the - * trailing slash if needed. Otherwise add the slash if - * this is the first absolute element, or a later relative - * element. Add an extra slash if this is a UNC path. + * trailing slash if needed. Otherwise add the slash if this is + * the first absolute element, or a later relative element. Add + * an extra slash if this is a UNC path. */ if (*name == ':') { Tcl_DStringAppend(&append, ":", 1); if (count > 1) { @@ -2024,12 +2130,12 @@ } break; case TCL_PLATFORM_UNIX: /* - * Add a separator if this is the first absolute element, or - * a later relative element. + * Add a separator if this is the first absolute element, or a + * later relative element. */ if ((*pattern != '\0') && (((length > 0) && (strchr(separators, lastChar) == NULL)) || ((length == 0) && (count > 0)))) { @@ -2039,39 +2145,50 @@ } } #endif /* PROBABLY_OBSOLETE */ /* - * Look for the first matching pair of braces or the first - * directory separator that is not inside a pair of braces. + * Look for the first matching pair of braces or the first directory + * separator that is not inside a pair of braces. */ openBrace = closeBrace = NULL; quoted = 0; for (p = pattern; *p != '\0'; p++) { if (quoted) { quoted = 0; + } else if (*p == '\\') { quoted = 1; if (strchr(separators, p[1]) != NULL) { - /* Quoted directory separator. */ + /* + * Quoted directory separator. + */ break; } + } else if (strchr(separators, *p) != NULL) { - /* Unquoted directory separator. */ + /* + * Unquoted directory separator. + */ break; + } else if (*p == '{') { openBrace = p; p++; if (SkipToChar(&p, '}')) { - /* Balanced braces. */ + /* + * Balanced braces. + */ + closeBrace = p; break; } Tcl_SetResult(interp, "unmatched open-brace in file name", TCL_STATIC); return TCL_ERROR; + } else if (*p == '}') { Tcl_SetResult(interp, "unmatched close-brace in file name", TCL_STATIC); return TCL_ERROR; } @@ -2086,13 +2203,13 @@ Tcl_DString newName; Tcl_DStringInit(&newName); /* - * For each element within in the outermost pair of braces, - * append the element and the remainder to the fixed portion - * before the first brace and recursively call DoGlob. + * For each element within in the outermost pair of braces, append the + * element and the remainder to the fixed portion before the first + * brace and recursively call DoGlob. */ Tcl_DStringAppend(&newName, pattern, openBrace-pattern); baseLength = Tcl_DStringLength(&newName); *closeBrace = '\0'; @@ -2113,31 +2230,31 @@ Tcl_DStringFree(&newName); return result; } /* - * At this point, there are no more brace substitutions to perform on - * this path component. The variable p is pointing at a quoted or - * unquoted directory separator or the end of the string. So we need - * to check for special globbing characters in the current pattern. - * We avoid modifying pattern if p is pointing at the end of the string. + * At this point, there are no more brace substitutions to perform on this + * path component. The variable p is pointing at a quoted or unquoted + * directory separator or the end of the string. So we need to check for + * special globbing characters in the current pattern. We avoid modifying + * pattern if p is pointing at the end of the string. * * If we find any globbing characters, then we must call - * Tcl_FSMatchInDirectory. If we're at the end of the string, then - * that's all we need to do. If we're not at the end of the - * string, then we must recurse, so we do that below. - * - * Alternatively, if there are no globbing characters then again - * there are two cases. If we're at the end of the string, we just - * need to check for the given path's existence and type. If we're - * not at the end of the string, we recurse. + * Tcl_FSMatchInDirectory. If we're at the end of the string, then that's + * all we need to do. If we're not at the end of the string, then we must + * recurse, so we do that below. + * + * Alternatively, if there are no globbing characters then again there are + * two cases. If we're at the end of the string, we just need to check for + * the given path's existence and type. If we're not at the end of the + * string, we recurse. */ if (*p != '\0') { /* - * Note that we are modifying the string in place. This won't work - * if the string is a static. + * Note that we are modifying the string in place. This won't work if + * the string is a static. */ char savedChar = *p; *p = '\0'; firstSpecialChar = strpbrk(pattern, "*[]?\\"); @@ -2146,14 +2263,13 @@ firstSpecialChar = strpbrk(pattern, "*[]?\\"); } if (firstSpecialChar != NULL) { /* - * Look for matching files in the given directory. The - * implementation of this function is filesystem specific. For - * each file that matches, it will add the match onto the - * resultPtr given. + * Look for matching files in the given directory. The implementation + * of this function is filesystem specific. For each file that + * matches, it will add the match onto the resultPtr given. */ static Tcl_GlobTypeData dirOnly = { TCL_GLOB_TYPE_DIR, 0, NULL, NULL }; @@ -2164,11 +2280,11 @@ return Tcl_FSMatchInDirectory(interp, matchesObj, pathPtr, pattern, types); } /* - * We do the recursion ourselves. This makes implementing + * We do the recursion ourselves. This makes implementing * Tcl_FSMatchInDirectory for each filesystem much easier. */ *p = '\0'; TclNewObj(subdirsPtr); @@ -2196,17 +2312,17 @@ if (*p == '\0') { /* * This is the code path reached by a command like 'glob foo'. * - * There are no more wildcards in the pattern and no more - * unprocessed characters in the pattern, so now we can construct - * the path, and pass it to Tcl_FSMatchInDirectory with an - * empty pattern to verify the existence of the file and check - * it is of the correct type (if a 'types' flag it given -- if - * no such flag was given, we could just use 'Tcl_FSLStat', but - * for simplicity we keep to a common approach). + * There are no more wildcards in the pattern and no more unprocessed + * characters in the pattern, so now we can construct the path, and + * pass it to Tcl_FSMatchInDirectory with an empty pattern to verify + * the existence of the file and check it is of the correct type (if a + * 'types' flag it given -- if no such flag was given, we could just + * use 'Tcl_FSLStat', but for simplicity we keep to a common + * approach). */ int length; Tcl_DString append; @@ -2227,10 +2343,11 @@ Tcl_DStringAppend(&append, "/", 1); } else { Tcl_DStringAppend(&append, ".", 1); } } + #if defined(__CYGWIN__) && defined(__WIN32__) { extern int cygwin_conv_to_win32_path(CONST char *, char *); char winbuf[MAX_PATH+1]; @@ -2238,10 +2355,11 @@ Tcl_DStringFree(&append); Tcl_DStringAppend(&append, winbuf, -1); } #endif /* __CYGWIN__ && __WIN32__ */ break; + case TCL_PLATFORM_UNIX: if (length == 0 && (Tcl_DStringLength(&append) == 0)) { if ((*name == '\\' && name[1] == '/') || (*name == '/')) { Tcl_DStringAppend(&append, "/", 1); } else { @@ -2248,19 +2366,35 @@ Tcl_DStringAppend(&append, ".", 1); } } break; } - /* Common for all platforms */ + + /* + * Common for all platforms. + */ + if (pathPtr == NULL) { joinedPtr = Tcl_NewStringObj(Tcl_DStringValue(&append), Tcl_DStringLength(&append)); } else if (flags) { joinedPtr = TclNewFSPathObj(pathPtr, Tcl_DStringValue(&append), Tcl_DStringLength(&append)); } else { joinedPtr = Tcl_DuplicateObj(pathPtr); + if (strchr(separators, Tcl_DStringValue(&append)[0]) == NULL) { + /* + * The current prefix must end in a separator. + */ + + int len; + CONST char *joined = Tcl_GetStringFromObj(joinedPtr,&len); + + if (strchr(separators, joined[len-1]) == NULL) { + Tcl_AppendToObj(joinedPtr, "/", 1); + } + } Tcl_AppendToObj(joinedPtr, Tcl_DStringValue(&append), Tcl_DStringLength(&append)); } Tcl_IncrRefCount(joinedPtr); Tcl_DStringFree(&append); @@ -2277,10 +2411,28 @@ joinedPtr = Tcl_NewStringObj(pattern, p-pattern); } else if (flags) { joinedPtr = TclNewFSPathObj(pathPtr, pattern, p-pattern); } else { joinedPtr = Tcl_DuplicateObj(pathPtr); + if (strchr(separators, pattern[0]) == NULL) { + /* + * The current prefix must end in a separator, unless this is a + * volume-relative path. In particular globbing in Windows + * shares, when not using -dir or -path, e.g. 'glob [file join + * //machine/share/subdir *]' requires adding a separator here. + * This behaviour is not currently tested for in the test suite. + */ + + int len; + CONST char *joined = Tcl_GetStringFromObj(joinedPtr,&len); + + if (strchr(separators, joined[len-1]) == NULL) { + if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) { + Tcl_AppendToObj(joinedPtr, "/", 1); + } + } + } Tcl_AppendToObj(joinedPtr, pattern, p-pattern); } Tcl_IncrRefCount(joinedPtr); result = DoGlob(interp, matchesObj, separators, joinedPtr, 1, p, types); @@ -2290,25 +2442,33 @@ } /* *--------------------------------------------------------------------------- * - * Tcl_AllocStatBuf + * Tcl_AllocStatBuf -- * - * This procedure allocates a Tcl_StatBuf on the heap. It exists - * so that extensions may be used unchanged on systems where - * largefile support is optional. + * This procedure allocates a Tcl_StatBuf on the heap. It exists so that + * extensions may be used unchanged on systems where largefile support is + * optional. * * Results: - * A pointer to a Tcl_StatBuf which may be deallocated by being - * passed to ckfree(). + * A pointer to a Tcl_StatBuf which may be deallocated by being passed to + * ckfree(). * * Side effects: - * None. + * None. * *--------------------------------------------------------------------------- */ Tcl_StatBuf * Tcl_AllocStatBuf() { return (Tcl_StatBuf *) ckalloc(sizeof(Tcl_StatBuf)); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclGet.c ================================================================== --- generic/tclGet.c +++ generic/tclGet.c @@ -1,23 +1,22 @@ -/* +/* * tclGet.c -- * - * This file contains procedures to convert strings into - * other forms, like integers or floating-point numbers or - * booleans, doing syntax checking along the way. + * This file contains functions to convert strings into other forms, like + * integers or floating-point numbers or booleans, doing syntax checking + * along the way. * * Copyright (c) 1990-1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclGet.c,v 1.9 2004/04/06 22:25:51 dgp Exp $ + * RCS: @(#) $Id: tclGet.c,v 1.9.2.5 2005/08/02 18:15:29 dgp Exp $ */ #include "tclInt.h" -#include /* *---------------------------------------------------------------------- * @@ -24,175 +23,85 @@ * Tcl_GetInt -- * * Given a string, produce the corresponding integer value. * * Results: - * The return value is normally TCL_OK; in this case *intPtr - * will be set to the integer value equivalent to string. If - * string is improperly formed then TCL_ERROR is returned and - * an error message will be left in the interp's result. + * The return value is normally TCL_OK; in this case *intPtr will be set + * to the integer value equivalent to src. If src is improperly formed + * then TCL_ERROR is returned and an error message will be left in the + * interp's result. * * Side effects: * None. * *---------------------------------------------------------------------- */ int -Tcl_GetInt(interp, string, intPtr) +Tcl_GetInt(interp, src, intPtr) Tcl_Interp *interp; /* Interpreter to use for error reporting. */ - CONST char *string; /* String containing a (possibly signed) - * integer in a form acceptable to strtol. */ + CONST char *src; /* String containing a (possibly signed) + * integer in a form acceptable to strtoul. */ int *intPtr; /* Place to store converted result. */ { - char *end; - CONST char *p = string; - long i; - - /* - * Note: use strtoul instead of strtol for integer conversions - * to allow full-size unsigned numbers, but don't depend on strtoul - * to handle sign characters; it won't in some implementations. - */ - - errno = 0; -#ifdef TCL_STRTOUL_SIGN_CHECK - /* - * This special sign check actually causes bad numbers to be allowed - * when strtoul. I can't find a strtoul that doesn't validly handle - * signed characters, and the C standard implies that this is all - * unnecessary. [Bug #634856] - */ - for ( ; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */ - /* Empty loop body. */ - } - if (*p == '-') { - p++; - i = -((long)strtoul(p, &end, 0)); /* INTL: Tcl source. */ - } else if (*p == '+') { - p++; - i = strtoul(p, &end, 0); /* INTL: Tcl source. */ - } else -#else - i = strtoul(p, &end, 0); /* INTL: Tcl source. */ -#endif - if (end == p) { - badInteger: - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "expected integer but got \"", string, - "\"", (char *) NULL); - TclCheckBadOctal(interp, string); - } - return TCL_ERROR; - } - - /* - * The second test below is needed on platforms where "long" is - * larger than "int" to detect values that fit in a long but not in - * an int. - */ - - if ((errno == ERANGE) || (((long)(int) i) != i)) { - if (interp != (Tcl_Interp *) NULL) { - Tcl_SetResult(interp, "integer value too large to represent", - TCL_STATIC); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - Tcl_GetStringResult(interp), (char *) NULL); - } - return TCL_ERROR; - } - while ((*end != '\0') && isspace(UCHAR(*end))) { /* INTL: ISO space. */ - end++; - } - if (*end != 0) { - goto badInteger; - } - *intPtr = (int) i; - return TCL_OK; + Tcl_Obj obj; + int code; + + obj.refCount = 1; + obj.bytes = (char *) src; + obj.length = strlen(src); + obj.typePtr = NULL; + + code = Tcl_GetIntFromObj(interp, &obj, intPtr); + if (obj.refCount > 1) { + Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); + } + return code; } /* *---------------------------------------------------------------------- * * TclGetLong -- * - * Given a string, produce the corresponding long integer value. - * This routine is a version of Tcl_GetInt but returns a "long" - * instead of an "int". + * Given a string, produce the corresponding long integer value. This + * routine is a version of Tcl_GetInt but returns a "long" instead of an + * "int" (a difference that matters on 64-bit architectures). * * Results: - * The return value is normally TCL_OK; in this case *longPtr - * will be set to the long integer value equivalent to string. If - * string is improperly formed then TCL_ERROR is returned and - * an error message will be left in the interp's result if interp - * is non-NULL. + * The return value is normally TCL_OK; in this case *longPtr will be set + * to the long integer value equivalent to src. If src is improperly + * formed then TCL_ERROR is returned and an error message will be left in + * the interp's result if interp is non-NULL. * * Side effects: * None. * *---------------------------------------------------------------------- */ int -TclGetLong(interp, string, longPtr) - Tcl_Interp *interp; /* Interpreter used for error reporting - * if not NULL. */ - CONST char *string; /* String containing a (possibly signed) - * long integer in a form acceptable to - * strtoul. */ +TclGetLong(interp, src, longPtr) + Tcl_Interp *interp; /* Interpreter used for error reporting if not + * NULL. */ + CONST char *src; /* String containing a (possibly signed) long + * integer in a form acceptable to strtoul. */ long *longPtr; /* Place to store converted long result. */ { - char *end; - CONST char *p = string; - long i; - - /* - * Note: don't depend on strtoul to handle sign characters; it won't - * in some implementations. - */ - - errno = 0; -#ifdef TCL_STRTOUL_SIGN_CHECK - for ( ; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */ - /* Empty loop body. */ - } - if (*p == '-') { - p++; - i = -(int)strtoul(p, &end, 0); /* INTL: Tcl source. */ - } else if (*p == '+') { - p++; - i = strtoul(p, &end, 0); /* INTL: Tcl source. */ - } else -#else - i = strtoul(p, &end, 0); /* INTL: Tcl source. */ -#endif - if (end == p) { - badInteger: - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "expected integer but got \"", string, - "\"", (char *) NULL); - TclCheckBadOctal(interp, string); - } - return TCL_ERROR; - } - if (errno == ERANGE) { - if (interp != (Tcl_Interp *) NULL) { - Tcl_SetResult(interp, "integer value too large to represent", - TCL_STATIC); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - Tcl_GetStringResult(interp), (char *) NULL); - } - return TCL_ERROR; - } - while ((*end != '\0') && isspace(UCHAR(*end))) { /* INTL: ISO space. */ - end++; - } - if (*end != 0) { - goto badInteger; - } - *longPtr = i; - return TCL_OK; + Tcl_Obj obj; + int code; + + obj.refCount = 1; + obj.bytes = (char *) src; + obj.length = strlen(src); + obj.typePtr = NULL; + + code = Tcl_GetLongFromObj(interp, &obj, longPtr); + if (obj.refCount > 1) { + Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); + } + return code; } /* *---------------------------------------------------------------------- * @@ -200,135 +109,92 @@ * * Given a string, produce the corresponding double-precision * floating-point value. * * Results: - * The return value is normally TCL_OK; in this case *doublePtr - * will be set to the double-precision value equivalent to string. - * If string is improperly formed then TCL_ERROR is returned and - * an error message will be left in the interp's result. + * The return value is normally TCL_OK; in this case *doublePtr will be + * set to the double-precision value equivalent to src. If src is + * improperly formed then TCL_ERROR is returned and an error message will + * be left in the interp's result. * * Side effects: * None. * *---------------------------------------------------------------------- */ int -Tcl_GetDouble(interp, string, doublePtr) +Tcl_GetDouble(interp, src, doublePtr) Tcl_Interp *interp; /* Interpreter used for error reporting. */ - CONST char *string; /* String containing a floating-point number + CONST char *src; /* String containing a floating-point number * in a form acceptable to strtod. */ double *doublePtr; /* Place to store converted result. */ { - char *end; - double d; - - errno = 0; - d = strtod(string, &end); /* INTL: Tcl source. */ - if (end == string) { - badDouble: - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, - "expected floating-point number but got \"", - string, "\"", (char *) NULL); - } - return TCL_ERROR; - } - if (errno != 0 && (d == HUGE_VAL || d == -HUGE_VAL || d == 0)) { - if (interp != (Tcl_Interp *) NULL) { - TclExprFloatError(interp, d); - } - return TCL_ERROR; - } - while ((*end != 0) && isspace(UCHAR(*end))) { /* INTL: ISO space. */ - end++; - } - if (*end != 0) { - goto badDouble; - } - *doublePtr = d; - return TCL_OK; + Tcl_Obj obj; + int code; + + obj.refCount = 1; + obj.bytes = (char *) src; + obj.length = strlen(src); + obj.typePtr = NULL; + + code = Tcl_GetDoubleFromObj(interp, &obj, doublePtr); + if (obj.refCount > 1) { + Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); + } + return code; } /* *---------------------------------------------------------------------- * * Tcl_GetBoolean -- * - * Given a string, return a 0/1 boolean value corresponding - * to the string. + * Given a string, return a 0/1 boolean value corresponding to the + * string. * * Results: - * The return value is normally TCL_OK; in this case *boolPtr - * will be set to the 0/1 value equivalent to string. If - * string is improperly formed then TCL_ERROR is returned and - * an error message will be left in the interp's result. + * The return value is normally TCL_OK; in this case *boolPtr will be set + * to the 0/1 value equivalent to src. If src is improperly formed then + * TCL_ERROR is returned and an error message will be left in the + * interp's result. * * Side effects: * None. * *---------------------------------------------------------------------- */ int -Tcl_GetBoolean(interp, string, boolPtr) +Tcl_GetBoolean(interp, src, boolPtr) Tcl_Interp *interp; /* Interpreter used for error reporting. */ - CONST char *string; /* String containing a boolean number + CONST char *src; /* String containing a boolean number * specified either as 1/0 or true/false or * yes/no. */ - int *boolPtr; /* Place to store converted result, which - * will be 0 or 1. */ -{ - int i; - char lowerCase[10], c; - size_t length; - - /* - * Convert the input string to all lower-case. - * INTL: This code will work on UTF strings. - */ - - for (i = 0; i < 9; i++) { - c = string[i]; - if (c == 0) { - break; - } - if ((c >= 'A') && (c <= 'Z')) { - c += (char) ('a' - 'A'); - } - lowerCase[i] = c; - } - lowerCase[i] = 0; - - length = strlen(lowerCase); - c = lowerCase[0]; - if ((c == '0') && (lowerCase[1] == '\0')) { - *boolPtr = 0; - } else if ((c == '1') && (lowerCase[1] == '\0')) { - *boolPtr = 1; - } else if ((c == 'y') && (strncmp(lowerCase, "yes", length) == 0)) { - *boolPtr = 1; - } else if ((c == 'n') && (strncmp(lowerCase, "no", length) == 0)) { - *boolPtr = 0; - } else if ((c == 't') && (strncmp(lowerCase, "true", length) == 0)) { - *boolPtr = 1; - } else if ((c == 'f') && (strncmp(lowerCase, "false", length) == 0)) { - *boolPtr = 0; - } else if ((c == 'o') && (length >= 2)) { - if (strncmp(lowerCase, "on", length) == 0) { - *boolPtr = 1; - } else if (strncmp(lowerCase, "off", length) == 0) { - *boolPtr = 0; - } else { - goto badBoolean; - } - } else { - badBoolean: - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "expected boolean value but got \"", - string, "\"", (char *) NULL); - } - return TCL_ERROR; - } - return TCL_OK; -} + int *boolPtr; /* Place to store converted result, which will + * be 0 or 1. */ +{ + Tcl_Obj obj; + int code; + + obj.refCount = 1; + obj.bytes = (char *) src; + obj.length = strlen(src); + obj.typePtr = NULL; + + code = Tcl_ConvertToType(interp, &obj, &tclBooleanType); + if (obj.refCount > 1) { + Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); + } + if (code == TCL_OK) { + *boolPtr = obj.internalRep.longValue; + } + return code; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclGetDate.y ================================================================== --- generic/tclGetDate.y +++ generic/tclGetDate.y @@ -9,11 +9,11 @@ * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclGetDate.y,v 1.25 2004/09/27 14:31:17 kennykb Exp $ + * RCS: @(#) $Id: tclGetDate.y,v 1.25.2.1 2004/12/29 22:47:00 kennykb Exp $ */ %{ /* * tclDate.c -- @@ -75,10 +75,12 @@ int dateHaveDay; char *dateInput; time_t *dateRelPointer; + int dateDigitCount; + } DateInfo; #define YYPARSE_PARAM info #define YYLEX_PARAM info @@ -103,10 +105,11 @@ #define yyRelMonth (((DateInfo*)info)->dateRelMonth) #define yyRelDay (((DateInfo*)info)->dateRelDay) #define yyRelSeconds (((DateInfo*)info)->dateRelSeconds) #define yyRelPointer (((DateInfo*)info)->dateRelPointer) #define yyInput (((DateInfo*)info)->dateInput) +#define yyDigitCount (((DateInfo*)info)->dateDigitCount) #define EPOCH 1970 #define START_OF_TIME 1902 #define END_OF_TIME 2037 @@ -405,11 +408,11 @@ { if (yyHaveTime && yyHaveDate && !yyHaveRel) { yyYear = $1; } else { yyHaveTime++; - if ($1 < 100) { + if (yyDigitCount <= 2) { yyHour = $1; yyMinutes = 0; } else { yyHour = $1 / 100; yyMinutes = $1 % 100; @@ -799,10 +802,11 @@ isdigit(UCHAR(c = *yyInput++)); ) { /* INTL: digit */ yylval.Number = 10 * yylval.Number + c - '0'; Count++; } yyInput--; + yyDigitCount = Count; /* A number with 6 or more digits is considered an ISO 8601 base */ if (Count >= 6) { return tISOBASE; } else { return tUNUMBER; Index: generic/tclHash.c ================================================================== --- generic/tclHash.c +++ generic/tclHash.c @@ -5,14 +5,14 @@ * applications. * * Copyright (c) 1991-1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclHash.c,v 1.22 2004/11/11 01:17:50 das Exp $ + * RCS: @(#) $Id: tclHash.c,v 1.22.2.1 2005/08/02 18:15:29 dgp Exp $ */ #include "tclInt.h" /* @@ -23,22 +23,21 @@ # undef Tcl_FindHashEntry # undef Tcl_CreateHashEntry #endif /* - * When there are this many entries per bucket, on average, rebuild - * the hash table to make it larger. + * When there are this many entries per bucket, on average, rebuild the hash + * table to make it larger. */ #define REBUILD_MULTIPLIER 3 /* - * The following macro takes a preliminary integer hash value and - * produces an index into a hash tables bucket list. The idea is - * to make it so that preliminary values that are arbitrarily similar - * will end up in different buckets. The hash function was taken - * from a random-number generator. + * The following macro takes a preliminary integer hash value and produces an + * index into a hash tables bucket list. The idea is to make it so that + * preliminary values that are arbitrarily similar will end up in different + * buckets. The hash function was taken from a random-number generator. */ #define RANDOM_INDEX(tablePtr, i) \ (((((long) (i))*1103515245) >> (tablePtr)->downShift) & (tablePtr)->mask) @@ -76,11 +75,11 @@ VOID *keyPtr, Tcl_HashEntry *hPtr)); static unsigned int HashStringKey _ANSI_ARGS_(( Tcl_HashTable *tablePtr, VOID *keyPtr)); /* - * Procedure prototypes for static procedures in this file: + * Function prototypes for static functions in this file: */ #if TCL_PRESERVE_BINARY_COMPATABILITY static Tcl_HashEntry * BogusFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, CONST char *key)); @@ -114,19 +113,18 @@ HashStringKey, /* hashKeyProc */ CompareStringKeys, /* compareKeysProc */ AllocStringEntry, /* allocEntryProc */ NULL /* freeEntryProc */ }; - /* *---------------------------------------------------------------------- * * Tcl_InitHashTable -- * - * Given storage for a hash table, set up the fields to prepare - * the hash table for use. + * Given storage for a hash table, set up the fields to prepare the hash + * table for use. * * Results: * None. * * Side effects: @@ -137,33 +135,34 @@ */ #undef Tcl_InitHashTable void Tcl_InitHashTable(tablePtr, keyType) - register Tcl_HashTable *tablePtr; /* Pointer to table record, which - * is supplied by the caller. */ + register Tcl_HashTable *tablePtr; /* Pointer to table record, which is + * supplied by the caller. */ int keyType; /* Type of keys to use in table: * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, * or an integer >= 2. */ { /* - * Use a special value to inform the extended version that it must - * not access any of the new fields in the Tcl_HashTable. If an - * extension is rebuilt then any calls to this function will be - * redirected to the extended version by a macro. + * Use a special value to inform the extended version that it must not + * access any of the new fields in the Tcl_HashTable. If an extension is + * rebuilt then any calls to this function will be redirected to the + * extended version by a macro. */ + Tcl_InitCustomHashTable(tablePtr, keyType, (Tcl_HashKeyType *) -1); } /* *---------------------------------------------------------------------- * * Tcl_InitCustomHashTable -- * - * Given storage for a hash table, set up the fields to prepare - * the hash table for use. This is an extended version of - * Tcl_InitHashTable which supports user defined keys. + * Given storage for a hash table, set up the fields to prepare the hash + * table for use. This is an extended version of Tcl_InitHashTable which + * supports user defined keys. * * Results: * None. * * Side effects: @@ -173,17 +172,17 @@ *---------------------------------------------------------------------- */ void Tcl_InitCustomHashTable(tablePtr, keyType, typePtr) - register Tcl_HashTable *tablePtr; /* Pointer to table record, which - * is supplied by the caller. */ + register Tcl_HashTable *tablePtr; /* Pointer to table record, which is + * supplied by the caller. */ int keyType; /* Type of keys to use in table: * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, * TCL_CUSTOM_TYPE_KEYS, - * TCL_CUSTOM_PTR_KEYS, or an - * integer >= 2. */ + * TCL_CUSTOM_PTR_KEYS, or an integer + * >= 2. */ Tcl_HashKeyType *typePtr; /* Pointer to structure which defines * the behaviour of this table. */ { #if (TCL_SMALL_HASH_TABLE != 4) Tcl_Panic("Tcl_InitCustomHashTable: TCL_SMALL_HASH_TABLE is %d, not 4\n", @@ -208,25 +207,26 @@ * The caller has been rebuilt so the hash table is an extended * version. */ } else if (typePtr != (Tcl_HashKeyType *) -1) { /* - * The caller is requesting a customized hash table so it must be - * an extended version. + * The caller is requesting a customized hash table so it must be an + * extended version. */ + tablePtr->typePtr = typePtr; } else { /* - * The caller has not been rebuilt so the hash table is not - * extended. + * The caller has not been rebuilt so the hash table is not extended. */ } #else if (typePtr == NULL) { /* * Use the key type to decide which key type is needed. */ + if (keyType == TCL_STRING_KEYS) { typePtr = &tclStringHashKeyType; } else if (keyType == TCL_ONE_WORD_KEYS) { typePtr = &tclOneWordHashKeyType; } else if (keyType == TCL_CUSTOM_TYPE_KEYS) { @@ -236,14 +236,15 @@ } else { typePtr = &tclArrayHashKeyType; } } else if (typePtr == (Tcl_HashKeyType *) -1) { /* - * If the caller has not been rebuilt then we cannot continue as - * the hash table is not an extended version. + * If the caller has not been rebuilt then we cannot continue as the + * hash table is not an extended version. */ - Tcl_Panic ("Hash table is not compatible"); + + Tcl_Panic("Hash table is not compatible"); } tablePtr->typePtr = typePtr; #endif } @@ -253,12 +254,12 @@ * Tcl_FindHashEntry -- * * Given a hash table find the entry with a matching key. * * Results: - * The return value is a token for the matching entry in the - * hash table, or NULL if there was no matching entry. + * The return value is a token for the matching entry in the hash table, + * or NULL if there was no matching entry. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -310,11 +311,11 @@ */ if (typePtr->compareKeysProc) { Tcl_CompareHashKeysProc *compareKeysProc = typePtr->compareKeysProc; for (hPtr = tablePtr->buckets[index]; hPtr != NULL; - hPtr = hPtr->nextPtr) { + hPtr = hPtr->nextPtr) { #if TCL_HASH_KEY_STORE_HASH if (hash != (unsigned int) hPtr->hash) { continue; } #endif @@ -322,11 +323,11 @@ return hPtr; } } } else { for (hPtr = tablePtr->buckets[index]; hPtr != NULL; - hPtr = hPtr->nextPtr) { + hPtr = hPtr->nextPtr) { #if TCL_HASH_KEY_STORE_HASH if (hash != (unsigned int) hPtr->hash) { continue; } #endif @@ -342,19 +343,19 @@ /* *---------------------------------------------------------------------- * * Tcl_CreateHashEntry -- * - * Given a hash table with string keys, and a string key, find - * the entry with a matching key. If there is no matching entry, - * then create a new entry that does match. + * Given a hash table with string keys, and a string key, find the entry + * with a matching key. If there is no matching entry, then create a new + * entry that does match. * * Results: - * The return value is a pointer to the matching entry. If this - * is a newly-created entry, then *newPtr will be set to a non-zero - * value; otherwise *newPtr will be set to 0. If this is a new - * entry the value stored in the entry will initially be 0. + * The return value is a pointer to the matching entry. If this is a + * newly-created entry, then *newPtr will be set to a non-zero value; + * otherwise *newPtr will be set to 0. If this is a new entry the value + * stored in the entry will initially be 0. * * Side effects: * A new entry may be added to the hash table. * *---------------------------------------------------------------------- @@ -363,12 +364,12 @@ Tcl_HashEntry * Tcl_CreateHashEntry(tablePtr, key, newPtr) Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ CONST char *key; /* Key to use to find or create matching * entry. */ - int *newPtr; /* Store info here telling whether a new - * entry was created. */ + int *newPtr; /* Store info here telling whether a new entry + * was created. */ { register Tcl_HashEntry *hPtr; Tcl_HashKeyType *typePtr; unsigned int hash; int index; @@ -409,11 +410,11 @@ */ if (typePtr->compareKeysProc) { Tcl_CompareHashKeysProc *compareKeysProc = typePtr->compareKeysProc; for (hPtr = tablePtr->buckets[index]; hPtr != NULL; - hPtr = hPtr->nextPtr) { + hPtr = hPtr->nextPtr) { #if TCL_HASH_KEY_STORE_HASH if (hash != (unsigned int) hPtr->hash) { continue; } #endif @@ -422,11 +423,11 @@ return hPtr; } } } else { for (hPtr = tablePtr->buckets[index]; hPtr != NULL; - hPtr = hPtr->nextPtr) { + hPtr = hPtr->nextPtr) { #if TCL_HASH_KEY_STORE_HASH if (hash != (unsigned int) hPtr->hash) { continue; } #endif @@ -436,11 +437,11 @@ } } } /* - * Entry not found. Add a new one to the bucket. + * Entry not found. Add a new one to the bucket. */ *newPtr = 1; if (typePtr->allocEntryProc) { hPtr = typePtr->allocEntryProc (tablePtr, (VOID *) key); @@ -465,12 +466,12 @@ #endif hPtr->clientData = 0; tablePtr->numEntries++; /* - * If the table has exceeded a decent size, rebuild it with many - * more buckets. + * If the table has exceeded a decent size, rebuild it with many more + * buckets. */ if (tablePtr->numEntries >= tablePtr->rebuildSize) { RebuildTable(tablePtr); } @@ -486,14 +487,13 @@ * * Results: * None. * * Side effects: - * The entry given by entryPtr is deleted from its table and - * should never again be used by the caller. It is up to the - * caller to free the clientData field of the entry, if that - * is relevant. + * The entry given by entryPtr is deleted from its table and should never + * again be used by the caller. It is up to the caller to free the + * clientData field of the entry, if that is relevant. * *---------------------------------------------------------------------- */ void @@ -563,12 +563,12 @@ /* *---------------------------------------------------------------------- * * Tcl_DeleteHashTable -- * - * Free up everything associated with a hash table except for - * the record for the table itself. + * Free up everything associated with a hash table except for the record + * for the table itself. * * Results: * None. * * Side effects: @@ -645,32 +645,30 @@ /* *---------------------------------------------------------------------- * * Tcl_FirstHashEntry -- * - * Locate the first entry in a hash table and set up a record - * that can be used to step through all the remaining entries - * of the table. + * Locate the first entry in a hash table and set up a record that can be + * used to step through all the remaining entries of the table. * * Results: - * The return value is a pointer to the first entry in tablePtr, - * or NULL if tablePtr has no entries in it. The memory at - * *searchPtr is initialized so that subsequent calls to - * Tcl_NextHashEntry will return all of the entries in the table, - * one at a time. + * The return value is a pointer to the first entry in tablePtr, or NULL + * if tablePtr has no entries in it. The memory at *searchPtr is + * initialized so that subsequent calls to Tcl_NextHashEntry will return + * all of the entries in the table, one at a time. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_HashEntry * Tcl_FirstHashEntry(tablePtr, searchPtr) - Tcl_HashTable *tablePtr; /* Table to search. */ - Tcl_HashSearch *searchPtr; /* Place to store information about - * progress through the table. */ + Tcl_HashTable *tablePtr; /* Table to search. */ + Tcl_HashSearch *searchPtr; /* Place to store information about progress + * through the table. */ { searchPtr->tablePtr = tablePtr; searchPtr->nextIndex = 0; searchPtr->nextEntryPtr = NULL; return Tcl_NextHashEntry(searchPtr); @@ -680,29 +678,30 @@ *---------------------------------------------------------------------- * * Tcl_NextHashEntry -- * * Once a hash table enumeration has been initiated by calling - * Tcl_FirstHashEntry, this procedure may be called to return - * successive elements of the table. + * Tcl_FirstHashEntry, this function may be called to return successive + * elements of the table. * * Results: - * The return value is the next entry in the hash table being - * enumerated, or NULL if the end of the table is reached. + * The return value is the next entry in the hash table being enumerated, + * or NULL if the end of the table is reached. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_HashEntry * Tcl_NextHashEntry(searchPtr) - register Tcl_HashSearch *searchPtr; /* Place to store information about - * progress through the table. Must - * have been initialized by calling - * Tcl_FirstHashEntry. */ + register Tcl_HashSearch *searchPtr; + /* Place to store information about progress + * through the table. Must have been + * initialized by calling + * Tcl_FirstHashEntry. */ { Tcl_HashEntry *hPtr; Tcl_HashTable *tablePtr = searchPtr->tablePtr; while (searchPtr->nextEntryPtr == NULL) { @@ -721,27 +720,26 @@ /* *---------------------------------------------------------------------- * * Tcl_HashStats -- * - * Return statistics describing the layout of the hash table - * in its hash buckets. + * Return statistics describing the layout of the hash table in its hash + * buckets. * * Results: - * The return value is a malloc-ed string containing information - * about tablePtr. It is the caller's responsibility to free - * this string. + * The return value is a malloc-ed string containing information about + * tablePtr. It is the caller's responsibility to free this string. * * Side effects: * None. * *---------------------------------------------------------------------- */ CONST char * Tcl_HashStats(tablePtr) - Tcl_HashTable *tablePtr; /* Table for which to produce stats. */ + Tcl_HashTable *tablePtr; /* Table for which to produce stats. */ { #define NUM_COUNTERS 10 int count[NUM_COUNTERS], overflow, i, j; double average, tmp; register Tcl_HashEntry *hPtr; @@ -793,10 +791,11 @@ } /* * Print out the histogram and a few other pieces of information. */ + if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { result = (char *) TclpSysAlloc((unsigned) (NUM_COUNTERS*60) + 300, 0); } else { result = (char *) ckalloc((unsigned) (NUM_COUNTERS*60) + 300); } @@ -864,12 +863,12 @@ * CompareArrayKeys -- * * Compares two array keys. * * Results: - * The return value is 0 if they are different and 1 if they are - * the same. + * The return value is 0 if they are different and 1 if they are the + * same. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -899,12 +898,12 @@ /* *---------------------------------------------------------------------- * * HashArrayKey -- * - * Compute a one-word summary of an array, which can be - * used to generate a hash index. + * Compute a one-word summary of an array, which can be used to generate + * a hash index. * * Results: * The return value is a one-word summary of the information in * string. * @@ -971,12 +970,12 @@ * CompareStringKeys -- * * Compares two string keys. * * Results: - * The return value is 0 if they are different and 1 if they are - * the same. + * The return value is 0 if they are different and 1 if they are the + * same. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -1008,16 +1007,15 @@ /* *---------------------------------------------------------------------- * * HashStringKey -- * - * Compute a one-word summary of a text string, which can be - * used to generate a hash index. + * Compute a one-word summary of a text string, which can be used to + * generate a hash index. * * Results: - * The return value is a one-word summary of the information in - * string. + * The return value is a one-word summary of the information in string. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -1031,23 +1029,24 @@ register CONST char *string = (CONST char *) keyPtr; register unsigned int result; register int c; /* - * I tried a zillion different hash functions and asked many other - * people for advice. Many people had their own favorite functions, - * all different, but no-one had much idea why they were good ones. - * I chose the one below (multiply by 9 and add new character) - * because of the following reasons: - * - * 1. Multiplying by 10 is perfect for keys that are decimal strings, - * and multiplying by 9 is just about as good. - * 2. Times-9 is (shift-left-3) plus (old). This means that each - * character's bits hang around in the low-order bits of the - * hash value for ever, plus they spread fairly rapidly up to - * the high-order bits to fill out the hash value. This seems - * works well both for decimal and non-decimal strings. + * I tried a zillion different hash functions and asked many other people + * for advice. Many people had their own favorite functions, all + * different, but no-one had much idea why they were good ones. I chose + * the one below (multiply by 9 and add new character) because of the + * following reasons: + * + * 1. Multiplying by 10 is perfect for keys that are decimal strings, and + * multiplying by 9 is just about as good. + * 2. Times-9 is (shift-left-3) plus (old). This means that each + * character's bits hang around in the low-order bits of the hash value + * for ever, plus they spread fairly rapidly up to the high-order bits + * to fill out the hash value. This seems works well both for decimal + * and non-decimal strings, but isn't strong against maliciously-chosen + * keys. */ result = 0; for (c=*string++ ; c ; c=*string++) { @@ -1060,16 +1059,15 @@ /* *---------------------------------------------------------------------- * * BogusFind -- * - * This procedure is invoked when an Tcl_FindHashEntry is called - * on a table that has been deleted. + * This function is invoked when an Tcl_FindHashEntry is called on a + * table that has been deleted. * * Results: - * If Tcl_Panic returns (which it shouldn't) this procedure returns - * NULL. + * If Tcl_Panic returns (which it shouldn't) this function returns NULL. * * Side effects: * Generates a panic. * *---------------------------------------------------------------------- @@ -1088,16 +1086,15 @@ /* *---------------------------------------------------------------------- * * BogusCreate -- * - * This procedure is invoked when an Tcl_CreateHashEntry is called - * on a table that has been deleted. + * This function is invoked when an Tcl_CreateHashEntry is called on a + * table that has been deleted. * * Results: - * If panic returns (which it shouldn't) this procedure returns - * NULL. + * If panic returns (which it shouldn't) this function returns NULL. * * Side effects: * Generates a panic. * *---------------------------------------------------------------------- @@ -1107,12 +1104,12 @@ static Tcl_HashEntry * BogusCreate(tablePtr, key, newPtr) Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ CONST char *key; /* Key to use to find or create matching * entry. */ - int *newPtr; /* Store info here telling whether a new - * entry was created. */ + int *newPtr; /* Store info here telling whether a new entry + * was created. */ { Tcl_Panic("called Tcl_CreateHashEntry on deleted table"); return NULL; } #endif @@ -1120,21 +1117,19 @@ /* *---------------------------------------------------------------------- * * RebuildTable -- * - * This procedure is invoked when the ratio of entries to hash - * buckets becomes too large. It creates a new table with a - * larger bucket array and moves all of the entries into the - * new table. + * This function is invoked when the ratio of entries to hash buckets + * becomes too large. It creates a new table with a larger bucket array + * and moves all of the entries into the new table. * * Results: * None. * * Side effects: - * Memory gets reallocated and entries get re-hashed to new - * buckets. + * Memory gets reallocated and entries get re-hashed to new buckets. * *---------------------------------------------------------------------- */ static void @@ -1164,12 +1159,12 @@ oldSize = tablePtr->numBuckets; oldBuckets = tablePtr->buckets; /* - * Allocate and initialize the new bucket array, and set up - * hashing constants for new array size. + * Allocate and initialize the new bucket array, and set up hashing + * constants for new array size. */ tablePtr->numBuckets *= 4; if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { tablePtr->buckets = (Tcl_HashEntry **) TclpSysAlloc((unsigned) @@ -1234,5 +1229,13 @@ } else { ckfree((char *) oldBuckets); } } } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclIO.c ================================================================== --- generic/tclIO.c +++ generic/tclIO.c @@ -1,6 +1,6 @@ -/* +/* * tclIO.c -- * * This file provides the generic portions (those that are the same on * all platforms and for all channel types) of Tcl's IO facilities. * @@ -8,63 +8,51 @@ * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIO.c,v 1.81 2004/11/30 19:34:47 dgp Exp $ + * RCS: @(#) $Id: tclIO.c,v 1.81.2.10 2005/10/08 13:44:37 dgp Exp $ */ #include "tclInt.h" #include "tclIO.h" #include - /* - * All static variables used in this file are collected into a single - * instance of the following structure. For multi-threaded implementations, - * there is one instance of this structure for each thread. + * All static variables used in this file are collected into a single instance + * of the following structure. For multi-threaded implementations, there is + * one instance of this structure for each thread. * - * Notice that different structures with the same name appear in other - * files. The structure defined below is used in this file only. + * Notice that different structures with the same name appear in other files. + * The structure defined below is used in this file only. */ typedef struct ThreadSpecificData { - /* - * This variable holds the list of nested ChannelHandlerEventProc - * invocations. - */ NextChannelHandler *nestedHandlerPtr; - - /* - * List of all channels currently open, indexed by ChannelState, - * as only one ChannelState exists per set of stacked channels. - */ - ChannelState *firstCSPtr; - + /* This variable holds the list of + * nested ChannelHandlerEventProc + * invocations. */ + ChannelState *firstCSPtr; /* List of all channels currently + * open, indexed by ChannelState, as + * only one ChannelState exists per + * set of stacked channels. */ #ifdef oldcode - /* - * Has a channel exit handler been created yet? - */ - int channelExitHandlerCreated; - - /* - * Has the channel event source been created and registered with the - * notifier? - */ - int channelEventSourceCreated; + int channelExitHandlerCreated; /* Has a channel exit handler been + * created yet? */ + int channelEventSourceCreated; /* Has the channel event source been + * created and registered with the + * notifier? */ #endif - - /* - * Static variables to hold channels for stdin, stdout and stderr. - */ - Tcl_Channel stdinChannel; + Tcl_Channel stdinChannel; /* Static variable for the stdin + * channel. */ int stdinInitialized; - Tcl_Channel stdoutChannel; + Tcl_Channel stdoutChannel; /* Static variable for the stdout + * channel. */ int stdoutInitialized; - Tcl_Channel stderrChannel; + Tcl_Channel stderrChannel; /* Static variable for the stderr + * channel. */ int stderrInitialized; - } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* @@ -146,18 +134,24 @@ static void UpdateInterest _ANSI_ARGS_((Channel *chanPtr)); static int WriteBytes _ANSI_ARGS_((Channel *chanPtr, CONST char *src, int srcLen)); static int WriteChars _ANSI_ARGS_((Channel *chanPtr, CONST char *src, int srcLen)); +static Tcl_Obj* FixLevelCode _ANSI_ARGS_ ((Tcl_Obj* msg)); + + +static void SpliceChannel _ANSI_ARGS_ ((Tcl_Channel chan)); +static void CutChannel _ANSI_ARGS_ ((Tcl_Channel chan)); + /* *--------------------------------------------------------------------------- * * TclInitIOSubsystem -- * * Initialize all resources used by this subsystem on a per-process - * basis. + * basis. * * Results: * None. * * Side effects: @@ -168,24 +162,25 @@ void TclInitIOSubsystem() { /* - * By fetching thread local storage we take care of - * allocating it for each thread. + * By fetching thread local storage we take care of allocating it for each + * thread. */ + (void) TCL_TSD_INIT(&dataKey); -} +} /* *------------------------------------------------------------------------- * * TclFinalizeIOSubsystem -- * - * Releases all resources used by this subsystem on a per-process - * basis. Closes all extant channels that have not already been - * closed because they were not owned by any interp. + * Releases all resources used by this subsystem on a per-process basis. + * Closes all extant channels that have not already been closed because + * they were not owned by any interp. * * Results: * None. * * Side effects: @@ -207,50 +202,47 @@ statePtr = nextCSPtr) { chanPtr = statePtr->topChanPtr; nextCSPtr = statePtr->nextCSPtr; /* - * Set the channel back into blocking mode to ensure that we wait - * for all data to flush out. + * Set the channel back into blocking mode to ensure that we wait for + * all data to flush out. */ (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr, "-blocking", "on"); if ((chanPtr == (Channel *) tsdPtr->stdinChannel) || (chanPtr == (Channel *) tsdPtr->stdoutChannel) || (chanPtr == (Channel *) tsdPtr->stderrChannel)) { - /* - * Decrement the refcount which was earlier artificially bumped - * up to keep the channel from being closed. + * Decrement the refcount which was earlier artificially bumped up + * to keep the channel from being closed. */ statePtr->refCount--; } if (statePtr->refCount <= 0) { - /* * Close it only if the refcount indicates that the channel is not - * referenced from any interpreter. If it is, that interpreter will - * close the channel when it gets destroyed. + * referenced from any interpreter. If it is, that interpreter + * will close the channel when it gets destroyed. */ (void) Tcl_Close((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); } else { - /* * The refcount is greater than zero, so flush the channel. */ Tcl_Flush((Tcl_Channel) chanPtr); /* - * Call the device driver to actually close the underlying - * device for this channel. + * Call the device driver to actually close the underlying device + * for this channel. */ if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) { (chanPtr->typePtr->closeProc)(chanPtr->instanceData, (Tcl_Interp *) NULL); @@ -268,19 +260,20 @@ chanPtr->instanceData = (ClientData) NULL; statePtr->flags |= CHANNEL_DEAD; } } + TclpFinalizePipes(); } /* *---------------------------------------------------------------------- * * Tcl_SetStdChannel -- * - * This function is used to change the channels that are used - * for stdin/stdout/stderr in new interpreters. + * This function is used to change the channels that are used for + * stdin/stdout/stderr in new interpreters. * * Results: * None * * Side effects: @@ -294,22 +287,22 @@ Tcl_Channel channel; int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); switch (type) { - case TCL_STDIN: - tsdPtr->stdinInitialized = 1; - tsdPtr->stdinChannel = channel; - break; - case TCL_STDOUT: - tsdPtr->stdoutInitialized = 1; - tsdPtr->stdoutChannel = channel; - break; - case TCL_STDERR: - tsdPtr->stderrInitialized = 1; - tsdPtr->stderrChannel = channel; - break; + case TCL_STDIN: + tsdPtr->stdinInitialized = 1; + tsdPtr->stdinChannel = channel; + break; + case TCL_STDOUT: + tsdPtr->stdoutInitialized = 1; + tsdPtr->stdoutChannel = channel; + break; + case TCL_STDERR: + tsdPtr->stderrInitialized = 1; + tsdPtr->stderrChannel = channel; + break; } } /* *---------------------------------------------------------------------- @@ -320,12 +313,11 @@ * * Results: * Returns the specified standard channel, or NULL. * * Side effects: - * May cause the creation of a standard channel and the underlying - * file. + * May cause the creation of a standard channel and the underlying file. * *---------------------------------------------------------------------- */ Tcl_Channel @@ -334,58 +326,58 @@ { Tcl_Channel channel = NULL; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* - * If the channels were not created yet, create them now and - * store them in the static variables. + * If the channels were not created yet, create them now and store them in + * the static variables. */ switch (type) { - case TCL_STDIN: - if (!tsdPtr->stdinInitialized) { - tsdPtr->stdinChannel = TclpGetDefaultStdChannel(TCL_STDIN); - tsdPtr->stdinInitialized = 1; - - /* - * Artificially bump the refcount to ensure that the channel - * is only closed on exit. - * - * NOTE: Must only do this if stdinChannel is not NULL. It - * can be NULL in situations where Tcl is unable to connect - * to the standard input. - */ - - if (tsdPtr->stdinChannel != (Tcl_Channel) NULL) { - (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, - tsdPtr->stdinChannel); - } - } - channel = tsdPtr->stdinChannel; - break; - case TCL_STDOUT: - if (!tsdPtr->stdoutInitialized) { - tsdPtr->stdoutChannel = TclpGetDefaultStdChannel(TCL_STDOUT); - tsdPtr->stdoutInitialized = 1; - if (tsdPtr->stdoutChannel != (Tcl_Channel) NULL) { - (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, - tsdPtr->stdoutChannel); - } - } - channel = tsdPtr->stdoutChannel; - break; - case TCL_STDERR: - if (!tsdPtr->stderrInitialized) { - tsdPtr->stderrChannel = TclpGetDefaultStdChannel(TCL_STDERR); - tsdPtr->stderrInitialized = 1; - if (tsdPtr->stderrChannel != (Tcl_Channel) NULL) { - (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, - tsdPtr->stderrChannel); - } - } - channel = tsdPtr->stderrChannel; - break; + case TCL_STDIN: + if (!tsdPtr->stdinInitialized) { + tsdPtr->stdinChannel = TclpGetDefaultStdChannel(TCL_STDIN); + tsdPtr->stdinInitialized = 1; + + /* + * Artificially bump the refcount to ensure that the channel is + * only closed on exit. + * + * NOTE: Must only do this if stdinChannel is not NULL. It can be + * NULL in situations where Tcl is unable to connect to the + * standard input. + */ + + if (tsdPtr->stdinChannel != (Tcl_Channel) NULL) { + (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, + tsdPtr->stdinChannel); + } + } + channel = tsdPtr->stdinChannel; + break; + case TCL_STDOUT: + if (!tsdPtr->stdoutInitialized) { + tsdPtr->stdoutChannel = TclpGetDefaultStdChannel(TCL_STDOUT); + tsdPtr->stdoutInitialized = 1; + if (tsdPtr->stdoutChannel != (Tcl_Channel) NULL) { + (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, + tsdPtr->stdoutChannel); + } + } + channel = tsdPtr->stdoutChannel; + break; + case TCL_STDERR: + if (!tsdPtr->stderrInitialized) { + tsdPtr->stderrChannel = TclpGetDefaultStdChannel(TCL_STDERR); + tsdPtr->stderrInitialized = 1; + if (tsdPtr->stderrChannel != (Tcl_Channel) NULL) { + (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, + tsdPtr->stderrChannel); + } + } + channel = tsdPtr->stderrChannel; + break; } return channel; } /* @@ -398,24 +390,24 @@ * * Results: * None. * * Side effects: - * Causes the callback to be called in the future when the channel - * will be closed. + * Causes the callback to be called in the future when the channel will + * be closed. * *---------------------------------------------------------------------- */ void Tcl_CreateCloseHandler(chan, proc, clientData) - Tcl_Channel chan; /* The channel for which to create the - * close callback. */ + Tcl_Channel chan; /* The channel for which to create the close + * callback. */ Tcl_CloseProc *proc; /* The callback routine to call when the * channel will be closed. */ - ClientData clientData; /* Arbitrary data to pass to the - * close callback. */ + ClientData clientData; /* Arbitrary data to pass to the close + * callback. */ { ChannelState *statePtr; CloseCallback *cbPtr; statePtr = ((Channel *) chan)->state; @@ -431,32 +423,31 @@ /* *---------------------------------------------------------------------- * * Tcl_DeleteCloseHandler -- * - * Removes a callback that would have been called on closing - * the channel. If there is no matching callback then this - * function has no effect. + * Removes a callback that would have been called on closing the channel. + * If there is no matching callback then this function has no effect. * * Results: * None. * * Side effects: - * The callback will not be called in the future when the channel - * is eventually closed. + * The callback will not be called in the future when the channel is + * eventually closed. * *---------------------------------------------------------------------- */ void Tcl_DeleteCloseHandler(chan, proc, clientData) - Tcl_Channel chan; /* The channel for which to cancel the - * close callback. */ + Tcl_Channel chan; /* The channel for which to cancel the close + * callback. */ Tcl_CloseProc *proc; /* The procedure for the callback to * remove. */ - ClientData clientData; /* The callback data for the callback - * to remove. */ + ClientData clientData; /* The callback data for the callback to + * remove. */ { ChannelState *statePtr; CloseCallback *cbPtr, *cbPrevPtr; statePtr = ((Channel *) chan)->state; @@ -478,21 +469,20 @@ /* *---------------------------------------------------------------------- * * GetChannelTable -- * - * Gets and potentially initializes the channel table for an - * interpreter. If it is initializing the table it also inserts - * channels for stdin, stdout and stderr if the interpreter is - * trusted. + * Gets and potentially initializes the channel table for an interpreter. + * If it is initializing the table it also inserts channels for stdin, + * stdout and stderr if the interpreter is trusted. * * Results: * A pointer to the hash table created, for use by the caller. * * Side effects: - * Initializes the channel table for an interpreter. May create - * channels for stdin, stdout and stderr. + * Initializes the channel table for an interpreter. May create channels + * for stdin, stdout and stderr. * *---------------------------------------------------------------------- */ static Tcl_HashTable * @@ -510,13 +500,12 @@ (void) Tcl_SetAssocData(interp, "tclIO", (Tcl_InterpDeleteProc *) DeleteChannelTable, (ClientData) hTblPtr); /* - * If the interpreter is trusted (not "safe"), insert channels - * for stdin, stdout and stderr (possibly creating them in the - * process). + * If the interpreter is trusted (not "safe"), insert channels for + * stdin, stdout and stderr (possibly creating them in the process). */ if (Tcl_IsSafe(interp) == 0) { stdinChan = Tcl_GetStdChannel(TCL_STDIN); if (stdinChan != NULL) { @@ -539,13 +528,12 @@ *---------------------------------------------------------------------- * * DeleteChannelTable -- * * Deletes the channel table for an interpreter, closing any open - * channels whose refcount reaches zero. This procedure is invoked - * when an interpreter is deleted, via the AssocData cleanup - * mechanism. + * channels whose refcount reaches zero. This procedure is invoked when + * an interpreter is deleted, via the AssocData cleanup mechanism. * * Results: * None. * * Side effects: @@ -565,11 +553,11 @@ Tcl_HashSearch hSearch; /* Search variable. */ Tcl_HashEntry *hPtr; /* Search variable. */ Channel *chanPtr; /* Channel being deleted. */ ChannelState *statePtr; /* State of Channel being deleted. */ EventScriptRecord *sPtr, *prevPtr, *nextPtr; - /* Variables to loop over all channel events + /* Variables to loop over all channel events * registered, to delete the ones that refer * to the interpreter being deleted. */ /* * Delete all the registered channels - this will close channels whose @@ -610,13 +598,13 @@ } } /* * Cannot call Tcl_UnregisterChannel because that procedure calls - * Tcl_GetAssocData to get the channel table, which might already - * be inaccessible from the interpreter structure. Instead, we - * emulate the behavior of Tcl_UnregisterChannel directly here. + * Tcl_GetAssocData to get the channel table, which might already be + * inaccessible from the interpreter structure. Instead, we emulate + * the behavior of Tcl_UnregisterChannel directly here. */ Tcl_DeleteHashEntry(hPtr); statePtr->refCount--; if (statePtr->refCount <= 0) { @@ -633,15 +621,15 @@ *---------------------------------------------------------------------- * * CheckForStdChannelsBeingClosed -- * * Perform special handling for standard channels being closed. When - * given a standard channel, if the refcount is now 1, it means that - * the last reference to the standard channel is being explicitly - * closed. Now bump the refcount artificially down to 0, to ensure the - * normal handling of channels being closed will occur. Also reset the - * static pointer to the channel to NULL, to avoid dangling references. + * given a standard channel, if the refcount is now 1, it means that the + * last reference to the standard channel is being explicitly closed. Now + * bump the refcount artificially down to 0, to ensure the normal + * handling of channels being closed will occur. Also reset the static + * pointer to the channel to NULL, to avoid dangling references. * * Results: * None. * * Side effects: @@ -697,17 +685,17 @@ * None. * *---------------------------------------------------------------------- */ -int +int Tcl_IsStandardChannel(chan) Tcl_Channel chan; /* Channel to check. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if ((chan == tsdPtr->stdinChannel) + if ((chan == tsdPtr->stdinChannel) || (chan == tsdPtr->stdoutChannel) || (chan == tsdPtr->stderrChannel)) { return 1; } else { return 0; @@ -718,12 +706,12 @@ *---------------------------------------------------------------------- * * Tcl_RegisterChannel -- * * Adds an already-open channel to the channel table of an interpreter. - * If the interpreter passed as argument is NULL, it only increments - * the channel refCount. + * If the interpreter passed as argument is NULL, it only increments the + * channel refCount. * * Results: * None. * * Side effects: @@ -759,11 +747,11 @@ if (interp != (Tcl_Interp *) NULL) { hTblPtr = GetChannelTable(interp); hPtr = Tcl_CreateHashEntry(hTblPtr, statePtr->channelName, &new); if (new == 0) { if (chan == (Tcl_Channel) Tcl_GetHashValue(hPtr)) { - return; + return; } Tcl_Panic("Tcl_RegisterChannel: duplicate channel names"); } Tcl_SetHashValue(hPtr, (ClientData) chanPtr); @@ -778,21 +766,21 @@ * * Deletes the hash entry for a channel associated with an interpreter. * If the interpreter given as argument is NULL, it only decrements the * reference count. (This all happens in the Tcl_DetachChannel helper * function). - * - * Finally, if the reference count of the channel drops to zero, - * it is deleted. + * + * Finally, if the reference count of the channel drops to zero, it is + * deleted. * * Results: * A standard Tcl result. * * Side effects: - * Calls Tcl_DetachChannel which deletes the hash entry for a channel + * Calls Tcl_DetachChannel which deletes the hash entry for a channel * associated with an interpreter. - * + * * May delete the channel, which can have a variety of consequences, * especially if we are forced to close the channel. * *---------------------------------------------------------------------- */ @@ -835,22 +823,25 @@ */ if (statePtr->refCount <= 0) { /* - * Ensure that if there is another buffer, it gets flushed - * whether or not we are doing a background flush. + * Ensure that if there is another buffer, it gets flushed whether or + * not we are doing a background flush. */ if ((statePtr->curOutPtr != NULL) && (statePtr->curOutPtr->nextAdded > statePtr->curOutPtr->nextRemoved)) { statePtr->flags |= BUFFER_READY; } Tcl_Preserve((ClientData)statePtr); if (!(statePtr->flags & BG_FLUSH_SCHEDULED)) { - /* We don't want to re-enter Tcl_Close */ + /* + * We don't want to re-enter Tcl_Close(). + */ + if (!(statePtr->flags & CHANNEL_CLOSED)) { if (Tcl_Close(interp, chan) != TCL_OK) { statePtr->flags |= CHANNEL_CLOSED; Tcl_Release((ClientData)statePtr); return TCL_ERROR; @@ -868,36 +859,33 @@ * * Tcl_DetachChannel -- * * Deletes the hash entry for a channel associated with an interpreter. * If the interpreter given as argument is NULL, it only decrements the - * reference count. Even if the ref count drops to zero, the - * channel is NOT closed or cleaned up. This allows a channel to - * be detached from an interpreter and left in the same state it - * was in when it was originally returned by 'Tcl_OpenFileChannel', - * for example. - * - * This function cannot be used on the standard channels, and - * will return TCL_ERROR if that is attempted. - * - * This function should only be necessary for special purposes - * in which you need to generate a pristine channel from one - * that has already been used. All ordinary purposes will almost - * always want to use Tcl_UnregisterChannel instead. - * - * Provided the channel is not attached to any other interpreter, - * it can then be closed with Tcl_Close, rather than with - * Tcl_UnregisterChannel. + * reference count. Even if the ref count drops to zero, the channel is + * NOT closed or cleaned up. This allows a channel to be detached from + * an interpreter and left in the same state it was in when it was + * originally returned by 'Tcl_OpenFileChannel', for example. + * + * This function cannot be used on the standard channels, and will return + * TCL_ERROR if that is attempted. + * + * This function should only be necessary for special purposes in which + * you need to generate a pristine channel from one that has already been + * used. All ordinary purposes will almost always want to use + * Tcl_UnregisterChannel instead. + * + * Provided the channel is not attached to any other interpreter, it can + * then be closed with Tcl_Close, rather than with Tcl_UnregisterChannel. * * Results: * A standard Tcl result. If the channel is not currently registered - * with the given interpreter, TCL_ERROR is returned, otherwise - * TCL_OK. However no error messages are left in the interp's result. + * with the given interpreter, TCL_ERROR is returned, otherwise TCL_OK. + * However no error messages are left in the interp's result. * * Side effects: - * Deletes the hash entry for a channel associated with an - * interpreter. + * Deletes the hash entry for a channel associated with an interpreter. * *---------------------------------------------------------------------- */ int @@ -917,24 +905,22 @@ * * DetachChannel -- * * Deletes the hash entry for a channel associated with an interpreter. * If the interpreter given as argument is NULL, it only decrements the - * reference count. Even if the ref count drops to zero, the - * channel is NOT closed or cleaned up. This allows a channel to - * be detached from an interpreter and left in the same state it - * was in when it was originally returned by 'Tcl_OpenFileChannel', - * for example. + * reference count. Even if the ref count drops to zero, the channel is + * NOT closed or cleaned up. This allows a channel to be detached from + * an interpreter and left in the same state it was in when it was + * originally returned by 'Tcl_OpenFileChannel', for example. * * Results: * A standard Tcl result. If the channel is not currently registered - * with the given interpreter, TCL_ERROR is returned, otherwise - * TCL_OK. However no error messages are left in the interp's result. + * with the given interpreter, TCL_ERROR is returned, otherwise TCL_OK. + * However no error messages are left in the interp's result. * * Side effects: - * Deletes the hash entry for a channel associated with an - * interpreter. + * Deletes the hash entry for a channel associated with an interpreter. * *---------------------------------------------------------------------- */ static int @@ -969,14 +955,14 @@ return TCL_ERROR; } Tcl_DeleteHashEntry(hPtr); /* - * Remove channel handlers that refer to this interpreter, so that they - * will not be present if the actual close is delayed and more events - * happen on the channel. This may occur if the channel is shared - * between several interpreters, or if the channel has async + * Remove channel handlers that refer to this interpreter, so that + * they will not be present if the actual close is delayed and more + * events happen on the channel. This may occur if the channel is + * shared between several interpreters, or if the channel has async * flushing active. */ CleanupChannelHandlers(interp, chanPtr); } @@ -994,24 +980,24 @@ * Finds an existing Tcl_Channel structure by name in a given * interpreter. This function is public because it is used by * channel-type-specific functions. * * Results: - * A Tcl_Channel or NULL on failure. If failed, interp's result - * object contains an error message. *modePtr is filled with the - * modes in which the channel was opened. + * A Tcl_Channel or NULL on failure. If failed, interp's result object + * contains an error message. *modePtr is filled with the modes in which + * the channel was opened. * * Side effects: * None. * *--------------------------------------------------------------------------- */ Tcl_Channel Tcl_GetChannel(interp, chanName, modePtr) - Tcl_Interp *interp; /* Interpreter in which to find or create - * the channel. */ + Tcl_Interp *interp; /* Interpreter in which to find or create the + * channel. */ CONST char *chanName; /* The name of the channel. */ int *modePtr; /* Where to store the mode in which the * channel was opened? Will contain an ORed * combination of TCL_READABLE and * TCL_WRITABLE, if non-NULL. */ @@ -1020,15 +1006,15 @@ Tcl_HashTable *hTblPtr; /* Hash table of channels. */ Tcl_HashEntry *hPtr; /* Search variable. */ CONST char *name; /* Translated name. */ /* - * Substitute "stdin", etc. Note that even though we immediately - * find the channel using Tcl_GetStdChannel, we still need to look - * it up in the specified interpreter to ensure that it is present - * in the channel table. Otherwise, safe interpreters would always - * have access to the standard channels. + * Substitute "stdin", etc. Note that even though we immediately find the + * channel using Tcl_GetStdChannel, we still need to look it up in the + * specified interpreter to ensure that it is present in the channel + * table. Otherwise, safe interpreters would always have access to the + * standard channels. */ name = chanName; if ((chanName[0] == 's') && (chanName[1] == 't')) { chanPtr = NULL; @@ -1051,14 +1037,13 @@ chanName, "\"", (char *) NULL); return NULL; } /* - * Always return bottom-most channel in the stack. This one lives - * the longest - other channels may go away unnoticed. - * The other APIs compensate where necessary to retrieve the - * topmost channel again. + * Always return bottom-most channel in the stack. This one lives the + * longest - other channels may go away unnoticed. The other APIs + * compensate where necessary to retrieve the topmost channel again. */ chanPtr = (Channel *) Tcl_GetHashValue(hPtr); chanPtr = chanPtr->state->bottomChanPtr; if (modePtr != NULL) { @@ -1071,52 +1056,50 @@ /* *---------------------------------------------------------------------- * * Tcl_CreateChannel -- * - * Creates a new entry in the hash table for a Tcl_Channel - * record. + * Creates a new entry in the hash table for a Tcl_Channel record. * * Results: * Returns the new Tcl_Channel. * * Side effects: - * Creates a new Tcl_Channel instance and inserts it into the - * hash table. + * Creates a new Tcl_Channel instance and inserts it into the hash table. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_CreateChannel(typePtr, chanName, instanceData, mask) Tcl_ChannelType *typePtr; /* The channel type record. */ CONST char *chanName; /* Name of channel to record. */ ClientData instanceData; /* Instance specific data. */ - int mask; /* TCL_READABLE & TCL_WRITABLE to indicate - * if the channel is readable, writable. */ + int mask; /* TCL_READABLE & TCL_WRITABLE to indicate if + * the channel is readable, writable. */ { Channel *chanPtr; /* The channel structure newly created. */ - ChannelState *statePtr; /* The stack-level independent state info - * for the channel. */ + ChannelState *statePtr; /* The stack-level independent state info for + * the channel. */ CONST char *name; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * With the change of the Tcl_ChannelType structure to use a version in * 8.3.2+, we have to make sure that our assumption that the structure * remains a binary compatible size is true. * - * If this assertion fails on some system, then it can be removed - * only if the user recompiles code with older channel drivers in - * the new system as well. + * If this assertion fails on some system, then it can be removed only if + * the user recompiles code with older channel drivers in the new system + * as well. */ assert(sizeof(Tcl_ChannelTypeVersion) == sizeof(Tcl_DriverBlockModeProc*)); /* - * JH: We could subsequently memset these to 0 to avoid the - * numerous assignments to 0/NULL below. + * JH: We could subsequently memset these to 0 to avoid the numerous + * assignments to 0/NULL below. */ chanPtr = (Channel *) ckalloc((unsigned) sizeof(Channel)); statePtr = (ChannelState *) ckalloc((unsigned) sizeof(ChannelState)); chanPtr->state = statePtr; @@ -1139,28 +1122,34 @@ statePtr->flags = mask; /* * Set the channel to system default encoding. + * + * Note the strange bit of protection taking place here. If the system + * encoding name is reported back as "binary", something weird is + * happening. Tcl provides no "binary" encoding, so someone else has + * provided one. We ignore it so as not to interfere with the "magic" + * interpretation that Tcl_Channels give to the "-encoding binary" option. */ statePtr->encoding = NULL; name = Tcl_GetEncodingName(NULL); if (strcmp(name, "binary") != 0) { - statePtr->encoding = Tcl_GetEncoding(NULL, name); + statePtr->encoding = Tcl_GetEncoding(NULL, name); } statePtr->inputEncodingState = NULL; statePtr->inputEncodingFlags = TCL_ENCODING_START; statePtr->outputEncodingState = NULL; statePtr->outputEncodingFlags = TCL_ENCODING_START; /* - * Set the channel up initially in AUTO input translation mode to - * accept "\n", "\r" and "\r\n". Output translation mode is set to - * a platform specific default value. The eofChar is set to 0 for both - * input and output, so that Tcl does not look for an in-file EOF - * indicator (e.g. ^Z) and does not append an EOF indicator to files. + * Set the channel up initially in AUTO input translation mode to accept + * "\n", "\r" and "\r\n". Output translation mode is set to a platform + * specific default value. The eofChar is set to 0 for both input and + * output, so that Tcl does not look for an in-file EOF indicator + * (e.g. ^Z) and does not append an EOF indicator to files. */ statePtr->inputTranslation = TCL_TRANSLATE_AUTO; statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION; statePtr->inEofChar = 0; @@ -1187,46 +1176,50 @@ statePtr->outputStage = (char *) ckalloc((unsigned) (statePtr->bufSize + 2)); } /* - * As we are creating the channel, it is obviously the top for now + * As we are creating the channel, it is obviously the top for now. */ statePtr->topChanPtr = chanPtr; statePtr->bottomChanPtr = chanPtr; chanPtr->downChanPtr = (Channel *) NULL; chanPtr->upChanPtr = (Channel *) NULL; chanPtr->inQueueHead = (ChannelBuffer *) NULL; chanPtr->inQueueTail = (ChannelBuffer *) NULL; + /* TIP #219, Tcl Channel Reflection API */ + statePtr->chanMsg = NULL; + statePtr->unreportedMsg = NULL; + /* * Link the channel into the list of all channels; create an on-exit - * handler if there is not one already, to close off all the channels - * in the list on exit. + * handler if there is not one already, to close off all the channels in + * the list on exit. * * JH: Could call Tcl_SpliceChannel, but need to avoid NULL check. - */ - - statePtr->nextCSPtr = tsdPtr->firstCSPtr; - tsdPtr->firstCSPtr = statePtr; - - /* - * TIP #10. Mark the current thread as the one managing the new - * channel. Note: 'Tcl_GetCurrentThread' returns sensible - * values even for a non-threaded core. - */ - - statePtr->managingThread = Tcl_GetCurrentThread(); - - /* - * Install this channel in the first empty standard channel slot, if - * the channel was previously closed explicitly. - */ - - if ((tsdPtr->stdinChannel == NULL) && - (tsdPtr->stdinInitialized == 1)) { + * + * TIP #218. + * AK: Just initialize the field to NULL before invoking Tcl_SpliceChannel + * We need Tcl_SpliceChannel, for the threadAction calls. There is no + * real reason to duplicate all of this. + * NOTE: All drivers using thread actions now have to perform their TSD + * manipulation only in their thread action proc. Doing it when + * creating their instance structures will collide with the thread + * action activity and lead to damaged lists. + */ + + statePtr->nextCSPtr = (ChannelState *) NULL; + SpliceChannel ((Tcl_Channel) chanPtr); + + /* + * Install this channel in the first empty standard channel slot, if the + * channel was previously closed explicitly. + */ + + if ((tsdPtr->stdinChannel == NULL) && (tsdPtr->stdinInitialized == 1)) { Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDIN); Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); } else if ((tsdPtr->stdoutChannel == NULL) && (tsdPtr->stdoutInitialized == 1)) { Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDOUT); @@ -1233,39 +1226,37 @@ Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); } else if ((tsdPtr->stderrChannel == NULL) && (tsdPtr->stderrInitialized == 1)) { Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDERR); Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); - } + } return (Tcl_Channel) chanPtr; } /* *---------------------------------------------------------------------- * * Tcl_StackChannel -- * - * Replaces an entry in the hash table for a Tcl_Channel - * record. The replacement is a new channel with same name, - * it supercedes the replaced channel. Input and output of - * the superceded channel is now going through the newly - * created channel and allows the arbitrary filtering/manipulation - * of the dataflow. - * - * Andreas Kupries , 12/13/1998 - * "Trf-Patch for filtering channels" + * Replaces an entry in the hash table for a Tcl_Channel record. The + * replacement is a new channel with same name, it supercedes the + * replaced channel. Input and output of the superceded channel is now + * going through the newly created channel and allows the arbitrary + * filtering/manipulation of the dataflow. + * + * Andreas Kupries , 12/13/1998 "Trf-Patch for + * filtering channels" * * Results: - * Returns the new Tcl_Channel, which actually contains the - * saved information about prevChan. + * Returns the new Tcl_Channel, which actually contains the saved + * information about prevChan. * * Side effects: - * A new channel structure is allocated and linked below - * the existing channel. The channel operations and client - * data of the existing channel are copied down to the newly - * created channel, and the current channel has its operations - * replaced by the new typePtr. + * A new channel structure is allocated and linked below the existing + * channel. The channel operations and client data of the existing channel + * are copied down to the newly created channel, and the current channel + * has its operations replaced by the new typePtr. * *---------------------------------------------------------------------- */ Tcl_Channel @@ -1273,21 +1264,22 @@ Tcl_Interp *interp; /* The interpreter we are working in */ Tcl_ChannelType *typePtr; /* The channel type record for the new * channel. */ ClientData instanceData; /* Instance specific data for the new * channel. */ - int mask; /* TCL_READABLE & TCL_WRITABLE to indicate - * if the channel is readable, writable. */ + int mask; /* TCL_READABLE & TCL_WRITABLE to indicate if + * the channel is readable, writable. */ Tcl_Channel prevChan; /* The channel structure to replace */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); Channel *chanPtr, *prevChanPtr; ChannelState *statePtr; + Tcl_DriverThreadActionProc *threadActionProc; /* - * Find the given channel in the list of all channels. - * If we don't find it, then it was never registered correctly. + * Find the given channel (prevChan) in the list of all channels. If we don't find + * it, then it was never registered correctly. * * This operation should occur at the top of a channel stack. */ statePtr = (ChannelState *) tsdPtr->firstCSPtr; @@ -1302,19 +1294,19 @@ Tcl_GetChannelName(prevChan), "\"", (char *) NULL); return (Tcl_Channel) NULL; } /* - * Here we check if the given "mask" matches the "flags" - * of the already existing channel. + * Here we check if the given "mask" matches the "flags" of the already + * existing channel. * * | - | R | W | RW | * --+---+---+---+----+ <=> 0 != (chan->mask & prevChan->mask) * - | | | | | - * R | | + | | + | The superceding channel is allowed to - * W | | | + | + | restrict the capabilities of the - * RW| | + | + | + | superceded one ! + * R | | + | | + | The superceding channel is allowed to restrict + * W | | | + | + | the capabilities of the superceded one! + * RW| | + | + | + | * --+---+---+---+----+ */ if ((mask & (statePtr->flags & (TCL_READABLE | TCL_WRITABLE))) == 0) { Tcl_AppendResult(interp, @@ -1322,14 +1314,14 @@ Tcl_GetChannelName(prevChan), "\"", (char *) NULL); return (Tcl_Channel) NULL; } /* - * Flush the buffers. This ensures that any data still in them - * at this time is not handled by the new transformation. Restrict - * this to writable channels. Take care to hide a possible bg-copy - * in progress from Tcl_Flush and the CheckForChannelErrors inside. + * Flush the buffers. This ensures that any data still in them at this + * time is not handled by the new transformation. Restrict this to + * writable channels. Take care to hide a possible bg-copy in progress + * from Tcl_Flush and the CheckForChannelErrors inside. */ if ((mask & TCL_WRITABLE) != 0) { CopyState *csPtr; @@ -1344,30 +1336,29 @@ } statePtr->csPtr = csPtr; } /* - * Discard any input in the buffers. They are not yet read by the - * user of the channel, so they have to go through the new - * transformation before reading. As the buffers contain the - * untransformed form their contents are not only useless but actually - * distorts our view of the system. - * - * To preserve the information without having to read them again and - * to avoid problems with the location in the channel (seeking might - * be impossible) we move the buffers from the common state structure - * into the channel itself. We use the buffers in the channel below - * the new transformation to hold the data. In the future this allows - * us to write transformations which pre-read data and push the unused - * part back when they are going away. + * Discard any input in the buffers. They are not yet read by the user of + * the channel, so they have to go through the new transformation before + * reading. As the buffers contain the untransformed form their contents + * are not only useless but actually distorts our view of the system. + * + * To preserve the information without having to read them again and to + * avoid problems with the location in the channel (seeking might be + * impossible) we move the buffers from the common state structure into + * the channel itself. We use the buffers in the channel below the new + * transformation to hold the data. In the future this allows us to write + * transformations which pre-read data and push the unused part back when + * they are going away. */ if (((mask & TCL_READABLE) != 0) && (statePtr->inQueueHead != (ChannelBuffer *) NULL)) { /* - * Remark: It is possible that the channel buffers contain - * data from some earlier push-backs. + * Remark: It is possible that the channel buffers contain data from + * some earlier push-backs. */ statePtr->inQueueTail->nextPtr = prevChanPtr->inQueueHead; prevChanPtr->inQueueHead = statePtr->inQueueHead; @@ -1380,12 +1371,12 @@ } chanPtr = (Channel *) ckalloc((unsigned) sizeof(Channel)); /* - * Save some of the current state into the new structure, - * reinitialize the parts which will stay with the transformation. + * Save some of the current state into the new structure, reinitialize the + * parts which will stay with the transformation. * * Remarks: */ chanPtr->state = statePtr; @@ -1401,28 +1392,44 @@ * stacked channels. */ prevChanPtr->upChanPtr = chanPtr; statePtr->topChanPtr = chanPtr; + + /* TIP #218, Channel Thread Actions. + * + * We call the thread actions for the new channel directly. We _cannot_ + * use SpliceChannel, because the (thread-)global list of all channels + * always contains the _ChannelState_ for a stack of channels, not the + * individual channels. And SpliceChannel would not only call the thread + * actions, but also add the shared ChannelState to this list a second + * time, mangling it. + */ + + threadActionProc = Tcl_ChannelThreadActionProc (chanPtr->typePtr); + if (threadActionProc != NULL) { + (*threadActionProc) (chanPtr->instanceData, + TCL_CHANNEL_THREAD_INSERT); + } return (Tcl_Channel) chanPtr; } /* *---------------------------------------------------------------------- * * Tcl_UnstackChannel -- * - * Unstacks an entry in the hash table for a Tcl_Channel - * record. This is the reverse to 'Tcl_StackChannel'. + * Unstacks an entry in the hash table for a Tcl_Channel record. This is + * the reverse to 'Tcl_StackChannel'. * * Results: * A standard Tcl result. * * Side effects: - * If TCL_ERROR is returned, the posix error code will be set - * with Tcl_SetErrno. + * If TCL_ERROR is returned, the posix error code will be set with + * Tcl_SetErrno. May leave a message in interp result as well. * *---------------------------------------------------------------------- */ int @@ -1431,10 +1438,11 @@ Tcl_Channel chan; /* The channel to unstack */ { Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; int result = 0; + Tcl_DriverThreadActionProc *threadActionProc; /* * This operation should occur at the top of a channel stack. */ @@ -1449,14 +1457,14 @@ */ Channel *downChanPtr = chanPtr->downChanPtr; /* - * Flush the buffers. This ensures that any data still in them - * at this time _is_ handled by the transformation we are unstacking - * right now. Restrict this to writable channels. Take care to hide - * a possible bg-copy in progress from Tcl_Flush and the + * Flush the buffers. This ensures that any data still in them at this + * time _is_ handled by the transformation we are unstacking right + * now. Restrict this to writable channels. Take care to hide a + * possible bg-copy in progress from Tcl_Flush and the * CheckForChannelErrors inside. */ if (statePtr->flags & TCL_WRITABLE) { CopyState *csPtr; @@ -1464,27 +1472,35 @@ csPtr = statePtr->csPtr; statePtr->csPtr = (CopyState *) NULL; if (Tcl_Flush((Tcl_Channel) chanPtr) != TCL_OK) { statePtr->csPtr = csPtr; - Tcl_AppendResult(interp, "could not flush channel \"", - Tcl_GetChannelName((Tcl_Channel) chanPtr), "\"", - (char *) NULL); + /* TIP #219, Tcl Channel Reflection API. + * Move error messages put by the driver into the chan/ip + * bypass area into the regular interpreter result. Fall back + * to the regular message if nothing was found in the + * bypasses. + */ + if (!TclChanCaughtErrorBypass (interp, chan)) { + Tcl_AppendResult(interp, "could not flush channel \"", + Tcl_GetChannelName((Tcl_Channel) chanPtr), "\"", + (char *) NULL); + } return TCL_ERROR; } statePtr->csPtr = csPtr; } /* - * Anything in the input queue and the push-back buffers of - * the transformation going away is transformed data, but not - * yet read. As unstacking means that the caller does not want - * to see transformed data any more we have to discard these - * bytes. To avoid writing an analogue to 'DiscardInputQueued' - * we move the information in the push back buffers to the - * input queue and then call 'DiscardInputQueued' on that. + * Anything in the input queue and the push-back buffers of the + * transformation going away is transformed data, but not yet read. As + * unstacking means that the caller does not want to see transformed + * data any more we have to discard these bytes. To avoid writing an + * analogue to 'DiscardInputQueued' we move the information in the + * push back buffers to the input queue and then call + * 'DiscardInputQueued' on that. */ if (((statePtr->flags & TCL_READABLE) != 0) && ((statePtr->inQueueHead != (ChannelBuffer *) NULL) || (chanPtr->inQueueHead != (ChannelBuffer *) NULL))) { @@ -1503,10 +1519,27 @@ chanPtr->inQueueHead = (ChannelBuffer *) NULL; chanPtr->inQueueTail = (ChannelBuffer *) NULL; DiscardInputQueued(statePtr, 0); } + + /* TIP #218, Channel Thread Actions. + * + * We call the thread actions for the new channel directly. We + * _cannot_ use CutChannel, because the (thread-)global list of all + * channels always contains the _ChannelState_ for a stack of + * channels, not the individual channels. And SpliceChannel would not + * only call the thread actions, but also remove the shared + * ChannelState from this list despite there being more channels for + * the state which are still active. + */ + + threadActionProc = Tcl_ChannelThreadActionProc (chanPtr->typePtr); + if (threadActionProc != NULL) { + (*threadActionProc) (chanPtr->instanceData, + TCL_CHANNEL_THREAD_REMOVE); + } statePtr->topChanPtr = downChanPtr; downChanPtr->upChanPtr = (Channel *) NULL; /* @@ -1535,23 +1568,38 @@ Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC); UpdateInterest(downChanPtr); if (result != 0) { Tcl_SetErrno(result); + /* TIP #219, Tcl Channel Reflection API. + * Move error messages put by the driver into the chan/ip bypass + * area into the regular interpreter result. + */ + TclChanCaughtErrorBypass (interp, chan); return TCL_ERROR; } } else { /* - * This channel does not cover another one. - * Simply do a close, if necessary. + * This channel does not cover another one. Simply do a close, if + * necessary. */ if (statePtr->refCount <= 0) { if (Tcl_Close(interp, chan) != TCL_OK) { + /* TIP #219, Tcl Channel Reflection API. + * "TclChanCaughtErrorBypass" is not required here, it was + * done already by "Tcl_Close". + */ return TCL_ERROR; } } + + /* TIP #218, Channel Thread Actions. + * Not required in this branch, this is done by Tcl_Close. If + * Tcl_Close is not called then the ChannelState is still active in + * the thread and no action has to be taken either. + */ } return TCL_OK; } @@ -1561,13 +1609,13 @@ * Tcl_GetStackedChannel -- * * Determines whether the specified channel is stacked upon another. * * Results: - * NULL if the channel is not stacked upon another one, or a reference - * to the channel it is stacked upon. This reference can be used in - * queries, but modification is not allowed. + * NULL if the channel is not stacked upon another one, or a reference to + * the channel it is stacked upon. This reference can be used in queries, + * but modification is not allowed. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -1588,13 +1636,13 @@ * Tcl_GetTopChannel -- * * Returns the top channel of a channel stack. * * Results: - * NULL if the channel is not stacked upon another one, or a reference - * to the channel it is stacked upon. This reference can be used in - * queries, but modification is not allowed. + * NULL if the channel is not stacked upon another one, or a reference to + * the channel it is stacked upon. This reference can be used in queries, + * but modification is not allowed. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -1637,12 +1685,11 @@ /* *---------------------------------------------------------------------- * * Tcl_GetChannelThread -- * - * Given a channel structure, returns the thread managing it. - * TIP #10 + * Given a channel structure, returns the thread managing it. TIP #10 * * Results: * Returns the id of the thread managing the channel. * * Side effects: @@ -1651,11 +1698,12 @@ *---------------------------------------------------------------------- */ Tcl_ThreadId Tcl_GetChannelThread(chan) - Tcl_Channel chan; /* The channel to return managing thread for. */ + Tcl_Channel chan; /* The channel to return managing thread + * for. */ { Channel *chanPtr = (Channel *) chan; /* The actual channel. */ return chanPtr->state->managingThread; } @@ -1678,22 +1726,23 @@ Tcl_ChannelType * Tcl_GetChannelType(chan) Tcl_Channel chan; /* The channel to return type for. */ { - Channel *chanPtr = (Channel *) chan; /* The actual channel. */ + Channel *chanPtr = (Channel *) chan; + /* The actual channel. */ return chanPtr->typePtr; } /* *---------------------------------------------------------------------- * * Tcl_GetChannelMode -- * - * Computes a mask indicating whether the channel is open for - * reading and writing. + * Computes a mask indicating whether the channel is open for reading and + * writing. * * Results: * An OR-ed combination of TCL_READABLE and TCL_WRITABLE. * * Side effects: @@ -1702,15 +1751,15 @@ *---------------------------------------------------------------------- */ int Tcl_GetChannelMode(chan) - Tcl_Channel chan; /* The channel for which the mode is - * being computed. */ + Tcl_Channel chan; /* The channel for which the mode is being + * computed. */ { ChannelState *statePtr = ((Channel *) chan)->state; - /* State of actual channel. */ + /* State of actual channel. */ return (statePtr->flags & (TCL_READABLE | TCL_WRITABLE)); } /* @@ -1719,13 +1768,12 @@ * Tcl_GetChannelName -- * * Returns the string identifying the channel name. * * Results: - * The string containing the channel name. This memory is - * owned by the generic layer and should not be modified by - * the caller. + * The string containing the channel name. This memory is owned by the + * generic layer and should not be modified by the caller. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -1780,20 +1828,19 @@ /* *--------------------------------------------------------------------------- * * AllocChannelBuffer -- * - * A channel buffer has BUFFER_PADDING bytes extra at beginning to - * hold any bytes of a native-encoding character that got split by - * the end of the previous buffer and need to be moved to the - * beginning of the next buffer to make a contiguous string so it - * can be converted to UTF-8. - * - * A channel buffer has BUFFER_PADDING bytes extra at the end to - * hold any bytes of a native-encoding character (generated from a - * UTF-8 character) that overflow past the end of the buffer and - * need to be moved to the next buffer. + * A channel buffer has BUFFER_PADDING bytes extra at beginning to hold + * any bytes of a native-encoding character that got split by the end of + * the previous buffer and need to be moved to the beginning of the next + * buffer to make a contiguous string so it can be converted to UTF-8. + * + * A channel buffer has BUFFER_PADDING bytes extra at the end to hold any + * bytes of a native-encoding character (generated from a UTF-8 + * character) that overflow past the end of the buffer and need to be + * moved to the next buffer. * * Results: * A newly allocated channel buffer. * * Side effects: @@ -1821,15 +1868,14 @@ /* *---------------------------------------------------------------------- * * RecycleBuffer -- * - * Helper function to recycle input and output buffers. Ensures - * that two input buffers are saved (one in the input queue and - * another in the saveInBufPtr field) and that curOutPtr is set - * to a buffer. Only if these conditions are met is the buffer - * freed to the OS. + * Helper function to recycle input and output buffers. Ensures that two + * input buffers are saved (one in the input queue and another in the + * saveInBufPtr field) and that curOutPtr is set to a buffer. Only if + * these conditions are met is the buffer freed to the OS. * * Results: * None. * * Side effects: @@ -1840,12 +1886,12 @@ static void RecycleBuffer(statePtr, bufPtr, mustDiscard) ChannelState *statePtr; /* ChannelState in which to recycle buffers. */ ChannelBuffer *bufPtr; /* The buffer to recycle. */ - int mustDiscard; /* If nonzero, free the buffer to the - * OS, always. */ + int mustDiscard; /* If nonzero, free the buffer to the OS, + * always. */ { /* * Do we have to free the buffer to the OS? */ @@ -1853,13 +1899,13 @@ ckfree((char *) bufPtr); return; } /* - * Only save buffers which are at least as big as the requested - * buffersize for the channel. This is to honor dynamic changes - * of the buffersize made by the user. + * Only save buffers which are at least as big as the requested buffersize + * for the channel. This is to honor dynamic changes of the buffersize + * made by the user. */ if ((bufPtr->bufLength - BUFFER_PADDING) < statePtr->bufSize) { ckfree((char *) bufPtr); return; @@ -1871,15 +1917,15 @@ if (statePtr->flags & TCL_READABLE) { if (statePtr->inQueueHead == (ChannelBuffer *) NULL) { statePtr->inQueueHead = bufPtr; statePtr->inQueueTail = bufPtr; - goto keepit; + goto keepBuffer; } if (statePtr->saveInBufPtr == (ChannelBuffer *) NULL) { statePtr->saveInBufPtr = bufPtr; - goto keepit; + goto keepBuffer; } } /* * Only save buffers for the output queue if the channel is writable. @@ -1886,11 +1932,11 @@ */ if (statePtr->flags & TCL_WRITABLE) { if (statePtr->curOutPtr == (ChannelBuffer *) NULL) { statePtr->curOutPtr = bufPtr; - goto keepit; + goto keepBuffer; } } /* * If we reached this code we return the buffer to the OS. @@ -1897,11 +1943,11 @@ */ ckfree((char *) bufPtr); return; - keepit: + keepBuffer: bufPtr->nextRemoved = BUFFER_PADDING; bufPtr->nextAdded = BUFFER_PADDING; bufPtr->nextPtr = (ChannelBuffer *) NULL; } @@ -1939,12 +1985,12 @@ /* *---------------------------------------------------------------------- * * CheckForDeadChannel -- * - * This function checks is a given channel is Dead. - * (A channel that has been closed but not yet deallocated.) + * This function checks is a given channel is Dead (a channel that has + * been closed but not yet deallocated.) * * Results: * True (1) if channel is Dead, False (0) if channel is Ok * * Side effects: @@ -1961,11 +2007,11 @@ if (statePtr->flags & CHANNEL_DEAD) { Tcl_SetErrno(EINVAL); if (interp) { Tcl_AppendResult(interp, "unable to access channel: invalid channel", - (char *) NULL); + (char *) NULL); } return 1; } return 0; } @@ -1978,28 +2024,28 @@ * This function flushes as much of the queued output as is possible * now. If calledFromAsyncFlush is nonzero, it is being called in an * event handler to flush channel output asynchronously. * * Results: - * 0 if successful, else the error code that was returned by the - * channel type operation. + * 0 if successful, else the error code that was returned by the channel + * type operation. May leave a message in the interp result. * * Side effects: - * May produce output on a channel. May block indefinitely if the - * channel is synchronous. May schedule an async flush on the channel. - * May recycle memory for buffers in the output queue. + * May produce output on a channel. May block indefinitely if the channel + * is synchronous. May schedule an async flush on the channel. May + * recycle memory for buffers in the output queue. * *---------------------------------------------------------------------- */ static int FlushChannel(interp, chanPtr, calledFromAsyncFlush) Tcl_Interp *interp; /* For error reporting during close. */ Channel *chanPtr; /* The channel to flush on. */ - int calledFromAsyncFlush; /* If nonzero then we are being - * called from an asynchronous - * flush callback. */ + int calledFromAsyncFlush; /* If nonzero then we are being called + * from an asynchronous flush + * callback. */ { ChannelState *statePtr = chanPtr->state; /* State of the channel stack. */ ChannelBuffer *bufPtr; /* Iterates over buffered output * queue. */ @@ -2007,31 +2053,30 @@ * buffer available to be written. */ int written; /* Amount of output data actually * written in current round. */ int errorCode = 0; /* Stores POSIX error codes from * channel driver operations. */ - int wroteSome = 0; /* Set to one if any data was - * written to the driver. */ + int wroteSome = 0; /* Set to one if any data was written + * to the driver. */ /* - * Prevent writing on a dead channel -- a channel that has been closed - * but not yet deallocated. This can occur if the exit handler for the - * channel deallocation runs before all channels are deregistered in - * all interpreters. + * Prevent writing on a dead channel -- a channel that has been closed but + * not yet deallocated. This can occur if the exit handler for the channel + * deallocation runs before all channels are deregistered in all + * interpreters. */ if (CheckForDeadChannel(interp, statePtr)) { return -1; } /* - * Loop over the queued buffers and attempt to flush as - * much as possible of the queued output to the channel. + * Loop over the queued buffers and attempt to flush as much as possible + * of the queued output to the channel. */ while (1) { - /* * If the queue is empty and there is a ready current buffer, OR if * the current buffer is full, then move the current buffer to the * queue. */ @@ -2051,12 +2096,12 @@ statePtr->curOutPtr = (ChannelBuffer *) NULL; } bufPtr = statePtr->outQueueHead; /* - * If we are not being called from an async flush and an async - * flush is active, we just return without producing any output. + * If we are not being called from an async flush and an async flush + * is active, we just return without producing any output. */ if ((!calledFromAsyncFlush) && (statePtr->flags & BG_FLUSH_SCHEDULED)) { return 0; @@ -2095,20 +2140,20 @@ errorCode = 0; continue; } /* - * If the channel is non-blocking and we would have blocked, - * start a background flushing handler and break out of the loop. + * If the channel is non-blocking and we would have blocked, start + * a background flushing handler and break out of the loop. */ if ((errorCode == EWOULDBLOCK) || (errorCode == EAGAIN)) { /* - * This used to check for CHANNEL_NONBLOCKING, and panic - * if the channel was blocking. However, it appears - * that setting stdin to -blocking 0 has some effect on - * the stdout when it's a tty channel (dup'ed underneath) + * This used to check for CHANNEL_NONBLOCKING, and panic if + * the channel was blocking. However, it appears that setting + * stdin to -blocking 0 has some effect on the stdout when + * it's a tty channel (dup'ed underneath) */ if (!(statePtr->flags & BG_FLUSH_SCHEDULED)) { statePtr->flags |= BG_FLUSH_SCHEDULED; UpdateInterest(chanPtr); @@ -2120,31 +2165,62 @@ /* * Decide whether to report the error upwards or defer it. */ if (calledFromAsyncFlush) { + /* TIP #219, Tcl Channel Reflection API. + * When defering the error copy a message from the bypass into + * the unreported area. Or discard it if the new error is to be + * ignored in favor of an earlier defered error. + */ + + Tcl_Obj* msg = statePtr->chanMsg; + if (statePtr->unreportedError == 0) { statePtr->unreportedError = errorCode; + statePtr->unreportedMsg = msg; + if (msg != NULL) { + Tcl_IncrRefCount (msg); + } + } else { + /* An old unreported error is kept, and this error + * thrown away. + */ + statePtr->chanMsg = NULL; + if (msg != NULL) { + Tcl_DecrRefCount (msg); + } } } else { + /* TIP #219, Tcl Channel Reflection API. + * Move error messages put by the driver into the chan bypass + * area into the regular interpreter result. Fall back to the + * regular message if nothing was found in the bypasses. + */ + Tcl_SetErrno(errorCode); if (interp != NULL) { - - /* - * Casting away CONST here is safe because the - * TCL_VOLATILE flag guarantees CONST treatment - * of the Posix error string. - */ - - Tcl_SetResult(interp, - (char *) Tcl_PosixError(interp), TCL_VOLATILE); - } + if (!TclChanCaughtErrorBypass (interp, (Tcl_Channel) chanPtr)) { + /* + * Casting away CONST here is safe because the + * TCL_VOLATILE flag guarantees CONST treatment + * of the Posix error string. + */ + + Tcl_SetResult(interp, + (char *) Tcl_PosixError(interp), + TCL_VOLATILE); + } + } + /* An unreportable bypassed message is kept, for the + * caller of Tcl_Seek, Tcl_Write, etc. + */ } /* - * When we get an error we throw away all the output - * currently queued. + * When we get an error we throw away all the output currently + * queued. */ DiscardOutputQueued(statePtr); continue; } else { @@ -2166,13 +2242,13 @@ } } /* Closes "while (1)". */ /* * If we wrote some data while flushing in the background, we are done. - * We can't finish the background flush until we run out of data and - * the channel becomes writable again. This ensures that all of the - * pending data has been flushed at the system level. + * We can't finish the background flush until we run out of data and the + * channel becomes writable again. This ensures that all of the pending + * data has been flushed at the system level. */ if (statePtr->flags & BG_FLUSH_SCHEDULED) { if (wroteSome) { return errorCode; @@ -2182,13 +2258,13 @@ statePtr->interestMask); } } /* - * If the channel is flagged as closed, delete it when the refCount - * drops to zero, the output queue is empty and there is no output - * in the current output buffer. + * If the channel is flagged as closed, delete it when the refCount drops + * to zero, the output queue is empty and there is no output in the + * current output buffer. */ if ((statePtr->flags & CHANNEL_CLOSED) && (statePtr->refCount <= 0) && (statePtr->outQueueHead == (ChannelBuffer *) NULL) && ((statePtr->curOutPtr == (ChannelBuffer *) NULL) || @@ -2208,19 +2284,19 @@ * * If the channel was stacked, then the it will copy the necessary * elements of the NEXT channel into the TOP channel, in essence * unstacking the channel. The NEXT channel will then be freed. * - * If the channel was not stacked, then we will free all the bits - * for the TOP channel, including the data structure itself. + * If the channel was not stacked, then we will free all the bits for the + * TOP channel, including the data structure itself. * * Results: - * 1 if the channel was stacked, 0 otherwise. + * Error code from an unreported error or the driver close operation. * * Side effects: - * May close the actual channel; may free memory. - * May change the value of errno. + * May close the actual channel, may free memory, may change the value of + * errno. * *---------------------------------------------------------------------- */ static int @@ -2253,38 +2329,51 @@ ckfree((char *) statePtr->curOutPtr); statePtr->curOutPtr = (ChannelBuffer *) NULL; } /* - * The caller guarantees that there are no more buffers - * queued for output. + * The caller guarantees that there are no more buffers queued for output. */ if (statePtr->outQueueHead != (ChannelBuffer *) NULL) { Tcl_Panic("TclFlush, closed channel: queued output left"); } /* - * If the EOF character is set in the channel, append that to the - * output device. + * If the EOF character is set in the channel, append that to the output + * device. */ if ((statePtr->outEofChar != 0) && (statePtr->flags & TCL_WRITABLE)) { int dummy; char c = (char) statePtr->outEofChar; (chanPtr->typePtr->outputProc) (chanPtr->instanceData, &c, 1, &dummy); } + + /* TIP #219, Tcl Channel Reflection API. + * Move a leftover error message in the channel bypass into the + * interpreter bypass. Just clear it if there is no interpreter. + */ + + if (statePtr->chanMsg != NULL) { + if (interp != NULL) { + Tcl_SetChannelErrorInterp (interp,statePtr->chanMsg); + } + Tcl_DecrRefCount (statePtr->chanMsg); + statePtr->chanMsg = NULL; + } /* * Remove this channel from of the list of all channels. */ - Tcl_CutChannel((Tcl_Channel) chanPtr); + CutChannel((Tcl_Channel) chanPtr); /* * Close and free the channel driver state. + * This may leave a TIP #219 error message in the interp. */ if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) { result = (chanPtr->typePtr->closeProc)(chanPtr->instanceData, interp); } else { @@ -2291,13 +2380,12 @@ result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData, interp, 0); } /* - * Some resources can be cleared only if the bottom channel - * in a stack is closed. All the other channels in the stack - * are not allowed to remove. + * Some resources can be cleared only if the bottom channel in a stack is + * closed. All the other channels in the stack are not allowed to remove. */ if (chanPtr == statePtr->bottomChanPtr) { if (statePtr->channelName != (char *) NULL) { ckfree((char *) statePtr->channelName); @@ -2310,16 +2398,27 @@ statePtr->outputStage = (char *) NULL; } } /* - * If we are being called synchronously, report either - * any latent error on the channel or the current error. + * If we are being called synchronously, report either any latent error on + * the channel or the current error. */ if (statePtr->unreportedError != 0) { errorCode = statePtr->unreportedError; + + /* TIP #219, Tcl Channel Reflection API. + * Move an error message found in the unreported area into the regular + * bypass (interp). This kills any message in the channel bypass area. + */ + + if (statePtr->chanMsg != NULL) { + Tcl_DecrRefCount (statePtr->chanMsg); + statePtr->chanMsg = NULL; + } + Tcl_SetChannelErrorInterp (interp,statePtr->unreportedMsg); } if (errorCode == 0) { errorCode = result; if (errorCode != 0) { Tcl_SetErrno(errorCode); @@ -2349,15 +2448,14 @@ Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC); return Tcl_Close(interp, (Tcl_Channel) downChanPtr); } /* - * There is only the TOP Channel, so we free the remaining - * pointers we have and then ourselves. Since this is the - * last of the channels in the stack, make sure to free the - * ChannelState structure associated with it. We use - * Tcl_EventuallyFree to allow for any last + * There is only the TOP Channel, so we free the remaining pointers we + * have and then ourselves. Since this is the last of the channels in the + * stack, make sure to free the ChannelState structure associated with it. + * We use Tcl_EventuallyFree to allow for any last references. */ chanPtr->typePtr = NULL; Tcl_EventuallyFree((ClientData) statePtr, TCL_DYNAMIC); @@ -2368,34 +2466,33 @@ /* *---------------------------------------------------------------------- * * Tcl_CutChannel -- + * CutChannel -- * - * Removes a channel from the (thread-)global list of all channels - * (in that thread). This is actually the statePtr for the stack - * of channel. + * Removes a channel from the (thread-)global list of all channels (in + * that thread). This is actually the statePtr for the stack of channel. * * Results: * Nothing. * * Side effects: * Resets the field 'nextCSPtr' of the specified channel state to NULL. * * NOTE: - * The channel to splice out of the list must not be referenced - * in any interpreter. This is something this procedure cannot - * check (despite the refcount) because the caller usually wants - * fiddle with the channel (like transfering it to a different - * thread) and thus keeps the refcount artifically high to prevent - * its destruction. + * The channel to cut out of the list must not be referenced in any + * interpreter. This is something this procedure cannot check (despite + * the refcount) because the caller usually wants fiddle with the channel + * (like transfering it to a different thread) and thus keeps the + * refcount artifically high to prevent its destruction. * *---------------------------------------------------------------------- */ -void -Tcl_CutChannel(chan) +static void +CutChannel(chan) Tcl_Channel chan; /* The channel being removed. Must * not be referenced in any * interpreter. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -2402,14 +2499,59 @@ ChannelState *prevCSPtr; /* Preceding channel state in list of * all states - used to splice a * channel out of the list on close. */ ChannelState *statePtr = ((Channel *) chan)->state; /* state of the channel stack. */ + Tcl_DriverThreadActionProc *threadActionProc; /* - * Remove this channel from of the list of all channels - * (in the current thread). + * Remove this channel from of the list of all channels (in the current + * thread). + */ + + if (tsdPtr->firstCSPtr && (statePtr == tsdPtr->firstCSPtr)) { + tsdPtr->firstCSPtr = statePtr->nextCSPtr; + } else { + for (prevCSPtr = tsdPtr->firstCSPtr; + prevCSPtr && (prevCSPtr->nextCSPtr != statePtr); + prevCSPtr = prevCSPtr->nextCSPtr) { + /* Empty loop body. */ + } + if (prevCSPtr == (ChannelState *) NULL) { + Tcl_Panic("FlushChannel: damaged channel list"); + } + prevCSPtr->nextCSPtr = statePtr->nextCSPtr; + } + + statePtr->nextCSPtr = (ChannelState *) NULL; + + /* TIP #218, Channel Thread Actions */ + threadActionProc = Tcl_ChannelThreadActionProc(Tcl_GetChannelType(chan)); + if (threadActionProc != NULL) { + (*threadActionProc) (Tcl_GetChannelInstanceData(chan), + TCL_CHANNEL_THREAD_REMOVE); + } +} + +void +Tcl_CutChannel(chan) + Tcl_Channel chan; /* The channel being added. Must not + * be referenced in any + * interpreter. */ +{ + Channel* chanPtr = ((Channel*) chan)->state->bottomChanPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ChannelState *prevCSPtr; /* Preceding channel state in list of + * all states - used to splice a + * channel out of the list on close. */ + ChannelState *statePtr = chanPtr->state; + /* state of the channel stack. */ + Tcl_DriverThreadActionProc *threadActionProc; + + /* + * Remove this channel from of the list of all channels (in the current + * thread). */ if (tsdPtr->firstCSPtr && (statePtr == tsdPtr->firstCSPtr)) { tsdPtr->firstCSPtr = statePtr->nextCSPtr; } else { @@ -2424,66 +2566,121 @@ prevCSPtr->nextCSPtr = statePtr->nextCSPtr; } statePtr->nextCSPtr = (ChannelState *) NULL; - TclpCutFileChannel(chan); - TclpCutSockChannel(chan); + /* TIP #218, Channel Thread Actions + * For all transformations and the base channel. + */ + + while (chanPtr) { + threadActionProc = Tcl_ChannelThreadActionProc(chanPtr->typePtr); + if (threadActionProc != NULL) { + (*threadActionProc) (chanPtr->instanceData, + TCL_CHANNEL_THREAD_REMOVE); + } + chanPtr= chanPtr->upChanPtr; + } } /* *---------------------------------------------------------------------- * * Tcl_SpliceChannel -- + * SpliceChannel -- * - * Adds a channel to the (thread-)global list of all channels - * (in that thread). Expects that the field 'nextChanPtr' in - * the channel is set to NULL. + * Adds a channel to the (thread-)global list of all channels (in that + * thread). Expects that the field 'nextChanPtr' in the channel is set to + * NULL. * * Results: * Nothing. * * Side effects: * Nothing. * * NOTE: - * The channel to add to the list must not be referenced in any - * interpreter. This is something this procedure cannot check - * (despite the refcount) because the caller usually wants figgle - * with the channel (like transfering it to a different thread) - * and thus keeps the refcount artifically high to prevent its - * destruction. + * The channel to splice into the list must not be referenced in any + * interpreter. This is something this procedure cannot check (despite + * the refcount) because the caller usually wants figgle with the channel + * (like transfering it to a different thread) and thus keeps the + * refcount artifically high to prevent its destruction. * *---------------------------------------------------------------------- */ + +static void +SpliceChannel(chan) + Tcl_Channel chan; /* The channel being added. Must not + * be referenced in any + * interpreter. */ +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ChannelState *statePtr = ((Channel *) chan)->state; + Tcl_DriverThreadActionProc *threadActionProc; + + if (statePtr->nextCSPtr != (ChannelState *) NULL) { + Tcl_Panic("SpliceChannel: trying to add channel used in different list"); + } + + statePtr->nextCSPtr = tsdPtr->firstCSPtr; + tsdPtr->firstCSPtr = statePtr; + + /* + * TIP #10. Mark the current thread as the new one managing this channel. + * Note: 'Tcl_GetCurrentThread' returns sensible values even for + * a non-threaded core. + */ + + statePtr->managingThread = Tcl_GetCurrentThread(); + + /* TIP #218, Channel Thread Actions */ + threadActionProc = Tcl_ChannelThreadActionProc(Tcl_GetChannelType(chan)); + if (threadActionProc != NULL) { + (*threadActionProc) (Tcl_GetChannelInstanceData(chan), + TCL_CHANNEL_THREAD_INSERT); + } +} void Tcl_SpliceChannel(chan) - Tcl_Channel chan; /* The channel being added. Must - * not be referenced in any + Tcl_Channel chan; /* The channel being added. Must not + * be referenced in any * interpreter. */ { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - ChannelState *statePtr = ((Channel *) chan)->state; + Channel *chanPtr = ((Channel*) chan)->state->bottomChanPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ChannelState *statePtr = chanPtr->state; + Tcl_DriverThreadActionProc *threadActionProc; if (statePtr->nextCSPtr != (ChannelState *) NULL) { - Tcl_Panic("Tcl_SpliceChannel: trying to add channel used in different list"); + Tcl_Panic("SpliceChannel: trying to add channel used in different list"); } statePtr->nextCSPtr = tsdPtr->firstCSPtr; tsdPtr->firstCSPtr = statePtr; /* - * TIP #10. Mark the current thread as the new one managing this - * channel. Note: 'Tcl_GetCurrentThread' returns sensible - * values even for a non-threaded core. + * TIP #10. Mark the current thread as the new one managing this channel. + * Note: 'Tcl_GetCurrentThread' returns sensible values even for + * a non-threaded core. */ statePtr->managingThread = Tcl_GetCurrentThread(); - TclpSpliceFileChannel(chan); - TclpSpliceSockChannel(chan); + /* TIP #218, Channel Thread Actions + * For all transformations and the base channel. + */ + + while (chanPtr) { + threadActionProc = Tcl_ChannelThreadActionProc(chanPtr->typePtr); + if (threadActionProc != NULL) { + (*threadActionProc) (chanPtr->instanceData, + TCL_CHANNEL_THREAD_INSERT); + } + chanPtr= chanPtr->upChanPtr; + } } /* *---------------------------------------------------------------------- * @@ -2497,30 +2694,31 @@ * Side effects: * Closes the channel if this is the last reference. * * NOTE: * Tcl_Close removes the channel as far as the user is concerned. - * However, it may continue to exist for a while longer if it has - * a background flush scheduled. The device itself is eventually - * closed and the channel record removed, in CloseChannel, above. + * However, it may continue to exist for a while longer if it has a + * background flush scheduled. The device itself is eventually closed and + * the channel record removed, in CloseChannel, above. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_Close(interp, chan) Tcl_Interp *interp; /* Interpreter for errors. */ - Tcl_Channel chan; /* The channel being closed. Must - * not be referenced in any + Tcl_Channel chan; /* The channel being closed. Must not + * be referenced in any * interpreter. */ { - CloseCallback *cbPtr; /* Iterate over close callbacks - * for this channel. */ + CloseCallback *cbPtr; /* Iterate over close callbacks for + * this channel. */ Channel *chanPtr; /* The real IO channel. */ ChannelState *statePtr; /* State of real IO channel. */ int result; /* Of calling FlushChannel. */ + int flushcode; if (chan == (Tcl_Channel) NULL) { return TCL_OK; } @@ -2555,14 +2753,28 @@ /* * When the channel has an escape sequence driven encoding such as * iso2022, the terminated escape sequence must write to the buffer. */ + if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL) && (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) { statePtr->outputEncodingFlags |= TCL_ENCODING_END; WriteChars(chanPtr, "", 0); + + /* TIP #219, Tcl Channel Reflection API. + * Move an error message found in the channel bypass into the + * interpreter bypass. Just clear it if there is no interpreter. + */ + + if (statePtr->chanMsg != NULL) { + if (interp != NULL) { + Tcl_SetChannelErrorInterp (interp,statePtr->chanMsg); + } + Tcl_DecrRefCount (statePtr->chanMsg); + statePtr->chanMsg = NULL; + } } Tcl_ClearChannelHandlers(chan); /* @@ -2586,12 +2798,12 @@ (statePtr->curOutPtr->nextAdded > statePtr->curOutPtr->nextRemoved)) { statePtr->flags |= BUFFER_READY; } /* - * If this channel supports it, close the read side, since we don't need it - * anymore and this will help avoid deadlocks on some channel types. + * If this channel supports it, close the read side, since we don't need + * it anymore and this will help avoid deadlocks on some channel types. */ if (chanPtr->typePtr->closeProc == TCL_CLOSE2PROC) { result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData, interp, TCL_CLOSE_READ); @@ -2598,17 +2810,35 @@ } else { result = 0; } /* - * The call to FlushChannel will flush any queued output and invoke - * the close function of the channel driver, or it will set up the - * channel to be flushed and closed asynchronously. + * The call to FlushChannel will flush any queued output and invoke the + * close function of the channel driver, or it will set up the channel to + * be flushed and closed asynchronously. */ statePtr->flags |= CHANNEL_CLOSED; - if ((FlushChannel(interp, chanPtr, 0) != 0) || (result != 0)) { + + flushcode = FlushChannel(interp, chanPtr, 0); + + /* TIP #219. + * Capture error messages put by the driver into the bypass area and put + * them into the regular interpreter result. + * + * Notes: Due to the assertion of CHANNEL_CLOSED in the flags + * "FlushChannel" has called "CloseChannel" and thus freed all the channel + * structures. We must not try to access "chan" anymore, hence the NULL + * argument in the call below. The only place which may still contain a + * message is the interpreter itself, and "CloseChannel" made sure to lift + * any channel message it generated into it. + */ + if (TclChanCaughtErrorBypass (interp, NULL)) { + result = EINVAL; + } + + if ((flushcode != 0) || (result != 0)) { return TCL_ERROR; } return TCL_OK; } @@ -2648,12 +2878,18 @@ chanPtr = (Channel *) channel; statePtr = chanPtr->state; chanPtr = statePtr->topChanPtr; /* - * Remove any references to channel handlers for this channel that - * may be about to be invoked. + * Cancel any outstanding timer. + */ + + Tcl_DeleteTimerHandler(statePtr->timer); + + /* + * Remove any references to channel handlers for this channel that may be + * about to be invoked. */ for (nhPtr = tsdPtr->nestedHandlerPtr; nhPtr != (NextChannelHandler *) NULL; nhPtr = nhPtr->nestedHandlerPtr) { @@ -2662,12 +2898,11 @@ nhPtr->nextHandlerPtr = NULL; } } /* - * Remove all the channel handler records attached to the channel - * itself. + * Remove all the channel handler records attached to the channel itself. */ for (chPtr = statePtr->chPtr; chPtr != (ChannelHandler *) NULL; chPtr = chNext) { @@ -2685,13 +2920,19 @@ /* * Must set the interest mask now to 0, otherwise infinite loops * will occur if Tcl_DoOneEvent is called before the channel is * finally deleted in FlushChannel. This can happen if the channel * has a background flush active. + * Also, delete all registered file handlers for this channel + * (and for the current thread). This prevents executing of pending + * file-events still sitting in the event queue of the current thread. + * We deliberately do not call UpdateInterest() because this could + * re-schedule new events if the channel still needs to be flushed. */ - + statePtr->interestMask = 0; + (chanPtr->typePtr->watchProc)(chanPtr->instanceData, 0); /* * Remove any EventScript records for this channel. */ @@ -2708,15 +2949,15 @@ /* *---------------------------------------------------------------------- * * Tcl_Write -- * - * Puts a sequence of bytes into an output buffer, may queue the - * buffer for output if it gets full, and also remembers whether the - * current buffer is ready e.g. if it contains a newline and we are in - * line buffering mode. Compensates stacking, i.e. will redirect the - * data from the specified channel to the topmost channel in a stack. + * Puts a sequence of bytes into an output buffer, may queue the buffer + * for output if it gets full, and also remembers whether the current + * buffer is ready e.g. if it contains a newline and we are in line + * buffering mode. Compensates stacking, i.e. will redirect the data from + * the specified channel to the topmost channel in a stack. * * No encoding conversions are applied to the bytes being read. * * Results: * The number of bytes written or -1 in case of error. If -1, @@ -2759,15 +3000,15 @@ /* *---------------------------------------------------------------------- * * Tcl_WriteRaw -- * - * Puts a sequence of bytes into an output buffer, may queue the - * buffer for output if it gets full, and also remembers whether the - * current buffer is ready e.g. if it contains a newline and we are in - * line buffering mode. Writes directly to the driver of the channel, - * does not compensate for stacking. + * Puts a sequence of bytes into an output buffer, may queue the buffer + * for output if it gets full, and also remembers whether the current + * buffer is ready e.g. if it contains a newline and we are in line + * buffering mode. Writes directly to the driver of the channel, does not + * compensate for stacking. * * No encoding conversions are applied to the bytes being read. * * Results: * The number of bytes written or -1 in case of error. If -1, @@ -2818,15 +3059,15 @@ *--------------------------------------------------------------------------- * * Tcl_WriteChars -- * * Takes a sequence of UTF-8 characters and converts them for output - * using the channel's current encoding, may queue the buffer for - * output if it gets full, and also remembers whether the current - * buffer is ready e.g. if it contains a newline and we are in - * line buffering mode. Compensates stacking, i.e. will redirect the - * data from the specified channel to the topmost channel in a stack. + * using the channel's current encoding, may queue the buffer for output + * if it gets full, and also remembers whether the current buffer is + * ready e.g. if it contains a newline and we are in line buffering + * mode. Compensates stacking, i.e. will redirect the data from the + * specified channel to the topmost channel in a stack. * * Results: * The number of bytes written or -1 in case of error. If -1, * Tcl_GetErrno will return the error code. * @@ -2838,12 +3079,13 @@ */ int Tcl_WriteChars(chan, src, len) Tcl_Channel chan; /* The channel to buffer output for. */ - CONST char *src; /* UTF-8 characters to queue in output buffer. */ - int len; /* Length of string in bytes, or < 0 for + CONST char *src; /* UTF-8 characters to queue in output + * buffer. */ + int len; /* Length of string in bytes, or < 0 for * strlen(). */ { ChannelState *statePtr; /* state info for channel */ statePtr = ((Channel *) chan)->state; @@ -2859,15 +3101,15 @@ *--------------------------------------------------------------------------- * * DoWriteChars -- * * Takes a sequence of UTF-8 characters and converts them for output - * using the channel's current encoding, may queue the buffer for - * output if it gets full, and also remembers whether the current - * buffer is ready e.g. if it contains a newline and we are in - * line buffering mode. Compensates stacking, i.e. will redirect the - * data from the specified channel to the topmost channel in a stack. + * using the channel's current encoding, may queue the buffer for output + * if it gets full, and also remembers whether the current buffer is + * ready e.g. if it contains a newline and we are in line buffering mode. + * Compensates stacking, i.e. will redirect the data from the specified + * channel to the topmost channel in a stack. * * Results: * The number of bytes written or -1 in case of error. If -1, * Tcl_GetErrno will return the error code. * @@ -2879,12 +3121,13 @@ */ static int DoWriteChars(chanPtr, src, len) Channel *chanPtr; /* The channel to buffer output for. */ - CONST char *src; /* UTF-8 characters to queue in output buffer. */ - int len; /* Length of string in bytes, or < 0 for + CONST char *src; /* UTF-8 characters to queue in output + * buffer. */ + int len; /* Length of string in bytes, or < 0 for * strlen(). */ { /* * Always use the topmost channel of the stack */ @@ -2897,12 +3140,12 @@ if (len < 0) { len = strlen(src); } if (statePtr->encoding == NULL) { /* - * Inefficient way to convert UTF-8 to byte-array, but the - * code parallels the way it is done for objects. + * Inefficient way to convert UTF-8 to byte-array, but the code + * parallels the way it is done for objects. */ Tcl_Obj *objPtr; int result; @@ -2918,21 +3161,21 @@ /* *--------------------------------------------------------------------------- * * Tcl_WriteObj -- * - * Takes the Tcl object and queues its contents for output. If the - * encoding of the channel is NULL, takes the byte-array representation - * of the object and queues those bytes for output. Otherwise, takes - * the characters in the UTF-8 (string) representation of the object - * and converts them for output using the channel's current encoding. - * May flush internal buffers to output if one becomes full or is ready - * for some other reason, e.g. if it contains a newline and the channel - * is in line buffering mode. + * Takes the Tcl object and queues its contents for output. If the + * encoding of the channel is NULL, takes the byte-array representation + * of the object and queues those bytes for output. Otherwise, takes the + * characters in the UTF-8 (string) representation of the object and + * converts them for output using the channel's current encoding. May + * flush internal buffers to output if one becomes full or is ready for + * some other reason, e.g. if it contains a newline and the channel is in + * line buffering mode. * * Results: - * The number of bytes written or -1 in case of error. If -1, + * The number of bytes written or -1 in case of error. If -1, * Tcl_GetErrno() will return the error code. * * Side effects: * May buffer up output and may cause output to be produced on the * channel. @@ -2946,10 +3189,11 @@ Tcl_Obj *objPtr; /* The object to write. */ { /* * Always use the topmost channel of the stack */ + Channel *chanPtr; ChannelState *statePtr; /* state info for channel */ char *src; int srcLen; @@ -2971,14 +3215,14 @@ /* *---------------------------------------------------------------------- * * WriteBytes -- * - * Write a sequence of bytes into an output buffer, may queue the - * buffer for output if it gets full, and also remembers whether the - * current buffer is ready e.g. if it contains a newline and we are in - * line buffering mode. + * Write a sequence of bytes into an output buffer, may queue the buffer + * for output if it gets full, and also remembers whether the current + * buffer is ready e.g. if it contains a newline and we are in line + * buffering mode. * * Results: * The number of bytes written or -1 in case of error. If -1, * Tcl_GetErrno will return the error code. * @@ -3003,12 +3247,12 @@ total = 0; sawLF = 0; savedLF = 0; /* - * Loop over all bytes in src, storing them in output buffer with - * proper EOL translation. + * Loop over all bytes in src, storing them in output buffer with proper + * EOL translation. */ while (srcLen + savedLF > 0) { bufPtr = statePtr->curOutPtr; if (bufPtr == NULL) { @@ -3024,12 +3268,12 @@ toWrite = srcLen; } if (savedLF) { /* - * A '\n' was left over from last call to TranslateOutputEOL() - * and we need to store it in this buffer. If the channel is + * A '\n' was left over from last call to TranslateOutputEOL() and + * we need to store it in this buffer. If the channel is * line-based, we will need to flush it. */ *dst++ = '\n'; dstLen--; @@ -3060,15 +3304,14 @@ /* *---------------------------------------------------------------------- * * WriteChars -- * - * Convert UTF-8 bytes to the channel's external encoding and - * write the produced bytes into an output buffer, may queue the - * buffer for output if it gets full, and also remembers whether the - * current buffer is ready e.g. if it contains a newline and we are in - * line buffering mode. + * Convert UTF-8 bytes to the channel's external encoding and write the + * produced bytes into an output buffer, may queue the buffer for output + * if it gets full, and also remembers whether the current buffer is + * ready e.g. if it contains a newline and we are in line buffering mode. * * Results: * The number of bytes written or -1 in case of error. If -1, * Tcl_GetErrno will return the error code. * @@ -3123,14 +3366,14 @@ toWrite = srcLen; } if (savedLF) { /* - * A '\n' was left over from last call to TranslateOutputEOL() - * and we need to store it in the staging buffer. If the - * channel is line-based, we will need to flush the output - * buffer (after translating the staging buffer). + * A '\n' was left over from last call to TranslateOutputEOL() and + * we need to store it in the staging buffer. If the channel is + * line-based, we will need to flush the output buffer (after + * translating the staging buffer). */ *stage++ = '\n'; stageLen--; sawLF++; @@ -3164,13 +3407,12 @@ dst = bufPtr->buf + bufPtr->nextAdded; dstLen = bufPtr->bufLength - bufPtr->nextAdded; if (saved != 0) { /* - * Here's some translated bytes left over from the last - * buffer that we need to stick at the beginning of this - * buffer. + * Here's some translated bytes left over from the last buffer + * that we need to stick at the beginning of this buffer. */ memcpy((VOID *) dst, (VOID *) safe, (size_t) saved); bufPtr->nextAdded += saved; dst += saved; @@ -3219,15 +3461,14 @@ } bufPtr->nextAdded += dstWrote; if (bufPtr->nextAdded > bufPtr->bufLength) { /* * When translating from UTF-8 to external encoding, we - * allowed the translation to produce a character that - * crossed the end of the output buffer, so that we would - * get a completely full buffer before flushing it. The - * extra bytes will be moved to the beginning of the next - * buffer. + * allowed the translation to produce a character that crossed + * the end of the output buffer, so that we would get a + * completely full buffer before flushing it. The extra bytes + * will be moved to the beginning of the next buffer. */ saved = bufPtr->nextAdded - bufPtr->bufLength; memcpy((VOID *) safe, (VOID *) (dst + dstLen), (size_t) saved); bufPtr->nextAdded = bufPtr->bufLength; @@ -3253,12 +3494,13 @@ endEncoding = 0; } } } - /* If nothing was written and it happened because there was no progress - * in the UTF conversion, we throw an error. + /* + * If nothing was written and it happened because there was no progress in + * the UTF conversion, we throw an error. */ if (!consumedSomething && (total == 0)) { Tcl_SetErrno(EINVAL); return -1; @@ -3269,41 +3511,40 @@ /* *--------------------------------------------------------------------------- * * TranslateOutputEOL -- * - * Helper function for WriteBytes() and WriteChars(). Converts the - * '\n' characters in the source buffer into the appropriate EOL - * form specified by the output translation mode. - * - * EOL translation stops either when the source buffer is empty - * or the output buffer is full. - * - * When converting to CRLF mode and there is only 1 byte left in - * the output buffer, this routine stores the '\r' in the last - * byte and then stores the '\n' in the byte just past the end of the - * buffer. The caller is responsible for passing in a buffer that - * is large enough to hold the extra byte. + * Helper function for WriteBytes() and WriteChars(). Converts the '\n' + * characters in the source buffer into the appropriate EOL form + * specified by the output translation mode. + * + * EOL translation stops either when the source buffer is empty or the + * output buffer is full. + * + * When converting to CRLF mode and there is only 1 byte left in the + * output buffer, this routine stores the '\r' in the last byte and then + * stores the '\n' in the byte just past the end of the buffer. The + * caller is responsible for passing in a buffer that is large enough to + * hold the extra byte. * * Results: - * The return value is 1 if a '\n' was translated from the source - * buffer, or 0 otherwise -- this can be used by the caller to - * decide to flush a line-based channel even though the channel - * buffer is not full. - * - * *dstLenPtr is filled with how many bytes of the output buffer - * were used. As mentioned above, this can be one more that - * the output buffer's specified length if a CRLF was stored. - * - * *srcLenPtr is filled with how many bytes of the source buffer - * were consumed. + * The return value is 1 if a '\n' was translated from the source buffer, + * or 0 otherwise -- this can be used by the caller to decide to flush a + * line-based channel even though the channel buffer is not full. + * + * *dstLenPtr is filled with how many bytes of the output buffer were + * used. As mentioned above, this can be one more that the output + * buffer's specified length if a CRLF was stored. + * + * *srcLenPtr is filled with how many bytes of the source buffer were + * consumed. * * Side effects: - * It may be obvious, but bears mentioning that when converting - * in CRLF mode (which requires two bytes of storage in the output - * buffer), the number of bytes consumed from the source buffer - * will be less than the number of bytes stored in the output buffer. + * It may be obvious, but bears mentioning that when converting in CRLF + * mode (which requires two bytes of storage in the output buffer), the + * number of bytes consumed from the source buffer will be less than the + * number of bytes stored in the output buffer. * *--------------------------------------------------------------------------- */ static int @@ -3315,98 +3556,94 @@ * source characters. */ CONST char *src; /* Source UTF-8 characters. */ int *dstLenPtr; /* On entry, the maximum length of output * buffer in bytes. On exit, the number of * bytes actually used in output buffer. */ - int *srcLenPtr; /* On entry, the length of source buffer. - * On exit, the number of bytes read from - * the source buffer. */ + int *srcLenPtr; /* On entry, the length of source buffer. On + * exit, the number of bytes read from the + * source buffer. */ { char *dstEnd; int srcLen, newlineFound; newlineFound = 0; srcLen = *srcLenPtr; switch (statePtr->outputTranslation) { - case TCL_TRANSLATE_LF: { - for (dstEnd = dst + srcLen; dst < dstEnd; ) { - if (*src == '\n') { - newlineFound = 1; - } - *dst++ = *src++; - } - *dstLenPtr = srcLen; - break; - } - case TCL_TRANSLATE_CR: { - for (dstEnd = dst + srcLen; dst < dstEnd;) { - if (*src == '\n') { - *dst++ = '\r'; - newlineFound = 1; - src++; - } else { - *dst++ = *src++; - } - } - *dstLenPtr = srcLen; - break; - } - case TCL_TRANSLATE_CRLF: { - /* - * Since this causes the number of bytes to grow, we - * start off trying to put 'srcLen' bytes into the - * output buffer, but allow it to store more bytes, as - * long as there's still source bytes and room in the - * output buffer. - */ - - char *dstStart, *dstMax; - CONST char *srcStart; - - dstStart = dst; - dstMax = dst + *dstLenPtr; - - srcStart = src; - - if (srcLen < *dstLenPtr) { - dstEnd = dst + srcLen; - } else { - dstEnd = dst + *dstLenPtr; - } - while (dst < dstEnd) { - if (*src == '\n') { - if (dstEnd < dstMax) { - dstEnd++; - } - *dst++ = '\r'; - newlineFound = 1; - } - *dst++ = *src++; - } - *srcLenPtr = src - srcStart; - *dstLenPtr = dst - dstStart; - break; - } - default: { - break; - } + case TCL_TRANSLATE_LF: + for (dstEnd = dst + srcLen; dst < dstEnd; ) { + if (*src == '\n') { + newlineFound = 1; + } + *dst++ = *src++; + } + *dstLenPtr = srcLen; + break; + case TCL_TRANSLATE_CR: + for (dstEnd = dst + srcLen; dst < dstEnd;) { + if (*src == '\n') { + *dst++ = '\r'; + newlineFound = 1; + src++; + } else { + *dst++ = *src++; + } + } + *dstLenPtr = srcLen; + break; + case TCL_TRANSLATE_CRLF: { + /* + * Since this causes the number of bytes to grow, we start off trying + * to put 'srcLen' bytes into the output buffer, but allow it to store + * more bytes, as long as there's still source bytes and room in the + * output buffer. + */ + + char *dstStart, *dstMax; + CONST char *srcStart; + + dstStart = dst; + dstMax = dst + *dstLenPtr; + + srcStart = src; + + if (srcLen < *dstLenPtr) { + dstEnd = dst + srcLen; + } else { + dstEnd = dst + *dstLenPtr; + } + while (dst < dstEnd) { + if (*src == '\n') { + if (dstEnd < dstMax) { + dstEnd++; + } + *dst++ = '\r'; + newlineFound = 1; + } + *dst++ = *src++; + } + *srcLenPtr = src - srcStart; + *dstLenPtr = dst - dstStart; + break; + } + default: + break; } return newlineFound; } /* *--------------------------------------------------------------------------- * * CheckFlush -- * - * Helper function for WriteBytes() and WriteChars(). If the - * channel buffer is ready to be flushed, flush it. + * Helper function for WriteBytes() and WriteChars(). If the channel + * buffer is ready to be flushed, flush it. * * Results: - * The return value is -1 if there was a problem flushing the - * channel buffer, or 0 otherwise. + * The return value is -1 if there was a problem flushing the channel + * buffer, or 0 otherwise. * * Side effects: * The buffer will be recycled if it is flushed. * *--------------------------------------------------------------------------- @@ -3414,12 +3651,12 @@ static int CheckFlush(chanPtr, bufPtr, newlineFlag) Channel *chanPtr; /* Channel being read, for buffering mode. */ ChannelBuffer *bufPtr; /* Channel buffer to possibly flush. */ - int newlineFlag; /* Non-zero if a the channel buffer - * contains a newline. */ + int newlineFlag; /* Non-zero if a the channel buffer contains a + * newline. */ { ChannelState *statePtr = chanPtr->state; /* state info for channel */ /* * The current buffer is ready for output: * 1. if it is full. @@ -3457,12 +3694,12 @@ * Length of line read (in characters) or -1 if error, EOF, or blocked. * If -1, use Tcl_GetErrno() to retrieve the POSIX error code for the * error or condition that occurred. * * Side effects: - * May flush output on the channel. May cause input to be consumed - * from the channel. + * May flush output on the channel. May cause input to be consumed from + * the channel. * *--------------------------------------------------------------------------- */ int @@ -3491,25 +3728,23 @@ *--------------------------------------------------------------------------- * * Tcl_GetsObj -- * * Accumulate input from the input channel until end-of-line or - * end-of-file has been seen. Bytes read from the input channel - * are converted to UTF-8 using the encoding specified by the - * channel. + * end-of-file has been seen. Bytes read from the input channel are + * converted to UTF-8 using the encoding specified by the channel. * * Results: * Number of characters accumulated in the object or -1 if error, - * blocked, or EOF. If -1, use Tcl_GetErrno() to retrieve the - * POSIX error code for the error or condition that occurred. + * blocked, or EOF. If -1, use Tcl_GetErrno() to retrieve the POSIX + * error code for the error or condition that occurred. * * Side effects: * Consumes input from the channel. * - * On reading EOF, leave channel pointing at EOF char. - * On reading EOL, leave channel pointing after EOL, but don't - * return EOL in dst buffer. + * On reading EOF, leave channel pointing at EOF char. On reading EOL, + * leave channel pointing after EOL, but don't return EOL in dst buffer. * *--------------------------------------------------------------------------- */ int @@ -3540,12 +3775,12 @@ bufPtr = statePtr->inQueueHead; encoding = statePtr->encoding; /* - * Preserved so we can restore the channel's state in case we don't - * find a newline in the available input. + * Preserved so we can restore the channel's state in case we don't find a + * newline in the available input. */ Tcl_GetStringFromObj(objPtr, &oldLength); oldFlags = statePtr->inputEncodingFlags; oldState = statePtr->inputEncodingState; @@ -3554,20 +3789,20 @@ oldRemoved = bufPtr->nextRemoved; } /* * If there is no encoding, use "iso8859-1" -- Tcl_GetsObj() doesn't - * produce ByteArray objects. + * produce ByteArray objects. */ if (encoding == NULL) { encoding = Tcl_GetEncoding(NULL, "iso8859-1"); } /* - * Object used by FilterInputBytes to keep track of how much data has - * been consumed from the channel buffers. + * Object used by FilterInputBytes to keep track of how much data has been + * consumed from the channel buffers. */ gs.objPtr = objPtr; gs.dstPtr = &dst; gs.encoding = encoding; @@ -3592,12 +3827,12 @@ } dstEnd = dst + gs.bytesWrote; } /* - * Remember if EOF char is seen, then look for EOL anyhow, because - * the EOL might be before the EOF char. + * Remember if EOF char is seen, then look for EOL anyhow, because the + * EOL might be before the EOF char. */ if (inEofChar != '\0') { for (eol = dst; eol < dstEnd; eol++) { if (*eol == inEofChar) { @@ -3612,119 +3847,113 @@ * On EOL, leave current file position pointing after the EOL, but * don't store the EOL in the output string. */ switch (statePtr->inputTranslation) { - case TCL_TRANSLATE_LF: { - for (eol = dst; eol < dstEnd; eol++) { - if (*eol == '\n') { - skip = 1; - goto goteol; - } - } - break; - } - case TCL_TRANSLATE_CR: { - for (eol = dst; eol < dstEnd; eol++) { - if (*eol == '\r') { - skip = 1; - goto goteol; - } - } - break; - } - case TCL_TRANSLATE_CRLF: { - for (eol = dst; eol < dstEnd; eol++) { - if (*eol == '\r') { - eol++; - - /* - * If a CR is at the end of the buffer, - * then check for a LF at the begining - * of the next buffer. - */ - - if (eol >= dstEnd) { - int offset; - - offset = eol - objPtr->bytes; - dst = dstEnd; - if (FilterInputBytes(chanPtr, &gs) != 0) { - goto restore; - } - dstEnd = dst + gs.bytesWrote; - eol = objPtr->bytes + offset; - if (eol >= dstEnd) { - skip = 0; - goto goteol; - } - } - if (*eol == '\n') { - eol--; - skip = 2; - goto goteol; - } - } - } - break; - } - case TCL_TRANSLATE_AUTO: { - eol = dst; - skip = 1; - if (statePtr->flags & INPUT_SAW_CR) { - statePtr->flags &= ~INPUT_SAW_CR; - if ((eol < dstEnd) && (*eol == '\n')) { - /* - * Skip the raw bytes that make up the '\n'. - */ - - char tmp[1 + TCL_UTF_MAX]; - int rawRead; - - bufPtr = gs.bufPtr; - Tcl_ExternalToUtf(NULL, gs.encoding, - bufPtr->buf + bufPtr->nextRemoved, - gs.rawRead, statePtr->inputEncodingFlags, - &gs.state, tmp, 1 + TCL_UTF_MAX, &rawRead, - NULL, NULL); - bufPtr->nextRemoved += rawRead; - gs.rawRead -= rawRead; - gs.bytesWrote--; - gs.charsWrote--; - memmove(dst, dst + 1, (size_t) (dstEnd - dst)); - dstEnd--; - } - } - for (eol = dst; eol < dstEnd; eol++) { - if (*eol == '\r') { - eol++; - if (eol == dstEnd) { - /* - * If buffer ended on \r, peek ahead to see if a - * \n is available. - */ - - int offset; - - offset = eol - objPtr->bytes; - dst = dstEnd; - PeekAhead(chanPtr, &dstEnd, &gs); - eol = objPtr->bytes + offset; - if (eol >= dstEnd) { - eol--; - statePtr->flags |= INPUT_SAW_CR; - goto goteol; - } - } - if (*eol == '\n') { - skip++; - } - eol--; - goto goteol; - } else if (*eol == '\n') { - goto goteol; - } + case TCL_TRANSLATE_LF: + for (eol = dst; eol < dstEnd; eol++) { + if (*eol == '\n') { + skip = 1; + goto gotEOL; + } + } + break; + case TCL_TRANSLATE_CR: + for (eol = dst; eol < dstEnd; eol++) { + if (*eol == '\r') { + skip = 1; + goto gotEOL; + } + } + break; + case TCL_TRANSLATE_CRLF: + for (eol = dst; eol < dstEnd; eol++) { + if (*eol == '\r') { + eol++; + + /* + * If a CR is at the end of the buffer, then check for a + * LF at the begining of the next buffer. + */ + + if (eol >= dstEnd) { + int offset; + + offset = eol - objPtr->bytes; + dst = dstEnd; + if (FilterInputBytes(chanPtr, &gs) != 0) { + goto restore; + } + dstEnd = dst + gs.bytesWrote; + eol = objPtr->bytes + offset; + if (eol >= dstEnd) { + skip = 0; + goto gotEOL; + } + } + if (*eol == '\n') { + eol--; + skip = 2; + goto gotEOL; + } + } + } + break; + case TCL_TRANSLATE_AUTO: + eol = dst; + skip = 1; + if (statePtr->flags & INPUT_SAW_CR) { + statePtr->flags &= ~INPUT_SAW_CR; + if ((eol < dstEnd) && (*eol == '\n')) { + /* + * Skip the raw bytes that make up the '\n'. + */ + + char tmp[1 + TCL_UTF_MAX]; + int rawRead; + + bufPtr = gs.bufPtr; + Tcl_ExternalToUtf(NULL, gs.encoding, + bufPtr->buf + bufPtr->nextRemoved, gs.rawRead, + statePtr->inputEncodingFlags, &gs.state, tmp, + 1 + TCL_UTF_MAX, &rawRead, NULL, NULL); + bufPtr->nextRemoved += rawRead; + gs.rawRead -= rawRead; + gs.bytesWrote--; + gs.charsWrote--; + memmove(dst, dst + 1, (size_t) (dstEnd - dst)); + dstEnd--; + } + } + for (eol = dst; eol < dstEnd; eol++) { + if (*eol == '\r') { + eol++; + if (eol == dstEnd) { + /* + * If buffer ended on \r, peek ahead to see if a \n is + * available. + */ + + int offset; + + offset = eol - objPtr->bytes; + dst = dstEnd; + PeekAhead(chanPtr, &dstEnd, &gs); + eol = objPtr->bytes + offset; + if (eol >= dstEnd) { + eol--; + statePtr->flags |= INPUT_SAW_CR; + goto gotEOL; + } + } + if (*eol == '\n') { + skip++; + } + eol--; + goto gotEOL; + } else if (*eol == '\n') { + goto gotEOL; } } } if (eof != NULL) { /* @@ -3749,24 +3978,24 @@ Tcl_SetObjLength(objPtr, oldLength); CommonGetsCleanup(chanPtr, encoding); copiedTotal = -1; goto done; } - goto goteol; + goto gotEOL; } dst = dstEnd; } /* - * Found EOL or EOF, but the output buffer may now contain too many - * UTF-8 characters. We need to know how many raw bytes correspond to - * the number of UTF-8 characters we want, plus how many raw bytes - * correspond to the character(s) making up EOL (if any), so we can - * remove the correct number of bytes from the channel buffer. + * Found EOL or EOF, but the output buffer may now contain too many UTF-8 + * characters. We need to know how many raw bytes correspond to the + * number of UTF-8 characters we want, plus how many raw bytes correspond + * to the character(s) making up EOL (if any), so we can remove the + * correct number of bytes from the channel buffer. */ - goteol: + gotEOL: bufPtr = gs.bufPtr; statePtr->inputEncodingState = gs.state; Tcl_ExternalToUtf(NULL, gs.encoding, bufPtr->buf + bufPtr->nextRemoved, gs.rawRead, statePtr->inputEncodingFlags, &statePtr->inputEncodingState, dst, @@ -3784,15 +4013,15 @@ copiedTotal = gs.totalChars + gs.charsWrote - skip; goto done; /* * Couldn't get a complete line. This only happens if we get a error - * reading from the channel or we are non-blocking and there wasn't - * an EOL or EOF in the data available. + * reading from the channel or we are non-blocking and there wasn't an EOL + * or EOF in the data available. */ - restore: + restore: bufPtr = statePtr->inQueueHead; bufPtr->nextRemoved = oldRemoved; for (bufPtr = bufPtr->nextPtr; bufPtr != NULL; bufPtr = bufPtr->nextPtr) { bufPtr->nextRemoved = BUFFER_PADDING; @@ -3803,52 +4032,52 @@ statePtr->inputEncodingFlags = oldFlags; Tcl_SetObjLength(objPtr, oldLength); /* * We didn't get a complete line so we need to indicate to UpdateInterest - * that the gets blocked. It will wait for more data instead of firing - * a timer, avoiding a busy wait. This is where we are assuming that the - * next operation is a gets. No more file events will be delivered on - * this channel until new data arrives or some operation is performed - * on the channel (e.g. gets, read, fconfigure) that changes the blocking + * that the gets blocked. It will wait for more data instead of firing a + * timer, avoiding a busy wait. This is where we are assuming that the + * next operation is a gets. No more file events will be delivered on + * this channel until new data arrives or some operation is performed on + * the channel (e.g. gets, read, fconfigure) that changes the blocking * state. Note that this means a file event will not be delivered even * though a read would be able to consume the buffered data. */ statePtr->flags |= CHANNEL_NEED_MORE_DATA; copiedTotal = -1; - done: /* - * Update the notifier state so we don't block while there is still - * data in the buffers. + * Update the notifier state so we don't block while there is still data + * in the buffers. */ + done: UpdateInterest(chanPtr); return copiedTotal; } /* *--------------------------------------------------------------------------- * * FilterInputBytes -- * - * Helper function for Tcl_GetsObj. Produces UTF-8 characters from - * raw bytes read from the channel. + * Helper function for Tcl_GetsObj. Produces UTF-8 characters from raw + * bytes read from the channel. * - * Consumes available bytes from channel buffers. When channel - * buffers are exhausted, reads more bytes from channel device into - * a new channel buffer. It is the caller's responsibility to - * free the channel buffers that have been exhausted. + * Consumes available bytes from channel buffers. When channel buffers + * are exhausted, reads more bytes from channel device into a new channel + * buffer. It is the caller's responsibility to free the channel buffers + * that have been exhausted. * * Results: - * The return value is -1 if there was an error reading from the - * channel, 0 otherwise. + * The return value is -1 if there was an error reading from the channel, + * 0 otherwise. * * Side effects: - * Status object keeps track of how much data from channel buffers - * has been consumed and where UTF-8 bytes should be stored. + * Status object keeps track of how much data from channel buffers has + * been consumed and where UTF-8 bytes should be stored. * *--------------------------------------------------------------------------- */ static int @@ -3860,13 +4089,13 @@ ChannelBuffer *bufPtr; char *raw, *rawStart, *rawEnd; char *dst; int offset, toRead, dstNeeded, spaceLeft, result, rawLen, length; Tcl_Obj *objPtr; -#define ENCODING_LINESIZE 20 /* Lower bound on how many bytes to convert - * at a time. Since we don't know a priori - * how many bytes of storage this many source +#define ENCODING_LINESIZE 20 /* Lower bound on how many bytes to convert at + * a time. Since we don't know a priori how + * many bytes of storage this many source * bytes will use, we actually need at least * ENCODING_LINESIZE * TCL_MAX_UTF bytes of * room. */ objPtr = gsPtr->objPtr; @@ -3885,16 +4114,16 @@ } gsPtr->totalChars += gsPtr->charsWrote; if ((bufPtr == NULL) || (bufPtr->nextAdded == BUFFER_PADDING)) { /* - * All channel buffers were exhausted and the caller still hasn't - * seen EOL. Need to read more bytes from the channel device. - * Side effect is to allocate another channel buffer. + * All channel buffers were exhausted and the caller still hasn't seen + * EOL. Need to read more bytes from the channel device. Side effect + * is to allocate another channel buffer. */ - read: + read: if (statePtr->flags & CHANNEL_BLOCKED) { if (statePtr->flags & CHANNEL_NONBLOCKING) { gsPtr->charsWrote = 0; gsPtr->rawRead = 0; return -1; @@ -3954,12 +4183,12 @@ statePtr->inputEncodingFlags &= ~TCL_ENCODING_START; if (result == TCL_CONVERT_MULTIBYTE) { /* * The last few bytes in this channel buffer were the start of a - * multibyte sequence. If this buffer was full, then move them to - * the next buffer so the bytes will be contiguous. + * multibyte sequence. If this buffer was full, then move them to the + * next buffer so the bytes will be contiguous. */ ChannelBuffer *nextPtr; int extra; @@ -3978,12 +4207,12 @@ */ bufPtr->nextRemoved = bufPtr->nextAdded; } else { /* - * There are no more cached raw bytes left. See if we can - * get some more. + * There are no more cached raw bytes left. See if we can get + * some more. */ goto read; } } else { @@ -4007,13 +4236,13 @@ /* *--------------------------------------------------------------------------- * * PeekAhead -- * - * Helper function used by Tcl_GetsObj(). Called when we've seen a - * \r at the end of the UTF-8 string and want to look ahead one - * character to see if it is a \n. + * Helper function used by Tcl_GetsObj(). Called when we've seen a \r at + * the end of the UTF-8 string and want to look ahead one character to + * see if it is a \n. * * Results: * *gsPtr->dstPtr is filled with a pointer to the start of the range of * UTF-8 characters that were found by peeking and *dstEndPtr is filled * with a pointer to the bytes just after the end of the range. @@ -4027,12 +4256,12 @@ */ static void PeekAhead(chanPtr, dstEndPtr, gsPtr) Channel *chanPtr; /* The channel to read. */ - char **dstEndPtr; /* Filled with pointer to end of new range - * of UTF-8 characters. */ + char **dstEndPtr; /* Filled with pointer to end of new range of + * UTF-8 characters. */ GetsState *gsPtr; /* Current state of gets operation. */ { ChannelState *statePtr = chanPtr->state; /* state info for channel */ ChannelBuffer *bufPtr; Tcl_DriverBlockModeProc *blockModeProc; @@ -4040,14 +4269,14 @@ bufPtr = gsPtr->bufPtr; /* * If there's any more raw input that's still buffered, we'll peek into - * that. Otherwise, only get more data from the channel driver if it - * looks like there might actually be more data. The assumption is that - * if the channel buffer is filled right up to the end, then there - * might be more data to read. + * that. Otherwise, only get more data from the channel driver if it looks + * like there might actually be more data. The assumption is that if the + * channel buffer is filled right up to the end, then there might be more + * data to read. */ blockModeProc = NULL; if (bufPtr->nextPtr == NULL) { bytesLeft = bufPtr->nextAdded - (bufPtr->nextRemoved + gsPtr->rawRead); @@ -4078,11 +4307,11 @@ if (blockModeProc != NULL) { StackSetBlockMode(chanPtr, TCL_MODE_BLOCKING); } return; - cleanup: + cleanup: bufPtr->nextRemoved += gsPtr->rawRead; gsPtr->rawRead = 0; gsPtr->totalChars += gsPtr->charsWrote; gsPtr->bytesWrote = 0; gsPtr->charsWrote = 0; @@ -4091,12 +4320,12 @@ /* *--------------------------------------------------------------------------- * * CommonGetsCleanup -- * - * Helper function for Tcl_GetsObj() to restore the channel after - * a "gets" operation. + * Helper function for Tcl_GetsObj() to restore the channel after a + * "gets" operation. * * Results: * None. * * Side effects: @@ -4157,20 +4386,20 @@ /* *---------------------------------------------------------------------- * * Tcl_Read -- * - * Reads a given number of bytes from a channel. EOL and EOF - * translation is done on the bytes being read, so the number - * of bytes consumed from the channel may not be equal to the - * number of bytes stored in the destination buffer. + * Reads a given number of bytes from a channel. EOL and EOF translation + * is done on the bytes being read, so the number of bytes consumed from + * the channel may not be equal to the number of bytes stored in the + * destination buffer. * * No encoding conversions are applied to the bytes being read. * * Results: - * The number of bytes read, or -1 on error. Use Tcl_GetErrno() - * to retrieve the error code for the error that occurred. + * The number of bytes read, or -1 on error. Use Tcl_GetErrno() to + * retrieve the error code for the error that occurred. * * Side effects: * May cause input to be buffered. * *---------------------------------------------------------------------- @@ -4180,11 +4409,11 @@ Tcl_Read(chan, dst, bytesToRead) Tcl_Channel chan; /* The channel from which to read. */ char *dst; /* Where to store input read. */ int bytesToRead; /* Maximum number of bytes to read. */ { - Channel *chanPtr = (Channel *) chan; + Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* state info for channel */ /* * This operation should occur at the top of a channel stack. */ @@ -4201,20 +4430,20 @@ /* *---------------------------------------------------------------------- * * Tcl_ReadRaw -- * - * Reads a given number of bytes from a channel. EOL and EOF - * translation is done on the bytes being read, so the number - * of bytes consumed from the channel may not be equal to the - * number of bytes stored in the destination buffer. + * Reads a given number of bytes from a channel. EOL and EOF translation + * is done on the bytes being read, so the number of bytes consumed from + * the channel may not be equal to the number of bytes stored in the + * destination buffer. * * No encoding conversions are applied to the bytes being read. * * Results: - * The number of bytes read, or -1 on error. Use Tcl_GetErrno() - * to retrieve the error code for the error that occurred. + * The number of bytes read, or -1 on error. Use Tcl_GetErrno() to + * retrieve the error code for the error that occurred. * * Side effects: * May cause input to be buffered. * *---------------------------------------------------------------------- @@ -4224,21 +4453,21 @@ Tcl_ReadRaw(chan, bufPtr, bytesToRead) Tcl_Channel chan; /* The channel from which to read. */ char *bufPtr; /* Where to store input read. */ int bytesToRead; /* Maximum number of bytes to read. */ { - Channel *chanPtr = (Channel *) chan; + Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* state info for channel */ int nread, result; int copied, copiedNow; /* * The check below does too much because it will reject a call to this * function with a channel which is part of an 'fcopy'. But we have to - * allow this here or else the chaining in the transformation drivers - * will fail with 'file busy' error instead of retrieving and - * transforming the data to copy. + * allow this here or else the chaining in the transformation drivers will + * fail with 'file busy' error instead of retrieving and transforming the + * data to copy. * * We let the check procedure now believe that there is no fcopy in * progress. A better solution than this might be an additional flag * argument to switch off specific checks. */ @@ -4246,13 +4475,13 @@ if (CheckChannelErrors(statePtr, TCL_READABLE | CHANNEL_RAW_MODE) != 0) { return -1; } /* - * Check for information in the push-back buffers. If there is - * some, use it. Go to the driver only if there is none (anymore) - * and the caller requests more bytes. + * Check for information in the push-back buffers. If there is some, use + * it. Go to the driver only if there is none (anymore) and the caller + * requests more bytes. */ for (copied = 0; copied < bytesToRead; copied += copiedNow) { copiedNow = CopyBuffer(chanPtr, bufPtr + copied, bytesToRead - copied); @@ -4266,42 +4495,46 @@ } statePtr->flags &= (~(CHANNEL_BLOCKED)); } #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING - /* [SF Tcl Bug 943274]. Better emulation of non-blocking - * channels for channels without BlockModeProc, by keeping - * track of true fileevents generated by the OS == Data - * waiting and reading if and only if we are sure to have - * data. + /* + * [SF Tcl Bug 943274]. Better emulation of non-blocking channels + * for channels without BlockModeProc, by keeping track of true + * fileevents generated by the OS == Data waiting and reading if + * and only if we are sure to have data. */ if ((statePtr->flags & CHANNEL_NONBLOCKING) && (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) && !(statePtr->flags & CHANNEL_HAS_MORE_DATA)) { /* - * We bypass the driver, it would block, as no data is - * available + * We bypass the driver; it would block as no data is + * available. */ + nread = -1; result = EWOULDBLOCK; } else { #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ + /* - * Now go to the driver to get as much as is possible to - * fill the remaining request. Do all the error handling - * by ourselves. The code was stolen from 'GetInput' and + * Now go to the driver to get as much as is possible to fill + * the remaining request. Do all the error handling by + * ourselves. The code was stolen from 'GetInput' and * slightly adapted (different return value here). * * The case of 'bytesToRead == 0' at this point cannot happen. */ nread = (chanPtr->typePtr->inputProc)(chanPtr->instanceData, bufPtr + copied, bytesToRead - copied, &result); + #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING } #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ + if (nread > 0) { /* * If we get a short read, signal up that we may be * BLOCKED. We should avoid calling the driver because * on some platforms we will block in the low level @@ -4314,20 +4547,22 @@ } #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING if (nread <= (bytesToRead - copied)) { /* - * [SF Tcl Bug 943274] We have read the available - * data, clear flag. + * [SF Tcl Bug 943274] We have read the available data, + * clear flag. */ statePtr->flags &= ~CHANNEL_HAS_MORE_DATA; } #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ + } else if (nread == 0) { statePtr->flags |= CHANNEL_EOF; statePtr->inputEncodingFlags |= TCL_ENCODING_END; + } else if (nread < 0) { if ((result == EWOULDBLOCK) || (result == EAGAIN)) { if (copied > 0) { /* * Information that was copied earlier has precedence @@ -4341,35 +4576,35 @@ result = EAGAIN; } Tcl_SetErrno(result); return -1; - } + } return copied + nread; } } -done: + done: return copied; } /* *--------------------------------------------------------------------------- * * Tcl_ReadChars -- * - * Reads from the channel until the requested number of characters - * have been seen, EOF is seen, or the channel would block. EOL - * and EOF translation is done. If reading binary data, the raw - * bytes are wrapped in a Tcl byte array object. Otherwise, the raw - * bytes are converted to UTF-8 using the channel's current encoding - * and stored in a Tcl string object. + * Reads from the channel until the requested number of characters have + * been seen, EOF is seen, or the channel would block. EOL and EOF + * translation is done. If reading binary data, the raw bytes are + * wrapped in a Tcl byte array object. Otherwise, the raw bytes are + * converted to UTF-8 using the channel's current encoding and stored in + * a Tcl string object. * * Results: - * The number of characters read, or -1 on error. Use Tcl_GetErrno() - * to retrieve the error code for the error that occurred. + * The number of characters read, or -1 on error. Use Tcl_GetErrno() to + * retrieve the error code for the error that occurred. * * Side effects: * May cause input to be buffered. * *--------------------------------------------------------------------------- @@ -4377,13 +4612,13 @@ int Tcl_ReadChars(chan, objPtr, toRead, appendFlag) Tcl_Channel chan; /* The channel to read. */ Tcl_Obj *objPtr; /* Input data is stored in this object. */ - int toRead; /* Maximum number of characters to store, - * or -1 to read all available data (up to EOF - * or when channel blocks). */ + int toRead; /* Maximum number of characters to store, or + * -1 to read all available data (up to EOF or + * when channel blocks). */ int appendFlag; /* If non-zero, data read from the channel * will be appended to the object. Otherwise, * the data will replace the existing contents * of the object. */ { @@ -4411,20 +4646,20 @@ /* *--------------------------------------------------------------------------- * * DoReadChars -- * - * Reads from the channel until the requested number of characters - * have been seen, EOF is seen, or the channel would block. EOL - * and EOF translation is done. If reading binary data, the raw - * bytes are wrapped in a Tcl byte array object. Otherwise, the raw - * bytes are converted to UTF-8 using the channel's current encoding - * and stored in a Tcl string object. + * Reads from the channel until the requested number of characters have + * been seen, EOF is seen, or the channel would block. EOL and EOF + * translation is done. If reading binary data, the raw bytes are + * wrapped in a Tcl byte array object. Otherwise, the raw bytes are + * converted to UTF-8 using the channel's current encoding and stored in + * a Tcl string object. * * Results: - * The number of characters read, or -1 on error. Use Tcl_GetErrno() - * to retrieve the error code for the error that occurred. + * The number of characters read, or -1 on error. Use Tcl_GetErrno() to + * retrieve the error code for the error that occurred. * * Side effects: * May cause input to be buffered. * *--------------------------------------------------------------------------- @@ -4432,13 +4667,13 @@ static int DoReadChars(chanPtr, objPtr, toRead, appendFlag) Channel *chanPtr; /* The channel to read. */ Tcl_Obj *objPtr; /* Input data is stored in this object. */ - int toRead; /* Maximum number of characters to store, - * or -1 to read all available data (up to EOF - * or when channel blocks). */ + int toRead; /* Maximum number of characters to store, or + * -1 to read all available data (up to EOF or + * when channel blocks). */ int appendFlag; /* If non-zero, data read from the channel * will be appended to the object. Otherwise, * the data will replace the existing contents * of the object. */ { @@ -4459,14 +4694,15 @@ if (appendFlag == 0) { if (encoding == NULL) { Tcl_SetByteArrayLength(objPtr, 0); } else { Tcl_SetObjLength(objPtr, 0); - /* - * We're going to access objPtr->bytes directly, so - * we must ensure that this is actually a string - * object (otherwise it might have been pure Unicode). + + /* + * We're going to access objPtr->bytes directly, so we must ensure + * that this is actually a string object (otherwise it might have + * been pure Unicode). */ Tcl_GetString(objPtr); } offset = 0; @@ -4502,10 +4738,11 @@ if (nextPtr == NULL) { statePtr->inQueueTail = NULL; } } } + if (copiedNow < 0) { if (statePtr->flags & CHANNEL_EOF) { break; } if (statePtr->flags & CHANNEL_BLOCKED) { @@ -4525,45 +4762,45 @@ } else { copied += copiedNow; toRead -= copiedNow; } } + statePtr->flags &= ~CHANNEL_BLOCKED; if (encoding == NULL) { Tcl_SetByteArrayLength(objPtr, offset); } else { Tcl_SetObjLength(objPtr, offset); } - done: /* - * Update the notifier state so we don't block while there is still - * data in the buffers. + * Update the notifier state so we don't block while there is still data + * in the buffers. */ + done: UpdateInterest(chanPtr); return copied; } /* *--------------------------------------------------------------------------- * * ReadBytes -- * - * Reads from the channel until the requested number of bytes have - * been seen, EOF is seen, or the channel would block. Bytes from - * the channel are stored in objPtr as a ByteArray object. EOL - * and EOF translation are done. - * - * 'bytesToRead' can safely be a very large number because - * space is only allocated to hold data read from the channel - * as needed. + * Reads from the channel until the requested number of bytes have been + * seen, EOF is seen, or the channel would block. Bytes from the channel + * are stored in objPtr as a ByteArray object. EOL and EOF translation + * are done. + * + * 'bytesToRead' can safely be a very large number because space is only + * allocated to hold data read from the channel as needed. * * Results: - * The return value is the number of bytes appended to the object - * and *offsetPtr is filled with the total number of bytes in the - * object (greater than the return value if there were already bytes - * in the object). + * The return value is the number of bytes appended to the object and + * *offsetPtr is filled with the total number of bytes in the object + * (greater than the return value if there were already bytes in the + * object). * * Side effects: * None. * *--------------------------------------------------------------------------- @@ -4571,34 +4808,33 @@ static int ReadBytes(statePtr, objPtr, bytesToRead, offsetPtr) ChannelState *statePtr; /* State of the channel to read. */ Tcl_Obj *objPtr; /* Input data is appended to this ByteArray - * object. Its length is how much space - * has been allocated to hold data, not how - * many bytes of data have been stored in the + * object. Its length is how much space has + * been allocated to hold data, not how many + * bytes of data have been stored in the * object. */ - int bytesToRead; /* Maximum number of bytes to store, - * or < 0 to get all available bytes. - * Bytes are obtained from the first - * buffer in the queue -- even if this number - * is larger than the number of bytes - * available in the first buffer, only the - * bytes from the first buffer are + int bytesToRead; /* Maximum number of bytes to store, or < 0 to + * get all available bytes. Bytes are obtained + * from the first buffer in the queue - even + * if this number is larger than the number of + * bytes available in the first buffer, only + * the bytes from the first buffer are * returned. */ - int *offsetPtr; /* On input, contains how many bytes of - * objPtr have been used to hold data. On - * output, filled with how many bytes are now - * being used. */ + int *offsetPtr; /* On input, contains how many bytes of objPtr + * have been used to hold data. On output, + * filled with how many bytes are now being + * used. */ { int toRead, srcLen, offset, length, srcRead, dstWrote; ChannelBuffer *bufPtr; char *src, *dst; offset = *offsetPtr; - bufPtr = statePtr->inQueueHead; + bufPtr = statePtr->inQueueHead; src = bufPtr->buf + bufPtr->nextRemoved; srcLen = bufPtr->nextAdded - bufPtr->nextRemoved; toRead = bytesToRead; if ((unsigned) toRead > (unsigned) srcLen) { @@ -4606,13 +4842,13 @@ } dst = (char *) Tcl_GetByteArrayFromObj(objPtr, &length); if (toRead > length - offset - 1) { /* - * Double the existing size of the object or make enough room to - * hold all the characters we may get from the source buffer, - * whichever is larger. + * Double the existing size of the object or make enough room to hold + * all the characters we may get from the source buffer, whichever is + * larger. */ length = offset * 2; if (offset < toRead) { length = offset + toRead + 1; @@ -4649,25 +4885,23 @@ /* *--------------------------------------------------------------------------- * * ReadChars -- * - * Reads from the channel until the requested number of UTF-8 - * characters have been seen, EOF is seen, or the channel would - * block. Raw bytes from the channel are converted to UTF-8 - * and stored in objPtr. EOL and EOF translation is done. - * - * 'charsToRead' can safely be a very large number because - * space is only allocated to hold data read from the channel - * as needed. + * Reads from the channel until the requested number of UTF-8 characters + * have been seen, EOF is seen, or the channel would block. Raw bytes + * from the channel are converted to UTF-8 and stored in objPtr. EOL and + * EOF translation is done. + * + * 'charsToRead' can safely be a very large number because space is only + * allocated to hold data read from the channel as needed. * * Results: - * The return value is the number of characters appended to - * the object, *offsetPtr is filled with the number of bytes that - * were appended, and *factorPtr is filled with the expansion - * factor used to guess how many bytes of UTF-8 to allocate to - * hold N source bytes. + * The return value is the number of characters appended to the object, + * *offsetPtr is filled with the number of bytes that were appended, and + * *factorPtr is filled with the expansion factor used to guess how many + * bytes of UTF-8 to allocate to hold N source bytes. * * Side effects: * None. * *--------------------------------------------------------------------------- @@ -4678,22 +4912,22 @@ ChannelState *statePtr; /* State of channel to read. */ Tcl_Obj *objPtr; /* Input data is appended to this object. * objPtr->length is how much space has been * allocated to hold data, not how many bytes * of data have been stored in the object. */ - int charsToRead; /* Maximum number of characters to store, - * or -1 to get all available characters. + int charsToRead; /* Maximum number of characters to store, or + * -1 to get all available characters. * Characters are obtained from the first * buffer in the queue -- even if this number * is larger than the number of characters * available in the first buffer, only the * characters from the first buffer are * returned. */ - int *offsetPtr; /* On input, contains how many bytes of - * objPtr have been used to hold data. On - * output, filled with how many bytes are now - * being used. */ + int *offsetPtr; /* On input, contains how many bytes of objPtr + * have been used to hold data. On output, + * filled with how many bytes are now being + * used. */ int *factorPtr; /* On input, contains a guess of how many * bytes need to be allocated to hold the * result of converting N source bytes to * UTF-8. On output, contains another guess * based on the data seen so far. */ @@ -4705,34 +4939,33 @@ Tcl_EncodingState oldState; factor = *factorPtr; offset = *offsetPtr; - bufPtr = statePtr->inQueueHead; + bufPtr = statePtr->inQueueHead; src = bufPtr->buf + bufPtr->nextRemoved; srcLen = bufPtr->nextAdded - bufPtr->nextRemoved; toRead = charsToRead; if ((unsigned)toRead > (unsigned)srcLen) { toRead = srcLen; } /* - * 'factor' is how much we guess that the bytes in the source buffer - * will expand when converted to UTF-8 chars. This guess comes from - * analyzing how many characters were produced by the previous - * pass. + * 'factor' is how much we guess that the bytes in the source buffer will + * expand when converted to UTF-8 chars. This guess comes from analyzing + * how many characters were produced by the previous pass. */ dstNeeded = toRead * factor / UTF_EXPANSION_FACTOR; spaceLeft = objPtr->length - offset - TCL_UTF_MAX - 1; if (dstNeeded > spaceLeft) { /* - * Double the existing size of the object or make enough room to - * hold all the characters we want from the source buffer, - * whichever is larger. + * Double the existing size of the object or make enough room to hold + * all the characters we want from the source buffer, whichever is + * larger. */ length = offset * 2; if (offset < dstNeeded) { length = offset + dstNeeded; @@ -4741,13 +4974,13 @@ length += TCL_UTF_MAX + 1; Tcl_SetObjLength(objPtr, length); } if (toRead == srcLen) { /* - * Want to convert the whole buffer in one pass. If we have - * enough space, convert it using all available space in object - * rather than using the factor. + * Want to convert the whole buffer in one pass. If we have enough + * space, convert it using all available space in object rather than + * using the factor. */ dstNeeded = spaceLeft; } dst = objPtr->bytes + offset; @@ -4783,13 +5016,13 @@ Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen, statePtr->inputEncodingFlags, &statePtr->inputEncodingState, dst, dstNeeded + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars); if (srcRead == 0) { /* - * Not enough bytes in src buffer to make a complete char. Copy - * the bytes to the next buffer to make a new contiguous string, - * then tell the caller to fill the buffer with more bytes. + * Not enough bytes in src buffer to make a complete char. Copy the + * bytes to the next buffer to make a new contiguous string, then tell + * the caller to fill the buffer with more bytes. */ ChannelBuffer *nextPtr; nextPtr = bufPtr->nextPtr; @@ -4800,15 +5033,14 @@ * character, so we need to wait for more data before the next * file event can be delivered. * * SF #478856. * - * The exception to this is if the input buffer was - * completely empty before we tried to convert its - * contents. Nothing in, nothing out, and no incomplete - * character data. The conversion before the current one - * was complete. + * The exception to this is if the input buffer was completely + * empty before we tried to convert its contents. Nothing in, + * nothing out, and no incomplete character data. The + * conversion before the current one was complete. */ statePtr->flags |= CHANNEL_NEED_MORE_DATA; } return -1; @@ -4822,14 +5054,14 @@ } dstRead = dstWrote; if (TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead) != 0) { /* - * Hit EOF char. How many bytes of src correspond to where the - * EOF was located in dst? Run the conversion again with an - * output buffer just big enough to hold the data so we can - * get the correct value for srcRead. + * Hit EOF char. How many bytes of src correspond to where the EOF was + * located in dst? Run the conversion again with an output buffer just + * big enough to hold the data so we can get the correct value for + * srcRead. */ if (dstWrote == 0) { return -1; } @@ -4836,16 +5068,16 @@ statePtr->inputEncodingState = oldState; Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen, statePtr->inputEncodingFlags, &statePtr->inputEncodingState, dst, dstRead + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars); TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead); - } + } /* - * The number of characters that we got may be less than the number - * that we started with because "\r\n" sequences may have been - * turned into just '\n' in dst. + * The number of characters that we got may be less than the number that + * we started with because "\r\n" sequences may have been turned into just + * '\n' in dst. */ numChars -= (dstRead - dstWrote); if ((unsigned) numChars > (unsigned) toRead) { @@ -4877,38 +5109,38 @@ /* *--------------------------------------------------------------------------- * * TranslateInputEOL -- * - * Perform input EOL and EOF translation on the source buffer, - * leaving the translated result in the destination buffer. + * Perform input EOL and EOF translation on the source buffer, leaving + * the translated result in the destination buffer. * * Results: * The return value is 1 if the EOF character was found when copying - * bytes to the destination buffer, 0 otherwise. + * bytes to the destination buffer, 0 otherwise. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static int TranslateInputEOL(statePtr, dstStart, srcStart, dstLenPtr, srcLenPtr) - ChannelState *statePtr; /* Channel being read, for EOL translation - * and EOF character. */ - char *dstStart; /* Output buffer filled with chars by - * applying appropriate EOL translation to - * source characters. */ + ChannelState *statePtr; /* Channel being read, for EOL translation and + * EOF character. */ + char *dstStart; /* Output buffer filled with chars by applying + * appropriate EOL translation to source + * characters. */ CONST char *srcStart; /* Source characters. */ int *dstLenPtr; /* On entry, the maximum length of output - * buffer in bytes; must be <= *srcLenPtr. On + * buffer in bytes; must be <= *srcLenPtr. On * exit, the number of bytes actually used in * output buffer. */ - int *srcLenPtr; /* On entry, the length of source buffer. - * On exit, the number of bytes read from - * the source buffer. */ + int *srcLenPtr; /* On entry, the length of source buffer. On + * exit, the number of bytes read from the + * source buffer. */ { int dstLen, srcLen, inEofChar; CONST char *eof; dstLen = *dstLenPtr; @@ -4915,14 +5147,14 @@ eof = NULL; inEofChar = statePtr->inEofChar; if (inEofChar != '\0') { /* - * Find EOF in translated buffer then compress out the EOL. The - * source buffer may be much longer than the destination buffer -- - * we only want to return EOF if the EOF has been copied to the - * destination buffer. + * Find EOF in translated buffer then compress out the EOL. The source + * buffer may be much longer than the destination buffer - we only + * want to return EOF if the EOF has been copied to the destination + * buffer. */ CONST char *src, *srcMax; srcMax = srcStart + *srcLenPtr; @@ -4937,105 +5169,103 @@ break; } } } switch (statePtr->inputTranslation) { - case TCL_TRANSLATE_LF: { - if (dstStart != srcStart) { - memcpy((VOID *) dstStart, (VOID *) srcStart, (size_t) dstLen); - } - srcLen = dstLen; - break; - } - case TCL_TRANSLATE_CR: { - char *dst, *dstEnd; - - if (dstStart != srcStart) { - memcpy((VOID *) dstStart, (VOID *) srcStart, (size_t) dstLen); - } - dstEnd = dstStart + dstLen; - for (dst = dstStart; dst < dstEnd; dst++) { - if (*dst == '\r') { - *dst = '\n'; - } - } - srcLen = dstLen; - break; - } - case TCL_TRANSLATE_CRLF: { - char *dst; - CONST char *src, *srcEnd, *srcMax; - - dst = dstStart; - src = srcStart; - srcEnd = srcStart + dstLen; - srcMax = srcStart + *srcLenPtr; - - for ( ; src < srcEnd; ) { - if (*src == '\r') { - src++; - if (src >= srcMax) { - statePtr->flags |= INPUT_NEED_NL; - } else if (*src == '\n') { - *dst++ = *src++; - } else { - *dst++ = '\r'; - } - } else { - *dst++ = *src++; - } - } - srcLen = src - srcStart; - dstLen = dst - dstStart; - break; - } - case TCL_TRANSLATE_AUTO: { - char *dst; - CONST char *src, *srcEnd, *srcMax; - - dst = dstStart; - src = srcStart; - srcEnd = srcStart + dstLen; - srcMax = srcStart + *srcLenPtr; - - if ((statePtr->flags & INPUT_SAW_CR) && (src < srcMax)) { - if (*src == '\n') { - src++; - } - statePtr->flags &= ~INPUT_SAW_CR; - } - for ( ; src < srcEnd; ) { - if (*src == '\r') { - src++; - if (src >= srcMax) { - statePtr->flags |= INPUT_SAW_CR; - } else if (*src == '\n') { - if (srcEnd < srcMax) { - srcEnd++; - } - src++; - } - *dst++ = '\n'; - } else { - *dst++ = *src++; - } - } - srcLen = src - srcStart; - dstLen = dst - dstStart; - break; - } - default: { /* lint. */ - return 0; - } + case TCL_TRANSLATE_LF: + if (dstStart != srcStart) { + memcpy((VOID *) dstStart, (VOID *) srcStart, (size_t) dstLen); + } + srcLen = dstLen; + break; + case TCL_TRANSLATE_CR: { + char *dst, *dstEnd; + + if (dstStart != srcStart) { + memcpy((VOID *) dstStart, (VOID *) srcStart, (size_t) dstLen); + } + dstEnd = dstStart + dstLen; + for (dst = dstStart; dst < dstEnd; dst++) { + if (*dst == '\r') { + *dst = '\n'; + } + } + srcLen = dstLen; + break; + } + case TCL_TRANSLATE_CRLF: { + char *dst; + CONST char *src, *srcEnd, *srcMax; + + dst = dstStart; + src = srcStart; + srcEnd = srcStart + dstLen; + srcMax = srcStart + *srcLenPtr; + + for ( ; src < srcEnd; ) { + if (*src == '\r') { + src++; + if (src >= srcMax) { + statePtr->flags |= INPUT_NEED_NL; + } else if (*src == '\n') { + *dst++ = *src++; + } else { + *dst++ = '\r'; + } + } else { + *dst++ = *src++; + } + } + srcLen = src - srcStart; + dstLen = dst - dstStart; + break; + } + case TCL_TRANSLATE_AUTO: { + char *dst; + CONST char *src, *srcEnd, *srcMax; + + dst = dstStart; + src = srcStart; + srcEnd = srcStart + dstLen; + srcMax = srcStart + *srcLenPtr; + + if ((statePtr->flags & INPUT_SAW_CR) && (src < srcMax)) { + if (*src == '\n') { + src++; + } + statePtr->flags &= ~INPUT_SAW_CR; + } + for ( ; src < srcEnd; ) { + if (*src == '\r') { + src++; + if (src >= srcMax) { + statePtr->flags |= INPUT_SAW_CR; + } else if (*src == '\n') { + if (srcEnd < srcMax) { + srcEnd++; + } + src++; + } + *dst++ = '\n'; + } else { + *dst++ = *src++; + } + } + srcLen = src - srcStart; + dstLen = dst - dstStart; + break; + } + default: + return 0; } *dstLenPtr = dstLen; if ((eof != NULL) && (srcStart + srcLen >= eof)) { /* - * EOF character was seen in EOL translated range. Leave current - * file position pointing at the EOF character, but don't store the - * EOF character in the output string. + * EOF character was seen in EOL translated range. Leave current file + * position pointing at the EOF character, but don't store the EOF + * character in the output string. */ statePtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); statePtr->inputEncodingFlags |= TCL_ENCODING_END; statePtr->flags &= ~(INPUT_SAW_CR | INPUT_NEED_NL); @@ -5049,12 +5279,12 @@ /* *---------------------------------------------------------------------- * * Tcl_Ungets -- * - * Causes the supplied string to be added to the input queue of - * the channel, at either the head or tail of the queue. + * Causes the supplied string to be added to the input queue of the + * channel, at either the head or tail of the queue. * * Results: * The number of bytes stored in the channel, or -1 on error. * * Side effects: @@ -5067,11 +5297,11 @@ Tcl_Ungets(chan, str, len, atEnd) Tcl_Channel chan; /* The channel for which to add the input. */ CONST char *str; /* The input itself. */ int len; /* The length of the input. */ int atEnd; /* If non-zero, add at end of queue; otherwise - * add at head of queue. */ + * add at head of queue. */ { Channel *chanPtr; /* The real IO channel. */ ChannelState *statePtr; /* State of actual channel. */ ChannelBuffer *bufPtr; /* Buffer to contain the data. */ int i, flags; @@ -5095,15 +5325,14 @@ goto done; } statePtr->flags = flags; /* - * If we have encountered a sticky EOF, just punt without storing. - * (sticky EOF is set if we have seen the input eofChar, to prevent - * reading beyond the eofChar). Otherwise, clear the EOF flags, and - * clear the BLOCKED bit. We want to discover these conditions anew - * in each operation. + * If we have encountered a sticky EOF, just punt without storing (sticky + * EOF is set if we have seen the input eofChar, to prevent reading beyond + * the eofChar). Otherwise, clear the EOF flags, and clear the BLOCKED + * bit. We want to discover these conditions anew in each operation. */ if (statePtr->flags & CHANNEL_STICKY_EOF) { goto done; } @@ -5125,16 +5354,16 @@ } else { bufPtr->nextPtr = statePtr->inQueueHead; statePtr->inQueueHead = bufPtr; } - done: /* - * Update the notifier state so we don't block while there is still - * data in the buffers. + * Update the notifier state so we don't block while there is still data + * in the buffers. */ + done: UpdateInterest(chanPtr); return len; } /* @@ -5192,12 +5421,12 @@ /* *---------------------------------------------------------------------- * * DiscardInputQueued -- * - * Discards any input read from the channel but not yet consumed - * by Tcl reading commands. + * Discards any input read from the channel but not yet consumed by Tcl + * reading commands. * * Results: * None. * * Side effects: @@ -5207,12 +5436,12 @@ *---------------------------------------------------------------------- */ static void DiscardInputQueued(statePtr, discardSavedBuffers) - ChannelState *statePtr; /* Channel on which to discard - * the queued input. */ + ChannelState *statePtr; /* Channel on which to discard the queued + * input. */ int discardSavedBuffers; /* If non-zero, discard all buffers including * last one. */ { ChannelBuffer *bufPtr, *nxtPtr; /* Loop variables. */ @@ -5240,15 +5469,15 @@ /* *--------------------------------------------------------------------------- * * GetInput -- * - * Reads input data from a device into a channel buffer. + * Reads input data from a device into a channel buffer. * * Results: * The return value is the Posix error code if an error occurred while - * reading from the file, or 0 otherwise. + * reading from the file, or 0 otherwise. * * Side effects: * Reads from the underlying device. * *--------------------------------------------------------------------------- @@ -5274,17 +5503,17 @@ if (CheckForDeadChannel(NULL, statePtr)) { return EINVAL; } /* - * First check for more buffers in the pushback area of the - * topmost channel in the stack and use them. They can be the - * result of a transformation which went away without reading all - * the information placed in the area when it was stacked. + * First check for more buffers in the pushback area of the topmost + * channel in the stack and use them. They can be the result of a + * transformation which went away without reading all the information + * placed in the area when it was stacked. * - * Two possibilities for the state: No buffers in it, or a single - * empty buffer. In the latter case we can recycle it now. + * Two possibilities for the state: No buffers in it, or a single empty + * buffer. In the latter case we can recycle it now. */ if (chanPtr->inQueueHead != (ChannelBuffer *) NULL) { if (statePtr->inQueueHead != (ChannelBuffer *) NULL) { RecycleBuffer(statePtr, statePtr->inQueueHead, 0); @@ -5297,18 +5526,18 @@ chanPtr->inQueueTail = (ChannelBuffer *) NULL; return 0; } /* - * Nothing in the pushback area, fall back to the usual handling - * (driver, etc.) + * Nothing in the pushback area, fall back to the usual handling (driver, + * etc.) */ /* - * See if we can fill an existing buffer. If we can, read only - * as much as will fit in it. Otherwise allocate a new buffer, - * add it to the input queue and attempt to fill it to the max. + * See if we can fill an existing buffer. If we can, read only as much as + * will fit in it. Otherwise allocate a new buffer, add it to the input + * queue and attempt to fill it to the max. */ bufPtr = statePtr->inQueueTail; if ((bufPtr != NULL) && (bufPtr->nextAdded < bufPtr->bufLength)) { toRead = bufPtr->bufLength - bufPtr->nextAdded; @@ -5317,12 +5546,12 @@ statePtr->saveInBufPtr = NULL; /* * Check the actual buffersize against the requested * buffersize. Buffers which are smaller than requested are - * squashed. This is done to honor dynamic changes of the - * buffersize made by the user. + * squashed. This is done to honor dynamic changes of the buffersize + * made by the user. */ if ((bufPtr != NULL) && (bufPtr->bufLength - BUFFER_PADDING < statePtr->bufSize)) { ckfree((char *) bufPtr); @@ -5332,21 +5561,22 @@ if (bufPtr == NULL) { bufPtr = AllocChannelBuffer(statePtr->bufSize); } bufPtr->nextPtr = (ChannelBuffer *) NULL; - /* SF #427196: Use the actual size of the buffer to determine - * the number of bytes to read from the channel and not the - * size for new buffers. They can be different if the - * buffersize was changed between reads. - * - * Note: This affects performance negatively if the buffersize - * was extended but this small buffer is reused for all - * subsequent reads. The system never uses buffers with the - * requested bigger size in that case. An adjunct patch could - * try and delete all unused buffers it encounters and which - * are smaller than the formally requested buffersize. + /* + * SF #427196: Use the actual size of the buffer to determine the + * number of bytes to read from the channel and not the size for new + * buffers. They can be different if the buffersize was changed + * between reads. + * + * Note: This affects performance negatively if the buffersize was + * extended but this small buffer is reused for all subsequent reads. + * The system never uses buffers with the requested bigger size in + * that case. An adjunct patch could try and delete all unused buffers + * it encounters and which are smaller than the formally requested + * buffersize. */ toRead = bufPtr->bufLength - bufPtr->nextAdded; if (statePtr->inQueueTail == NULL) { @@ -5366,14 +5596,14 @@ return 0; } #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING /* - * [SF Tcl Bug 943274]. Better emulation of non-blocking channels - * for channels without BlockModeProc, by keeping track of true - * fileevents generated by the OS == Data waiting and reading if - * and only if we are sure to have data. + * [SF Tcl Bug 943274]. Better emulation of non-blocking channels for + * channels without BlockModeProc, by keeping track of true fileevents + * generated by the OS == Data waiting and reading if and only if we are + * sure to have data. */ if ((statePtr->flags & CHANNEL_NONBLOCKING) && (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) && !(statePtr->flags & CHANNEL_HAS_MORE_DATA)) { @@ -5383,35 +5613,37 @@ nread = -1; result = EWOULDBLOCK; } else { #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ + nread = (chanPtr->typePtr->inputProc)(chanPtr->instanceData, bufPtr->buf + bufPtr->nextAdded, toRead, &result); + #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING } #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ if (nread > 0) { bufPtr->nextAdded += nread; /* - * If we get a short read, signal up that we may be BLOCKED. We - * should avoid calling the driver because on some platforms we - * will block in the low level reading code even though the - * channel is set into nonblocking mode. + * If we get a short read, signal up that we may be BLOCKED. We should + * avoid calling the driver because on some platforms we will block in + * the low level reading code even though the channel is set into + * nonblocking mode. */ if (nread < toRead) { statePtr->flags |= CHANNEL_BLOCKED; } #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING if (nread <= toRead) { /* - * [SF Tcl Bug 943274] We have read the available data, - * clear flag. + * [SF Tcl Bug 943274] We have read the available data, clear + * flag. */ statePtr->flags &= ~CHANNEL_HAS_MORE_DATA; } #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ @@ -5433,16 +5665,16 @@ /* *---------------------------------------------------------------------- * * Tcl_Seek -- * - * Implements seeking on Tcl Channels. This is a public function - * so that other C facilities may be implemented on top of it. + * Implements seeking on Tcl Channels. This is a public function so that + * other C facilities may be implemented on top of it. * * Results: - * The new access point or -1 on error. If error, use Tcl_GetErrno() - * to retrieve the POSIX error code for the error that occurred. + * The new access point or -1 on error. If error, use Tcl_GetErrno() to + * retrieve the POSIX error code for the error that occurred. * * Side effects: * May flush output on the channel. May discard queued input. * *---------------------------------------------------------------------- @@ -5458,23 +5690,23 @@ ChannelState *statePtr = chanPtr->state; /* state info for channel */ int inputBuffered, outputBuffered; /* # bytes held in buffers. */ int result; /* Of device driver operations. */ Tcl_WideInt curPos; /* Position on the device. */ - int wasAsync; /* Was the channel nonblocking before the - * seek operation? If so, must restore to - * nonblocking mode after the seek. */ + int wasAsync; /* Was the channel nonblocking before the seek + * operation? If so, must restore to + * non-blocking mode after the seek. */ if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) { return Tcl_LongAsWide(-1); } /* - * Disallow seek on dead channels -- channels that have been closed but - * not yet been deallocated. Such channels can be found if the exit - * handler for channel cleanup has run but the channel is still - * registered in an interpreter. + * Disallow seek on dead channels - channels that have been closed but not + * yet been deallocated. Such channels can be found if the exit handler + * for channel cleanup has run but the channel is still registered in an + * interpreter. */ if (CheckForDeadChannel(NULL, statePtr)) { return Tcl_LongAsWide(-1); } @@ -5494,12 +5726,12 @@ Tcl_SetErrno(EINVAL); return Tcl_LongAsWide(-1); } /* - * Compute how much input and output is buffered. If both input and - * output is buffered, cannot compute the current position. + * Compute how much input and output is buffered. If both input and output + * is buffered, cannot compute the current position. */ inputBuffered = Tcl_InputBuffered(chan); outputBuffered = Tcl_OutputBuffered(chan); @@ -5516,29 +5748,29 @@ if (mode == SEEK_CUR) { offset -= inputBuffered; } /* - * Discard any queued input - this input should not be read after - * the seek. + * Discard any queued input - this input should not be read after the + * seek. */ DiscardInputQueued(statePtr, 0); /* - * Reset EOF and BLOCKED flags. We invalidate them by moving the - * access point. Also clear CR related flags. + * Reset EOF and BLOCKED flags. We invalidate them by moving the access + * point. Also clear CR related flags. */ statePtr->flags &= ~(CHANNEL_EOF | CHANNEL_STICKY_EOF | CHANNEL_BLOCKED | INPUT_SAW_CR); /* - * If the channel is in asynchronous output mode, switch it back - * to synchronous mode and cancel any async flush that may be - * scheduled. After the flush, the channel will be put back into - * asynchronous output mode. + * If the channel is in asynchronous output mode, switch it back to + * synchronous mode and cancel any async flush that may be scheduled. + * After the flush, the channel will be put back into asynchronous output + * mode. */ wasAsync = 0; if (statePtr->flags & CHANNEL_NONBLOCKING) { wasAsync = 1; @@ -5551,36 +5783,36 @@ statePtr->flags &= (~(BG_FLUSH_SCHEDULED)); } } /* - * If there is data buffered in statePtr->curOutPtr then mark - * the channel as ready to flush before invoking FlushChannel. + * If there is data buffered in statePtr->curOutPtr then mark the channel + * as ready to flush before invoking FlushChannel. */ if ((statePtr->curOutPtr != (ChannelBuffer *) NULL) && (statePtr->curOutPtr->nextAdded > statePtr->curOutPtr->nextRemoved)) { statePtr->flags |= BUFFER_READY; } /* - * If the flush fails we cannot recover the original position. In - * that case the seek is not attempted because we do not know where - * the access position is - instead we return the error. FlushChannel - * has already called Tcl_SetErrno() to report the error upwards. - * If the flush succeeds we do the seek also. + * If the flush fails we cannot recover the original position. In that + * case the seek is not attempted because we do not know where the access + * position is - instead we return the error. FlushChannel has already + * called Tcl_SetErrno() to report the error upwards. If the flush + * succeeds we do the seek also. */ if (FlushChannel(NULL, chanPtr, 0) != 0) { curPos = -1; } else { /* * Now seek to the new position in the channel as requested by the - * caller. Note that we prefer the wideSeekProc if that is - * available and non-NULL... + * caller. Note that we prefer the wideSeekProc if that is available + * and non-NULL... */ if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) && chanPtr->typePtr->wideSeekProc != NULL) { curPos = (chanPtr->typePtr->wideSeekProc) (chanPtr->instanceData, @@ -5600,12 +5832,12 @@ } /* * Restore to nonblocking mode if that was the previous behavior. * - * NOTE: Even if there was an async flush active we do not restore - * it now because we already flushed all the queued output, above. + * NOTE: Even if there was an async flush active we do not restore it now + * because we already flushed all the queued output, above. */ if (wasAsync) { statePtr->flags |= CHANNEL_NONBLOCKING; result = StackSetBlockMode(chanPtr, TCL_MODE_NONBLOCKING); @@ -5620,17 +5852,17 @@ /* *---------------------------------------------------------------------- * * Tcl_Tell -- * - * Returns the position of the next character to be read/written on - * this channel. + * Returns the position of the next character to be read/written on this + * channel. * * Results: - * A nonnegative integer on success, -1 on failure. If failed, - * use Tcl_GetErrno() to retrieve the POSIX error code for the - * error that occurred. + * A nonnegative integer on success, -1 on failure. If failed, use + * Tcl_GetErrno() to retrieve the POSIX error code for the error that + * occurred. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -5651,12 +5883,12 @@ } /* * Disallow tell on dead channels -- channels that have been closed but * not yet been deallocated. Such channels can be found if the exit - * handler for channel cleanup has run but the channel is still - * registered in an interpreter. + * handler for channel cleanup has run but the channel is still registered + * in an interpreter. */ if (CheckForDeadChannel(NULL, statePtr)) { return Tcl_LongAsWide(-1); } @@ -5676,12 +5908,12 @@ Tcl_SetErrno(EINVAL); return Tcl_LongAsWide(-1); } /* - * Compute how much input and output is buffered. If both input and - * output is buffered, cannot compute the current position. + * Compute how much input and output is buffered. If both input and output + * is buffered, cannot compute the current position. */ inputBuffered = Tcl_InputBuffered(chan); outputBuffered = Tcl_OutputBuffered(chan); @@ -5689,13 +5921,13 @@ Tcl_SetErrno(EFAULT); return Tcl_LongAsWide(-1); } /* - * Get the current position in the device and compute the position - * where the next character will be read or written. Note that we - * prefer the wideSeekProc if that is available and non-NULL... + * Get the current position in the device and compute the position where + * the next character will be read or written. Note that we prefer the + * wideSeekProc if that is available and non-NULL... */ if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) && chanPtr->typePtr->wideSeekProc != NULL) { curPos = (chanPtr->typePtr->wideSeekProc) (chanPtr->instanceData, @@ -5717,13 +5949,13 @@ /* *--------------------------------------------------------------------------- * * Tcl_SeekOld, Tcl_TellOld -- * - * Backward-compatability versions of the seek/tell interface that - * do not support 64-bit offsets. This interface is not documented - * or expected to be supported indefinitely. + * Backward-compatability versions of the seek/tell interface that do not + * support 64-bit offsets. This interface is not documented or expected + * to be supported indefinitely. * * Results: * As for Tcl_Seek and Tcl_Tell respectively, except truncated to * whatever value will fit in an 'int'. * @@ -5757,18 +5989,86 @@ } /* *--------------------------------------------------------------------------- * + * Tcl_TruncateChannel -- + * + * Truncate a channel to the given length. + * + * Results: + * TCL_OK on success, TCL_ERROR if the operation failed (e.g. is not + * supported by the type of channel, or the underlying OS operation + * failed in some way). + * + * Side effects: + * Seeks the channel to the current location. Sets errno on OS error. + * + *--------------------------------------------------------------------------- + */ + +int +Tcl_TruncateChannel(chan, length) + Tcl_Channel chan; + Tcl_WideInt length; +{ + Channel *chanPtr = (Channel *) chan; + Tcl_DriverTruncateProc *truncateProc = + Tcl_ChannelTruncateProc(chanPtr->typePtr); + int result; + + if (truncateProc == NULL) { + /* + * Feature not supported and it's not emulatable. Pretend it's + * returned an EINVAL, a very generic error! + */ + Tcl_SetErrno(EINVAL); + return TCL_ERROR; + } + + if (!(chanPtr->state->flags & TCL_WRITABLE)) { + /* + * We require that the file was opened of writing. Do that check now + * so that we only flush if we think we're going to succeed. + */ + Tcl_SetErrno(EINVAL); + return TCL_ERROR; + } + + /* + * Seek first to force a total flush of all pending buffers and ditch any + * pre-read input data. + */ + + if (Tcl_Seek(chan, 0, SEEK_CUR) == Tcl_LongAsWide(-1)) { + return TCL_ERROR; + } + + /* + * We're all flushed to disk now and we also don't have any unfortunate + * input baggage around either; can truncate with impunity. + */ + + result = truncateProc(chanPtr->instanceData, length); + if (result != 0) { + Tcl_SetErrno(result); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * * CheckChannelErrors -- * - * See if the channel is in an ready state and can perform the - * desired operation. + * See if the channel is in an ready state and can perform the desired + * operation. * * Results: - * The return value is 0 if the channel is OK, otherwise the - * return value is -1 and errno is set to indicate the error. + * The return value is 0 if the channel is OK, otherwise the return value + * is -1 and errno is set to indicate the error. * * Side effects: * May clear the EOF and/or BLOCKED bits if reading from channel. * *--------------------------------------------------------------------------- @@ -5789,16 +6089,26 @@ */ if (statePtr->unreportedError != 0) { Tcl_SetErrno(statePtr->unreportedError); statePtr->unreportedError = 0; + + /* TIP #219, Tcl Channel Reflection API. + * Move a defered error message back into the channel bypass. + */ + + if (statePtr->chanMsg != NULL) { + Tcl_DecrRefCount (statePtr->chanMsg); + } + statePtr->chanMsg = statePtr->unreportedMsg; + statePtr->unreportedMsg = NULL; return -1; } /* - * Only the raw read and write operations are allowed during close - * in order to drain data from stacked channels. + * Only the raw read and write operations are allowed during close in + * order to drain data from stacked channels. */ if ((statePtr->flags & CHANNEL_CLOSED) && ((flags & CHANNEL_RAW_MODE) == 0)) { Tcl_SetErrno(EACCES); @@ -5827,14 +6137,14 @@ return -1; } if (direction == TCL_READABLE) { /* - * If we have not encountered a sticky EOF, clear the EOF bit - * (sticky EOF is set if we have seen the input eofChar, to prevent - * reading beyond the eofChar). Also, always clear the BLOCKED bit. - * We want to discover these conditions anew in each operation. + * If we have not encountered a sticky EOF, clear the EOF bit (sticky + * EOF is set if we have seen the input eofChar, to prevent reading + * beyond the eofChar). Also, always clear the BLOCKED bit. We want to + * discover these conditions anew in each operation. */ if ((statePtr->flags & CHANNEL_STICKY_EOF) == 0) { statePtr->flags &= ~CHANNEL_EOF; } @@ -5901,16 +6211,16 @@ /* *---------------------------------------------------------------------- * * Tcl_InputBuffered -- * - * Returns the number of bytes of input currently buffered in the - * common internal buffer of a channel. + * Returns the number of bytes of input currently buffered in the common + * internal buffer of a channel. * * Results: - * The number of input bytes buffered, or zero if the channel is not - * open for reading. + * The number of input bytes buffered, or zero if the channel is not open + * for reading. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -5947,16 +6257,16 @@ /* *---------------------------------------------------------------------- * * Tcl_OutputBuffered -- * - * Returns the number of bytes of output currently buffered in the - * common internal buffer of a channel. + * Returns the number of bytes of output currently buffered in the common + * internal buffer of a channel. * * Results: - * The number of output bytes buffered, or zero if the channel is not - * open for writing. + * The number of output bytes buffered, or zero if the channel is not open + * for writing. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -5992,12 +6302,12 @@ * * Returns the number of bytes of input currently buffered in the * internal buffer (push back area) of a channel. * * Results: - * The number of input bytes buffered, or zero if the channel is not - * open for reading. + * The number of input bytes buffered, or zero if the channel is not open + * for reading. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -6024,12 +6334,12 @@ /* *---------------------------------------------------------------------- * * Tcl_SetChannelBufferSize -- * - * Sets the size of buffers to allocate to store input or output - * in the channel. The size must be between 10 bytes and 1 MByte. + * Sets the size of buffers to allocate to store input or output in the + * channel. The size must be between 1 byte and 1 MByte. * * Results: * None. * * Side effects: @@ -6038,22 +6348,22 @@ *---------------------------------------------------------------------- */ void Tcl_SetChannelBufferSize(chan, sz) - Tcl_Channel chan; /* The channel whose buffer size - * to set. */ + Tcl_Channel chan; /* The channel whose buffer size to + * set. */ int sz; /* The size to set. */ { ChannelState *statePtr; /* State of real channel structure. */ /* - * If the buffer size is smaller than 10 bytes or larger than one MByte, - * do not accept the requested size and leave the current buffer size. + * If the buffer size is smaller than 1 byte or larger than one MByte, do + * not accept the requested size and leave the current buffer size. */ - if (sz < 10) { + if (sz < 1) { return; } if (sz > (1024 * 1024)) { return; } @@ -6065,11 +6375,11 @@ ckfree((char *) statePtr->outputStage); statePtr->outputStage = NULL; } if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) { statePtr->outputStage = (char *) - ckalloc((unsigned) (statePtr->bufSize + 2)); + ckalloc((unsigned) (statePtr->bufSize + 2)); } } /* *---------------------------------------------------------------------- @@ -6101,61 +6411,62 @@ /* *---------------------------------------------------------------------- * * Tcl_BadChannelOption -- * - * This procedure generates a "bad option" error message in an - * (optional) interpreter. It is used by channel drivers when - * a invalid Set/Get option is requested. Its purpose is to concatenate - * the generic options list to the specific ones and factorize - * the generic options error message string. + * This procedure generates a "bad option" error message in an (optional) + * interpreter. It is used by channel drivers when a invalid Set/Get + * option is requested. Its purpose is to concatenate the generic options + * list to the specific ones and factorize the generic options error + * message string. * * Results: * TCL_ERROR. * * Side effects: - * An error message is generated in interp's result object to - * indicate that a command was invoked with the a bad option - * The message has the form - * bad option "blah": should be one of + + * An error message is generated in interp's result object to indicate + * that a command was invoked with the a bad option. The message has the + * form: + * bad option "blah": should be one of * <...generic options...>+<...specific options...> - * "blah" is the optionName argument and "" - * is a space separated list of specific option words. - * The function takes good care of inserting minus signs before - * each option, commas after, and an "or" before the last option. + * "blah" is the optionName argument and "" is a space + * separated list of specific option words. The function takes good care + * of inserting minus signs before each option, commas after, and an "or" + * before the last option. * *---------------------------------------------------------------------- */ int Tcl_BadChannelOption(interp, optionName, optionList) - Tcl_Interp *interp; /* Current interpreter. (can be NULL)*/ + Tcl_Interp *interp; /* Current interpreter (can be NULL).*/ CONST char *optionName; /* 'bad option' name */ - CONST char *optionList; /* Specific options list to append - * to the standard generic options. - * can be NULL for generic options + CONST char *optionList; /* Specific options list to append to + * the standard generic options. Can + * be NULL for generic options * only. */ { - if (interp) { - CONST char *genericopt = - "blocking buffering buffersize encoding eofchar translation"; + if (interp != NULL) { + CONST char *genericopt = + "blocking buffering buffersize encoding eofchar translation"; CONST char **argv; - int argc, i; + int argc, i; Tcl_DString ds; Tcl_DStringInit(&ds); Tcl_DStringAppend(&ds, genericopt, -1); if (optionList && (*optionList)) { Tcl_DStringAppend(&ds, " ", 1); Tcl_DStringAppend(&ds, optionList, -1); } - if (Tcl_SplitList(interp, Tcl_DStringValue(&ds), + if (Tcl_SplitList(interp, Tcl_DStringValue(&ds), &argc, &argv) != TCL_OK) { Tcl_Panic("malformed option list in channel driver"); } Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad option \"", optionName, + Tcl_AppendResult(interp, "bad option \"", optionName, "\": should be one of ", (char *) NULL); argc--; for (i = 0; i < argc; i++) { Tcl_AppendResult(interp, "-", argv[i], ", ", (char *) NULL); } @@ -6170,18 +6481,18 @@ /* *---------------------------------------------------------------------- * * Tcl_GetChannelOption -- * - * Gets a mode associated with an IO channel. If the optionName arg - * is non NULL, retrieves the value of that option. If the optionName - * arg is NULL, retrieves a list of alternating option names and - * values for the given channel. + * Gets a mode associated with an IO channel. If the optionName arg is + * non NULL, retrieves the value of that option. If the optionName arg is + * NULL, retrieves a list of alternating option names and values for the + * given channel. * * Results: - * A standard Tcl result. Also sets the supplied DString to the - * string value of the option(s) returned. + * A standard Tcl result. Also sets the supplied DString to the string + * value of the option(s) returned. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -6201,12 +6512,12 @@ int flags; /* * Disallow options on dead channels -- channels that have been closed but * not yet been deallocated. Such channels can be found if the exit - * handler for channel cleanup has run but the channel is still - * registered in an interpreter. + * handler for channel cleanup has run but the channel is still registered + * in an interpreter. */ if (CheckForDeadChannel(interp, statePtr)) { return TCL_ERROR; } @@ -6230,12 +6541,12 @@ } else { flags = statePtr->flags; } /* - * If the optionName is NULL it means that we want a list of all - * options and values. + * If the optionName is NULL it means that we want a list of all options + * and values. */ if (optionName == (char *) NULL) { len = 0; } else { @@ -6385,19 +6696,19 @@ return TCL_OK; } } if (chanPtr->typePtr->getOptionProc != (Tcl_DriverGetOptionProc *) NULL) { /* - * let the driver specific handle additional options - * and result code and message. + * Let the driver specific handle additional options and result code + * and message. */ return (chanPtr->typePtr->getOptionProc) (chanPtr->instanceData, interp, optionName, dsPtr); } else { /* - * no driver specific options case. + * No driver specific options case. */ if (len == 0) { return TCL_OK; } @@ -6411,12 +6722,12 @@ * Tcl_SetChannelOption -- * * Sets an option on a channel. * * Results: - * A standard Tcl result. On error, sets interp's result object - * if interp is not NULL. + * A standard Tcl result. On error, sets interp's result object if + * interp is not NULL. * * Side effects: * May modify an option on a device. * *--------------------------------------------------------------------------- @@ -6448,12 +6759,12 @@ } /* * Disallow options on dead channels -- channels that have been closed but * not yet been deallocated. Such channels can be found if the exit - * handler for channel cleanup has run but the channel is still - * registered in an interpreter. + * handler for channel cleanup has run but the channel is still registered + * in an interpreter. */ if (CheckForDeadChannel(NULL, statePtr)) { return TCL_ERROR; } @@ -6573,13 +6884,13 @@ if (argv != NULL) { ckfree((char *) argv); } /* - * [SF Tcl Bug 930851] Reset EOF and BLOCKED flags. Changing - * the character which signals eof can transform a current eof - * condition into a 'go ahead'. Ditto for blocked. + * [SF Tcl Bug 930851] Reset EOF and BLOCKED flags. Changing the + * character which signals eof can transform a current eof condition + * into a 'go ahead'. Ditto for blocked. */ statePtr->flags &= ~(CHANNEL_EOF | CHANNEL_STICKY_EOF | CHANNEL_BLOCKED); @@ -6615,11 +6926,11 @@ } else if (strcmp(readMode, "auto") == 0) { translation = TCL_TRANSLATE_AUTO; } else if (strcmp(readMode, "binary") == 0) { translation = TCL_TRANSLATE_LF; statePtr->inEofChar = 0; - Tcl_FreeEncoding(statePtr->encoding); + Tcl_FreeEncoding(statePtr->encoding); statePtr->encoding = NULL; } else if (strcmp(readMode, "lf") == 0) { translation = TCL_TRANSLATE_LF; } else if (strcmp(readMode, "cr") == 0) { translation = TCL_TRANSLATE_CR; @@ -6637,13 +6948,13 @@ ckfree((char *) argv); return TCL_ERROR; } /* - * Reset the EOL flags since we need to look at any buffered - * data to see if the new translation mode allows us to - * complete the line. + * Reset the EOL flags since we need to look at any buffered data + * to see if the new translation mode allows us to complete the + * line. */ if (translation != statePtr->inputTranslation) { statePtr->inputTranslation = translation; statePtr->flags &= ~(INPUT_SAW_CR); @@ -6654,14 +6965,13 @@ if (writeMode) { if (*writeMode == '\0') { /* Do nothing. */ } else if (strcmp(writeMode, "auto") == 0) { /* - * This is a hack to get TCP sockets to produce output - * in CRLF mode if they are being set into AUTO mode. - * A better solution for achieving this effect will be - * coded later. + * This is a hack to get TCP sockets to produce output in CRLF + * mode if they are being set into AUTO mode. A better + * solution for achieving this effect will be coded later. */ if (strcmp(Tcl_ChannelName(chanPtr->typePtr), "tcp") == 0) { statePtr->outputTranslation = TCL_TRANSLATE_CRLF; } else { @@ -6668,11 +6978,11 @@ statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION; } } else if (strcmp(writeMode, "binary") == 0) { statePtr->outEofChar = 0; statePtr->outputTranslation = TCL_TRANSLATE_LF; - Tcl_FreeEncoding(statePtr->encoding); + Tcl_FreeEncoding(statePtr->encoding); statePtr->encoding = NULL; } else if (strcmp(writeMode, "lf") == 0) { statePtr->outputTranslation = TCL_TRANSLATE_LF; } else if (strcmp(writeMode, "cr") == 0) { statePtr->outputTranslation = TCL_TRANSLATE_CR; @@ -6689,11 +6999,11 @@ } ckfree((char *) argv); return TCL_ERROR; } } - ckfree((char *) argv); + ckfree((char *) argv); return TCL_OK; } else if (chanPtr->typePtr->setOptionProc != NULL) { return (*chanPtr->typePtr->setOptionProc)(chanPtr->instanceData, interp, optionName, newValue); } else { @@ -6725,11 +7035,11 @@ if (statePtr->outputStage != NULL) { ckfree((char *) statePtr->outputStage); statePtr->outputStage = NULL; } if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) { - statePtr->outputStage = (char *) + statePtr->outputStage = (char *) ckalloc((unsigned) (statePtr->bufSize + 2)); } return TCL_OK; } @@ -6736,15 +7046,14 @@ /* *---------------------------------------------------------------------- * * CleanupChannelHandlers -- * - * Removes channel handlers that refer to the supplied interpreter, - * so that if the actual channel is not closed now, these handlers - * will not run on subsequent events on the channel. This would be - * erroneous, because the interpreter no longer has a reference to - * this channel. + * Removes channel handlers that refer to the supplied interpreter, so + * that if the actual channel is not closed now, these handlers will not + * run on subsequent events on the channel. This would be erroneous, + * because the interpreter no longer has a reference to this channel. * * Results: * None. * * Side effects: @@ -6760,12 +7069,12 @@ { ChannelState *statePtr = chanPtr->state; /* state info for channel */ EventScriptRecord *sPtr, *prevPtr, *nextPtr; /* - * Remove fileevent records on this channel that refer to the - * given interpreter. + * Remove fileevent records on this channel that refer to the given + * interpreter. */ for (sPtr = statePtr->scriptRecordPtr, prevPtr = (EventScriptRecord *) NULL; sPtr != (EventScriptRecord *) NULL; @@ -6792,14 +7101,13 @@ /* *---------------------------------------------------------------------- * * Tcl_NotifyChannel -- * - * This procedure is called by a channel driver when a driver - * detects an event on a channel. This procedure is responsible - * for actually handling the event by invoking any channel - * handler callbacks. + * This procedure is called by a channel driver when a driver detects an + * event on a channel. This procedure is responsible for actually + * handling the event by invoking any channel handler callbacks. * * Results: * None. * * Side effects: @@ -6822,14 +7130,14 @@ NextChannelHandler nh; Channel *upChanPtr; Tcl_ChannelType *upTypePtr; #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING - /* [SF Tcl Bug 943274] - * For a non-blocking channel without blockmodeproc we keep track - * of actual input coming from the OS so that we can do a credible - * imitation of non-blocking behaviour. + /* + * [SF Tcl Bug 943274] For a non-blocking channel without blockmodeproc we + * keep track of actual input coming from the OS so that we can do a + * credible imitation of non-blocking behaviour. */ if ((mask & TCL_READABLE) && (statePtr->flags & CHANNEL_NONBLOCKING) && (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) && @@ -6838,19 +7146,19 @@ statePtr->flags |= CHANNEL_HAS_MORE_DATA; } #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ /* - * In contrast to the other API functions this procedure walks towards - * the top of a stack and not down from it. + * In contrast to the other API functions this procedure walks towards the + * top of a stack and not down from it. * * The channel calling this procedure is the one who generated the event, - * and thus does not take part in handling it. IOW, its HandlerProc is - * not called, instead we begin with the channel above it. + * and thus does not take part in handling it. IOW, its HandlerProc is not + * called, instead we begin with the channel above it. * - * This behaviour also allows the transformation channels to - * generate their own events and pass them upward. + * This behaviour also allows the transformation channels to generate + * their own events and pass them upward. */ while (mask && (chanPtr->upChanPtr != ((Channel *) NULL))) { Tcl_DriverHandlerProc *upHandlerProc; @@ -6859,45 +7167,44 @@ upHandlerProc = Tcl_ChannelHandlerProc(upTypePtr); if (upHandlerProc != NULL) { mask = (*upHandlerProc) (upChanPtr->instanceData, mask); } - /* ELSE: - * Ignore transformations which are unable to handle the event - * coming from below. Assume that they don't change the mask and - * pass it on. + /* + * ELSE: Ignore transformations which are unable to handle the event + * coming from below. Assume that they don't change the mask and pass + * it on. */ chanPtr = upChanPtr; } channel = (Tcl_Channel) chanPtr; /* - * Here we have either reached the top of the stack or the mask is - * empty. We break out of the procedure if it is the latter. + * Here we have either reached the top of the stack or the mask is empty. + * We break out of the procedure if it is the latter. */ if (!mask) { return; } /* - * We are now above the topmost channel in a stack and have events - * left. Now call the channel handlers as usual. + * We are now above the topmost channel in a stack and have events left. + * Now call the channel handlers as usual. * * Preserve the channel struct in case the script closes it. */ Tcl_Preserve((ClientData) channel); Tcl_Preserve((ClientData) statePtr); /* - * If we are flushing in the background, be sure to call FlushChannel - * for writable events. Note that we have to discard the writable - * event so we don't call any write handlers before the flush is - * complete. + * If we are flushing in the background, be sure to call FlushChannel for + * writable events. Note that we have to discard the writable event so we + * don't call any write handlers before the flush is complete. */ if ((statePtr->flags & BG_FLUSH_SCHEDULED) && (mask & TCL_WRITABLE)) { FlushChannel(NULL, chanPtr, 1); mask &= ~TCL_WRITABLE; @@ -6926,13 +7233,13 @@ chPtr = chPtr->nextPtr; } } /* - * Update the notifier interest, since it may have changed after - * invoking event handlers. Skip that if the channel was deleted - * in the call to the channel handler. + * Update the notifier interest, since it may have changed after invoking + * event handlers. Skip that if the channel was deleted in the call to the + * channel handler. */ if (chanPtr->typePtr != NULL) { UpdateInterest(chanPtr); } @@ -6946,12 +7253,12 @@ /* *---------------------------------------------------------------------- * * UpdateInterest -- * - * Arrange for the notifier to call us back at appropriate times - * based on the current state of the channel. + * Arrange for the notifier to call us back at appropriate times based on + * the current state of the channel. * * Results: * None. * * Side effects: @@ -6966,12 +7273,12 @@ { ChannelState *statePtr = chanPtr->state; /* state info for channel */ int mask = statePtr->interestMask; /* - * If there are flushed buffers waiting to be written, then - * we need to watch for the channel to become writable. + * If there are flushed buffers waiting to be written, then we need to + * watch for the channel to become writable. */ if (statePtr->flags & BG_FLUSH_SCHEDULED) { mask |= TCL_WRITABLE; } @@ -6991,45 +7298,43 @@ mask &= ~TCL_READABLE; /* * Andreas Kupries, April 11, 2003 * - * Some operating systems (Solaris 2.6 and higher (but not - * Solaris 2.5, go figure)) generate READABLE and - * EXCEPTION events when select()'ing [*] on a plain file, - * even if EOF was not yet reached. This is a problem in - * the following situation: - * - * - An extension asks to get both READABLE and EXCEPTION - * events. - * - It reads data into a buffer smaller than the buffer - * used by Tcl itself. - * - It does not process all events in the event queue, but - * only one, at least in some situations. + * Some operating systems (Solaris 2.6 and higher (but not Solaris + * 2.5, go figure)) generate READABLE and EXCEPTION events when + * select()'ing [*] on a plain file, even if EOF was not yet + * reached. This is a problem in the following situation: + * + * - An extension asks to get both READABLE and EXCEPTION events. + * - It reads data into a buffer smaller than the buffer used by + * Tcl itself. + * - It does not process all events in the event queue, but only + * one, at least in some situations. * * In that case we can get into a situation where * * - Tcl drops READABLE here, because it has data in its own - * buffers waiting to be read by the extension. + * buffers waiting to be read by the extension. * - A READABLE event is syntesized via timer. * - The OS still reports the EXCEPTION condition on the file. - * - And the extension gets the EXCPTION event first, and - * handles this as EOF. + * - And the extension gets the EXCPTION event first, and handles + * this as EOF. * * End result ==> Premature end of reading from a file. * - * The concrete example is 'Expect', and its [expect] - * command (and at the C-level, deep in the bowels of - * Expect, 'exp_get_next_event'. See marker 'SunOS' for - * commentary in that function too). - * - * [*] As the Tcl notifier does. See also for marker - * 'SunOS' in file 'exp_event.c' of Expect. - * - * Our solution here is to drop the interest in the - * EXCEPTION events too. This compiles on all platforms, - * and also passes the testsuite on all of them. + * The concrete example is 'Expect', and its [expect] command + * (and at the C-level, deep in the bowels of Expect, + * 'exp_get_next_event'. See marker 'SunOS' for commentary in + * that function too). + * + * [*] As the Tcl notifier does. See also for marker 'SunOS' in + * file 'exp_event.c' of Expect. + * + * Our solution here is to drop the interest in the EXCEPTION + * events too. This compiles on all platforms, and also passes the + * testsuite on all of them. */ mask &= ~TCL_EXCEPTION; if (!statePtr->timer) { @@ -7044,12 +7349,12 @@ /* *---------------------------------------------------------------------- * * ChannelTimerProc -- * - * Timer handler scheduled by UpdateInterest to monitor the - * channel buffers until they are empty. + * Timer handler scheduled by UpdateInterest to monitor the channel + * buffers until they are empty. * * Results: * None. * * Side effects: @@ -7069,23 +7374,24 @@ && (statePtr->interestMask & TCL_READABLE) && (statePtr->inQueueHead != (ChannelBuffer *) NULL) && (statePtr->inQueueHead->nextRemoved < statePtr->inQueueHead->nextAdded)) { /* - * Restart the timer in case a channel handler reenters the - * event loop before UpdateInterest gets called by Tcl_NotifyChannel. + * Restart the timer in case a channel handler reenters the event loop + * before UpdateInterest gets called by Tcl_NotifyChannel. */ statePtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc, (ClientData) chanPtr); #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING - /* Set the TIMER flag to notify the higher levels that the - * driver might have no data for us. We do this only if we are - * in non-blocking mode and the driver has no BlockModeProc - * because only then we really don't know if the driver will - * block or not. A similar test is done in "PeekAhead". + /* + * Set the TIMER flag to notify the higher levels that the driver + * might have no data for us. We do this only if we are in + * non-blocking mode and the driver has no BlockModeProc because only + * then we really don't know if the driver will block or not. A + * similar test is done in "PeekAhead". */ if ((statePtr->flags & CHANNEL_NONBLOCKING) && (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL)) { statePtr->flags |= CHANNEL_TIMER_FEV; @@ -7094,11 +7400,11 @@ Tcl_Preserve((ClientData) statePtr); Tcl_NotifyChannel((Tcl_Channel)chanPtr, TCL_READABLE); #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING - statePtr->flags &= ~CHANNEL_TIMER_FEV; + statePtr->flags &= ~CHANNEL_TIMER_FEV; #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ Tcl_Release((ClientData) statePtr); } else { statePtr->timer = NULL; @@ -7109,47 +7415,46 @@ /* *---------------------------------------------------------------------- * * Tcl_CreateChannelHandler -- * - * Arrange for a given procedure to be invoked whenever the - * channel indicated by the chanPtr arg becomes readable or - * writable. + * Arrange for a given procedure to be invoked whenever the channel + * indicated by the chanPtr arg becomes readable or writable. * * Results: * None. * * Side effects: - * From now on, whenever the I/O channel given by chanPtr becomes - * ready in the way indicated by mask, proc will be invoked. - * See the manual entry for details on the calling sequence - * to proc. If there is already an event handler for chan, proc - * and clientData, then the mask will be updated. + * From now on, whenever the I/O channel given by chanPtr becomes ready + * in the way indicated by mask, proc will be invoked. See the manual + * entry for details on the calling sequence to proc. If there is already + * an event handler for chan, proc and clientData, then the mask will be + * updated. * *---------------------------------------------------------------------- */ void Tcl_CreateChannelHandler(chan, mask, proc, clientData) Tcl_Channel chan; /* The channel to create the handler for. */ int mask; /* OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, and TCL_EXCEPTION: - * indicates conditions under which - * proc should be called. Use 0 to - * disable a registered handler. */ - Tcl_ChannelProc *proc; /* Procedure to call for each - * selected event. */ + * TCL_WRITABLE, and TCL_EXCEPTION: indicates + * conditions under which proc should be + * called. Use 0 to disable a registered + * handler. */ + Tcl_ChannelProc *proc; /* Procedure to call for each selected + * event. */ ClientData clientData; /* Arbitrary data to pass to proc. */ { ChannelHandler *chPtr; Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* state info for channel */ /* - * Check whether this channel handler is not already registered. If - * it is not, create a new record, else reuse existing record (smash - * current values). + * Check whether this channel handler is not already registered. If it is + * not, create a new record, else reuse existing record (smash current + * values). */ for (chPtr = statePtr->chPtr; chPtr != (ChannelHandler *) NULL; chPtr = chPtr->nextPtr) { @@ -7167,20 +7472,19 @@ chPtr->nextPtr = statePtr->chPtr; statePtr->chPtr = chPtr; } /* - * The remainder of the initialization below is done regardless of - * whether or not this is a new record or a modification of an old - * one. + * The remainder of the initialization below is done regardless of whether + * or not this is a new record or a modification of an old one. */ chPtr->mask = mask; /* - * Recompute the interest mask for the channel - this call may actually - * be disabling an existing handler. + * Recompute the interest mask for the channel - this call may actually be + * disabling an existing handler. */ statePtr->interestMask = 0; for (chPtr = statePtr->chPtr; chPtr != (ChannelHandler *) NULL; @@ -7194,19 +7498,18 @@ /* *---------------------------------------------------------------------- * * Tcl_DeleteChannelHandler -- * - * Cancel a previously arranged callback arrangement for an IO - * channel. + * Cancel a previously arranged callback arrangement for an IO channel. * * Results: * None. * * Side effects: * If a callback was previously registered for this chan, proc and - * clientData , it is removed and the callback will no longer be called + * clientData, it is removed and the callback will no longer be called * when the channel becomes ready for IO. * *---------------------------------------------------------------------- */ @@ -7213,12 +7516,12 @@ void Tcl_DeleteChannelHandler(chan, proc, clientData) Tcl_Channel chan; /* The channel for which to remove the * callback. */ Tcl_ChannelProc *proc; /* The procedure in the callback to delete. */ - ClientData clientData; /* The client data in the callback - * to delete. */ + ClientData clientData; /* The client data in the callback to + * delete. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); ChannelHandler *chPtr, *prevChPtr; Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* state info for channel */ @@ -7270,12 +7573,11 @@ } ckfree((char *) chPtr); /* * Recompute the interest list for the channel, so that infinite loops - * will not result if Tcl_DeleteChannelHandler is called inside an - * event. + * will not result if Tcl_DeleteChannelHandler is called inside an event. */ statePtr->interestMask = 0; for (chPtr = statePtr->chPtr; chPtr != (ChannelHandler *) NULL; @@ -7289,12 +7591,12 @@ /* *---------------------------------------------------------------------- * * DeleteScriptRecord -- * - * Delete a script record for this combination of channel, interp - * and mask. + * Delete a script record for this combination of channel, interp and + * mask. * * Results: * None. * * Side effects: @@ -7305,14 +7607,14 @@ static void DeleteScriptRecord(interp, chanPtr, mask) Tcl_Interp *interp; /* Interpreter in which script was to be * executed. */ - Channel *chanPtr; /* The channel for which to delete the - * script record (if any). */ - int mask; /* Events in mask must exactly match mask - * of script to delete. */ + Channel *chanPtr; /* The channel for which to delete the script + * record (if any). */ + int mask; /* Events in mask must exactly match mask of + * script to delete. */ { ChannelState *statePtr = chanPtr->state; /* state info for channel */ EventScriptRecord *esPtr, *prevEsPtr; for (esPtr = statePtr->scriptRecordPtr, @@ -7354,16 +7656,16 @@ *---------------------------------------------------------------------- */ static void CreateScriptRecord(interp, chanPtr, mask, scriptPtr) - Tcl_Interp *interp; /* Interpreter in which to execute - * the stored script. */ - Channel *chanPtr; /* Channel for which script is to - * be stored. */ - int mask; /* Set of events for which script - * will be invoked. */ + Tcl_Interp *interp; /* Interpreter in which to execute the + * stored script. */ + Channel *chanPtr; /* Channel for which script is to be + * stored. */ + int mask; /* Set of events for which script will + * be invoked. */ Tcl_Obj *scriptPtr; /* Pointer to script object. */ { ChannelState *statePtr = chanPtr->state; /* state info for channel */ EventScriptRecord *esPtr; @@ -7394,13 +7696,13 @@ /* *---------------------------------------------------------------------- * * TclChannelEventScriptInvoker -- * - * Invokes a script scheduled by "fileevent" for when the channel - * becomes ready for IO. This function is invoked by the channel - * handler which was created by the Tcl "fileevent" command. + * Invokes a script scheduled by "fileevent" for when the channel becomes + * ready for IO. This function is invoked by the channel handler which + * was created by the Tcl "fileevent" command. * * Results: * None. * * Side effects: @@ -7425,21 +7727,21 @@ chanPtr = esPtr->chanPtr; mask = esPtr->mask; interp = esPtr->interp; /* - * We must preserve the interpreter so we can report errors on it - * later. Note that we do not need to preserve the channel because - * that is done by Tcl_NotifyChannel before calling channel handlers. + * We must preserve the interpreter so we can report errors on it later. + * Note that we do not need to preserve the channel because that is done + * by Tcl_NotifyChannel before calling channel handlers. */ Tcl_Preserve((ClientData) interp); result = Tcl_EvalObjEx(interp, esPtr->scriptPtr, TCL_EVAL_GLOBAL); /* - * On error, cause a background error and remove the channel handler - * and the script record. + * On error, cause a background error and remove the channel handler and + * the script record. * * NOTE: Must delete channel handler before causing the background error * because the background error may want to reinstall the handler. */ @@ -7455,14 +7757,14 @@ /* *---------------------------------------------------------------------- * * Tcl_FileEventObjCmd -- * - * This procedure implements the "fileevent" Tcl command. See the - * user documentation for details on what it does. This command is - * based on the Tk command "fileevent" which in turn is based on work - * contributed by Mark Diekhans. + * This procedure implements the "fileevent" Tcl command. See the user + * documentation for details on what it does. This command is based on + * the Tk command "fileevent" which in turn is based on work contributed + * by Mark Diekhans. * * Results: * A standard Tcl result. * * Side effects: @@ -7474,17 +7776,17 @@ /* ARGSUSED */ int Tcl_FileEventObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Interpreter in which the channel - * for which to create the handler - * is found. */ + * for which to create the handler is + * found. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Channel *chanPtr; /* The channel to create - * the handler for. */ + Channel *chanPtr; /* The channel to create the handler + * for. */ ChannelState *statePtr; /* state info for channel */ Tcl_Channel chan; /* The opaque type for the channel. */ char *chanName; int modeIndex; /* Index of mode argument. */ int mask; @@ -7540,13 +7842,13 @@ DeleteScriptRecord(interp, chanPtr, mask); return TCL_OK; } /* - * Make the script record that will link between the event and the - * script to invoke. This also creates a channel event handler which - * will evaluate the script in the supplied interpreter. + * Make the script record that will link between the event and the script + * to invoke. This also creates a channel event handler which will + * evaluate the script in the supplied interpreter. */ CreateScriptRecord(interp, chanPtr, mask, objv[3]); return TCL_OK; @@ -7556,21 +7858,21 @@ *---------------------------------------------------------------------- * * TclCopyChannel -- * * This routine copies data from one channel to another, either - * synchronously or asynchronously. If a command script is - * supplied, the operation runs in the background. The script - * is invoked when the copy completes. Otherwise the function - * waits until the copy is completed before returning. + * synchronously or asynchronously. If a command script is supplied, the + * operation runs in the background. The script is invoked when the copy + * completes. Otherwise the function waits until the copy is completed + * before returning. * * Results: * A standard Tcl result. * * Side effects: - * May schedule a background copy operation that causes both - * channels to be marked busy. + * May schedule a background copy operation that causes both channels to + * be marked busy. * *---------------------------------------------------------------------- */ int @@ -7605,21 +7907,21 @@ readFlags = inStatePtr->flags; writeFlags = outStatePtr->flags; /* * Set up the blocking mode appropriately. Background copies need - * non-blocking channels. Foreground copies need blocking channels. - * If there is an error, restore the old blocking mode. + * non-blocking channels. Foreground copies need blocking channels. If + * there is an error, restore the old blocking mode. */ if (nonBlocking != (readFlags & CHANNEL_NONBLOCKING)) { if (SetBlockMode(interp, inPtr, nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING) != TCL_OK) { return TCL_ERROR; } - } + } if (inPtr != outPtr) { if (nonBlocking != (writeFlags & CHANNEL_NONBLOCKING)) { if (SetBlockMode(NULL, outPtr, nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING) != TCL_OK) { @@ -7672,12 +7974,12 @@ /* *---------------------------------------------------------------------- * * CopyData -- * - * This function implements the lowest level of the copying - * mechanism for TclCopyChannel. + * This function implements the lowest level of the copying mechanism for + * TclCopyChannel. * * Results: * Returns TCL_OK on success, else TCL_ERROR. * * Side effects: @@ -7691,17 +7993,18 @@ CopyState *csPtr; /* State of copy operation. */ int mask; /* Current channel event flags. */ { Tcl_Interp *interp; Tcl_Obj *cmdPtr, *errObj = NULL, *bufObj = NULL; + Tcl_Obj* msg = NULL; Tcl_Channel inChan, outChan; ChannelState *inStatePtr, *outStatePtr; int result = TCL_OK, size, total, sizeb; char *buffer; int inBinary, outBinary, sameEncoding; /* Encoding control */ - int underflow; /* input underflow */ + int underflow; /* input underflow */ inChan = (Tcl_Channel) csPtr->readPtr; outChan = (Tcl_Channel) csPtr->writePtr; inStatePtr = csPtr->readPtr->state; outStatePtr = csPtr->writePtr->state; @@ -7709,13 +8012,13 @@ cmdPtr = csPtr->cmdPtr; /* * Copy the data the slow way, using the translation mechanism. * - * Note: We have make sure that we use the topmost channel in a stack - * for the copying. The caller uses Tcl_GetChannel to access it, and - * thus gets the bottom of the stack. + * Note: We have make sure that we use the topmost channel in a stack for + * the copying. The caller uses Tcl_GetChannel to access it, and thus gets + * the bottom of the stack. */ inBinary = (inStatePtr->encoding == NULL); outBinary = (outStatePtr->encoding == NULL); sameEncoding = (inStatePtr->encoding == outStatePtr->encoding); @@ -7728,16 +8031,18 @@ while (csPtr->toRead != 0) { /* * Check for unreported background errors. */ - if (inStatePtr->unreportedError != 0) { + Tcl_GetChannelError (inChan, &msg); + if ((inStatePtr->unreportedError != 0) || (msg != NULL)) { Tcl_SetErrno(inStatePtr->unreportedError); inStatePtr->unreportedError = 0; goto readError; } - if (outStatePtr->unreportedError != 0) { + Tcl_GetChannelError (outChan, &msg); + if ((outStatePtr->unreportedError != 0) || (msg != NULL)) { Tcl_SetErrno(outStatePtr->unreportedError); outStatePtr->unreportedError = 0; goto writeError; } @@ -7757,21 +8062,28 @@ size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb, 0 /* No append */); } underflow = (size >= 0) && (size < sizeb); /* input underflow */ if (size < 0) { - readError: + readError: TclNewObj(errObj); Tcl_AppendStringsToObj(errObj, "error reading \"", - Tcl_GetChannelName(inChan), "\": ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_GetChannelName(inChan), "\": ", + (char *) NULL); + if (msg != NULL) { + Tcl_AppendObjToObj(errObj,msg); + } else { + Tcl_AppendStringsToObj(errObj, + Tcl_PosixError(interp), + (char *) NULL); + } break; } else if (underflow) { /* - * We had an underflow on the read side. If we are at EOF, - * then the copying is done, otherwise set up a channel - * handler to detect when the channel becomes readable again. + * We had an underflow on the read side. If we are at EOF, then + * the copying is done, otherwise set up a channel handler to + * detect when the channel becomes readable again. */ if ((size == 0) && Tcl_Eof(inChan)) { break; } @@ -7813,23 +8125,30 @@ /* Both read and write counted bytes */ size = sizeb; } /* else : Read counted characters, write counted bytes, i.e. size != sizeb */ if (sizeb < 0) { - writeError: + writeError: TclNewObj(errObj); Tcl_AppendStringsToObj(errObj, "error writing \"", - Tcl_GetChannelName(outChan), "\": ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_GetChannelName(outChan), "\": ", + (char *) NULL); + if (msg != NULL) { + Tcl_AppendObjToObj(errObj,msg); + } else { + Tcl_AppendStringsToObj(errObj, + Tcl_PosixError(interp), + (char *) NULL); + } break; } /* - * Update the current byte count. Do it now so the count is - * valid before a return or break takes us out of the loop. - * The invariant at the top of the loop should be that - * csPtr->toRead holds the number of bytes left to copy. + * Update the current byte count. Do it now so the count is valid + * before a return or break takes us out of the loop. The invariant at + * the top of the loop should be that csPtr->toRead holds the number + * of bytes left to copy. */ if (csPtr->toRead != -1) { csPtr->toRead -= size; } @@ -7865,18 +8184,18 @@ } return TCL_OK; } /* - * For background copies, we only do one buffer per invocation so - * we don't starve the rest of the system. + * For background copies, we only do one buffer per invocation so we + * don't starve the rest of the system. */ if (cmdPtr) { /* - * The first time we enter this code, there won't be a - * channel handler established yet, so do it here. + * The first time we enter this code, there won't be a channel + * handler established yet, so do it here. */ if (mask == 0) { Tcl_CreateChannelHandler(outChan, TCL_WRITABLE, CopyEventProc, (ClientData) csPtr); @@ -7893,20 +8212,20 @@ TclDecrRefCount(bufObj); bufObj = (Tcl_Obj *) NULL; } /* - * Make the callback or return the number of bytes transferred. - * The local total is used because StopCopy frees csPtr. + * Make the callback or return the number of bytes transferred. The local + * total is used because StopCopy frees csPtr. */ total = csPtr->total; if (cmdPtr) { /* - * Get a private copy of the command so we can mutate it - * by adding arguments. Note that StopCopy frees our saved - * reference to the original command obj. + * Get a private copy of the command so we can mutate it by adding + * arguments. Note that StopCopy frees our saved reference to the + * original command obj. */ cmdPtr = Tcl_DuplicateObj(cmdPtr); Tcl_IncrRefCount(cmdPtr); StopCopy(csPtr); @@ -7943,12 +8262,12 @@ * Reads a given number of bytes from a channel. * * No encoding conversions are applied to the bytes being read. * * Results: - * The number of characters read, or -1 on error. Use Tcl_GetErrno() - * to retrieve the error code for the error that occurred. + * The number of characters read, or -1 on error. Use Tcl_GetErrno() to + * retrieve the error code for the error that occurred. * * Side effects: * May cause input to be buffered. * *---------------------------------------------------------------------- @@ -7959,20 +8278,20 @@ Channel *chanPtr; /* The channel from which to read. */ char *bufPtr; /* Where to store input read. */ int toRead; /* Maximum number of bytes to read. */ { ChannelState *statePtr = chanPtr->state; /* state info for channel */ - int copied; /* How many characters were copied into - * the result string? */ - int copiedNow; /* How many characters were copied from - * the current input buffer? */ + int copied; /* How many characters were copied into the + * result string? */ + int copiedNow; /* How many characters were copied from the + * current input buffer? */ int result; /* Of calling GetInput. */ /* - * If we have not encountered a sticky EOF, clear the EOF bit. Either - * way clear the BLOCKED bit. We want to discover these anew during - * each operation. + * If we have not encountered a sticky EOF, clear the EOF bit. Either way + * clear the BLOCKED bit. We want to discover these anew during each + * operation. */ if (!(statePtr->flags & CHANNEL_STICKY_EOF)) { statePtr->flags &= ~CHANNEL_EOF; } @@ -8001,32 +8320,32 @@ } } statePtr->flags &= (~(CHANNEL_BLOCKED)); - done: /* - * Update the notifier state so we don't block while there is still - * data in the buffers. + * Update the notifier state so we don't block while there is still data + * in the buffers. */ + done: UpdateInterest(chanPtr); return copied; } /* *---------------------------------------------------------------------- * * CopyAndTranslateBuffer -- * - * Copy at most one buffer of input to the result space, doing - * eol translations according to mode in effect currently. + * Copy at most one buffer of input to the result space, doing eol + * translations according to mode in effect currently. * * Results: - * Number of bytes stored in the result buffer (as opposed to the - * number of bytes read from the channel). May return - * zero if no input is available to be translated. + * Number of bytes stored in the result buffer (as opposed to the number + * of bytes read from the channel). May return zero if no input is + * available to be translated. * * Side effects: * Consumes buffered input. May deallocate one buffer. * *---------------------------------------------------------------------- @@ -8034,26 +8353,26 @@ static int CopyAndTranslateBuffer(statePtr, result, space) ChannelState *statePtr; /* Channel state from which to read input. */ char *result; /* Where to store the copied input. */ - int space; /* How many bytes are available in result - * to store the copied input? */ + int space; /* How many bytes are available in result to + * store the copied input? */ { ChannelBuffer *bufPtr; /* The buffer from which to copy bytes. */ - int bytesInBuffer; /* How many bytes are available to be - * copied in the current input buffer? */ + int bytesInBuffer; /* How many bytes are available to be copied + * in the current input buffer? */ int copied; /* How many characters were already copied * into the destination space? */ - int i; /* Iterates over the copied input looking - * for the input eofChar. */ + int i; /* Iterates over the copied input looking for + * the input eofChar. */ /* * If there is no input at all, return zero. The invariant is that either - * there is no buffer in the queue, or if the first buffer is empty, it - * is also the last buffer (and thus there is no input in the queue). - * Note also that if the buffer is empty, we leave it in the queue. + * there is no buffer in the queue, or if the first buffer is empty, it is + * also the last buffer (and thus there is no input in the queue). Note + * also that if the buffer is empty, we leave it in the queue. */ if (statePtr->inQueueHead == (ChannelBuffer *) NULL) { return 0; } @@ -8060,169 +8379,161 @@ bufPtr = statePtr->inQueueHead; bytesInBuffer = bufPtr->nextAdded - bufPtr->nextRemoved; copied = 0; switch (statePtr->inputTranslation) { - case TCL_TRANSLATE_LF: { - if (bytesInBuffer == 0) { - return 0; - } - - /* - * Copy the current chunk into the result buffer. - */ - - if (bytesInBuffer < space) { - space = bytesInBuffer; - } - memcpy((VOID *) result, - (VOID *) (bufPtr->buf + bufPtr->nextRemoved), - (size_t) space); - bufPtr->nextRemoved += space; - copied = space; - break; - } - case TCL_TRANSLATE_CR: { - char *end; - - if (bytesInBuffer == 0) { - return 0; - } - - /* - * Copy the current chunk into the result buffer, then - * replace all \r with \n. - */ - - if (bytesInBuffer < space) { - space = bytesInBuffer; - } - memcpy((VOID *) result, - (VOID *) (bufPtr->buf + bufPtr->nextRemoved), - (size_t) space); - bufPtr->nextRemoved += space; - copied = space; - - for (end = result + copied; result < end; result++) { - if (*result == '\r') { - *result = '\n'; - } - } - break; - } - case TCL_TRANSLATE_CRLF: { - char *src, *end, *dst; - int curByte; - - /* - * If there is a held-back "\r" at EOF, produce it now. - */ - - if (bytesInBuffer == 0) { - if ((statePtr->flags & (INPUT_SAW_CR | CHANNEL_EOF)) == - (INPUT_SAW_CR | CHANNEL_EOF)) { - result[0] = '\r'; - statePtr->flags &= ~INPUT_SAW_CR; - return 1; - } - return 0; - } - - /* - * Copy the current chunk and replace "\r\n" with "\n" - * (but not standalone "\r"!). - */ - - if (bytesInBuffer < space) { - space = bytesInBuffer; - } - memcpy((VOID *) result, - (VOID *) (bufPtr->buf + bufPtr->nextRemoved), - (size_t) space); - bufPtr->nextRemoved += space; - copied = space; - - end = result + copied; - dst = result; - for (src = result; src < end; src++) { - curByte = *src; - if (curByte == '\n') { - statePtr->flags &= ~INPUT_SAW_CR; - } else if (statePtr->flags & INPUT_SAW_CR) { - statePtr->flags &= ~INPUT_SAW_CR; - *dst = '\r'; - dst++; - } - if (curByte == '\r') { - statePtr->flags |= INPUT_SAW_CR; - } else { - *dst = (char) curByte; - dst++; - } - } - copied = dst - result; - break; - } - case TCL_TRANSLATE_AUTO: { - char *src, *end, *dst; - int curByte; - - if (bytesInBuffer == 0) { - return 0; - } - - /* - * Loop over the current buffer, converting "\r" and "\r\n" - * to "\n". - */ - - if (bytesInBuffer < space) { - space = bytesInBuffer; - } - memcpy((VOID *) result, - (VOID *) (bufPtr->buf + bufPtr->nextRemoved), - (size_t) space); - bufPtr->nextRemoved += space; - copied = space; - - end = result + copied; - dst = result; - for (src = result; src < end; src++) { - curByte = *src; - if (curByte == '\r') { - statePtr->flags |= INPUT_SAW_CR; - *dst = '\n'; - dst++; - } else { - if ((curByte != '\n') || - !(statePtr->flags & INPUT_SAW_CR)) { - *dst = (char) curByte; - dst++; - } - statePtr->flags &= ~INPUT_SAW_CR; - } - } - copied = dst - result; - break; - } - default: { - Tcl_Panic("unknown eol translation mode"); - } - } - - /* - * If an in-stream EOF character is set for this channel, check that - * the input we copied so far does not contain the EOF char. If it does, - * copy only up to and excluding that character. + case TCL_TRANSLATE_LF: + if (bytesInBuffer == 0) { + return 0; + } + + /* + * Copy the current chunk into the result buffer. + */ + + if (bytesInBuffer < space) { + space = bytesInBuffer; + } + memcpy((VOID *) result, (VOID *) (bufPtr->buf + bufPtr->nextRemoved), + (size_t) space); + bufPtr->nextRemoved += space; + copied = space; + break; + case TCL_TRANSLATE_CR: { + char *end; + + if (bytesInBuffer == 0) { + return 0; + } + + /* + * Copy the current chunk into the result buffer, then replace all \r + * with \n. + */ + + if (bytesInBuffer < space) { + space = bytesInBuffer; + } + memcpy((VOID *) result, (VOID *) (bufPtr->buf + bufPtr->nextRemoved), + (size_t) space); + bufPtr->nextRemoved += space; + copied = space; + + for (end = result + copied; result < end; result++) { + if (*result == '\r') { + *result = '\n'; + } + } + break; + } + case TCL_TRANSLATE_CRLF: { + char *src, *end, *dst; + int curByte; + + /* + * If there is a held-back "\r" at EOF, produce it now. + */ + + if (bytesInBuffer == 0) { + if ((statePtr->flags & (INPUT_SAW_CR | CHANNEL_EOF)) == + (INPUT_SAW_CR | CHANNEL_EOF)) { + result[0] = '\r'; + statePtr->flags &= ~INPUT_SAW_CR; + return 1; + } + return 0; + } + + /* + * Copy the current chunk and replace "\r\n" with "\n" + * (but not standalone "\r"!). + */ + + if (bytesInBuffer < space) { + space = bytesInBuffer; + } + memcpy((VOID *) result, (VOID *) (bufPtr->buf + bufPtr->nextRemoved), + (size_t) space); + bufPtr->nextRemoved += space; + copied = space; + + end = result + copied; + dst = result; + for (src = result; src < end; src++) { + curByte = *src; + if (curByte == '\n') { + statePtr->flags &= ~INPUT_SAW_CR; + } else if (statePtr->flags & INPUT_SAW_CR) { + statePtr->flags &= ~INPUT_SAW_CR; + *dst = '\r'; + dst++; + } + if (curByte == '\r') { + statePtr->flags |= INPUT_SAW_CR; + } else { + *dst = (char) curByte; + dst++; + } + } + copied = dst - result; + break; + } + case TCL_TRANSLATE_AUTO: { + char *src, *end, *dst; + int curByte; + + if (bytesInBuffer == 0) { + return 0; + } + + /* + * Loop over the current buffer, converting "\r" and "\r\n" to "\n". + */ + + if (bytesInBuffer < space) { + space = bytesInBuffer; + } + memcpy((VOID *) result, (VOID *) (bufPtr->buf + bufPtr->nextRemoved), + (size_t) space); + bufPtr->nextRemoved += space; + copied = space; + + end = result + copied; + dst = result; + for (src = result; src < end; src++) { + curByte = *src; + if (curByte == '\r') { + statePtr->flags |= INPUT_SAW_CR; + *dst = '\n'; + dst++; + } else { + if ((curByte != '\n') || !(statePtr->flags & INPUT_SAW_CR)) { + *dst = (char) curByte; + dst++; + } + statePtr->flags &= ~INPUT_SAW_CR; + } + } + copied = dst - result; + break; + } + default: + Tcl_Panic("unknown eol translation mode"); + } + + /* + * If an in-stream EOF character is set for this channel, check that the + * input we copied so far does not contain the EOF char. If it does, copy + * only up to and excluding that character. */ if (statePtr->inEofChar != 0) { for (i = 0; i < copied; i++) { if (result[i] == (char) statePtr->inEofChar) { /* - * Set sticky EOF so that no further input is presented - * to the caller. + * Set sticky EOF so that no further input is presented to the + * caller. */ statePtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); statePtr->inputEncodingFlags |= TCL_ENCODING_END; copied = i; @@ -8242,13 +8553,13 @@ } RecycleBuffer(statePtr, bufPtr, 0); } /* - * Return the number of characters copied into the result buffer. - * This may be different from the number of bytes consumed, because - * of EOL translations. + * Return the number of characters copied into the result buffer. This may + * be different from the number of bytes consumed, because of EOL + * translations. */ return copied; } @@ -8258,12 +8569,12 @@ * CopyBuffer -- * * Copy at most one buffer of input to the result space. * * Results: - * Number of bytes stored in the result buffer. May return - * zero if no input is available. + * Number of bytes stored in the result buffer. May return zero if no + * input is available. * * Side effects: * Consumes buffered input. May deallocate one buffer. * *---------------------------------------------------------------------- @@ -8271,25 +8582,25 @@ static int CopyBuffer(chanPtr, result, space) Channel *chanPtr; /* Channel from which to read input. */ char *result; /* Where to store the copied input. */ - int space; /* How many bytes are available in result - * to store the copied input? */ + int space; /* How many bytes are available in result to + * store the copied input? */ { ChannelBuffer *bufPtr; /* The buffer from which to copy bytes. */ - int bytesInBuffer; /* How many bytes are available to be - * copied in the current input buffer? */ + int bytesInBuffer; /* How many bytes are available to be copied + * in the current input buffer? */ int copied; /* How many characters were already copied * into the destination space? */ /* - * If there is no input at all, return zero. The invariant is that - * either there is no buffer in the queue, or if the first buffer - * is empty, it is also the last buffer (and thus there is no - * input in the queue). Note also that if the buffer is empty, we - * don't leave it in the queue, but recycle it. + * If there is no input at all, return zero. The invariant is that either + * there is no buffer in the queue, or if the first buffer is empty, it is + * also the last buffer (and thus there is no input in the queue). Note + * also that if the buffer is empty, we don't leave it in the queue, but + * recycle it. */ if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { return 0; } @@ -8311,20 +8622,19 @@ if (bytesInBuffer < space) { space = bytesInBuffer; } - memcpy((VOID *) result, - (VOID *) (bufPtr->buf + bufPtr->nextRemoved), - (size_t) space); + memcpy((VOID *) result, (VOID *) (bufPtr->buf + bufPtr->nextRemoved), + (size_t) space); bufPtr->nextRemoved += space; copied = space; /* - * We don't care about in-stream EOF characters here as the data - * read here may still flow through one or more transformations, - * i.e. is not in its final state yet. + * We don't care about in-stream EOF characters here as the data read here + * may still flow through one or more transformations, i.e. is not in its + * final state yet. */ /* * If the current buffer is empty recycle it. */ @@ -8376,20 +8686,20 @@ int foundNewline; /* Did we find a newline in output? */ char *dPtr; CONST char *sPtr; /* Search variables for newline. */ int crsent; /* In CRLF eol translation mode, * remember the fact that a CR was - * output to the channel without - * its following NL. */ + * output to the channel without its + * following NL. */ int i; /* Loop index for newline search. */ int destCopied; /* How many bytes were used in this * destination buffer to hold the * output? */ - int totalDestCopied; /* How many bytes total were - * copied to the channel buffer? */ - int srcCopied; /* How many bytes were copied from - * the source string? */ + int totalDestCopied; /* How many bytes total were copied to + * the channel buffer? */ + int srcCopied; /* How many bytes were copied from the + * source string? */ char *destPtr; /* Where in line to copy to? */ /* * If we are in network (or windows) translation mode, record the fact * that we have not yet sent a CR to the channel. @@ -8422,45 +8732,45 @@ destCopied = srcLen; } destPtr = outBufPtr->buf + outBufPtr->nextAdded; switch (statePtr->outputTranslation) { - case TCL_TRANSLATE_LF: - srcCopied = destCopied; - memcpy((VOID *) destPtr, (VOID *) src, (size_t) destCopied); - break; - case TCL_TRANSLATE_CR: - srcCopied = destCopied; - memcpy((VOID *) destPtr, (VOID *) src, (size_t) destCopied); - for (dPtr = destPtr; dPtr < destPtr + destCopied; dPtr++) { - if (*dPtr == '\n') { - *dPtr = '\r'; - } - } - break; - case TCL_TRANSLATE_CRLF: - for (srcCopied = 0, dPtr = destPtr, sPtr = src; - dPtr < destPtr + destCopied; - dPtr++, sPtr++, srcCopied++) { - if (*sPtr == '\n') { - if (crsent) { - *dPtr = '\n'; - crsent = 0; - } else { - *dPtr = '\r'; - crsent = 1; - sPtr--, srcCopied--; - } - } else { - *dPtr = *sPtr; - } - } - break; - case TCL_TRANSLATE_AUTO: - Tcl_Panic("Tcl_Write: AUTO output translation mode not supported"); - default: - Tcl_Panic("Tcl_Write: unknown output translation mode"); + case TCL_TRANSLATE_LF: + srcCopied = destCopied; + memcpy((VOID *) destPtr, (VOID *) src, (size_t) destCopied); + break; + case TCL_TRANSLATE_CR: + srcCopied = destCopied; + memcpy((VOID *) destPtr, (VOID *) src, (size_t) destCopied); + for (dPtr = destPtr; dPtr < destPtr + destCopied; dPtr++) { + if (*dPtr == '\n') { + *dPtr = '\r'; + } + } + break; + case TCL_TRANSLATE_CRLF: + for (srcCopied = 0, dPtr = destPtr, sPtr = src; + dPtr < destPtr + destCopied; + dPtr++, sPtr++, srcCopied++) { + if (*sPtr == '\n') { + if (crsent) { + *dPtr = '\n'; + crsent = 0; + } else { + *dPtr = '\r'; + crsent = 1; + sPtr--, srcCopied--; + } + } else { + *dPtr = *sPtr; + } + } + break; + case TCL_TRANSLATE_AUTO: + Tcl_Panic("Tcl_Write: AUTO output translation mode not supported"); + default: + Tcl_Panic("Tcl_Write: unknown output translation mode"); } /* * The current buffer is ready for output if it is full, or if it * contains a newline and this channel is line-buffered, or if it @@ -8505,13 +8815,13 @@ /* *---------------------------------------------------------------------- * * CopyEventProc -- * - * This routine is invoked as a channel event handler for - * the background copy operation. It is just a trivial wrapper - * around the CopyData routine. + * This routine is invoked as a channel event handler for the background + * copy operation. It is just a trivial wrapper around the CopyData + * routine. * * Results: * None. * * Side effects: @@ -8523,11 +8833,11 @@ static void CopyEventProc(clientData, mask) ClientData clientData; int mask; { - (void) CopyData((CopyState *)clientData, mask); + (void) CopyData((CopyState *) clientData, mask); } /* *---------------------------------------------------------------------- * @@ -8537,12 +8847,12 @@ * * Results: * None. * * Side effects: - * Removes any pending channel handlers and restores the blocking - * and buffering modes of the channels. The CopyState is freed. + * Removes any pending channel handlers and restores the blocking and + * buffering modes of the channels. The CopyState is freed. * *---------------------------------------------------------------------- */ static void @@ -8575,18 +8885,18 @@ nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING); } } outStatePtr->flags &= ~(CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED); outStatePtr->flags |= - csPtr->writeFlags & (CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED); + csPtr->writeFlags & (CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED); if (csPtr->cmdPtr) { - Tcl_DeleteChannelHandler((Tcl_Channel)csPtr->readPtr, CopyEventProc, - (ClientData)csPtr); + Tcl_DeleteChannelHandler((Tcl_Channel) csPtr->readPtr, CopyEventProc, + (ClientData) csPtr); if (csPtr->readPtr != csPtr->writePtr) { - Tcl_DeleteChannelHandler((Tcl_Channel)csPtr->writePtr, - CopyEventProc, (ClientData)csPtr); + Tcl_DeleteChannelHandler((Tcl_Channel) csPtr->writePtr, + CopyEventProc, (ClientData) csPtr); } TclDecrRefCount(csPtr->cmdPtr); } inStatePtr->csPtr = NULL; outStatePtr->csPtr = NULL; @@ -8596,19 +8906,19 @@ /* *---------------------------------------------------------------------- * * StackSetBlockMode -- * - * This function sets the blocking mode for a channel, iterating - * through each channel in a stack and updates the state flags. + * This function sets the blocking mode for a channel, iterating through + * each channel in a stack and updates the state flags. * * Results: * 0 if OK, result code from failed blockModeProc otherwise. * * Side effects: - * Modifies the blocking mode of the channel and possibly generates - * an error. + * Modifies the blocking mode of the channel and possibly generates an + * error. * *---------------------------------------------------------------------- */ static int @@ -8642,19 +8952,19 @@ /* *---------------------------------------------------------------------- * * SetBlockMode -- * - * This function sets the blocking mode for a channel and updates - * the state flags. + * This function sets the blocking mode for a channel and updates the + * state flags. * * Results: * A standard Tcl result. * * Side effects: - * Modifies the blocking mode of the channel and possibly generates - * an error. + * Modifies the blocking mode of the channel and possibly generates an + * error. * *---------------------------------------------------------------------- */ static int @@ -8668,12 +8978,30 @@ int result = 0; result = StackSetBlockMode(chanPtr, mode); if (result != 0) { if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "error setting blocking mode: ", - Tcl_PosixError(interp), (char *) NULL); + /* TIP #219. + * Move error messages put by the driver into the bypass area and + * put them into the regular interpreter result. Fall back to the + * regular message if nothing was found in the bypass. + * + * Note that we cannot have a message in the interpreter bypass + * area, StackSetBlockMode is restricted to the channel bypass. + * We still need the interp as the destination of the move. + */ + if (!TclChanCaughtErrorBypass (interp, (Tcl_Channel) chanPtr)) { + Tcl_AppendResult(interp, "error setting blocking mode: ", + Tcl_PosixError(interp), (char *) NULL); + } + } else { + /* TIP #219. + * If we have no interpreter to put a bypass message into we have + * to clear it, to prevent its propagation and use in other places + * unrelated to the actual occurence of the problem. + */ + Tcl_SetChannelError ((Tcl_Channel) chanPtr, NULL); } return TCL_ERROR; } if (mode == TCL_MODE_BLOCKING) { statePtr->flags &= (~(CHANNEL_NONBLOCKING | BG_FLUSH_SCHEDULED)); @@ -8709,13 +9037,13 @@ /* *---------------------------------------------------------------------- * * Tcl_GetChannelNamesEx -- * - * Return the names of open channels in the interp filtered - * filtered through a pattern. If pattern is NULL, it returns - * all the open channels. + * Return the names of open channels in the interp filtered filtered + * through a pattern. If pattern is NULL, it returns all the open + * channels. * * Results: * TCL_OK or TCL_ERROR. * * Side effects: @@ -8740,17 +9068,26 @@ if (interp == (Tcl_Interp *) NULL) { return TCL_OK; } /* - * Get the channel table that stores the channels registered - * for this interpreter. + * Get the channel table that stores the channels registered for this + * interpreter. */ hTblPtr = GetChannelTable(interp); TclNewObj(resultPtr); - + if ((pattern != NULL) && TclMatchIsTrivial(pattern) + && !((pattern[0] == 's') && (pattern[1] == 't') + && (pattern[2] == 'd'))) { + if ((Tcl_FindHashEntry(hTblPtr, pattern) != NULL) + && (Tcl_ListObjAppendElement(interp, resultPtr, + Tcl_NewStringObj(pattern, -1)) != TCL_OK)) { + goto error; + } + goto done; + } for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); hPtr != (Tcl_HashEntry *) NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { statePtr = ((Channel *) Tcl_GetHashValue(hPtr))->state; @@ -8760,35 +9097,38 @@ name = "stdout"; } else if (statePtr->topChanPtr == (Channel *) tsdPtr->stderrChannel) { name = "stderr"; } else { /* - * This is also stored in Tcl_GetHashKey(hTblPtr, hPtr), - * but it's simpler to just grab the name from the statePtr. + * This is also stored in Tcl_GetHashKey(hTblPtr, hPtr), but it's + * simpler to just grab the name from the statePtr. */ name = statePtr->channelName; } if (((pattern == NULL) || Tcl_StringMatch(name, pattern)) && (Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(name, -1)) != TCL_OK)) { + error: TclDecrRefCount(resultPtr); return TCL_ERROR; } } + + done: Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_IsChannelRegistered -- * - * Checks whether the channel is associated with the interp. - * See also Tcl_RegisterChannel and Tcl_UnregisterChannel. + * Checks whether the channel is associated with the interp. See also + * Tcl_RegisterChannel and Tcl_UnregisterChannel. * * Results: * 0 if the channel is not registered in the interpreter, 1 else. * * Side effects: @@ -8797,21 +9137,21 @@ *---------------------------------------------------------------------- */ int Tcl_IsChannelRegistered(interp, chan) - Tcl_Interp *interp; /* The interp to query of the channel */ - Tcl_Channel chan; /* The channel to check */ + Tcl_Interp *interp; /* The interp to query of the channel */ + Tcl_Channel chan; /* The channel to check */ { Tcl_HashTable *hTblPtr; /* Hash table of channels. */ Tcl_HashEntry *hPtr; /* Search variable. */ Channel *chanPtr; /* The real IO channel. */ ChannelState *statePtr; /* State of the real channel. */ /* - * Always check bottom-most channel in the stack. This is the one - * that gets registered. + * Always check bottom-most channel in the stack. This is the one that + * gets registered. */ chanPtr = ((Channel *) chan)->state->bottomChanPtr; statePtr = chanPtr->state; @@ -8860,12 +9200,12 @@ *---------------------------------------------------------------------- * * Tcl_IsChannelExisting -- * * Checks whether a channel of the given name exists in the - * (thread)-global list of all channels. - * See Tcl_GetChannelNamesEx for function exposed at the Tcl level. + * (thread)-global list of all channels. See Tcl_GetChannelNamesEx for + * function exposed at the Tcl level. * * Results: * A boolean value (0 = Does not exist, 1 = Does exist). * * Side effects: @@ -8951,14 +9291,16 @@ { if (chanTypePtr->version == TCL_CHANNEL_VERSION_2) { return TCL_CHANNEL_VERSION_2; } else if (chanTypePtr->version == TCL_CHANNEL_VERSION_3) { return TCL_CHANNEL_VERSION_3; + } else if (chanTypePtr->version == TCL_CHANNEL_VERSION_4) { + return TCL_CHANNEL_VERSION_4; } else { /* - * In wideSeekProc; } else { return NULL; } } + +/* + *---------------------------------------------------------------------- + * + * Tcl_ChannelThreadActionProc -- + * + * TIP #218, Channel Thread Actions. Return the + * Tcl_DriverThreadActionProc of the channel type. + * + * Results: + * A pointer to the proc. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_DriverThreadActionProc * +Tcl_ChannelThreadActionProc(chanTypePtr) + Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */ +{ + if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_4)) { + return chanTypePtr->threadActionProc; + } else { + return NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetChannelErrorInterp -- + * + * TIP #219, Tcl Channel Reflection API. + * Store an error message for the I/O system. + * + * Results: + * None. + * + * Side effects: + * Discards a previously stored message. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetChannelErrorInterp (interp, msg) + Tcl_Interp* interp; /* Interp to store the data into. */ + Tcl_Obj* msg; /* Error message to store. */ +{ + Interp* iPtr = (Interp*) interp; + + if (iPtr->chanMsg != NULL) { + Tcl_DecrRefCount (iPtr->chanMsg); + iPtr->chanMsg = NULL; + } + + if (msg != NULL) { + iPtr->chanMsg = FixLevelCode (msg); + Tcl_IncrRefCount (iPtr->chanMsg); + } + return; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetChannelError -- + * + * TIP #219, Tcl Channel Reflection API. + * Store an error message for the I/O system. + * + * Results: + * None. + * + * Side effects: + * Discards a previously stored message. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetChannelError (chan, msg) + Tcl_Channel chan; /* Channel to store the data into. */ + Tcl_Obj* msg; /* Error message to store. */ +{ + ChannelState* statePtr = ((Channel*) chan)->state; + + if (statePtr->chanMsg != NULL) { + Tcl_DecrRefCount (statePtr->chanMsg); + statePtr->chanMsg = NULL; + } + + if (msg != NULL) { + statePtr->chanMsg = FixLevelCode (msg); + Tcl_IncrRefCount (statePtr->chanMsg); + } + return; +} + +/* + *---------------------------------------------------------------------- + * + * FixLevelCode -- + * + * TIP #219, Tcl Channel Reflection API. + * Scans an error message for bad -code / -level + * directives. Returns a modified copy with such + * directives corrected, and the input if it had + * no problems. + * + * Results: + * A Tcl_Obj* + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj* +FixLevelCode (msg) +Tcl_Obj* msg; +{ + int lc; + Tcl_Obj** lv; + int explicitResult; + int numOptions; + int lcn; + Tcl_Obj** lvn; + int res, i, j, val, lignore, cignore; + Tcl_Obj* newlevel = NULL; + Tcl_Obj* newcode = NULL; + + /* ASSERT msg != NULL */ + + /* Process the caught message. + * + * Syntax = (option value)... ?message? + * + * Bad syntax causes a panic. Because the other side uses + * Tcl_GetReturnOptions and list construction functions to marshall the + * information. + */ + + res = Tcl_ListObjGetElements (NULL, msg, &lc, &lv); + if (res != TCL_OK) { + Tcl_Panic ("Tcl_SetChannelError(Interp): Bad syntax of message"); + } + + explicitResult = (1 == (lc % 2)); + numOptions = lc - explicitResult; + + /* No options, nothing to do. + */ + + if (numOptions == 0) { + return msg; + } + + /* Check for -code x, x != 1|error, and -level x, x != 0 */ + + for (i = 0; i < numOptions; i += 2) { + if (0 == strcmp (Tcl_GetString (lv [i]), "-code")) { + /* !"error", !integer, integer != 1 (numeric code for error) */ + + res = Tcl_GetIntFromObj (NULL, lv [i+1], &val); + if (((res == TCL_OK) && (val != 1)) || + ((res != TCL_OK) && (0 != strcmp (Tcl_GetString (lv [i+1]), "error")))) { + newcode = Tcl_NewIntObj (1); + } + } else if (0 == strcmp (Tcl_GetString (lv [i]), "-level")) { + /* !integer, integer != 0 */ + res = Tcl_GetIntFromObj (NULL, lv [i+1], &val); + if ((res != TCL_OK) || (val != 0)) { + newlevel = Tcl_NewIntObj (0); + } + } + } + + /* -code, -level are either not present or ok. Nothing to do. + */ + + if (!newlevel && !newcode) { + return msg; + } + + lcn = numOptions; + if (explicitResult) lcn ++; + if (newlevel) lcn += 2; + if (newcode) lcn += 2; + + lvn = (Tcl_Obj**) ckalloc (lcn * sizeof (Tcl_Obj*)); + + /* New level/code information is spliced into the first occurence of + * -level, -code, further occurences are ignored. The options cannot be + * not present, we would not come here. Options which are ok are simply + * copied over. + */ + + lignore = cignore = 0; + for (i = 0, j = 0; i < numOptions; i += 2) { + if (0 == strcmp (Tcl_GetString (lv [i]), "-level")) { + if (newlevel) { + lvn [j] = lv [i]; j++; + lvn [j] = newlevel; j++; + newlevel = NULL; + lignore = 1; + continue; + } else if (lignore) { + continue; + } + } else if (0 == strcmp (Tcl_GetString (lv [i]), "-code")) { + if (newcode) { + lvn [j] = lv [i]; j++; + lvn [j] = newcode; j++; + newcode = NULL; + cignore = 1; + continue; + } else if (cignore) { + continue; + } + } + /* Keep everything else, possibly copied down */ + lvn [j] = lv [i]; j++; + lvn [j] = lv [i+1]; j++; + } + + if (explicitResult) { + lvn [j] = lv [i]; j++; + } + + msg = Tcl_NewListObj (j, lvn); + + ckfree ((char*) lvn); + return msg; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelErrorInterp -- + * + * TIP #219, Tcl Channel Reflection API. + * Return the message stored by the channel driver. + * + * Results: + * Tcl error message object. + * + * Side effects: + * Resets the stored data to NULL. + * + *---------------------------------------------------------------------- + */ + +void Tcl_GetChannelErrorInterp (interp, msg) + Tcl_Interp* interp; /* Interp to query. */ + Tcl_Obj** msg; /* Place for error message. */ +{ + Interp* iPtr = (Interp*) interp; + + *msg = iPtr->chanMsg; + iPtr->chanMsg = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelError -- + * + * TIP #219, Tcl Channel Reflection API. + * Return the message stored by the channel driver. + * + * Results: + * Tcl error message object. + * + * Side effects: + * Resets the stored data to NULL. + * + *---------------------------------------------------------------------- + */ + +void Tcl_GetChannelError (chan, msg) + Tcl_Channel chan; /* Channel to query. */ + Tcl_Obj** msg; /* Place for error message. */ +{ + ChannelState* statePtr = ((Channel*) chan)->state; + + *msg = statePtr->chanMsg; + statePtr->chanMsg = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ChannelTruncateProc -- + * + * TIP #208 (subsection relating to truncation, based on TIP #206). + * Return the Tcl_DriverTruncateProc of the channel type. + * + * Results: + * A pointer to the proc. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_DriverTruncateProc * +Tcl_ChannelTruncateProc(chanTypePtr) + Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */ +{ + if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_4)) { + return chanTypePtr->truncateProc; + } else { + return NULL; + } +} #if 0 /* - * For future debugging work, a simple function to print the flags of - * a channel in semi-readable form. + * For future debugging work, a simple function to print the flags of a + * channel in semi-readable form. */ static int DumpFlags(str, flags) - char *str; - int flags; + char *str; + int flags; { char buf[20]; int i = 0; - if (flags & TCL_READABLE) buf[i++] = 'r'; else buf[i++]='_'; - if (flags & TCL_WRITABLE) buf[i++] = 'w'; else buf[i++]='_'; - if (flags & CHANNEL_NONBLOCKING) buf[i++] = 'n'; else buf[i++]='_'; - if (flags & CHANNEL_LINEBUFFERED) buf[i++] = 'l'; else buf[i++]='_'; - if (flags & CHANNEL_UNBUFFERED) buf[i++] = 'u'; else buf[i++]='_'; - if (flags & BUFFER_READY) buf[i++] = 'R'; else buf[i++]='_'; - if (flags & BG_FLUSH_SCHEDULED) buf[i++] = 'F'; else buf[i++]='_'; - if (flags & CHANNEL_CLOSED) buf[i++] = 'c'; else buf[i++]='_'; - if (flags & CHANNEL_EOF) buf[i++] = 'E'; else buf[i++]='_'; - if (flags & CHANNEL_STICKY_EOF) buf[i++] = 'S'; else buf[i++]='_'; - if (flags & CHANNEL_BLOCKED) buf[i++] = 'B'; else buf[i++]='_'; - if (flags & INPUT_SAW_CR) buf[i++] = '/'; else buf[i++]='_'; - if (flags & INPUT_NEED_NL) buf[i++] = '*'; else buf[i++]='_'; - if (flags & CHANNEL_DEAD) buf[i++] = 'D'; else buf[i++]='_'; - if (flags & CHANNEL_RAW_MODE) buf[i++] = 'R'; else buf[i++]='_'; +#define ChanFlag(chr,bit) (buf[i++] = ((flags & (bit)) ? (chr) : '_')) + + ChanFlag('r', TCL_READABLE); + ChanFlag('w', TCL_WRITABLE); + ChanFlag('n', CHANNEL_NONBLOCKING); + ChanFlag('l', CHANNEL_LINEBUFFERED); + ChanFlag('u', CHANNEL_UNBUFFERED); + ChanFlag('R', BUFFER_READY); + ChanFlag('F', BG_FLUSH_SCHEDULED); + ChanFlag('c', CHANNEL_CLOSED); + ChanFlag('E', CHANNEL_EOF); + ChanFlag('S', CHANNEL_STICKY_EOF); + ChanFlag('B', CHANNEL_BLOCKED); + ChanFlag('/', INPUT_SAW_CR); + ChanFlag('*', INPUT_NEED_NL); + ChanFlag('D', CHANNEL_DEAD); + ChanFlag('R', CHANNEL_RAW_MODE); #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING - if (flags & CHANNEL_TIMER_FEV) buf[i++] = 'T'; else buf[i++]='_'; - if (flags & CHANNEL_HAS_MORE_DATA) buf[i++] = 'H'; else buf[i++]='_'; + ChanFlag('T', CHANNEL_TIMER_FEV); + ChanFlag('H', CHANNEL_HAS_MORE_DATA); #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ - if (flags & CHANNEL_INCLOSE) buf[i++] = 'x'; else buf[i++]='_'; + ChanFlag('x', CHANNEL_INCLOSE); + buf[i] ='\0'; - fprintf(stderr,"%s: %s\n", str, buf); + fprintf(stderr, "%s: %s\n", str, buf); return 0; } #endif + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclIO.h ================================================================== --- generic/tclIO.h +++ generic/tclIO.h @@ -8,11 +8,11 @@ * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIO.h,v 1.7 2004/07/15 20:46:49 andreas_kupries Exp $ + * RCS: @(#) $Id: tclIO.h,v 1.7.2.1 2005/08/25 15:46:31 dgp Exp $ */ /* * Make sure that both EAGAIN and EWOULDBLOCK are defined. This does not * compile on systems where neither is defined. We want both defined so @@ -233,10 +233,24 @@ * long as the channel state. Never NULL. */ struct ChannelState *nextCSPtr; /* Next in list of channels currently open. */ Tcl_ThreadId managingThread; /* TIP #10: Id of the thread managing * this stack of channels. */ + + /* TIP #219 ... Info for the I/O system ... + * Error message set by channel drivers, for the propagation of + * arbitrary Tcl errors. This information, if present (chanMsg not + * NULL), takes precedence over a posix error code returned by a + * channel operation. + */ + + Tcl_Obj* chanMsg; + Tcl_Obj* unreportedMsg; /* Non-NULL if an error report was + * deferred because it happened in the + * background. The value is the + * chanMg, if any. #219's companion to + * 'unreportedError'. */ } ChannelState; /* * Values for the flags field in Channel. Any ORed combination of the * following flags can be stored in the field. These flags record various Index: generic/tclIOCmd.c ================================================================== --- generic/tclIOCmd.c +++ generic/tclIOCmd.c @@ -1,16 +1,16 @@ -/* +/* * tclIOCmd.c -- * * Contains the definitions of most of the Tcl commands relating to IO. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOCmd.c,v 1.22 2004/10/07 00:24:49 dgp Exp $ + * RCS: @(#) $Id: tclIOCmd.c,v 1.22.2.4 2005/08/25 15:46:31 dgp Exp $ */ #include "tclInt.h" /* @@ -25,13 +25,13 @@ /* * Static functions for this file: */ static void AcceptCallbackProc _ANSI_ARGS_((ClientData callbackData, - Tcl_Channel chan, char *address, int port)); + Tcl_Channel chan, char *address, int port)); static void RegisterTcpServerInterpCleanup _ANSI_ARGS_((Tcl_Interp *interp, - AcceptCallback *acceptCallbackPtr)); + AcceptCallback *acceptCallbackPtr)); static void TcpAcceptCallbacksDeleteProc _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp)); static void TcpServerCloseProc _ANSI_ARGS_((ClientData callbackData)); static void UnregisterTcpServerInterpCleanupProc _ANSI_ARGS_(( Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr)); @@ -39,12 +39,12 @@ /* *---------------------------------------------------------------------- * * Tcl_PutsObjCmd -- * - * This procedure is invoked to process the "puts" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "puts" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -59,25 +59,25 @@ ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tcl_Channel chan; /* The channel to puts on. */ - Tcl_Obj *string; /* String to write. */ - int newline; /* Add a newline at end? */ - char *channelId; /* Name of channel for puts. */ - int result; /* Result of puts operation. */ - int mode; /* Mode in which channel is opened. */ + Tcl_Channel chan; /* The channel to puts on. */ + Tcl_Obj *string; /* String to write. */ + int newline; /* Add a newline at end? */ + char *channelId; /* Name of channel for puts. */ + int result; /* Result of puts operation. */ + int mode; /* Mode in which channel is opened. */ switch (objc) { - case 2: /* puts $x */ + case 2: /* [puts $x] */ string = objv[1]; newline = 1; channelId = "stdout"; break; - case 3: /* puts -nonewline $x or puts $chan $x */ + case 3: /* [puts -nonewline $x] or [puts $chan $x] */ if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) { newline = 0; channelId = "stdout"; } else { newline = 1; @@ -84,77 +84,84 @@ channelId = Tcl_GetString(objv[1]); } string = objv[2]; break; - case 4: /* puts -nonewline $chan $x or puts $chan $x nonewline */ + case 4: /* [puts -nonewline $chan $x] or [puts $chan $x nonewline] */ if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) { channelId = Tcl_GetString(objv[2]); string = objv[3]; } else { /* - * The code below provides backwards compatibility with an - * old form of the command that is no longer recommended - * or documented. + * The code below provides backwards compatibility with an old + * form of the command that is no longer recommended or + * documented. */ char *arg; int length; arg = Tcl_GetStringFromObj(objv[3], &length); if ((length != 9) || (strncmp(arg, "nonewline", (size_t) length) != 0)) { Tcl_AppendResult(interp, "bad argument \"", arg, - "\": should be \"nonewline\"", - (char *) NULL); + "\": should be \"nonewline\"", (char *) NULL); return TCL_ERROR; } channelId = Tcl_GetString(objv[1]); string = objv[2]; } newline = 0; break; - default: /* puts or puts some bad number of arguments... */ + default: + /* [puts] or [puts some bad number of arguments...] */ Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string"); return TCL_ERROR; } chan = Tcl_GetChannel(interp, channelId, &mode); if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; + return TCL_ERROR; } if ((mode & TCL_WRITABLE) == 0) { Tcl_AppendResult(interp, "channel \"", channelId, - "\" wasn't opened for writing", (char *) NULL); - return TCL_ERROR; + "\" wasn't opened for writing", (char *) NULL); + return TCL_ERROR; } result = Tcl_WriteObj(chan, string); if (result < 0) { - goto error; + goto error; } if (newline != 0) { - result = Tcl_WriteChars(chan, "\n", 1); - if (result < 0) { - goto error; - } + result = Tcl_WriteChars(chan, "\n", 1); + if (result < 0) { + goto error; + } } return TCL_OK; - error: - Tcl_AppendResult(interp, "error writing \"", channelId, "\": ", - Tcl_PosixError(interp), (char *) NULL); + error: + /* TIP #219. + * Capture error messages put by the driver into the bypass area and put + * them into the regular interpreter result. Fall back to the regular + * message if nothing was found in the bypass. + */ + if (!TclChanCaughtErrorBypass (interp, chan)) { + Tcl_AppendResult(interp, "error writing \"", channelId, "\": ", + Tcl_PosixError(interp), (char *) NULL); + } return TCL_ERROR; } /* *---------------------------------------------------------------------- * * Tcl_FlushObjCmd -- * - * This procedure is called to process the Tcl "flush" command. - * See the user documentation for details on what it does. + * This procedure is called to process the Tcl "flush" command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -169,11 +176,11 @@ ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tcl_Channel chan; /* The channel to flush on. */ + Tcl_Channel chan; /* The channel to flush on. */ char *channelId; int mode; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channelId"); @@ -185,16 +192,23 @@ return TCL_ERROR; } if ((mode & TCL_WRITABLE) == 0) { Tcl_AppendResult(interp, "channel \"", channelId, "\" wasn't opened for writing", (char *) NULL); - return TCL_ERROR; + return TCL_ERROR; } - + if (Tcl_Flush(chan) != TCL_OK) { - Tcl_AppendResult(interp, "error flushing \"", channelId, "\": ", - Tcl_PosixError(interp), (char *) NULL); + /* TIP #219. + * Capture error messages put by the driver into the bypass area and + * put them into the regular interpreter result. Fall back to the + * regular message if nothing was found in the bypass. + */ + if (!TclChanCaughtErrorBypass (interp, chan)) { + Tcl_AppendResult(interp, "error flushing \"", channelId, "\": ", + Tcl_PosixError(interp), (char *) NULL); + } return TCL_ERROR; } return TCL_OK; } @@ -201,12 +215,12 @@ /* *---------------------------------------------------------------------- * * Tcl_GetsObjCmd -- * - * This procedure is called to process the Tcl "gets" command. - * See the user documentation for details on what it does. + * This procedure is called to process the Tcl "gets" command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -221,13 +235,13 @@ ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tcl_Channel chan; /* The channel to read from. */ - int lineLen; /* Length of line just read. */ - int mode; /* Mode in which channel is opened. */ + Tcl_Channel chan; /* The channel to read from. */ + int lineLen; /* Length of line just read. */ + int mode; /* Mode in which channel is opened. */ char *name; Tcl_Obj *linePtr; if ((objc != 2) && (objc != 3)) { Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?"); @@ -239,34 +253,42 @@ return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { Tcl_AppendResult(interp, "channel \"", name, "\" wasn't opened for reading", (char *) NULL); - return TCL_ERROR; + return TCL_ERROR; } linePtr = Tcl_NewObj(); lineLen = Tcl_GetsObj(chan, linePtr); if (lineLen < 0) { - if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { + if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { Tcl_DecrRefCount(linePtr); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading \"", name, "\": ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - lineLen = -1; + + /* TIP #219. + * Capture error messages put by the driver into the bypass area + * and put them into the regular interpreter result. Fall back to + * the regular message if nothing was found in the bypass. + */ + if (!TclChanCaughtErrorBypass (interp, chan)) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading \"", name, "\": ", + Tcl_PosixError(interp), (char *) NULL); + } + return TCL_ERROR; + } + lineLen = -1; } if (objc == 3) { if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount(linePtr); - return TCL_ERROR; - } + return TCL_ERROR; + } Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen)); - return TCL_OK; + return TCL_OK; } else { Tcl_SetObjResult(interp, linePtr); } return TCL_OK; } @@ -274,12 +296,12 @@ /* *---------------------------------------------------------------------- * * Tcl_ReadObjCmd -- * - * This procedure is invoked to process the Tcl "read" command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the Tcl "read" command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -303,14 +325,24 @@ int mode; /* Mode in which channel is opened. */ char *name; Tcl_Obj *resultPtr; if ((objc != 2) && (objc != 3)) { - argerror: + Interp *iPtr; + + argerror: + iPtr = (Interp *) interp; Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numChars?"); - Tcl_AppendResult(interp, " or \"", Tcl_GetString(objv[0]), - " ?-nonewline? channelId\"", (char *) NULL); + + /* + * Do not append directly; that makes ensembles using this command as + * a subcommand produce the wrong message. + */ + + iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; + Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? channelId"); + iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS; return TCL_ERROR; } i = 1; newline = 0; @@ -318,63 +350,70 @@ newline = 1; i++; } if (i == objc) { - goto argerror; + goto argerror; } name = Tcl_GetString(objv[i]); chan = Tcl_GetChannel(interp, name, &mode); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", name, - "\" wasn't opened for reading", (char *) NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "channel \"", name, + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; } i++; /* Consumed channel name. */ /* - * Compute how many bytes to read, and see whether the final - * newline should be dropped. + * Compute how many bytes to read, and see whether the final newline + * should be dropped. */ toRead = -1; if (i < objc) { char *arg; - + arg = Tcl_GetString(objv[i]); if (isdigit(UCHAR(arg[0]))) { /* INTL: digit */ if (Tcl_GetIntFromObj(interp, objv[i], &toRead) != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; } } else if (strcmp(arg, "nonewline") == 0) { newline = 1; } else { Tcl_AppendResult(interp, "bad argument \"", arg, "\": should be \"nonewline\"", (char *) NULL); return TCL_ERROR; - } + } } resultPtr = Tcl_NewObj(); Tcl_IncrRefCount(resultPtr); charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); if (charactersRead < 0) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading \"", name, "\": ", - Tcl_PosixError(interp), (char *) NULL); - Tcl_DecrRefCount(resultPtr); + /* TIP #219. + * Capture error messages put by the driver into the bypass area and + * put them into the regular interpreter result. Fall back to the + * regular message if nothing was found in the bypass. + */ + if (!TclChanCaughtErrorBypass (interp, chan)) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading \"", name, "\": ", + Tcl_PosixError(interp), (char *) NULL); + Tcl_DecrRefCount(resultPtr); + } return TCL_ERROR; } - + /* * If requested, remove the last newline in the channel if at EOF. */ - + if ((charactersRead > 0) && (newline != 0)) { char *result; int length; result = Tcl_GetStringFromObj(resultPtr, &length); @@ -390,19 +429,19 @@ /* *---------------------------------------------------------------------- * * Tcl_SeekObjCmd -- * - * This procedure is invoked to process the Tcl "seek" command. See - * the user documentation for details on what it does. + * This procedure is invoked to process the Tcl "seek" command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: - * Moves the position of the access point on the specified channel. - * May flush queued output. + * Moves the position of the access point on the specified channel. May + * flush queued output. * *---------------------------------------------------------------------- */ /* ARGSUSED */ @@ -445,24 +484,32 @@ mode = modeArray[optionIndex]; } result = Tcl_Seek(chan, offset, mode); if (result == Tcl_LongAsWide(-1)) { - Tcl_AppendResult(interp, "error during seek on \"", - chanName, "\": ", Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; + /* TIP #219. + * Capture error messages put by the driver into the bypass area and + * put them into the regular interpreter result. Fall back to the + * regular message if nothing was found in the bypass. + */ + if (!TclChanCaughtErrorBypass (interp, chan)) { + Tcl_AppendResult(interp, "error during seek on \"", + chanName, "\": ", Tcl_PosixError(interp), + (char *) NULL); + } + return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_TellObjCmd -- * - * This procedure is invoked to process the Tcl "tell" command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the Tcl "tell" command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -479,36 +526,49 @@ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Channel chan; /* The channel to tell on. */ char *chanName; + Tcl_WideInt newLoc; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channelId"); return TCL_ERROR; } + /* - * Try to find a channel with the right name and permissions in - * the IO channel table of this interpreter. + * Try to find a channel with the right name and permissions in the IO + * channel table of this interpreter. */ - + chanName = Tcl_GetString(objv[1]); chan = Tcl_GetChannel(interp, chanName, NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_Tell(chan))); + + newLoc = Tcl_Tell(chan); + + /* TIP #219. + * Capture error messages put by the driver into the bypass area and put + * them into the regular interpreter result. + */ + if (TclChanCaughtErrorBypass (interp, chan)) { + return TCL_ERROR; + } + + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(newLoc)); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_CloseObjCmd -- * - * This procedure is invoked to process the Tcl "close" command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the Tcl "close" command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -538,35 +598,35 @@ if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) { - /* - * If there is an error message and it ends with a newline, remove - * the newline. This is done for command pipeline channels where the - * error output from the subprocesses is stored in interp's result. - * - * NOTE: This is likely to not have any effect on regular error - * messages produced by drivers during the closing of a channel, - * because the Tcl convention is that such error messages do not - * have a terminating newline. - */ + /* + * If there is an error message and it ends with a newline, remove the + * newline. This is done for command pipeline channels where the error + * output from the subprocesses is stored in interp's result. + * + * NOTE: This is likely to not have any effect on regular error + * messages produced by drivers during the closing of a channel, + * because the Tcl convention is that such error messages do not have + * a terminating newline. + */ Tcl_Obj *resultPtr; char *string; int len; - + resultPtr = Tcl_GetObjResult(interp); if (Tcl_IsShared(resultPtr)) { resultPtr = Tcl_DuplicateObj(resultPtr); Tcl_SetObjResult(interp, resultPtr); } string = Tcl_GetStringFromObj(resultPtr, &len); - if ((len > 0) && (string[len - 1] == '\n')) { + if ((len > 0) && (string[len - 1] == '\n')) { Tcl_SetObjLength(resultPtr, len - 1); - } - return TCL_ERROR; + } + return TCL_ERROR; } return TCL_OK; } @@ -596,67 +656,70 @@ Tcl_Obj *CONST objv[]; /* Argument objects. */ { char *chanName, *optionName, *valueName; Tcl_Channel chan; /* The channel to set a mode on. */ int i; /* Iterate over arg-value pairs. */ - Tcl_DString ds; /* DString to hold result of - * calling Tcl_GetChannelOption. */ + Tcl_DString ds; /* DString to hold result of calling + * Tcl_GetChannelOption. */ if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) { Tcl_WrongNumArgs(interp, 1, objv, "channelId ?optionName? ?value? ?optionName value?..."); - return TCL_ERROR; + return TCL_ERROR; } + chanName = Tcl_GetString(objv[1]); chan = Tcl_GetChannel(interp, chanName, NULL); if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - if (objc == 2) { - Tcl_DStringInit(&ds); - if (Tcl_GetChannelOption(interp, chan, (char *) NULL, &ds) != TCL_OK) { - Tcl_DStringFree(&ds); - return TCL_ERROR; - } - Tcl_DStringResult(interp, &ds); - return TCL_OK; - } - if (objc == 3) { - Tcl_DStringInit(&ds); - optionName = Tcl_GetString(objv[2]); - if (Tcl_GetChannelOption(interp, chan, optionName, &ds) != TCL_OK) { - Tcl_DStringFree(&ds); - return TCL_ERROR; - } - Tcl_DStringResult(interp, &ds); - return TCL_OK; - } + return TCL_ERROR; + } + + if (objc == 2) { + Tcl_DStringInit(&ds); + if (Tcl_GetChannelOption(interp, chan, (char *) NULL, &ds) != TCL_OK) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + Tcl_DStringResult(interp, &ds); + return TCL_OK; + } else if (objc == 3) { + Tcl_DStringInit(&ds); + optionName = Tcl_GetString(objv[2]); + if (Tcl_GetChannelOption(interp, chan, optionName, &ds) != TCL_OK) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + Tcl_DStringResult(interp, &ds); + return TCL_OK; + } + for (i = 3; i < objc; i += 2) { optionName = Tcl_GetString(objv[i-1]); valueName = Tcl_GetString(objv[i]); - if (Tcl_SetChannelOption(interp, chan, optionName, valueName) + if (Tcl_SetChannelOption(interp, chan, optionName, valueName) != TCL_OK) { - return TCL_ERROR; - } + return TCL_ERROR; + } } + return TCL_OK; } /* *--------------------------------------------------------------------------- * * Tcl_EofObjCmd -- * - * This procedure is invoked to process the Tcl "eof" command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the Tcl "eof" command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: - * Sets interp's result to boolean true or false depending on whether - * the specified channel has an EOF condition. + * Sets interp's result to boolean true or false depending on whether the + * specified channel has an EOF condition. * *--------------------------------------------------------------------------- */ /* ARGSUSED */ @@ -671,11 +734,11 @@ int dummy; char *arg; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channelId"); - return TCL_ERROR; + return TCL_ERROR; } arg = Tcl_GetString(objv[1]); chan = Tcl_GetChannel(interp, arg, &dummy); if (chan == NULL) { @@ -689,12 +752,12 @@ /* *---------------------------------------------------------------------- * * Tcl_ExecObjCmd -- * - * This procedure is invoked to process the "exec" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "exec" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -763,17 +826,16 @@ background = 0; string = Tcl_GetString(objv[objc - 1]); if ((string[0] == '&') && (string[1] == '\0')) { objc--; - background = 1; + background = 1; } /* - * Create the string argument array "argv". Make sure argv is large - * enough to hold the argc arguments plus 1 extra for the zero - * end-of-argv word. + * Create the string argument array "argv". Make sure argv is large enough + * to hold the argc arguments plus 1 extra for the zero end-of-argv word. */ argv = argStorage; argc = objc - skip; if ((argc + 1) > sizeof(argv) / sizeof(argv[0])) { @@ -788,11 +850,11 @@ for (i = 0; i < argc; i++) { argv[i] = Tcl_GetString(objv[i + skip]); } argv[argc] = NULL; chan = Tcl_OpenCommandChannel(interp, argc, argv, - (background ? 0 : TCL_STDOUT | TCL_STDERR)); + (background ? 0 : TCL_STDOUT | TCL_STDERR)); /* * Free the argv array if malloc'ed storage was used. */ @@ -803,46 +865,54 @@ if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } if (background) { - /* + /* * Store the list of PIDs from the pipeline in interp's result and * detach the PIDs (instead of waiting for them). */ - TclGetAndDetachPids(interp, chan); - if (Tcl_Close(interp, chan) != TCL_OK) { + TclGetAndDetachPids(interp, chan); + if (Tcl_Close(interp, chan) != TCL_OK) { return TCL_ERROR; - } + } return TCL_OK; } resultPtr = Tcl_NewObj(); if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) { if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading output from command: ", - Tcl_PosixError(interp), (char *) NULL); - Tcl_DecrRefCount(resultPtr); + /* TIP #219. + * Capture error messages put by the driver into the bypass area + * and put them into the regular interpreter result. Fall back to + * the regular message if nothing was found in the bypass. + */ + if (!TclChanCaughtErrorBypass (interp, chan)) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading output from command: ", + Tcl_PosixError(interp), (char *) NULL); + Tcl_DecrRefCount(resultPtr); + } return TCL_ERROR; } } + /* - * If the process produced anything on stderr, it will have been - * returned in the interpreter result. It needs to be appended to - * the result string. + * If the process produced anything on stderr, it will have been returned + * in the interpreter result. It needs to be appended to the result + * string. */ result = Tcl_Close(interp, chan); Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp)); /* - * If the last character of the result is a newline, then remove - * the newline character. + * If the last character of the result is a newline, then remove the + * newline character. */ - + if (keepNewline == 0) { string = Tcl_GetStringFromObj(resultPtr, &length); if ((length > 0) && (string[length - 1] == '\n')) { Tcl_SetObjLength(resultPtr, length - 1); } @@ -855,19 +925,19 @@ /* *--------------------------------------------------------------------------- * * Tcl_FblockedObjCmd -- * - * This procedure is invoked to process the Tcl "fblocked" command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the Tcl "fblocked" command. See + * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: - * Sets interp's result to boolean true or false depending on whether - * the preceeding input operation on the channel would have blocked. + * Sets interp's result to boolean true or false depending on whether the + * preceeding input operation on the channel would have blocked. * *--------------------------------------------------------------------------- */ /* ARGSUSED */ @@ -882,35 +952,35 @@ int mode; char *arg; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channelId"); - return TCL_ERROR; + return TCL_ERROR; } arg = Tcl_GetString(objv[1]); chan = Tcl_GetChannel(interp, arg, &mode); if (chan == NULL) { - return TCL_ERROR; + return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", - arg, "\" wasn't opened for reading", (char *) NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "channel \"", arg, + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; } - + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_InputBlocked(chan))); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_OpenObjCmd -- * - * This procedure is invoked to process the "open" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "open" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -956,44 +1026,48 @@ /* * Open the file or create a process pipeline. */ if (!pipeline) { - chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot); + chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot); } else { - int mode, seekFlag, cmdObjc; + int mode, seekFlag, cmdObjc, binary; CONST char **cmdArgv; - if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) { - return TCL_ERROR; - } + if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) { + return TCL_ERROR; + } - mode = TclGetOpenMode(interp, modeString, &seekFlag); - if (mode == -1) { + mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary); + if (mode == -1) { chan = NULL; - } else { + } else { int flags = TCL_STDERR | TCL_ENFORCE_MODE; + switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { - case O_RDONLY: - flags |= TCL_STDOUT; - break; - case O_WRONLY: - flags |= TCL_STDIN; - break; - case O_RDWR: - flags |= (TCL_STDIN | TCL_STDOUT); - break; - default: - Tcl_Panic("Tcl_OpenCmd: invalid mode value"); - break; + case O_RDONLY: + flags |= TCL_STDOUT; + break; + case O_WRONLY: + flags |= TCL_STDIN; + break; + case O_RDWR: + flags |= (TCL_STDIN | TCL_STDOUT); + break; + default: + Tcl_Panic("Tcl_OpenCmd: invalid mode value"); + break; } chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags); + if (binary) { + Tcl_SetChannelOption(interp, chan, "-translation", "binary"); + } } - ckfree((char *) cmdArgv); + ckfree((char *) cmdArgv); } if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; + return TCL_ERROR; } Tcl_RegisterChannel(interp, chan); Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL); return TCL_OK; } @@ -1001,44 +1075,44 @@ /* *---------------------------------------------------------------------- * * TcpAcceptCallbacksDeleteProc -- * - * Assocdata cleanup routine called when an interpreter is being - * deleted to set the interp field of all the accept callback records - * registered with the interpreter to NULL. This will prevent the - * interpreter from being used in the future to eval accept scripts. + * Assocdata cleanup routine called when an interpreter is being deleted + * to set the interp field of all the accept callback records registered + * with the interpreter to NULL. This will prevent the interpreter from + * being used in the future to eval accept scripts. * * Results: * None. * * Side effects: * Deallocates memory and sets the interp field of all the accept - * callback records to NULL to prevent this interpreter from being - * used subsequently to eval accept scripts. + * callback records to NULL to prevent this interpreter from being used + * subsequently to eval accept scripts. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static void TcpAcceptCallbacksDeleteProc(clientData, interp) ClientData clientData; /* Data which was passed when the assocdata - * was registered. */ + * was registered. */ Tcl_Interp *interp; /* Interpreter being deleted - not used. */ { Tcl_HashTable *hTblPtr; Tcl_HashEntry *hPtr; Tcl_HashSearch hSearch; AcceptCallback *acceptCallbackPtr; hTblPtr = (Tcl_HashTable *) clientData; for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); - hPtr != (Tcl_HashEntry *) NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - acceptCallbackPtr = (AcceptCallback *) Tcl_GetHashValue(hPtr); - acceptCallbackPtr->interp = (Tcl_Interp *) NULL; + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + acceptCallbackPtr = (AcceptCallback *) Tcl_GetHashValue(hPtr); + acceptCallbackPtr->interp = (Tcl_Interp *) NULL; } Tcl_DeleteHashTable(hTblPtr); ckfree((char *) hTblPtr); } @@ -1045,105 +1119,103 @@ /* *---------------------------------------------------------------------- * * RegisterTcpServerInterpCleanup -- * - * Registers an accept callback record to have its interp - * field set to NULL when the interpreter is deleted. + * Registers an accept callback record to have its interp field set to + * NULL when the interpreter is deleted. * * Results: * None. * * Side effects: - * When, in the future, the interpreter is deleted, the interp - * field of the accept callback data structure will be set to - * NULL. This will prevent attempts to eval the accept script - * in a deleted interpreter. + * When, in the future, the interpreter is deleted, the interp field of + * the accept callback data structure will be set to NULL. This will + * prevent attempts to eval the accept script in a deleted interpreter. * *---------------------------------------------------------------------- */ static void RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr) Tcl_Interp *interp; /* Interpreter for which we want to be - * informed of deletion. */ + * informed of deletion. */ AcceptCallback *acceptCallbackPtr; - /* The accept callback record whose - * interp field we want set to NULL when - * the interpreter is deleted. */ + /* The accept callback record whose interp + * field we want set to NULL when the + * interpreter is deleted. */ { - Tcl_HashTable *hTblPtr; /* Hash table for accept callback - * records to smash when the interpreter - * will be deleted. */ + Tcl_HashTable *hTblPtr; /* Hash table for accept callback records to + * smash when the interpreter will be + * deleted. */ Tcl_HashEntry *hPtr; /* Entry for this record. */ int new; /* Is the entry new? */ hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, - "tclTCPAcceptCallbacks", - NULL); + "tclTCPAcceptCallbacks", NULL); if (hTblPtr == (Tcl_HashTable *) NULL) { - hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); - Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS); - (void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", - TcpAcceptCallbacksDeleteProc, (ClientData) hTblPtr); + hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); + Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS); + (void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", + TcpAcceptCallbacksDeleteProc, (ClientData) hTblPtr); } hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &new); if (!new) { - Tcl_Panic("RegisterTcpServerCleanup: damaged accept record table"); + Tcl_Panic("RegisterTcpServerCleanup: damaged accept record table"); } Tcl_SetHashValue(hPtr, (ClientData) acceptCallbackPtr); } /* *---------------------------------------------------------------------- * * UnregisterTcpServerInterpCleanupProc -- * - * Unregister a previously registered accept callback record. The - * interp field of this record will no longer be set to NULL in - * the future when the interpreter is deleted. + * Unregister a previously registered accept callback record. The interp + * field of this record will no longer be set to NULL in the future when + * the interpreter is deleted. * * Results: * None. * * Side effects: - * Prevents the interp field of the accept callback record from - * being set to NULL in the future when the interpreter is deleted. + * Prevents the interp field of the accept callback record from being set + * to NULL in the future when the interpreter is deleted. * *---------------------------------------------------------------------- */ static void UnregisterTcpServerInterpCleanupProc(interp, acceptCallbackPtr) Tcl_Interp *interp; /* Interpreter in which the accept callback - * record was registered. */ + * record was registered. */ AcceptCallback *acceptCallbackPtr; - /* The record for which to delete the - * registration. */ + /* The record for which to delete the + * registration. */ { Tcl_HashTable *hTblPtr; Tcl_HashEntry *hPtr; hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, - "tclTCPAcceptCallbacks", NULL); + "tclTCPAcceptCallbacks", NULL); if (hTblPtr == (Tcl_HashTable *) NULL) { - return; + return; } hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr); if (hPtr == (Tcl_HashEntry *) NULL) { - return; + return; } Tcl_DeleteHashEntry(hPtr); } /* *---------------------------------------------------------------------- * * AcceptCallbackProc -- * - * This callback is invoked by the TCP channel driver when it - * accepts a new connection from a client on a server socket. + * This callback is invoked by the TCP channel driver when it accepts a + * new connection from a client on a server socket. * * Results: * None. * * Side effects: @@ -1153,16 +1225,16 @@ */ static void AcceptCallbackProc(callbackData, chan, address, port) ClientData callbackData; /* The data stored when the callback - * was created in the call to - * Tcl_OpenTcpServer. */ + * was created in the call to + * Tcl_OpenTcpServer. */ Tcl_Channel chan; /* Channel for the newly accepted - * connection. */ + * connection. */ char *address; /* Address of client that was - * accepted. */ + * accepted. */ int port; /* Port of client that was accepted. */ { AcceptCallback *acceptCallbackPtr; Tcl_Interp *interp; char *script; @@ -1174,89 +1246,89 @@ /* * Check if the callback is still valid; the interpreter may have gone * away, this is signalled by setting the interp field of the callback * data to NULL. */ - + if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) { - script = acceptCallbackPtr->script; - interp = acceptCallbackPtr->interp; - - Tcl_Preserve((ClientData) script); - Tcl_Preserve((ClientData) interp); + script = acceptCallbackPtr->script; + interp = acceptCallbackPtr->interp; + + Tcl_Preserve((ClientData) script); + Tcl_Preserve((ClientData) interp); TclFormatInt(portBuf, port); - Tcl_RegisterChannel(interp, chan); - - /* - * Artificially bump the refcount to protect the channel from - * being deleted while the script is being evaluated. - */ - - Tcl_RegisterChannel((Tcl_Interp *) NULL, chan); - - result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), - " ", address, " ", portBuf, (char *) NULL); - if (result != TCL_OK) { - Tcl_BackgroundError(interp); + Tcl_RegisterChannel(interp, chan); + + /* + * Artificially bump the refcount to protect the channel from being + * deleted while the script is being evaluated. + */ + + Tcl_RegisterChannel((Tcl_Interp *) NULL, chan); + + result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), + " ", address, " ", portBuf, (char *) NULL); + if (result != TCL_OK) { + Tcl_BackgroundError(interp); Tcl_UnregisterChannel(interp, chan); - } - - /* - * Decrement the artificially bumped refcount. After this it is - * not safe anymore to use "chan", because it may now be deleted. - */ - - Tcl_UnregisterChannel((Tcl_Interp *) NULL, chan); - - Tcl_Release((ClientData) interp); - Tcl_Release((ClientData) script); + } + + /* + * Decrement the artificially bumped refcount. After this it is not + * safe anymore to use "chan", because it may now be deleted. + */ + + Tcl_UnregisterChannel((Tcl_Interp *) NULL, chan); + + Tcl_Release((ClientData) interp); + Tcl_Release((ClientData) script); } else { - /* - * The interpreter has been deleted, so there is no useful - * way to utilize the client socket - just close it. - */ + /* + * The interpreter has been deleted, so there is no useful way to + * utilize the client socket - just close it. + */ - Tcl_Close((Tcl_Interp *) NULL, chan); + Tcl_Close((Tcl_Interp *) NULL, chan); } } /* *---------------------------------------------------------------------- * * TcpServerCloseProc -- * - * This callback is called when the TCP server channel for which it - * was registered is being closed. It informs the interpreter in - * which the accept script is evaluated (if that interpreter still - * exists) that this channel no longer needs to be informed if the - * interpreter is deleted. + * This callback is called when the TCP server channel for which it was + * registered is being closed. It informs the interpreter in which the + * accept script is evaluated (if that interpreter still exists) that + * this channel no longer needs to be informed if the interpreter is + * deleted. * * Results: * None. * * Side effects: - * In the future, if the interpreter is deleted this channel will - * no longer be informed. + * In the future, if the interpreter is deleted this channel will no + * longer be informed. * *---------------------------------------------------------------------- */ static void TcpServerCloseProc(callbackData) ClientData callbackData; /* The data passed in the call to - * Tcl_CreateCloseHandler. */ + * Tcl_CreateCloseHandler. */ { AcceptCallback *acceptCallbackPtr; - /* The actual data. */ + /* The actual data. */ acceptCallbackPtr = (AcceptCallback *) callbackData; if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) { - UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, - acceptCallbackPtr); + UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, + acceptCallbackPtr); } Tcl_EventuallyFree((ClientData) acceptCallbackPtr->script, TCL_DYNAMIC); ckfree((char *) acceptCallbackPtr); } @@ -1263,12 +1335,12 @@ /* *---------------------------------------------------------------------- * * Tcl_SocketObjCmd -- * - * This procedure is invoked to process the "socket" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "socket" Tcl command. See + * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -1286,20 +1358,20 @@ { static CONST char *socketOptions[] = { "-async", "-myaddr", "-myport","-server", (char *) NULL }; enum socketOptions { - SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER + SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER }; int optionIndex, a, server, port; char *arg, *copyScript, *host, *script; char *myaddr = NULL; int myport = 0; int async = 0; Tcl_Channel chan; AcceptCallback *acceptCallbackPtr; - + server = 0; script = NULL; if (TclpHasSockets(interp) != TCL_OK) { return TCL_ERROR; @@ -1313,158 +1385,154 @@ if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions, "option", TCL_EXACT, &optionIndex) != TCL_OK) { return TCL_ERROR; } switch ((enum socketOptions) optionIndex) { - case SKT_ASYNC: { - if (server == 1) { - Tcl_AppendResult(interp, - "cannot set -async option for server sockets", - (char *) NULL); - return TCL_ERROR; - } - async = 1; - break; - } - case SKT_MYADDR: { - a++; - if (a >= objc) { - Tcl_AppendResult(interp, - "no argument given for -myaddr option", - (char *) NULL); - return TCL_ERROR; - } - myaddr = Tcl_GetString(objv[a]); - break; - } - case SKT_MYPORT: { - char *myPortName; - a++; - if (a >= objc) { - Tcl_AppendResult(interp, - "no argument given for -myport option", - (char *) NULL); - return TCL_ERROR; - } - myPortName = Tcl_GetString(objv[a]); - if (TclSockGetPort(interp, myPortName, "tcp", &myport) - != TCL_OK) { - return TCL_ERROR; - } - break; - } - case SKT_SERVER: { - if (async == 1) { - Tcl_AppendResult(interp, - "cannot set -async option for server sockets", - (char *) NULL); - return TCL_ERROR; - } - server = 1; - a++; - if (a >= objc) { - Tcl_AppendResult(interp, - "no argument given for -server option", - (char *) NULL); - return TCL_ERROR; - } - script = Tcl_GetString(objv[a]); - break; - } - default: { - Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); - } + case SKT_ASYNC: + if (server == 1) { + Tcl_AppendResult(interp, + "cannot set -async option for server sockets", + (char *) NULL); + return TCL_ERROR; + } + async = 1; + break; + case SKT_MYADDR: + a++; + if (a >= objc) { + Tcl_AppendResult(interp, + "no argument given for -myaddr option", (char *) NULL); + return TCL_ERROR; + } + myaddr = Tcl_GetString(objv[a]); + break; + case SKT_MYPORT: { + char *myPortName; + + a++; + if (a >= objc) { + Tcl_AppendResult(interp, + "no argument given for -myport option", (char *) NULL); + return TCL_ERROR; + } + myPortName = Tcl_GetString(objv[a]); + if (TclSockGetPort(interp, myPortName, "tcp", &myport) != TCL_OK) { + return TCL_ERROR; + } + break; + } + case SKT_SERVER: + if (async == 1) { + Tcl_AppendResult(interp, + "cannot set -async option for server sockets", + (char *) NULL); + return TCL_ERROR; + } + server = 1; + a++; + if (a >= objc) { + Tcl_AppendResult(interp, + "no argument given for -server option", (char *) NULL); + return TCL_ERROR; + } + script = Tcl_GetString(objv[a]); + break; + default: + Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); } } if (server) { - host = myaddr; /* NULL implies INADDR_ANY */ + host = myaddr; /* NULL implies INADDR_ANY */ if (myport != 0) { Tcl_AppendResult(interp, "Option -myport is not valid for servers", NULL); return TCL_ERROR; } } else if (a < objc) { host = Tcl_GetString(objv[a]); a++; } else { -wrongNumArgs: - Tcl_AppendResult(interp, "wrong # args: should be either:\n", - Tcl_GetString(objv[0]), - " ?-myaddr addr? ?-myport myport? ?-async? host port\n", - Tcl_GetString(objv[0]), - " -server command ?-myaddr addr? port", - (char *) NULL); - return TCL_ERROR; + Interp *iPtr; + + wrongNumArgs: + iPtr = (Interp *) interp; + Tcl_WrongNumArgs(interp, 1, objv, + "?-myaddr addr? ?-myport myport? ?-async? host port"); + iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; + Tcl_WrongNumArgs(interp, 1, objv, + "-server command ?-myaddr addr? port"); + iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS; + return TCL_ERROR; } if (a == objc-1) { - if (TclSockGetPort(interp, Tcl_GetString(objv[a]), - "tcp", &port) != TCL_OK) { + if (TclSockGetPort(interp, Tcl_GetString(objv[a]), "tcp", + &port) != TCL_OK) { return TCL_ERROR; } } else { goto wrongNumArgs; } if (server) { - acceptCallbackPtr = (AcceptCallback *) ckalloc((unsigned) - sizeof(AcceptCallback)); - copyScript = ckalloc((unsigned) strlen(script) + 1); - strcpy(copyScript, script); - acceptCallbackPtr->script = copyScript; - acceptCallbackPtr->interp = interp; - chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, - (ClientData) acceptCallbackPtr); - if (chan == (Tcl_Channel) NULL) { - ckfree(copyScript); - ckfree((char *) acceptCallbackPtr); - return TCL_ERROR; - } - - /* - * Register with the interpreter to let us know when the - * interpreter is deleted (by having the callback set the - * acceptCallbackPtr->interp field to NULL). This is to - * avoid trying to eval the script in a deleted interpreter. - */ - - RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr); - - /* - * Register a close callback. This callback will inform the - * interpreter (if it still exists) that this channel does not - * need to be informed when the interpreter is deleted. - */ - - Tcl_CreateCloseHandler(chan, TcpServerCloseProc, - (ClientData) acceptCallbackPtr); + acceptCallbackPtr = (AcceptCallback *) ckalloc((unsigned) + sizeof(AcceptCallback)); + copyScript = ckalloc((unsigned) strlen(script) + 1); + strcpy(copyScript, script); + acceptCallbackPtr->script = copyScript; + acceptCallbackPtr->interp = interp; + chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, + (ClientData) acceptCallbackPtr); + if (chan == (Tcl_Channel) NULL) { + ckfree(copyScript); + ckfree((char *) acceptCallbackPtr); + return TCL_ERROR; + } + + /* + * Register with the interpreter to let us know when the interpreter + * is deleted (by having the callback set the interp field of the + * acceptCallbackPtr's structure to NULL). This is to avoid trying to + * eval the script in a deleted interpreter. + */ + + RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr); + + /* + * Register a close callback. This callback will inform the + * interpreter (if it still exists) that this channel does not need to + * be informed when the interpreter is deleted. + */ + + Tcl_CreateCloseHandler(chan, TcpServerCloseProc, + (ClientData) acceptCallbackPtr); } else { - chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } + chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } } - Tcl_RegisterChannel(interp, chan); + Tcl_RegisterChannel(interp, chan); Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL); - + return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_FcopyObjCmd -- * - * This procedure is invoked to process the "fcopy" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "fcopy" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: - * Moves data between two channels and possibly sets up a - * background copy handler. + * Moves data between two channels and possibly sets up a background copy + * handler. * *---------------------------------------------------------------------- */ int @@ -1487,33 +1555,33 @@ "input output ?-size size? ?-command callback?"); return TCL_ERROR; } /* - * Parse the channel arguments and verify that they are readable - * or writable, as appropriate. + * Parse the channel arguments and verify that they are readable or + * writable, as appropriate. */ arg = Tcl_GetString(objv[1]); inChan = Tcl_GetChannel(interp, arg, &mode); if (inChan == (Tcl_Channel) NULL) { return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", arg, - "\" wasn't opened for reading", (char *) NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "channel \"", arg, + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; } arg = Tcl_GetString(objv[2]); outChan = Tcl_GetChannel(interp, arg, &mode); if (outChan == (Tcl_Channel) NULL) { return TCL_ERROR; } if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", arg, - "\" wasn't opened for writing", (char *) NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "channel \"", arg, + "\" wasn't opened for writing", (char *) NULL); + return TCL_ERROR; } toRead = -1; cmdPtr = NULL; for (i = 3; i < objc; i += 2) { @@ -1520,18 +1588,102 @@ if (Tcl_GetIndexFromObj(interp, objv[i], switches, "switch", 0, (int *) &index) != TCL_OK) { return TCL_ERROR; } switch (index) { - case FcopySize: - if (Tcl_GetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) { - return TCL_ERROR; - } - break; - case FcopyCommand: - cmdPtr = objv[i+1]; - break; + case FcopySize: + if (Tcl_GetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) { + return TCL_ERROR; + } + break; + case FcopyCommand: + cmdPtr = objv[i+1]; + break; } } return TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr); } + +/* + *---------------------------------------------------------------------- + * + * Tcl_ChanTruncateObjCmd -- + * + * This procedure is invoked to process the "chan truncate" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Truncates a channel (or rather a file underlying a channel). + * + *---------------------------------------------------------------------- + */ + +int +TclChanTruncateObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Channel chan; + int mode; + Tcl_WideInt length; + char *chanName; + + if ((objc < 2) || (objc > 3)) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId ?length?"); + return TCL_ERROR; + } + chanName = TclGetString(objv[1]); + chan = Tcl_GetChannel(interp, chanName, &mode); + if (chan == NULL) { + return TCL_ERROR; + } + + if (objc == 3) { + /* + * User is supplying an explicit length. + */ + + if (Tcl_GetWideIntFromObj(interp, objv[2], &length) != TCL_OK) { + return TCL_ERROR; + } + if (length < 0) { + Tcl_AppendResult(interp, + "cannot truncate to negative length of file", NULL); + return TCL_ERROR; + } + } else { + /* + * User wants to truncate to the current file position. + */ + + length = Tcl_Tell(chan); + if (length == Tcl_WideAsLong(-1)) { + Tcl_AppendResult(interp, + "could not determine current location in \"", chanName, + "\": ", Tcl_PosixError(interp), NULL); + return TCL_ERROR; + } + } + + if (Tcl_TruncateChannel(chan, length) != TCL_OK) { + Tcl_AppendResult(interp, "error during truncate on \"", chanName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ + Index: generic/tclIOGT.c ================================================================== --- generic/tclIOGT.c +++ generic/tclIOGT.c @@ -8,125 +8,123 @@ * Copyright (c) 1999-2000 Andreas Kupries (a.kupries@westend.com) * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * CVS: $Id: tclIOGT.c,v 1.12 2004/11/13 00:19:09 dgp Exp $ + * CVS: $Id: tclIOGT.c,v 1.12.2.1 2005/08/02 18:15:32 dgp Exp $ */ #include "tclInt.h" #include "tclIO.h" - /* - * Forward declarations of internal procedures. - * First the driver procedures of the transformation. + * Forward declarations of internal procedures. First the driver procedures + * of the transformation. */ -static int TransformBlockModeProc _ANSI_ARGS_ (( - ClientData instanceData, int mode)); -static int TransformCloseProc _ANSI_ARGS_ (( - ClientData instanceData, Tcl_Interp* interp)); -static int TransformInputProc _ANSI_ARGS_ (( - ClientData instanceData, - char* buf, int toRead, int* errorCodePtr)); -static int TransformOutputProc _ANSI_ARGS_ (( - ClientData instanceData, CONST char *buf, - int toWrite, int* errorCodePtr)); -static int TransformSeekProc _ANSI_ARGS_ (( - ClientData instanceData, long offset, - int mode, int* errorCodePtr)); +static int TransformBlockModeProc _ANSI_ARGS_(( + ClientData instanceData, int mode)); +static int TransformCloseProc _ANSI_ARGS_(( + ClientData instanceData, Tcl_Interp* interp)); +static int TransformInputProc _ANSI_ARGS_(( + ClientData instanceData, char *buf, int toRead, + int *errorCodePtr)); +static int TransformOutputProc _ANSI_ARGS_(( + ClientData instanceData, CONST char *buf, + int toWrite, int *errorCodePtr)); +static int TransformSeekProc _ANSI_ARGS_(( + ClientData instanceData, long offset, int mode, + int *errorCodePtr)); static int TransformSetOptionProc _ANSI_ARGS_(( - ClientData instanceData, Tcl_Interp *interp, - CONST char *optionName, CONST char *value)); + ClientData instanceData, Tcl_Interp *interp, + CONST char *optionName, CONST char *value)); static int TransformGetOptionProc _ANSI_ARGS_(( - ClientData instanceData, Tcl_Interp *interp, - CONST char *optionName, Tcl_DString *dsPtr)); -static void TransformWatchProc _ANSI_ARGS_ (( - ClientData instanceData, int mask)); -static int TransformGetFileHandleProc _ANSI_ARGS_ (( - ClientData instanceData, int direction, - ClientData* handlePtr)); -static int TransformNotifyProc _ANSI_ARGS_ (( - ClientData instanceData, int mask)); -static Tcl_WideInt TransformWideSeekProc _ANSI_ARGS_ (( - ClientData instanceData, Tcl_WideInt offset, - int mode, int* errorCodePtr)); + ClientData instanceData, Tcl_Interp *interp, + CONST char *optionName, Tcl_DString *dsPtr)); +static void TransformWatchProc _ANSI_ARGS_(( + ClientData instanceData, int mask)); +static int TransformGetFileHandleProc _ANSI_ARGS_(( + ClientData instanceData, int direction, + ClientData *handlePtr)); +static int TransformNotifyProc _ANSI_ARGS_(( + ClientData instanceData, int mask)); +static Tcl_WideInt TransformWideSeekProc _ANSI_ARGS_(( + ClientData instanceData, Tcl_WideInt offset, + int mode, int *errorCodePtr)); /* - * Forward declarations of internal procedures. - * Secondly the procedures for handling and generating fileeevents. + * Forward declarations of internal procedures. Secondly the procedures for + * handling and generating fileeevents. */ -static void TransformChannelHandlerTimer _ANSI_ARGS_ (( - ClientData clientData)); +static void TransformChannelHandlerTimer _ANSI_ARGS_(( + ClientData clientData)); /* - * Forward declarations of internal procedures. - * Third, helper procedures encapsulating essential tasks. + * Forward declarations of internal procedures. Third, helper procedures + * encapsulating essential tasks. */ typedef struct TransformChannelData TransformChannelData; -static int ExecuteCallback _ANSI_ARGS_ (( - TransformChannelData* ctrl, Tcl_Interp* interp, - unsigned char* op, unsigned char* buf, - int bufLen, int transmit, int preserve)); +static int ExecuteCallback _ANSI_ARGS_(( + TransformChannelData *ctrl, Tcl_Interp *interp, + unsigned char *op, unsigned char *buf, int bufLen, + int transmit, int preserve)); /* - * Action codes to give to 'ExecuteCallback' (argument 'transmit') - * confering to the procedure what to do with the result of the script - * it calls. + * Action codes to give to 'ExecuteCallback' (argument 'transmit') confering + * to the procedure what to do with the result of the script it calls. */ -#define TRANSMIT_DONT (0) /* No transfer to do */ -#define TRANSMIT_DOWN (1) /* Transfer to the underlying channel */ -#define TRANSMIT_SELF (2) /* Transfer into our channel. */ -#define TRANSMIT_IBUF (3) /* Transfer to internal input buffer */ -#define TRANSMIT_NUM (4) /* Transfer number to 'maxRead' */ +#define TRANSMIT_DONT (0) /* No transfer to do */ +#define TRANSMIT_DOWN (1) /* Transfer to the underlying channel */ +#define TRANSMIT_SELF (2) /* Transfer into our channel. */ +#define TRANSMIT_IBUF (3) /* Transfer to internal input buffer */ +#define TRANSMIT_NUM (4) /* Transfer number to 'maxRead' */ /* * Codes for 'preserve' of 'ExecuteCallback' */ -#define P_PRESERVE (1) -#define P_NO_PRESERVE (0) +#define P_PRESERVE (1) +#define P_NO_PRESERVE (0) /* - * Strings for the action codes delivered to the script implementing - * a transformation. Argument 'op' of 'ExecuteCallback'. + * Strings for the action codes delivered to the script implementing a + * transformation. Argument 'op' of 'ExecuteCallback'. */ -#define A_CREATE_WRITE (UCHARP ("create/write")) -#define A_DELETE_WRITE (UCHARP ("delete/write")) -#define A_FLUSH_WRITE (UCHARP ("flush/write")) -#define A_WRITE (UCHARP ("write")) - -#define A_CREATE_READ (UCHARP ("create/read")) -#define A_DELETE_READ (UCHARP ("delete/read")) -#define A_FLUSH_READ (UCHARP ("flush/read")) -#define A_READ (UCHARP ("read")) - -#define A_QUERY_MAXREAD (UCHARP ("query/maxRead")) -#define A_CLEAR_READ (UCHARP ("clear/read")) +#define A_CREATE_WRITE (UCHARP("create/write")) +#define A_DELETE_WRITE (UCHARP("delete/write")) +#define A_FLUSH_WRITE (UCHARP("flush/write")) +#define A_WRITE (UCHARP("write")) + +#define A_CREATE_READ (UCHARP("create/read")) +#define A_DELETE_READ (UCHARP("delete/read")) +#define A_FLUSH_READ (UCHARP("flush/read")) +#define A_READ (UCHARP("read")) + +#define A_QUERY_MAXREAD (UCHARP("query/maxRead")) +#define A_CLEAR_READ (UCHARP("clear/read")) /* * Management of a simple buffer. */ typedef struct ResultBuffer ResultBuffer; -static void ResultClear _ANSI_ARGS_ ((ResultBuffer* r)); -static void ResultInit _ANSI_ARGS_ ((ResultBuffer* r)); -static int ResultLength _ANSI_ARGS_ ((ResultBuffer* r)); -static int ResultCopy _ANSI_ARGS_ ((ResultBuffer* r, - unsigned char* buf, int toRead)); -static void ResultAdd _ANSI_ARGS_ ((ResultBuffer* r, - unsigned char* buf, int toWrite)); +static void ResultClear _ANSI_ARGS_((ResultBuffer *r)); +static void ResultInit _ANSI_ARGS_((ResultBuffer *r)); +static int ResultLength _ANSI_ARGS_((ResultBuffer *r)); +static int ResultCopy _ANSI_ARGS_((ResultBuffer *r, + unsigned char *buf, int toRead)); +static void ResultAdd _ANSI_ARGS_((ResultBuffer *r, + unsigned char *buf, int toWrite)); /* - * This structure describes the channel type structure for tcl based + * This structure describes the channel type structure for Tcl based * transformations. */ static Tcl_ChannelType transformChannelType = { "transform", /* Type name. */ @@ -156,83 +154,83 @@ * Definition of the structure containing the information about the * internal input buffer. */ struct ResultBuffer { - unsigned char* buf; /* Reference to the buffer area */ - int allocated; /* Allocated size of the buffer area */ - int used; /* Number of bytes in the buffer, <= allocated */ + unsigned char *buf; /* Reference to the buffer area. */ + int allocated; /* Allocated size of the buffer area. */ + int used; /* Number of bytes in the buffer, <= + * allocated. */ }; /* * Additional bytes to allocate during buffer expansion */ -#define INCREMENT (512) +#define INCREMENT (512) /* - * Number of milliseconds to wait before firing an event to flush - * out information waiting in buffers (fileevent support). + * Number of milliseconds to wait before firing an event to flush out + * information waiting in buffers (fileevent support). */ -#define FLUSH_DELAY (5) +#define FLUSH_DELAY (5) /* * Convenience macro to make some casts easier to use. */ -#define UCHARP(x) ((unsigned char*) (x)) -#define NO_INTERP ((Tcl_Interp*) NULL) +#define UCHARP(x) ((unsigned char *) (x)) +#define NO_INTERP ((Tcl_Interp *) NULL) /* * Definition of a structure used by all transformations generated here to * maintain their local state. */ struct TransformChannelData { - /* * General section. Data to integrate the transformation into the channel * system. */ - Tcl_Channel self; /* Our own Channel handle */ - int readIsFlushed; /* Flag to note wether in.flushProc was called or not - */ - int flags; /* Currently CHANNEL_ASYNC or zero */ - int watchMask; /* Current watch/event/interest mask */ - int mode; /* mode of parent channel, OR'ed combination of - * TCL_READABLE, TCL_WRITABLE */ - Tcl_TimerToken timer; /* Timer for automatic flushing of information - * sitting in an internal buffer. Required for full - * fileevent support */ + Tcl_Channel self; /* Our own Channel handle. */ + int readIsFlushed; /* Flag to note whether in.flushProc was + * called or not. */ + int flags; /* Currently CHANNEL_ASYNC or zero. */ + int watchMask; /* Current watch/event/interest mask. */ + int mode; /* Mode of parent channel, OR'ed combination + * of TCL_READABLE, TCL_WRITABLE. */ + Tcl_TimerToken timer; /* Timer for automatic flushing of information + * sitting in an internal buffer. Required for + * full fileevent support. */ + /* * Transformation specific data. */ - int maxRead; /* Maximum allowed number of bytes to read, as - * given to us by the tcl script implementing the - * transformation. */ - Tcl_Interp* interp; /* Reference to the interpreter which created the - * transformation. Used to execute the code - * below. */ - Tcl_Obj* command; /* Tcl code to execute for a buffer */ - ResultBuffer result; /* Internal buffer used to store the result of a - * transformation of incoming data. Additionally - * serves as buffer of all data not yet consumed by - * the reader. */ + int maxRead; /* Maximum allowed number of bytes to read, as + * given to us by the tcl script implementing + * the transformation. */ + Tcl_Interp *interp; /* Reference to the interpreter which created + * the transformation. Used to execute the + * code below. */ + Tcl_Obj *command; /* Tcl code to execute for a buffer */ + ResultBuffer result; /* Internal buffer used to store the result of + * a transformation of incoming data. + * Additionally serves as buffer of all data + * not yet consumed by the reader. */ }; - /* *---------------------------------------------------------------------- * * TclChannelTransform -- * - * Implements the Tcl "testchannel transform" debugging command. - * This is part of the testing environment. This sets up a tcl - * script (cmdObjPtr) to be used as a transform on the channel. + * Implements the Tcl "testchannel transform" debugging command. This is + * part of the testing environment. This sets up a tcl script (cmdObjPtr) + * to be used as a transform on the channel. * * Results: * A standard Tcl result. * * Side effects: @@ -246,34 +244,33 @@ TclChannelTransform(interp, chan, cmdObjPtr) Tcl_Interp *interp; /* Interpreter for result. */ Tcl_Channel chan; /* Channel to transform. */ Tcl_Obj *cmdObjPtr; /* Script to use for transform. */ { - Channel *chanPtr; /* The actual channel. */ - ChannelState *statePtr; /* state info for channel */ - int mode; /* rw mode of the channel */ - TransformChannelData *dataPtr; - int res; - Tcl_DString ds; + Channel *chanPtr; /* The actual channel. */ + ChannelState *statePtr; /* state info for channel */ + int mode; /* rw mode of the channel */ + TransformChannelData *dataPtr; + int res; + Tcl_DString ds; if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } - chanPtr = (Channel *) chan; - statePtr = chanPtr->state; - chanPtr = statePtr->topChanPtr; - chan = (Tcl_Channel) chanPtr; - mode = (statePtr->flags & (TCL_READABLE|TCL_WRITABLE)); + chanPtr = (Channel *) chan; + statePtr = chanPtr->state; + chanPtr = statePtr->topChanPtr; + chan = (Tcl_Channel) chanPtr; + mode = (statePtr->flags & (TCL_READABLE|TCL_WRITABLE)); /* - * Now initialize the transformation state and stack it upon the - * specified channel. One of the necessary things to do is to - * retrieve the blocking regime of the underlying channel and to - * use the same for us too. + * Now initialize the transformation state and stack it upon the specified + * channel. One of the necessary things to do is to retrieve the blocking + * regime of the underlying channel and to use the same for us too. */ - dataPtr = (TransformChannelData*) ckalloc(sizeof(TransformChannelData)); + dataPtr = (TransformChannelData *) ckalloc(sizeof(TransformChannelData)); Tcl_DStringInit (&ds); Tcl_GetChannelOption(interp, chan, "-blocking", &ds); dataPtr->readIsFlushed = 0; @@ -281,19 +278,19 @@ if (ds.string[0] == '0') { dataPtr->flags |= CHANNEL_ASYNC; } - Tcl_DStringFree (&ds); - - dataPtr->self = chan; - dataPtr->watchMask = 0; - dataPtr->mode = mode; - dataPtr->timer = (Tcl_TimerToken) NULL; - dataPtr->maxRead = 4096; /* Initial value not relevant */ - dataPtr->interp = interp; - dataPtr->command = cmdObjPtr; + Tcl_DStringFree(&ds); + + dataPtr->self = chan; + dataPtr->watchMask = 0; + dataPtr->mode = mode; + dataPtr->timer = (Tcl_TimerToken) NULL; + dataPtr->maxRead = 4096; /* Initial value not relevant */ + dataPtr->interp = interp; + dataPtr->command = cmdObjPtr; Tcl_IncrRefCount(dataPtr->command); ResultInit(&dataPtr->result); @@ -303,35 +300,35 @@ Tcl_AppendResult(interp, "\nfailed to stack channel \"", Tcl_GetChannelName(chan), "\"", (char *) NULL); Tcl_DecrRefCount(dataPtr->command); ResultClear(&dataPtr->result); - ckfree((VOID *) dataPtr); + ckfree((char *) dataPtr); return TCL_ERROR; } /* * At last initialize the transformation at the script level. */ if (dataPtr->mode & TCL_WRITABLE) { - res = ExecuteCallback (dataPtr, NO_INTERP, A_CREATE_WRITE, - NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE); + res = ExecuteCallback(dataPtr, NO_INTERP, A_CREATE_WRITE, NULL, 0, + TRANSMIT_DONT, P_NO_PRESERVE); if (res != TCL_OK) { Tcl_UnstackChannel(interp, chan); return TCL_ERROR; } } if (dataPtr->mode & TCL_READABLE) { - res = ExecuteCallback (dataPtr, NO_INTERP, A_CREATE_READ, - NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE); + res = ExecuteCallback(dataPtr, NO_INTERP, A_CREATE_READ, NULL, 0, + TRANSMIT_DONT, P_NO_PRESERVE); if (res != TCL_OK) { - ExecuteCallback (dataPtr, NO_INTERP, A_DELETE_WRITE, - NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE); + ExecuteCallback(dataPtr, NO_INTERP, A_DELETE_WRITE, NULL, 0, + TRANSMIT_DONT, P_NO_PRESERVE); Tcl_UnstackChannel(interp, chan); return TCL_ERROR; } } @@ -338,57 +335,56 @@ return TCL_OK; } /* - *------------------------------------------------------* - * - * ExecuteCallback -- - * - * Executes the defined callback for buffer and - * operation. - * - * Sideeffects: - * As of the executed tcl script. - * - * Result: - * A standard TCL error code. In case of an - * error a message is left in the result area - * of the specified interpreter. - * - *------------------------------------------------------* + *---------------------------------------------------------------------- + * + * ExecuteCallback -- + * + * Executes the defined callback for buffer and operation. + * + * Side effects: + * As of the executed tcl script. + * + * Result: + * A standard TCL error code. In case of an error a message is left in + * the result area of the specified interpreter. + * + *---------------------------------------------------------------------- */ static int -ExecuteCallback (dataPtr, interp, op, buf, bufLen, transmit, preserve) - TransformChannelData* dataPtr; /* Transformation with the callback */ - Tcl_Interp* interp; /* Current interpreter, possibly NULL */ - unsigned char* op; /* Operation invoking the callback */ - unsigned char* buf; /* Buffer to give to the script. */ - int bufLen; /* Ands its length */ - int transmit; /* Flag, determines whether the result - * of the callback is sent to the - * underlying channel or not. */ - int preserve; /* Flag. If true the procedure will - * preserver the result state of all - * accessed interpreters. */ +ExecuteCallback(dataPtr, interp, op, buf, bufLen, transmit, preserve) + TransformChannelData *dataPtr; /* Transformation with the callback */ + Tcl_Interp *interp; /* Current interpreter, possibly + * NULL. */ + unsigned char *op; /* Operation invoking the callback */ + unsigned char *buf; /* Buffer to give to the script. */ + int bufLen; /* And its length */ + int transmit; /* Flag, determines whether the result + * of the callback is sent to the + * underlying channel or not. */ + int preserve; /* Flag. If true the procedure will + * preserver the result state of all + * accessed interpreters. */ { /* * Step 1, create the complete command to execute. Do this by appending * operation and buffer to operate upon to a copy of the callback * definition. We *cannot* create a list containing 3 objects and then use * 'Tcl_EvalObjv', because the command may contain additional prefixed * arguments. Feather's curried commands would come in handy here. */ - Tcl_Obj* resObj; /* See below, switch (transmit) */ + Tcl_Obj *resObj; /* See below, switch (transmit) */ int resLen; - unsigned char* resBuf; + unsigned char *resBuf; Tcl_InterpState state = NULL; int res = TCL_OK; - Tcl_Obj* command = Tcl_DuplicateObj (dataPtr->command); - Tcl_Obj* temp; + Tcl_Obj *command = Tcl_DuplicateObj(dataPtr->command); + Tcl_Obj *temp; if (preserve) { state = Tcl_SaveInterpState(dataPtr->interp, res); } @@ -412,12 +408,12 @@ if (res != TCL_OK) { goto cleanup; } /* - * Use a byte-array to prevent the misinterpretation of binary data - * coming through as UTF while at the tcl level. + * Use a byte-array to prevent the misinterpretation of binary data coming + * through as UTF while at the tcl level. */ temp = Tcl_NewByteArrayObj(buf, bufLen); if (temp == (Tcl_Obj*) NULL) { @@ -424,25 +420,25 @@ /* Memory allocation problem */ res = TCL_ERROR; goto cleanup; } - res = Tcl_ListObjAppendElement (dataPtr->interp, command, temp); + res = Tcl_ListObjAppendElement(dataPtr->interp, command, temp); if (res != TCL_OK) { goto cleanup; } /* - * Step 2, execute the command at the global level of the interpreter - * used to create the transformation. Destroy the command afterward. - * If an error occured and the current interpreter is defined and not - * equal to the interpreter for the callback, then copy the error - * message into current interpreter. Don't copy if in preservation mode. + * Step 2, execute the command at the global level of the interpreter used + * to create the transformation. Destroy the command afterward. If an + * error occured and the current interpreter is defined and not equal to + * the interpreter for the callback, then copy the error message into + * current interpreter. Don't copy if in preservation mode. */ - res = Tcl_GlobalEvalObj (dataPtr->interp, command); - Tcl_DecrRefCount (command); + res = Tcl_GlobalEvalObj(dataPtr->interp, command); + Tcl_DecrRefCount(command); command = (Tcl_Obj*) NULL; if ((res != TCL_OK) && (interp != NO_INTERP) && (dataPtr->interp != interp) && !preserve) { Tcl_SetObjResult(interp, Tcl_GetObjResult(dataPtr->interp)); @@ -453,38 +449,38 @@ * Step 3, transmit a possible conversion result to the underlying * channel, or ourselves. */ switch (transmit) { - case TRANSMIT_DONT: - /* nothing to do */ - break; - - case TRANSMIT_DOWN: - resObj = Tcl_GetObjResult(dataPtr->interp); - resBuf = (unsigned char*) Tcl_GetByteArrayFromObj(resObj, &resLen); - Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), - (char*) resBuf, resLen); - break; - - case TRANSMIT_SELF: - resObj = Tcl_GetObjResult (dataPtr->interp); - resBuf = (unsigned char*) Tcl_GetByteArrayFromObj(resObj, &resLen); - Tcl_WriteRaw(dataPtr->self, (char*) resBuf, resLen); - break; - - case TRANSMIT_IBUF: - resObj = Tcl_GetObjResult (dataPtr->interp); - resBuf = (unsigned char*) Tcl_GetByteArrayFromObj(resObj, &resLen); - ResultAdd(&dataPtr->result, resBuf, resLen); - break; - - case TRANSMIT_NUM: - /* Interpret result as integer number */ - resObj = Tcl_GetObjResult (dataPtr->interp); - Tcl_GetIntFromObj(dataPtr->interp, resObj, &dataPtr->maxRead); - break; + case TRANSMIT_DONT: + /* nothing to do */ + break; + + case TRANSMIT_DOWN: + resObj = Tcl_GetObjResult(dataPtr->interp); + resBuf = (unsigned char *) Tcl_GetByteArrayFromObj(resObj, &resLen); + Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), (char *) resBuf, + resLen); + break; + + case TRANSMIT_SELF: + resObj = Tcl_GetObjResult(dataPtr->interp); + resBuf = (unsigned char *) Tcl_GetByteArrayFromObj(resObj, &resLen); + Tcl_WriteRaw(dataPtr->self, (char *) resBuf, resLen); + break; + + case TRANSMIT_IBUF: + resObj = Tcl_GetObjResult(dataPtr->interp); + resBuf = (unsigned char *) Tcl_GetByteArrayFromObj(resObj, &resLen); + ResultAdd(&dataPtr->result, resBuf, resLen); + break; + + case TRANSMIT_NUM: + /* Interpret result as integer number */ + resObj = Tcl_GetObjResult(dataPtr->interp); + Tcl_GetIntFromObj(dataPtr->interp, resObj, &dataPtr->maxRead); + break; } Tcl_ResetResult(dataPtr->interp); if (preserve) { @@ -491,11 +487,11 @@ (void) Tcl_RestoreInterpState(dataPtr->interp, state); } return res; - cleanup: + cleanup: if (preserve) { (void) Tcl_RestoreInterpState(dataPtr->interp, state); } if (command != (Tcl_Obj*) NULL) { @@ -504,34 +500,32 @@ return res; } /* - *------------------------------------------------------* - * - * TransformBlockModeProc -- - * - * Trap handler. Called by the generic IO system - * during option processing to change the blocking - * mode of the channel. - * - * Sideeffects: - * Forwards the request to the underlying - * channel. - * - * Result: - * 0 if successful, errno when failed. - * - *------------------------------------------------------* + *---------------------------------------------------------------------- + * + * TransformBlockModeProc -- + * + * Trap handler. Called by the generic IO system during option processing + * to change the blocking mode of the channel. + * + * Side effects: + * Forwards the request to the underlying channel. + * + * Result: + * 0 if successful, errno when failed. + * + *---------------------------------------------------------------------- */ static int -TransformBlockModeProc (instanceData, mode) - ClientData instanceData; /* State of transformation */ - int mode; /* New blocking mode */ +TransformBlockModeProc(instanceData, mode) + ClientData instanceData; /* State of transformation */ + int mode; /* New blocking mode */ { - TransformChannelData* dataPtr = (TransformChannelData*) instanceData; + TransformChannelData *dataPtr = (TransformChannelData *) instanceData; if (mode == TCL_MODE_NONBLOCKING) { dataPtr->flags |= CHANNEL_ASYNC; } else { dataPtr->flags &= ~(CHANNEL_ASYNC); @@ -538,37 +532,36 @@ } return 0; } /* - *------------------------------------------------------* - * - * TransformCloseProc -- - * - * Trap handler. Called by the generic IO system - * during destruction of the transformation channel. - * - * Sideeffects: - * Releases the memory allocated in - * 'Tcl_TransformObjCmd'. - * - * Result: - * None. - * - *------------------------------------------------------* + *---------------------------------------------------------------------- + * + * TransformCloseProc -- + * + * Trap handler. Called by the generic IO system during destruction of + * the transformation channel. + * + * Side effects: + * Releases the memory allocated in 'Tcl_TransformObjCmd'. + * + * Result: + * None. + * + *---------------------------------------------------------------------- */ static int -TransformCloseProc (instanceData, interp) - ClientData instanceData; - Tcl_Interp* interp; +TransformCloseProc(instanceData, interp) + ClientData instanceData; + Tcl_Interp *interp; { - TransformChannelData* dataPtr = (TransformChannelData*) instanceData; + TransformChannelData *dataPtr = (TransformChannelData *) instanceData; /* - * Important: In this procedure 'dataPtr->self' already points to - * the underlying channel. + * Important: In this procedure 'dataPtr->self' already points to the + * underlying channel. */ /* * There is no need to cancel an existing channel handler, this is already * done. Either by 'Tcl_UnstackChannel' or by the general cleanup in @@ -577,84 +570,85 @@ * But we have to cancel an active timer to prevent it from firing on the * removed channel. */ if (dataPtr->timer != (Tcl_TimerToken) NULL) { - Tcl_DeleteTimerHandler (dataPtr->timer); + Tcl_DeleteTimerHandler(dataPtr->timer); dataPtr->timer = (Tcl_TimerToken) NULL; } /* * Now flush data waiting in internal buffers to output and input. The - * input must be done despite the fact that there is no real receiver - * for it anymore. But the scripts might have sideeffects other parts - * of the system rely on (f.e. signaling the close to interested parties). + * input must be done despite the fact that there is no real receiver for + * it anymore. But the scripts might have sideeffects other parts of the + * system rely on (f.e. signaling the close to interested parties). */ if (dataPtr->mode & TCL_WRITABLE) { - ExecuteCallback (dataPtr, interp, A_FLUSH_WRITE, - NULL, 0, TRANSMIT_DOWN, 1); + ExecuteCallback(dataPtr, interp, A_FLUSH_WRITE, NULL, 0, + TRANSMIT_DOWN, 1); } if ((dataPtr->mode & TCL_READABLE) && !dataPtr->readIsFlushed) { dataPtr->readIsFlushed = 1; - ExecuteCallback (dataPtr, interp, A_FLUSH_READ, - NULL, 0, TRANSMIT_IBUF, 1); + ExecuteCallback(dataPtr, interp, A_FLUSH_READ, NULL, 0, + TRANSMIT_IBUF, 1); } if (dataPtr->mode & TCL_WRITABLE) { - ExecuteCallback (dataPtr, interp, A_DELETE_WRITE, - NULL, 0, TRANSMIT_DONT, 1); + ExecuteCallback(dataPtr, interp, A_DELETE_WRITE, NULL, 0, + TRANSMIT_DONT, 1); } if (dataPtr->mode & TCL_READABLE) { - ExecuteCallback (dataPtr, interp, A_DELETE_READ, - NULL, 0, TRANSMIT_DONT, 1); + ExecuteCallback(dataPtr, interp, A_DELETE_READ, NULL, 0, + TRANSMIT_DONT, 1); } /* * General cleanup */ ResultClear(&dataPtr->result); Tcl_DecrRefCount(dataPtr->command); - ckfree((VOID*) dataPtr); + ckfree((char *) dataPtr); return TCL_OK; } /* - *------------------------------------------------------* + *---------------------------------------------------------------------- * - * TransformInputProc -- + * TransformInputProc -- * * Called by the generic IO system to convert read data. * - * Sideeffects: - * As defined by the conversion. + * Side effects: + * As defined by the conversion. * - * Result: - * A transformed buffer. + * Result: + * A transformed buffer. * - *------------------------------------------------------* + *---------------------------------------------------------------------- */ static int -TransformInputProc (instanceData, buf, toRead, errorCodePtr) +TransformInputProc(instanceData, buf, toRead, errorCodePtr) ClientData instanceData; - char* buf; - int toRead; - int* errorCodePtr; + char *buf; + int toRead; + int *errorCodePtr; { - TransformChannelData* dataPtr = (TransformChannelData*) instanceData; + TransformChannelData* dataPtr = (TransformChannelData *) instanceData; int gotBytes, read, res, copied; Tcl_Channel downChan; /* should assert (dataPtr->mode & TCL_READABLE) */ if (toRead == 0) { - /* Catch a no-op. + /* + * Catch a no-op. */ return 0; } gotBytes = 0; @@ -664,37 +658,38 @@ /* * Loop until the request is satisfied (or no data is available from * below, possibly EOF). */ - copied = ResultCopy (&dataPtr->result, UCHARP (buf), toRead); + copied = ResultCopy(&dataPtr->result, UCHARP(buf), toRead); - toRead -= copied; - buf += copied; + toRead -= copied; + buf += copied; gotBytes += copied; if (toRead == 0) { - /* The request was completely satisfied from our buffers. - * We can break out of the loop and return to the caller. + /* + * The request was completely satisfied from our buffers. We can + * break out of the loop and return to the caller. */ return gotBytes; } /* - * Length (dataPtr->result) == 0, toRead > 0 here . Use the incoming - * 'buf'! as target to store the intermediary information read - * from the underlying channel. - * - * Ask the tcl level how much data it allows us to read from - * the underlying channel. This feature allows the transform to - * signal EOF upstream although there is none downstream. Useful - * to control an unbounded 'fcopy', either through counting bytes, - * or by pattern matching. - */ - - ExecuteCallback (dataPtr, NO_INTERP, A_QUERY_MAXREAD, - NULL, 0, TRANSMIT_NUM /* -> maxRead */, 1); + * Length (dataPtr->result) == 0, toRead > 0 here. Use the incoming + * 'buf'! as target to store the intermediary information read from + * the underlying channel. + * + * Ask the tcl level how much data it allows us to read from the + * underlying channel. This feature allows the transform to signal EOF + * upstream although there is none downstream. Useful to control an + * unbounded 'fcopy', either through counting bytes, or by pattern + * matching. + */ + + ExecuteCallback(dataPtr, NO_INTERP, A_QUERY_MAXREAD, NULL, 0, + TRANSMIT_NUM /* -> maxRead */, 1); if (dataPtr->maxRead >= 0) { if (dataPtr->maxRead < toRead) { toRead = dataPtr->maxRead; } @@ -705,13 +700,14 @@ } read = Tcl_ReadRaw(downChan, buf, toRead); if (read < 0) { - /* Report errors to caller. EAGAIN is a special situation. - * If we had some data before we report that instead of the - * request to re-try. + /* + * Report errors to caller. EAGAIN is a special situation. If we + * had some data before we report that instead of the request to + * re-try. */ if ((Tcl_GetErrno() == EAGAIN) && (gotBytes > 0)) { return gotBytes; } @@ -720,54 +716,55 @@ return -1; } if (read == 0) { /* - * Check wether we hit on EOF in the underlying channel or - * not. If not differentiate between blocking and - * non-blocking modes. In non-blocking mode we ran - * temporarily out of data. Signal this to the caller via - * EWOULDBLOCK and error return (-1). In the other cases - * we simply return what we got and let the caller wait - * for more. On the other hand, if we got an EOF we have - * to convert and flush all waiting partial data. + * Check wether we hit on EOF in the underlying channel or not. If + * not differentiate between blocking and non-blocking modes. In + * non-blocking mode we ran temporarily out of data. Signal this + * to the caller via EWOULDBLOCK and error return (-1). In the + * other cases we simply return what we got and let the caller + * wait for more. On the other hand, if we got an EOF we have to + * convert and flush all waiting partial data. */ - if (! Tcl_Eof (downChan)) { + if (! Tcl_Eof(downChan)) { if ((gotBytes == 0) && (dataPtr->flags & CHANNEL_ASYNC)) { *errorCodePtr = EWOULDBLOCK; return -1; } else { return gotBytes; } } else { if (dataPtr->readIsFlushed) { - /* Already flushed, nothing to do anymore + /* + * Already flushed, nothing to do anymore. */ return gotBytes; } dataPtr->readIsFlushed = 1; - ExecuteCallback (dataPtr, NO_INTERP, A_FLUSH_READ, - NULL, 0, TRANSMIT_IBUF, P_PRESERVE); + ExecuteCallback(dataPtr, NO_INTERP, A_FLUSH_READ, NULL, 0, + TRANSMIT_IBUF, P_PRESERVE); - if (ResultLength (&dataPtr->result) == 0) { + if (ResultLength(&dataPtr->result) == 0) { /* we had nothing to flush */ return gotBytes; } continue; /* at: while (toRead > 0) */ } } /* read == 0 */ - /* Transform the read chunk and add the result to our - * read buffer (dataPtr->result) + /* + * Transform the read chunk and add the result to our read buffer + * (dataPtr->result) */ - res = ExecuteCallback (dataPtr, NO_INTERP, A_READ, - UCHARP (buf), read, TRANSMIT_IBUF, P_PRESERVE); + res = ExecuteCallback(dataPtr, NO_INTERP, A_READ, UCHARP(buf), read, + TRANSMIT_IBUF, P_PRESERVE); if (res != TCL_OK) { *errorCodePtr = EINVAL; return -1; } @@ -775,46 +772,45 @@ return gotBytes; } /* - *------------------------------------------------------* - * - * TransformOutputProc -- - * - * Called by the generic IO system to convert data - * waiting to be written. - * - * Sideeffects: - * As defined by the transformation. - * - * Result: - * A transformed buffer. - * - *------------------------------------------------------* + *---------------------------------------------------------------------- + * + * TransformOutputProc -- + * + * Called by the generic IO system to convert data waiting to be written. + * + * Side effects: + * As defined by the transformation. + * + * Result: + * A transformed buffer. + * + *---------------------------------------------------------------------- */ static int -TransformOutputProc (instanceData, buf, toWrite, errorCodePtr) +TransformOutputProc(instanceData, buf, toWrite, errorCodePtr) ClientData instanceData; - CONST char* buf; - int toWrite; - int* errorCodePtr; + CONST char *buf; + int toWrite; + int *errorCodePtr; { TransformChannelData* dataPtr = (TransformChannelData*) instanceData; int res; /* should assert (dataPtr->mode & TCL_WRITABLE) */ if (toWrite == 0) { - /* Catch a no-op. + /* + * Catch a no-op. */ return 0; } - res = ExecuteCallback (dataPtr, NO_INTERP, A_WRITE, - UCHARP (buf), toWrite, + res = ExecuteCallback(dataPtr, NO_INTERP, A_WRITE, UCHARP(buf), toWrite, TRANSMIT_DOWN, P_NO_PRESERVE); if (res != TCL_OK) { *errorCodePtr = EINVAL; return -1; @@ -822,67 +818,65 @@ return toWrite; } /* - *------------------------------------------------------* - * - * TransformSeekProc -- - * - * This procedure is called by the generic IO level - * to move the access point in a channel. - * - * Sideeffects: - * Moves the location at which the channel - * will be accessed in future operations. - * Flushes all transformation buffers, then - * forwards it to the underlying channel. - * - * Result: - * -1 if failed, the new position if - * successful. An output argument contains - * the POSIX error code if an error - * occurred, or zero. - * - *------------------------------------------------------* + *---------------------------------------------------------------------- + * + * TransformSeekProc -- + * + * This procedure is called by the generic IO level to move the access + * point in a channel. + * + * Side effects: + * Moves the location at which the channel will be accessed in future + * operations. Flushes all transformation buffers, then forwards it to + * the underlying channel. + * + * Result: + * -1 if failed, the new position if successful. An output argument + * contains the POSIX error code if an error occurred, or zero. + * + *---------------------------------------------------------------------- */ static int -TransformSeekProc (instanceData, offset, mode, errorCodePtr) - ClientData instanceData; /* The channel to manipulate */ - long offset; /* Size of movement. */ - int mode; /* How to move */ - int* errorCodePtr; /* Location of error flag. */ -{ - TransformChannelData* dataPtr = (TransformChannelData*) instanceData; - Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self); - Tcl_ChannelType* parentType = Tcl_GetChannelType(parent); - Tcl_DriverSeekProc* parentSeekProc = Tcl_ChannelSeekProc(parentType); +TransformSeekProc(instanceData, offset, mode, errorCodePtr) + ClientData instanceData; /* The channel to manipulate */ + long offset; /* Size of movement. */ + int mode; /* How to move */ + int *errorCodePtr; /* Location of error flag. */ +{ + TransformChannelData *dataPtr = (TransformChannelData *) instanceData; + Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self); + Tcl_ChannelType *parentType = Tcl_GetChannelType(parent); + Tcl_DriverSeekProc *parentSeekProc = Tcl_ChannelSeekProc(parentType); if ((offset == 0) && (mode == SEEK_CUR)) { - /* This is no seek but a request to tell the caller the current + /* + * This is no seek but a request to tell the caller the current * location. Simply pass the request down. */ return (*parentSeekProc) (Tcl_GetChannelInstanceData(parent), offset, mode, errorCodePtr); } /* - * It is a real request to change the position. Flush all data waiting - * for output and discard everything in the input buffers. Then pass - * the request down, unchanged. + * It is a real request to change the position. Flush all data waiting for + * output and discard everything in the input buffers. Then pass the + * request down, unchanged. */ if (dataPtr->mode & TCL_WRITABLE) { - ExecuteCallback (dataPtr, NO_INTERP, A_FLUSH_WRITE, - NULL, 0, TRANSMIT_DOWN, P_NO_PRESERVE); + ExecuteCallback(dataPtr, NO_INTERP, A_FLUSH_WRITE, NULL, 0, + TRANSMIT_DOWN, P_NO_PRESERVE); } if (dataPtr->mode & TCL_READABLE) { - ExecuteCallback (dataPtr, NO_INTERP, A_CLEAR_READ, - NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE); + ExecuteCallback(dataPtr, NO_INTERP, A_CLEAR_READ, NULL, 0, + TRANSMIT_DONT, P_NO_PRESERVE); ResultClear(&dataPtr->result); dataPtr->readIsFlushed = 0; } return (*parentSeekProc) (Tcl_GetChannelInstanceData(parent), @@ -892,45 +886,39 @@ /* *---------------------------------------------------------------------- * * TransformWideSeekProc -- * - * This procedure is called by the generic IO level to move the - * access point in a channel, with a (potentially) 64-bit offset. + * This procedure is called by the generic IO level to move the access + * point in a channel, with a (potentially) 64-bit offset. * * Side effects: - * Moves the location at which the channel will be accessed in - * future operations. Flushes all transformation buffers, then - * forwards it to the underlying channel. + * Moves the location at which the channel will be accessed in future + * operations. Flushes all transformation buffers, then forwards it to + * the underlying channel. * * Result: - * -1 if failed, the new position if successful. An output - * argument contains the POSIX error code if an error occurred, - * or zero. + * -1 if failed, the new position if successful. An output argument + * contains the POSIX error code if an error occurred, or zero. * *---------------------------------------------------------------------- */ static Tcl_WideInt -TransformWideSeekProc (instanceData, offset, mode, errorCodePtr) - ClientData instanceData; /* The channel to manipulate */ +TransformWideSeekProc(instanceData, offset, mode, errorCodePtr) + ClientData instanceData; /* The channel to manipulate */ Tcl_WideInt offset; /* Size of movement. */ - int mode; /* How to move */ - int* errorCodePtr; /* Location of error flag. */ -{ - TransformChannelData* dataPtr = - (TransformChannelData*) instanceData; - Tcl_Channel parent = - Tcl_GetStackedChannel(dataPtr->self); - Tcl_ChannelType* parentType = - Tcl_GetChannelType(parent); - Tcl_DriverSeekProc* parentSeekProc = - Tcl_ChannelSeekProc(parentType); + int mode; /* How to move */ + int *errorCodePtr; /* Location of error flag. */ +{ + TransformChannelData * dataPtr = (TransformChannelData *) instanceData; + Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self); + Tcl_ChannelType* parentType = Tcl_GetChannelType(parent); + Tcl_DriverSeekProc* parentSeekProc = Tcl_ChannelSeekProc(parentType); Tcl_DriverWideSeekProc* parentWideSeekProc = - Tcl_ChannelWideSeekProc(parentType); - ClientData parentData = - Tcl_GetChannelInstanceData(parent); + Tcl_ChannelWideSeekProc(parentType); + ClientData parentData = Tcl_GetChannelInstanceData(parent); if ((offset == Tcl_LongAsWide(0)) && (mode == SEEK_CUR)) { /* * This is no seek but a request to tell the caller the current * location. Simply pass the request down. @@ -944,70 +932,72 @@ return Tcl_LongAsWide((*parentSeekProc) (parentData, 0, mode, errorCodePtr)); } /* - * It is a real request to change the position. Flush all data waiting - * for output and discard everything in the input buffers. Then pass - * the request down, unchanged. + * It is a real request to change the position. Flush all data waiting for + * output and discard everything in the input buffers. Then pass the + * request down, unchanged. */ if (dataPtr->mode & TCL_WRITABLE) { - ExecuteCallback (dataPtr, NO_INTERP, A_FLUSH_WRITE, - NULL, 0, TRANSMIT_DOWN, P_NO_PRESERVE); + ExecuteCallback(dataPtr, NO_INTERP, A_FLUSH_WRITE, NULL, 0, + TRANSMIT_DOWN, P_NO_PRESERVE); } if (dataPtr->mode & TCL_READABLE) { - ExecuteCallback (dataPtr, NO_INTERP, A_CLEAR_READ, - NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE); + ExecuteCallback(dataPtr, NO_INTERP, A_CLEAR_READ, NULL, 0, + TRANSMIT_DONT, P_NO_PRESERVE); ResultClear(&dataPtr->result); dataPtr->readIsFlushed = 0; } /* * If we have a wide seek capability, we should stick with that. */ + if (parentWideSeekProc != NULL) { return (*parentWideSeekProc) (parentData, offset, mode, errorCodePtr); } /* - * We're transferring to narrow seeks at this point; this is a bit - * complex because we have to check whether the seek is possible - * first (i.e. whether we are losing information in truncating the - * bits of the offset.) Luckily, there's a defined error for what - * happens when trying to go out of the representable range. + * We're transferring to narrow seeks at this point; this is a bit complex + * because we have to check whether the seek is possible first (i.e. + * whether we are losing information in truncating the bits of the + * offset.) Luckily, there's a defined error for what happens when trying + * to go out of the representable range. */ + if (offsetTcl_LongAsWide(LONG_MAX)) { *errorCodePtr = EOVERFLOW; return Tcl_LongAsWide(-1); } + return Tcl_LongAsWide((*parentSeekProc) (parentData, Tcl_WideAsLong(offset), mode, errorCodePtr)); } /* - *------------------------------------------------------* - * - * TransformSetOptionProc -- - * - * Called by generic layer to handle the reconfi- - * guration of channel specific options. As this - * channel type does not have such, it simply passes - * all requests downstream. - * - * Sideeffects: - * As defined by the channel downstream. - * - * Result: - * A standard TCL error code. - * - *------------------------------------------------------* + *---------------------------------------------------------------------- + * + * TransformSetOptionProc -- + * + * Called by generic layer to handle the reconfiguration of channel + * specific options. As this channel type does not have such, it simply + * passes all requests downstream. + * + * Side effects: + * As defined by the channel downstream. + * + * Result: + * A standard TCL error code. + * + *---------------------------------------------------------------------- */ static int -TransformSetOptionProc (instanceData, interp, optionName, value) +TransformSetOptionProc(instanceData, interp, optionName, value) ClientData instanceData; Tcl_Interp *interp; CONST char *optionName; CONST char *value; { @@ -1022,34 +1012,33 @@ } return TCL_ERROR; } /* - *------------------------------------------------------* - * - * TransformGetOptionProc -- - * - * Called by generic layer to handle requests for - * the values of channel specific options. As this - * channel type does not have such, it simply passes - * all requests downstream. - * - * Sideeffects: - * As defined by the channel downstream. - * - * Result: - * A standard TCL error code. - * - *------------------------------------------------------* + *---------------------------------------------------------------------- + * + * TransformGetOptionProc -- + * + * Called by generic layer to handle requests for the values of channel + * specific options. As this channel type does not have such, it simply + * passes all requests downstream. + * + * Side effects: + * As defined by the channel downstream. + * + * Result: + * A standard TCL error code. + * + *---------------------------------------------------------------------- */ static int -TransformGetOptionProc (instanceData, interp, optionName, dsPtr) - ClientData instanceData; - Tcl_Interp* interp; - CONST char* optionName; - Tcl_DString* dsPtr; +TransformGetOptionProc(instanceData, interp, optionName, dsPtr) + ClientData instanceData; + Tcl_Interp *interp; + CONST char *optionName; + Tcl_DString *dsPtr; { TransformChannelData* dataPtr = (TransformChannelData*) instanceData; Tcl_Channel downChan = Tcl_GetStackedChannel(dataPtr->self); Tcl_DriverGetOptionProc *getOptionProc; @@ -1059,394 +1048,404 @@ interp, optionName, dsPtr); } else if (optionName == (CONST char*) NULL) { /* * Request is query for all options, this is ok. */ + return TCL_OK; } + /* * Request for a specific option has to fail, we don't have any. */ + return TCL_ERROR; } /* - *------------------------------------------------------* - * - * TransformWatchProc -- - * - * Initialize the notifier to watch for events from - * this channel. - * - * Sideeffects: - * Sets up the notifier so that a future - * event on the channel will be seen by Tcl. - * - * Result: - * None. - * - *------------------------------------------------------* + *---------------------------------------------------------------------- + * + * TransformWatchProc -- + * + * Initialize the notifier to watch for events from this channel. + * + * Side effects: + * Sets up the notifier so that a future event on the channel will be + * seen by Tcl. + * + * Result: + * None. + * + *---------------------------------------------------------------------- */ + /* ARGSUSED */ static void -TransformWatchProc (instanceData, mask) +TransformWatchProc(instanceData, mask) ClientData instanceData; /* Channel to watch */ - int mask; /* Events of interest */ + int mask; /* Events of interest */ { - /* The caller expressed interest in events occuring for this - * channel. We are forwarding the call to the underlying - * channel now. + /* + * The caller expressed interest in events occuring for this channel. We + * are forwarding the call to the underlying channel now. */ - TransformChannelData* dataPtr = (TransformChannelData*) instanceData; - Tcl_Channel downChan; + TransformChannelData *dataPtr = (TransformChannelData *) instanceData; + Tcl_Channel downChan; dataPtr->watchMask = mask; - /* No channel handlers any more. We will be notified automatically - * about events on the channel below via a call to our - * 'TransformNotifyProc'. But we have to pass the interest down now. - * We are allowed to add additional 'interest' to the mask if we want - * to. But this transformation has no such interest. It just passes - * the request down, unchanged. + /* + * No channel handlers any more. We will be notified automatically about + * events on the channel below via a call to our 'TransformNotifyProc'. + * But we have to pass the interest down now. We are allowed to add + * additional 'interest' to the mask if we want to. But this + * transformation has no such interest. It just passes the request down, + * unchanged. */ downChan = Tcl_GetStackedChannel(dataPtr->self); - (Tcl_GetChannelType(downChan)) - ->watchProc(Tcl_GetChannelInstanceData(downChan), mask); + Tcl_GetChannelType(downChan)->watchProc( + Tcl_GetChannelInstanceData(downChan), mask); /* * Management of the internal timer. */ if ((dataPtr->timer != (Tcl_TimerToken) NULL) && - (!(mask & TCL_READABLE) || (ResultLength(&dataPtr->result) == 0))) { - - /* A pending timer exists, but either is there no (more) - * interest in the events it generates or nothing is availablee - * for reading, so remove it. + (!(mask & TCL_READABLE) || ResultLength(&dataPtr->result)==0)) { + /* + * A pending timer exists, but either is there no (more) interest in + * the events it generates or nothing is availablee for reading, so + * remove it. */ - Tcl_DeleteTimerHandler (dataPtr->timer); + Tcl_DeleteTimerHandler(dataPtr->timer); dataPtr->timer = (Tcl_TimerToken) NULL; } if ((dataPtr->timer == (Tcl_TimerToken) NULL) && - (mask & TCL_READABLE) && (ResultLength (&dataPtr->result) > 0)) { - - /* There is no pending timer, but there is interest in readable - * events and we actually have data waiting, so generate a timer - * to flush that. + (mask & TCL_READABLE) && (ResultLength(&dataPtr->result) > 0)) { + /* + * There is no pending timer, but there is interest in readable events + * and we actually have data waiting, so generate a timer to flush + * that. */ - dataPtr->timer = Tcl_CreateTimerHandler (FLUSH_DELAY, + dataPtr->timer = Tcl_CreateTimerHandler(FLUSH_DELAY, TransformChannelHandlerTimer, (ClientData) dataPtr); } } /* - *------------------------------------------------------* - * - * TransformGetFileHandleProc -- - * - * Called from Tcl_GetChannelHandle to retrieve - * OS specific file handle from inside this channel. - * - * Sideeffects: - * None. - * - * Result: - * The appropriate Tcl_File or NULL if not - * present. - * - *------------------------------------------------------* + *---------------------------------------------------------------------- + * + * TransformGetFileHandleProc -- + * + * Called from Tcl_GetChannelHandle to retrieve OS specific file handle + * from inside this channel. + * + * Side effects: + * None. + * + * Result: + * The appropriate Tcl_File or NULL if not present. + * + *---------------------------------------------------------------------- */ + static int -TransformGetFileHandleProc (instanceData, direction, handlePtr) - ClientData instanceData; /* Channel to query */ - int direction; /* Direction of interest */ - ClientData* handlePtr; /* Place to store the handle into */ +TransformGetFileHandleProc(instanceData, direction, handlePtr) + ClientData instanceData; /* Channel to query */ + int direction; /* Direction of interest */ + ClientData *handlePtr; /* Place to store the handle into */ { /* - * Return the handle belonging to parent channel. - * IOW, pass the request down and the result up. + * Return the handle belonging to parent channel. IOW, pass the request + * down and the result up. */ - TransformChannelData* dataPtr = (TransformChannelData*) instanceData; + TransformChannelData *dataPtr = (TransformChannelData *) instanceData; return Tcl_GetChannelHandle(Tcl_GetStackedChannel(dataPtr->self), direction, handlePtr); } /* - *------------------------------------------------------* - * - * TransformNotifyProc -- - * - * ------------------------------------------------* - * Handler called by Tcl to inform us of activity - * on the underlying channel. - * ------------------------------------------------* - * - * Sideeffects: - * May process the incoming event by itself. - * - * Result: - * None. - * - *------------------------------------------------------* + *---------------------------------------------------------------------- + * + * TransformNotifyProc -- + * + * Handler called by Tcl to inform us of activity on the underlying + * channel. + * + * Side effects: + * May process the incoming event by itself. + * + * Result: + * None. + * + *---------------------------------------------------------------------- */ static int -TransformNotifyProc (clientData, mask) - ClientData clientData; /* The state of the notified transformation */ - int mask; /* The mask of occuring events */ +TransformNotifyProc(clientData, mask) + ClientData clientData; /* The state of the notified transformation */ + int mask; /* The mask of occuring events */ { - TransformChannelData* dataPtr = (TransformChannelData*) clientData; + TransformChannelData *dataPtr = (TransformChannelData *) clientData; /* - * An event occured in the underlying channel. This - * transformation doesn't process such events thus returns the - * incoming mask unchanged. + * An event occured in the underlying channel. This transformation + * doesn't process such events thus returns the incoming mask unchanged. */ if (dataPtr->timer != (Tcl_TimerToken) NULL) { /* - * Delete an existing timer. It was not fired, yet we are - * here, so the channel below generated such an event and we - * don't have to. The renewal of the interest after the - * execution of channel handlers will eventually cause us to - * recreate the timer (in TransformWatchProc). + * Delete an existing timer. It was not fired, yet we are here, so the + * channel below generated such an event and we don't have to. The + * renewal of the interest after the execution of channel handlers + * will eventually cause us to recreate the timer (in + * TransformWatchProc). */ - Tcl_DeleteTimerHandler (dataPtr->timer); + Tcl_DeleteTimerHandler(dataPtr->timer); dataPtr->timer = (Tcl_TimerToken) NULL; } return mask; } /* - *------------------------------------------------------* - * - * TransformChannelHandlerTimer -- - * - * Called by the notifier (-> timer) to flush out - * information waiting in the input buffer. - * - * Sideeffects: - * As of 'Tcl_NotifyChannel'. - * - * Result: - * None. - * - *------------------------------------------------------* + *---------------------------------------------------------------------- + * + * TransformChannelHandlerTimer -- + * + * Called by the notifier (-> timer) to flush out information waiting in + * the input buffer. + * + * Side effects: + * As of 'Tcl_NotifyChannel'. + * + * Result: + * None. + * + *---------------------------------------------------------------------- */ static void -TransformChannelHandlerTimer (clientData) - ClientData clientData; /* Transformation to query */ +TransformChannelHandlerTimer(clientData) + ClientData clientData; /* Transformation to query */ { - TransformChannelData* dataPtr = (TransformChannelData*) clientData; + TransformChannelData *dataPtr = (TransformChannelData *) clientData; dataPtr->timer = (Tcl_TimerToken) NULL; if (!(dataPtr->watchMask & TCL_READABLE) || - (ResultLength (&dataPtr->result) == 0)) { - /* The timer fired, but either is there no (more) - * interest in the events it generates or nothing is available - * for reading, so ignore it and don't recreate it. + (ResultLength(&dataPtr->result) == 0)) { + /* + * The timer fired, but either is there no (more) interest in the + * events it generates or nothing is available for reading, so ignore + * it and don't recreate it. */ return; } Tcl_NotifyChannel(dataPtr->self, TCL_READABLE); } /* - *------------------------------------------------------* - * - * ResultClear -- - * - * Deallocates any memory allocated by 'ResultAdd'. - * - * Sideeffects: - * See above. - * - * Result: - * None. - * - *------------------------------------------------------* - */ - -static void -ResultClear (r) - ResultBuffer* r; /* Reference to the buffer to clear out */ -{ - r->used = 0; - - if (r->allocated) { - ckfree((char*) r->buf); - r->buf = UCHARP (NULL); - r->allocated = 0; - } -} - -/* - *------------------------------------------------------* - * - * ResultInit -- - * - * Initializes the specified buffer structure. The - * structure will contain valid information for an - * emtpy buffer. - * - * Sideeffects: - * See above. - * - * Result: - * None. - * - *------------------------------------------------------* - */ - -static void -ResultInit (r) - ResultBuffer* r; /* Reference to the structure to initialize */ -{ - r->used = 0; - r->allocated = 0; - r->buf = UCHARP (NULL); -} - -/* - *------------------------------------------------------* - * - * ResultLength -- - * - * Returns the number of bytes stored in the buffer. - * - * Sideeffects: - * None. - * - * Result: - * An integer, see above too. - * - *------------------------------------------------------* - */ - -static int -ResultLength (r) - ResultBuffer* r; /* The structure to query */ + *---------------------------------------------------------------------- + * + * ResultClear -- + * + * Deallocates any memory allocated by 'ResultAdd'. + * + * Side effects: + * See above. + * + * Result: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +ResultClear(r) + ResultBuffer *r; /* Reference to the buffer to clear out. */ +{ + r->used = 0; + + if (r->allocated) { + ckfree((char *) r->buf); + r->buf = UCHARP(NULL); + r->allocated = 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * ResultInit -- + * + * Initializes the specified buffer structure. The structure will contain + * valid information for an emtpy buffer. + * + * Side effects: + * See above. + * + * Result: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +ResultInit(r) + ResultBuffer *r; /* Reference to the structure to initialize */ +{ + r->used = 0; + r->allocated = 0; + r->buf = UCHARP(NULL); +} + +/* + *---------------------------------------------------------------------- + * + * ResultLength -- + * + * Returns the number of bytes stored in the buffer. + * + * Side effects: + * None. + * + * Result: + * An integer, see above too. + * + *---------------------------------------------------------------------- + */ + +static int +ResultLength(r) + ResultBuffer *r; /* The structure to query */ { return r->used; } /* - *------------------------------------------------------* - * - * ResultCopy -- - * - * Copies the requested number of bytes from the - * buffer into the specified array and removes them - * from the buffer afterward. Copies less if there - * is not enough data in the buffer. - * - * Sideeffects: - * See above. - * - * Result: - * The number of actually copied bytes, - * possibly less than 'toRead'. - * - *------------------------------------------------------* + *---------------------------------------------------------------------- + * + * ResultCopy -- + * + * Copies the requested number of bytes from the buffer into the + * specified array and removes them from the buffer afterward. Copies + * less if there is not enough data in the buffer. + * + * Side effects: + * See above. + * + * Result: + * The number of actually copied bytes, possibly less than 'toRead'. + * + *---------------------------------------------------------------------- */ static int -ResultCopy (r, buf, toRead) - ResultBuffer* r; /* The buffer to read from */ - unsigned char* buf; /* The buffer to copy into */ - int toRead; /* Number of requested bytes */ +ResultCopy(r, buf, toRead) + ResultBuffer *r; /* The buffer to read from. */ + unsigned char *buf; /* The buffer to copy into. */ + int toRead; /* Number of requested bytes. */ { if (r->used == 0) { - /* Nothing to copy in the case of an empty buffer. + /* + * Nothing to copy in the case of an empty buffer. */ return 0; } if (r->used == toRead) { - /* We have just enough. Copy everything to the caller. + /* + * We have just enough. Copy everything to the caller. */ - memcpy ((VOID*) buf, (VOID*) r->buf, (size_t) toRead); + memcpy((VOID *) buf, (VOID *) r->buf, (size_t) toRead); r->used = 0; return toRead; } if (r->used > toRead) { - /* The internal buffer contains more than requested. - * Copy the requested subset to the caller, and shift - * the remaining bytes down. + /* + * The internal buffer contains more than requested. Copy the + * requested subset to the caller, and shift the remaining bytes down. */ - memcpy ((VOID*) buf, (VOID*) r->buf, (size_t) toRead); - memmove ((VOID*) r->buf, (VOID*) (r->buf + toRead), + memcpy((VOID *) buf, (VOID *) r->buf, (size_t) toRead); + memmove((VOID *) r->buf, (VOID *) (r->buf + toRead), (size_t) r->used - toRead); r->used -= toRead; return toRead; } - /* There is not enough in the buffer to satisfy the caller, so - * take everything. + /* + * There is not enough in the buffer to satisfy the caller, so take + * everything. */ - memcpy((VOID*) buf, (VOID*) r->buf, (size_t) r->used); + memcpy((VOID *) buf, (VOID *) r->buf, (size_t) r->used); toRead = r->used; r->used = 0; return toRead; } /* - *------------------------------------------------------* - * - * ResultAdd -- - * - * Adds the bytes in the specified array to the - * buffer, by appending it. - * - * Sideeffects: - * See above. - * - * Result: - * None. - * - *------------------------------------------------------* + *---------------------------------------------------------------------- + * + * ResultAdd -- + * + * Adds the bytes in the specified array to the buffer, by appending it. + * + * Side effects: + * See above. + * + * Result: + * None. + * + *---------------------------------------------------------------------- */ static void -ResultAdd (r, buf, toWrite) - ResultBuffer* r; /* The buffer to extend */ - unsigned char* buf; /* The buffer to read from */ - int toWrite; /* The number of bytes in 'buf' */ +ResultAdd(r, buf, toWrite) + ResultBuffer *r; /* The buffer to extend */ + unsigned char *buf; /* The buffer to read from */ + int toWrite; /* The number of bytes in 'buf' */ { if ((r->used + toWrite) > r->allocated) { - /* Extension of the internal buffer is required. + /* + * Extension of the internal buffer is required. */ if (r->allocated == 0) { r->allocated = toWrite + INCREMENT; - r->buf = UCHARP (ckalloc((unsigned) r->allocated)); + r->buf = UCHARP(ckalloc((unsigned) r->allocated)); } else { r->allocated += toWrite + INCREMENT; - r->buf = UCHARP (ckrealloc((char*) r->buf, + r->buf = UCHARP(ckrealloc((char *) r->buf, (unsigned) r->allocated)); } } /* now copy data */ memcpy(r->buf + r->used, buf, (size_t) toWrite); r->used += toWrite; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ ADDED generic/tclIORChan.c Index: generic/tclIORChan.c ================================================================== --- /dev/null +++ generic/tclIORChan.c @@ -0,0 +1,2660 @@ +/* + * tclIORChan.c -- + * + * This file contains the implementation of Tcl's generic + * channel reflection code, which allows the implementation + * of Tcl channels in Tcl code. + * + * Parts of this file are based on code contributed by + * Jean-Claude Wippler. + * + * See TIP #219 for the specification of this functionality. + * + * Copyright (c) 2004-2005 ActiveState, a divison of Sophos + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclIORChan.c,v 1.1.2.6 2005/10/08 13:44:37 dgp Exp $ + */ + +#include +#include +#include + +#ifndef EINVAL +#define EINVAL 9 +#endif +#ifndef EOK +#define EOK 0 +#endif + +/* + * Signatures of all functions used in the C layer of the reflection. + */ + +/* Required */ +static int RcClose _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); + +/* Required, "read" is optional despite this. */ +static int RcInput _ANSI_ARGS_((ClientData clientData, + char *buf, int toRead, int *errorCodePtr)); + +/* Required, "write" is optional despite this. */ +static int RcOutput _ANSI_ARGS_((ClientData clientData, + CONST char *buf, int toWrite, int *errorCodePtr)); + +/* Required */ +static void RcWatch _ANSI_ARGS_((ClientData clientData, int mask)); + +/* NULL'able - "blocking", is optional */ +static int RcBlock _ANSI_ARGS_((ClientData clientData, + int mode)); + +/* NULL'able - "seek", is optional */ +static Tcl_WideInt RcSeekWide _ANSI_ARGS_((ClientData clientData, + Tcl_WideInt offset, + int mode, int *errorCodePtr)); + +static int RcSeek _ANSI_ARGS_((ClientData clientData, + long offset, int mode, int *errorCodePtr)); + +/* NULL'able - "cget" / "cgetall", are optional */ +static int RcGetOption _ANSI_ARGS_((ClientData clientData, + Tcl_Interp* interp, + CONST char *optionName, + Tcl_DString *dsPtr)); + +/* NULL'able - "configure", is optional */ +static int RcSetOption _ANSI_ARGS_((ClientData clientData, + Tcl_Interp* interp, + CONST char *optionName, + CONST char *newValue)); + + +/* + * The C layer channel type/driver definition used by the reflection. + * This is a version 3 structure. + */ + +static Tcl_ChannelType tclRChannelType = { + "tclrchannel", /* Type name. */ + TCL_CHANNEL_VERSION_3, + RcClose, /* Close channel, clean instance data */ + RcInput, /* Handle read request */ + RcOutput, /* Handle write request */ + RcSeek, /* Move location of access point. NULL'able */ + RcSetOption, /* Set options. NULL'able */ + RcGetOption, /* Get options. NULL'able */ + RcWatch, /* Initialize notifier */ + NULL, /* Get OS handle from the channel. NULL'able */ + NULL, /* No close2 support. NULL'able */ + RcBlock, /* Set blocking/nonblocking. NULL'able */ + NULL, /* Flush channel. Not used by core. NULL'able */ + NULL, /* Handle events. NULL'able */ + RcSeekWide /* Move access point (64 bit). NULL'able */ +}; + +/* + * Instance data for a reflected channel. =========================== + */ + +typedef struct { + Tcl_Channel chan; /* Back reference to generic channel structure. + */ + Tcl_Interp* interp; /* Reference to the interpreter containing the + * Tcl level part of the channel. */ +#ifdef TCL_THREADS + Tcl_ThreadId thread; /* Thread the 'interp' belongs to. */ +#endif + + /* See [==] as well. + * Storage for the command prefix and the additional words required + * for the invocation of methods in the command handler. + * + * argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2] + * cmd ... pfx | method chan | detail1 detail2 + * ~~~~ CT ~~~ ~~ CT ~~ + * + * CT = Belongs to the 'Command handler Thread'. + */ + + int argc; /* Number of preallocated words - 2 */ + Tcl_Obj** argv; /* Preallocated array for calling the handler. + * args [0] is placeholder for cmd word. + * Followed by the arguments in the prefix, + * plus 4 placeholders for method, channel, + * and at most two varying (method specific) + * words. + */ + + int methods; /* Bitmask of supported methods */ + + /* ---------------------------------------- */ + + /* NOTE (9): Should we have predefined shared literals + * NOTE (9): for the method names ? + */ + + /* ---------------------------------------- */ + + int mode; /* Mask of R/W mode */ + int interest; /* Mask of events the channel is interested in. */ + + /* Note regarding the usage of timers. + * + * Most channel implementations need a timer in the + * C level to ensure that data in buffers is flushed + * out through the generation of fake file events. + * + * See 'rechan', 'memchan', etc. + * + * Here this is _not_ required. Interest in events is + * posted to the Tcl level via 'watch'. And posting of + * events is possible from the Tcl level as well, via + * 'chan postevent'. This means that the generation of + * all events, fake or not, timer based or not, is + * completely in the hands of the Tcl level. Therefore + * no timer here. + */ + +} ReflectingChannel; + +/* + * Event literals. ================================================== + */ + +static CONST char *eventOptions[] = { + "read", "write", (char *) NULL +}; +typedef enum { + EVENT_READ, EVENT_WRITE +} EventOption; + +/* + * Method literals. ================================================== + */ + +static CONST char *methodNames[] = { + "blocking", /* OPT */ + "cget", /* OPT \/ Together or none */ + "cgetall", /* OPT /\ of these two */ + "configure", /* OPT */ + "finalize", /* */ + "initialize", /* */ + "read", /* OPT */ + "seek", /* OPT */ + "watch", /* */ + "write", /* OPT */ + (char *) NULL +}; +typedef enum { + METH_BLOCKING, + METH_CGET, + METH_CGETALL, + METH_CONFIGURE, + METH_FINAL, + METH_INIT, + METH_READ, + METH_SEEK, + METH_WATCH, + METH_WRITE, +} MethodName; + +#define FLAG(m) (1 << (m)) +#define REQUIRED_METHODS (FLAG (METH_INIT) | FLAG (METH_FINAL) | FLAG (METH_WATCH)) +#define NULLABLE_METHODS (FLAG (METH_BLOCKING) | FLAG (METH_SEEK) | \ + FLAG (METH_CONFIGURE) | FLAG (METH_CGET) | FLAG (METH_CGETALL)) + +#define RANDW (TCL_READABLE|TCL_WRITABLE) + +#define IMPLIES(a,b) ((!(a)) || (b)) +#define NEGIMPL(a,b) +#define HAS(x,f) (x & FLAG(f)) + + +#ifdef TCL_THREADS +/* + * Thread specific types and structures. + * + * We are here essentially creating a very specific implementation of + * 'thread send'. + */ + +/* + * Enumeration of all operations which can be forwarded. + */ + +typedef enum { + RcOpClose, + RcOpInput, + RcOpOutput, + RcOpSeek, + RcOpWatch, + RcOpBlock, + RcOpSetOpt, + RcOpGetOpt, + RcOpGetOptAll +} RcOperation; + +/* + * Event used to forward driver invocations to the thread actually + * managing the channel. We cannot construct the command to execute + * and forward that. Because then it will contain a mixture of + * Tcl_Obj's belonging to both the command handler thread (CT), and + * the thread managing the channel (MT), executed in CT. Tcl_Obj's are + * not allowed to cross thread boundaries. So we forward an operation + * code, the argument details ,and reference to results. The command + * is assembled in the CT and belongs fully to that thread. No sharing + * problems. + */ + +typedef struct RcForwardParamBase { + int code; /* O: Ok/Fail of the cmd handler */ + char* msg; /* O: Error message for handler failure */ + int vol; /* O: True - msg is allocated, False - msg is static */ +} RcForwardParamBase; + +/* + * Operation specific parameter/result structures. + */ + +typedef struct RcForwardParamClose { + RcForwardParamBase b; +} RcForwardParamClose; + +typedef struct RcForwardParamInput { + RcForwardParamBase b; + char* buf; /* O: Where to store the read bytes */ + int toRead; /* I: #bytes to read, + * O: #bytes actually read */ +} RcForwardParamInput; + +typedef struct RcForwardParamOutput { + RcForwardParamBase b; + CONST char* buf; /* I: Where the bytes to write come from */ + int toWrite; /* I: #bytes to write, + * O: #bytes actually written */ +} RcForwardParamOutput; + +typedef struct RcForwardParamSeek { + RcForwardParamBase b; + int seekMode; /* I: How to seek */ + Tcl_WideInt offset; /* I: Where to seek, + * O: New location */ +} RcForwardParamSeek; + +typedef struct RcForwardParamWatch { + RcForwardParamBase b; + int mask; /* I: What events to watch for */ +} RcForwardParamWatch; + +typedef struct RcForwardParamBlock { + RcForwardParamBase b; + int nonblocking; /* I: What mode to activate */ +} RcForwardParamBlock; + +typedef struct RcForwardParamSetOpt { + RcForwardParamBase b; + CONST char* name; /* Name of option to set */ + CONST char* value; /* Value to set */ +} RcForwardParamSetOpt; + +typedef struct RcForwardParamGetOpt { + RcForwardParamBase b; + CONST char* name; /* Name of option to get, maybe NULL */ + Tcl_DString* value; /* Result */ +} RcForwardParamGetOpt; + +/* + * General event structure, with reference to + * operation specific data. + */ + +typedef struct RcForwardingEvent { + Tcl_Event event; /* Basic event data, has to be first item */ + struct RcForwardingResult* resultPtr; + + RcOperation op; /* Forwarded driver operation */ + ReflectingChannel* rcPtr; /* Channel instance */ + CONST RcForwardParamBase* param; /* Arguments, a RcForwardParamXXX pointer */ +} RcForwardingEvent; + +/* + * Structure to manage the result of the forwarding. This is not the + * result of the operation itself, but about the success of the + * forward event itself. The event can be successful, even if the + * operation which was forwarded failed. It is also there to manage + * the synchronization between the involved threads. + */ + +typedef struct RcForwardingResult { + + Tcl_ThreadId src; /* Originating thread. */ + Tcl_ThreadId dst; /* Thread the op was forwarded to. */ + Tcl_Condition done; /* Condition variable the forwarder blocks on. */ + int result; /* TCL_OK or TCL_ERROR */ + + struct RcForwardingEvent* evPtr; /* Event the result belongs to. */ + + struct RcForwardingResult* prevPtr; /* Links into the list of pending */ + struct RcForwardingResult* nextPtr; /* forwarded results. */ + +} RcForwardingResult; + +/* + * List of forwarded operations which have not completed yet, plus the + * mutex to protect the access to this process global list. + */ + +static RcForwardingResult* forwardList = (RcForwardingResult*) NULL; +TCL_DECLARE_MUTEX (rcForwardMutex) + +/* + * Function containing the generic code executing a forward, and + * wrapper macros for the actual operations we wish to forward. + */ + +static void +RcForwardOp _ANSI_ARGS_ ((ReflectingChannel* rcPtr, RcOperation op, + Tcl_ThreadId dst, CONST VOID* param)); + +/* + * The event function executed by the thread receiving a forwarding + * event. Executes the appropriate function and collects the result, + * if any. + */ + +static int +RcForwardProc _ANSI_ARGS_ ((Tcl_Event *evPtr, int mask)); + +/* + * Helpers which intercept when threads are going away, and clean up + * after pending forwarding events. Different actions depending on + * which thread went away, originator (src), or receiver (dst). + */ + +static void +RcSrcExitProc _ANSI_ARGS_ ((ClientData clientData)); + +static void +RcDstExitProc _ANSI_ARGS_ ((ClientData clientData)); + +#define RcFreeReceivedError(pb) \ + if ((pb).vol) {ckfree ((pb).msg);} + +#define RcPassReceivedErrorInterp(i,pb) \ + if ((i)) {Tcl_SetChannelErrorInterp ((i), Tcl_NewStringObj ((pb).msg,-1));} \ + RcFreeReceivedError (pb) + +#define RcPassReceivedError(c,pb) \ + Tcl_SetChannelError ((c), Tcl_NewStringObj ((pb).msg,-1)); \ + RcFreeReceivedError (pb) + +#define RcForwardSetStaticError(p,emsg) \ + (p)->code = TCL_ERROR; (p)->vol = 0; (p)->msg = (char*) (emsg); + +#define RcForwardSetDynError(p,emsg) \ + (p)->code = TCL_ERROR; (p)->vol = 1; (p)->msg = (char*) (emsg); + +static void +RcForwardSetObjError _ANSI_ARGS_ ((RcForwardParamBase* p, + Tcl_Obj* obj)); + +#endif /* TCL_THREADS */ + +#define RcSetChannelErrorStr(c,msg) \ + Tcl_SetChannelError ((c), Tcl_NewStringObj ((msg),-1)) + +static Tcl_Obj* RcErrorMarshall _ANSI_ARGS_ ((Tcl_Interp *interp)); +static void RcErrorReturn _ANSI_ARGS_ ((Tcl_Interp* interp, Tcl_Obj* msg)); + + + +/* + * Static functions for this file: + */ + +static int RcEncodeEventMask _ANSI_ARGS_((Tcl_Interp* interp, + CONST char* objName, Tcl_Obj* obj, + int* mask)); + +static Tcl_Obj* RcDecodeEventMask _ANSI_ARGS_ ((int mask)); + +static ReflectingChannel* RcNew _ANSI_ARGS_ ((Tcl_Interp* interp, + Tcl_Obj* cmdpfxObj, int mode, + Tcl_Obj* id)); + +static Tcl_Obj* RcNewHandle _ANSI_ARGS_ ((void)); + +static void RcFree _ANSI_ARGS_ ((ReflectingChannel* rcPtr)); + +static void +RcInvokeTclMethod _ANSI_ARGS_((ReflectingChannel* rcPtr, + CONST char* method, Tcl_Obj* argone, Tcl_Obj* argtwo, + int* result, Tcl_Obj** resultObj, int capture)); + +#define NO_CAPTURE (0) +#define DO_CAPTURE (1) + +/* + * Global constant strings (messages). ================== + * These string are used directly as bypass errors, thus they have to be valid + * Tcl lists where the last element is the message itself. Hence the + * list-quoting to keep the words of the message together. See also [x]. + */ + +static CONST char* msg_read_unsup = "{read not supported by Tcl driver}"; +static CONST char* msg_read_toomuch = "{read delivered more than requested}"; +static CONST char* msg_write_unsup = "{write not supported by Tcl driver}"; +static CONST char* msg_write_toomuch = "{write wrote more than requested}"; +static CONST char* msg_seek_beforestart = "{Tried to seek before origin}"; + +#ifdef TCL_THREADS +static CONST char* msg_send_originlost = "{Origin thread lost}"; +static CONST char* msg_send_dstlost = "{Destination thread lost}"; +#endif /* TCL_THREADS */ + +/* + * Main methods to plug into the 'chan' ensemble'. ================== + */ + +/* + *---------------------------------------------------------------------- + * + * TclChanCreateObjCmd -- + * + * This procedure is invoked to process the "chan create" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * The handle of the new channel is placed in the interp result. + * + * Side effects: + * Creates a new channel. + * + *---------------------------------------------------------------------- + */ + +int +TclChanCreateObjCmd (/*ignored*/ clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp* interp; + int objc; + Tcl_Obj* CONST* objv; +{ + ReflectingChannel* rcPtr; /* Instance data of the new channel */ + Tcl_Obj* rcId; /* Handle of the new channel */ + int mode; /* R/W mode of new channel. Has to + * match abilities of handler commands */ + Tcl_Obj* cmdObj; /* Command prefix, list of words */ + Tcl_Obj* cmdNameObj; /* Command name */ + Tcl_Channel chan; /* Token for the new channel */ + Tcl_Obj* modeObj; /* mode in obj form for method call */ + int listc; /* Result of 'initialize', and of */ + Tcl_Obj** listv; /* its sublist in the 2nd element */ + int methIndex; /* Encoded method name */ + int res; /* Result code for 'initialize' */ + Tcl_Obj* resObj; /* Result data for 'initialize' */ + int methods; /* Bitmask for supported methods. */ + Channel* chanPtr; /* 'chan' resolved to internal struct. */ + + /* Syntax: chan create MODE CMDPREFIX + * [0] [1] [2] [3] + * + * Actually: rCreate MODE CMDPREFIX + * [0] [1] [2] + */ + +#define MODE (1) +#define CMD (2) + + /* Number of arguments ... */ + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "mode cmdprefix"); + return TCL_ERROR; + } + + /* First argument is a list of modes. Allowed entries are "read", + * "write". Expect at least one list element. Abbreviations are + * ok. + */ + + modeObj = objv [MODE]; + if (RcEncodeEventMask (interp, "mode", objv [MODE], &mode) != TCL_OK) { + return TCL_ERROR; + } + + /* Second argument is command prefix, i.e. list of words, first + * word is name of handler command, other words are fixed + * arguments. Run 'initialize' method to get the list of supported + * methods. Validate this. + */ + + cmdObj = objv [CMD]; + + /* Basic check that the command prefix truly is a list. */ + + if (Tcl_ListObjIndex(interp, cmdObj, 0, &cmdNameObj) != TCL_OK) { + return TCL_ERROR; + } + + /* Now create the channel. + */ + + rcId = RcNewHandle (); + rcPtr = RcNew (interp, cmdObj, mode, rcId); + chan = Tcl_CreateChannel (&tclRChannelType, + Tcl_GetString (rcId), + rcPtr, mode); + rcPtr->chan = chan; + chanPtr = (Channel*) chan; + + /* Invoke 'initialize' and validate that the handler + * is present and ok. Squash the channel if not. + */ + + /* Note: The conversion of 'mode' back into a Tcl_Obj ensures that + * 'initialize' is invoked with canonical mode names, and no + * abbreviations. Using modeObj directly could feed abbreviations + * into the handler, and the handler is not specified to handle + * such. + */ + + modeObj = RcDecodeEventMask (mode); + RcInvokeTclMethod (rcPtr, "initialize", modeObj, NULL, + &res, &resObj, NO_CAPTURE); + Tcl_DecrRefCount (modeObj); + + if (res != TCL_OK) { + Tcl_Obj* err = Tcl_NewStringObj ("Initialize failure: ",-1); + + Tcl_AppendObjToObj(err,resObj); + Tcl_SetObjResult (interp,err); + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + goto error; + } + + /* Verify the result. + * - List, of method names. Convert to mask. + * Check for non-optionals through the mask. + * Compare open mode against optional r/w. + */ + + Tcl_AppendResult (interp, "Initialize failure: ", (char*) NULL); + + if (Tcl_ListObjGetElements (interp, resObj, + &listc, &listv) != TCL_OK) { + /* The function above replaces my prefix in case of an error, + * so more work for us to get the prefix back into the error + * message + */ + + Tcl_Obj* err = Tcl_NewStringObj ("Initialize failure: ",-1); + + Tcl_AppendObjToObj(err,Tcl_GetObjResult (interp)); + Tcl_SetObjResult (interp,err); + goto error; + } + + methods = 0; + while (listc > 0) { + if (Tcl_GetIndexFromObj (interp, listv [listc-1], + methodNames, "method", TCL_EXACT, &methIndex) != TCL_OK) { + Tcl_Obj* err = Tcl_NewStringObj ("Initialize failure: ",-1); + + Tcl_AppendObjToObj(err,Tcl_GetObjResult (interp)); + Tcl_SetObjResult (interp,err); + goto error; + } + + methods |= FLAG (methIndex); + listc --; + } + + if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) { + Tcl_AppendResult (interp, "Not all required methods supported", + (char*) NULL); + goto error; + } + + if ((mode & TCL_READABLE) && !HAS(methods,METH_READ)) { + Tcl_AppendResult (interp, "Reading not supported, but requested", + (char*) NULL); + goto error; + } + + if ((mode & TCL_WRITABLE) && !HAS(methods,METH_WRITE)) { + Tcl_AppendResult (interp, "Writing not supported, but requested", + (char*) NULL); + goto error; + } + + if (!IMPLIES (HAS(methods,METH_CGET), HAS(methods,METH_CGETALL))) { + Tcl_AppendResult (interp, "'cgetall' not supported, but should be, as 'cget' is", + (char*) NULL); + goto error; + } + + if (!IMPLIES (HAS(methods,METH_CGETALL),HAS(methods,METH_CGET))) { + Tcl_AppendResult (interp, "'cget' not supported, but should be, as 'cgetall' is", + (char*) NULL); + goto error; + } + + Tcl_ResetResult (interp); + + /* Everything is fine now */ + + rcPtr->methods = methods; + + if ((methods & NULLABLE_METHODS) != NULLABLE_METHODS) { + /* Some of the nullable methods are not supported. We clone + * the channel type, null the associated C functions, and use + * the result as the actual channel type. + */ + + Tcl_ChannelType* clonePtr = (Tcl_ChannelType*) ckalloc (sizeof (Tcl_ChannelType)); + if (clonePtr == (Tcl_ChannelType*) NULL) { + Tcl_Panic ("Out of memory in Tcl_RcCreate"); + } + + memcpy (clonePtr, &tclRChannelType, sizeof (Tcl_ChannelType)); + + if (!(methods & FLAG (METH_CONFIGURE))) { + clonePtr->setOptionProc = NULL; + } + + if ( + !(methods & FLAG (METH_CGET)) && + !(methods & FLAG (METH_CGETALL)) + ) { + clonePtr->getOptionProc = NULL; + } + if (!(methods & FLAG (METH_BLOCKING))) { + clonePtr->blockModeProc = NULL; + } + if (!(methods & FLAG (METH_SEEK))) { + clonePtr->seekProc = NULL; + clonePtr->wideSeekProc = NULL; + } + + chanPtr->typePtr = clonePtr; + } + + Tcl_RegisterChannel (interp, chan); + + /* Return handle as result of command */ + + Tcl_SetObjResult (interp, rcId); + return TCL_OK; + + error: + /* Signal to RcClose to not call 'finalize' */ + rcPtr->methods = 0; + Tcl_Close (interp, chan); + return TCL_ERROR; + +#undef MODE +#undef CMD +} + +/* + *---------------------------------------------------------------------- + * + * TclChanPostEventObjCmd -- + * + * This procedure is invoked to process the "chan postevent" + * Tcl command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Posts events to a reflected channel, invokes event handlers. + * The latter implies that arbitrary side effects are possible. + * + *---------------------------------------------------------------------- + */ + +int +TclChanPostEventObjCmd (/*ignored*/ clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp* interp; + int objc; + Tcl_Obj* CONST* objv; +{ + /* Syntax: chan postevent CHANNEL EVENTSPEC + * [0] [1] [2] [3] + * + * Actually: rPostevent CHANNEL EVENTSPEC + * [0] [1] [2] + * + * where EVENTSPEC = {read write ...} (Abbreviations allowed as well. + */ + +#define CHAN (1) +#define EVENT (2) + + CONST char* chanId; /* Tcl level channel handle */ + Tcl_Channel chan; /* Channel associated to the handle */ + Tcl_ChannelType* chanTypePtr; /* Its associated driver structure */ + ReflectingChannel* rcPtr; /* Associated instance data */ + int mode; /* Dummy, r|w mode of the channel */ + int events; /* Mask of events to post */ + + /* Number of arguments ... */ + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "channel eventspec"); + return TCL_ERROR; + } + + /* First argument is a channel, a reflected channel, and the call + * of this command is done from the interp defining the channel + * handler cmd. + */ + + chanId = Tcl_GetString (objv [CHAN]); + chan = Tcl_GetChannel(interp, chanId, &mode); + + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + + chanTypePtr = Tcl_GetChannelType (chan); + + /* We use a function referenced by the channel type as our cookie + * to detect calls to non-reflecting channels. The channel type + * itself is not suitable, as it might not be the static + * definition in this file, but a clone thereof. And while we have + * reserved the name of the type nothing in the core checks + * against violation, so someone else might have created a channel + * type using our name, clashing with ourselves. + */ + + if (chanTypePtr->watchProc != &RcWatch) { + Tcl_AppendResult(interp, "channel \"", chanId, + "\" is not a reflected channel", + (char *) NULL); + return TCL_ERROR; + } + + rcPtr = (ReflectingChannel*) Tcl_GetChannelInstanceData (chan); + + if (rcPtr->interp != interp) { + Tcl_AppendResult(interp, "postevent for channel \"", chanId, + "\" called from outside interpreter", + (char *) NULL); + return TCL_ERROR; + } + + /* Second argument is a list of events. Allowed entries are + * "read", "write". Expect at least one list element. + * Abbreviations are ok. + */ + + if (RcEncodeEventMask (interp, "event", objv [EVENT], &events) != TCL_OK) { + return TCL_ERROR; + } + + /* Check that the channel is actually interested in the provided + * events. + */ + + if (events & ~rcPtr->interest) { + Tcl_AppendResult(interp, "tried to post events channel \"", chanId, + "\" is not interested in", + (char *) NULL); + return TCL_ERROR; + } + + /* We have the channel and the events to post. + */ + + Tcl_NotifyChannel (chan, events); + + /* Squash interp results left by the event script. + */ + + Tcl_ResetResult (interp); + return TCL_OK; + +#undef CHAN +#undef EVENT +} + + +static Tcl_Obj* +RcErrorMarshall (interp) + Tcl_Interp *interp; +{ + /* Capture the result status of the interpreter into a string. + * => List of options and values, followed by the error message. + * The result has refCount 0. + */ + + Tcl_Obj* returnOpt = Tcl_GetReturnOptions (interp, TCL_ERROR); + + /* => returnOpt.refCount == 0. We can append directly. + */ + + Tcl_ListObjAppendElement (NULL, returnOpt, Tcl_GetObjResult (interp)); + return returnOpt; +} + +static void +RcErrorReturn (interp, msg) + Tcl_Interp *interp; + Tcl_Obj *msg; +{ + int res; + int lc; + Tcl_Obj** lv; + int explicitResult; + int numOptions; + + /* Process the caught message. + * + * Syntax = (option value)... ?message? + * + * Bad syntax causes a panic. Because the other side uses + * Tcl_GetReturnOptions and list construction functions to marshall the + * information. + */ + + res = Tcl_ListObjGetElements (interp, msg, &lc, &lv); + if (res != TCL_OK) { + Tcl_Panic ("TclChanCaughtErrorBypass: Bad syntax of caught result"); + } + + explicitResult = (1 == (lc % 2)); + numOptions = lc - explicitResult; + + if (explicitResult) { + Tcl_SetObjResult (interp, lv [lc-1]); + } + + (void) Tcl_SetReturnOptions(interp, Tcl_NewListObj (numOptions, lv)); +} + +int +TclChanCaughtErrorBypass (interp, chan) + Tcl_Interp *interp; + Tcl_Channel chan; +{ + Tcl_Obj* msgc = NULL; + Tcl_Obj* msgi = NULL; + Tcl_Obj* msg = NULL; + + /* Get a bypassed error message from channel and/or interpreter, save the + * reference, then kill the returned objects, if there were any. If there + * are messages in both the channel has preference. + */ + + if ((chan == NULL) && (interp == NULL)) { + return 0; + } + + if (chan != NULL) { + Tcl_GetChannelError (chan, &msgc); + } + if (interp != NULL) { + Tcl_GetChannelErrorInterp (interp, &msgi); + } + + if (msgc != NULL) { + msg = msgc; + Tcl_IncrRefCount (msg); + } else if (msgi != NULL) { + msg = msgi; + Tcl_IncrRefCount (msg); + } + + if (msgc != NULL) { + Tcl_DecrRefCount (msgc); + } + if (msgi != NULL) { + Tcl_DecrRefCount (msgi); + } + + /* No message returned, nothing caught. + */ + + if (msg == NULL) { + return 0; + } + + RcErrorReturn (interp, msg); + + Tcl_DecrRefCount (msg); + return 1; +} + +/* + * Driver functions. ================================================ + */ + +/* + *---------------------------------------------------------------------- + * + * RcClose -- + * + * This function is invoked when the channel is closed, to delete + * the driver specific instance data. + * + * Results: + * A posix error. + * + * Side effects: + * Releases memory. Arbitrary, as it calls upon a script. + * + *---------------------------------------------------------------------- + */ + +static int +RcClose (clientData, interp) + ClientData clientData; + Tcl_Interp* interp; +{ + ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; + int res; /* Result code for 'close' */ + Tcl_Obj* resObj; /* Result data for 'close' */ + + if (interp == (Tcl_Interp*) NULL) { + /* This call comes from TclFinalizeIOSystem. There are no + * interpreters, and therefore we cannot call upon the handler + * command anymore. Threading is irrelevant as well. We + * simply clean up all our C level data structures and leave + * the Tcl level to the other finalization functions. + */ + + /* THREADED => Forward this to the origin thread */ + /* Note: Have a thread delete handler for the origin + * thread. Use this to clean up the structure! + */ + +#ifdef TCL_THREADS + /* Are we in the correct thread ? + */ + + if (rcPtr->thread != Tcl_GetCurrentThread ()) { + RcForwardParamClose p; + + RcForwardOp (rcPtr, RcOpClose, rcPtr->thread, &p); + res = p.b.code; + + /* RcFree is done in the forwarded operation!, + * in the other thread. rcPtr here is gone! + */ + + if (res != TCL_OK) { + RcFreeReceivedError (p.b); + } + } else { +#endif + RcFree (rcPtr); +#ifdef TCL_THREADS + } +#endif + return EOK; + } + + /* -------- */ + + /* -- No -- ASSERT rcPtr->methods & FLAG (METH_FINAL) */ + + /* A cleaned method mask here implies that the channel creation + * was aborted, and "finalize" must not be called. + */ + + if (rcPtr->methods == 0) { + RcFree (rcPtr); + return EOK; + } else { +#ifdef TCL_THREADS + /* Are we in the correct thread ? + */ + + if (rcPtr->thread != Tcl_GetCurrentThread ()) { + RcForwardParamClose p; + + RcForwardOp (rcPtr, RcOpClose, rcPtr->thread, &p); + res = p.b.code; + + /* RcFree is done in the forwarded operation!, + * in the other thread. rcPtr here is gone! + */ + + if (res != TCL_OK) { + RcPassReceivedErrorInterp (interp, p.b); + } + } else { +#endif + RcInvokeTclMethod (rcPtr, "finalize", NULL, NULL, + &res, &resObj, DO_CAPTURE); + + if ((res != TCL_OK) && (interp != NULL)) { + Tcl_SetChannelErrorInterp (interp, resObj); + } + + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ +#ifdef TCL_THREADS + RcFree (rcPtr); + } +#endif + return (res == TCL_OK) ? EOK : EINVAL; + } +} + +/* + *---------------------------------------------------------------------- + * + * RcInput -- + * + * This function is invoked when more data is requested from the + * channel. + * + * Results: + * The number of bytes read. + * + * Side effects: + * Allocates memory. Arbitrary, as it calls upon a script. + * + *---------------------------------------------------------------------- + */ + +static int +RcInput (clientData, buf, toRead, errorCodePtr) + ClientData clientData; + char* buf; + int toRead; + int* errorCodePtr; +{ + ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; + Tcl_Obj* toReadObj; + int bytec; /* Number of returned bytes */ + unsigned char* bytev; /* Array of returned bytes */ + int res; /* Result code for 'read' */ + Tcl_Obj* resObj; /* Result data for 'read' */ + + /* The following check can be done before thread redirection, + * because we are reading from an item which is readonly, i.e. + * will never change during the lifetime of the channel. + */ + + if (!(rcPtr->methods & FLAG (METH_READ))) { + RcSetChannelErrorStr (rcPtr->chan, msg_read_unsup); + *errorCodePtr = EINVAL; + return -1; + } + +#ifdef TCL_THREADS + /* Are we in the correct thread ? + */ + + if (rcPtr->thread != Tcl_GetCurrentThread ()) { + RcForwardParamInput p; + + p.buf = buf; + p.toRead = toRead; + + RcForwardOp (rcPtr, RcOpInput, rcPtr->thread, &p); + + if (p.b.code != TCL_OK) { + RcPassReceivedError (rcPtr->chan, p.b); + *errorCodePtr = EINVAL; + } else { + *errorCodePtr = EOK; + } + + return p.toRead; + } +#endif + + /* -------- */ + + /* ASSERT: rcPtr->method & FLAG (METH_READ) */ + /* ASSERT: rcPtr->mode & TCL_READABLE */ + + toReadObj = Tcl_NewIntObj(toRead); + if (toReadObj == (Tcl_Obj*) NULL) { + Tcl_Panic ("Out of memory in RcInput"); + } + + RcInvokeTclMethod (rcPtr, "read", toReadObj, NULL, + &res, &resObj, DO_CAPTURE); + + if (res != TCL_OK) { + Tcl_SetChannelError (rcPtr->chan, resObj); + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + *errorCodePtr = EINVAL; + return -1; + } + + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); + + if (toRead < bytec) { + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + RcSetChannelErrorStr (rcPtr->chan, msg_read_toomuch); + *errorCodePtr = EINVAL; + return -1; + } + + *errorCodePtr = EOK; + + if (bytec > 0) { + memcpy (buf, bytev, bytec); + } + + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + return bytec; +} + +/* + *---------------------------------------------------------------------- + * + * RcOutput -- + * + * This function is invoked when data is writen to the + * channel. + * + * Results: + * The number of bytes actually written. + * + * Side effects: + * Allocates memory. Arbitrary, as it calls upon a script. + * + *---------------------------------------------------------------------- + */ + +static int +RcOutput (clientData, buf, toWrite, errorCodePtr) + ClientData clientData; + CONST char* buf; + int toWrite; + int* errorCodePtr; +{ + ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; + Tcl_Obj* bufObj; + int res; /* Result code for 'write' */ + Tcl_Obj* resObj; /* Result data for 'write' */ + int written; + + /* The following check can be done before thread redirection, + * because we are reading from an item which is readonly, i.e. + * will never change during the lifetime of the channel. + */ + + if (!(rcPtr->methods & FLAG (METH_WRITE))) { + RcSetChannelErrorStr (rcPtr->chan, msg_write_unsup); + *errorCodePtr = EINVAL; + return -1; + } + +#ifdef TCL_THREADS + /* Are we in the correct thread ? + */ + + if (rcPtr->thread != Tcl_GetCurrentThread ()) { + RcForwardParamOutput p; + + p.buf = buf; + p.toWrite = toWrite; + + RcForwardOp (rcPtr, RcOpOutput, rcPtr->thread, &p); + + if (p.b.code != TCL_OK) { + RcPassReceivedError (rcPtr->chan, p.b); + *errorCodePtr = EINVAL; + } else { + *errorCodePtr = EOK; + } + + return p.toWrite; + } +#endif + + /* -------- */ + + /* ASSERT: rcPtr->method & FLAG (METH_WRITE) */ + /* ASSERT: rcPtr->mode & TCL_WRITABLE */ + + bufObj = Tcl_NewByteArrayObj((unsigned char*) buf, toWrite); + if (bufObj == (Tcl_Obj*) NULL) { + Tcl_Panic ("Out of memory in RcOutput"); + } + + RcInvokeTclMethod (rcPtr, "write", bufObj, NULL, + &res, &resObj, DO_CAPTURE); + + if (res != TCL_OK) { + Tcl_SetChannelError (rcPtr->chan, resObj); + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + *errorCodePtr = EINVAL; + return -1; + } + + res = Tcl_GetIntFromObj (rcPtr->interp, resObj, &written); + if (res != TCL_OK) { + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + Tcl_SetChannelError (rcPtr->chan, RcErrorMarshall (rcPtr->interp)); + *errorCodePtr = EINVAL; + return -1; + } + + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + + if ((written == 0) || (toWrite < written)) { + /* The handler claims to have written more than it was given. + * That is bad. Note that the I/O core would crash if we were + * to return this information, trying to write -nnn bytes in + * the next iteration. + */ + + RcSetChannelErrorStr (rcPtr->chan, msg_write_toomuch); + *errorCodePtr = EINVAL; + return -1; + } + + *errorCodePtr = EOK; + return written; +} + +/* + *---------------------------------------------------------------------- + * + * RcSeekWide / RcSeek -- + * + * This function is invoked when the user wishes to seek on + * the channel. + * + * Results: + * The new location of the access point. + * + * Side effects: + * Allocates memory. Arbitrary, as it calls upon a script. + * + *---------------------------------------------------------------------- + */ + +static Tcl_WideInt +RcSeekWide (clientData, offset, seekMode, errorCodePtr) + ClientData clientData; + Tcl_WideInt offset; + int seekMode; + int* errorCodePtr; +{ + ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; + Tcl_Obj* offObj; + Tcl_Obj* baseObj; + int res; /* Result code for 'seek' */ + Tcl_Obj* resObj; /* Result data for 'seek' */ + Tcl_WideInt newLoc; + +#ifdef TCL_THREADS + /* Are we in the correct thread ? + */ + + if (rcPtr->thread != Tcl_GetCurrentThread ()) { + RcForwardParamSeek p; + + p.seekMode = seekMode; + p.offset = offset; + + RcForwardOp (rcPtr, RcOpSeek, rcPtr->thread, &p); + + if (p.b.code != TCL_OK) { + RcPassReceivedError (rcPtr->chan, p.b); + *errorCodePtr = EINVAL; + } else { + *errorCodePtr = EOK; + } + + return p.offset; + } +#endif + + /* -------- */ + + /* ASSERT: rcPtr->method & FLAG (METH_SEEK) */ + + offObj = Tcl_NewWideIntObj(offset); + if (offObj == (Tcl_Obj*) NULL) { + Tcl_Panic ("Out of memory in RcSeekWide"); + } + + baseObj = Tcl_NewStringObj((seekMode == SEEK_SET) ? + "start" : + ((seekMode == SEEK_CUR) ? + "current" : + "end"), -1); + + if (baseObj == (Tcl_Obj*) NULL) { + Tcl_Panic ("Out of memory in RcSeekWide"); + } + + RcInvokeTclMethod (rcPtr, "seek", offObj, baseObj, + &res, &resObj, DO_CAPTURE); + + if (res != TCL_OK) { + Tcl_SetChannelError (rcPtr->chan, resObj); + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + *errorCodePtr = EINVAL; + return -1; + } + + res = Tcl_GetWideIntFromObj (rcPtr->interp, resObj, &newLoc); + if (res != TCL_OK) { + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + Tcl_SetChannelError (rcPtr->chan, RcErrorMarshall (rcPtr->interp)); + *errorCodePtr = EINVAL; + return -1; + } + + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + + if (newLoc < Tcl_LongAsWide (0)) { + RcSetChannelErrorStr (rcPtr->chan, msg_seek_beforestart); + *errorCodePtr = EINVAL; + return -1; + } + + *errorCodePtr = EOK; + return newLoc; +} + +static int +RcSeek (clientData, offset, seekMode, errorCodePtr) + ClientData clientData; + long offset; + int seekMode; + int* errorCodePtr; +{ + /* This function can be invoked from a transformation which is based + * on standard seeking, i.e. non-wide. Because o this we have to + * implement it, a dummy is not enough. We simply delegate the call + * to the wide routine. + */ + + return (int) RcSeekWide (clientData, Tcl_LongAsWide (offset), + seekMode, errorCodePtr); +} + +/* + *---------------------------------------------------------------------- + * + * RcWatch -- + * + * This function is invoked to tell the channel what events + * the I/O system is interested in. + * + * Results: + * None. + * + * Side effects: + * Allocates memory. Arbitrary, as it calls upon a script. + * + *---------------------------------------------------------------------- + */ + +static void +RcWatch (clientData, mask) + ClientData clientData; + int mask; +{ + ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; + Tcl_Obj* maskObj; + + /* ASSERT rcPtr->methods & FLAG (METH_WATCH) */ + + /* We restrict the interest to what the channel can support + * IOW there will never be write events for a channel which is + * not writable. Analoguous for read events. + */ + + mask = mask & rcPtr->mode; + + if (mask == rcPtr->interest) { + /* Same old, same old, why should we do something ? */ + return; + } + + rcPtr->interest = mask; + +#ifdef TCL_THREADS + /* Are we in the correct thread ? + */ + + if (rcPtr->thread != Tcl_GetCurrentThread ()) { + RcForwardParamWatch p; + + p.mask = mask; + + RcForwardOp (rcPtr, RcOpWatch, rcPtr->thread, &p); + + /* Any failure from the forward is ignored. We have no place to + * put this. + */ + return; + } +#endif + + /* -------- */ + + maskObj = RcDecodeEventMask (mask); + RcInvokeTclMethod (rcPtr, "watch", maskObj, NULL, + NULL, NULL, NO_CAPTURE); + Tcl_DecrRefCount (maskObj); +} + +/* + *---------------------------------------------------------------------- + * + * RcBlock -- + * + * This function is invoked to tell the channel which blocking + * behaviour is required of it. + * + * Results: + * A posix error number. + * + * Side effects: + * Allocates memory. Arbitrary, as it calls upon a script. + * + *---------------------------------------------------------------------- + */ + +static int +RcBlock (clientData, nonblocking) + ClientData clientData; + int nonblocking; +{ + ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; + Tcl_Obj* blockObj; + int res; /* Result code for 'blocking' */ + Tcl_Obj* resObj; /* Result data for 'blocking' */ + +#ifdef TCL_THREADS + /* Are we in the correct thread ? + */ + + if (rcPtr->thread != Tcl_GetCurrentThread ()) { + RcForwardParamBlock p; + + p.nonblocking = nonblocking; + + RcForwardOp (rcPtr, RcOpBlock, rcPtr->thread, &p); + + if (p.b.code != TCL_OK) { + RcPassReceivedError (rcPtr->chan, p.b); + return EINVAL; + } else { + return EOK; + } + } +#endif + + /* -------- */ + + blockObj = Tcl_NewBooleanObj(!nonblocking); + if (blockObj == (Tcl_Obj*) NULL) { + Tcl_Panic ("Out of memory in RcBlock"); + } + + RcInvokeTclMethod (rcPtr, "blocking", blockObj, NULL, + &res, &resObj, DO_CAPTURE); + + if (res != TCL_OK) { + Tcl_SetChannelError (rcPtr->chan, resObj); + res = EINVAL; + } else { + res = EOK; + } + + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + return res; +} + +/* + *---------------------------------------------------------------------- + * + * RcSetOption -- + * + * This function is invoked to configure a channel option. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Arbitrary, as it calls upon a Tcl script. + * + *---------------------------------------------------------------------- + */ + +static int +RcSetOption (clientData, interp, optionName, newValue) + ClientData clientData; /* Channel to query */ + Tcl_Interp *interp; /* Interpreter to leave error messages in */ + CONST char *optionName; /* Name of requested option */ + CONST char *newValue; /* The new value */ +{ + ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; + Tcl_Obj* optionObj; + Tcl_Obj* valueObj; + int res; /* Result code for 'configure' */ + Tcl_Obj* resObj; /* Result data for 'configure' */ + +#ifdef TCL_THREADS + /* Are we in the correct thread ? + */ + + if (rcPtr->thread != Tcl_GetCurrentThread ()) { + RcForwardParamSetOpt p; + + p.name = optionName; + p.value = newValue; + + RcForwardOp (rcPtr, RcOpSetOpt, rcPtr->thread, &p); + + if (p.b.code != TCL_OK) { + Tcl_Obj* err = Tcl_NewStringObj (p.b.msg, -1); + + RcErrorReturn (interp, err); + + Tcl_DecrRefCount (err); + if (p.b.vol) {ckfree (p.b.msg);} + } + + return p.b.code; + } +#endif + + /* -------- */ + + optionObj = Tcl_NewStringObj(optionName,-1); + if (optionObj == (Tcl_Obj*) NULL) { + Tcl_Panic ("Out of memory in RcSetOption"); + } + + valueObj = Tcl_NewStringObj(newValue,-1); + if (valueObj == (Tcl_Obj*) NULL) { + Tcl_Panic ("Out of memory in RcSetOption"); + } + + RcInvokeTclMethod (rcPtr, "configure", optionObj, valueObj, + &res, &resObj, DO_CAPTURE); + + if (res != TCL_OK) { + RcErrorReturn (interp, resObj); + } + + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + return res; +} + +/* + *---------------------------------------------------------------------- + * + * RcGetOption -- + * + * This function is invoked to retrieve all or a channel option. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Arbitrary, as it calls upon a Tcl script. + * + *---------------------------------------------------------------------- + */ + +static int +RcGetOption (clientData, interp, optionName, dsPtr) + ClientData clientData; /* Channel to query */ + Tcl_Interp* interp; /* Interpreter to leave error messages in */ + CONST char* optionName; /* Name of reuqested option */ + Tcl_DString* dsPtr; /* String to place the result into */ +{ + /* This code is special. It has regular passing of Tcl result, and + * errors. The bypass functions are not required. + */ + + ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; + Tcl_Obj* optionObj; + int res; /* Result code for 'configure' */ + Tcl_Obj* resObj; /* Result data for 'configure' */ + int listc; + Tcl_Obj** listv; + const char* method; + +#ifdef TCL_THREADS + /* Are we in the correct thread ? + */ + + if (rcPtr->thread != Tcl_GetCurrentThread ()) { + int opcode; + RcForwardParamGetOpt p; + + p.name = optionName; + p.value = dsPtr; + + if (optionName == (char*) NULL) { + opcode = RcOpGetOptAll; + } else { + opcode = RcOpGetOpt; + } + + RcForwardOp (rcPtr, opcode, rcPtr->thread, &p); + + if (p.b.code != TCL_OK) { + Tcl_Obj* err = Tcl_NewStringObj (p.b.msg, -1); + + RcErrorReturn (interp, err); + + Tcl_DecrRefCount (err); + if (p.b.vol) {ckfree (p.b.msg);} + } + + return p.b.code; + } +#endif + + /* -------- */ + + if (optionName == (char*) NULL) { + /* Retrieve all options. */ + method = "cgetall"; + optionObj = NULL; + } else { + /* Retrieve the value of one option */ + + method = "cget"; + optionObj = Tcl_NewStringObj(optionName,-1); + if (optionObj == (Tcl_Obj*) NULL) { + Tcl_Panic ("Out of memory in RcGetOption"); + } + } + + RcInvokeTclMethod (rcPtr, method, optionObj, NULL, + &res, &resObj, DO_CAPTURE); + + if (res != TCL_OK) { + RcErrorReturn (interp, resObj); + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + return res; + } + + /* The result has to go into the 'dsPtr' for propagation to the + * caller of the driver. + */ + + if (optionObj != NULL) { + Tcl_DStringAppend (dsPtr, Tcl_GetString (resObj), -1); + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + return res; + } + + /* Extract the list and append each item as element. + */ + + /* NOTE (4): If we extract the string rep we can assume a + * NOTE (4): properly quoted string. Together with a separating + * NOTE (4): space this way of simply appending the whole string + * NOTE (4): rep might be faster. It also doesn't check if the + * NOTE (4): result is a valid list. Nor that the list has an + * NOTE (4): even number elements. + * NOTE (4): --- + */ + + res = Tcl_ListObjGetElements (interp, resObj, &listc, &listv); + + if (res != TCL_OK) { + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + return res; + } + + if ((listc % 2) == 1) { + /* Odd number of elements is wrong. + */ + Tcl_Obj *objPtr = Tcl_NewObj(); + Tcl_ResetResult(interp); + TclObjPrintf(NULL, objPtr, "Expected list with even number of " + "elements, got %d element%s instead", listc, + (listc == 1 ? "" : "s")); + Tcl_SetObjResult(interp, objPtr); + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + return TCL_ERROR; + } + + + { + int len; + char* str = Tcl_GetStringFromObj (resObj, &len); + + if (len) { + Tcl_DStringAppend (dsPtr, " ", 1); + Tcl_DStringAppend (dsPtr, str, len); + } + } + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + return res; +} + +/* + * Helpers. ========================================================= + */ + +/* + *---------------------------------------------------------------------- + * + * RcEncodeEventMask -- + * + * This function takes a list of event items and constructs the + * equivalent internal bitmask. The list has to contain at + * least one element. Elements are "read", "write", or any unique + * abbreviation thereof. Note that the bitmask is not changed if + * problems are encountered. + * + * Results: + * A standard Tcl error code. A bitmask where TCL_READABLE + * and/or TCL_WRITABLE can be set. + * + * Side effects: + * May shimmer 'obj' to a list representation. May place an + * error message into the interp result. + * + *---------------------------------------------------------------------- + */ + +static int +RcEncodeEventMask (interp, objName, obj, mask) + Tcl_Interp* interp; + CONST char* objName; + Tcl_Obj* obj; + int* mask; +{ + int events; /* Mask of events to post */ + int listc; /* #elements in eventspec list */ + Tcl_Obj** listv; /* Elements of eventspec list */ + int evIndex; /* Id of event for an element of the + * eventspec list */ + + if (Tcl_ListObjGetElements (interp, obj, + &listc, &listv) != TCL_OK) { + return TCL_ERROR; + } + + if (listc < 1) { + Tcl_AppendResult(interp, "bad ", objName, " list: is empty", + (char *) NULL); + return TCL_ERROR; + } + + events = 0; + while (listc > 0) { + if (Tcl_GetIndexFromObj (interp, listv [listc-1], + eventOptions, objName, 0, &evIndex) != TCL_OK) { + return TCL_ERROR; + } + switch (evIndex) { + case EVENT_READ: events |= TCL_READABLE; break; + case EVENT_WRITE: events |= TCL_WRITABLE; break; + } + listc --; + } + + *mask = events; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * RcDecodeEventMask -- + * + * This function takes an internal bitmask of events and + * constructs the equivalent list of event items. + * + * Results: + * A Tcl_Obj reference. The object will have a refCount of + * one. The user has to decrement it to release the object. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj* +RcDecodeEventMask (mask) + int mask; +{ + Tcl_Obj* evObj = Tcl_NewStringObj (((mask & RANDW) == RANDW) ? + "read write" : + ((mask & TCL_READABLE) ? + "read" : + ((mask & TCL_WRITABLE) ? + "write" : "")), -1); + if (evObj == (Tcl_Obj*) NULL) { + Tcl_Panic ("Out of memory in RcDecodeEventMask"); + } + + Tcl_IncrRefCount (evObj); + return evObj; +} + +/* + *---------------------------------------------------------------------- + * + * RcNew -- + * + * This function is invoked to allocate and initialize the + * instance data of a new reflected channel. + * + * Results: + * A heap-allocated channel instance. + * + * Side effects: + * Allocates memory. + * + *---------------------------------------------------------------------- + */ + +static ReflectingChannel* +RcNew (interp, cmdpfxObj, mode, id) + Tcl_Interp* interp; + Tcl_Obj* cmdpfxObj; + int mode; + Tcl_Obj* id; +{ + ReflectingChannel* rcPtr; + int listc; + Tcl_Obj** listv; + Tcl_Obj* word; + int i; + + rcPtr = (ReflectingChannel*) ckalloc (sizeof(ReflectingChannel)); + + /* rcPtr->chan : Assigned by caller. Dummy data here. */ + /* rcPtr->methods : Assigned by caller. Dummy data here. */ + + rcPtr->chan = (Tcl_Channel) NULL; + rcPtr->methods = 0; + rcPtr->interp = interp; +#ifdef TCL_THREADS + rcPtr->thread = Tcl_GetCurrentThread (); +#endif + rcPtr->mode = mode; + rcPtr->interest = 0; /* Initially no interest registered */ + + /* Method placeholder */ + + /* ASSERT: cmdpfxObj is a Tcl List */ + + Tcl_ListObjGetElements (interp, cmdpfxObj, &listc, &listv); + + /* See [==] as well. + * Storage for the command prefix and the additional words required + * for the invocation of methods in the command handler. + * + * listv [0] [listc-1] | [listc] [listc+1] | + * argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2] + * cmd ... pfx | method chan | detail1 detail2 + */ + + rcPtr->argc = listc + 2; + rcPtr->argv = (Tcl_Obj**) ckalloc (sizeof (Tcl_Obj*) * (listc+4)); + + for (i = 0; i < listc ; i++) { + word = rcPtr->argv [i] = listv [i]; + Tcl_IncrRefCount (word); + } + + i++; /* Skip placeholder for method */ + + rcPtr->argv [i] = id ; Tcl_IncrRefCount (id); + + /* The next two objects are kept empty, varying arguments */ + + /* Initialization complete */ + return rcPtr; +} + +/* + *---------------------------------------------------------------------- + * + * RcNewHandle -- + * + * This function is invoked to generate a channel handle for + * a new reflected channel. + * + * Results: + * A Tcl_Obj containing the string of the new channel handle. + * The refcount of the returned object is -- zero --. + * + * Side effects: + * May allocate memory. Mutex protected critical section + * locks out other threads for a short time. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj* +RcNewHandle () +{ + /* Count number of generated reflected channels. Used for id + * generation. Ids are never reclaimed and there is no dealing + * with wrap around. On the other hand, "unsigned long" should be + * big enough except for absolute longrunners (generate a 100 ids + * per second => overflow will occur in 1 1/3 years). + */ + +#ifdef TCL_THREADS + TCL_DECLARE_MUTEX (rcCounterMutex) +#endif + static unsigned long rcCounter = 0; + + Tcl_Obj* res = Tcl_NewObj (); + +#ifdef TCL_THREADS + Tcl_MutexLock (&rcCounterMutex); +#endif + + TclObjPrintf(NULL, res, "rc%lu", rcCounter); + rcCounter ++; + +#ifdef TCL_THREADS + Tcl_MutexUnlock (&rcCounterMutex); +#endif + + return res; +} + + +static void +RcFree (rcPtr) + ReflectingChannel* rcPtr; +{ + Channel* chanPtr = (Channel*) rcPtr->chan; + int i, n; + + if (chanPtr->typePtr != &tclRChannelType) { + /* Delete a cloned ChannelType structure. */ + ckfree ((char*) chanPtr->typePtr); + } + + n = rcPtr->argc - 2; + for (i = 0; i < n; i++) { + Tcl_DecrRefCount (rcPtr->argv[i]); + } + + ckfree ((char*) rcPtr->argv); + ckfree ((char*) rcPtr); + return; +} + +/* + *---------------------------------------------------------------------- + * + * RcInvokeTclMethod -- + * + * This function is used to invoke the Tcl level of a reflected + * channel. It handles all the command assembly, invokation, and + * generic state and result mgmt. + * + * Results: + * Result code and data as returned by the method. + * + * Side effects: + * Arbitrary, as it calls upo na Tcl script. + * + *---------------------------------------------------------------------- + */ + +static void +RcInvokeTclMethod (rcPtr, method, argone, argtwo, result, resultObj, capture) + ReflectingChannel* rcPtr; + CONST char* method; + Tcl_Obj* argone; /* NULL'able */ + Tcl_Obj* argtwo; /* NULL'able */ + int* result; /* NULL'able */ + Tcl_Obj** resultObj; /* NULL'able */ + int capture; +{ + /* Thread redirection was done by higher layers */ + /* ASSERT: Tcl_GetCurrentThread () == rcPtr->thread */ + + int cmdc; /* #words in constructed command */ + Tcl_Obj* methObj = NULL; /* Method name in object form */ + Tcl_InterpState sr; /* State of handler interp */ + int res; /* Result code of method invokation */ + Tcl_Obj* resObj = NULL; /* Result of method invokation. */ + + /* NOTE (5): Decide impl. issue: Cache objects with method names ? + * NOTE (5): Requires TSD data as reflections can be created in + * NOTE (5): many different threads. + * NOTE (5): --- + */ + + /* Insert method into the pre-allocated area, after the command + * prefix, before the channel id. + */ + + methObj = Tcl_NewStringObj (method, -1); + if (methObj == (Tcl_Obj*) NULL) { + Tcl_Panic ("Out of memory in RcInvokeTclMethod"); + } + Tcl_IncrRefCount (methObj); + rcPtr->argv [rcPtr->argc - 2] = methObj; + + /* Append the additional argument containing method specific + * details behind the channel id. If specified. + */ + + cmdc = rcPtr->argc ; + if (argone) { + Tcl_IncrRefCount (argone); + rcPtr->argv [cmdc] = argone; + cmdc++; + } + if (argtwo) { + Tcl_IncrRefCount (argtwo); + rcPtr->argv [cmdc] = argtwo; + cmdc++; + } + + /* And run the handler ... This is done in auch a manner which + * leaves any existing state intact. + */ + + sr = Tcl_SaveInterpState (rcPtr->interp, 0 /* Dummy */); + res = Tcl_EvalObjv (rcPtr->interp, cmdc, rcPtr->argv, TCL_EVAL_GLOBAL); + + /* We do not try to extract the result information if the caller has no + * interest in it. I.e. there is no need to put effort into creating + * something which is discarded immediately after. + */ + + if (resultObj) { + if ((res == TCL_OK) || !capture) { + /* Ok result taken as is, also if the caller requests that there + * is no capture. + */ + + resObj = Tcl_GetObjResult (rcPtr->interp); + } else { + /* Non-ok ressult is always treated as an error. + * We have to capture the full state of the result, + * including additional options. + */ + + res = TCL_ERROR; + resObj = RcErrorMarshall (rcPtr->interp); + } + Tcl_IncrRefCount(resObj); + } + Tcl_RestoreInterpState (rcPtr->interp, sr); + + /* ... */ + + /* Cleanup of the dynamic parts of the command */ + + Tcl_DecrRefCount (methObj); + if (argone) {Tcl_DecrRefCount (argone);} + if (argtwo) {Tcl_DecrRefCount (argtwo);} + + /* The resObj has a ref count of 1 at this location. This means + * that the caller of RcInvoke has to dispose of it (but only if + * it was returned to it). + */ + + if (result) { + *result = res; + } + if (resultObj) { + *resultObj = resObj; + } + /* There no need to handle the case where nothing is returned, because for + * that case resObj was not set anyway. + */ +} + +#ifdef TCL_THREADS +static void +RcForwardOp (rcPtr, op, dst, param) + ReflectingChannel* rcPtr; /* Channel instance */ + RcOperation op; /* Forwarded driver operation */ + Tcl_ThreadId dst; /* Destination thread */ + CONST VOID* param; /* Arguments */ +{ + RcForwardingEvent* evPtr; + RcForwardingResult* resultPtr; + int result; + + /* Create and initialize the event and data structures */ + + evPtr = (RcForwardingEvent*) ckalloc (sizeof (RcForwardingEvent)); + resultPtr = (RcForwardingResult*) ckalloc (sizeof (RcForwardingResult)); + + evPtr->event.proc = RcForwardProc; + evPtr->resultPtr = resultPtr; + evPtr->op = op; + evPtr->rcPtr = rcPtr; + evPtr->param = param; + + resultPtr->src = Tcl_GetCurrentThread (); + resultPtr->dst = dst; + resultPtr->done = (Tcl_Condition) NULL; + resultPtr->result = -1; + resultPtr->evPtr = evPtr; + + /* Now execute the forward */ + + Tcl_MutexLock(&rcForwardMutex); + TclSpliceIn(resultPtr, forwardList); + + /* + * Ensure cleanup of the event if any of the two involved threads + * exits while this event is pending or in progress. + */ + + Tcl_CreateThreadExitHandler(RcSrcExitProc, (ClientData) evPtr); + Tcl_CreateThreadExitHandler(RcDstExitProc, (ClientData) evPtr); + + /* + * Queue the event and poke the other thread's notifier. + */ + + Tcl_ThreadQueueEvent(dst, (Tcl_Event*)evPtr, TCL_QUEUE_TAIL); + Tcl_ThreadAlert(dst); + + /* + * (*) Block until the other thread has either processed the transfer + * or rejected it. + */ + + while (resultPtr->result < 0) { + /* NOTE (1): Is it possible that the current thread goes away while waiting here ? + * NOTE (1): IOW Is it possible that "RcSrcExitProc" is called while we are here ? + * NOTE (1): See complementary note (2) in "RcSrcExitProc" + * NOTE (1): --- + */ + + Tcl_ConditionWait(&resultPtr->done, &rcForwardMutex, NULL); + } + + /* + * Unlink result from the forwarder list. + */ + + TclSpliceOut(resultPtr, forwardList); + + resultPtr->nextPtr = NULL; + resultPtr->prevPtr = NULL; + + Tcl_MutexUnlock(&rcForwardMutex); + Tcl_ConditionFinalize(&resultPtr->done); + + /* + * Kill the cleanup handlers now, and the result structure as well, + * before returning the success code. + * + * Note: The event structure has already been deleted. + */ + + Tcl_DeleteThreadExitHandler(RcSrcExitProc, (ClientData) evPtr); + Tcl_DeleteThreadExitHandler(RcDstExitProc, (ClientData) evPtr); + + result = resultPtr->result; + ckfree ((char*) resultPtr); +} + +static int +RcForwardProc (evGPtr, mask) + Tcl_Event *evGPtr; + int mask; +{ + /* Notes regarding access to the referenced data. + * + * In principle the data belongs to the originating thread (see + * evPtr->src), however this thread is currently blocked at (*), + * i.e. quiescent. Because of this we can treat the data as + * belonging to us, without fear of race conditions. I.e. we can + * read and write as we like. + * + * The only thing we cannot be sure of is the resultPtr. This can be + * be NULLed if the originating thread went away while the event + * is handled here now. + */ + + RcForwardingEvent* evPtr = (RcForwardingEvent*) evGPtr; + RcForwardingResult* resultPtr = evPtr->resultPtr; + ReflectingChannel* rcPtr = evPtr->rcPtr; + Tcl_Interp* interp = rcPtr->interp; + RcForwardParamBase* paramPtr = (RcForwardParamBase*) evPtr->param; + int res = TCL_OK; /* Result code of RcInvokeTclMethod */ + Tcl_Obj* resObj = NULL; /* Interp result of RcInvokeTclMethod */ + + /* Ignore the event if no one is waiting for its result anymore. + */ + + if (!resultPtr) { + return 1; + } + + paramPtr->code = TCL_OK; + paramPtr->msg = NULL; + paramPtr->vol = 0; + + switch (evPtr->op) { + /* The destination thread for the following operations is + * rcPtr->thread, which contains rcPtr->interp, the interp + * we have to call upon for the driver. + */ + + case RcOpClose: + { + /* No parameters/results */ + RcInvokeTclMethod (rcPtr, "finalize", NULL, NULL, + &res, &resObj, DO_CAPTURE); + + if (res != TCL_OK) { + RcForwardSetObjError (paramPtr, resObj); + } + + /* Freeing is done here, in the origin thread, because the + * argv[] objects belong to this thread. Deallocating them + * in a different thread is not allowed + */ + + RcFree (rcPtr); + } + break; + + case RcOpInput: + { + RcForwardParamInput* p = (RcForwardParamInput*) paramPtr; + Tcl_Obj* toReadObj = Tcl_NewIntObj (p->toRead); + + if (toReadObj == (Tcl_Obj*) NULL) { + Tcl_Panic ("Out of memory in RcInput"); + } + + RcInvokeTclMethod (rcPtr, "read", toReadObj, NULL, + &res, &resObj, DO_CAPTURE); + + if (res != TCL_OK) { + RcForwardSetObjError (paramPtr, resObj); + p->toRead = -1; + } else { + /* Process a regular result. */ + + int bytec; /* Number of returned bytes */ + unsigned char* bytev; /* Array of returned bytes */ + + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); + + if (p->toRead < bytec) { + RcForwardSetStaticError (paramPtr, msg_read_toomuch); + p->toRead = -1; + + } else { + if (bytec > 0) { + memcpy (p->buf, bytev, bytec); + } + + p->toRead = bytec; + } + } + } + break; + + case RcOpOutput: + { + RcForwardParamOutput* p = (RcForwardParamOutput*) paramPtr; + Tcl_Obj* bufObj = Tcl_NewByteArrayObj((unsigned char*) p->buf, p->toWrite); + + if (bufObj == (Tcl_Obj*) NULL) { + Tcl_Panic ("Out of memory in RcOutput"); + } + + RcInvokeTclMethod (rcPtr, "write", bufObj, NULL, + &res, &resObj, DO_CAPTURE); + + if (res != TCL_OK) { + RcForwardSetObjError (paramPtr, resObj); + p->toWrite = -1; + } else { + /* Process a regular result. */ + + int written; + + res = Tcl_GetIntFromObj (interp, resObj, &written); + if (res != TCL_OK) { + + RcForwardSetObjError (paramPtr, RcErrorMarshall (interp)); + p->toWrite = -1; + + } else if ((written == 0) || (p->toWrite < written)) { + + RcForwardSetStaticError (paramPtr, msg_write_toomuch); + p->toWrite = -1; + + } else { + p->toWrite = written; + } + } + } + break; + + case RcOpSeek: + { + RcForwardParamSeek* p = (RcForwardParamSeek*) paramPtr; + + Tcl_Obj* offObj; + Tcl_Obj* baseObj; + + offObj = Tcl_NewWideIntObj(p->offset); + if (offObj == (Tcl_Obj*) NULL) { + Tcl_Panic ("Out of memory in RcSeekWide"); + } + + baseObj = Tcl_NewStringObj((p->seekMode == SEEK_SET) ? + "start" : + ((p->seekMode == SEEK_CUR) ? + "current" : + "end"), -1); + + if (baseObj == (Tcl_Obj*) NULL) { + Tcl_Panic ("Out of memory in RcSeekWide"); + } + + RcInvokeTclMethod (rcPtr, "seek", offObj, baseObj, + &res, &resObj, DO_CAPTURE); + + if (res != TCL_OK) { + RcForwardSetObjError (paramPtr, resObj); + p->offset = -1; + } else { + /* Process a regular result. If the type is wrong this + * may change into an error. + */ + + Tcl_WideInt newLoc; + res = Tcl_GetWideIntFromObj (interp, resObj, &newLoc); + + if (res == TCL_OK) { + if (newLoc < Tcl_LongAsWide (0)) { + RcForwardSetStaticError (paramPtr, msg_seek_beforestart); + p->offset = -1; + } else { + p->offset = newLoc; + } + } else { + RcForwardSetObjError (paramPtr, RcErrorMarshall (interp)); + p->offset = -1; + } + } + } + break; + + case RcOpWatch: + { + RcForwardParamWatch* p = (RcForwardParamWatch*) paramPtr; + + Tcl_Obj* maskObj = RcDecodeEventMask (p->mask); + RcInvokeTclMethod (rcPtr, "watch", maskObj, NULL, + NULL, NULL, NO_CAPTURE); + Tcl_DecrRefCount (maskObj); + } + break; + + case RcOpBlock: + { + RcForwardParamBlock* p = (RcForwardParamBlock*) evPtr->param; + Tcl_Obj* blockObj = Tcl_NewBooleanObj(!p->nonblocking); + + if (blockObj == (Tcl_Obj*) NULL) { + Tcl_Panic ("Out of memory in RcBlock"); + } + + RcInvokeTclMethod (rcPtr, "blocking", blockObj, NULL, + &res, &resObj, DO_CAPTURE); + + if (res != TCL_OK) { + RcForwardSetObjError (paramPtr, resObj); + } + } + break; + + case RcOpSetOpt: + { + RcForwardParamSetOpt* p = (RcForwardParamSetOpt*) paramPtr; + Tcl_Obj* optionObj; + Tcl_Obj* valueObj; + + optionObj = Tcl_NewStringObj(p->name,-1); + if (optionObj == (Tcl_Obj*) NULL) { + Tcl_Panic ("Out of memory in RcSetOption"); + } + + valueObj = Tcl_NewStringObj(p->value,-1); + if (valueObj == (Tcl_Obj*) NULL) { + Tcl_Panic ("Out of memory in RcSetOption"); + } + + RcInvokeTclMethod (rcPtr, "configure", optionObj, valueObj, + &res, &resObj, DO_CAPTURE); + + if (res != TCL_OK) { + RcForwardSetObjError (paramPtr, resObj); + } + } + break; + + case RcOpGetOpt: + { + /* Retrieve the value of one option */ + + RcForwardParamGetOpt* p = (RcForwardParamGetOpt*) paramPtr; + Tcl_Obj* optionObj; + + optionObj = Tcl_NewStringObj(p->name,-1); + if (optionObj == (Tcl_Obj*) NULL) { + Tcl_Panic ("Out of memory in RcGetOption"); + } + + RcInvokeTclMethod (rcPtr, "cget", optionObj, NULL, + &res, &resObj, DO_CAPTURE); + + if (res != TCL_OK) { + RcForwardSetObjError (paramPtr, resObj); + } else { + Tcl_DStringAppend (p->value, Tcl_GetString (resObj), -1); + } + } + break; + + case RcOpGetOptAll: + { + /* Retrieve all options. */ + + RcForwardParamGetOpt* p = (RcForwardParamGetOpt*) paramPtr; + + RcInvokeTclMethod (rcPtr, "cgetall", NULL, NULL, + &res, &resObj, DO_CAPTURE); + + if (res != TCL_OK) { + RcForwardSetObjError (paramPtr, resObj); + } else { + /* Extract list, validate that it is a list, and + * #elements. See NOTE (4) as well. + */ + + int listc; + Tcl_Obj** listv; + + res = Tcl_ListObjGetElements (interp, resObj, &listc, &listv); + if (res != TCL_OK) { + RcForwardSetObjError (paramPtr, RcErrorMarshall (interp)); + + } else if ((listc % 2) == 1) { + /* Odd number of elements is wrong. + * [x]. + */ + + char* buf = ckalloc (200); + sprintf (buf, + "{Expected list with even number of elements, got %d %s instead}", + listc, + (listc == 1 ? "element" : "elements")); + + RcForwardSetDynError (paramPtr, buf); + } else { + int len; + char* str = Tcl_GetStringFromObj (resObj, &len); + + if (len) { + Tcl_DStringAppend (p->value, " ", 1); + Tcl_DStringAppend (p->value, str, len); + } + } + } + } + break; + + default: + /* Bad operation code */ + Tcl_Panic ("Bad operation code in RcForwardProc"); + break; + } + + /* Remove the reference we held on the result of the invoke, if we had + * such + */ + if (resObj != NULL) { + Tcl_DecrRefCount (resObj); + } + + if (resultPtr) { + /* + * Report the forwarding result synchronously to the waiting + * caller. This unblocks (*) as well. This is wrapped into a + * conditional because the caller may have exited in the mean + * time. + */ + + Tcl_MutexLock(&rcForwardMutex); + resultPtr->result = TCL_OK; + Tcl_ConditionNotify(&resultPtr->done); + Tcl_MutexUnlock(&rcForwardMutex); + } + + return 1; +} + + +static void +RcSrcExitProc (clientData) + ClientData clientData; +{ + RcForwardingEvent* evPtr = (RcForwardingEvent*) clientData; + RcForwardingResult* resultPtr; + RcForwardParamBase* paramPtr; + + /* NOTE (2): Can this handler be called with the originator blocked ? + * NOTE (2): --- + */ + + /* The originator for the event exited. It is not sure if this + * can happen, as the originator should be blocked at (*) while + * the event is in transit/pending. + */ + + /* + * We make sure that the event cannot refer to the result anymore, + * remove it from the list of pending results and free the + * structure. Locking the access ensures that we cannot get in + * conflict with "RcForwardProc", should it already execute the + * event. + */ + + Tcl_MutexLock(&rcForwardMutex); + + resultPtr = evPtr->resultPtr; + paramPtr = (RcForwardParamBase*) evPtr->param; + + evPtr->resultPtr = NULL; + resultPtr->evPtr = NULL; + resultPtr->result = TCL_ERROR; + + RcForwardSetStaticError (paramPtr, msg_send_originlost); + + /* See below: TclSpliceOut(resultPtr, forwardList); */ + + Tcl_MutexUnlock(&rcForwardMutex); + + /* + * This unlocks (*). The structure will be spliced out and freed by + * "RcForwardProc". Maybe. + */ + + Tcl_ConditionNotify(&resultPtr->done); +} + + +static void +RcDstExitProc (clientData) + ClientData clientData; +{ + RcForwardingEvent* evPtr = (RcForwardingEvent*) clientData; + RcForwardingResult* resultPtr = evPtr->resultPtr; + RcForwardParamBase* paramPtr = (RcForwardParamBase*) evPtr->param; + + /* NOTE (3): It is not clear if the event still exists when this handler is called.. + * NOTE (3): We might have to use 'resultPtr' as our clientData instead. + * NOTE (3): --- + */ + + /* The receiver for the event exited, before processing the + * event. We detach the result now, wake the originator up + * and signal failure. + */ + + evPtr->resultPtr = NULL; + resultPtr->evPtr = NULL; + resultPtr->result = TCL_ERROR; + + RcForwardSetStaticError (paramPtr, msg_send_dstlost); + + Tcl_ConditionNotify(&resultPtr->done); +} + + +static void +RcForwardSetObjError (p,obj) + RcForwardParamBase* p; + Tcl_Obj* obj; +{ + int len; + char* msg; + + msg = Tcl_GetStringFromObj (obj, &len); + + p->code = TCL_ERROR; + p->vol = 1; + p->msg = strcpy(ckalloc (1+len), msg); +} +#endif + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclIOSock.c ================================================================== --- generic/tclIOSock.c +++ generic/tclIOSock.c @@ -1,33 +1,32 @@ -/* +/* * tclIOSock.c -- * * Common routines used by all socket based channel types. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOSock.c,v 1.8 2004/04/06 22:25:53 dgp Exp $ + * RCS: @(#) $Id: tclIOSock.c,v 1.8.2.1 2005/08/02 18:15:32 dgp Exp $ */ #include "tclInt.h" /* *--------------------------------------------------------------------------- * * TclSockGetPort -- * - * Maps from a string, which could be a service name, to a port. - * Used by socket creation code to get port numbers and resolve - * registered service names to port numbers. + * Maps from a string, which could be a service name, to a port. Used by + * socket creation code to get port numbers and resolve registered + * service names to port numbers. * * Results: - * A standard Tcl result. On success, the port number is returned - * in portPtr. On failure, an error message is left in the interp's - * result. + * A standard Tcl result. On success, the port number is returned in + * portPtr. On failure, an error message is left in the interp's result. * * Side effects: * None. * *--------------------------------------------------------------------------- @@ -46,11 +45,11 @@ if (Tcl_GetInt(NULL, string, portPtr) != TCL_OK) { /* * Don't bother translating 'proto' to native. */ - + native = Tcl_UtfToExternalDString(NULL, string, -1, &ds); sp = getservbyname(native, proto); /* INTL: Native. */ Tcl_DStringFree(&ds); if (sp != NULL) { *portPtr = ntohs((unsigned short) sp->s_port); @@ -59,12 +58,12 @@ } if (Tcl_GetInt(interp, string, portPtr) != TCL_OK) { return TCL_ERROR; } if (*portPtr > 0xFFFF) { - Tcl_AppendResult(interp, "couldn't open socket: port number too high", - (char *) NULL); + Tcl_AppendResult(interp, "couldn't open socket: port number too high", + (char *) NULL); return TCL_ERROR; } return TCL_OK; } @@ -104,5 +103,13 @@ len = sizeof(int); setsockopt(sock, SOL_SOCKET, SO_RCVBUF, (char *)&size, len); } return TCL_OK; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclIOUtil.c ================================================================== --- generic/tclIOUtil.c +++ generic/tclIOUtil.c @@ -1,65 +1,65 @@ -/* +/* * tclIOUtil.c -- * - * This file contains the implementation of Tcl's generic - * filesystem code, which supports a pluggable filesystem - * architecture allowing both platform specific filesystems and - * 'virtual filesystems'. All filesystem access should go through - * the functions defined in this file. Most of this code was - * contributed by Vince Darley. - * - * Parts of this file are based on code contributed by Karl - * Lehenbauer, Mark Diekhans and Peter da Silva. + * This file contains the implementation of Tcl's generic filesystem + * code, which supports a pluggable filesystem architecture allowing both + * platform specific filesystems and 'virtual filesystems'. All + * filesystem access should go through the functions defined in this + * file. Most of this code was contributed by Vince Darley. + * + * Parts of this file are based on code contributed by Karl Lehenbauer, + * Mark Diekhans and Peter da Silva. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 2001-2004 Vincent Darley. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOUtil.c,v 1.113 2004/11/17 00:31:47 dgp Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.113.2.7 2005/09/15 20:58:39 dgp Exp $ */ #include "tclInt.h" #ifdef __WIN32__ -#include "tclWinInt.h" +# include "tclWinInt.h" #endif #include "tclFileSystem.h" /* * Prototypes for procedures defined later in this file. */ static FilesystemRecord * FsGetFirstFilesystem _ANSI_ARGS_((void)); static void FsThrExitProc _ANSI_ARGS_((ClientData cd)); -static Tcl_Obj* FsListMounts _ANSI_ARGS_((Tcl_Obj *pathPtr, +static Tcl_Obj* FsListMounts _ANSI_ARGS_((Tcl_Obj *pathPtr, CONST char *pattern)); static void FsAddMountsToGlobResult _ANSI_ARGS_(( Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, - CONST char *pattern, + CONST char *pattern, Tcl_GlobTypeData *types)); -static void FsUpdateCwd _ANSI_ARGS_((Tcl_Obj *cwdObj, +static void FsUpdateCwd _ANSI_ARGS_((Tcl_Obj *cwdObj, ClientData clientData)); #ifdef TCL_THREADS static void FsRecacheFilesystemList(void); #endif -/* - * These form part of the native filesystem support. They are needed - * here because we have a few native filesystem functions (which are - * the same for win/unix) in this file. There is no need to place - * them in tclInt.h, because they are not (and should not be) used - * anywhere else. +/* + * These form part of the native filesystem support. They are needed here + * because we have a few native filesystem functions (which are the same for + * win/unix) in this file. There is no need to place them in tclInt.h, + * because they are not (and should not be) used anywhere else. */ + extern CONST char * tclpFileAttrStrings[]; extern CONST TclFileAttrProcs tclpFileAttrProcs[]; -/* - * The following functions are obsolete string based APIs, and should - * be removed in a future release (Tcl 9 would be a good time). +/* + * The following functions are obsolete string based APIs, and should be + * removed in a future release (Tcl 9 would be a good time). */ /* Obsolete */ int Tcl_Stat(path, oldStyleBuf) @@ -85,11 +85,11 @@ * Perform the result-buffer overflow check manually. * * Note that ino_t/ino64_t is unsigned... */ - if (OUT_OF_URANGE(buf.st_ino) || OUT_OF_RANGE(buf.st_size) + if (OUT_OF_URANGE(buf.st_ino) || OUT_OF_RANGE(buf.st_size) #ifdef HAVE_ST_BLOCKS || OUT_OF_RANGE(buf.st_blocks) #endif ) { #ifdef EFBIG @@ -107,69 +107,71 @@ # undef OUT_OF_RANGE # undef OUT_OF_URANGE #endif /* !TCL_WIDE_INT_IS_LONG */ /* - * Copy across all supported fields, with possible type - * coercions on those fields that change between the normal - * and lf64 versions of the stat structure (on Solaris at - * least.) This is slow when the structure sizes coincide, - * but that's what you get for using an obsolete interface. + * Copy across all supported fields, with possible type coercions on + * those fields that change between the normal and lf64 versions of + * the stat structure (on Solaris at least.) This is slow when the + * structure sizes coincide, but that's what you get for using an + * obsolete interface. */ - oldStyleBuf->st_mode = buf.st_mode; - oldStyleBuf->st_ino = (ino_t) buf.st_ino; - oldStyleBuf->st_dev = buf.st_dev; - oldStyleBuf->st_rdev = buf.st_rdev; - oldStyleBuf->st_nlink = buf.st_nlink; - oldStyleBuf->st_uid = buf.st_uid; - oldStyleBuf->st_gid = buf.st_gid; - oldStyleBuf->st_size = (off_t) buf.st_size; - oldStyleBuf->st_atime = buf.st_atime; - oldStyleBuf->st_mtime = buf.st_mtime; - oldStyleBuf->st_ctime = buf.st_ctime; + oldStyleBuf->st_mode = buf.st_mode; + oldStyleBuf->st_ino = (ino_t) buf.st_ino; + oldStyleBuf->st_dev = buf.st_dev; + oldStyleBuf->st_rdev = buf.st_rdev; + oldStyleBuf->st_nlink = buf.st_nlink; + oldStyleBuf->st_uid = buf.st_uid; + oldStyleBuf->st_gid = buf.st_gid; + oldStyleBuf->st_size = (off_t) buf.st_size; + oldStyleBuf->st_atime = buf.st_atime; + oldStyleBuf->st_mtime = buf.st_mtime; + oldStyleBuf->st_ctime = buf.st_ctime; #ifdef HAVE_ST_BLOCKS - oldStyleBuf->st_blksize = buf.st_blksize; - oldStyleBuf->st_blocks = (blkcnt_t) buf.st_blocks; + oldStyleBuf->st_blksize = buf.st_blksize; + oldStyleBuf->st_blocks = (blkcnt_t) buf.st_blocks; #endif } return ret; } /* Obsolete */ int Tcl_Access(path, mode) CONST char *path; /* Path of file to access (in current CP). */ - int mode; /* Permission setting. */ + int mode; /* Permission setting. */ { int ret; Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); + Tcl_IncrRefCount(pathPtr); ret = Tcl_FSAccess(pathPtr,mode); Tcl_DecrRefCount(pathPtr); + return ret; } /* Obsolete */ Tcl_Channel Tcl_OpenFileChannel(interp, path, modeString, permissions) - Tcl_Interp *interp; /* Interpreter for error reporting; - * can be NULL. */ - CONST char *path; /* Name of file to open. */ - CONST char *modeString; /* A list of POSIX open modes or - * a string such as "rw". */ - int permissions; /* If the open involves creating a - * file, with what modes to create - * it? */ + Tcl_Interp *interp; /* Interpreter for error reporting; can be + * NULL. */ + CONST char *path; /* Name of file to open. */ + CONST char *modeString; /* A list of POSIX open modes or a string such + * as "rw". */ + int permissions; /* If the open involves creating a file, with + * what modes to create it? */ { Tcl_Channel ret; Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); + Tcl_IncrRefCount(pathPtr); ret = Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions); Tcl_DecrRefCount(pathPtr); + return ret; - } /* Obsolete */ int Tcl_Chdir(dirName) @@ -214,32 +216,32 @@ ret = Tcl_FSEvalFile(interp, pathPtr); Tcl_DecrRefCount(pathPtr); return ret; } - -/* +/* * The 3 hooks for Stat, Access and OpenFileChannel are obsolete. The - * complete, general hooked filesystem APIs should be used instead. - * This define decides whether to include the obsolete hooks and - * related code. If these are removed, we'll also want to remove them - * from stubs/tclInt. The only known users of these APIs are prowrap - * and mktclapp. New code/extensions should not use them, since they - * do not provide as full support as the full filesystem API. - * - * As soon as prowrap and mktclapp are updated to use the full - * filesystem support, I suggest all these hooks are removed. + * complete, general hooked filesystem APIs should be used instead. This + * define decides whether to include the obsolete hooks and related code. If + * these are removed, we'll also want to remove them from stubs/tclInt. The + * only known users of these APIs are prowrap and mktclapp. New + * code/extensions should not use them, since they do not provide as full + * support as the full filesystem API. + * + * As soon as prowrap and mktclapp are updated to use the full filesystem + * support, I suggest all these hooks are removed. */ + #define USE_OBSOLETE_FS_HOOKS - #ifdef USE_OBSOLETE_FS_HOOKS + /* - * The following typedef declarations allow for hooking into the chain - * of functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' & - * 'Tcl_OpenFileChannel(...)'. Basically for each hookable function - * a linked list is defined. + * The following typedef declarations allow for hooking into the chain of + * functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' & + * 'Tcl_OpenFileChannel(...)'. Basically for each hookable function a linked + * list is defined. */ typedef struct StatProc { TclStatProc_ *proc; /* Function to process a 'stat()' call */ struct StatProc *nextPtr; /* The next 'stat()' function to call */ @@ -249,28 +251,26 @@ TclAccessProc_ *proc; /* Function to process a 'access()' call */ struct AccessProc *nextPtr; /* The next 'access()' function to call */ } AccessProc; typedef struct OpenFileChannelProc { - TclOpenFileChannelProc_ *proc; /* Function to process a - * 'Tcl_OpenFileChannel()' call */ + TclOpenFileChannelProc_ *proc; /* Function to process a + * 'Tcl_OpenFileChannel()' call */ struct OpenFileChannelProc *nextPtr; - /* The next 'Tcl_OpenFileChannel()' - * function to call */ + /* The next 'Tcl_OpenFileChannel()' + * function to call */ } OpenFileChannelProc; /* - * For each type of (obsolete) hookable function, a static node is - * declared to hold the function pointer for the "built-in" routine - * (e.g. 'TclpStat(...)') and the respective list is initialized as a - * pointer to that node. - * - * The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that - * these statically declared list entry cannot be inadvertently removed. - * - * This method avoids the need to call any sort of "initialization" - * function. + * For each type of (obsolete) hookable function, a static node is declared to + * hold the function pointer for the "built-in" routine (e.g. 'TclpStat(...)') + * and the respective list is initialized as a pointer to that node. + * + * The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that these + * statically declared list entry cannot be inadvertently removed. + * + * This method avoids the need to call any sort of "initialization" function. * * All three lists are protected by a global obsoleteFsHookMutex. */ static StatProc *statProcList = NULL; @@ -279,64 +279,64 @@ TCL_DECLARE_MUTEX(obsoleteFsHookMutex) #endif /* USE_OBSOLETE_FS_HOOKS */ -/* - * Declare the native filesystem support. These functions should - * be considered private to Tcl, and should really not be called - * directly by any code other than this file (i.e. neither by - * Tcl's core nor by extensions). Similarly, the old string-based - * Tclp... native filesystem functions should not be called. - * - * The correct API to use now is the Tcl_FS... set of functions, - * which ensure correct and complete virtual filesystem support. - * - * We cannot make all of these static, since some of them - * are implemented in the platform-specific directories. +/* + * Declare the native filesystem support. These functions should be + * considered private to Tcl, and should really not be called directly by any + * code other than this file (i.e. neither by Tcl's core nor by extensions). + * Similarly, the old string-based Tclp... native filesystem functions should + * not be called. + * + * The correct API to use now is the Tcl_FS... set of functions, which ensure + * correct and complete virtual filesystem support. + * + * We cannot make all of these static, since some of them are implemented in + * the platform-specific directories. */ + static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator; static Tcl_FSFreeInternalRepProc NativeFreeInternalRep; static Tcl_FSFileAttrStringsProc NativeFileAttrStrings; static Tcl_FSFileAttrsGetProc NativeFileAttrsGet; static Tcl_FSFileAttrsSetProc NativeFileAttrsSet; -/* - * The only reason these functions are not static is that they - * are either called by code in the native (win/unix) directories - * or they are actually implemented in those directories. They - * should simply not be called by code outside Tcl's native - * filesystem core. i.e. they should be considered 'static' to - * Tcl's filesystem code (if we ever built the native filesystem - * support into a separate code library, this could actually be - * enforced). +/* + * The only reason these functions are not static is that they are either + * called by code in the native (win/unix) directories or they are actually + * implemented in those directories. They should simply not be called by code + * outside Tcl's native filesystem core i.e. they should be considered + * 'static' to Tcl's filesystem code (if we ever built the native filesystem + * support into a separate code library, this could actually be enforced). */ + Tcl_FSFilesystemPathTypeProc TclpFilesystemPathType; Tcl_FSInternalToNormalizedProc TclpNativeToNormalized; Tcl_FSStatProc TclpObjStat; -Tcl_FSAccessProc TclpObjAccess; -Tcl_FSMatchInDirectoryProc TclpMatchInDirectory; -Tcl_FSChdirProc TclpObjChdir; -Tcl_FSLstatProc TclpObjLstat; -Tcl_FSCopyFileProc TclpObjCopyFile; -Tcl_FSDeleteFileProc TclpObjDeleteFile; -Tcl_FSRenameFileProc TclpObjRenameFile; -Tcl_FSCreateDirectoryProc TclpObjCreateDirectory; -Tcl_FSCopyDirectoryProc TclpObjCopyDirectory; -Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory; -Tcl_FSUnloadFileProc TclpUnloadFile; -Tcl_FSLinkProc TclpObjLink; -Tcl_FSListVolumesProc TclpObjListVolumes; - -/* - * Define the native filesystem dispatch table. If necessary, it - * is ok to make this non-static, but it should only be accessed - * by the functions actually listed within it (or perhaps other - * helper functions of them). Anything which is not part of this - * 'native filesystem implementation' should not be delving inside - * here! - */ +Tcl_FSAccessProc TclpObjAccess; +Tcl_FSMatchInDirectoryProc TclpMatchInDirectory; +Tcl_FSChdirProc TclpObjChdir; +Tcl_FSLstatProc TclpObjLstat; +Tcl_FSCopyFileProc TclpObjCopyFile; +Tcl_FSDeleteFileProc TclpObjDeleteFile; +Tcl_FSRenameFileProc TclpObjRenameFile; +Tcl_FSCreateDirectoryProc TclpObjCreateDirectory; +Tcl_FSCopyDirectoryProc TclpObjCopyDirectory; +Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory; +Tcl_FSUnloadFileProc TclpUnloadFile; +Tcl_FSLinkProc TclpObjLink; +Tcl_FSListVolumesProc TclpObjListVolumes; + +/* + * Define the native filesystem dispatch table. If necessary, it is ok to + * make this non-static, but it should only be accessed by the functions + * actually listed within it (or perhaps other helper functions of them). + * Anything which is not part of this 'native filesystem implementation' + * should not be delving inside here! + */ + Tcl_Filesystem tclNativeFilesystem = { "native", sizeof(Tcl_Filesystem), TCL_FILESYSTEM_VERSION_2, &TclNativePathInFilesystem, @@ -360,104 +360,117 @@ &TclpObjListVolumes, &NativeFileAttrStrings, &NativeFileAttrsGet, &NativeFileAttrsSet, &TclpObjCreateDirectory, - &TclpObjRemoveDirectory, + &TclpObjRemoveDirectory, &TclpObjDeleteFile, &TclpObjCopyFile, &TclpObjRenameFile, - &TclpObjCopyDirectory, + &TclpObjCopyDirectory, &TclpObjLstat, &TclpDlopen, /* Needs a cast since we're using version_2 */ (Tcl_FSGetCwdProc*)&TclpGetNativeCwd, &TclpObjChdir }; -/* - * Define the tail of the linked list. Note that for unconventional - * uses of Tcl without a native filesystem, we may in the future wish - * to modify the current approach of hard-coding the native filesystem - * in the lookup list 'filesystemList' below. - * - * We initialize the record so that it thinks one file uses it. This - * means it will never be freed. +/* + * Define the tail of the linked list. Note that for unconventional uses of + * Tcl without a native filesystem, we may in the future wish to modify the + * current approach of hard-coding the native filesystem in the lookup list + * 'filesystemList' below. + * + * We initialize the record so that it thinks one file uses it. This means it + * will never be freed. */ + static FilesystemRecord nativeFilesystemRecord = { NULL, &tclNativeFilesystem, 1, NULL }; -/* - * This is incremented each time we modify the linked list of - * filesystems. Any time it changes, all cached filesystem - * representations are suspect and must be freed. - * For multithreading builds, change of the filesystem epoch +/* + * This is incremented each time we modify the linked list of filesystems. + * Any time it changes, all cached filesystem representations are suspect and + * must be freed. For multithreading builds, change of the filesystem epoch * will trigger cache cleanup in all threads. */ + static int theFilesystemEpoch = 0; /* - * Stores the linked list of filesystems. A 1:1 copy of this - * list is also maintained in the TSD for each thread. This - * is to avoid synchronization issues. + * Stores the linked list of filesystems. A 1:1 copy of this list is also + * maintained in the TSD for each thread. This is to avoid synchronization + * issues. */ + static FilesystemRecord *filesystemList = &nativeFilesystemRecord; TCL_DECLARE_MUTEX(filesystemMutex) -/* +/* * Used to implement Tcl_FSGetCwd in a file-system independent way. */ + static Tcl_Obj* cwdPathPtr = NULL; static int cwdPathEpoch = 0; static ClientData cwdClientData = NULL; TCL_DECLARE_MUTEX(cwdMutex) Tcl_ThreadDataKey tclFsDataKey; -/* - * Declare fallback support function and - * information for Tcl_FSLoadFile +/* + * Declare fallback support function and information for Tcl_FSLoadFile */ + static Tcl_FSUnloadFileProc FSUnloadTempFile; /* - * One of these structures is used each time we successfully load a - * file from a file system by way of making a temporary copy of the - * file on the native filesystem. We need to store both the actual - * unloadProc/clientData combination which was used, and the original - * and modified filenames, so that we can correctly undo the entire - * operation when we want to unload the code. + * One of these structures is used each time we successfully load a file from + * a file system by way of making a temporary copy of the file on the native + * filesystem. We need to store both the actual unloadProc/clientData + * combination which was used, and the original and modified filenames, so + * that we can correctly undo the entire operation when we want to unload the + * code. */ + typedef struct FsDivertLoad { Tcl_LoadHandle loadHandle; - Tcl_FSUnloadFileProc *unloadProcPtr; + Tcl_FSUnloadFileProc *unloadProcPtr; Tcl_Obj *divertedFile; Tcl_Filesystem *divertedFilesystem; ClientData divertedFileNativeRep; } FsDivertLoad; - -/* Now move on to the basic filesystem implementation */ + +/* + * Now move on to the basic filesystem implementation + */ static void FsThrExitProc(cd) ClientData cd; { - ThreadSpecificData *tsdPtr = (ThreadSpecificData*)cd; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) cd; FilesystemRecord *fsRecPtr = NULL, *tmpFsRecPtr = NULL; - /* Trash the cwd copy */ + /* + * Trash the cwd copy. + */ + if (tsdPtr->cwdPathPtr != NULL) { Tcl_DecrRefCount(tsdPtr->cwdPathPtr); } if (tsdPtr->cwdClientData != NULL) { NativeFreeInternalRep(tsdPtr->cwdClientData); } - /* Trash the filesystems cache */ + + /* + * Trash the filesystems cache. + */ + fsRecPtr = tsdPtr->filesystemList; while (fsRecPtr != NULL) { tmpFsRecPtr = fsRecPtr->nextPtr; if (--fsRecPtr->fileRefCount <= 0) { ckfree((char *)fsRecPtr); @@ -465,11 +478,11 @@ fsRecPtr = tmpFsRecPtr; } } int -TclFSCwdIsNative() +TclFSCwdIsNative() { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); if (tsdPtr->cwdClientData != NULL) { return 1; @@ -481,27 +494,27 @@ /* *---------------------------------------------------------------------- * * TclFSCwdPointerEquals -- * - * Check whether the current working directory is equal to the - * path given. - * + * Check whether the current working directory is equal to the path + * given. + * * Results: * 1 (equal) or 0 (un-equal) as appropriate. * * Side effects: - * If the paths are equal, but are not the same object, this - * method will modify the given pathPtrPtr to refer to the same - * object. In this case the object pointed to by pathPtrPtr will - * have its refCount decremented, and it will be adjusted to - * point to the cwd (with a new refCount). + * If the paths are equal, but are not the same object, this method will + * modify the given pathPtrPtr to refer to the same object. In this case + * the object pointed to by pathPtrPtr will have its refCount + * decremented, and it will be adjusted to point to the cwd (with a new + * refCount). * *---------------------------------------------------------------------- */ -int +int TclFSCwdPointerEquals(pathPtrPtr) Tcl_Obj** pathPtrPtr; { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); @@ -512,16 +525,16 @@ Tcl_DecrRefCount(tsdPtr->cwdPathPtr); } if (tsdPtr->cwdClientData != NULL) { NativeFreeInternalRep(tsdPtr->cwdClientData); } - if (cwdPathPtr == NULL) { - tsdPtr->cwdPathPtr = NULL; - } else { - tsdPtr->cwdPathPtr = Tcl_DuplicateObj(cwdPathPtr); - Tcl_IncrRefCount(tsdPtr->cwdPathPtr); - } + if (cwdPathPtr == NULL) { + tsdPtr->cwdPathPtr = NULL; + } else { + tsdPtr->cwdPathPtr = Tcl_DuplicateObj(cwdPathPtr); + Tcl_IncrRefCount(tsdPtr->cwdPathPtr); + } if (cwdClientData == NULL) { tsdPtr->cwdClientData = NULL; } else { tsdPtr->cwdClientData = TclNativeDupInternalRep(cwdClientData); } @@ -528,30 +541,32 @@ tsdPtr->cwdPathEpoch = cwdPathEpoch; } Tcl_MutexUnlock(&cwdMutex); if (tsdPtr->initialized == 0) { - Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData)tsdPtr); + Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData) tsdPtr); tsdPtr->initialized = 1; } if (pathPtrPtr == NULL) { - return (tsdPtr->cwdPathPtr == NULL); + return (tsdPtr->cwdPathPtr == NULL); } - + if (tsdPtr->cwdPathPtr == *pathPtrPtr) { - return 1; + return 1; } else { int len1, len2; CONST char *str1, *str2; + str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); str2 = Tcl_GetStringFromObj(*pathPtrPtr, &len2); if (len1 == len2 && !strcmp(str1,str2)) { - /* - * They are equal, but different objects. Update so they - * will be the same object in the future. + /* + * They are equal, but different objects. Update so they will be + * the same object in the future. */ + Tcl_DecrRefCount(*pathPtrPtr); *pathPtrPtr = tsdPtr->cwdPathPtr; Tcl_IncrRefCount(*pathPtrPtr); return 1; } else { @@ -565,38 +580,44 @@ FsRecacheFilesystemList(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); FilesystemRecord *fsRecPtr, *tmpFsRecPtr = NULL; - /* Trash the current cache */ + /* + * Trash the current cache. + */ + fsRecPtr = tsdPtr->filesystemList; while (fsRecPtr != NULL) { - tmpFsRecPtr = fsRecPtr->nextPtr; + tmpFsRecPtr = fsRecPtr->nextPtr; if (--fsRecPtr->fileRefCount <= 0) { ckfree((char *)fsRecPtr); } fsRecPtr = tmpFsRecPtr; } tsdPtr->filesystemList = NULL; /* - * Code below operates on shared data. We - * are already called under mutex lock so - * we can safely proceede. + * Code below operates on shared data. We are already called under mutex + * lock so we can safely proceede. + * + * Locate tail of the global filesystem list. */ - /* Locate tail of the global filesystem list */ fsRecPtr = filesystemList; while (fsRecPtr != NULL) { tmpFsRecPtr = fsRecPtr; fsRecPtr = fsRecPtr->nextPtr; } - /* Refill the cache honouring the order */ + /* + * Refill the cache honouring the order. + */ + fsRecPtr = tmpFsRecPtr; while (fsRecPtr != NULL) { - tmpFsRecPtr = (FilesystemRecord *)ckalloc(sizeof(FilesystemRecord)); + tmpFsRecPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord)); *tmpFsRecPtr = *fsRecPtr; tmpFsRecPtr->nextPtr = tsdPtr->filesystemList; tmpFsRecPtr->prevPtr = NULL; if (tsdPtr->filesystemList) { tsdPtr->filesystemList->prevPtr = tmpFsRecPtr; @@ -603,13 +624,16 @@ } tsdPtr->filesystemList = tmpFsRecPtr; fsRecPtr = fsRecPtr->prevPtr; } - /* Make sure the above gets released on thread exit */ + /* + * Make sure the above gets released on thread exit. + */ + if (tsdPtr->initialized == 0) { - Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData)tsdPtr); + Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData) tsdPtr); tsdPtr->initialized = 1; } } #endif /* TCL_THREADS */ @@ -632,25 +656,27 @@ #endif return fsRecPtr; } /* - * The epoch can be changed both by filesystems being added or - * removed and by env(HOME) changing. + * The epoch can be changed both by filesystems being added or removed and by + * env(HOME) changing. */ + int -TclFSEpochOk (filesystemEpoch) - int filesystemEpoch; +TclFSEpochOk(filesystemEpoch) + int filesystemEpoch; { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); (void) FsGetFirstFilesystem(); return (filesystemEpoch == tsdPtr->filesystemEpoch); } -/* +/* * If non-NULL, clientData is owned by us and must be freed later. */ + static void FsUpdateCwd(cwdObj, clientData) Tcl_Obj *cwdObj; ClientData clientData; { @@ -662,39 +688,45 @@ str = Tcl_GetStringFromObj(cwdObj, &len); } Tcl_MutexLock(&cwdMutex); if (cwdPathPtr != NULL) { - Tcl_DecrRefCount(cwdPathPtr); + Tcl_DecrRefCount(cwdPathPtr); } if (cwdClientData != NULL) { NativeFreeInternalRep(cwdClientData); } + if (cwdObj == NULL) { cwdPathPtr = NULL; cwdClientData = NULL; } else { - /* This must be stored as string obj! */ - cwdPathPtr = Tcl_NewStringObj(str, len); + /* + * This must be stored as string obj! + */ + + cwdPathPtr = Tcl_NewStringObj(str, len); Tcl_IncrRefCount(cwdPathPtr); cwdClientData = TclNativeDupInternalRep(clientData); } + cwdPathEpoch++; tsdPtr->cwdPathEpoch = cwdPathEpoch; Tcl_MutexUnlock(&cwdMutex); if (tsdPtr->cwdPathPtr) { - Tcl_DecrRefCount(tsdPtr->cwdPathPtr); + Tcl_DecrRefCount(tsdPtr->cwdPathPtr); } if (tsdPtr->cwdClientData) { NativeFreeInternalRep(tsdPtr->cwdClientData); } + if (cwdObj == NULL) { tsdPtr->cwdPathPtr = NULL; tsdPtr->cwdClientData = NULL; } else { - tsdPtr->cwdPathPtr = Tcl_NewStringObj(str, len); + tsdPtr->cwdPathPtr = Tcl_NewStringObj(str, len); tsdPtr->cwdClientData = clientData; Tcl_IncrRefCount(tsdPtr->cwdPathPtr); } } @@ -703,14 +735,14 @@ * * TclFinalizeFilesystem -- * * Clean up the filesystem. After this, calls to all Tcl_FS... * functions will fail. - * - * We will later call TclResetFilesystem to restore the FS - * to a pristine state. - * + * + * We will later call TclResetFilesystem to restore the FS to a pristine + * state. + * * Results: * None. * * Side effects: * Frees any memory allocated by the filesystem. @@ -721,46 +753,49 @@ void TclFinalizeFilesystem() { FilesystemRecord *fsRecPtr; - /* - * Assumption that only one thread is active now. Otherwise - * we would need to put various mutexes around this code. + /* + * Assumption that only one thread is active now. Otherwise we would need + * to put various mutexes around this code. */ - + if (cwdPathPtr != NULL) { Tcl_DecrRefCount(cwdPathPtr); cwdPathPtr = NULL; - cwdPathEpoch = 0; + cwdPathEpoch = 0; } if (cwdClientData != NULL) { NativeFreeInternalRep(cwdClientData); cwdClientData = NULL; } - /* - * Remove all filesystems, freeing any allocated memory - * that is no longer needed + /* + * Remove all filesystems, freeing any allocated memory that is no longer + * needed */ fsRecPtr = filesystemList; while (fsRecPtr != NULL) { FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr; - if (fsRecPtr->fileRefCount <= 0) { - /* The native filesystem is static, so we don't free it */ - if (fsRecPtr != &nativeFilesystemRecord) { - ckfree((char *)fsRecPtr); - } - } - fsRecPtr = tmpFsRecPtr; + if (fsRecPtr->fileRefCount <= 0) { + /* + * The native filesystem is static, so we don't free it. + */ + + if (fsRecPtr != &nativeFilesystemRecord) { + ckfree((char *)fsRecPtr); + } + } + fsRecPtr = tmpFsRecPtr; } filesystemList = NULL; /* - * Now filesystemList is NULL. This means that any attempt - * to use the filesystem is likely to fail. + * Now filesystemList is NULL. This means that any attempt to use the + * filesystem is likely to fail. */ statProcList = NULL; accessProcList = NULL; openFileChannelProcList = NULL; @@ -773,11 +808,11 @@ *---------------------------------------------------------------------- * * TclResetFilesystem -- * * Restore the filesystem to a pristine state. - * + * * Results: * None. * * Side effects: * None. @@ -787,61 +822,60 @@ void TclResetFilesystem() { filesystemList = &nativeFilesystemRecord; - /* - * Note, at this point, I believe nativeFilesystemRecord -> - * fileRefCount should equal 1 and if not, we should try to track - * down the cause. + + /* + * Note, at this point, I believe nativeFilesystemRecord -> fileRefCount + * should equal 1 and if not, we should try to track down the cause. */ - + #ifdef __WIN32__ - /* - * Cleans up the win32 API filesystem proc lookup table. This must - * happen very late in finalization so that deleting of copied - * dlls can occur. + /* + * Cleans up the win32 API filesystem proc lookup table. This must happen + * very late in finalization so that deleting of copied dlls can occur. */ + TclWinResetInterfaces(); #endif } /* *---------------------------------------------------------------------- * * Tcl_FSRegister -- * - * Insert the filesystem function table at the head of the list of - * functions which are used during calls to all file-system - * operations. The filesystem will be added even if it is - * already in the list. (You can use Tcl_FSData to - * check if it is in the list, provided the ClientData used was - * not NULL). - * - * Note that the filesystem handling is head-to-tail of the list. - * Each filesystem is asked in turn whether it can handle a - * particular request, _until_ one of them says 'yes'. At that - * point no further filesystems are asked. - * - * In particular this means if you want to add a diagnostic - * filesystem (which simply reports all fs activity), it must be - * at the head of the list: i.e. it must be the last registered. + * Insert the filesystem function table at the head of the list of + * functions which are used during calls to all file-system operations. + * The filesystem will be added even if it is already in the list. (You + * can use Tcl_FSData to check if it is in the list, provided the + * ClientData used was not NULL). + * + * Note that the filesystem handling is head-to-tail of the list. Each + * filesystem is asked in turn whether it can handle a particular + * request, until one of them says 'yes'. At that point no further + * filesystems are asked. + * + * In particular this means if you want to add a diagnostic filesystem + * (which simply reports all fs activity), it must be at the head of the + * list: i.e. it must be the last registered. * * Results: - * Normally TCL_OK; TCL_ERROR if memory for a new node in the list - * could not be allocated. + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could + * not be allocated. * * Side effects: - * Memory allocated and modifies the link list for filesystems. + * Memory allocated and modifies the link list for filesystems. * *---------------------------------------------------------------------- */ int Tcl_FSRegister(clientData, fsPtr) - ClientData clientData; /* Client specific data for this fs */ - Tcl_Filesystem *fsPtr; /* The filesystem record for the new fs. */ + ClientData clientData; /* Client specific data for this fs */ + Tcl_Filesystem *fsPtr; /* The filesystem record for the new fs. */ { FilesystemRecord *newFilesystemPtr; if (fsPtr == NULL) { return TCL_ERROR; @@ -849,42 +883,45 @@ newFilesystemPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord)); newFilesystemPtr->clientData = clientData; newFilesystemPtr->fsPtr = fsPtr; - /* - * We start with a refCount of 1. If this drops to zero, then - * anyone is welcome to ckfree us. + + /* + * We start with a refCount of 1. If this drops to zero, then anyone is + * welcome to ckfree us. */ + newFilesystemPtr->fileRefCount = 1; - /* - * Is this lock and wait strictly speaking necessary? Since any - * iterators out there will have grabbed a copy of the head of - * the list and be iterating away from that, if we add a new - * element to the head of the list, it can't possibly have any - * effect on any of their loops. In fact it could be better not - * to wait, since we are adjusting the filesystem epoch, any - * cached representations calculated by existing iterators are + /* + * Is this lock and wait strictly speaking necessary? Since any iterators + * out there will have grabbed a copy of the head of the list and be + * iterating away from that, if we add a new element to the head of the + * list, it can't possibly have any effect on any of their loops. In fact + * it could be better not to wait, since we are adjusting the filesystem + * epoch, any cached representations calculated by existing iterators are * going to have to be thrown away anyway. - * - * However, since registering and unregistering filesystems is - * a very rare action, this is not a very important point. + * + * However, since registering and unregistering filesystems is a very rare + * action, this is not a very important point. */ + Tcl_MutexLock(&filesystemMutex); newFilesystemPtr->nextPtr = filesystemList; newFilesystemPtr->prevPtr = NULL; if (filesystemList) { - filesystemList->prevPtr = newFilesystemPtr; + filesystemList->prevPtr = newFilesystemPtr; } filesystemList = newFilesystemPtr; - /* - * Increment the filesystem epoch counter, since existing paths - * might conceivably now belong to different filesystems. + /* + * Increment the filesystem epoch counter, since existing paths might + * conceivably now belong to different filesystems. */ + theFilesystemEpoch++; Tcl_MutexUnlock(&filesystemMutex); return TCL_OK; } @@ -892,43 +929,42 @@ /* *---------------------------------------------------------------------- * * Tcl_FSUnregister -- * - * Remove the passed filesystem from the list of filesystem - * function tables. It also ensures that the built-in - * (native) filesystem is not removable, although we may wish - * to change that decision in the future to allow a smaller - * Tcl core, in which the native filesystem is not used at - * all (we could, say, initialise Tcl completely over a network - * connection). + * Remove the passed filesystem from the list of filesystem function + * tables. It also ensures that the built-in (native) filesystem is not + * removable, although we may wish to change that decision in the future + * to allow a smaller Tcl core, in which the native filesystem is not + * used at all (we could, say, initialise Tcl completely over a network + * connection). * * Results: - * TCL_OK if the procedure pointer was successfully removed, - * TCL_ERROR otherwise. + * TCL_OK if the procedure pointer was successfully removed, TCL_ERROR + * otherwise. * * Side effects: - * Memory may be deallocated (or will be later, once no "path" - * objects refer to this filesystem), but the list of registered - * filesystems is updated immediately. + * Memory may be deallocated (or will be later, once no "path" objects + * refer to this filesystem), but the list of registered filesystems is + * updated immediately. * *---------------------------------------------------------------------- */ int Tcl_FSUnregister(fsPtr) - Tcl_Filesystem *fsPtr; /* The filesystem record to remove. */ + Tcl_Filesystem *fsPtr; /* The filesystem record to remove. */ { int retVal = TCL_ERROR; FilesystemRecord *fsRecPtr; Tcl_MutexLock(&filesystemMutex); /* - * Traverse the 'filesystemList' looking for the particular node - * whose 'fsPtr' member matches 'fsPtr' and remove that one from - * the list. Ensure that the "default" node cannot be removed. + * Traverse the 'filesystemList' looking for the particular node whose + * 'fsPtr' member matches 'fsPtr' and remove that one from the list. + * Ensure that the "default" node cannot be removed. */ fsRecPtr = filesystemList; while ((retVal == TCL_ERROR) && (fsRecPtr != &nativeFilesystemRecord)) { if (fsRecPtr->fsPtr == fsPtr) { @@ -938,83 +974,83 @@ filesystemList = fsRecPtr->nextPtr; } if (fsRecPtr->nextPtr) { fsRecPtr->nextPtr->prevPtr = fsRecPtr->prevPtr; } - /* - * Increment the filesystem epoch counter, since existing - * paths might conceivably now belong to different - * filesystems. This should also ensure that paths which - * have cached the filesystem which is about to be deleted - * do not reference that filesystem (which would of course - * lead to memory exceptions). + + /* + * Increment the filesystem epoch counter, since existing paths + * might conceivably now belong to different filesystems. This + * should also ensure that paths which have cached the filesystem + * which is about to be deleted do not reference that filesystem + * (which would of course lead to memory exceptions). */ + theFilesystemEpoch++; - + fsRecPtr->fileRefCount--; if (fsRecPtr->fileRefCount <= 0) { - ckfree((char *)fsRecPtr); + ckfree((char *)fsRecPtr); } retVal = TCL_OK; } else { fsRecPtr = fsRecPtr->nextPtr; } } Tcl_MutexUnlock(&filesystemMutex); - return (retVal); + return retVal; } /* *---------------------------------------------------------------------- * * Tcl_FSMatchInDirectory -- * - * This routine is used by the globbing code to search a directory - * for all files which match a given pattern. The appropriate - * function for the filesystem to which pathPtr belongs will be - * called. If pathPtr does not belong to any filesystem and if it - * is NULL or the empty string, then we assume the pattern is to be - * matched in the current working directory. To avoid each - * filesystem's Tcl_FSMatchInDirectoryProc having to deal with this - * issue, we create a pathPtr on the fly (equal to the cwd), and - * then remove it from the results returned. This makes filesystems - * easy to write, since they can assume the pathPtr passed to them - * is an ordinary path. In fact this means we could remove such - * special case handling from Tcl's native filesystems. - * - * If 'pattern' is NULL, then pathPtr is assumed to be a fully - * specified path of a single file/directory which must be - * checked for existence and correct type. - * - * Results: - * - * The return value is a standard Tcl result indicating whether an - * error occurred in globbing. Error messages are placed in - * interp, but good results are placed in the resultPtr given. - * + * This routine is used by the globbing code to search a directory for + * all files which match a given pattern. The appropriate function for + * the filesystem to which pathPtr belongs will be called. If pathPtr + * does not belong to any filesystem and if it is NULL or the empty + * string, then we assume the pattern is to be matched in the current + * working directory. To avoid have the Tcl_FSMatchInDirectoryProc for + * each filesystem from having to deal with this issue, we create a + * pathPtr on the fly (equal to the cwd), and then remove it from the + * results returned. This makes filesystems easy to write, since they + * can assume the pathPtr passed to them is an ordinary path. In fact + * this means we could remove such special case handling from Tcl's + * native filesystems. + * + * If 'pattern' is NULL, then pathPtr is assumed to be a fully specified + * path of a single file/directory which must be checked for existence + * and correct type. + * + * Results: + * + * The return value is a standard Tcl result indicating whether an error + * occurred in globbing. Error messages are placed in interp, but good + * results are placed in the resultPtr given. + * * Recursive searches, e.g. - * - * glob -dir $dir -join * pkgIndex.tcl - * - * which must recurse through each directory matching '*' are - * handled internally by Tcl, by passing specific flags in a - * modified 'types' parameter. This means the actual filesystem - * only ever sees patterns which match in a single directory. + * glob -dir $dir -join * pkgIndex.tcl + * which must recurse through each directory matching '*' are handled + * internally by Tcl, by passing specific flags in a modified 'types' + * parameter. This means the actual filesystem only ever sees patterns + * which match in a single directory. * * Side effects: * The interpreter may have an error message inserted into it. * - *---------------------------------------------------------------------- + *---------------------------------------------------------------------- */ int Tcl_FSMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) - Tcl_Interp *interp; /* Interpreter to receive error messages. */ + Tcl_Interp *interp; /* Interpreter to receive error + * messages, but may be NULL. */ Tcl_Obj *resultPtr; /* List object to receive results. */ - Tcl_Obj *pathPtr; /* Contains path to directory to search. */ + Tcl_Obj *pathPtr; /* Contains path to directory to search. */ CONST char *pattern; /* Pattern to match against. */ Tcl_GlobTypeData *types; /* Object containing list of acceptable types. * May be NULL. In particular the directory * flag is very important. */ { @@ -1021,28 +1057,29 @@ Tcl_Filesystem *fsPtr; Tcl_Obj *cwd, *tmpResultPtr, **elemsPtr; int resLength, i, ret = -1; if (types != NULL && types->type & TCL_GLOB_TYPE_MOUNT) { - /* - * We don't currently allow querying of mounts by external code - * (a valuable future step), so since we're the only function - * that actually knows about mounts, this means we're being - * called recursively by ourself. Return no matches. + /* + * We don't currently allow querying of mounts by external code (a + * valuable future step), so since we're the only function that + * actually knows about mounts, this means we're being called + * recursively by ourself. Return no matches. */ + return TCL_OK; } - + if (pathPtr != NULL) { - fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); } else { fsPtr = NULL; } - + /* - * Check if we've successfully mapped the path to a filesystem - * within which to search. + * Check if we've successfully mapped the path to a filesystem within + * which to search. */ if (fsPtr != NULL) { if (fsPtr->matchInDirectoryProc == NULL) { Tcl_SetErrno(ENOENT); @@ -1054,29 +1091,28 @@ FsAddMountsToGlobResult(resultPtr, pathPtr, pattern, types); } return ret; } - /* - * If the path isn't empty, we have no idea how to match files in - * a directory which belongs to no known filesystem + /* + * If the path isn't empty, we have no idea how to match files in a + * directory which belongs to no known filesystem */ if (pathPtr != NULL && TclGetString(pathPtr)[0] != '\0') { Tcl_SetErrno(ENOENT); return -1; } - /* - * We have an empty or NULL path. This is defined to mean we - * must search for files within the current 'cwd'. We - * therefore use that, but then since the proc we call will - * return results which include the cwd we must then trim it - * off the front of each path in the result. We choose to deal - * with this here (in the generic code), since if we don't, - * every single filesystem's implementation of - * Tcl_FSMatchInDirectory will have to deal with it for us. + /* + * We have an empty or NULL path. This is defined to mean we must search + * for files within the current 'cwd'. We therefore use that, but then + * since the proc we call will return results which include the cwd we + * must then trim it off the front of each path in the result. We choose + * to deal with this here (in the generic code), since if we don't, every + * single filesystem's implementation of Tcl_FSMatchInDirectory will have + * to deal with it for us. */ cwd = Tcl_FSGetCwd(NULL); if (cwd == NULL) { if (interp != NULL) { @@ -1092,14 +1128,18 @@ Tcl_IncrRefCount(tmpResultPtr); ret = (*fsPtr->matchInDirectoryProc)(interp, tmpResultPtr, cwd, pattern, types); if (ret == TCL_OK) { FsAddMountsToGlobResult(tmpResultPtr, cwd, pattern, types); - /* Note that we know resultPtr and tmpResultPtr are distinct */ + + /* + * Note that we know resultPtr and tmpResultPtr are distinct. + */ + ret = Tcl_ListObjGetElements(interp, tmpResultPtr, &resLength, &elemsPtr); - for (i = 0; ret == TCL_OK && i < resLength; i++) { + for (i=0 ; ret==TCL_OK && ifsPtr == fsPtr) { retVal = fsRecPtr->clientData; @@ -1319,86 +1364,84 @@ /* *--------------------------------------------------------------------------- * * TclFSNormalizeToUniquePath -- * - * Description: - * Takes a path specification containing no ../, ./ sequences, - * and converts it into a unique path for the given platform. - * On Unix, this means the path must be free of - * symbolic links/aliases, and on Windows it means we want the - * long form, with that long form's case-dependence (which gives - * us a unique, case-dependent path). + * Takes a path specification containing no ../, ./ sequences, and + * converts it into a unique path for the given platform. On Unix, this + * means the path must be free of symbolic links/aliases, and on Windows + * it means we want the long form, with that long form's case-dependence + * (which gives us a unique, case-dependent path). * * Results: - * The pathPtr is modified in place. The return value is - * the last byte offset which was recognised in the path - * string. + * The pathPtr is modified in place. The return value is the last byte + * offset which was recognised in the path string. * * Side effects: * None (beyond the memory allocation for the result). * * Special notes: - * If the filesystem-specific normalizePathProcs can re-introduce - * ../, ./ sequences into the path, then this function will - * not return the correct result. This may be possible with - * symbolic links on unix. - * - * Important assumption: if startAt is non-zero, it must point - * to a directory separator that we know exists and is already - * normalized (so it is important not to point to the char just - * after the separator). + * If the filesystem-specific normalizePathProcs can re-introduce ../, ./ + * sequences into the path, then this function will not return the + * correct result. This may be possible with symbolic links on unix. + * + * Important assumption: if startAt is non-zero, it must point to a + * directory separator that we know exists and is already normalized (so + * it is important not to point to the char just after the separator). + * *--------------------------------------------------------------------------- */ + int TclFSNormalizeToUniquePath(interp, pathPtr, startAt, clientDataPtr) - Tcl_Interp *interp; /* Used for error messages. */ - Tcl_Obj *pathPtr; /* The path to normalize in place */ - int startAt; /* Start at this char-offset */ - ClientData *clientDataPtr; /* If we generated a complete - * normalized path for a given - * filesystem, we can optionally return - * an fs-specific clientdata here. */ + Tcl_Interp *interp; /* Used for error messages. */ + Tcl_Obj *pathPtr; /* The path to normalize in place */ + int startAt; /* Start at this char-offset */ + ClientData *clientDataPtr; /* If we generated a complete normalized path + * for a given filesystem, we can optionally + * return an fs-specific clientdata here. */ { FilesystemRecord *fsRecPtr, *firstFsRecPtr; /* Ignore this variable */ - (void)clientDataPtr; - + (void) clientDataPtr; + /* - * Call each of the "normalise path" functions in succession. This is - * a special case, in which if we have a native filesystem handler, - * we call it first. This is because the root of Tcl's filesystem - * is always a native filesystem (i.e. '/' on unix is native). + * Call each of the "normalise path" functions in succession. This is a + * special case, in which if we have a native filesystem handler, we call + * it first. This is because the root of Tcl's filesystem is always a + * native filesystem (i.e. '/' on unix is native). */ firstFsRecPtr = FsGetFirstFilesystem(); - fsRecPtr = firstFsRecPtr; + fsRecPtr = firstFsRecPtr; while (fsRecPtr != NULL) { - if (fsRecPtr == &nativeFilesystemRecord) { + if (fsRecPtr == &nativeFilesystemRecord) { Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc; if (proc != NULL) { startAt = (*proc)(interp, pathPtr, startAt); } break; - } + } fsRecPtr = fsRecPtr->nextPtr; } - + fsRecPtr = firstFsRecPtr; while (fsRecPtr != NULL) { - /* Skip the native system next time through */ + /* + * Skip the native system next time through. + */ + if (fsRecPtr != &nativeFilesystemRecord) { Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc; if (proc != NULL) { startAt = (*proc)(interp, pathPtr, startAt); } - /* + + /* * We could add an efficiency check like this: - * - * if (retVal == length-of(pathPtr)) {break;} - * + * if (retVal == length-of(pathPtr)) {break;} * but there's not much benefit. */ } fsRecPtr = fsRecPtr->nextPtr; } @@ -1409,111 +1452,161 @@ /* *--------------------------------------------------------------------------- * * TclGetOpenMode -- * - * Description: + * This routine is an obsolete, limited version of TclGetOpenModeEx() + * below. It exists only to satisfy any extensions imprudently using it + * via Tcl's internal stubs table. + * + * Results: + * Same as TclGetOpenModeEx(). + * + * Side effects: + * Same as TclGetOpenModeEx(). + * + *--------------------------------------------------------------------------- + */ + +int +TclGetOpenMode(interp, modeString, seekFlagPtr) + Tcl_Interp *interp; /* Interpreter to use for error + * reporting - may be NULL. */ + CONST char *modeString; /* Mode string, e.g. "r+" or "RDONLY + * CREAT". */ + int *seekFlagPtr; /* Set this to 1 if the caller should + * seek to EOF during the opening of + * the file. */ +{ + int binary = 0; + return TclGetOpenModeEx(interp, modeString, seekFlagPtr, &binary); +} + +/* + *--------------------------------------------------------------------------- + * + * TclGetOpenModeEx -- + * * Computes a POSIX mode mask for opening a file, from a given string, - * and also sets a flag to indicate whether the caller should seek to - * EOF after opening the file. + * and also sets flags to indicate whether the caller should seek to EOF + * after opening the file, and whether the caller should configure the + * channel for binary data. * * Results: * On success, returns mode to pass to "open". If an error occurs, the * return value is -1 and if interp is not NULL, sets interp's result * object to an error message. * * Side effects: - * Sets the integer referenced by seekFlagPtr to 1 to tell the caller - * to seek to EOF after opening the file. + * Sets the integer referenced by seekFlagPtr to 1 to tell the caller to + * seek to EOF after opening the file, or to 0 otherwise. Sets the + * integer referenced by binaryPtr to 1 to tell the caller to seek to + * configure the channel for binary data, or to 0 otherwise. * * Special note: - * This code is based on a prototype implementation contributed - * by Mark Diekhans. + * This code is based on a prototype implementation contributed by Mark + * Diekhans. * *--------------------------------------------------------------------------- */ int -TclGetOpenMode(interp, string, seekFlagPtr) +TclGetOpenModeEx(interp, modeString, seekFlagPtr, binaryPtr) Tcl_Interp *interp; /* Interpreter to use for error * reporting - may be NULL. */ - CONST char *string; /* Mode string, e.g. "r+" or - * "RDONLY CREAT". */ - int *seekFlagPtr; /* Set this to 1 if the caller - * should seek to EOF during the - * opening of the file. */ + CONST char *modeString; /* Mode string, e.g. "r+" or "RDONLY + * CREAT". */ + int *seekFlagPtr; /* Set this to 1 if the caller should + * seek to EOF during the opening of + * the file. */ + int *binaryPtr; /* Set this to 1 if the caller should + * configure the opened channel for + * binary operations */ { int mode, modeArgc, c, i, gotRW; CONST char **modeArgv, *flag; #define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR) /* - * Check for the simpler fopen-like access modes (e.g. "r"). They - * are distinguished from the POSIX access modes by the presence - * of a lower-case first letter. + * Check for the simpler fopen-like access modes (e.g. "r"). They are + * distinguished from the POSIX access modes by the presence of a + * lower-case first letter. */ *seekFlagPtr = 0; + *binaryPtr = 0; mode = 0; /* * Guard against international characters before using byte oriented * routines. */ - if (!(string[0] & 0x80) - && islower(UCHAR(string[0]))) { /* INTL: ISO only. */ - switch (string[0]) { - case 'r': - mode = O_RDONLY; - break; - case 'w': - mode = O_WRONLY|O_CREAT|O_TRUNC; - break; - case 'a': - mode = O_WRONLY|O_CREAT; - *seekFlagPtr = 1; - break; - default: - error: - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, - "illegal access mode \"", string, "\"", - (char *) NULL); - } - return -1; - } - if (string[1] == '+') { - mode &= ~(O_RDONLY|O_WRONLY); - mode |= O_RDWR; - if (string[2] != 0) { - goto error; - } - } else if (string[1] != 0) { - goto error; - } - return mode; - } - - /* - * The access modes are specified using a list of POSIX modes - * such as O_CREAT. - * - * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when - * a NULL interpreter is passed in. - */ - - if (Tcl_SplitList(interp, string, &modeArgc, &modeArgv) != TCL_OK) { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AddErrorInfo(interp, - "\n while processing open access modes \""); - Tcl_AddErrorInfo(interp, string); - Tcl_AddErrorInfo(interp, "\""); - } - return -1; - } - + if (!(modeString[0] & 0x80) + && islower(UCHAR(modeString[0]))) { /* INTL: ISO only. */ + switch (modeString[0]) { + case 'r': + mode = O_RDONLY; + break; + case 'w': + mode = O_WRONLY|O_CREAT|O_TRUNC; + break; + case 'a': + mode = O_WRONLY|O_CREAT; + *seekFlagPtr = 1; + break; + default: + error: + *seekFlagPtr = 0; + *binaryPtr = 0; + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "illegal access mode \"", modeString, + "\"", (char *) NULL); + } + return -1; + } + i=1; + while (i<3 && modeString[i]) { + if (modeString[i] == modeString[i-1]) { + goto error; + } + switch (modeString[i++]) { + case '+': + mode &= ~(O_RDONLY|O_WRONLY); + mode |= O_RDWR; + break; + case 'b': + *binaryPtr = 1; + break; + default: + goto error; + } + } + if (modeString[i] != 0) { + goto error; + } + return mode; + } + + /* + * The access modes are specified using a list of POSIX modes such as + * O_CREAT. + * + * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when a NULL + * interpreter is passed in. + */ + + if (Tcl_SplitList(interp, modeString, &modeArgc, &modeArgv) != TCL_OK) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AddErrorInfo(interp, + "\n while processing open access modes \""); + Tcl_AddErrorInfo(interp, modeString); + Tcl_AddErrorInfo(interp, "\""); + } + return -1; + } + gotRW = 0; for (i = 0; i < modeArgc; i++) { flag = modeArgv[i]; c = flag[0]; if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) { @@ -1525,65 +1618,78 @@ } else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) { mode = (mode & ~RW_MODES) | O_RDWR; gotRW = 1; } else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) { mode |= O_APPEND; - *seekFlagPtr = 1; + *seekFlagPtr = 1; } else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) { mode |= O_CREAT; } else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) { mode |= O_EXCL; + } else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) { #ifdef O_NOCTTY mode |= O_NOCTTY; #else if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "access mode \"", flag, - "\" not supported by this system", (char *) NULL); - } - ckfree((char *) modeArgv); + Tcl_AppendResult(interp, "access mode \"", flag, + "\" not supported by this system", (char *) NULL); + } + ckfree((char *) modeArgv); return -1; #endif + } else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) { #if defined(O_NDELAY) || defined(O_NONBLOCK) # ifdef O_NONBLOCK mode |= O_NONBLOCK; # else mode |= O_NDELAY; # endif + #else - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "access mode \"", flag, - "\" not supported by this system", (char *) NULL); - } - ckfree((char *) modeArgv); + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "access mode \"", flag, + "\" not supported by this system", (char *) NULL); + } + ckfree((char *) modeArgv); return -1; #endif + } else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) { mode |= O_TRUNC; + } else if ((c == 'B') && (strcmp(flag, "BINARY") == 0)) { + *binaryPtr = 1; } else { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "invalid access mode \"", flag, - "\": must be RDONLY, WRONLY, RDWR, APPEND, CREAT", - " EXCL, NOCTTY, NONBLOCK, or TRUNC", (char *) NULL); - } + + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "invalid access mode \"", flag, + "\": must be RDONLY, WRONLY, RDWR, APPEND, BINARY, " + "CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC", + (char *) NULL); + } ckfree((char *) modeArgv); return -1; } } + ckfree((char *) modeArgv); + if (!gotRW) { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "access mode must include either", - " RDONLY, WRONLY, or RDWR", (char *) NULL); - } + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "access mode must include either", + " RDONLY, WRONLY, or RDWR", (char *) NULL); + } return -1; } return mode; } -/* Tcl_FSEvalFile is Tcl_FSEvalFileEx without encoding argument */ +/* + * Tcl_FSEvalFile is Tcl_FSEvalFileEx without encoding argument. + */ + int Tcl_FSEvalFile(interp, pathPtr) Tcl_Interp *interp; /* Interpreter in which to process file. */ Tcl_Obj *pathPtr; /* Path of file to process. Tilde-substitution * will be performed on this name. */ @@ -1594,33 +1700,32 @@ /* *---------------------------------------------------------------------- * * Tcl_FSEvalFileEx -- * - * Read in a file and process the entire file as one gigantic - * Tcl command. + * Read in a file and process the entire file as one gigantic Tcl + * command. * * Results: - * A standard Tcl result, which is either the result of executing - * the file or an error indicating why the file couldn't be read. + * A standard Tcl result, which is either the result of executing the + * file or an error indicating why the file couldn't be read. * * Side effects: - * Depends on the commands in the file. During the evaluation - * of the contents of the file, iPtr->scriptFile is made to - * point to pathPtr (the old value is cached and replaced when - * this function returns). + * Depends on the commands in the file. During the evaluation of the + * contents of the file, iPtr->scriptFile is made to point to pathPtr + * (the old value is cached and replaced when this function returns). * *---------------------------------------------------------------------- */ int Tcl_FSEvalFileEx(interp, pathPtr, encodingName) Tcl_Interp *interp; /* Interpreter in which to process file. */ Tcl_Obj *pathPtr; /* Path of file to process. Tilde-substitution * will be performed on this name. */ - CONST char *encodingName; /* If non-NULL, then use this encoding - * for the file. */ + CONST char *encodingName; /* If non-NULL, then use this encoding for the + * file. */ { int result, length; Tcl_StatBuf statBuf; Tcl_Obj *oldScriptFile; Interp *iPtr; @@ -1634,92 +1739,91 @@ result = TCL_ERROR; objPtr = Tcl_NewObj(); if (Tcl_FSStat(pathPtr, &statBuf) == -1) { - Tcl_SetErrno(errno); - Tcl_AppendResult(interp, "couldn't read file \"", + Tcl_SetErrno(errno); + Tcl_AppendResult(interp, "couldn't read file \"", Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); if (chan == (Tcl_Channel) NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't read file \"", + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't read file \"", Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } + /* - * The eofchar is \32 (^Z). This is the usual on Windows, but we - * effect this cross-platform to allow for scripted documents. - * [Bug: 2040] + * The eofchar is \32 (^Z). This is the usual on Windows, but we effect + * this cross-platform to allow for scripted documents. [Bug: 2040] */ + Tcl_SetChannelOption(interp, chan, "-eofchar", "\32"); + /* - * If the encoding is specified, set it for the channel. - * Else don't touch it (and use the system encoding) - * Report error on unknown encoding. + * If the encoding is specified, set it for the channel. Else don't touch + * it (and use the system encoding) Report error on unknown encoding. */ + if (encodingName != NULL) { if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName) != TCL_OK) { Tcl_Close(interp,chan); goto end; } } + if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) { - Tcl_Close(interp, chan); - Tcl_AppendResult(interp, "couldn't read file \"", + Tcl_Close(interp, chan); + Tcl_AppendResult(interp, "couldn't read file \"", Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } + if (Tcl_Close(interp, chan) != TCL_OK) { - goto end; + goto end; } iPtr = (Interp *) interp; oldScriptFile = iPtr->scriptFile; iPtr->scriptFile = pathPtr; Tcl_IncrRefCount(iPtr->scriptFile); string = Tcl_GetStringFromObj(objPtr, &length); result = Tcl_EvalEx(interp, string, length, 0); - /* + + /* * Now we have to be careful; the script may have changed the - * iPtr->scriptFile value, so we must reset it without - * assuming it still points to 'pathPtr'. + * iPtr->scriptFile value, so we must reset it without assuming it still + * points to 'pathPtr'. */ + if (iPtr->scriptFile != NULL) { Tcl_DecrRefCount(iPtr->scriptFile); } iPtr->scriptFile = oldScriptFile; if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } else if (result == TCL_ERROR) { - /* * Record information telling where the error occurred. */ - - Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine); - Tcl_Obj *msg = Tcl_NewStringObj("\n (file \"", -1); CONST char *pathString = Tcl_GetStringFromObj(pathPtr, &length); - Tcl_IncrRefCount(msg); - Tcl_IncrRefCount(errorLine); - TclAppendLimitedToObj(msg, pathString, length, 150, ""); - Tcl_AppendToObj(msg, "\" line ", -1); - Tcl_AppendObjToObj(msg, errorLine); - Tcl_DecrRefCount(errorLine); - Tcl_AppendToObj(msg, ")", -1); - TclAppendObjToErrorInfo(interp, msg); - Tcl_DecrRefCount(msg); + int limit = 150; + int overflow = (length > limit); + + TclFormatToErrorInfo(interp, "\n (file \"%.*s%s\" line %d)", + (overflow ? limit : length), pathString, + (overflow ? "..." : ""), interp->errorLine); } - end: + end: Tcl_DecrRefCount(objPtr); return result; } /* @@ -1726,19 +1830,19 @@ *---------------------------------------------------------------------- * * Tcl_GetErrno -- * * Gets the current value of the Tcl error code variable. This is - * currently the global variable "errno" but could in the future - * change to something else. + * currently the global variable "errno" but could in the future change + * to something else. * * Results: * The value of the Tcl error code variable. * * Side effects: - * None. Note that the value of the Tcl error code variable is - * UNDEFINED if a call to Tcl_SetErrno did not precede this call. + * None. Note that the value of the Tcl error code variable is UNDEFINED + * if a call to Tcl_SetErrno did not precede this call. * *---------------------------------------------------------------------- */ int @@ -1773,28 +1877,27 @@ /* *---------------------------------------------------------------------- * * Tcl_PosixError -- * - * This procedure is typically called after UNIX kernel calls - * return errors. It stores machine-readable information about - * the error in errorCode field of interp and returns an - * information string for the caller's use. + * This procedure is typically called after UNIX kernel calls return + * errors. It stores machine-readable information about the error in + * errorCode field of interp and returns an information string for the + * caller's use. * * Results: - * The return value is a human-readable string describing the - * error. + * The return value is a human-readable string describing the error. * * Side effects: * The errorCode field of the interp is set. * *---------------------------------------------------------------------- */ CONST char * Tcl_PosixError(interp) - Tcl_Interp *interp; /* Interpreter whose errorCode field + Tcl_Interp *interp; /* Interpreter whose errorCode field * is to be set. */ { CONST char *id, *msg; msg = Tcl_ErrnoMsg(errno); @@ -1807,19 +1910,19 @@ *---------------------------------------------------------------------- * * Tcl_FSStat -- * * This procedure replaces the library version of stat and lsat. - * - * The appropriate function for the filesystem to which pathPtr - * belongs will be called. + * + * The appropriate function for the filesystem to which pathPtr belongs + * will be called. * * Results: - * See stat documentation. + * See stat documentation. * * Side effects: - * See stat documentation. + * See stat documentation. * *---------------------------------------------------------------------- */ int @@ -1831,16 +1934,16 @@ #ifdef USE_OBSOLETE_FS_HOOKS struct stat oldStyleStatBuffer; int retVal = -1; /* - * Call each of the "stat" function in succession. A non-return - * value of -1 indicates the particular function has succeeded. + * Call each of the "stat" function in succession. A non-return value of + * -1 indicates the particular function has succeeded. */ Tcl_MutexLock(&obsoleteFsHookMutex); - + if (statProcList != NULL) { StatProc *statProcPtr; char *path; Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); if (transPtr == NULL) { @@ -1856,17 +1959,18 @@ } if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } } - + Tcl_MutexUnlock(&obsoleteFsHookMutex); if (retVal != -1) { /* - * Note that EOVERFLOW is not a problem here, and these - * assignments should all be widening (if not identity.) + * Note that EOVERFLOW is not a problem here, and these assignments + * should all be widening (if not identity.) */ + buf->st_mode = oldStyleStatBuffer.st_mode; buf->st_ino = oldStyleStatBuffer.st_ino; buf->st_dev = oldStyleStatBuffer.st_dev; buf->st_rdev = oldStyleStatBuffer.st_rdev; buf->st_nlink = oldStyleStatBuffer.st_nlink; @@ -1878,13 +1982,14 @@ buf->st_ctime = oldStyleStatBuffer.st_ctime; #ifdef HAVE_ST_BLOCKS buf->st_blksize = oldStyleStatBuffer.st_blksize; buf->st_blocks = Tcl_LongAsWide(oldStyleStatBuffer.st_blocks); #endif - return retVal; + return retVal; } #endif /* USE_OBSOLETE_FS_HOOKS */ + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { Tcl_FSStatProc *proc = fsPtr->statProc; if (proc != NULL) { return (*proc)(pathPtr, buf); @@ -1897,21 +2002,20 @@ /* *---------------------------------------------------------------------- * * Tcl_FSLstat -- * - * This procedure replaces the library version of lstat. - * The appropriate function for the filesystem to which pathPtr - * belongs will be called. If no 'lstat' function is listed, - * but a 'stat' function is, then Tcl will fall back on the - * stat function. + * This procedure replaces the library version of lstat. The appropriate + * function for the filesystem to which pathPtr belongs will be called. + * If no 'lstat' function is listed, but a 'stat' function is, then Tcl + * will fall back on the stat function. * * Results: - * See lstat documentation. + * See lstat documentation. * * Side effects: - * See lstat documentation. + * See lstat documentation. * *---------------------------------------------------------------------- */ int @@ -1938,35 +2042,35 @@ /* *---------------------------------------------------------------------- * * Tcl_FSAccess -- * - * This procedure replaces the library version of access. - * The appropriate function for the filesystem to which pathPtr - * belongs will be called. + * This procedure replaces the library version of access. The + * appropriate function for the filesystem to which pathPtr belongs will + * be called. * * Results: - * See access documentation. + * See access documentation. * * Side effects: - * See access documentation. + * See access documentation. * *---------------------------------------------------------------------- */ int Tcl_FSAccess(pathPtr, mode) Tcl_Obj *pathPtr; /* Path of file to access (in current CP). */ - int mode; /* Permission setting. */ + int mode; /* Permission setting. */ { Tcl_Filesystem *fsPtr; #ifdef USE_OBSOLETE_FS_HOOKS int retVal = -1; /* - * Call each of the "access" function in succession. A non-return - * value of -1 indicates the particular function has succeeded. + * Call each of the "access" function in succession. A non-return value + * of -1 indicates the particular function has succeeded. */ Tcl_MutexLock(&obsoleteFsHookMutex); if (accessProcList != NULL) { @@ -1986,16 +2090,17 @@ } if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } } - + Tcl_MutexUnlock(&obsoleteFsHookMutex); if (retVal != -1) { return retVal; } #endif /* USE_OBSOLETE_FS_HOOKS */ + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { Tcl_FSAccessProc *proc = fsPtr->accessProc; if (proc != NULL) { return (*proc)(pathPtr, mode); @@ -2009,61 +2114,59 @@ /* *---------------------------------------------------------------------- * * Tcl_FSOpenFileChannel -- * - * The appropriate function for the filesystem to which pathPtr - * belongs will be called. + * The appropriate function for the filesystem to which pathPtr belongs + * will be called. * * Results: * The new channel or NULL, if the named file could not be opened. * * Side effects: - * May open the channel and may cause creation of a file on the - * file system. + * May open the channel and may cause creation of a file on the file + * system. * *---------------------------------------------------------------------- */ - + Tcl_Channel Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) - Tcl_Interp *interp; /* Interpreter for error reporting; - * can be NULL. */ - Tcl_Obj *pathPtr; /* Name of file to open. */ - CONST char *modeString; /* A list of POSIX open modes or - * a string such as "rw". */ - int permissions; /* If the open involves creating a - * file, with what modes to create - * it? */ + Tcl_Interp *interp; /* Interpreter for error reporting; can be + * NULL. */ + Tcl_Obj *pathPtr; /* Name of file to open. */ + CONST char *modeString; /* A list of POSIX open modes or a string such + * as "rw". */ + int permissions; /* If the open involves creating a file, with + * what modes to create it? */ { Tcl_Filesystem *fsPtr; #ifdef USE_OBSOLETE_FS_HOOKS Tcl_Channel retVal = NULL; /* - * Call each of the "Tcl_OpenFileChannel" functions in succession. - * A non-NULL return value indicates the particular function has - * succeeded. + * Call each of the "Tcl_OpenFileChannel" functions in succession. A + * non-NULL return value indicates the particular function has succeeded. */ Tcl_MutexLock(&obsoleteFsHookMutex); if (openFileChannelProcList != NULL) { OpenFileChannelProc *openFileChannelProcPtr; char *path; Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr); - + if (transPtr == NULL) { path = NULL; } else { path = Tcl_GetString(transPtr); } openFileChannelProcPtr = openFileChannelProcList; - + while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) { retVal = (*openFileChannelProcPtr->proc)(interp, path, - modeString, permissions); + modeString, permissions); openFileChannelProcPtr = openFileChannelProcPtr->nextPtr; } if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } @@ -2071,80 +2174,89 @@ Tcl_MutexUnlock(&obsoleteFsHookMutex); if (retVal != NULL) { return retVal; } #endif /* USE_OBSOLETE_FS_HOOKS */ - - /* - * We need this just to ensure we return the correct error messages - * under some circumstances. + + /* + * We need this just to ensure we return the correct error messages under + * some circumstances. */ + if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) { - return NULL; + return NULL; } - + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc; if (proc != NULL) { - int mode, seekFlag; - mode = TclGetOpenMode(interp, modeString, &seekFlag); + int mode, seekFlag, binary; + + mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary); if (mode == -1) { - return NULL; + return NULL; } + retVal = (*proc)(interp, pathPtr, mode, permissions); if (retVal != NULL) { if (seekFlag) { - if (Tcl_Seek(retVal, (Tcl_WideInt)0, - SEEK_END) < (Tcl_WideInt)0) { + if (Tcl_Seek(retVal, (Tcl_WideInt)0, + SEEK_END) < (Tcl_WideInt)0) { if (interp != (Tcl_Interp *) NULL) { Tcl_AppendResult(interp, "could not seek to end of file while opening \"", - Tcl_GetString(pathPtr), "\": ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_GetString(pathPtr), "\": ", + Tcl_PosixError(interp), (char *) NULL); } Tcl_Close(NULL, retVal); return NULL; } } + if (binary) { + Tcl_SetChannelOption(interp, retVal, + "-translation", "binary"); + } } return retVal; } } - /* File doesn't belong to any filesystem that can open it */ + + /* + * File doesn't belong to any filesystem that can open it. + */ + Tcl_SetErrno(ENOENT); if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't open \"", - Tcl_GetString(pathPtr), "\": ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_AppendResult(interp, "couldn't open \"", Tcl_GetString(pathPtr), + "\": ", Tcl_PosixError(interp), (char *) NULL); } return NULL; } /* *---------------------------------------------------------------------- * * Tcl_FSUtime -- * - * This procedure replaces the library version of utime. - * The appropriate function for the filesystem to which pathPtr - * belongs will be called. + * This procedure replaces the library version of utime. The appropriate + * function for the filesystem to which pathPtr belongs will be called. * * Results: - * See utime documentation. + * See utime documentation. * * Side effects: - * See utime documentation. + * See utime documentation. * *---------------------------------------------------------------------- */ -int -Tcl_FSUtime (pathPtr, tval) - Tcl_Obj *pathPtr; /* File to change access/modification times */ - struct utimbuf *tval; /* Structure containing access/modification - * times to use. Should not be modified. */ +int +Tcl_FSUtime(pathPtr, tval) + Tcl_Obj *pathPtr; /* File to change access/modification times */ + struct utimbuf *tval; /* Structure containing access/modification + * times to use. Should not be modified. */ { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { Tcl_FSUtimeProc *proc = fsPtr->utimeProc; if (proc != NULL) { @@ -2157,21 +2269,21 @@ /* *---------------------------------------------------------------------- * * NativeFileAttrStrings -- * - * This procedure implements the platform dependent 'file - * attributes' subcommand, for the native filesystem, for listing - * the set of possible attribute strings. This function is part - * of Tcl's native filesystem support, and is placed here because - * it is shared by Unix and Windows code. + * This procedure implements the platform dependent 'file attributes' + * subcommand, for the native filesystem, for listing the set of possible + * attribute strings. This function is part of Tcl's native filesystem + * support, and is placed here because it is shared by Unix and Windows + * code. * * Results: - * An array of strings + * An array of strings * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ static CONST char** @@ -2185,25 +2297,23 @@ /* *---------------------------------------------------------------------- * * NativeFileAttrsGet -- * - * This procedure implements the platform dependent - * 'file attributes' subcommand, for the native - * filesystem, for 'get' operations. This function is part - * of Tcl's native filesystem support, and is placed here - * because it is shared by Unix and Windows code. + * This procedure implements the platform dependent 'file attributes' + * subcommand, for the native filesystem, for 'get' operations. This + * function is part of Tcl's native filesystem support, and is placed + * here because it is shared by Unix and Windows code. * * Results: - * Standard Tcl return code. The object placed in objPtrRef - * (if TCL_OK was returned) is likely to have a refCount of zero. - * Either way we must either store it somewhere (e.g. the Tcl - * result), or Incr/Decr its refCount to ensure it is properly - * freed. + * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK + * was returned) is likely to have a refCount of zero. Either way we + * must either store it somewhere (e.g. the Tcl result), or Incr/Decr its + * refCount to ensure it is properly freed. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ static int @@ -2211,30 +2321,29 @@ Tcl_Interp *interp; /* The interpreter for error reporting. */ int index; /* index of the attribute command. */ Tcl_Obj *pathPtr; /* path of file we are operating on. */ Tcl_Obj **objPtrRef; /* for output. */ { - return (*tclpFileAttrProcs[index].getProc)(interp, index, - pathPtr, objPtrRef); + return (*tclpFileAttrProcs[index].getProc)(interp, index, pathPtr, + objPtrRef); } /* *---------------------------------------------------------------------- * * NativeFileAttrsSet -- * - * This procedure implements the platform dependent - * 'file attributes' subcommand, for the native - * filesystem, for 'set' operations. This function is part - * of Tcl's native filesystem support, and is placed here - * because it is shared by Unix and Windows code. + * This procedure implements the platform dependent 'file attributes' + * subcommand, for the native filesystem, for 'set' operations. This + * function is part of Tcl's native filesystem support, and is placed + * here because it is shared by Unix and Windows code. * * Results: - * Standard Tcl return code. + * Standard Tcl return code. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ static int @@ -2242,43 +2351,41 @@ Tcl_Interp *interp; /* The interpreter for error reporting. */ int index; /* index of the attribute command. */ Tcl_Obj *pathPtr; /* path of file we are operating on. */ Tcl_Obj *objPtr; /* set to this value. */ { - return (*tclpFileAttrProcs[index].setProc)(interp, index, - pathPtr, objPtr); + return (*tclpFileAttrProcs[index].setProc)(interp, index, pathPtr, objPtr); } /* *---------------------------------------------------------------------- * * Tcl_FSFileAttrStrings -- * - * This procedure implements part of the hookable 'file - * attributes' subcommand. The appropriate function for the - * filesystem to which pathPtr belongs will be called. + * This procedure implements part of the hookable 'file attributes' + * subcommand. The appropriate function for the filesystem to which + * pathPtr belongs will be called. * * Results: - * The called procedure may either return an array of strings, - * or may instead return NULL and place a Tcl list into the - * given objPtrRef. Tcl will take that list and first increment - * its refCount before using it. On completion of that use, Tcl - * will decrement its refCount. Hence if the list should be - * disposed of by Tcl when done, it should have a refCount of zero, - * and if the list should not be disposed of, the filesystem - * should ensure it retains a refCount on the object. + * The called procedure may either return an array of strings, or may + * instead return NULL and place a Tcl list into the given objPtrRef. + * Tcl will take that list and first increment its refCount before using + * it. On completion of that use, Tcl will decrement its refCount. Hence + * if the list should be disposed of by Tcl when done, it should have a + * refCount of zero, and if the list should not be disposed of, the + * filesystem should ensure it retains a refCount on the object. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ CONST char ** Tcl_FSFileAttrStrings(pathPtr, objPtrRef) - Tcl_Obj* pathPtr; - Tcl_Obj** objPtrRef; + Tcl_Obj *pathPtr; + Tcl_Obj **objPtrRef; { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { Tcl_FSFileAttrStringsProc *proc = fsPtr->fileAttrStringsProc; if (proc != NULL) { @@ -2290,26 +2397,101 @@ } /* *---------------------------------------------------------------------- * + * TclFSFileAttrIndex -- + * + * Helper function for converting an attribute name to an index into the + * attribute table. + * + * Results: + * Tcl result code, index written to *indexPtr on result==TCL_OK + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclFSFileAttrIndex(pathPtr, attributeName, indexPtr) + Tcl_Obj *pathPtr; /* File whose attributes are to be + * indexed into. */ + CONST char *attributeName; /* The attribute being looked for. */ + int *indexPtr; /* Where to write the found index. */ +{ + Tcl_Obj *listObj = NULL; + CONST char **attrTable; + + /* + * Get the attribute table for the file. + */ + + attrTable = Tcl_FSFileAttrStrings(pathPtr, &listObj); + if (listObj != NULL) { + Tcl_IncrRefCount(listObj); + } + + if (attrTable != NULL) { + /* + * It's a constant attribute table, so use T_GIFO. + */ + + Tcl_Obj *tmpObj = Tcl_NewStringObj(attributeName, -1); + int result; + + result = Tcl_GetIndexFromObj(NULL, tmpObj, attrTable, NULL, TCL_EXACT, + indexPtr); + TclDecrRefCount(tmpObj); + if (listObj != NULL) { + TclDecrRefCount(listObj); + } + return result; + } else if (listObj != NULL) { + /* + * It's a non-constant attribute list, so do a literal search. + */ + + int i, objc; + Tcl_Obj **objv; + + if (Tcl_ListObjGetElements(NULL, listObj, &objc, &objv) != TCL_OK) { + TclDecrRefCount(listObj); + return TCL_ERROR; + } + for (i=0 ; ifsPtr->getCwdProc; if (proc != NULL) { if (fsRecPtr->fsPtr->version != TCL_FILESYSTEM_VERSION_1) { ClientData retCd; TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)proc; - + retCd = (*proc2)(NULL); if (retCd != NULL) { Tcl_Obj *norm; /* Looks like a new current directory */ - retVal = (*fsRecPtr->fsPtr->internalToNormalizedProc)(retCd); + retVal = (*fsRecPtr->fsPtr->internalToNormalizedProc)( + retCd); Tcl_IncrRefCount(retVal); - norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL); + norm = TclFSNormalizeAbsolutePath(interp,retVal,NULL); if (norm != NULL) { - /* - * We found a cwd, which is now in our global storage. - * We must make a copy. Norm already has a refCount of 1. - * - * Threading issue: note that multiple threads at system - * startup could in principle call this procedure - * simultaneously. They will therefore each set the - * cwdPathPtr independently. That behaviour is a bit - * peculiar, but should be fine. Once we have a cwd, - * we'll always be in the 'else' branch below which - * is simpler. + /* + * We found a cwd, which is now in our global + * storage. We must make a copy. Norm already has + * a refCount of 1. + * + * Threading issue: note that multiple threads at + * system startup could in principle call this + * procedure simultaneously. They will therefore + * each set the cwdPathPtr independently. That + * behaviour is a bit peculiar, but should be + * fine. Once we have a cwd, we'll always be in + * the 'else' branch below which is simpler. */ + FsUpdateCwd(norm, retCd); Tcl_DecrRefCount(norm); } else { (*fsRecPtr->fsPtr->freeInternalRepProc)(retCd); } @@ -2471,119 +2653,129 @@ retVal = (*proc)(interp); } } fsRecPtr = fsRecPtr->nextPtr; } - /* - * Now the 'cwd' may NOT be normalized, at least on some - * platforms. For the sake of efficiency, we want a completely - * normalized cwd at all times. - * - * Finally, if retVal is NULL, we do not have a cwd, which - * could be problematic. + + /* + * Now the 'cwd' may NOT be normalized, at least on some platforms. + * For the sake of efficiency, we want a completely normalized cwd at + * all times. + * + * Finally, if retVal is NULL, we do not have a cwd, which could be + * problematic. */ + if (retVal != NULL) { Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL); if (norm != NULL) { - /* - * We found a cwd, which is now in our global storage. - * We must make a copy. Norm already has a refCount of 1. - * + /* + * We found a cwd, which is now in our global storage. We + * must make a copy. Norm already has a refCount of 1. + * * Threading issue: note that multiple threads at system - * startup could in principle call this procedure + * startup could in principle call this procedure * simultaneously. They will therefore each set the * cwdPathPtr independently. That behaviour is a bit - * peculiar, but should be fine. Once we have a cwd, - * we'll always be in the 'else' branch below which - * is simpler. + * peculiar, but should be fine. Once we have a cwd, we'll + * always be in the 'else' branch below which is simpler. */ + ClientData cd = (ClientData) Tcl_FSGetNativePath(norm); FsUpdateCwd(norm, TclNativeDupInternalRep(cd)); Tcl_DecrRefCount(norm); } Tcl_DecrRefCount(retVal); } } else { - /* - * We already have a cwd cached, but we want to give the - * filesystem it is in a chance to check whether that cwd - * has changed, or is perhaps no longer accessible. This - * allows an error to be thrown if, say, the permissions on - * that directory have changed. + /* + * We already have a cwd cached, but we want to give the filesystem it + * is in a chance to check whether that cwd has changed, or is perhaps + * no longer accessible. This allows an error to be thrown if, say, + * the permissions on that directory have changed. */ + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(tsdPtr->cwdPathPtr); - /* - * If the filesystem couldn't be found, or if no cwd function - * exists for this filesystem, then we simply assume the cached - * cwd is ok. If we do call a cwd, we must watch for errors - * (if the cwd returns NULL). This ensures that, say, on Unix - * if the permissions of the cwd change, 'pwd' does actually - * throw the correct error in Tcl. (This is tested for in the - * test suite on unix). + + /* + * If the filesystem couldn't be found, or if no cwd function exists + * for this filesystem, then we simply assume the cached cwd is ok. + * If we do call a cwd, we must watch for errors (if the cwd returns + * NULL). This ensures that, say, on Unix if the permissions of the + * cwd change, 'pwd' does actually throw the correct error in Tcl. + * (This is tested for in the test suite on unix). */ + if (fsPtr != NULL) { Tcl_FSGetCwdProc *proc = fsPtr->getCwdProc; ClientData retCd = NULL; if (proc != NULL) { Tcl_Obj *retVal; if (fsPtr->version != TCL_FILESYSTEM_VERSION_1) { TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)proc; - + retCd = (*proc2)(tsdPtr->cwdClientData); if (retCd == NULL && interp != NULL) { Tcl_AppendResult(interp, "error getting working directory name: ", Tcl_PosixError(interp), (char *) NULL); } - + if (retCd == tsdPtr->cwdClientData) { goto cdDidNotChange; } - - /* Looks like a new current directory */ + + /* + * Looks like a new current directory. + */ + retVal = (*fsPtr->internalToNormalizedProc)(retCd); Tcl_IncrRefCount(retVal); } else { retVal = (*proc)(interp); } if (retVal != NULL) { - Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, - NULL); - /* - * Check whether cwd has changed from the value - * previously stored in cwdPathPtr. Really 'norm' - * shouldn't be null, but we are careful. + Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, + retVal, NULL); + + /* + * Check whether cwd has changed from the value previously + * stored in cwdPathPtr. Really 'norm' shouldn't be null, + * but we are careful. */ + if (norm == NULL) { /* Do nothing */ if (retCd != NULL) { (*fsPtr->freeInternalRepProc)(retCd); } } else if (norm == tsdPtr->cwdPathPtr) { goto cdEqual; } else { - /* - * Note that both 'norm' and - * 'tsdPtr->cwdPathPtr' are normalized paths. - * Therefore we can be more efficient than - * calling 'Tcl_FSEqualPaths', and in addition - * avoid a nasty infinite loop bug when trying - * to normalize tsdPtr->cwdPathPtr. + /* + * Note that both 'norm' and 'tsdPtr->cwdPathPtr' are + * normalized paths. Therefore we can be more + * efficient than calling 'Tcl_FSEqualPaths', and in + * addition avoid a nasty infinite loop bug when + * trying to normalize tsdPtr->cwdPathPtr. */ + int len1, len2; char *str1, *str2; + str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); str2 = Tcl_GetStringFromObj(norm, &len2); if ((len1 == len2) && (strcmp(str1, str2) == 0)) { - /* + /* * If the paths were equal, we can be more - * efficient and retain the old path object - * which will probably already be shared. In - * this case we can simply free the normalized - * path we just calculated. + * efficient and retain the old path object which + * will probably already be shared. In this case + * we can simply free the normalized path we just + * calculated. */ - cdEqual: + + cdEqual: Tcl_DecrRefCount(norm); if (retCd != NULL) { (*fsPtr->freeInternalRepProc)(retCd); } } else { @@ -2597,236 +2789,239 @@ FsUpdateCwd(NULL, NULL); } } } } - + cdDidNotChange: if (tsdPtr->cwdPathPtr != NULL) { Tcl_IncrRefCount(tsdPtr->cwdPathPtr); } - - return tsdPtr->cwdPathPtr; + + return tsdPtr->cwdPathPtr; } /* *---------------------------------------------------------------------- * * Tcl_FSChdir -- * * This function replaces the library version of chdir(). - * - * The path is normalized and then passed to the filesystem - * which claims it. + * + * The path is normalized and then passed to the filesystem which claims + * it. * * Results: - * See chdir() documentation. If successful, we keep a - * record of the successful path in cwdPathPtr for subsequent - * calls to getcwd. + * See chdir() documentation. If successful, we keep a record of the + * successful path in cwdPathPtr for subsequent calls to getcwd. * * Side effects: - * See chdir() documentation. The global cwdPathPtr may - * change value. + * See chdir() documentation. The global cwdPathPtr may change value. * *---------------------------------------------------------------------- */ + int Tcl_FSChdir(pathPtr) Tcl_Obj *pathPtr; { Tcl_Filesystem *fsPtr; int retVal = -1; - + if (Tcl_FSGetNormalizedPath(NULL, pathPtr) == NULL) { Tcl_SetErrno(ENOENT); - return (retVal); + return retVal; } - + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { Tcl_FSChdirProc *proc = fsPtr->chdirProc; if (proc != NULL) { - /* - * If this fails, an appropriate errno will have - * been stored using 'Tcl_SetErrno()'. + /* + * If this fails, an appropriate errno will have been stored using + * 'Tcl_SetErrno()'. */ + retVal = (*proc)(pathPtr); } else { - /* Fallback on stat-based implementation */ + /* + * Fallback on stat-based implementation. + */ + Tcl_StatBuf buf; - /* - * If the file can be stat'ed and is a directory and is - * readable, then we can chdir. If any of these actions - * fail, then 'Tcl_SetErrno()' should automatically have - * been called to set an appropriate error code + + /* + * If the file can be stat'ed and is a directory and is readable, + * then we can chdir. If any of these actions fail, then + * 'Tcl_SetErrno()' should automatically have been called to set + * an appropriate error code */ - if ((Tcl_FSStat(pathPtr, &buf) == 0) - && (S_ISDIR(buf.st_mode)) - && (Tcl_FSAccess(pathPtr, R_OK) == 0)) { - /* We allow the chdir */ + + if ((Tcl_FSStat(pathPtr, &buf) == 0) && (S_ISDIR(buf.st_mode)) + && (Tcl_FSAccess(pathPtr, R_OK) == 0)) { + /* + * We allow the chdir. + */ + retVal = 0; } } } else { Tcl_SetErrno(ENOENT); } - - /* - * The cwd changed, or an error was thrown. If an error was - * thrown, we can just continue (and that will report the error - * to the user). If there was no error we must assume that the - * cwd was actually changed to the normalized value we - * calculated above, and we must therefore cache that - * information. + + /* + * The cwd changed, or an error was thrown. If an error was thrown, we + * can just continue (and that will report the error to the user). If + * there was no error we must assume that the cwd was actually changed to + * the normalized value we calculated above, and we must therefore cache + * that information. */ /* - * If the filesystem in question has a getCwdProc, then the - * correct logic which performs the part below is already part - * of the Tcl_FSGetCwd() call, so no need to replicate it again. - * This will have a side effect though. The private - * authoritative representation of the current working directory - * stored in cwdPathPtr in static memory will be out-of-sync - * with the real OS-maintained value. The first call to - * Tcl_FSGetCwd will however recalculate the private copy to - * match the OS-value so everything will work right. - * - * However, if there is no getCwdProc, then we _must_ update - * our private storage of the cwd, since this is the only - * opportunity to do that! - * - * Note: We currently call this block of code irrespective of - * whether there was a getCwdProc or not, but the code should - * all in principle work if we only call this block if - * fsPtr->getCwdProc == NULL. + * If the filesystem in question has a getCwdProc, then the correct logic + * which performs the part below is already part of the Tcl_FSGetCwd() + * call, so no need to replicate it again. This will have a side effect + * though. The private authoritative representation of the current + * working directory stored in cwdPathPtr in static memory will be + * out-of-sync with the real OS-maintained value. The first call to + * Tcl_FSGetCwd will however recalculate the private copy to match the + * OS-value so everything will work right. + * + * However, if there is no getCwdProc, then we _must_ update our private + * storage of the cwd, since this is the only opportunity to do that! + * + * Note: We currently call this block of code irrespective of whether + * there was a getCwdProc or not, but the code should all in principle + * work if we only call this block if fsPtr->getCwdProc == NULL. */ if (retVal == 0) { - /* - * Note that this normalized path may be different to what - * we found above (or at least a different object), if the - * filesystem epoch changed recently. This can actually - * happen with scripted documents very easily. Therefore - * we ask for the normalized path again (the correct value - * will have been cached as a result of the + /* + * Note that this normalized path may be different to what we found + * above (or at least a different object), if the filesystem epoch + * changed recently. This can actually happen with scripted documents + * very easily. Therefore we ask for the normalized path again (the + * correct value will have been cached as a result of the * Tcl_FSGetFileSystemForPath call above anyway). */ + Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (normDirName == NULL) { /* Not really true, but what else to do? */ - Tcl_SetErrno(ENOENT); + Tcl_SetErrno(ENOENT); return -1; } + if (fsPtr == &tclNativeFilesystem) { - /* - * For the native filesystem, we keep a cache of the - * native representation of the cwd. But, we want to do - * that for the exact format that is returned by - * 'getcwd' (so that we can later compare the two - * representations for equality), which might not be - * exactly the same char-string as the native - * representation of the fully normalized path (e.g. on - * Windows there's a forward-slash vs backslash - * difference). Hence we ask for this again here. On - * Unix it might actually be true that we always have - * the correct form in the native rep in which case we - * could simply use: - * - * cd = Tcl_FSGetNativePath(pathPtr); - * - * instead. This should be examined by someone on - * Unix. + /* + * For the native filesystem, we keep a cache of the native + * representation of the cwd. But, we want to do that for the + * exact format that is returned by 'getcwd' (so that we can later + * compare the two representations for equality), which might not + * be exactly the same char-string as the native representation of + * the fully normalized path (e.g. on Windows there's a + * forward-slash vs backslash difference). Hence we ask for this + * again here. On Unix it might actually be true that we always + * have the correct form in the native rep in which case we could + * simply use: + * cd = Tcl_FSGetNativePath(pathPtr); + * instead. This should be examined by someone on Unix. */ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); ClientData cd; - /* Assumption we are using a filesystem version 2 */ + /* + * Assumption we are using a filesystem version 2. + */ + TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)fsPtr->getCwdProc; cd = (*proc2)(tsdPtr->cwdClientData); FsUpdateCwd(normDirName, TclNativeDupInternalRep(cd)); } else { FsUpdateCwd(normDirName, NULL); } } - - return (retVal); + + return retVal; } /* *---------------------------------------------------------------------- * * Tcl_FSLoadFile -- * - * Dynamically loads a binary code file into memory and returns - * the addresses of two procedures within that file, if they are - * defined. The appropriate function for the filesystem to which - * pathPtr belongs will be called. - * - * Note that the native filesystem doesn't actually assume 'pathPtr' - * is a path. Rather it assumes pathPtr is either a path or just - * the name (tail) of a file which can be found somewhere in the - * environment's loadable path. This behaviour is not very - * compatible with virtual filesystems (and has other problems - * documented in the load man-page), so it is advised that full - * paths are always used. + * Dynamically loads a binary code file into memory and returns the + * addresses of two procedures within that file, if they are defined. + * The appropriate function for the filesystem to which pathPtr belongs + * will be called. + * + * Note that the native filesystem doesn't actually assume 'pathPtr' is a + * path. Rather it assumes pathPtr is either a path or just the name + * (tail) of a file which can be found somewhere in the environment's + * loadable path. This behaviour is not very compatible with virtual + * filesystems (and has other problems documented in the load man-page), + * so it is advised that full paths are always used. * * Results: - * A standard Tcl completion code. If an error occurs, an error - * message is left in the interp's result. + * A standard Tcl completion code. If an error occurs, an error message + * is left in the interp's result. * * Side effects: - * New code suddenly appears in memory. This may later be - * unloaded by passing the clientData to the unloadProc. + * New code suddenly appears in memory. This may later be unloaded by + * passing the clientData to the unloadProc. * *---------------------------------------------------------------------- */ int -Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, - handlePtr, unloadProcPtr) +Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, + handlePtr, unloadProcPtr) Tcl_Interp *interp; /* Used for error reporting. */ Tcl_Obj *pathPtr; /* Name of the file containing the desired * code. */ - CONST char *sym1, *sym2; /* Names of two procedures to look up in - * the file's symbol table. */ + CONST char *sym1, *sym2; /* Names of two procedures to look up in the + * file's symbol table. */ Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; /* Where to return the addresses corresponding * to sym1 and sym2. */ Tcl_LoadHandle *handlePtr; /* Filled with token for dynamically loaded - * file which will be passed back to + * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr; + Tcl_FSUnloadFileProc **unloadProcPtr; /* Filled with address of Tcl_FSUnloadFileProc - * function which should be used for - * this file. */ + * function which should be used for this + * file. */ { CONST char *symbols[2]; Tcl_PackageInitProc **procPtrs[2]; ClientData clientData; int res; - + /* Initialize the arrays */ symbols[0] = sym1; symbols[1] = sym2; procPtrs[0] = proc1Ptr; procPtrs[1] = proc2Ptr; - + /* Perform the load */ - res = TclLoadFile(interp, pathPtr, 2, symbols, procPtrs, - handlePtr, &clientData, unloadProcPtr); - - /* - * Due to an unfortunate mis-design in Tcl 8.4 fs, when loading a - * shared library, we don't keep the loadHandle (for TclpFindSymbol) - * and the clientData (for the unloadProc) separately. In fact we - * effectively throw away the loadHandle and only use the clientData. - * It just so happens, for the native filesystem only, that these two - * are identical. - * + res = TclLoadFile(interp, pathPtr, 2, symbols, procPtrs, + handlePtr, &clientData, unloadProcPtr); + + /* + * Due to an unfortunate mis-design in Tcl 8.4 fs, when loading a shared + * library, we don't keep the loadHandle (for TclpFindSymbol) and the + * clientData (for the unloadProc) separately. In fact we effectively + * throw away the loadHandle and only use the clientData. It just so + * happens, for the native filesystem only, that these two are identical. + * * This also means that the signatures Tcl_FSUnloadFileProc and * Tcl_FSLoadFileProc are both misleading. */ + *handlePtr = (Tcl_LoadHandle) clientData; return res; } /* @@ -2833,282 +3028,362 @@ *---------------------------------------------------------------------- * * TclLoadFile -- * * Dynamically loads a binary code file into memory and returns the - * addresses of a number of given procedures within that file, if - * they are defined. The appropriate function for the filesystem to - * which pathPtr belongs will be called. - * - * Note that the native filesystem doesn't actually assume 'pathPtr' - * is a path. Rather it assumes pathPtr is either a path or just - * the name (tail) of a file which can be found somewhere in the - * environment's loadable path. This behaviour is not very - * compatible with virtual filesystems (and has other problems - * documented in the load man-page), so it is advised that full - * paths are always used. - * - * This function is currently private to Tcl. It may be exported in - * the future and its interface fixed (but we should clean up the - * loadHandle/clientData confusion at that time -- see the above - * comments in Tcl_FSLoadFile for details). For a public function, - * see Tcl_FSLoadFile. + * addresses of a number of given procedures within that file, if they + * are defined. The appropriate function for the filesystem to which + * pathPtr belongs will be called. + * + * Note that the native filesystem doesn't actually assume 'pathPtr' is a + * path. Rather it assumes pathPtr is either a path or just the name + * (tail) of a file which can be found somewhere in the environment's + * loadable path. This behaviour is not very compatible with virtual + * filesystems (and has other problems documented in the load man-page), + * so it is advised that full paths are always used. + * + * This function is currently private to Tcl. It may be exported in the + * future and its interface fixed (but we should clean up the + * loadHandle/clientData confusion at that time -- see the above comments + * in Tcl_FSLoadFile for details). For a public function, see + * Tcl_FSLoadFile. * * Results: - * A standard Tcl completion code. If an error occurs, an error - * message is left in the interp's result. + * A standard Tcl completion code. If an error occurs, an error message + * is left in the interp's result. * * Side effects: - * New code suddenly appears in memory. This may later be - * unloaded by passing the clientData to the unloadProc. + * New code suddenly appears in memory. This may later be unloaded by + * passing the clientData to the unloadProc. * *---------------------------------------------------------------------- */ int -TclLoadFile(interp, pathPtr, symc, symbols, procPtrs, +TclLoadFile(interp, pathPtr, symc, symbols, procPtrs, handlePtr, clientDataPtr, unloadProcPtr) Tcl_Interp *interp; /* Used for error reporting. */ Tcl_Obj *pathPtr; /* Name of the file containing the desired * code. */ - int symc; /* Number of symbols/procPtrs in the - * next two arrays. */ - CONST char *symbols[]; /* Names of procedures to look up in - * the file's symbol table. */ + int symc; /* Number of symbols/procPtrs in the next two + * arrays. */ + CONST char *symbols[]; /* Names of procedures to look up in the + * file's symbol table. */ Tcl_PackageInitProc **procPtrs[]; - /* Where to return the addresses - * corresponding to symbols[]. */ - Tcl_LoadHandle *handlePtr; /* Filled with token for shared - * library information which can be - * used in TclpFindSymbol. */ + /* Where to return the addresses corresponding + * to symbols[]. */ + Tcl_LoadHandle *handlePtr; /* Filled with token for shared library + * information which can be used in + * TclpFindSymbol. */ ClientData *clientDataPtr; /* Filled with token for dynamically loaded - * file which will be passed back to + * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr; - /* Filled with address of Tcl_FSUnloadFileProc - * function which should be used for - * this file. */ + Tcl_FSUnloadFileProc **unloadProcPtr; + /* Filled with address of Tcl_FSUnloadFileProc + * function which should be used for this + * file. */ { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { Tcl_FSLoadFileProc *proc = fsPtr->loadFileProc; Tcl_Filesystem *copyFsPtr; Tcl_Obj *copyToPtr; - + if (proc != NULL) { int retVal = (*proc)(interp, pathPtr, handlePtr, unloadProcPtr); if (retVal == TCL_OK) { int i; if (*handlePtr == NULL) { return TCL_ERROR; } - for (i = 0;i < symc;i++) { - if (symbols[i] != NULL) { - *procPtrs[i] = TclpFindSymbol(interp, *handlePtr, - symbols[i]); - } - } - /* Copy this across, since both are equal for the native fs */ - *clientDataPtr = (ClientData)*handlePtr; - return retVal; - } - if (Tcl_GetErrno() != EXDEV) { - return retVal; - } - } - /* - * The filesystem doesn't support 'load', so we fall back on - * the following technique: - */ - - /* First check if it is readable -- and exists! */ + for (i=0 ; iloadHandle = newLoadHandle; tvdlPtr->unloadProcPtr = newUnloadProcPtr; if (copyFsPtr != &tclNativeFilesystem) { /* copyToPtr is already incremented for this reference */ tvdlPtr->divertedFile = copyToPtr; - /* - * This is the filesystem we loaded it into. Since - * we have a reference to 'copyToPtr', we already - * have a refCount on this filesystem, so we don't - * need to worry about it disappearing on us. + /* + * This is the filesystem we loaded it into. Since we have a + * reference to 'copyToPtr', we already have a refCount on + * this filesystem, so we don't need to worry about it + * disappearing on us. */ + tvdlPtr->divertedFilesystem = copyFsPtr; tvdlPtr->divertedFileNativeRep = NULL; } else { /* We need the native rep */ - tvdlPtr->divertedFileNativeRep = - TclNativeDupInternalRep(Tcl_FSGetInternalRep(copyToPtr, - copyFsPtr)); - /* - * We don't need or want references to the copied - * Tcl_Obj or the filesystem if it is the native - * one. + tvdlPtr->divertedFileNativeRep = TclNativeDupInternalRep( + Tcl_FSGetInternalRep(copyToPtr, copyFsPtr)); + + /* + * We don't need or want references to the copied Tcl_Obj or + * the filesystem if it is the native one. */ + tvdlPtr->divertedFile = NULL; tvdlPtr->divertedFilesystem = NULL; Tcl_DecrRefCount(copyToPtr); } copyToPtr = NULL; (*handlePtr) = newLoadHandle; - (*clientDataPtr) = (ClientData)tvdlPtr; + (*clientDataPtr) = (ClientData) tvdlPtr; (*unloadProcPtr) = &FSUnloadTempFile; + Tcl_ResetResult(interp); return retVal; + } else { - /* Cross-platform copy failed */ + /* + * Cross-platform copy failed. + */ + Tcl_FSDeleteFile(copyToPtr); Tcl_DecrRefCount(copyToPtr); return TCL_ERROR; } } Tcl_SetErrno(ENOENT); - return -1; + return TCL_ERROR; } -/* - * This function used to be in the platform specific directories, but it - * has now been made to work cross-platform +/* + * This function used to be in the platform specific directories, but it has + * now been made to work cross-platform */ + int -TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, - clientDataPtr, unloadProcPtr) +TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, + clientDataPtr, unloadProcPtr) Tcl_Interp *interp; /* Used for error reporting. */ Tcl_Obj *pathPtr; /* Name of the file containing the desired * code (UTF-8). */ - CONST char *sym1, *sym2; /* Names of two procedures to look up in - * the file's symbol table. */ + CONST char *sym1, *sym2; /* Names of two procedures to look up in the + * file's symbol table. */ Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; /* Where to return the addresses corresponding * to sym1 and sym2. */ ClientData *clientDataPtr; /* Filled with token for dynamically loaded - * file which will be passed back to + * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr; + Tcl_FSUnloadFileProc **unloadProcPtr; /* Filled with address of Tcl_FSUnloadFileProc - * function which should be used for - * this file. */ + * function which should be used for this + * file. */ { Tcl_LoadHandle handle = NULL; int res; - + res = TclpDlopen(interp, pathPtr, &handle, unloadProcPtr); - + if (res != TCL_OK) { - return res; + return res; } if (handle == NULL) { return TCL_ERROR; } - + *clientDataPtr = (ClientData)handle; - + *proc1Ptr = TclpFindSymbol(interp, handle, sym1); *proc2Ptr = TclpFindSymbol(interp, handle, sym2); return TCL_OK; } @@ -3115,87 +3390,90 @@ /* *--------------------------------------------------------------------------- * * FSUnloadTempFile -- * - * This function is called when we loaded a library of code via - * an intermediate temporary file. This function ensures - * the library is correctly unloaded and the temporary file - * is correctly deleted. + * This function is called when we loaded a library of code via an + * intermediate temporary file. This function ensures the library is + * correctly unloaded and the temporary file is correctly deleted. * * Results: * None. * * Side effects: - * The effects of the 'unload' function called, and of course - * the temporary file will be deleted. + * The effects of the 'unload' function called, and of course the + * temporary file will be deleted. * *--------------------------------------------------------------------------- */ -static void +static void FSUnloadTempFile(loadHandle) - Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call - * to Tcl_FSLoadFile(). The loadHandle is - * a token that represents the loaded - * file. */ + Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call to + * Tcl_FSLoadFile(). The loadHandle is a token + * that represents the loaded file. */ { FsDivertLoad *tvdlPtr = (FsDivertLoad*)loadHandle; - /* - * This test should never trigger, since we give - * the client data in the function above. + + /* + * This test should never trigger, since we give the client data in the + * function above. */ + if (tvdlPtr == NULL) { return; } - - /* - * Call the real 'unloadfile' proc we actually used. It is very - * important that we call this first, so that the shared library - * is actually unloaded by the OS. Otherwise, the following - * 'delete' may well fail because the shared library is still in - * use. + + /* + * Call the real 'unloadfile' proc we actually used. It is very important + * that we call this first, so that the shared library is actually + * unloaded by the OS. Otherwise, the following 'delete' may well fail + * because the shared library is still in use. */ + if (tvdlPtr->unloadProcPtr != NULL) { (*tvdlPtr->unloadProcPtr)(tvdlPtr->loadHandle); } - + if (tvdlPtr->divertedFilesystem == NULL) { - /* - * It was the native filesystem, and we have a special - * function available just for this purpose, which we - * know works even at this late stage. + /* + * It was the native filesystem, and we have a special function + * available just for this purpose, which we know works even at this + * late stage. */ + TclpDeleteFile(tvdlPtr->divertedFileNativeRep); NativeFreeInternalRep(tvdlPtr->divertedFileNativeRep); + } else { - /* - * Remove the temporary file we created. Note, we may crash - * here because encodings have been taken down already. + /* + * Remove the temporary file we created. Note, we may crash here + * because encodings have been taken down already. */ + if (tvdlPtr->divertedFilesystem->deleteFileProc(tvdlPtr->divertedFile) - != TCL_OK) { - /* + != TCL_OK) { + /* * The above may have failed because the filesystem, or something * it depends upon (e.g. encodings) have been taken down because * Tcl is exiting. - * - * We may need to work out how to delete this file more - * robustly (or give the filesystem the information it needs - * to delete the file more robustly). - * - * In particular, one problem might be that the filesystem - * cannot extract the information it needs from the above - * path object because Tcl's entire filesystem apparatus - * (the code in this file) has been finalized, and it - * refuses to pass the internal representation to the - * filesystem. - */ - } - - /* - * And free up the allocations. This will also of course remove - * a refCount from the Tcl_Filesystem to which this file belongs, - * which could then free up the filesystem if we are exiting. - */ + * + * We may need to work out how to delete this file more robustly + * (or give the filesystem the information it needs to delete the + * file more robustly). + * + * In particular, one problem might be that the filesystem cannot + * extract the information it needs from the above path object + * because Tcl's entire filesystem apparatus (the code in this + * file) has been finalized, and it refuses to pass the internal + * representation to the filesystem. + */ + } + + /* + * And free up the allocations. This will also of course remove a + * refCount from the Tcl_Filesystem to which this file belongs, which + * could then free up the filesystem if we are exiting. + */ + Tcl_DecrRefCount(tvdlPtr->divertedFile); } ckfree((char*)tvdlPtr); } @@ -3203,61 +3481,60 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSLink -- * - * This function replaces the library version of readlink() and - * can also be used to make links. The appropriate function for - * the filesystem to which pathPtr belongs will be called. + * This function replaces the library version of readlink() and can also + * be used to make links. The appropriate function for the filesystem to + * which pathPtr belongs will be called. * * Results: - * If toPtr is NULL, then the result is a Tcl_Obj specifying the - * contents of the symbolic link given by 'pathPtr', or NULL if - * the symbolic link could not be read. The result is owned by - * the caller, which should call Tcl_DecrRefCount when the result - * is no longer needed. - * - * If toPtr is non-NULL, then the result is toPtr if the link action - * was successful, or NULL if not. In this case the result has no - * additional reference count, and need not be freed. The actual - * action to perform is given by the 'linkAction' flags, which is - * an or'd combination of: - * - * TCL_CREATE_SYMBOLIC_LINK - * TCL_CREATE_HARD_LINK - * - * Note that most filesystems will not support linking across - * to different filesystems, so this function will usually - * fail unless toPtr is in the same FS as pathPtr. - * + * If toPtr is NULL, then the result is a Tcl_Obj specifying the contents + * of the symbolic link given by 'pathPtr', or NULL if the symbolic link + * could not be read. The result is owned by the caller, which should + * call Tcl_DecrRefCount when the result is no longer needed. + * + * If toPtr is non-NULL, then the result is toPtr if the link action was + * successful, or NULL if not. In this case the result has no additional + * reference count, and need not be freed. The actual action to perform + * is given by the 'linkAction' flags, which is an or'd combination of: + * + * TCL_CREATE_SYMBOLIC_LINK + * TCL_CREATE_HARD_LINK + * + * Note that most filesystems will not support linking across to + * different filesystems, so this function will usually fail unless toPtr + * is in the same FS as pathPtr. + * * Side effects: - * See readlink() documentation. A new filesystem link - * object may appear + * See readlink() documentation. A new filesystem link object may appear * *--------------------------------------------------------------------------- */ Tcl_Obj * Tcl_FSLink(pathPtr, toPtr, linkAction) Tcl_Obj *pathPtr; /* Path of file to readlink or link */ Tcl_Obj *toPtr; /* NULL or path to be linked to */ - int linkAction; /* Action to perform */ + int linkAction; /* Action to perform */ { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { Tcl_FSLinkProc *proc = fsPtr->linkProc; if (proc != NULL) { return (*proc)(pathPtr, toPtr, linkAction); } } + /* - * If S_IFLNK isn't defined it means that the machine doesn't - * support symbolic links, so the file can't possibly be a - * symbolic link. Generate an EINVAL error, which is what - * happens on machines that do support symbolic links when - * you invoke readlink on a file that isn't a symbolic link. + * If S_IFLNK isn't defined it means that the machine doesn't support + * symbolic links, so the file can't possibly be a symbolic link. + * Generate an EINVAL error, which is what happens on machines that do + * support symbolic links when you invoke readlink on a file that isn't a + * symbolic link. */ + #ifndef S_IFLNK errno = EINVAL; #else Tcl_SetErrno(ENOENT); #endif /* S_IFLNK */ @@ -3267,21 +3544,20 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSListVolumes -- * - * Lists the currently mounted volumes. The chain of functions - * that have been "inserted" into the filesystem will be called in - * succession; each may return a list of volumes, all of which are - * added to the result until all mounted file systems are listed. - * - * Notice that we assume the lists returned by each filesystem - * (if non NULL) have been given a refCount for us already. - * However, we are NOT allowed to hang on to the list itself - * (it belongs to the filesystem we called). Therefore we - * quite naturally add its contents to the result we are - * building, and then decrement the refCount. + * Lists the currently mounted volumes. The chain of functions that have + * been "inserted" into the filesystem will be called in succession; each + * may return a list of volumes, all of which are added to the result + * until all mounted file systems are listed. + * + * Notice that we assume the lists returned by each filesystem (if non + * NULL) have been given a refCount for us already. However, we are NOT + * allowed to hang on to the list itself (it belongs to the filesystem we + * called). Therefore we quite naturally add its contents to the result + * we are building, and then decrement the refCount. * * Results: * The list of volumes, in an object which has refCount 0. * * Side effects: @@ -3293,16 +3569,16 @@ Tcl_Obj* Tcl_FSListVolumes(void) { FilesystemRecord *fsRecPtr; Tcl_Obj *resultPtr = Tcl_NewObj(); - + /* - * Call each of the "listVolumes" function in succession. - * A non-NULL return value indicates the particular function has - * succeeded. We call all the functions registered, since we want - * a list of all drives from all filesystems. + * Call each of the "listVolumes" function in succession. A non-NULL + * return value indicates the particular function has succeeded. We call + * all the functions registered, since we want a list of all drives from + * all filesystems. */ fsRecPtr = FsGetFirstFilesystem(); while (fsRecPtr != NULL) { Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc; @@ -3313,135 +3589,139 @@ Tcl_DecrRefCount(thisFsVolumes); } } fsRecPtr = fsRecPtr->nextPtr; } - + return resultPtr; } /* *--------------------------------------------------------------------------- * * FsListMounts -- * - * List all mounts within the given directory, which match the - * given pattern. + * List all mounts within the given directory, which match the given + * pattern. * * Results: - * The list of mounts, in a list object which has refCount 0, or - * NULL if we didn't even find any filesystems to try to list - * mounts. + * The list of mounts, in a list object which has refCount 0, or NULL if + * we didn't even find any filesystems to try to list mounts. * * Side effects: * None * *--------------------------------------------------------------------------- */ static Tcl_Obj* FsListMounts(pathPtr, pattern) - Tcl_Obj *pathPtr; /* Contains path to directory to search. */ + Tcl_Obj *pathPtr; /* Contains path to directory to search. */ CONST char *pattern; /* Pattern to match against. */ { FilesystemRecord *fsRecPtr; Tcl_GlobTypeData mountsOnly = { TCL_GLOB_TYPE_MOUNT, 0, NULL, NULL }; Tcl_Obj *resultPtr = NULL; - + /* - * Call each of the "matchInDirectory" functions in succession, with - * the specific type information 'mountsOnly'. A non-NULL return - * value indicates the particular function has succeeded. We call - * all the functions registered, since we want a list from each - * filesystems. + * Call each of the "matchInDirectory" functions in succession, with the + * specific type information 'mountsOnly'. A non-NULL return value + * indicates the particular function has succeeded. We call all the + * functions registered, since we want a list from each filesystems. */ fsRecPtr = FsGetFirstFilesystem(); while (fsRecPtr != NULL) { if (fsRecPtr != &nativeFilesystemRecord) { - Tcl_FSMatchInDirectoryProc *proc = - fsRecPtr->fsPtr->matchInDirectoryProc; + Tcl_FSMatchInDirectoryProc *proc = + fsRecPtr->fsPtr->matchInDirectoryProc; if (proc != NULL) { if (resultPtr == NULL) { resultPtr = Tcl_NewObj(); } (*proc)(NULL, resultPtr, pathPtr, pattern, &mountsOnly); } } fsRecPtr = fsRecPtr->nextPtr; } - + return resultPtr; } /* *--------------------------------------------------------------------------- * * Tcl_FSSplitPath -- * - * This function takes the given Tcl_Obj, which should be a valid - * path, and returns a Tcl List object containing each segment of - * that path as an element. + * This function takes the given Tcl_Obj, which should be a valid path, + * and returns a Tcl List object containing each segment of that path as + * an element. * * Results: - * Returns list object with refCount of zero. If the passed in - * lenPtr is non-NULL, we use it to return the number of elements - * in the returned list. + * Returns list object with refCount of zero. If the passed in lenPtr is + * non-NULL, we use it to return the number of elements in the returned + * list. * * Side effects: * None. * *--------------------------------------------------------------------------- */ -Tcl_Obj* +Tcl_Obj* Tcl_FSSplitPath(pathPtr, lenPtr) Tcl_Obj *pathPtr; /* Path to split. */ int *lenPtr; /* int to store number of path elements. */ { - Tcl_Obj *result = NULL; /* Needed only to prevent gcc warnings. */ + Tcl_Obj *result = NULL; /* Needed only to prevent gcc warnings. */ Tcl_Filesystem *fsPtr; char separator = '/'; int driveNameLength; char *p; - + /* - * Perform platform specific splitting. + * Perform platform specific splitting. */ - if (TclFSGetPathType(pathPtr, &fsPtr, &driveNameLength) - == TCL_PATH_ABSOLUTE) { + if (TclFSGetPathType(pathPtr, &fsPtr, + &driveNameLength) == TCL_PATH_ABSOLUTE) { if (fsPtr == &tclNativeFilesystem) { return TclpNativeSplitPath(pathPtr, lenPtr); } } else { return TclpNativeSplitPath(pathPtr, lenPtr); } - /* We assume separators are single characters */ + /* + * We assume separators are single characters. + */ + if (fsPtr->filesystemSeparatorProc != NULL) { Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(pathPtr); if (sep != NULL) { Tcl_IncrRefCount(sep); separator = Tcl_GetString(sep)[0]; Tcl_DecrRefCount(sep); } } - - /* - * Place the drive name as first element of the - * result list. The drive name may contain strange - * characters, like colons and multiple forward slashes - * (for example 'ftp://' is a valid vfs drive name) + + /* + * Place the drive name as first element of the result list. The drive + * name may contain strange characters, like colons and multiple forward + * slashes (for example 'ftp://' is a valid vfs drive name) */ + result = Tcl_NewObj(); p = Tcl_GetString(pathPtr); - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(p, driveNameLength)); - p+= driveNameLength; - - /* Add the remaining path elements to the list */ + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(p, driveNameLength)); + p += driveNameLength; + + /* + * Add the remaining path elements to the list. + */ + for (;;) { char *elementStart = p; int length; while ((*p != '\0') && (*p != separator)) { p++; @@ -3459,11 +3739,11 @@ } if (*p++ == '\0') { break; } } - + /* * Compute the number of elements in the result. */ if (lenPtr != NULL) { @@ -3471,11 +3751,11 @@ } return result; } /* Simple helper function */ -Tcl_Obj* +Tcl_Obj* TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr) Tcl_Filesystem *fromFilesystem; ClientData clientData; FilesystemRecord **fsRecPtrPtr; { @@ -3486,13 +3766,13 @@ *fsRecPtrPtr = fsRecPtr; break; } fsRecPtr = fsRecPtr->nextPtr; } - - if ((fsRecPtr != NULL) - && (fromFilesystem->internalToNormalizedProc != NULL)) { + + if ((fsRecPtr != NULL) + && (fromFilesystem->internalToNormalizedProc != NULL)) { return (*fromFilesystem->internalToNormalizedProc)(clientData); } else { return NULL; } } @@ -3504,49 +3784,47 @@ * * Helper function used by FSGetPathType. * * Results: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or - * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will - * be set if and only if it is non-NULL and the function's - * return value is TCL_PATH_ABSOLUTE. + * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will be set if and + * only if it is non-NULL and the function's return value is + * TCL_PATH_ABSOLUTE. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_PathType TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef) - Tcl_Obj *pathPtr; /* Path to determine type for */ - Tcl_Filesystem **filesystemPtrPtr; /* If absolute path and this is - * non-NULL, then set to the - * filesystem which claims this - * path */ - int *driveNameLengthPtr; /* If the path is absolute, and - * this is non-NULL, then set to - * the length of the driveName */ - Tcl_Obj **driveNameRef; /* If the path is absolute, and - * this is non-NULL, then set to - * the name of the drive, - * network-volume which contains - * the path, already with a - * refCount for the caller. */ + Tcl_Obj *pathPtr; /* Path to determine type for */ + Tcl_Filesystem **filesystemPtrPtr; /* If absolute path and this is not + * NULL, then set to the filesystem + * which claims this path. */ + int *driveNameLengthPtr; /* If the path is absolute, and this + * is non-NULL, then set to the length + * of the driveName. */ + Tcl_Obj **driveNameRef; /* If the path is absolute, and this + * is non-NULL, then set to the name + * of the drive, network-volume which + * contains the path, already with a + * refCount for the caller. */ { int pathLen; char *path; Tcl_PathType type; - + path = Tcl_GetStringFromObj(pathPtr, &pathLen); - type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, - driveNameLengthPtr, driveNameRef); - + type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, + driveNameLengthPtr, driveNameRef); + if (type != TCL_PATH_ABSOLUTE) { - type = TclpGetNativePathType(pathPtr, driveNameLengthPtr, - driveNameRef); + type = TclpGetNativePathType(pathPtr, driveNameLengthPtr, + driveNameRef); if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) { *filesystemPtrPtr = &tclNativeFilesystem; } } return type; @@ -3555,94 +3833,92 @@ /* *---------------------------------------------------------------------- * * TclFSNonnativePathType -- * - * Helper function used by TclGetPathType. Its purpose is to - * check whether the given path starts with a string which - * corresponds to a file volume in any registered filesystem - * except the native one. For speed and historical reasons the - * native filesystem has special hard-coded checks dotted here - * and there in the filesystem code. + * Helper function used by TclGetPathType. Its purpose is to check + * whether the given path starts with a string which corresponds to a + * file volume in any registered filesystem except the native one. For + * speed and historical reasons the native filesystem has special + * hard-coded checks dotted here and there in the filesystem code. * * Results: - * Returns one of TCL_PATH_ABSOLUTE or TCL_PATH_RELATIVE. - * The filesystem reference will be set if and only if it is - * non-NULL and the function's return value is TCL_PATH_ABSOLUTE. + * Returns one of TCL_PATH_ABSOLUTE or TCL_PATH_RELATIVE. The filesystem + * reference will be set if and only if it is non-NULL and the function's + * return value is TCL_PATH_ABSOLUTE. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_PathType -TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, - driveNameLengthPtr, driveNameRef) - CONST char *path; /* Path to determine type for */ - int pathLen; /* Length of the path */ - Tcl_Filesystem **filesystemPtrPtr; /* If absolute path and this is - * non-NULL, then set to the - * filesystem which claims this - * path */ - int *driveNameLengthPtr; /* If the path is absolute, and - * this is non-NULL, then set to - * the length of the driveName */ - Tcl_Obj **driveNameRef; /* If the path is absolute, and - * this is non-NULL, then set to - * the name of the drive, - * network-volume which contains - * the path, already with a +TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, driveNameLengthPtr, + driveNameRef) + CONST char *path; /* Path to determine type for */ + int pathLen; /* Length of the path */ + Tcl_Filesystem **filesystemPtrPtr; /* If absolute path and this is not + * NULL, then set to the filesystem + * which claims this path. */ + int *driveNameLengthPtr; /* If the path is absolute, and this + * is non-NULL, then set to the length + * of the driveName. */ + Tcl_Obj **driveNameRef; /* If the path is absolute, and this + * is non-NULL, then set to the name + * of the drive, network-volume which + * contains the path, already with a * refCount for the caller. */ { FilesystemRecord *fsRecPtr; Tcl_PathType type = TCL_PATH_RELATIVE; /* - * Call each of the "listVolumes" function in succession, checking - * whether the given path is an absolute path on any of the volumes - * returned (this is done by checking whether the path's prefix - * matches). + * Call each of the "listVolumes" function in succession, checking whether + * the given path is an absolute path on any of the volumes returned (this + * is done by checking whether the path's prefix matches). */ fsRecPtr = FsGetFirstFilesystem(); while (fsRecPtr != NULL) { Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc; - /* + + /* * We want to skip the native filesystem in this loop because - * otherwise we won't necessarily pass all the Tcl testsuite -- - * this is because some of the tests artificially change the - * current platform (between win, unix) but the list - * of volumes we get by calling (*proc) will reflect the current - * (real) platform only and this may cause some tests to fail. - * In particular, on unix '/' will match the beginning of - * certain absolute Windows paths starting '//' and those tests - * will go wrong. - * - * Besides these test-suite issues, there is one other reason - * to skip the native filesystem --- since the tclFilename.c - * code has nice fast 'absolute path' checkers, we don't want - * to waste time repeating that effort here, and this - * function is actually called quite often, so if we can - * save the overhead of the native filesystem returning us - * a list of volumes all the time, it is better. + * otherwise we won't necessarily pass all the Tcl testsuite -- this + * is because some of the tests artificially change the current + * platform (between win, unix) but the list of volumes we get by + * calling (*proc) will reflect the current (real) platform only and + * this may cause some tests to fail. In particular, on unix '/' will + * match the beginning of certain absolute Windows paths starting '//' + * and those tests will go wrong. + * + * Besides these test-suite issues, there is one other reason to skip + * the native filesystem --- since the tclFilename.c code has nice + * fast 'absolute path' checkers, we don't want to waste time + * repeating that effort here, and this function is actually called + * quite often, so if we can save the overhead of the native + * filesystem returning us a list of volumes all the time, it is + * better. */ + if ((fsRecPtr->fsPtr != &tclNativeFilesystem) && (proc != NULL)) { int numVolumes; Tcl_Obj *thisFsVolumes = (*proc)(); if (thisFsVolumes != NULL) { - if (Tcl_ListObjLength(NULL, thisFsVolumes, - &numVolumes) != TCL_OK) { - /* - * This is VERY bad; the Tcl_FSListVolumesProc - * didn't return a valid list. Set numVolumes to - * -1 so that we skip the while loop below and just - * return with the current value of 'type'. - * - * It would be better if we could signal an error - * here (but Tcl_Panic seems a bit excessive). + if (Tcl_ListObjLength(NULL, thisFsVolumes, + &numVolumes) != TCL_OK) { + /* + * This is VERY bad; the Tcl_FSListVolumesProc didn't + * return a valid list. Set numVolumes to -1 so that we + * skip the while loop below and just return with the + * current value of 'type'. + * + * It would be better if we could signal an error here + * (but Tcl_Panic seems a bit excessive). */ + numVolumes = -1; } while (numVolumes > 0) { Tcl_Obj *vol; int len; @@ -3684,16 +3960,16 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSRenameFile -- * - * If the two paths given belong to the same filesystem, we call - * that filesystems rename function. Otherwise we simply - * return the posix error 'EXDEV', and -1. + * If the two paths given belong to the same filesystem, we call that + * filesystems rename function. Otherwise we simply return the posix + * error 'EXDEV', and -1. * * Results: - * Standard Tcl error code if a function was called. + * Standard Tcl error code if a function was called. * * Side effects: * A file may be renamed. * *--------------------------------------------------------------------------- @@ -3726,28 +4002,28 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSCopyFile -- * - * If the two paths given belong to the same filesystem, we call - * that filesystem's copy function. Otherwise we simply - * return the posix error 'EXDEV', and -1. - * - * Note that in the native filesystems, 'copyFileProc' is defined - * to copy soft links (i.e. it copies the links themselves, not - * the things they point to). + * If the two paths given belong to the same filesystem, we call that + * filesystem's copy function. Otherwise we simply return the posix + * error 'EXDEV', and -1. + * + * Note that in the native filesystems, 'copyFileProc' is defined to copy + * soft links (i.e. it copies the links themselves, not the things they + * point to). * * Results: - * Standard Tcl error code if a function was called. + * Standard Tcl error code if a function was called. * * Side effects: * A file may be copied. * *--------------------------------------------------------------------------- */ -int +int Tcl_FSCopyFile(srcPathPtr, destPathPtr) Tcl_Obj* srcPathPtr; /* Pathname of file to be copied (UTF-8). */ Tcl_Obj *destPathPtr; /* Pathname of file to copy to (UTF-8). */ { int retVal = -1; @@ -3770,61 +4046,74 @@ /* *--------------------------------------------------------------------------- * * TclCrossFilesystemCopy -- * - * Helper for above function, and for Tcl_FSLoadFile, to copy - * files from one filesystem to another. This function will - * overwrite the target file if it already exists. + * Helper for above function, and for Tcl_FSLoadFile, to copy files from + * one filesystem to another. This function will overwrite the target + * file if it already exists. * * Results: - * Standard Tcl error code. + * Standard Tcl error code. * * Side effects: * A file may be created. * *--------------------------------------------------------------------------- */ -int -TclCrossFilesystemCopy(interp, source, target) +int +TclCrossFilesystemCopy(interp, source, target) Tcl_Interp *interp; /* For error messages */ Tcl_Obj *source; /* Pathname of file to be copied (UTF-8). */ Tcl_Obj *target; /* Pathname of file to copy to (UTF-8). */ { int result = TCL_ERROR; int prot = 0666; - + Tcl_Channel out = Tcl_FSOpenFileChannel(interp, target, "w", prot); if (out != NULL) { - /* It looks like we can copy it over */ - Tcl_Channel in = Tcl_FSOpenFileChannel(interp, source, - "r", prot); + /* + * It looks like we can copy it over. + */ + + Tcl_Channel in = Tcl_FSOpenFileChannel(interp, source, "r", prot); + if (in == NULL) { - /* This is very strange, we checked this above */ + /* + * This is very strange, we checked this above + */ + Tcl_Close(interp, out); + } else { Tcl_StatBuf sourceStatBuf; struct utimbuf tval; - /* - * Copy it synchronously. We might wish to add an - * asynchronous option to support vfs's which are - * slow (e.g. network sockets). + + /* + * Copy it synchronously. We might wish to add an asynchronous + * option to support vfs's which are slow (e.g. network sockets). */ + Tcl_SetChannelOption(interp, in, "-translation", "binary"); Tcl_SetChannelOption(interp, out, "-translation", "binary"); - + if (TclCopyChannel(interp, in, out, -1, NULL) == TCL_OK) { result = TCL_OK; } - /* - * If the copy failed, assume that copy channel left - * a good error message. + + /* + * If the copy failed, assume that copy channel left a good error + * message. */ + Tcl_Close(interp, in); Tcl_Close(interp, out); - - /* Set modification date of copied file */ + + /* + * Set modification date of copied file. + */ + if (Tcl_FSLstat(source, &sourceStatBuf) == 0) { tval.actime = sourceStatBuf.st_atime; tval.modtime = sourceStatBuf.st_mtime; Tcl_FSUtime(target, &tval); } @@ -3836,15 +4125,15 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSDeleteFile -- * - * The appropriate function for the filesystem to which pathPtr - * belongs will be called. + * The appropriate function for the filesystem to which pathPtr belongs + * will be called. * * Results: - * Standard Tcl error code. + * Standard Tcl error code. * * Side effects: * A file may be deleted. * *--------------------------------------------------------------------------- @@ -3868,15 +4157,15 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSCreateDirectory -- * - * The appropriate function for the filesystem to which pathPtr - * belongs will be called. + * The appropriate function for the filesystem to which pathPtr belongs + * will be called. * * Results: - * Standard Tcl error code. + * Standard Tcl error code. * * Side effects: * A directory may be created. * *--------------------------------------------------------------------------- @@ -3900,16 +4189,16 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSCopyDirectory -- * - * If the two paths given belong to the same filesystem, we call - * that filesystems copy-directory function. Otherwise we simply - * return the posix error 'EXDEV', and -1. + * If the two paths given belong to the same filesystem, we call that + * filesystems copy-directory function. Otherwise we simply return the + * posix error 'EXDEV', and -1. * * Results: - * Standard Tcl error code if a function was called. + * Standard Tcl error code if a function was called. * * Side effects: * A directory may be copied. * *--------------------------------------------------------------------------- @@ -3918,13 +4207,13 @@ int Tcl_FSCopyDirectory(srcPathPtr, destPathPtr, errorPtr) Tcl_Obj* srcPathPtr; /* Pathname of directory to be copied * (UTF-8). */ Tcl_Obj *destPathPtr; /* Pathname of target directory (UTF-8). */ - Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a - * new object containing name of file - * causing error, with refCount 1. */ + Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a new + * object containing name of file causing + * error, with refCount 1. */ { int retVal = -1; Tcl_Filesystem *fsPtr, *fsPtr2; fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); @@ -3944,15 +4233,15 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSRemoveDirectory -- * - * The appropriate function for the filesystem to which pathPtr - * belongs will be called. + * The appropriate function for the filesystem to which pathPtr belongs + * will be called. * * Results: - * Standard Tcl error code. + * Standard Tcl error code. * * Side effects: * A directory may be deleted. * *--------------------------------------------------------------------------- @@ -3960,51 +4249,54 @@ int Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr) Tcl_Obj *pathPtr; /* Pathname of directory to be removed * (UTF-8). */ - int recursive; /* If non-zero, removes directories that - * are nonempty. Otherwise, will only remove + int recursive; /* If non-zero, removes directories that are + * nonempty. Otherwise, will only remove * empty directories. */ - Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a - * new object containing name of file - * causing error, with refCount 1. */ + Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a new + * object containing name of file causing + * error, with refCount 1. */ { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr != NULL) { - Tcl_FSRemoveDirectoryProc *proc = fsPtr->removeDirectoryProc; - if (proc != NULL) { - if (recursive) { - /* - * We check whether the cwd lies inside this directory - * and move it if it does. - */ - Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL); - if (cwdPtr != NULL) { - char *cwdStr, *normPathStr; - int cwdLen, normLen; - Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); - if (normPath != NULL) { - normPathStr = Tcl_GetStringFromObj(normPath, &normLen); - cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); - if ((cwdLen >= normLen) && (strncmp(normPathStr, - cwdStr, (size_t) normLen) == 0)) { - /* - * the cwd is inside the directory, so we - * perform a 'cd [file dirname $path]' - */ - Tcl_Obj *dirPtr = TclPathPart(NULL, pathPtr, - TCL_PATH_DIRNAME); - Tcl_FSChdir(dirPtr); - Tcl_DecrRefCount(dirPtr); - } - } - Tcl_DecrRefCount(cwdPtr); - } - } - return (*proc)(pathPtr, recursive, errorPtr); - } + if (fsPtr != NULL && fsPtr->removeDirectoryProc != NULL) { + Tcl_FSRemoveDirectoryProc *proc = fsPtr->removeDirectoryProc; + if (recursive) { + /* + * We check whether the cwd lies inside this directory and move it + * if it does. + */ + + Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL); + + if (cwdPtr != NULL) { + char *cwdStr, *normPathStr; + int cwdLen, normLen; + Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); + + if (normPath != NULL) { + normPathStr = Tcl_GetStringFromObj(normPath, &normLen); + cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); + if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr, + (size_t) normLen) == 0)) { + /* + * The cwd is inside the directory, so we perform a + * 'cd [file dirname $path]'. + */ + + Tcl_Obj *dirPtr = TclPathPart(NULL, pathPtr, + TCL_PATH_DIRNAME); + + Tcl_FSChdir(dirPtr); + Tcl_DecrRefCount(dirPtr); + } + } + Tcl_DecrRefCount(cwdPtr); + } + } + return (*proc)(pathPtr, recursive, errorPtr); } Tcl_SetErrno(ENOENT); return -1; } @@ -4011,17 +4303,17 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSGetFileSystemForPath -- * - * This function determines which filesystem to use for a - * particular path object, and returns the filesystem which - * accepts this file. If no filesystem will accept this object - * as a valid file path, then NULL is returned. + * This function determines which filesystem to use for a particular path + * object, and returns the filesystem which accepts this file. If no + * filesystem will accept this object as a valid file path, then NULL is + * returned. * * Results: -.* NULL or a filesystem which will accept this path. + * NULL or a filesystem which will accept this path. * * Side effects: * The object may be converted to a path type. * *--------------------------------------------------------------------------- @@ -4031,34 +4323,32 @@ Tcl_FSGetFileSystemForPath(pathPtr) Tcl_Obj* pathPtr; { FilesystemRecord *fsRecPtr; Tcl_Filesystem* retVal = NULL; - + if (pathPtr == NULL) { Tcl_Panic("Tcl_FSGetFileSystemForPath called with NULL object"); return NULL; } - - /* - * If the object has a refCount of zero, we reject it. This - * is to avoid possible segfaults or nondeterministic memory - * leaks (i.e. the user doesn't know if they should decrement - * the ref count on return or not). + + /* + * If the object has a refCount of zero, we reject it. This is to avoid + * possible segfaults or nondeterministic memory leaks (i.e. the user + * doesn't know if they should decrement the ref count on return or not). */ - + if (pathPtr->refCount == 0) { Tcl_Panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0"); return NULL; } - - /* - * Check if the filesystem has changed in some way since - * this object's internal representation was calculated. - * Before doing that, assure we have the most up-to-date - * copy of the master filesystem. This is accomplished - * by the FsGetFirstFilesystem() call. + + /* + * Check if the filesystem has changed in some way since this object's + * internal representation was calculated. Before doing that, assure we + * have the most up-to-date copy of the master filesystem. This is + * accomplished by the FsGetFirstFilesystem() call. */ fsRecPtr = FsGetFirstFilesystem(); if (TclFSEnsureEpochOk(pathPtr, &retVal) != TCL_OK) { @@ -4065,24 +4355,26 @@ return NULL; } /* * Call each of the "pathInFilesystem" functions in succession. A - * non-return value of -1 indicates the particular function has - * succeeded. + * non-return value of -1 indicates the particular function has succeeded. */ while ((retVal == NULL) && (fsRecPtr != NULL)) { - Tcl_FSPathInFilesystemProc *proc = fsRecPtr->fsPtr->pathInFilesystemProc; + Tcl_FSPathInFilesystemProc *proc = + fsRecPtr->fsPtr->pathInFilesystemProc; + if (proc != NULL) { ClientData clientData = NULL; int ret = (*proc)(pathPtr, &clientData); if (ret != -1) { - /* - * We assume the type of pathPtr hasn't been changed - * by the above call to the pathInFilesystemProc. + /* + * We assume the type of pathPtr hasn't been changed by the + * above call to the pathInFilesystemProc. */ + TclFSSetPathDetails(pathPtr, fsRecPtr, clientData); retVal = fsRecPtr->fsPtr; } } fsRecPtr = fsRecPtr->nextPtr; @@ -4094,29 +4386,27 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSGetNativePath -- * - * This function is for use by the Win/Unix native filesystems, - * so that they can easily retrieve the native (char* or TCHAR*) - * representation of a path. Other filesystems will probably - * want to implement similar functions. They basically act as a - * safety net around Tcl_FSGetInternalRep. Normally your file- - * system procedures will always be called with path objects - * already converted to the correct filesystem, but if for - * some reason they are called directly (i.e. by procedures - * not in this file), then one cannot necessarily guarantee that - * the path object pointer is from the correct filesystem. - * - * Note: in the future it might be desireable to have separate - * versions of this function with different signatures, for - * example Tcl_FSGetNativeWinPath, Tcl_FSGetNativeUnixPath etc. - * Right now, since native paths are all string based, we use just - * one function. + * This function is for use by the Win/Unix native filesystems, so that + * they can easily retrieve the native (char* or TCHAR*) representation + * of a path. Other filesystems will probably want to implement similar + * functions. They basically act as a safety net around + * Tcl_FSGetInternalRep. Normally your file- system procedures will + * always be called with path objects already converted to the correct + * filesystem, but if for some reason they are called directly (i.e. by + * procedures not in this file), then one cannot necessarily guarantee + * that the path object pointer is from the correct filesystem. + * + * Note: in the future it might be desireable to have separate versions + * of this function with different signatures, for example + * Tcl_FSGetNativeWinPath, Tcl_FSGetNativeUnixPath etc. Right now, since + * native paths are all string based, we use just one function. * * Results: - * NULL or a valid native path. + * NULL or a valid native path. * * Side effects: * See Tcl_FSGetInternalRep. * *--------------------------------------------------------------------------- @@ -4124,148 +4414,151 @@ CONST char * Tcl_FSGetNativePath(pathPtr) Tcl_Obj *pathPtr; { - return (CONST char *)Tcl_FSGetInternalRep(pathPtr, &tclNativeFilesystem); + return (CONST char *) Tcl_FSGetInternalRep(pathPtr, &tclNativeFilesystem); } /* *--------------------------------------------------------------------------- * * NativeFreeInternalRep -- * - * Free a native internal representation, which will be non-NULL. + * Free a native internal representation, which will be non-NULL. * * Results: - * None. + * None. * * Side effects: * Memory is released. * *--------------------------------------------------------------------------- */ -static void + +static void NativeFreeInternalRep(clientData) ClientData clientData; { - ckfree((char*)clientData); + ckfree((char *) clientData); } /* *--------------------------------------------------------------------------- * * Tcl_FSFileSystemInfo -- * - * This function returns a list of two elements. The first - * element is the name of the filesystem (e.g. "native" or "vfs"), - * and the second is the particular type of the given path within - * that filesystem. + * This function returns a list of two elements. The first element is + * the name of the filesystem (e.g. "native" or "vfs"), and the second is + * the particular type of the given path within that filesystem. * * Results: - * A list of two elements. + * A list of two elements. * * Side effects: * The object may be converted to a path type. * *--------------------------------------------------------------------------- */ + Tcl_Obj* Tcl_FSFileSystemInfo(pathPtr) Tcl_Obj* pathPtr; { Tcl_Obj *resPtr; Tcl_FSFilesystemPathTypeProc *proc; Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - + if (fsPtr == NULL) { return NULL; } - + resPtr = Tcl_NewListObj(0,NULL); - - Tcl_ListObjAppendElement(NULL, resPtr, - Tcl_NewStringObj(fsPtr->typeName,-1)); + + Tcl_ListObjAppendElement(NULL, resPtr, + Tcl_NewStringObj(fsPtr->typeName,-1)); proc = fsPtr->filesystemPathTypeProc; if (proc != NULL) { Tcl_Obj *typePtr = (*proc)(pathPtr); if (typePtr != NULL) { Tcl_ListObjAppendElement(NULL, resPtr, typePtr); } } - + return resPtr; } /* *--------------------------------------------------------------------------- * * Tcl_FSPathSeparator -- * - * This function returns the separator to be used for a given - * path. The object returned should have a refCount of zero + * This function returns the separator to be used for a given path. The + * object returned should have a refCount of zero * * Results: - * A Tcl object, with a refCount of zero. If the caller - * needs to retain a reference to the object, it should - * call Tcl_IncrRefCount, and should otherwise free the - * object. + * A Tcl object, with a refCount of zero. If the caller needs to retain a + * reference to the object, it should call Tcl_IncrRefCount, and should + * otherwise free the object. * * Side effects: * The path object may be converted to a path type. * *--------------------------------------------------------------------------- */ + Tcl_Obj* Tcl_FSPathSeparator(pathPtr) Tcl_Obj* pathPtr; { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - + if (fsPtr == NULL) { return NULL; } if (fsPtr->filesystemSeparatorProc != NULL) { return (*fsPtr->filesystemSeparatorProc)(pathPtr); } else { - /* - * Allow filesystems not to provide a filesystemSeparatorProc - * if they wish to use the standard forward slash. + /* + * Allow filesystems not to provide a filesystemSeparatorProc if they + * wish to use the standard forward slash. */ + return Tcl_NewStringObj("/", 1); } } /* *--------------------------------------------------------------------------- * * NativeFilesystemSeparator -- * - * This function is part of the native filesystem support, and - * returns the separator for the given path. + * This function is part of the native filesystem support, and returns + * the separator for the given path. * * Results: - * String object containing the separator character. + * String object containing the separator character. * * Side effects: * None. * *--------------------------------------------------------------------------- */ + static Tcl_Obj* NativeFilesystemSeparator(pathPtr) Tcl_Obj* pathPtr; { char *separator = NULL; /* lint */ switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - separator = "/"; - break; - case TCL_PLATFORM_WINDOWS: - separator = "\\"; - break; + case TCL_PLATFORM_UNIX: + separator = "/"; + break; + case TCL_PLATFORM_WINDOWS: + separator = "\\"; + break; } return Tcl_NewStringObj(separator,1); } /* Everything from here on is contained in this obsolete ifdef */ @@ -4275,22 +4568,21 @@ *---------------------------------------------------------------------- * * TclStatInsertProc -- * * Insert the passed procedure pointer at the head of the list of - * functions which are used during a call to 'TclStat(...)'. The - * passed function should behave exactly like 'TclStat' when called - * during that time (see 'TclStat(...)' for more information). - * The function will be added even if it already in the list. + * functions which are used during a call to 'TclStat(...)'. The passed + * function should behave exactly like 'TclStat' when called during that + * time (see 'TclStat(...)' for more information). The function will be + * added even if it already in the list. * * Results: - * Normally TCL_OK; TCL_ERROR if memory for a new node in the list - * could not be allocated. + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could + * not be allocated. * * Side effects: - * Memory allocated and modifies the link list for 'TclStat' - * functions. + * Memory allocated and modifies the link list for 'TclStat' functions. * *---------------------------------------------------------------------- */ int @@ -4322,19 +4614,18 @@ *---------------------------------------------------------------------- * * TclStatDeleteProc -- * * Removed the passed function pointer from the list of 'TclStat' - * functions. Ensures that the built-in stat function is not - * removvable. + * functions. Ensures that the built-in stat function is not removvable. * * Results: - * TCL_OK if the procedure pointer was successfully removed, - * TCL_ERROR otherwise. + * TCL_OK if the procedure pointer was successfully removed, TCL_ERROR + * otherwise. * * Side effects: - * Memory is deallocated and the respective list updated. + * Memory is deallocated and the respective list updated. * *---------------------------------------------------------------------- */ int @@ -4345,14 +4636,15 @@ StatProc *tmpStatProcPtr; StatProc *prevStatProcPtr = NULL; Tcl_MutexLock(&obsoleteFsHookMutex); tmpStatProcPtr = statProcList; + /* - * Traverse the 'statProcList' looking for the particular node - * whose 'proc' member matches 'proc' and remove that one from - * the list. Ensure that the "default" node cannot be removed. + * Traverse the 'statProcList' looking for the particular node whose + * 'proc' member matches 'proc' and remove that one from the list. Ensure + * that the "default" node cannot be removed. */ while ((retVal == TCL_ERROR) && (tmpStatProcPtr != NULL)) { if (tmpStatProcPtr->proc == proc) { if (prevStatProcPtr == NULL) { @@ -4379,23 +4671,21 @@ *---------------------------------------------------------------------- * * TclAccessInsertProc -- * * Insert the passed procedure pointer at the head of the list of - * functions which are used during a call to 'TclAccess(...)'. - * The passed function should behave exactly like 'TclAccess' when - * called during that time (see 'TclAccess(...)' for more - * information). The function will be added even if it already in - * the list. + * functions which are used during a call to 'TclAccess(...)'. The + * passed function should behave exactly like 'TclAccess' when called + * during that time (see 'TclAccess(...)' for more information). The + * function will be added even if it already in the list. * * Results: - * Normally TCL_OK; TCL_ERROR if memory for a new node in the list - * could not be allocated. + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could + * not be allocated. * * Side effects: - * Memory allocated and modifies the link list for 'TclAccess' - * functions. + * Memory allocated and modifies the link list for 'TclAccess' functions. * *---------------------------------------------------------------------- */ int @@ -4431,15 +4721,15 @@ * Removed the passed function pointer from the list of 'TclAccess' * functions. Ensures that the built-in access function is not * removvable. * * Results: - * TCL_OK if the procedure pointer was successfully removed, - * TCL_ERROR otherwise. + * TCL_OK if the procedure pointer was successfully removed, TCL_ERROR + * otherwise. * * Side effects: - * Memory is deallocated and the respective list updated. + * Memory is deallocated and the respective list updated. * *---------------------------------------------------------------------- */ int @@ -4449,13 +4739,13 @@ int retVal = TCL_ERROR; AccessProc *tmpAccessProcPtr; AccessProc *prevAccessProcPtr = NULL; /* - * Traverse the 'accessProcList' looking for the particular node - * whose 'proc' member matches 'proc' and remove that one from - * the list. Ensure that the "default" node cannot be removed. + * Traverse the 'accessProcList' looking for the particular node whose + * 'proc' member matches 'proc' and remove that one from the list. Ensure + * that the "default" node cannot be removed. */ Tcl_MutexLock(&obsoleteFsHookMutex); tmpAccessProcPtr = accessProcList; while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != NULL)) { @@ -4484,22 +4774,22 @@ * * TclOpenFileChannelInsertProc -- * * Insert the passed procedure pointer at the head of the list of * functions which are used during a call to - * 'Tcl_OpenFileChannel(...)'. The passed function should behave - * exactly like 'Tcl_OpenFileChannel' when called during that time - * (see 'Tcl_OpenFileChannel(...)' for more information). The - * function will be added even if it already in the list. + * 'Tcl_OpenFileChannel(...)'. The passed function should behave exactly + * like 'Tcl_OpenFileChannel' when called during that time (see + * 'Tcl_OpenFileChannel(...)' for more information). The function will be + * added even if it already in the list. * * Results: - * Normally TCL_OK; TCL_ERROR if memory for a new node in the list - * could not be allocated. + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could + * not be allocated. * * Side effects: - * Memory allocated and modifies the link list for - * 'Tcl_OpenFileChannel' functions. + * Memory allocated and modifies the link list for 'Tcl_OpenFileChannel' + * functions. * *---------------------------------------------------------------------- */ int @@ -4509,42 +4799,40 @@ int retVal = TCL_ERROR; if (proc != NULL) { OpenFileChannelProc *newOpenFileChannelProcPtr; - newOpenFileChannelProcPtr = - (OpenFileChannelProc *)ckalloc(sizeof(OpenFileChannelProc)); - - if (newOpenFileChannelProcPtr != NULL) { - newOpenFileChannelProcPtr->proc = proc; - Tcl_MutexLock(&obsoleteFsHookMutex); - newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList; - openFileChannelProcList = newOpenFileChannelProcPtr; - Tcl_MutexUnlock(&obsoleteFsHookMutex); - - retVal = TCL_OK; - } - } - - return (retVal); + newOpenFileChannelProcPtr = (OpenFileChannelProc *) + ckalloc(sizeof(OpenFileChannelProc)); + + newOpenFileChannelProcPtr->proc = proc; + Tcl_MutexLock(&obsoleteFsHookMutex); + newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList; + openFileChannelProcList = newOpenFileChannelProcPtr; + Tcl_MutexUnlock(&obsoleteFsHookMutex); + + retVal = TCL_OK; + } + + return retVal; } /* *---------------------------------------------------------------------- * * TclOpenFileChannelDeleteProc -- * * Removed the passed function pointer from the list of - * 'Tcl_OpenFileChannel' functions. Ensures that the built-in - * open file channel function is not removable. + * 'Tcl_OpenFileChannel' functions. Ensures that the built-in open file + * channel function is not removable. * * Results: - * TCL_OK if the procedure pointer was successfully removed, - * TCL_ERROR otherwise. + * TCL_OK if the procedure pointer was successfully removed, TCL_ERROR + * otherwise. * * Side effects: - * Memory is deallocated and the respective list updated. + * Memory is deallocated and the respective list updated. * *---------------------------------------------------------------------- */ int @@ -4554,13 +4842,12 @@ int retVal = TCL_ERROR; OpenFileChannelProc *tmpOpenFileChannelProcPtr = openFileChannelProcList; OpenFileChannelProc *prevOpenFileChannelProcPtr = NULL; /* - * Traverse the 'openFileChannelProcList' looking for the particular - * node whose 'proc' member matches 'proc' and remove that one from - * the list. + * Traverse the 'openFileChannelProcList' looking for the particular node + * whose 'proc' member matches 'proc' and remove that one from the list. */ Tcl_MutexLock(&obsoleteFsHookMutex); tmpOpenFileChannelProcPtr = openFileChannelProcList; while ((retVal == TCL_ERROR) && @@ -4571,11 +4858,11 @@ } else { prevOpenFileChannelProcPtr->nextPtr = tmpOpenFileChannelProcPtr->nextPtr; } - ckfree((char *)tmpOpenFileChannelProcPtr); + ckfree((char *) tmpOpenFileChannelProcPtr); retVal = TCL_OK; } else { prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr; tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr; @@ -4584,5 +4871,13 @@ Tcl_MutexUnlock(&obsoleteFsHookMutex); return retVal; } #endif /* USE_OBSOLETE_FS_HOOKS */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclIndexObj.c ================================================================== --- generic/tclIndexObj.c +++ generic/tclIndexObj.c @@ -1,24 +1,24 @@ -/* +/* * tclIndexObj.c -- * - * This file implements objects of type "index". This object type - * is used to lookup a keyword in a table of valid values and cache - * the index of the matching entry. + * This file implements objects of type "index". This object type is used + * to lookup a keyword in a table of valid values and cache the index of + * the matching entry. * * Copyright (c) 1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIndexObj.c,v 1.22 2004/11/25 16:37:15 dkf Exp $ + * RCS: @(#) $Id: tclIndexObj.c,v 1.22.2.2 2005/08/02 18:15:40 dgp Exp $ */ #include "tclInt.h" /* - * Prototypes for procedures defined later in this file: + * Prototypes for functions defined later in this file: */ static int SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static void UpdateStringOfIndex _ANSI_ARGS_((Tcl_Obj *objPtr)); @@ -25,26 +25,26 @@ static void DupIndex _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *dupPtr)); static void FreeIndex _ANSI_ARGS_((Tcl_Obj *objPtr)); /* - * The structure below defines the index Tcl object type by means of - * procedures that can be invoked by generic object code. + * The structure below defines the index Tcl object type by means of functions + * that can be invoked by generic object code. */ -Tcl_ObjType tclIndexType = { +static Tcl_ObjType indexType = { "index", /* name */ FreeIndex, /* freeIntRepProc */ DupIndex, /* dupIntRepProc */ UpdateStringOfIndex, /* updateStringProc */ SetIndexFromAny /* setFromAnyProc */ }; /* - * The definition of the internal representation of the "index" - * object; The internalRep.otherValuePtr field of an object of "index" - * type will be a pointer to one of these structures. + * The definition of the internal representation of the "index" object; The + * internalRep.otherValuePtr field of an object of "index" type will be a + * pointer to one of these structures. * * Keep this structure declaration in sync with tclTestObj.c */ typedef struct { @@ -60,35 +60,32 @@ (*((CONST char * CONST *)(((char *)(table)) + ((offset) * (index))))) #define NEXT_ENTRY(table, offset) \ (&(STRING_AT(table, offset, 1))) #define EXPAND_OF(indexRep) \ STRING_AT((indexRep)->tablePtr, (indexRep)->offset, (indexRep)->index) - /* *---------------------------------------------------------------------- * * Tcl_GetIndexFromObj -- * - * This procedure looks up an object's value in a table of strings - * and returns the index of the matching string, if any. + * This function looks up an object's value in a table of strings and + * returns the index of the matching string, if any. * * Results: - * - * If the value of objPtr is identical to or a unique abbreviation - * for one of the entries in objPtr, then the return value is - * TCL_OK and the index of the matching entry is stored at - * *indexPtr. If there isn't a proper match, then TCL_ERROR is - * returned and an error message is left in interp's result (unless - * interp is NULL). The msg argument is used in the error - * message; for example, if msg has the value "option" then the - * error message will say something flag 'bad option "foo": must be + * If the value of objPtr is identical to or a unique abbreviation for + * one of the entries in objPtr, then the return value is TCL_OK and the + * index of the matching entry is stored at *indexPtr. If there isn't a + * proper match, then TCL_ERROR is returned and an error message is left + * in interp's result (unless interp is NULL). The msg argument is used + * in the error message; for example, if msg has the value "option" then + * the error message will say something flag 'bad option "foo": must be * ...' * * Side effects: - * The result of the lookup is cached as the internal rep of - * objPtr, so that repeated lookups can be done quickly. + * The result of the lookup is cached as the internal rep of objPtr, so + * that repeated lookups can be done quickly. * *---------------------------------------------------------------------- */ int @@ -96,28 +93,30 @@ Tcl_Interp *interp; /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr; /* Object containing the string to lookup. */ CONST char **tablePtr; /* Array of strings to compare against the * value of objPtr; last entry must be NULL * and there must not be duplicate entries. */ - CONST char *msg; /* Identifying word to use in error messages. */ + CONST char *msg; /* Identifying word to use in error + * messages. */ int flags; /* 0 or TCL_EXACT */ int *indexPtr; /* Place to store resulting integer index. */ { /* - * See if there is a valid cached result from a previous lookup - * (doing the check here saves the overhead of calling - * Tcl_GetIndexFromObjStruct in the common case where the result - * is cached). + * See if there is a valid cached result from a previous lookup (doing the + * check here saves the overhead of calling Tcl_GetIndexFromObjStruct in + * the common case where the result is cached). */ - if (objPtr->typePtr == &tclIndexType) { + if (objPtr->typePtr == &indexType) { IndexRep *indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr; + /* - * Here's hoping we don't get hit by unfortunate packing - * constraints on odd platforms like a Cray PVP... + * Here's hoping we don't get hit by unfortunate packing constraints + * on odd platforms like a Cray PVP... */ + if (indexRep->tablePtr == (VOID *)tablePtr && indexRep->offset == sizeof(char *)) { *indexPtr = indexRep->index; return TCL_OK; } @@ -129,46 +128,44 @@ /* *---------------------------------------------------------------------- * * Tcl_GetIndexFromObjStruct -- * - * This procedure looks up an object's value given a starting - * string and an offset for the amount of space between strings. - * This is useful when the strings are embedded in some other - * kind of array. + * This function looks up an object's value given a starting string and + * an offset for the amount of space between strings. This is useful when + * the strings are embedded in some other kind of array. * * Results: - * - * If the value of objPtr is identical to or a unique abbreviation - * for one of the entries in objPtr, then the return value is - * TCL_OK and the index of the matching entry is stored at - * *indexPtr. If there isn't a proper match, then TCL_ERROR is - * returned and an error message is left in interp's result (unless - * interp is NULL). The msg argument is used in the error - * message; for example, if msg has the value "option" then the - * error message will say something flag 'bad option "foo": must be + * If the value of objPtr is identical to or a unique abbreviation for + * one of the entries in objPtr, then the return value is TCL_OK and the + * index of the matching entry is stored at *indexPtr. If there isn't a + * proper match, then TCL_ERROR is returned and an error message is left + * in interp's result (unless interp is NULL). The msg argument is used + * in the error message; for example, if msg has the value "option" then + * the error message will say something flag 'bad option "foo": must be * ...' * * Side effects: - * The result of the lookup is cached as the internal rep of - * objPtr, so that repeated lookups can be done quickly. + * The result of the lookup is cached as the internal rep of objPtr, so + * that repeated lookups can be done quickly. * *---------------------------------------------------------------------- */ int -Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, +Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr; /* Object containing the string to lookup. */ CONST VOID *tablePtr; /* The first string in the table. The second * string will be at this address plus the * offset, the third plus the offset again, - * etc. The last entry must be NULL - * and there must not be duplicate entries. */ + * etc. The last entry must be NULL and there + * must not be duplicate entries. */ int offset; /* The number of bytes between entries */ - CONST char *msg; /* Identifying word to use in error messages. */ + CONST char *msg; /* Identifying word to use in error + * messages. */ int flags; /* 0 or TCL_EXACT */ int *indexPtr; /* Place to store resulting integer index. */ { int index, length, i, numAbbrev; char *key, *p1; @@ -179,11 +176,11 @@ /* * See if there is a valid cached result from a previous lookup. */ - if (objPtr->typePtr == &tclIndexType) { + if (objPtr->typePtr == &indexType) { indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr; if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) { *indexPtr = indexRep->index; return TCL_OK; } @@ -199,82 +196,87 @@ numAbbrev = 0; /* * The key should not be empty, otherwise it's not a match. */ - + if (key[0] == '\0') { goto error; } - + /* * Scan the table looking for one of: * - An exact match (always preferred) * - A single abbreviation (allowed depending on flags) * - Several abbreviations (never allowed, but overridden by exact match) */ - for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; + + for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; entryPtr = NEXT_ENTRY(entryPtr, offset), i++) { for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) { if (*p1 == '\0') { index = i; goto done; } } if (*p1 == '\0') { /* - * The value is an abbreviation for this entry. Continue - * checking other entries to make sure it's unique. If we - * get more than one unique abbreviation, keep searching to - * see if there is an exact match, but remember the number - * of unique abbreviations and don't allow either. + * The value is an abbreviation for this entry. Continue checking + * other entries to make sure it's unique. If we get more than one + * unique abbreviation, keep searching to see if there is an exact + * match, but remember the number of unique abbreviations and + * don't allow either. */ numAbbrev++; index = i; } } + /* * Check if we were instructed to disallow abbreviations. */ + if ((flags & TCL_EXACT) || (numAbbrev != 1)) { goto error; } - done: + done: /* - * Cache the found representation. Note that we want to avoid - * allocating a new internal-rep if at all possible since that is - * potentially a slow operation. + * Cache the found representation. Note that we want to avoid allocating a + * new internal-rep if at all possible since that is potentially a slow + * operation. */ - if (objPtr->typePtr == &tclIndexType) { + + if (objPtr->typePtr == &indexType) { indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr; } else { TclFreeIntRep(objPtr); indexRep = (IndexRep *) ckalloc(sizeof(IndexRep)); objPtr->internalRep.otherValuePtr = (VOID *) indexRep; - objPtr->typePtr = &tclIndexType; + objPtr->typePtr = &indexType; } indexRep->tablePtr = (VOID*) tablePtr; indexRep->offset = offset; indexRep->index = index; *indexPtr = index; return TCL_OK; - error: + error: if (interp != NULL) { /* * Produce a fancy error message. */ + int count; TclNewObj(resultPtr); Tcl_SetObjResult(interp, resultPtr); Tcl_AppendStringsToObj(resultPtr, - (numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"", - key, "\": must be ", STRING_AT(tablePtr,offset,0), (char*)NULL); + (numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"", key, + "\": must be ", STRING_AT(tablePtr,offset,0), (char*) NULL); for (entryPtr = NEXT_ENTRY(tablePtr, offset), count = 0; *entryPtr != NULL; entryPtr = NEXT_ENTRY(entryPtr, offset), count++) { if (*NEXT_ENTRY(entryPtr, offset) == NULL) { Tcl_AppendStringsToObj(resultPtr, @@ -292,18 +294,18 @@ /* *---------------------------------------------------------------------- * * SetIndexFromAny -- * - * This procedure is called to convert a Tcl object to index - * internal form. However, this doesn't make sense (need to have a - * table of keywords in order to do the conversion) so the - * procedure always generates an error. + * This function is called to convert a Tcl object to index internal + * form. However, this doesn't make sense (need to have a table of + * keywords in order to do the conversion) so the function always + * generates an error. * * Results: - * The return value is always TCL_ERROR, and an error message is - * left in interp's result if interp isn't NULL. + * The return value is always TCL_ERROR, and an error message is left in + * interp's result if interp isn't NULL. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -323,13 +325,12 @@ /* *---------------------------------------------------------------------- * * UpdateStringOfIndex -- * - * This procedure is called to convert a Tcl object from index - * internal form to its string form. No abbreviation is ever - * generated. + * This function is called to convert a Tcl object from index internal + * form to its string form. No abbreviation is ever generated. * * Results: * None. * * Side effects: @@ -357,19 +358,19 @@ /* *---------------------------------------------------------------------- * * DupIndex -- * - * This procedure is called to copy the internal rep of an index - * Tcl object from to another object. + * This function is called to copy the internal rep of an index Tcl + * object from to another object. * * Results: * None. * * Side effects: - * The internal representation of the target object is updated - * and the type is set. + * The internal representation of the target object is updated and the + * type is set. * *---------------------------------------------------------------------- */ static void @@ -379,20 +380,20 @@ IndexRep *srcIndexRep = (IndexRep *) srcPtr->internalRep.otherValuePtr; IndexRep *dupIndexRep = (IndexRep *) ckalloc(sizeof(IndexRep)); memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep)); dupPtr->internalRep.otherValuePtr = (VOID *) dupIndexRep; - dupPtr->typePtr = &tclIndexType; + dupPtr->typePtr = &indexType; } /* *---------------------------------------------------------------------- * * FreeIndex -- * - * This procedure is called to delete the internal rep of an index - * Tcl object. + * This function is called to delete the internal rep of an index Tcl + * object. * * Results: * None. * * Side effects: @@ -411,167 +412,220 @@ /* *---------------------------------------------------------------------- * * Tcl_WrongNumArgs -- * - * This procedure generates a "wrong # args" error message in an - * interpreter. It is used as a utility function by many command - * procedures. + * This function generates a "wrong # args" error message in an + * interpreter. It is used as a utility function by many command + * functions, including the function that implements procedures. * * Results: * None. * * Side effects: - * An error message is generated in interp's result object to - * indicate that a command was invoked with the wrong number of - * arguments. The message has the form + * An error message is generated in interp's result object to indicate + * that a command was invoked with the wrong number of arguments. The + * message has the form * wrong # args: should be "foo bar additional stuff" - * where "foo" and "bar" are the initial objects in objv (objc - * determines how many of these are printed) and "additional stuff" - * is the contents of the message argument. + * where "foo" and "bar" are the initial objects in objv (objc determines + * how many of these are printed) and "additional stuff" is the contents + * of the message argument. + * + * The message printed is modified somewhat if the command is wrapped + * inside an ensemble. In that case, the error message generated is + * rewritten in such a way that it appears to be generated from the + * user-visible command and not how that command is actually implemented, + * giving a better overall user experience. + * + * Internally, the Tcl core may set the flag INTERP_ALTERNATE_WRONG_ARGS + * in the interpreter to generate complex multi-part messages by calling + * this function repeatedly. This allows the code that knows how to + * handle ensemble-related error messages to be kept here while still + * generating suitable error messages for commands like [read] and + * [socket]. Ideally, this would be done through an extra flags argument, + * but that wouldn't be source-compatible with the existing API and it's + * a fairly rare requirement anyway. * *---------------------------------------------------------------------- */ void Tcl_WrongNumArgs(interp, objc, objv, message) - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments to print - * from objv. */ - Tcl_Obj *CONST objv[]; /* Initial argument objects, which - * should be included in the error - * message. */ - CONST char *message; /* Error message to print after the - * leading objects in objv. The - * message may be NULL. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments to print from objv. */ + Tcl_Obj *CONST objv[]; /* Initial argument objects, which should be + * included in the error message. */ + CONST char *message; /* Error message to print after the leading + * objects in objv. The message may be + * NULL. */ { Tcl_Obj *objPtr; int i, len, elemLen, flags; register IndexRep *indexRep; Interp *iPtr = (Interp *) interp; char *elementStr; -#ifndef AVOID_HACKS_FOR_ITCL - int isFirst = 1; /* Special flag used to inhibit the - * treating of the first word as a - * list element so the hacky way Itcl - * does error message generation for - * ensembles will still work. - * [Bug 1066837] */ -#define MAY_QUOTE_WORD (!isFirst) -#else /* !AVOID_HACKS_FOR_ITCL */ -#define MAY_QUOTE_WORD 1 -#endif /* AVOID_HACKS_FOR_ITCL */ - - TclNewObj(objPtr); - Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1); - - /* - * Check to see if we are processing an ensemble implementation, - * and if so rewrite the results in terms of how the ensemble was - * invoked. - */ - - if (iPtr->ensembleRewrite.sourceObjs != NULL) { - /* - * We only know how to do rewriting if all the replaced - * objects are actually arguments (in objv) to this function. - * Otherwise it just gets too complicated... - */ - - if (objc >= iPtr->ensembleRewrite.numInsertedObjs) { - objv += iPtr->ensembleRewrite.numInsertedObjs; - objc -= iPtr->ensembleRewrite.numInsertedObjs; - /* - * We assume no object is of index type. - */ - for (i=0 ; iensembleRewrite.numRemovedObjs ; i++) { - /* - * Add the element, quoting it if necessary. - */ - - elementStr = Tcl_GetStringFromObj( - iPtr->ensembleRewrite.sourceObjs[i], &elemLen); - len = Tcl_ScanCountedElement(elementStr, elemLen, &flags); - if (MAY_QUOTE_WORD && len != elemLen) { - char *quotedElementStr = ckalloc((unsigned) len); - len = Tcl_ConvertCountedElement(elementStr, elemLen, - quotedElementStr, flags); - Tcl_AppendToObj(objPtr, quotedElementStr, len); - ckfree(quotedElementStr); - } else { - Tcl_AppendToObj(objPtr, elementStr, elemLen); - } -#ifndef AVOID_HACKS_FOR_ITCL - isFirst = 0; -#endif /* AVOID_HACKS_FOR_ITCL */ - - /* - * Add a space if the word is not the last one (which - * has a moderately complex condition here). - */ - - if ((i < (iPtr->ensembleRewrite.numRemovedObjs - 1)) - || objc || message) { - Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL); - } - } - } - } - - /* - * Now add the arguments (other than those rewritten) that the - * caller took from its calling context. - */ - - for (i = 0; i < objc; i++) { - /* - * If the object is an index type use the index table which allows - * for the correct error message even if the subcommand was - * abbreviated. Otherwise, just use the string rep. - */ - - if (objv[i]->typePtr == &tclIndexType) { + + /* + * [incr Tcl] does something fairly horrific when generating error + * messages for its ensembles; it passes the whole set of ensemble + * arguments as a list in the first argument. This means that this code + * causes a problem in iTcl if it attempts to correctly quote all + * arguments, which would be the correct thing to do. We work around this + * nasty behaviour for now, and hope that we can remove it all in the + * future... + */ + +#ifndef AVOID_HACKS_FOR_ITCL + int isFirst = 1; /* Special flag used to inhibit the treating + * of the first word as a list element so the + * hacky way Itcl generates error messages for + * its ensembles will still work. [Bug + * 1066837] */ +# define MAY_QUOTE_WORD (!isFirst) +# define AFTER_FIRST_WORD (isFirst = 0) +#else /* !AVOID_HACKS_FOR_ITCL */ +# define MAY_QUOTE_WORD 1 +# define AFTER_FIRST_WORD (void) 0 +#endif /* AVOID_HACKS_FOR_ITCL */ + + TclNewObj(objPtr); + if (iPtr->flags & INTERP_ALTERNATE_WRONG_ARGS) { + Tcl_AppendObjToObj(objPtr, Tcl_GetObjResult(interp)); + Tcl_AppendToObj(objPtr, " or \"", -1); + } else { + Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1); + } + + /* + * Check to see if we are processing an ensemble implementation, and if so + * rewrite the results in terms of how the ensemble was invoked. + */ + + if (iPtr->ensembleRewrite.sourceObjs != NULL) { + int toSkip = iPtr->ensembleRewrite.numInsertedObjs; + int toPrint = iPtr->ensembleRewrite.numRemovedObjs; + Tcl_Obj * CONST *origObjv = iPtr->ensembleRewrite.sourceObjs; + + /* + * We only know how to do rewriting if all the replaced objects are + * actually arguments (in objv) to this function. Otherwise it just + * gets too complicated and we'd be better off just giving a slightly + * confusing error message... + */ + + if (objc < toSkip) { + goto addNormalArgumentsToMessage; + } + + /* + * Strip out the actual arguments that the ensemble inserted. + */ + + objv += toSkip; + objc -= toSkip; + + /* + * We assume no object is of index type. + */ + + for (i=0 ; itypePtr == &indexType) { indexRep = (IndexRep *) objv[i]->internalRep.otherValuePtr; Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), (char *) NULL); } else { /* * Quote the argument if it contains spaces (Bug 942757). */ elementStr = Tcl_GetStringFromObj(objv[i], &elemLen); len = Tcl_ScanCountedElement(elementStr, elemLen, &flags); + if (MAY_QUOTE_WORD && len != elemLen) { char *quotedElementStr = ckalloc((unsigned) len); + len = Tcl_ConvertCountedElement(elementStr, elemLen, quotedElementStr, flags); Tcl_AppendToObj(objPtr, quotedElementStr, len); ckfree(quotedElementStr); } else { Tcl_AppendToObj(objPtr, elementStr, elemLen); } } -#ifndef AVOID_HACKS_FOR_ITCL - isFirst = 0; -#endif /* AVOID_HACKS_FOR_ITCL */ + + AFTER_FIRST_WORD; /* * Append a space character (" ") if there is more text to follow * (either another element from objv, or the message string). */ - if ((i < (objc - 1)) || message) { + + if (i #include #ifdef NO_LIMITS_H @@ -58,13 +64,38 @@ #else typedef int ptrdiff_t; #endif /* - * Used to tag functions that are only to be visible within the module - * being built and not outside it (where this is supported by the - * linker). + * Ensure WORDS_BIGENDIAN is defined correcly: + * Needs to happen here in addition to configure to work with fat compiles on + * Darwin (i.e. ppc and i386 at the same time). + */ + +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_SYS_PARAM_H +# include +#endif +#ifdef BYTE_ORDER +# ifdef BIG_ENDIAN +# if BYTE_ORDER == BIG_ENDIAN +# undef WORDS_BIGENDIAN +# define WORDS_BIGENDIAN +# endif +# endif +# ifdef LITTLE_ENDIAN +# if BYTE_ORDER == LITTLE_ENDIAN +# undef WORDS_BIGENDIAN +# endif +# endif +#endif + +/* + * Used to tag functions that are only to be visible within the module being + * built and not outside it (where this is supported by the linker). */ #ifndef MODULE_SCOPE # ifdef __cplusplus # define MODULE_SCOPE extern "C" @@ -72,49 +103,50 @@ # define MODULE_SCOPE extern # endif #endif /* - * The following procedures allow namespaces to be customized to - * support special name resolution rules for commands/variables. - * + * 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. */ struct Tcl_ResolvedVarInfo; -typedef Tcl_Var (Tcl_ResolveRuntimeVarProc) _ANSI_ARGS_(( - Tcl_Interp* interp, struct Tcl_ResolvedVarInfo *vinfoPtr)); +typedef Tcl_Var (Tcl_ResolveRuntimeVarProc) (Tcl_Interp* interp, + struct Tcl_ResolvedVarInfo *vinfoPtr); -typedef void (Tcl_ResolveVarDeleteProc) _ANSI_ARGS_(( - struct Tcl_ResolvedVarInfo *vinfoPtr)); +typedef void (Tcl_ResolveVarDeleteProc)(struct Tcl_ResolvedVarInfo *vinfoPtr); /* * The following structure encapsulates the routines needed to resolve a - * variable reference at runtime. Any variable specific state will typically + * variable reference at runtime. Any variable specific state will typically * be appended to this structure. */ - typedef struct Tcl_ResolvedVarInfo { Tcl_ResolveRuntimeVarProc *fetchProc; Tcl_ResolveVarDeleteProc *deleteProc; } Tcl_ResolvedVarInfo; - - -typedef int (Tcl_ResolveCompiledVarProc) _ANSI_ARGS_(( - Tcl_Interp* interp, CONST84 char* name, int length, - Tcl_Namespace *context, Tcl_ResolvedVarInfo **rPtr)); - -typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_(( - Tcl_Interp* interp, CONST84 char* name, Tcl_Namespace *context, - int flags, Tcl_Var *rPtr)); - -typedef int (Tcl_ResolveCmdProc) _ANSI_ARGS_((Tcl_Interp* interp, - CONST84 char* name, Tcl_Namespace *context, int flags, - Tcl_Command *rPtr)); - +typedef int (Tcl_ResolveCompiledVarProc) (Tcl_Interp* interp, + CONST84 char* name, int length, Tcl_Namespace *context, + Tcl_ResolvedVarInfo **rPtr); + +typedef int (Tcl_ResolveVarProc) (Tcl_Interp* interp, CONST84 char* name, + Tcl_Namespace *context, int flags, Tcl_Var *rPtr); + +typedef int (Tcl_ResolveCmdProc) (Tcl_Interp* interp, CONST84 char* name, + Tcl_Namespace *context, int flags, Tcl_Command *rPtr); + typedef struct Tcl_ResolverInfo { Tcl_ResolveCmdProc *cmdResProc; /* Procedure handling command name * resolution. */ Tcl_ResolveVarProc *varResProc; /* Procedure handling variable name * resolution for variables that @@ -129,131 +161,155 @@ * Data structures related to namespaces. *---------------------------------------------------------------- */ typedef struct Tcl_Ensemble Tcl_Ensemble; +typedef struct NamespacePathEntry NamespacePathEntry; /* * The structure below defines a namespace. * Note: the first five fields must match exactly the fields in a - * Tcl_Namespace structure (see tcl.h). If you change one, be sure to - * change the other. + * Tcl_Namespace structure (see tcl.h). If you change one, be sure to change + * the other. */ typedef struct Namespace { - char *name; /* The namespace's simple (unqualified) - * name. This contains no ::'s. The name of - * the global namespace is "" although "::" - * is an synonym. */ - char *fullName; /* The namespace's fully qualified name. - * This starts with ::. */ + char *name; /* The namespace's simple (unqualified) name. + * This contains no ::'s. The name of the + * global namespace is "" although "::" is an + * synonym. */ + char *fullName; /* The namespace's fully qualified name. This + * starts with ::. */ ClientData clientData; /* An arbitrary value associated with this * namespace. */ Tcl_NamespaceDeleteProc *deleteProc; /* Procedure invoked when deleting the * namespace to, e.g., free clientData. */ - struct Namespace *parentPtr;/* Points to the namespace that contains - * this one. NULL if this is the global + struct Namespace *parentPtr;/* Points to the namespace that contains this + * one. NULL if this is the global * namespace. */ - Tcl_HashTable childTable; /* Contains any child namespaces. Indexed - * by strings; values have type - * (Namespace *). */ + Tcl_HashTable childTable; /* Contains any child namespaces. Indexed by + * strings; values have type (Namespace *). */ long nsId; /* Unique id for the namespace. */ Tcl_Interp *interp; /* The interpreter containing this * namespace. */ - int flags; /* OR-ed combination of the namespace - * status flags NS_DYING and NS_DEAD - * listed below. */ + int flags; /* OR-ed combination of the namespace status + * flags NS_DYING and NS_DEAD listed below. */ int activationCount; /* Number of "activations" or active call - * frames for this namespace that are on - * the Tcl call stack. The namespace won't - * be freed until activationCount becomes - * zero. */ - int refCount; /* Count of references by namespaceName * - * objects. The namespace can't be freed - * until refCount becomes zero. */ + * frames for this namespace that are on the + * Tcl call stack. The namespace won't be + * freed until activationCount becomes zero. */ + int refCount; /* Count of references by namespaceName + * objects. The namespace can't be freed until + * refCount becomes zero. */ Tcl_HashTable cmdTable; /* Contains all the commands currently * registered in the namespace. Indexed by * strings; values have type (Command *). * Commands imported by Tcl_Import have * Command structures that point (via an - * ImportedCmdRef structure) to the - * Command structure in the source - * namespace's command table. */ + * ImportedCmdRef structure) to the Command + * structure in the source namespace's command + * table. */ Tcl_HashTable varTable; /* Contains all the (global) variables - * currently in this namespace. Indexed - * by strings; values have type (Var *). */ + * currently in this namespace. Indexed by + * strings; values have type (Var *). */ char **exportArrayPtr; /* Points to an array of string patterns - * specifying which commands are exported. - * A pattern may include "string match" - * style wildcard characters to specify - * multiple commands; however, no namespace - * qualifiers are allowed. NULL if no - * export patterns are registered. */ + * specifying which commands are exported. A + * pattern may include "string match" style + * wildcard characters to specify multiple + * commands; however, no namespace qualifiers + * are allowed. NULL if no export patterns are + * registered. */ int numExportPatterns; /* Number of export patterns currently * registered using "namespace export". */ - int maxExportPatterns; /* Mumber of export patterns for which - * space is currently allocated. */ + int maxExportPatterns; /* Mumber of export patterns for which space + * is currently allocated. */ int cmdRefEpoch; /* Incremented if a newly added command - * shadows a command for which this - * namespace has already cached a Command * - * pointer; this causes all its cached - * Command* pointers to be invalidated. */ - int resolverEpoch; /* Incremented whenever (a) the name resolution - * rules change for this namespace or (b) a - * newly added command shadows a command that - * is compiled to bytecodes. - * This invalidates all byte codes compiled - * in the namespace, causing the code to be + * shadows a command for which this namespace + * has already cached a Command * pointer; + * this causes all its cached Command* + * pointers to be invalidated. */ + int resolverEpoch; /* Incremented whenever (a) the name + * resolution rules change for this namespace + * or (b) a newly added command shadows a + * command that is compiled to bytecodes. This + * invalidates all byte codes compiled in the + * namespace, causing the code to be * recompiled under the new rules.*/ Tcl_ResolveCmdProc *cmdResProc; - /* If non-null, this procedure overrides - * the usual command resolution mechanism - * in Tcl. This procedure is invoked - * within Tcl_FindCommand to resolve all - * command references within the namespace. */ + /* If non-null, this procedure overrides the + * usual command resolution mechanism in Tcl. + * This procedure is invoked within + * Tcl_FindCommand to resolve all command + * references within the namespace. */ Tcl_ResolveVarProc *varResProc; - /* If non-null, this procedure overrides - * the usual variable resolution mechanism - * in Tcl. This procedure is invoked - * within Tcl_FindNamespaceVar to resolve all - * variable references within the namespace - * at runtime. */ + /* If non-null, this procedure overrides the + * usual variable resolution mechanism in Tcl. + * This procedure is invoked within + * Tcl_FindNamespaceVar to resolve all + * variable references within the namespace at + * runtime. */ Tcl_ResolveCompiledVarProc *compiledVarResProc; - /* If non-null, this procedure overrides - * the usual variable resolution mechanism - * in Tcl. This procedure is invoked - * within LookupCompiledLocal to resolve - * variable references within the namespace - * at compile time. */ + /* If non-null, this procedure overrides the + * usual variable resolution mechanism in Tcl. + * This procedure is invoked within + * LookupCompiledLocal to resolve variable + * references within the namespace at compile + * time. */ int exportLookupEpoch; /* Incremented whenever a command is added to * a namespace, removed from a namespace or * the exports of a namespace are changed. * Allows TIP#112-driven command lists to be * validated efficiently. */ Tcl_Ensemble *ensembles; /* List of structures that contain the details * of the ensembles that are implemented on * top of this namespace. */ + int commandPathLength; /* The length of the explicit path. */ + NamespacePathEntry *commandPathArray; + /* The explicit path of the namespace as an + * array. */ + NamespacePathEntry *commandPathSourceList; + /* Linked list of path entries that point to + * this namespace. */ } Namespace; + +/* + * An entry on a namespace's command resolution path. + */ + +struct NamespacePathEntry { + Namespace *nsPtr; /* What does this path entry point to? If it + * is NULL, this path entry points is + * redundant and should be skipped. */ + Namespace *creatorNsPtr; /* Where does this path entry point from? This + * allows for efficient invalidation of + * references when the path entry's target + * updates its current list of defined + * commands. */ + NamespacePathEntry *prevPtr, *nextPtr; + /* Linked list pointers or NULL at either end + * of the list that hangs off Namespace's + * commandPathSourceList field. */ +}; /* * Flags used to represent the status of a namespace: * * NS_DYING - 1 means Tcl_DeleteNamespace has been called to delete the * namespace but there are still active call frames on the Tcl * stack that refer to the namespace. When the last call frame * referring to it has been popped, it's variables and command - * will be destroyed and it will be marked "dead" (NS_DEAD). - * The namespace can no longer be looked up by name. + * will be destroyed and it will be marked "dead" (NS_DEAD). The + * namespace can no longer be looked up by name. * NS_DEAD - 1 means Tcl_DeleteNamespace has been called to delete the - * namespace and no call frames still refer to it. Its - * variables and command have already been destroyed. This bit - * allows the namespace resolution code to recognize that the - * namespace is "deleted". When the last namespaceName object - * in any byte code unit that refers to the namespace has - * been freed (i.e., when the namespace's refCount is 0), the - * namespace's storage will be freed. + * namespace and no call frames still refer to it. Its variables + * and command have already been destroyed. This bit allows the + * namespace resolution code to recognize that the namespace is + * "deleted". When the last namespaceName object in any byte code + * unit that refers to the namespace has been freed (i.e., when + * the namespace's refCount is 0), the namespace's storage will + * be freed. */ #define NS_DYING 0x01 #define NS_DEAD 0x02 @@ -269,230 +325,226 @@ #define TCL_CREATE_NS_IF_UNKNOWN 0x800 #define TCL_FIND_ONLY_NS 0x1000 /* *---------------------------------------------------------------- - * Data structures related to variables. These are used primarily - * in tclVar.c + * Data structures related to variables. These are used primarily in tclVar.c *---------------------------------------------------------------- */ /* - * The following structure defines a variable trace, which is used to - * invoke a specific C procedure whenever certain operations are performed - * on a variable. + * The following structure defines a variable trace, which is used to invoke a + * specific C procedure whenever certain operations are performed on a + * variable. */ typedef struct VarTrace { - Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given - * by flags are performed on variable. */ + Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given by + * flags are performed on variable. */ ClientData clientData; /* Argument to pass to proc. */ int flags; /* What events the trace procedure is - * interested in: OR-ed combination of + * interested in: OR-ed combination of * TCL_TRACE_READS, TCL_TRACE_WRITES, * TCL_TRACE_UNSETS and TCL_TRACE_ARRAY. */ - struct VarTrace *nextPtr; /* Next in list of traces associated with - * a particular variable. */ + struct VarTrace *nextPtr; /* Next in list of traces associated with a + * particular variable. */ } VarTrace; /* - * The following structure defines a command trace, which is used to - * invoke a specific C procedure whenever certain operations are performed - * on a command. + * The following structure defines a command trace, which is used to invoke a + * specific C procedure whenever certain operations are performed on a + * command. */ typedef struct CommandTrace { - Tcl_CommandTraceProc *traceProc;/* Procedure to call when operations given - * by flags are performed on command. */ - ClientData clientData; /* Argument to pass to proc. */ - int flags; /* What events the trace procedure is - * interested in: OR-ed combination of - * TCL_TRACE_RENAME, TCL_TRACE_DELETE. */ - struct CommandTrace *nextPtr; /* Next in list of traces associated with - * a particular command. */ - int refCount; /* Used to ensure this structure is - * not deleted too early. Keeps track - * of how many pieces of code have - * a pointer to this structure. */ + Tcl_CommandTraceProc *traceProc; + /* Procedure to call when operations given by + * flags are performed on command. */ + ClientData clientData; /* Argument to pass to proc. */ + int flags; /* What events the trace procedure is + * interested in: OR-ed combination of + * TCL_TRACE_RENAME, TCL_TRACE_DELETE. */ + struct CommandTrace *nextPtr; + /* Next in list of traces associated with a + * particular command. */ + int refCount; /* Used to ensure this structure is not + * deleted too early. Keeps track of how many + * pieces of code have a pointer to this + * structure. */ } CommandTrace; /* - * When a command trace is active (i.e. its associated procedure is - * executing), one of the following structures is linked into a list - * associated with the command's interpreter. The information in - * the structure is needed in order for Tcl to behave reasonably - * if traces are deleted while traces are active. + * When a command trace is active (i.e. its associated procedure is executing) + * one of the following structures is linked into a list associated with the + * command's interpreter. The information in the structure is needed in order + * for Tcl to behave reasonably if traces are deleted while traces are active. */ typedef struct ActiveCommandTrace { struct Command *cmdPtr; /* Command that's being traced. */ struct ActiveCommandTrace *nextPtr; - /* Next in list of all active command - * traces for the interpreter, or NULL - * if no more. */ - CommandTrace *nextTracePtr; /* Next trace to check after current - * trace procedure returns; if this - * trace gets deleted, must update pointer - * to avoid using free'd memory. */ + /* Next in list of all active command traces + * for the interpreter, or NULL if no more. */ + CommandTrace *nextTracePtr; /* Next trace to check after current trace + * procedure returns; if this trace gets + * deleted, must update pointer to avoid using + * free'd memory. */ + int reverseScan; /* Boolean set true when traces are scanning + * in reverse order. */ } ActiveCommandTrace; /* * When a variable trace is active (i.e. its associated procedure is - * executing), one of the following structures is linked into a list - * associated with the variable's interpreter. The information in - * the structure is needed in order for Tcl to behave reasonably - * if traces are deleted while traces are active. + * executing) one of the following structures is linked into a list associated + * with the variable's interpreter. The information in the structure is needed + * in order for Tcl to behave reasonably if traces are deleted while traces + * are active. */ typedef struct ActiveVarTrace { struct Var *varPtr; /* Variable that's being traced. */ struct ActiveVarTrace *nextPtr; - /* Next in list of all active variable - * traces for the interpreter, or NULL - * if no more. */ - VarTrace *nextTracePtr; /* Next trace to check after current - * trace procedure returns; if this - * trace gets deleted, must update pointer - * to avoid using free'd memory. */ + /* Next in list of all active variable traces + * for the interpreter, or NULL if no more. */ + VarTrace *nextTracePtr; /* Next trace to check after current trace + * procedure returns; if this trace gets + * deleted, must update pointer to avoid using + * free'd memory. */ } ActiveVarTrace; /* - * The following structure describes an enumerative search in progress on - * an array variable; this are invoked with options to the "array" - * command. + * The following structure describes an enumerative search in progress on an + * array variable; this are invoked with options to the "array" command. */ typedef struct ArraySearch { int id; /* Integer id used to distinguish among - * multiple concurrent searches for the - * same array. */ + * multiple concurrent searches for the same + * array. */ struct Var *varPtr; /* Pointer to array variable that's being * searched. */ - Tcl_HashSearch search; /* Info kept by the hash module about - * progress through the array. */ - Tcl_HashEntry *nextEntry; /* Non-null means this is the next element - * to be enumerated (it's leftover from - * the Tcl_FirstHashEntry call or from - * an "array anymore" command). NULL - * means must call Tcl_NextHashEntry - * to get value to return. */ - struct ArraySearch *nextPtr;/* Next in list of all active searches - * for this variable, or NULL if this is - * the last one. */ + Tcl_HashSearch search; /* Info kept by the hash module about progress + * through the array. */ + Tcl_HashEntry *nextEntry; /* Non-null means this is the next element to + * be enumerated (it's leftover from the + * Tcl_FirstHashEntry call or from an "array + * anymore" command). NULL means must call + * Tcl_NextHashEntry to get value to + * return. */ + struct ArraySearch *nextPtr;/* Next in list of all active searches for + * this variable, or NULL if this is the last + * one. */ } ArraySearch; /* - * The structure below defines a variable, which associates a string name - * with a Tcl_Obj value. These structures are kept in procedure call frames - * (for local variables recognized by the compiler) or in the heap (for - * global variables and any variable not known to the compiler). For each - * Var structure in the heap, a hash table entry holds the variable name and - * a pointer to the Var structure. + * The structure below defines a variable, which associates a string name with + * a Tcl_Obj value. These structures are kept in procedure call frames (for + * local variables recognized by the compiler) or in the heap (for global + * variables and any variable not known to the compiler). For each Var + * structure in the heap, a hash table entry holds the variable name and a + * pointer to the Var structure. */ typedef struct Var { union { - Tcl_Obj *objPtr; /* The variable's object value. Used for + Tcl_Obj *objPtr; /* The variable's object value. Used for * scalar variables and array elements. */ Tcl_HashTable *tablePtr;/* For array variables, this points to - * information about the hash table used - * to implement the associative array. - * Points to malloc-ed data. */ - struct Var *linkPtr; /* If this is a global variable being - * referred to in a procedure, or a variable - * created by "upvar", this field points to - * the referenced variable's Var struct. */ + * information about the hash table used to + * implement the associative array. Points to + * ckalloc-ed data. */ + struct Var *linkPtr; /* If this is a global variable being referred + * to in a procedure, or a variable created by + * "upvar", this field points to the + * referenced variable's Var struct. */ } value; char *name; /* NULL if the variable is in a hashtable, - * otherwise points to the variable's - * name. It is used, e.g., by TclLookupVar - * and "info locals". The storage for the - * characters of the name is not owned by - * the Var and must not be freed when - * freeing the Var. */ - Namespace *nsPtr; /* Points to the namespace that contains - * this variable or NULL if the variable is - * a local variable in a Tcl procedure. */ + * otherwise points to the variable's name. It + * is used, e.g., by TclLookupVar and "info + * locals". The storage for the characters of + * the name is not owned by the Var and must + * not be freed when freeing the Var. */ + Namespace *nsPtr; /* Points to the namespace that contains this + * variable or NULL if the variable is a local + * variable in a Tcl procedure. */ Tcl_HashEntry *hPtr; /* If variable is in a hashtable, either the * hash table entry that refers to this * variable or NULL if the variable has been - * detached from its hash table (e.g. an - * array is deleted, but some of its - * elements are still referred to in - * upvars). NULL if the variable is not in a - * hashtable. This is used to delete an - * variable from its hashtable if it is no - * longer needed. */ + * detached from its hash table (e.g. an array + * is deleted, but some of its elements are + * still referred to in upvars). NULL if the + * variable is not in a hashtable. This is + * used to delete an variable from its + * hashtable if it is no longer needed. */ int refCount; /* Counts number of active uses of this * variable, not including its entry in the * call frame or the hash table: 1 for each * additional variable whose linkPtr points * here, 1 for each nested trace active on - * variable, and 1 if the variable is a + * variable, and 1 if the variable is a * namespace variable. This record can't be * deleted until refCount becomes 0. */ VarTrace *tracePtr; /* First in list of all traces set for this * variable. */ - ArraySearch *searchPtr; /* First in list of all searches active - * for this variable, or NULL if none. */ + ArraySearch *searchPtr; /* First in list of all searches active for + * this variable, or NULL if none. */ int flags; /* Miscellaneous bits of information about * variable. See below for definitions. */ } Var; /* * Flag bits for variables. The first three (VAR_SCALAR, VAR_ARRAY, and * VAR_LINK) are mutually exclusive and give the "type" of the variable. - * VAR_UNDEFINED is independent of the variable's type. - * - * VAR_SCALAR - 1 means this is a scalar variable and not - * an array or link. The "objPtr" field points - * to the variable's value, a Tcl object. - * VAR_ARRAY - 1 means this is an array variable rather - * than a scalar variable or link. The - * "tablePtr" field points to the array's - * hashtable for its elements. - * VAR_LINK - 1 means this Var structure contains a - * pointer to another Var structure that - * either has the real value or is itself - * another VAR_LINK pointer. Variables like - * this come about through "upvar" and "global" - * commands, or through references to variables - * in enclosing namespaces. - * VAR_UNDEFINED - 1 means that the variable is in the process - * of being deleted. An undefined variable - * logically does not exist and survives only - * while it has a trace, or if it is a global - * variable currently being used by some - * procedure. + * VAR_UNDEFINED is independent of the variable's type. + * + * VAR_SCALAR - 1 means this is a scalar variable and not an + * array or link. The "objPtr" field points to + * the variable's value, a Tcl object. + * VAR_ARRAY - 1 means this is an array variable rather than + * a scalar variable or link. The "tablePtr" + * field points to the array's hashtable for its + * elements. + * VAR_LINK - 1 means this Var structure contains a pointer + * to another Var structure that either has the + * real value or is itself another VAR_LINK + * pointer. Variables like this come about + * through "upvar" and "global" commands, or + * through references to variables in enclosing + * namespaces. + * VAR_UNDEFINED - 1 means that the variable is in the process of + * being deleted. An undefined variable logically + * does not exist and survives only while it has + * a trace, or if it is a global variable + * currently being used by some procedure. * VAR_IN_HASHTABLE - 1 means this variable is in a hashtable and - * the Var structure is malloced. 0 if it is - * a local variable that was assigned a slot - * in a procedure frame by the compiler so the - * Var storage is part of the call frame. + * the Var structure is malloced. 0 if it is a + * local variable that was assigned a slot in a + * procedure frame by the compiler so the Var + * storage is part of the call frame. * VAR_TRACE_ACTIVE - 1 means that trace processing is currently - * underway for a read or write access, so - * new read or write accesses should not cause - * trace procedures to be called and the - * variable can't be deleted. + * underway for a read or write access, so new + * read or write accesses should not cause trace + * procedures to be called and the variable can't + * be deleted. * VAR_ARRAY_ELEMENT - 1 means that this variable is an array - * element, so it is not legal for it to be - * an array itself (the VAR_ARRAY flag had - * better not be set). - * VAR_NAMESPACE_VAR - 1 means that this variable was declared - * as a namespace variable. This flag ensures - * it persists until its namespace is - * destroyed or until the variable is unset; - * it will persist even if it has not been - * initialized and is marked undefined. - * The variable's refCount is incremented to - * reflect the "reference" from its namespace. - * - * The following additional flags are used with the CompiledLocal type - * defined below: + * element, so it is not legal for it to be an + * array itself (the VAR_ARRAY flag had better + * not be set). + * VAR_NAMESPACE_VAR - 1 means that this variable was declared as a + * namespace variable. This flag ensures it + * persists until its namespace is destroyed or + * until the variable is unset; it will persist + * even if it has not been initialized and is + * marked undefined. The variable's refCount is + * incremented to reflect the "reference" from + * its namespace. + * + * The following additional flags are used with the CompiledLocal type defined + * below: * * VAR_ARGUMENT - 1 means that this variable holds a procedure - * argument. + * argument. * VAR_TEMPORARY - 1 if the local variable is an anonymous * temporary variable. Temporaries have a NULL * name. * VAR_RESOLVED - 1 if name resolution has been done for this * variable. @@ -507,22 +559,23 @@ #define VAR_ARRAY_ELEMENT 0x40 #define VAR_NAMESPACE_VAR 0x80 #define VAR_ARGUMENT 0x100 #define VAR_TEMPORARY 0x200 -#define VAR_RESOLVED 0x400 +#define VAR_RESOLVED 0x400 +#define VAR_IS_ARGS 0x800 /* * Macros to ensure that various flag bits are set properly for variables. * The ANSI C "prototypes" for these macros are: * - * MODULE_SCOPE void TclSetVarScalar _ANSI_ARGS_((Var *varPtr)); - * MODULE_SCOPE void TclSetVarArray _ANSI_ARGS_((Var *varPtr)); - * MODULE_SCOPE void TclSetVarLink _ANSI_ARGS_((Var *varPtr)); - * MODULE_SCOPE void TclSetVarArrayElement _ANSI_ARGS_((Var *varPtr)); - * MODULE_SCOPE void TclSetVarUndefined _ANSI_ARGS_((Var *varPtr)); - * MODULE_SCOPE void TclClearVarUndefined _ANSI_ARGS_((Var *varPtr)); + * MODULE_SCOPE void TclSetVarScalar(Var *varPtr); + * MODULE_SCOPE void TclSetVarArray(Var *varPtr); + * MODULE_SCOPE void TclSetVarLink(Var *varPtr); + * MODULE_SCOPE void TclSetVarArrayElement(Var *varPtr); + * MODULE_SCOPE void TclSetVarUndefined(Var *varPtr); + * MODULE_SCOPE void TclClearVarUndefined(Var *varPtr); */ #define TclSetVarScalar(varPtr) \ (varPtr)->flags = ((varPtr)->flags & ~(VAR_ARRAY|VAR_LINK)) | VAR_SCALAR @@ -555,20 +608,20 @@ /* * Macros to read various flag bits of variables. * The ANSI C "prototypes" for these macros are: * - * MODULE_SCOPE int TclIsVarScalar _ANSI_ARGS_((Var *varPtr)); - * MODULE_SCOPE int TclIsVarLink _ANSI_ARGS_((Var *varPtr)); - * MODULE_SCOPE int TclIsVarArray _ANSI_ARGS_((Var *varPtr)); - * MODULE_SCOPE int TclIsVarUndefined _ANSI_ARGS_((Var *varPtr)); - * MODULE_SCOPE int TclIsVarArrayElement _ANSI_ARGS_((Var *varPtr)); - * MODULE_SCOPE int TclIsVarTemporary _ANSI_ARGS_((Var *varPtr)); - * MODULE_SCOPE int TclIsVarArgument _ANSI_ARGS_((Var *varPtr)); - * MODULE_SCOPE int TclIsVarResolved _ANSI_ARGS_((Var *varPtr)); + * MODULE_SCOPE int TclIsVarScalar(Var *varPtr); + * MODULE_SCOPE int TclIsVarLink(Var *varPtr); + * MODULE_SCOPE int TclIsVarArray(Var *varPtr); + * MODULE_SCOPE int TclIsVarUndefined(Var *varPtr); + * MODULE_SCOPE int TclIsVarArrayElement(Var *varPtr); + * MODULE_SCOPE int TclIsVarTemporary(Var *varPtr); + * MODULE_SCOPE int TclIsVarArgument(Var *varPtr); + * MODULE_SCOPE int TclIsVarResolved(Var *varPtr); */ - + #define TclIsVarScalar(varPtr) \ ((varPtr)->flags & VAR_SCALAR) #define TclIsVarLink(varPtr) \ ((varPtr)->flags & VAR_LINK) @@ -585,14 +638,14 @@ #define TclIsVarNamespaceVar(varPtr) \ ((varPtr)->flags & VAR_NAMESPACE_VAR) #define TclIsVarTemporary(varPtr) \ ((varPtr)->flags & VAR_TEMPORARY) - + #define TclIsVarArgument(varPtr) \ ((varPtr)->flags & VAR_ARGUMENT) - + #define TclIsVarResolved(varPtr) \ ((varPtr)->flags & VAR_RESOLVED) #define TclIsVarTraceActive(varPtr) \ ((varPtr)->flags & VAR_TRACE_ACTIVE) @@ -603,11 +656,11 @@ /* * Macros for direct variable access by TEBC */ #define TclIsVarDirectReadable(varPtr) \ - (TclIsVarScalar(varPtr) \ + (TclIsVarScalar(varPtr) \ && !TclIsVarUndefined(varPtr) \ && TclIsVarUntraced(varPtr)) #define TclIsVarDirectWritable(varPtr) \ ( !(((varPtr)->flags & VAR_IN_HASHTABLE) \ @@ -616,12 +669,12 @@ && (TclIsVarScalar(varPtr) \ || TclIsVarUndefined(varPtr))) /* *---------------------------------------------------------------- - * Data structures related to procedures. These are used primarily - * in tclProc.c, tclCompile.c, and tclExecute.c. + * Data structures related to procedures. These are used primarily in + * tclProc.c, tclCompile.c, and tclExecute.c. *---------------------------------------------------------------- */ /* * Forward declaration to prevent an error when the forward reference to @@ -630,95 +683,96 @@ struct Command; /* * The variable-length structure below describes a local variable of a - * procedure that was recognized by the compiler. These variables have a - * name, an element in the array of compiler-assigned local variables in the + * procedure that was recognized by the compiler. These variables have a name, + * an element in the array of compiler-assigned local variables in the * procedure's call frame, and various other items of information. If the - * local variable is a formal argument, it may also have a default value. - * The compiler can't recognize local variables whose names are - * expressions (these names are only known at runtime when the expressions - * are evaluated) or local variables that are created as a result of an - * "upvar" or "uplevel" command. These other local variables are kept - * separately in a hash table in the call frame. + * local variable is a formal argument, it may also have a default value. The + * compiler can't recognize local variables whose names are expressions (these + * names are only known at runtime when the expressions are evaluated) or + * local variables that are created as a result of an "upvar" or "uplevel" + * command. These other local variables are kept separately in a hash table in + * the call frame. */ typedef struct CompiledLocal { struct CompiledLocal *nextPtr; - /* Next compiler-recognized local variable - * for this procedure, or NULL if this is - * the last local. */ + /* Next compiler-recognized local variable for + * this procedure, or NULL if this is the last + * local. */ int nameLength; /* The number of characters in local - * variable's name. Used to speed up - * variable lookups. */ + * variable's name. Used to speed up variable + * lookups. */ int frameIndex; /* Index in the array of compiler-assigned * variables in the procedure call frame. */ int flags; /* Flag bits for the local variable. Same as * the flags for the Var structure above, - * although only VAR_SCALAR, VAR_ARRAY, + * although only VAR_SCALAR, VAR_ARRAY, * VAR_LINK, VAR_ARGUMENT, VAR_TEMPORARY, and * VAR_RESOLVED make sense. */ Tcl_Obj *defValuePtr; /* Pointer to the default value of an * argument, if any. NULL if not an argument * or, if an argument, no default value. */ Tcl_ResolvedVarInfo *resolveInfo; /* Customized variable resolution info * supplied by the Tcl_ResolveCompiledVarProc * associated with a namespace. Each variable - * is marked by a unique ClientData tag - * during compilation, and that same tag - * is used to find the variable at runtime. */ - char name[4]; /* Name of the local variable starts here. - * If the name is NULL, this will just be - * '\0'. The actual size of this field will - * be large enough to hold the name. MUST - * BE THE LAST FIELD IN THE STRUCTURE! */ + * is marked by a unique ClientData tag during + * compilation, and that same tag is used to + * find the variable at runtime. */ + char name[4]; /* Name of the local variable starts here. If + * the name is NULL, this will just be '\0'. + * The actual size of this field will be large + * enough to hold the name. MUST BE THE LAST + * FIELD IN THE STRUCTURE! */ } CompiledLocal; /* * The structure below defines a command procedure, which consists of a - * collection of Tcl commands plus information about arguments and other - * local variables recognized at compile time. + * collection of Tcl commands plus information about arguments and other local + * variables recognized at compile time. */ typedef struct Proc { - struct Interp *iPtr; /* Interpreter for which this command - * is defined. */ - int refCount; /* Reference count: 1 if still present - * in command table plus 1 for each call - * to the procedure that is currently - * active. This structure can be freed - * when refCount becomes zero. */ - struct Command *cmdPtr; /* Points to the Command structure for - * this procedure. This is used to get - * the namespace in which to execute - * the procedure. */ - Tcl_Obj *bodyPtr; /* Points to the ByteCode object for - * procedure's body command. */ - int numArgs; /* Number of formal parameters. */ - int numCompiledLocals; /* Count of local variables recognized by - * the compiler including arguments and - * temporaries. */ - CompiledLocal *firstLocalPtr; /* Pointer to first of the procedure's - * compiler-allocated local variables, or - * NULL if none. The first numArgs entries - * in this list describe the procedure's - * formal arguments. */ - CompiledLocal *lastLocalPtr; /* Pointer to the last allocated local - * variable or NULL if none. This has - * frame index (numCompiledLocals-1). */ + struct Interp *iPtr; /* Interpreter for which this command is + * defined. */ + int refCount; /* Reference count: 1 if still present in + * command table plus 1 for each call to the + * procedure that is currently active. This + * structure can be freed when refCount + * becomes zero. */ + struct Command *cmdPtr; /* Points to the Command structure for this + * procedure. This is used to get the + * namespace in which to execute the + * procedure. */ + Tcl_Obj *bodyPtr; /* Points to the ByteCode object for + * procedure's body command. */ + int numArgs; /* Number of formal parameters. */ + int numCompiledLocals; /* Count of local variables recognized by the + * compiler including arguments and + * temporaries. */ + CompiledLocal *firstLocalPtr; + /* Pointer to first of the procedure's + * compiler-allocated local variables, or NULL + * if none. The first numArgs entries in this + * list describe the procedure's formal + * arguments. */ + CompiledLocal *lastLocalPtr;/* Pointer to the last allocated local + * variable or NULL if none. This has frame + * index (numCompiledLocals-1). */ } Proc; /* - * The structure below defines a command trace. This is used to allow Tcl + * The structure below defines a command trace. This is used to allow Tcl * clients to find out whenever a command is about to be executed. */ typedef struct Trace { - int level; /* Only trace commands at nesting level - * less than or equal to this. */ + int level; /* Only trace commands at nesting level less + * than or equal to this. */ Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */ ClientData clientData; /* Arbitrary value to pass to proc. */ struct Trace *nextPtr; /* Next in list of traces for this interp. */ int flags; /* Flags governing the trace - see * Tcl_CreateObjTrace for details */ @@ -725,271 +779,288 @@ Tcl_CmdObjTraceDeleteProc* delProc; /* Procedure to call when trace is deleted */ } Trace; /* - * When an interpreter trace is active (i.e. its associated procedure - * is executing), one of the following structures is linked into a list - * associated with the interpreter. The information in the structure - * is needed in order for Tcl to behave reasonably if traces are - * deleted while traces are active. + * When an interpreter trace is active (i.e. its associated procedure is + * executing), one of the following structures is linked into a list + * associated with the interpreter. The information in the structure is needed + * in order for Tcl to behave reasonably if traces are deleted while traces + * are active. */ typedef struct ActiveInterpTrace { struct ActiveInterpTrace *nextPtr; - /* Next in list of all active command - * traces for the interpreter, or NULL - * if no more. */ - Trace *nextTracePtr; /* Next trace to check after current - * trace procedure returns; if this - * trace gets deleted, must update pointer - * to avoid using free'd memory. */ + /* Next in list of all active command traces + * for the interpreter, or NULL if no more. */ + Trace *nextTracePtr; /* Next trace to check after current trace + * procedure returns; if this trace gets + * deleted, must update pointer to avoid using + * free'd memory. */ + int reverseScan; /* Boolean set true when traces are scanning + * in reverse order. */ } ActiveInterpTrace; /* - * The structure below defines an entry in the assocData hash table which - * is associated with an interpreter. The entry contains a pointer to a - * function to call when the interpreter is deleted, and a pointer to - * a user-defined piece of data. + * Flag values designating types of execution traces. See tclTrace.c for + * related flag values. + * + * TCL_TRACE_ENTER_EXEC - triggers enter/enterstep traces. + * - passed to Tcl_CreateObjTrace to set up + * "enterstep" traces. + * TCL_TRACE_LEAVE_EXEC - triggers leave/leavestep traces. + * - passed to Tcl_CreateObjTrace to set up + * "leavestep" traces. + * + */ +#define TCL_TRACE_ENTER_EXEC 1 +#define TCL_TRACE_LEAVE_EXEC 2 + +/* + * The structure below defines an entry in the assocData hash table which is + * associated with an interpreter. The entry contains a pointer to a function + * to call when the interpreter is deleted, and a pointer to a user-defined + * piece of data. */ typedef struct AssocData { Tcl_InterpDeleteProc *proc; /* Proc to call when deleting. */ ClientData clientData; /* Value to pass to proc. */ -} AssocData; +} AssocData; /* * The structure below defines a call frame. A call frame defines a naming - * context for a procedure call: its local naming scope (for local - * variables) and its global naming scope (a namespace, perhaps the global - * :: namespace). A call frame can also define the naming context for a - * namespace eval or namespace inscope command: the namespace in which the - * command's code should execute. The Tcl_CallFrame structures exist only - * while procedures or namespace eval/inscope's are being executed, and - * provide a kind of Tcl call stack. - * + * context for a procedure call: its local naming scope (for local variables) + * and its global naming scope (a namespace, perhaps the global :: namespace). + * A call frame can also define the naming context for a namespace eval or + * namespace inscope command: the namespace in which the command's code should + * execute. The Tcl_CallFrame structures exist only while procedures or + * namespace eval/inscope's are being executed, and provide a kind of Tcl call + * stack. + * * WARNING!! The structure definition must be kept consistent with the * Tcl_CallFrame structure in tcl.h. If you change one, change the other. */ typedef struct CallFrame { Namespace *nsPtr; /* Points to the namespace used to resolve * commands and global variables. */ - int isProcCallFrame; /* If nonzero, the frame was pushed to - * execute a Tcl procedure and may have - * local vars. If 0, the frame was pushed - * to execute a namespace command and var - * references are treated as references to - * namespace vars; varTablePtr and - * compiledLocals are ignored. */ - int objc; /* This and objv below describe the - * arguments for this procedure call. */ + int isProcCallFrame; /* If 0, the frame was pushed to execute a + * namespace command and var references are + * treated as references to namespace vars; + * varTablePtr and compiledLocals are ignored. + * If FRAME_IS_PROC is set, the frame was + * pushed to execute a Tcl procedure and may + * have local vars. */ + int objc; /* This and objv below describe the arguments + * for this procedure call. */ Tcl_Obj *CONST *objv; /* Array of argument objects. */ struct CallFrame *callerPtr; /* Value of interp->framePtr when this - * procedure was invoked (i.e. next higher - * in stack of all active procedures). */ + * procedure was invoked (i.e. next higher in + * stack of all active procedures). */ struct CallFrame *callerVarPtr; /* Value of interp->varFramePtr when this * procedure was invoked (i.e. determines - * variable scoping within caller). Same - * as callerPtr unless an "uplevel" command - * or something equivalent was active in - * the caller). */ + * variable scoping within caller). Same as + * callerPtr unless an "uplevel" command or + * something equivalent was active in the + * caller). */ int level; /* Level of this procedure, for "uplevel" * purposes (i.e. corresponds to nesting of * callerVarPtr's, not callerPtr's). 1 for * outermost procedure, 0 for top-level. */ - Proc *procPtr; /* Points to the structure defining the - * called procedure. Used to get information - * such as the number of compiled local - * variables (local variables assigned - * entries ["slots"] in the compiledLocals - * array below). */ + Proc *procPtr; /* Points to the structure defining the called + * procedure. Used to get information such as + * the number of compiled local variables + * (local variables assigned entries ["slots"] + * in the compiledLocals array below). */ Tcl_HashTable *varTablePtr; /* Hash table containing local variables not * recognized by the compiler, or created at * execution time through, e.g., upvar. * Initially NULL and created if needed. */ - int numCompiledLocals; /* Count of local variables recognized by - * the compiler including arguments. */ + int numCompiledLocals; /* Count of local variables recognized by the + * compiler including arguments. */ Var* compiledLocals; /* Points to the array of local variables * recognized by the compiler. The compiler * emits code that refers to these variables * using an index into this array. */ } CallFrame; +#define FRAME_IS_PROC 0x1 + /* *---------------------------------------------------------------- - * Data structures and procedures related to TclHandles, which - * are a very lightweight method of preserving enough information - * to determine if an arbitrary malloc'd block has been deleted. + * Data structures and procedures related to TclHandles, which are a very + * lightweight method of preserving enough information to determine if an + * arbitrary malloc'd block has been deleted. *---------------------------------------------------------------- */ typedef VOID **TclHandle; /* *---------------------------------------------------------------- - * Data structures related to expressions. These are used only in - * tclExpr.c. + * Data structures related to expressions. These are used only in tclExpr.c. *---------------------------------------------------------------- */ /* - * The data structure below defines a math function (e.g. sin or hypot) - * for use in Tcl expressions. + * The data structure below defines a math function (e.g. sin or hypot) for + * use in Tcl expressions. */ #define MAX_MATH_ARGS 5 typedef struct MathFunc { int builtinFuncIndex; /* If this is a builtin math function, its * index in the array of builtin functions. * (tclCompilation.h lists these indices.) * The value is -1 if this is a new function - * defined by Tcl_CreateMathFunc. The value - * is also -1 if a builtin function is - * replaced by a Tcl_CreateMathFunc call. */ + * defined by Tcl_CreateMathFunc. The value is + * also -1 if a builtin function is replaced + * by a Tcl_CreateMathFunc call. */ int numArgs; /* Number of arguments for function. */ Tcl_ValueType argTypes[MAX_MATH_ARGS]; /* Acceptable types for each argument. */ Tcl_MathProc *proc; /* Procedure that implements this function. * NULL if isBuiltinFunc is 1. */ - ClientData clientData; /* Additional argument to pass to the - * function when invoking it. NULL if - * isBuiltinFunc is 1. */ + ClientData clientData; /* Additional argument to pass to the function + * when invoking it. NULL if isBuiltinFunc is + * 1. */ } MathFunc; /* * These are a thin layer over TclpThreadKeyDataGet and TclpThreadKeyDataSet - * when threads are used, or an emulation if there are no threads. These - * are really internal and Tcl clients should use Tcl_GetThreadData. + * when threads are used, or an emulation if there are no threads. These are + * really internal and Tcl clients should use Tcl_GetThreadData. */ -MODULE_SCOPE VOID * TclThreadDataKeyGet _ANSI_ARGS_(( - Tcl_ThreadDataKey *keyPtr)); -MODULE_SCOPE void TclThreadDataKeySet _ANSI_ARGS_(( - Tcl_ThreadDataKey *keyPtr, VOID *data)); +MODULE_SCOPE VOID * TclThreadDataKeyGet(Tcl_ThreadDataKey *keyPtr); +MODULE_SCOPE void TclThreadDataKeySet(Tcl_ThreadDataKey *keyPtr, + VOID *data); /* * This is a convenience macro used to initialize a thread local storage ptr. */ -#define TCL_TSD_INIT(keyPtr) (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData)) + +#define TCL_TSD_INIT(keyPtr) \ + (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData)) /* *---------------------------------------------------------------- - * Data structures related to bytecode compilation and execution. - * These are used primarily in tclCompile.c, tclExecute.c, and - * tclBasic.c. + * Data structures related to bytecode compilation and execution. These are + * used primarily in tclCompile.c, tclExecute.c, and tclBasic.c. *---------------------------------------------------------------- */ /* * Forward declaration to prevent errors when the forward references to - * Tcl_Parse and CompileEnv are encountered in the procedure type - * CompileProc declared below. + * Tcl_Parse and CompileEnv are encountered in the procedure type CompileProc + * declared below. */ struct CompileEnv; /* * The type of procedures called by the Tcl bytecode compiler to compile * commands. Pointers to these procedures are kept in the Command structure - * describing each command. The integer value returned by a CompileProc - * must be one of the following: + * describing each command. The integer value returned by a CompileProc must + * be one of the following: * * TCL_OK Compilation completed normally. - * TCL_OUT_LINE_COMPILE Compilation could not be completed. This can - * be just a judgment by the CompileProc that the - * command is too complex to compile effectively, - * or it can indicate that in the current state of - * the interp, the command would raise an error. - * In the latter circumstance, we defer error reporting - * until the actual runtime, because by then changes - * in the interp state may allow the command to be - * successfully evaluated. + * TCL_ERROR Compilation could not be completed. This can be just a + * judgment by the CompileProc that the command is too + * complex to compile effectively, or it can indicate + * that in the current state of the interp, the command + * would raise an error. The bytecode compiler will not + * do any error reporting at compiler time. Error + * reporting is deferred until the actual runtime, + * because by then changes in the interp state may allow + * the command to be successfully evaluated. + * TCL_OUT_LINE_COMPILE A source-compatible alias for TCL_ERROR, kept for the + * sake of old code only. */ -#define TCL_OUT_LINE_COMPILE (TCL_CONTINUE + 1) +#define TCL_OUT_LINE_COMPILE TCL_ERROR -typedef int (CompileProc) _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Parse *parsePtr, struct CompileEnv *compEnvPtr)); +typedef int (CompileProc) (Tcl_Interp *interp, Tcl_Parse *parsePtr, + struct CompileEnv *compEnvPtr); /* * The type of procedure called from the compilation hook point in * SetByteCodeFromAny. */ -typedef int (CompileHookProc) _ANSI_ARGS_((Tcl_Interp *interp, - struct CompileEnv *compEnvPtr, ClientData clientData)); +typedef int (CompileHookProc) (Tcl_Interp *interp, + struct CompileEnv *compEnvPtr, ClientData clientData); /* * The data structure defining the execution environment for ByteCode's. - * There is one ExecEnv structure per Tcl interpreter. It holds the - * evaluation stack that holds command operands and results. The stack grows - * towards increasing addresses. The "stackTop" member is cached by - * TclExecuteByteCode in a local variable: it must be set before calling - * TclExecuteByteCode and will be restored by TclExecuteByteCode before it - * returns. + * There is one ExecEnv structure per Tcl interpreter. It holds the evaluation + * stack that holds command operands and results. The stack grows towards + * increasing addresses. The "stackTop" member is cached by TclExecuteByteCode + * in a local variable: it must be set before calling TclExecuteByteCode and + * will be restored by TclExecuteByteCode before it returns. */ typedef struct ExecEnv { - Tcl_Obj **stackPtr; /* Points to the first item in the - * evaluation stack on the heap. */ - Tcl_Obj **tosPtr; /* Points to current top of stack; + Tcl_Obj **stackPtr; /* Points to the first item in the evaluation + * stack on the heap. */ + Tcl_Obj **tosPtr; /* Points to current top of stack; * (stackPtr-1) when the stack is empty. */ Tcl_Obj **endPtr; /* Points to last usable item in stack. */ + Tcl_Obj *constants[2]; /* Pointers to constant "0" and "1" objs. */ } ExecEnv; /* * The definitions for the LiteralTable and LiteralEntry structures. Each * interpreter contains a LiteralTable. It is used to reduce the storage * needed for all the Tcl objects that hold the literals of scripts compiled - * by the interpreter. A literal's object is shared by all the ByteCodes - * that refer to the literal. Each distinct literal has one LiteralEntry - * entry in the LiteralTable. A literal table is a specialized hash table - * that is indexed by the literal's string representation, which may contain - * null characters. + * by the interpreter. A literal's object is shared by all the ByteCodes that + * refer to the literal. Each distinct literal has one LiteralEntry entry in + * the LiteralTable. A literal table is a specialized hash table that is + * indexed by the literal's string representation, which may contain null + * characters. * * Note that we reduce the space needed for literals by sharing literal * objects both within a ByteCode (each ByteCode contains a local * LiteralTable) and across all an interpreter's ByteCodes (with the * interpreter's global LiteralTable). */ typedef struct LiteralEntry { - struct LiteralEntry *nextPtr; /* Points to next entry in this - * hash bucket or NULL if end of - * chain. */ - Tcl_Obj *objPtr; /* Points to Tcl object that - * holds the literal's bytes and - * length. */ - int refCount; /* If in an interpreter's global - * literal table, the number of - * ByteCode structures that share - * the literal object; the literal - * entry can be freed when refCount - * drops to 0. If in a local literal - * table, -1. */ + struct LiteralEntry *nextPtr; + /* Points to next entry in this hash bucket or + * NULL if end of chain. */ + Tcl_Obj *objPtr; /* Points to Tcl object that holds the + * literal's bytes and length. */ + int refCount; /* If in an interpreter's global literal + * table, the number of ByteCode structures + * that share the literal object; the literal + * entry can be freed when refCount drops to + * 0. If in a local literal table, -1. */ + Namespace *nsPtr; /* Namespace in which this literal is used. We + * try to avoid sharing literal non-FQ command + * names among different namespaces to reduce + * shimmering. */ } LiteralEntry; typedef struct LiteralTable { - LiteralEntry **buckets; /* Pointer to bucket array. Each - * element points to first entry in - * bucket's hash chain, or NULL. */ + LiteralEntry **buckets; /* Pointer to bucket array. Each element + * points to first entry in bucket's hash + * chain, or NULL. */ LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE]; - /* Bucket array used for small - * tables to avoid mallocs and - * frees. */ - int numBuckets; /* Total number of buckets allocated - * at **buckets. */ - int numEntries; /* Total number of entries present - * in table. */ - int rebuildSize; /* Enlarge table when numEntries - * gets to be this large. */ - int mask; /* Mask value used in hashing - * function. */ + /* Bucket array used for small tables to avoid + * mallocs and frees. */ + int numBuckets; /* Total number of buckets allocated at + * **buckets. */ + int numEntries; /* Total number of entries present in + * table. */ + int rebuildSize; /* Enlarge table when numEntries gets to be + * this large. */ + int mask; /* Mask value used in hashing function. */ } LiteralTable; /* * The following structure defines for each Tcl interpreter various * statistics-related information about the bytecode compiler and @@ -996,36 +1067,37 @@ * interpreter's operation in that interpreter. */ #ifdef TCL_COMPILE_STATS typedef struct ByteCodeStats { - long numExecutions; /* Number of ByteCodes executed. */ - long numCompilations; /* Number of ByteCodes created. */ - long numByteCodesFreed; /* Number of ByteCodes destroyed. */ - long instructionCount[256]; /* Number of times each instruction was - * executed. */ - - double totalSrcBytes; /* Total source bytes ever compiled. */ - double totalByteCodeBytes; /* Total bytes for all ByteCodes. */ - double currentSrcBytes; /* Src bytes for all current ByteCodes. */ - double currentByteCodeBytes; /* Code bytes in all current ByteCodes. */ - - long srcCount[32]; /* Source size distribution: # of srcs of - * size [2**(n-1)..2**n), n in [0..32). */ - long byteCodeCount[32]; /* ByteCode size distribution. */ - long lifetimeCount[32]; /* ByteCode lifetime distribution (ms). */ - - double currentInstBytes; /* Instruction bytes-current ByteCodes. */ - double currentLitBytes; /* Current literal bytes. */ - double currentExceptBytes; /* Current exception table bytes. */ - double currentAuxBytes; /* Current auxiliary information bytes. */ - double currentCmdMapBytes; /* Current src<->code map bytes. */ - - long numLiteralsCreated; /* Total literal objects ever compiled. */ - double totalLitStringBytes; /* Total string bytes in all literals. */ - double currentLitStringBytes; /* String bytes in current literals. */ - long literalCount[32]; /* Distribution of literal string sizes. */ + long numExecutions; /* Number of ByteCodes executed. */ + long numCompilations; /* Number of ByteCodes created. */ + long numByteCodesFreed; /* Number of ByteCodes destroyed. */ + long instructionCount[256]; /* Number of times each instruction was + * executed. */ + + double totalSrcBytes; /* Total source bytes ever compiled. */ + double totalByteCodeBytes; /* Total bytes for all ByteCodes. */ + double currentSrcBytes; /* Src bytes for all current ByteCodes. */ + double currentByteCodeBytes;/* Code bytes in all current ByteCodes. */ + + long srcCount[32]; /* Source size distribution: # of srcs of + * size [2**(n-1)..2**n), n in [0..32). */ + long byteCodeCount[32]; /* ByteCode size distribution. */ + long lifetimeCount[32]; /* ByteCode lifetime distribution (ms). */ + + double currentInstBytes; /* Instruction bytes-current ByteCodes. */ + double currentLitBytes; /* Current literal bytes. */ + double currentExceptBytes; /* Current exception table bytes. */ + double currentAuxBytes; /* Current auxiliary information bytes. */ + double currentCmdMapBytes; /* Current src<->code map bytes. */ + + long numLiteralsCreated; /* Total literal objects ever compiled. */ + double totalLitStringBytes; /* Total string bytes in all literals. */ + double currentLitStringBytes; + /* String bytes in current literals. */ + long literalCount[32]; /* Distribution of literal string sizes. */ } ByteCodeStats; #endif /* TCL_COMPILE_STATS */ /* *---------------------------------------------------------------- @@ -1033,27 +1105,28 @@ *---------------------------------------------------------------- */ /* * An imported command is created in an namespace when it imports a "real" - * command from another namespace. An imported command has a Command - * structure that points (via its ClientData value) to the "real" Command - * structure in the source namespace's command table. The real command - * records all the imported commands that refer to it in a list of ImportRef - * structures so that they can be deleted when the real command is deleted. */ + * command from another namespace. An imported command has a Command structure + * that points (via its ClientData value) to the "real" Command structure in + * the source namespace's command table. The real command records all the + * imported commands that refer to it in a list of ImportRef structures so + * that they can be deleted when the real command is deleted. + */ typedef struct ImportRef { struct Command *importedCmdPtr; /* Points to the imported command created in * an importing namespace; this command * redirects its invocations to the "real" * command. */ - struct ImportRef *nextPtr; /* Next element on the linked list of - * imported commands that refer to the - * "real" command. The real command deletes - * these imported commands on this list when - * it is deleted. */ + struct ImportRef *nextPtr; /* Next element on the linked list of imported + * commands that refer to the "real" command. + * The real command deletes these imported + * commands on this list when it is + * deleted. */ } ImportRef; /* * Data structure used as the ClientData of imported commands: commands * created in an namespace when it imports a "real" command from another @@ -1062,39 +1135,38 @@ typedef struct ImportedCmdData { struct Command *realCmdPtr; /* "Real" command that this imported command * refers to. */ struct Command *selfPtr; /* Pointer to this imported command. Needed - * only when deleting it in order to remove - * it from the real command's linked list of + * only when deleting it in order to remove it + * from the real command's linked list of * imported commands that refer to it. */ } ImportedCmdData; /* - * A Command structure exists for each command in a namespace. The - * Tcl_Command opaque type actually refers to these structures. + * A Command structure exists for each command in a namespace. The Tcl_Command + * opaque type actually refers to these structures. */ typedef struct Command { - Tcl_HashEntry *hPtr; /* Pointer to the hash table entry that - * refers to this command. The hash table is - * either a namespace's command table or an + Tcl_HashEntry *hPtr; /* Pointer to the hash table entry that refers + * to this command. The hash table is either a + * namespace's command table or an * interpreter's hidden command table. This * pointer is used to get a command's name * from its Tcl_Command handle. NULL means - * that the hash table entry has been - * removed already (this can happen if - * deleteProc causes the command to be - * deleted or recreated). */ + * that the hash table entry has been removed + * already (this can happen if deleteProc + * causes the command to be deleted or + * recreated). */ Namespace *nsPtr; /* Points to the namespace containing this * command. */ int refCount; /* 1 if in command hashtable plus 1 for each * reference from a CmdName Tcl object - * representing a command's name in a - * ByteCode instruction sequence. This - * structure can be freed when refCount - * becomes zero. */ + * representing a command's name in a ByteCode + * instruction sequence. This structure can be + * freed when refCount becomes zero. */ int cmdEpoch; /* Incremented to invalidate any references * that point to this command when it is * renamed, deleted, hidden, or exposed. */ CompileProc *compileProc; /* Procedure called to compile command. NULL * if no compile proc exists for command. */ @@ -1101,46 +1173,47 @@ Tcl_ObjCmdProc *objProc; /* Object-based command procedure. */ ClientData objClientData; /* Arbitrary value passed to object proc. */ Tcl_CmdProc *proc; /* String-based command procedure. */ ClientData clientData; /* Arbitrary value passed to string proc. */ Tcl_CmdDeleteProc *deleteProc; - /* Procedure invoked when deleting command - * to, e.g., free all client data. */ + /* Procedure invoked when deleting command to, + * e.g., free all client data. */ ClientData deleteData; /* Arbitrary value passed to deleteProc. */ int flags; /* Miscellaneous bits of information about * command. See below for definitions. */ ImportRef *importRefPtr; /* List of each imported Command created in * another namespace when this command is - * imported. These imported commands - * redirect invocations back to this - * command. The list is used to remove all - * those imported commands when deleting - * this "real" command. */ + * imported. These imported commands redirect + * invocations back to this command. The list + * is used to remove all those imported + * commands when deleting this "real" + * command. */ CommandTrace *tracePtr; /* First in list of all traces set for this * command. */ } Command; /* - * Flag bits for commands. + * Flag bits for commands. * - * CMD_IS_DELETED - Means that the command is in the process - * of being deleted (its deleteProc is - * currently executing). Other attempts to - * delete the command should be ignored. + * CMD_IS_DELETED - Means that the command is in the process of + * being deleted (its deleteProc is currently + * executing). Other attempts to delete the + * command should be ignored. * CMD_TRACE_ACTIVE - 1 means that trace processing is currently - * underway for a rename/delete change. - * See the two flags below for which is - * currently being processed. - * CMD_HAS_EXEC_TRACES - 1 means that this command has at least - * one execution trace (as opposed to simple + * underway for a rename/delete change. See the + * two flags below for which is currently being + * processed. + * CMD_HAS_EXEC_TRACES - 1 means that this command has at least one + * execution trace (as opposed to simple * delete/rename traces) in its tracePtr list. * TCL_TRACE_RENAME - A rename trace is in progress. Further * recursive renames will not be traced. - * TCL_TRACE_DELETE - A delete trace is in progress. Further + * TCL_TRACE_DELETE - A delete trace is in progress. Further * recursive deletes will not be traced. * (these last two flags are defined in tcl.h) */ + #define CMD_IS_DELETED 0x1 #define CMD_TRACE_ACTIVE 0x2 #define CMD_HAS_EXEC_TRACES 0x4 /* @@ -1148,30 +1221,29 @@ * Data structures related to name resolution procedures. *---------------------------------------------------------------- */ /* - * The interpreter keeps a linked list of name resolution schemes. - * The scheme for a namespace is consulted first, followed by the - * list of schemes in an interpreter, followed by the default - * name resolution in Tcl. Schemes are added/removed from the - * interpreter's list by calling Tcl_AddInterpResolver and - * Tcl_RemoveInterpResolver. + * The interpreter keeps a linked list of name resolution schemes. The scheme + * for a namespace is consulted first, followed by the list of schemes in an + * interpreter, followed by the default name resolution in Tcl. Schemes are + * added/removed from the interpreter's list by calling Tcl_AddInterpResolver + * and Tcl_RemoveInterpResolver. */ typedef struct ResolverScheme { char *name; /* Name identifying this scheme. */ Tcl_ResolveCmdProc *cmdResProc; /* Procedure handling command name * resolution. */ Tcl_ResolveVarProc *varResProc; - /* Procedure handling variable name - * resolution for variables that - * can only be handled at runtime. */ + /* Procedure handling variable name resolution + * for variables that can only be handled at + * runtime. */ Tcl_ResolveCompiledVarProc *compiledVarResProc; - /* Procedure handling variable name - * resolution at compile time. */ + /* Procedure handling variable name resolution + * at compile time. */ struct ResolverScheme *nextPtr; /* Pointer to next record in linked list. */ } ResolverScheme; @@ -1181,174 +1253,168 @@ typedef struct LimitHandler LimitHandler; /* *---------------------------------------------------------------- - * This structure defines an interpreter, which is a collection of - * commands plus other state information related to interpreting - * commands, such as variable storage. Primary responsibility for - * this data structure is in tclBasic.c, but almost every Tcl - * source file uses something in here. + * This structure defines an interpreter, which is a collection of commands + * plus other state information related to interpreting commands, such as + * variable storage. Primary responsibility for this data structure is in + * tclBasic.c, but almost every Tcl source file uses something in here. *---------------------------------------------------------------- */ typedef struct Interp { - /* - * Note: the first three fields must match exactly the fields in - * a Tcl_Interp struct (see tcl.h). If you change one, be sure to - * change the other. + * Note: the first three fields must match exactly the fields in a + * Tcl_Interp struct (see tcl.h). If you change one, be sure to change the + * other. * * The interpreter's result is held in both the string and the * objResultPtr fields. These fields hold, respectively, the result's * string or object value. The interpreter's result is always in the * result field if that is non-empty, otherwise it is in objResultPtr. * The two fields are kept consistent unless some C code sets * interp->result directly. Programs should not access result and * objResultPtr directly; instead, they should always get and set the - * result using procedures such as Tcl_SetObjResult, Tcl_GetObjResult, - * and Tcl_GetStringResult. See the SetResult man page for details. + * result using procedures such as Tcl_SetObjResult, Tcl_GetObjResult, and + * Tcl_GetStringResult. See the SetResult man page for details. */ char *result; /* If the last command returned a string * result, this points to it. Should not be * accessed directly; see comment above. */ Tcl_FreeProc *freeProc; /* Zero means a string result is statically - * allocated. TCL_DYNAMIC means string - * result was allocated with ckalloc and - * should be freed with ckfree. Other values - * give address of procedure to invoke to - * free the string result. Tcl_Eval must - * free it before executing next command. */ - int errorLine; /* When TCL_ERROR is returned, this gives - * the line number in the command where the - * error occurred (1 means first line). */ - struct TclStubs *stubTable; - /* Pointer to the exported Tcl stub table. - * On previous versions of Tcl this is a - * pointer to the objResultPtr or a pointer - * to a buckets array in a hash table. We - * therefore have to do some careful checking - * before we can use this. */ + * allocated. TCL_DYNAMIC means string result + * was allocated with ckalloc and should be + * freed with ckfree. Other values give + * address of procedure to invoke to free the + * string result. Tcl_Eval must free it before + * executing next command. */ + int errorLine; /* When TCL_ERROR is returned, this gives the + * line number in the command where the error + * occurred (1 means first line). */ + struct TclStubs *stubTable; /* Pointer to the exported Tcl stub table. On + * previous versions of Tcl this is a pointer + * to the objResultPtr or a pointer to a + * buckets array in a hash table. We therefore + * have to do some careful checking before we + * can use this. */ TclHandle handle; /* Handle used to keep track of when this * interp is deleted. */ Namespace *globalNsPtr; /* The interpreter's global namespace. */ Tcl_HashTable *hiddenCmdTablePtr; - /* Hash table used by tclBasic.c to keep - * track of hidden commands on a per-interp + /* Hash table used by tclBasic.c to keep track + * of hidden commands on a per-interp * basis. */ ClientData interpInfo; /* Information used by tclInterp.c to keep - * track of master/slave interps on - * a per-interp basis. */ + * track of master/slave interps on a + * per-interp basis. */ Tcl_HashTable mathFuncTable;/* Contains all the math functions currently - * defined for the interpreter. Indexed by - * strings (function names); values have - * type (MathFunc *). */ - - + * defined for the interpreter. Indexed by + * strings (function names); values have type + * (MathFunc *). */ /* - * Information related to procedures and variables. See tclProc.c - * and tclVar.c for usage. + * Information related to procedures and variables. See tclProc.c and + * tclVar.c for usage. */ int numLevels; /* Keeps track of how many nested calls to * Tcl_Eval are in progress for this - * interpreter. It's used to delay deletion - * of the table until all Tcl_Eval - * invocations are completed. */ + * interpreter. It's used to delay deletion of + * the table until all Tcl_Eval invocations + * are completed. */ int maxNestingDepth; /* If numLevels exceeds this value then Tcl * assumes that infinite recursion has * occurred and it generates an error. */ CallFrame *framePtr; /* Points to top-most in stack of all nested - * procedure invocations. NULL means there - * are no active procedures. */ + * procedure invocations. NULL means there are + * no active procedures. */ CallFrame *varFramePtr; /* Points to the call frame whose variables * are currently in use (same as framePtr - * unless an "uplevel" command is - * executing). NULL means no procedure is - * active or "uplevel 0" is executing. */ + * unless an "uplevel" command is executing). + * NULL means no procedure is active or + * "uplevel 0" is executing. */ ActiveVarTrace *activeVarTracePtr; - /* First in list of active traces for - * interp, or NULL if no active traces. */ + /* First in list of active traces for interp, + * or NULL if no active traces. */ int returnCode; /* [return -code] parameter */ char *unused3; /* No longer used (was errorInfo) */ char *unused4; /* No longer used (was errorCode) */ /* - * Information used by Tcl_AppendResult to keep track of partial - * results. See Tcl_AppendResult code for details. + * Information used by Tcl_AppendResult to keep track of partial results. + * See Tcl_AppendResult code for details. */ - char *appendResult; /* Storage space for results generated - * by Tcl_AppendResult. Malloc-ed. NULL - * means not yet allocated. */ + char *appendResult; /* Storage space for results generated by + * Tcl_AppendResult. Ckalloc-ed. NULL means + * not yet allocated. */ int appendAvl; /* Total amount of space available at * partialResult. */ - int appendUsed; /* Number of non-null bytes currently - * stored at partialResult. */ + int appendUsed; /* Number of non-null bytes currently stored + * at partialResult. */ /* - * Information about packages. Used only in tclPkg.c. + * Information about packages. Used only in tclPkg.c. */ - Tcl_HashTable packageTable; /* Describes all of the packages loaded - * in or available to this interpreter. - * Keys are package names, values are - * (Package *) pointers. */ - char *packageUnknown; /* Command to invoke during "package - * require" commands for packages that - * aren't described in packageTable. - * Malloc'ed, may be NULL. */ + Tcl_HashTable packageTable; /* Describes all of the packages loaded in or + * available to this interpreter. Keys are + * package names, values are (Package *) + * pointers. */ + char *packageUnknown; /* Command to invoke during "package require" + * commands for packages that aren't described + * in packageTable. Ckalloc'ed, may be + * NULL. */ /* * Miscellaneous information: */ int cmdCount; /* Total number of times a command procedure * has been called for this interpreter. */ int evalFlags; /* Flags to control next call to Tcl_Eval. * Normally zero, but may be set before - * calling Tcl_Eval. See below for valid + * calling Tcl_Eval. See below for valid * values. */ int unused1; /* No longer used (was termOffset) */ - LiteralTable literalTable; /* Contains LiteralEntry's describing all - * Tcl objects holding literals of scripts - * compiled by the interpreter. Indexed by - * the string representations of literals. - * Used to avoid creating duplicate - * objects. */ - int compileEpoch; /* Holds the current "compilation epoch" - * for this interpreter. This is - * incremented to invalidate existing - * ByteCodes when, e.g., a command with a - * compile procedure is redefined. */ - Proc *compiledProcPtr; /* If a procedure is being compiled, a - * pointer to its Proc structure; otherwise, - * this is NULL. Set by ObjInterpProc in - * tclProc.c and used by tclCompile.c to - * process local variables appropriately. */ + LiteralTable literalTable; /* Contains LiteralEntry's describing all Tcl + * objects holding literals of scripts + * compiled by the interpreter. Indexed by the + * string representations of literals. Used to + * avoid creating duplicate objects. */ + int compileEpoch; /* Holds the current "compilation epoch" for + * this interpreter. This is incremented to + * invalidate existing ByteCodes when, e.g., a + * command with a compile procedure is + * redefined. */ + Proc *compiledProcPtr; /* If a procedure is being compiled, a pointer + * to its Proc structure; otherwise, this is + * NULL. Set by ObjInterpProc in tclProc.c and + * used by tclCompile.c to process local + * variables appropriately. */ ResolverScheme *resolverPtr; /* Linked list of name resolution schemes - * added to this interpreter. Schemes - * are added/removed by calling + * added to this interpreter. Schemes are + * added and removed by calling * Tcl_AddInterpResolvers and - * Tcl_RemoveInterpResolver. */ + * Tcl_RemoveInterpResolver respectively. */ Tcl_Obj *scriptFile; /* NULL means there is no nested source - * command active; otherwise this points to + * command active; otherwise this points to * pathPtr of the file being sourced. */ - int flags; /* Various flag bits. See below. */ + int flags; /* Various flag bits. See below. */ long randSeed; /* Seed used for rand() function. */ Trace *tracePtr; /* List of traces for this interpreter. */ - Tcl_HashTable *assocData; /* Hash table for associating data with - * this interpreter. Cleaned up when - * this interpreter is deleted. */ + Tcl_HashTable *assocData; /* Hash table for associating data with this + * interpreter. Cleaned up when this + * interpreter is deleted. */ struct ExecEnv *execEnvPtr; /* Execution environment for Tcl bytecode - * execution. Contains a pointer to the - * Tcl evaluation stack. */ + * execution. Contains a pointer to the Tcl + * evaluation stack. */ Tcl_Obj *emptyObjPtr; /* Points to an object holding an empty * string. Returned by Tcl_ObjSetVar2 when * variable traces change a variable in a * gross way. */ char resultSpace[TCL_RESULT_SIZE+1]; @@ -1360,12 +1426,12 @@ ActiveCommandTrace *activeCmdTracePtr; /* First in list of active command traces for * interp, or NULL if no active traces. */ ActiveInterpTrace *activeInterpTracePtr; - /* First in list of active traces for - * interp, or NULL if no active traces. */ + /* First in list of active traces for interp, + * or NULL if no active traces. */ int tracesForbiddingInline; /* Count of traces (in the list headed by * tracePtr) that forbid inline bytecode * compilation */ @@ -1382,100 +1448,157 @@ /* * Resource limiting framework support (TIP#143). */ struct { - int active; /* Flag values defining which limits have - * been set. */ + int active; /* Flag values defining which limits have been + * set. */ int granularityTicker; /* Counter used to determine how often to * check the limits. */ int exceeded; /* Which limits have been exceeded, described * as flag values the same as the 'active' * field. */ - int cmdCount; /* Limit for how many commands to execute - * in the interpreter. */ - LimitHandler *cmdHandlers; /* Handlers to execute when the limit - * is reached. */ - int cmdGranularity; /* Mod factor used to determine how often - * to evaluate the limit check. */ + int cmdCount; /* Limit for how many commands to execute in + * the interpreter. */ + LimitHandler *cmdHandlers; + /* Handlers to execute when the limit is + * reached. */ + int cmdGranularity; /* Mod factor used to determine how often to + * evaluate the limit check. */ Tcl_Time time; /* Time limit for execution within the * interpreter. */ - LimitHandler *timeHandlers; /* Handlers to execute when the limit - * is reached. */ - int timeGranularity; /* Mod factor used to determine how often - * to evaluate the limit check. */ - - Tcl_HashTable callbacks; /* Mapping from (interp,type) pair to data - * used to install a limit handler callback - * to run in _this_ interp when the limit - * is exceeded. */ + LimitHandler *timeHandlers; + /* Handlers to execute when the limit is + * reached. */ + int timeGranularity; /* Mod factor used to determine how often to + * evaluate the limit check. */ + Tcl_TimerToken timeEvent; + /* Handle for a timer callback that will occur + * when the time-limit is exceeded. */ + + Tcl_HashTable callbacks;/* Mapping from (interp,type) pair to data + * used to install a limit handler callback to + * run in _this_ interp when the limit is + * exceeded. */ } limit; /* - * Information for improved default error generation from - * ensembles (TIP#112). + * Information for improved default error generation from ensembles + * (TIP#112). */ struct { Tcl_Obj * CONST *sourceObjs; - /* What arguments were actually input into - * the *root* ensemble command? (Nested - * ensembles don't rewrite this.) NULL if - * we're not processing an ensemble. */ + /* What arguments were actually input into the + * *root* ensemble command? (Nested ensembles + * don't rewrite this.) NULL if we're not + * processing an ensemble. */ int numRemovedObjs; /* How many arguments have been stripped off * because of ensemble processing. */ int numInsertedObjs; /* How many of the current arguments were * inserted by an ensemble. */ } ensembleRewrite; + /* + * TIP #219 ... Global info for the I/O system ... + */ + + Tcl_Obj* chanMsg; /* Error message set by channel drivers, for + * the propagation of arbitrary Tcl errors. + * This information, if present (chanMsg not + * NULL), takes precedence over a posix error + * code returned by a channel operation. */ + /* * Statistical information about the bytecode compiler and interpreter's * operation. */ #ifdef TCL_COMPILE_STATS - ByteCodeStats stats; /* Holds compilation and execution - * statistics for this interpreter. */ -#endif /* TCL_COMPILE_STATS */ + ByteCodeStats stats; /* Holds compilation and execution statistics + * for this interpreter. */ +#endif /* TCL_COMPILE_STATS */ } Interp; +/* + * General list of interpreters. Doubly linked for easier removal of items + * deep in the list. + */ + +typedef struct InterpList { + Interp* interpPtr; + struct InterpList* prevPtr; + struct InterpList* nextPtr; +} InterpList; + +/* + * Macros for splicing into and out of doubly linked lists. They assume + * existence of struct items 'prevPtr' and 'nextPtr'. + * + * a = element to add or remove. + * b = list head. + * + * TclSpliceIn adds to the head of the list. + */ + +#define TclSpliceIn(a,b) \ + (a)->nextPtr = (b); \ + if ((b) != NULL) { \ + (b)->prevPtr = (a); \ + } \ + (a)->prevPtr = NULL, (b) = (a); + +#define TclSpliceOut(a,b) \ + if ((a)->prevPtr != NULL) { \ + (a)->prevPtr->nextPtr = (a)->nextPtr; \ + } else { \ + (b) = (a)->nextPtr; \ + } \ + if ((a)->nextPtr != NULL) { \ + (a)->nextPtr->prevPtr = (a)->prevPtr; \ + } + /* * EvalFlag bits for Interp structures: * - * TCL_ALLOW_EXCEPTIONS 1 means it's OK for the script to terminate with - * a code other than TCL_OK or TCL_ERROR; 0 means - * codes other than these should be turned into errors. + * TCL_ALLOW_EXCEPTIONS 1 means it's OK for the script to terminate with a + * code other than TCL_OK or TCL_ERROR; 0 means codes + * other than these should be turned into errors. */ -#define TCL_ALLOW_EXCEPTIONS 4 +#define TCL_ALLOW_EXCEPTIONS 4 /* * Flag bits for Interp structures: * * DELETED: Non-zero means the interpreter has been deleted: * don't process any more commands for it, and destroy * the structure as soon as all nested invocations of * Tcl_Eval are done. - * ERR_ALREADY_LOGGED: Non-zero means information has already been logged - * in iPtr->errorInfo for the current Tcl_Eval instance, - * so Tcl_Eval needn't log it (used to implement the - * "error message log" command). - * DONT_COMPILE_CMDS_INLINE: Non-zero means that the bytecode compiler - * should not compile any commands into an inline - * sequence of instructions. This is set 1, for - * example, when command traces are requested. - * RAND_SEED_INITIALIZED: Non-zero means that the randSeed value of the - * interp has not be initialized. This is set 1 - * when we first use the rand() or srand() functions. - * SAFE_INTERP: Non zero means that the current interp is a - * safe interp (ie it has only the safe commands - * installed, less priviledge than a regular interp). + * ERR_ALREADY_LOGGED: Non-zero means information has already been logged in + * iPtr->errorInfo for the current Tcl_Eval instance, so + * Tcl_Eval needn't log it (used to implement the "error + * message log" command). + * DONT_COMPILE_CMDS_INLINE: Non-zero means that the bytecode compiler should + * not compile any commands into an inline sequence of + * instructions. This is set 1, for example, when command + * traces are requested. + * RAND_SEED_INITIALIZED: Non-zero means that the randSeed value of the interp + * has not be initialized. This is set 1 when we first + * use the rand() or srand() functions. + * SAFE_INTERP: Non zero means that the current interp is a safe + * interp (i.e. it has only the safe commands installed, + * less priviledge than a regular interp). * INTERP_TRACE_IN_PROGRESS: Non-zero means that an interp trace is currently * active; so no further trace callbacks should be * invoked. + * INTERP_ALTERNATE_WRONG_ARGS: Used for listing second and subsequent forms + * of the wrong-num-args string in Tcl_WrongNumArgs. + * Makes it append instead of replacing and uses + * different intermediate text. * * WARNING: For the sake of some extensions that have made use of former * internal values, do not re-use the flag values 2 (formerly ERR_IN_PROGRESS) * or 8 (formerly ERROR_CODE_SET). */ @@ -1484,14 +1607,15 @@ #define ERR_ALREADY_LOGGED 4 #define DONT_COMPILE_CMDS_INLINE 0x20 #define RAND_SEED_INITIALIZED 0x40 #define SAFE_INTERP 0x80 #define INTERP_TRACE_IN_PROGRESS 0x200 +#define INTERP_ALTERNATE_WRONG_ARGS 0x400 /* - * Maximum number of levels of nesting permitted in Tcl commands (used - * to catch infinite recursion). + * Maximum number of levels of nesting permitted in Tcl commands (used to + * catch infinite recursion). */ #define MAX_NESTING_DEPTH 1000 /* @@ -1498,34 +1622,36 @@ * TIP#143 limit handler internal representation. */ struct LimitHandler { int flags; /* The state of this particular handler. */ - Tcl_LimitHandlerProc *handlerProc; /* The handler callback. */ + Tcl_LimitHandlerProc *handlerProc; + /* The handler callback. */ ClientData clientData; /* Opaque argument to the handler callback. */ - Tcl_LimitHandlerDeleteProc *deleteProc; /* How to delete the clientData */ + Tcl_LimitHandlerDeleteProc *deleteProc; + /* How to delete the clientData */ LimitHandler *prevPtr; /* Previous item in linked list of handlers */ LimitHandler *nextPtr; /* Next item in linked list of handlers */ }; /* * Values for the LimitHandler flags field. * LIMIT_HANDLER_ACTIVE - Whether the handler is currently being * processed; handlers are never to be entered reentrantly. - * LIMIT_HANDLER_DELETED - Whether the handler has been deleted. This + * LIMIT_HANDLER_DELETED - Whether the handler has been deleted. This * should not normally be observed because when a handler is * deleted it is also spliced out of the list of handlers, but * even so we will be careful. */ #define LIMIT_HANDLER_ACTIVE 0x01 #define LIMIT_HANDLER_DELETED 0x02 /* - * The macro below is used to modify a "char" value (e.g. by casting - * it to an unsigned character) so that it can be used safely with - * macros such as isspace. + * The macro below is used to modify a "char" value (e.g. by casting it to an + * unsigned character) so that it can be used safely with macros such as + * isspace. */ #define UCHAR(c) ((unsigned char) (c)) /* @@ -1533,13 +1659,13 @@ * data structure in memory. Given a starting offset or size, it "rounds up" * or "aligns" the offset to the next 8-byte boundary so that any data * structure can be placed at the resulting offset without fear of an * alignment error. * - * WARNING!! DO NOT USE THIS MACRO TO ALIGN POINTERS: it will produce - * the wrong result on platforms that allocate addresses that are divisible - * by 4 or 2. Only use it for offsets or sizes. + * WARNING!! DO NOT USE THIS MACRO TO ALIGN POINTERS: it will produce the + * wrong result on platforms that allocate addresses that are divisible by 4 + * or 2. Only use it for offsets or sizes. * * This macro is only used by tclCompile.c in the core (Bug 926445). It * however not be made file static, as extensions that touch bytecodes * (notably tbcload) require it. */ @@ -1546,23 +1672,23 @@ #define TCL_ALIGN(x) (((int)(x) + 7) & ~7) /* - * The following enum values are used to specify the runtime platform - * setting of the tclPlatform variable. + * The following enum values are used to specify the runtime platform setting + * of the tclPlatform variable. */ typedef enum { TCL_PLATFORM_UNIX = 0, /* Any Unix-like OS. */ TCL_PLATFORM_WINDOWS = 2 /* Any Microsoft Windows OS. */ } TclPlatformType; /* - * The following enum values are used to indicate the translation - * of a Tcl channel. Declared here so that each platform can define - * TCL_PLATFORM_TRANSLATION to the native translation on that platform + * The following enum values are used to indicate the translation of a Tcl + * channel. Declared here so that each platform can define + * TCL_PLATFORM_TRANSLATION to the native translation on that platform */ typedef enum TclEolTranslation { TCL_TRANSLATE_AUTO, /* Eol == \r, \n and \r\n. */ TCL_TRANSLATE_CR, /* Eol == \r. */ @@ -1571,97 +1697,140 @@ } TclEolTranslation; /* * Flags for TclInvoke: * - * TCL_INVOKE_HIDDEN Invoke a hidden command; if not set, - * invokes an exposed command. - * TCL_INVOKE_NO_UNKNOWN If set, "unknown" is not invoked if - * the command to be invoked is not found. - * Only has an effect if invoking an exposed - * command, i.e. if TCL_INVOKE_HIDDEN is not - * also set. - * TCL_INVOKE_NO_TRACEBACK Does not record traceback information if - * the invoked command returns an error. Used - * if the caller plans on recording its own - * traceback information. + * TCL_INVOKE_HIDDEN Invoke a hidden command; if not set, invokes + * an exposed command. + * TCL_INVOKE_NO_UNKNOWN If set, "unknown" is not invoked if the + * command to be invoked is not found. Only has + * an effect if invoking an exposed command, + * i.e. if TCL_INVOKE_HIDDEN is not also set. + * TCL_INVOKE_NO_TRACEBACK Does not record traceback information if the + * invoked command returns an error. Used if the + * caller plans on recording its own traceback + * information. */ #define TCL_INVOKE_HIDDEN (1<<0) #define TCL_INVOKE_NO_UNKNOWN (1<<1) #define TCL_INVOKE_NO_TRACEBACK (1<<2) /* - * The structure used as the internal representation of Tcl list - * objects. This is an array of pointers to the element objects. This array - * is grown (reallocated and copied) as necessary to hold all the list's - * element pointers. The array might contain more slots than currently used - * to hold all element pointers. This is done to make append operations + * The structure used as the internal representation of Tcl list objects. This + * struct is grown (reallocated and copied) as necessary to hold all the + * list's element pointers. The struct might contain more slots than currently + * used to hold all element pointers. This is done to make append operations * faster. */ typedef struct List { + int refCount; int maxElemCount; /* Total number of element array slots. */ int elemCount; /* Current number of list elements. */ - Tcl_Obj **elements; /* Array of pointers to element objects. */ + int canonicalFlag; /* Set if the string representation was + * derived from the list representation. May + * be ignored if there is no string rep at + * all.*/ + Tcl_Obj *elements; /* First list element; the struct is grown to + * accomodate all elements. */ } List; +/* + * Macro used to get the elements of a list object - do NOT forget to verify + * that it is of list type before using! + */ + +#define TclListObjGetElements(listPtr, objc, objv) \ + { \ + List *listRepPtr = \ + (List *) (listPtr)->internalRep.twoPtrValue.ptr1;\ + (objc) = listRepPtr->elemCount;\ + (objv) = &listRepPtr->elements;\ + } + +/* + * Flag values for TclTraceDictPath(). + * + * DICT_PATH_READ indicates that all entries on the path must exist but no + * updates will be needed. + * + * DICT_PATH_UPDATE indicates that we are going to be doing an update at the + * tip of the path, so duplication of shared objects should be done along the + * way. + * + * DICT_PATH_EXISTS indicates that we are performing an existance test and a + * lookup failure should therefore not be an error. If (and only if) this flag + * is set, TclTraceDictPath() will return the special value + * DICT_PATH_NON_EXISTENT if the path is not traceable. + * + * DICT_PATH_CREATE (which also requires the DICT_PATH_UPDATE bit to be set) + * indicates that we are to create non-existant dictionaries on the path. + */ + +#define DICT_PATH_READ 0 +#define DICT_PATH_UPDATE 1 +#define DICT_PATH_EXISTS 2 +#define DICT_PATH_CREATE 5 + +#define DICT_PATH_NON_EXISTENT ((Tcl_Obj *) (void *) 1) + /* *---------------------------------------------------------------- * Data structures related to the filesystem internals *---------------------------------------------------------------- */ - -/* - * The version_2 filesystem is private to Tcl. As and when these - * changes have been thoroughly tested and investigated a new public - * filesystem interface will be released. The aim is more versatile - * virtual filesystem interfaces, more efficiency in 'path' manipulation - * and usage, and cleaner filesystem code internally. +/* + * The version_2 filesystem is private to Tcl. As and when these changes have + * been thoroughly tested and investigated a new public filesystem interface + * will be released. The aim is more versatile virtual filesystem interfaces, + * more efficiency in 'path' manipulation and usage, and cleaner filesystem + * code internally. */ + #define TCL_FILESYSTEM_VERSION_2 ((Tcl_FSVersion) 0x2) -typedef ClientData (TclFSGetCwdProc2) _ANSI_ARGS_((ClientData clientData)); +typedef ClientData (TclFSGetCwdProc2) (ClientData clientData); /* - * The following types are used for getting and storing platform-specific - * file attributes in tclFCmd.c and the various platform-versions of - * that file. This is done to have as much common code as possible - * in the file attributes code. For more information about the callbacks, - * see TclFileAttrsCmd in tclFCmd.c. + * The following types are used for getting and storing platform-specific file + * attributes in tclFCmd.c and the various platform-versions of that file. + * This is done to have as much common code as possible in the file attributes + * code. For more information about the callbacks, see TclFileAttrsCmd in + * tclFCmd.c. */ -typedef int (TclGetFileAttrProc) _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, Tcl_Obj **attrObjPtrPtr)); -typedef int (TclSetFileAttrProc) _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, Tcl_Obj *attrObjPtr)); +typedef int (TclGetFileAttrProc) (Tcl_Interp *interp, int objIndex, + Tcl_Obj *fileName, Tcl_Obj **attrObjPtrPtr); +typedef int (TclSetFileAttrProc) (Tcl_Interp *interp, int objIndex, + Tcl_Obj *fileName, Tcl_Obj *attrObjPtr); typedef struct TclFileAttrProcs { - TclGetFileAttrProc *getProc; /* The procedure for getting attrs. */ - TclSetFileAttrProc *setProc; /* The procedure for setting attrs. */ + TclGetFileAttrProc *getProc;/* The procedure for getting attrs. */ + TclSetFileAttrProc *setProc;/* The procedure for setting attrs. */ } TclFileAttrProcs; /* * Opaque handle used in pipeline routines to encapsulate platform-dependent - * state. + * state. */ typedef struct TclFile_ *TclFile; - + /* - * The "globParameters" argument of the function TclGlob is an - * or'ed combination of the following values: + * The "globParameters" argument of the function TclGlob is an or'ed + * combination of the following values: */ #define TCL_GLOBMODE_NO_COMPLAIN 1 #define TCL_GLOBMODE_JOIN 2 #define TCL_GLOBMODE_DIR 4 #define TCL_GLOBMODE_TAILS 8 typedef enum Tcl_PathPart { TCL_PATH_DIRNAME, - TCL_PATH_TAIL, + TCL_PATH_TAIL, TCL_PATH_EXTENSION, TCL_PATH_ROOT } Tcl_PathPart; /* @@ -1668,16 +1837,14 @@ *---------------------------------------------------------------- * Data structures related to obsolete filesystem hooks *---------------------------------------------------------------- */ -typedef int (TclStatProc_) _ANSI_ARGS_((CONST char *path, struct stat *buf)); -typedef int (TclAccessProc_) _ANSI_ARGS_((CONST char *path, int mode)); -typedef Tcl_Channel (TclOpenFileChannelProc_) _ANSI_ARGS_((Tcl_Interp *interp, - CONST char *fileName, CONST char *modeString, - int permissions)); - +typedef int (TclStatProc_) (CONST char *path, struct stat *buf); +typedef int (TclAccessProc_) (CONST char *path, int mode); +typedef Tcl_Channel (TclOpenFileChannelProc_) (Tcl_Interp *interp, + CONST char *fileName, CONST char *modeString, int permissions); /* *---------------------------------------------------------------- * Data structures related to procedures *---------------------------------------------------------------- @@ -1690,38 +1857,67 @@ *---------------------------------------------------------------- * Data structures for process-global values. *---------------------------------------------------------------- */ -typedef void (TclInitProcessGlobalValueProc) _ANSI_ARGS_((char **valuePtr, - int *lengthPtr, Tcl_Encoding *encodingPtr)); +typedef void (TclInitProcessGlobalValueProc) (char **valuePtr, int *lengthPtr, + Tcl_Encoding *encodingPtr); /* - * A ProcessGlobalValue struct exists for each internal value in - * Tcl that is to be shared among several threads. Each thread - * sees a (Tcl_Obj) copy of the value, and the master is kept as - * a counted string, with epoch and mutex control. Each ProcessGlobalValue - * struct should be a static variable in some file. + * A ProcessGlobalValue struct exists for each internal value in Tcl that is + * to be shared among several threads. Each thread sees a (Tcl_Obj) copy of + * the value, and the master is kept as a counted string, with epoch and mutex + * control. Each ProcessGlobalValue struct should be a static variable in some + * file. */ + typedef struct ProcessGlobalValue { - int epoch; /* Epoch counter to detect changes - * in the master value */ - int numBytes; /* Length of the master string */ - char *value; /* The master string value */ - Tcl_Encoding encoding; /* system encoding when master string - * was initialized */ + int epoch; /* Epoch counter to detect changes in the + * master value. */ + int numBytes; /* Length of the master string. */ + char *value; /* The master string value. */ + Tcl_Encoding encoding; /* system encoding when master string was + * initialized. */ TclInitProcessGlobalValueProc *proc; - /* A procedure to initialize the - * master string copy when a "get" - * request comes in before any - * "set" request has been received. */ - Tcl_Mutex mutex; /* Enforce orderly access from - * multiple threads */ - Tcl_ThreadDataKey key; /* Key for per-thread data holding - * the (Tcl_Obj) copy for each thread */ + /* A procedure to initialize the master string + * copy when a "get" request comes in before + * any "set" request has been received. */ + Tcl_Mutex mutex; /* Enforce orderly access from multiple + * threads. */ + Tcl_ThreadDataKey key; /* Key for per-thread data holding the + * (Tcl_Obj) copy for each thread. */ } 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. *---------------------------------------------------------------- */ @@ -1730,14 +1926,24 @@ MODULE_SCOPE int tclFindExecutableSearchDone; MODULE_SCOPE char * tclMemDumpFileName; MODULE_SCOPE TclPlatformType tclPlatform; MODULE_SCOPE Tcl_NotifierProcs tclOriginalNotifier; +/* + * TIP #233 (Virtualized Time) + * Data for the time hooks, if any. + */ + +MODULE_SCOPE Tcl_GetTimeProc* tclGetTimeProcPtr; +MODULE_SCOPE Tcl_ScaleTimeProc* tclScaleTimeProcPtr; +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; MODULE_SCOPE Tcl_ObjType tclDoubleType; MODULE_SCOPE Tcl_ObjType tclEndOffsetType; @@ -1745,17 +1951,15 @@ MODULE_SCOPE Tcl_ObjType tclListType; MODULE_SCOPE Tcl_ObjType tclDictType; MODULE_SCOPE Tcl_ObjType tclProcBodyType; MODULE_SCOPE Tcl_ObjType tclStringType; MODULE_SCOPE Tcl_ObjType tclArraySearchType; -MODULE_SCOPE Tcl_ObjType tclIndexType; MODULE_SCOPE Tcl_ObjType tclNsNameType; -MODULE_SCOPE Tcl_ObjType tclEnsembleCmdType; +#ifndef NO_WIDE_TYPE MODULE_SCOPE Tcl_ObjType tclWideIntType; -MODULE_SCOPE Tcl_ObjType tclLocalVarNameType; +#endif MODULE_SCOPE Tcl_ObjType tclRegexpType; -MODULE_SCOPE Tcl_ObjType tclLevelReferenceType; /* * Variables denoting the hash key types defined in the core. */ @@ -1777,612 +1981,640 @@ #define TCL_MAX_SHARED_OBJ_STATS 5 MODULE_SCOPE long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS]; #endif /* TCL_COMPILE_STATS */ /* - * Pointer to a heap-allocated string of length zero that the Tcl core uses - * as the value of an empty string representation for an object. This value - * is shared by all new objects allocated by Tcl_NewObj. + * Pointer to a heap-allocated string of length zero that the Tcl core uses as + * the value of an empty string representation for an object. This value is + * shared by all new objects allocated by Tcl_NewObj. */ MODULE_SCOPE char * tclEmptyStringRep; MODULE_SCOPE char tclEmptyString; /* *---------------------------------------------------------------- - * Procedures shared among Tcl modules but not used by the outside - * world: + * Procedures shared among Tcl modules but not used by the outside world: *---------------------------------------------------------------- */ -MODULE_SCOPE void TclAppendLimitedToObj _ANSI_ARGS_((Tcl_Obj *objPtr, +MODULE_SCOPE int TclAppendFormattedObjs(Tcl_Interp *interp, + Tcl_Obj *appendObj, CONST char *format, + int objc, Tcl_Obj *CONST objv[]); +MODULE_SCOPE void TclAppendLimitedToObj(Tcl_Obj *objPtr, CONST char *bytes, int length, int limit, - CONST char *ellipsis)); -MODULE_SCOPE void TclAppendObjToErrorInfo _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_Obj *objPtr)); -MODULE_SCOPE int TclArraySet _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj)); -MODULE_SCOPE int TclCheckBadOctal _ANSI_ARGS_((Tcl_Interp *interp, - CONST char *value)); -MODULE_SCOPE void TclCleanupLiteralTable _ANSI_ARGS_(( - Tcl_Interp* interp, LiteralTable* tablePtr)); -MODULE_SCOPE void TclExpandTokenArray _ANSI_ARGS_(( - Tcl_Parse *parsePtr)); -MODULE_SCOPE int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -MODULE_SCOPE int TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])) ; -MODULE_SCOPE int TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -MODULE_SCOPE int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])) ; -MODULE_SCOPE int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])) ; -MODULE_SCOPE void TclFinalizeAllocSubsystem _ANSI_ARGS_((void)); -MODULE_SCOPE void TclFinalizeCompExecEnv _ANSI_ARGS_((void)); -MODULE_SCOPE void TclFinalizeCompilation _ANSI_ARGS_((void)); -MODULE_SCOPE void TclFinalizeEncodingSubsystem _ANSI_ARGS_((void)); -MODULE_SCOPE void TclFinalizeEnvironment _ANSI_ARGS_((void)); -MODULE_SCOPE void TclFinalizeExecution _ANSI_ARGS_((void)); -MODULE_SCOPE void TclFinalizeIOSubsystem _ANSI_ARGS_((void)); -MODULE_SCOPE void TclFinalizeFilesystem _ANSI_ARGS_((void)); -MODULE_SCOPE void TclResetFilesystem _ANSI_ARGS_((void)); -MODULE_SCOPE void TclFinalizeLoad _ANSI_ARGS_((void)); -MODULE_SCOPE void TclFinalizeMemorySubsystem _ANSI_ARGS_((void)); -MODULE_SCOPE void TclFinalizeNotifier _ANSI_ARGS_((void)); -MODULE_SCOPE void TclFinalizeAsync _ANSI_ARGS_((void)); -MODULE_SCOPE void TclFinalizeSynchronization _ANSI_ARGS_((void)); -MODULE_SCOPE void TclFinalizeLock _ANSI_ARGS_((void)); -MODULE_SCOPE void TclFinalizeThreadData _ANSI_ARGS_((void)); -MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler _ANSI_ARGS_((Tcl_Interp *interp)); -MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue _ANSI_ARGS_ (( - ProcessGlobalValue *pgvPtr)); -MODULE_SCOPE int TclGlob _ANSI_ARGS_((Tcl_Interp *interp, - char *pattern, Tcl_Obj *unquotedPrefix, - int globFlags, Tcl_GlobTypeData* types)); -MODULE_SCOPE void TclInitAlloc _ANSI_ARGS_((void)); -MODULE_SCOPE void TclInitDbCkalloc _ANSI_ARGS_((void)); -MODULE_SCOPE void TclInitEmbeddedConfigurationInformation - _ANSI_ARGS_((Tcl_Interp *interp)); -MODULE_SCOPE void TclInitEncodingSubsystem _ANSI_ARGS_((void)); -MODULE_SCOPE void TclInitIOSubsystem _ANSI_ARGS_((void)); -MODULE_SCOPE void TclInitLimitSupport _ANSI_ARGS_((Tcl_Interp *interp)); -MODULE_SCOPE void TclInitNamespaceSubsystem _ANSI_ARGS_((void)); -MODULE_SCOPE void TclInitNotifier _ANSI_ARGS_((void)); -MODULE_SCOPE void TclInitObjSubsystem _ANSI_ARGS_((void)); + CONST char *ellipsis); +MODULE_SCOPE void TclAppendObjToErrorInfo(Tcl_Interp *interp, + Tcl_Obj *objPtr); +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[]); +MODULE_SCOPE int TclChanPostEventObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); +MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, + Tcl_Channel chan); +MODULE_SCOPE void TclCleanupLiteralTable(Tcl_Interp* interp, + LiteralTable* tablePtr); +MODULE_SCOPE int TclDoubleDigits(char* buf, double value, int* signum); +MODULE_SCOPE void TclExpandTokenArray(Tcl_Parse *parsePtr); +MODULE_SCOPE int TclFileAttrsCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +MODULE_SCOPE int TclFileCopyCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +MODULE_SCOPE int TclFileDeleteCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +MODULE_SCOPE int TclFileMakeDirsCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +MODULE_SCOPE int TclFileRenameCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +MODULE_SCOPE void TclFinalizeAllocSubsystem(void); +MODULE_SCOPE void TclFinalizeAsync(void); +MODULE_SCOPE void TclFinalizeCompilation(void); +MODULE_SCOPE void TclFinalizeDoubleConversion(void); +MODULE_SCOPE void TclFinalizeEncodingSubsystem(void); +MODULE_SCOPE void TclFinalizeEnvironment(void); +MODULE_SCOPE void TclFinalizeExecution(void); +MODULE_SCOPE void TclFinalizeIOSubsystem(void); +MODULE_SCOPE void TclFinalizeFilesystem(void); +MODULE_SCOPE void TclResetFilesystem(void); +MODULE_SCOPE void TclFinalizeLoad(void); +MODULE_SCOPE void TclFinalizeLock(void); +MODULE_SCOPE void TclFinalizeMemorySubsystem(void); +MODULE_SCOPE void TclFinalizeNotifier(void); +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, ...); +MODULE_SCOPE int TclFormatToErrorInfo(Tcl_Interp *interp, + CONST char *format, ...); +MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr, + CONST char *attributeName, int *indexPtr); +MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler(Tcl_Interp *interp); +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); +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( + Tcl_Interp *interp); +MODULE_SCOPE void TclInitEncodingSubsystem(void); +MODULE_SCOPE void TclInitIOSubsystem(void); +MODULE_SCOPE void TclInitLimitSupport(Tcl_Interp *interp); +MODULE_SCOPE void TclInitNamespaceSubsystem(void); +MODULE_SCOPE void TclInitNotifier(void); +MODULE_SCOPE void TclInitObjSubsystem(void); MODULE_SCOPE void TclInitSubsystems (); -MODULE_SCOPE int TclIsLocalScalar _ANSI_ARGS_((CONST char *src, - int len)); -MODULE_SCOPE int TclJoinThread _ANSI_ARGS_((Tcl_ThreadId id, - int* result)); -MODULE_SCOPE void TclLimitRemoveAllHandlers _ANSI_ARGS_(( - Tcl_Interp *interp)); -MODULE_SCOPE Tcl_Obj * TclLindexList _ANSI_ARGS_((Tcl_Interp* interp, - Tcl_Obj* listPtr, Tcl_Obj* argPtr)); -MODULE_SCOPE Tcl_Obj * TclLindexFlat _ANSI_ARGS_((Tcl_Interp* interp, - Tcl_Obj* listPtr, int indexCount, - Tcl_Obj *CONST indexArray[])); -MODULE_SCOPE int TclLoadFile _ANSI_ARGS_((Tcl_Interp* interp, - Tcl_Obj *pathPtr, int symc, - CONST char *symbols[], +MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp); +MODULE_SCOPE int TclIsLocalScalar(CONST char *src, int len); +MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int* result); +MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); +MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp* interp, + Tcl_Obj* listPtr, Tcl_Obj* argPtr); +MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp* interp, Tcl_Obj* listPtr, + int indexCount, Tcl_Obj *CONST indexArray[]); +MODULE_SCOPE int TclLoadFile(Tcl_Interp* interp, Tcl_Obj *pathPtr, + int symc, CONST char *symbols[], Tcl_PackageInitProc **procPtrs[], Tcl_LoadHandle *handlePtr, ClientData *clientDataPtr, - Tcl_FSUnloadFileProc **unloadProcPtr)); -MODULE_SCOPE Tcl_Obj * TclLsetList _ANSI_ARGS_((Tcl_Interp* interp, - Tcl_Obj* listPtr, Tcl_Obj* indexPtr, - Tcl_Obj* valuePtr)); -MODULE_SCOPE Tcl_Obj * TclLsetFlat _ANSI_ARGS_((Tcl_Interp* interp, - Tcl_Obj* listPtr, int indexCount, - Tcl_Obj *CONST indexArray[], Tcl_Obj* valuePtr)); -MODULE_SCOPE int TclMergeReturnOptions _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[], - Tcl_Obj **optionsPtrPtr, int *codePtr, - int *levelPtr)); -MODULE_SCOPE int TclObjInvokeNamespace _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[], - Tcl_Namespace *nsPtr, int flags)); -MODULE_SCOPE int TclParseBackslash _ANSI_ARGS_((CONST char *src, - int numBytes, int *readPtr, char *dst)); -MODULE_SCOPE int TclParseHex _ANSI_ARGS_((CONST char *src, int numBytes, - Tcl_UniChar *resultPtr)); -MODULE_SCOPE void TclParseInit _ANSI_ARGS_ ((Tcl_Interp *interp, - CONST char *string, int numBytes, - Tcl_Parse *parsePtr)); -MODULE_SCOPE int TclParseInteger _ANSI_ARGS_((CONST char *string, - int numBytes)); -MODULE_SCOPE int TclParseWhiteSpace _ANSI_ARGS_((CONST char *src, - int numBytes, Tcl_Parse *parsePtr, char *typePtr)); -MODULE_SCOPE int TclProcessReturn _ANSI_ARGS_((Tcl_Interp *interp, - int code, int level, Tcl_Obj *returnOpts)); -MODULE_SCOPE int TclpObjLstat _ANSI_ARGS_((Tcl_Obj *pathPtr, - Tcl_StatBuf *buf)); -MODULE_SCOPE int TclpCheckStackSpace _ANSI_ARGS_((void)); -MODULE_SCOPE Tcl_Obj * TclpTempFileName _ANSI_ARGS_((void)); -MODULE_SCOPE Tcl_Obj * TclNewFSPathObj _ANSI_ARGS_((Tcl_Obj *dirPtr, - CONST char *addStrRep, int len)); -MODULE_SCOPE int TclpDeleteFile _ANSI_ARGS_((CONST char *path)); -MODULE_SCOPE void TclpFinalizeCondition _ANSI_ARGS_(( - Tcl_Condition *condPtr)); -MODULE_SCOPE void TclpFinalizeMutex _ANSI_ARGS_((Tcl_Mutex *mutexPtr)); -MODULE_SCOPE void TclpFinalizeThreadData _ANSI_ARGS_(( - Tcl_ThreadDataKey *keyPtr)); -MODULE_SCOPE int TclpThreadCreate _ANSI_ARGS_(( - Tcl_ThreadId *idPtr, - Tcl_ThreadCreateProc proc, - ClientData clientData, - int stackSize, int flags)); -MODULE_SCOPE void TclpFinalizeThreadDataKey _ANSI_ARGS_(( - Tcl_ThreadDataKey *keyPtr)); -MODULE_SCOPE int TclpFindVariable _ANSI_ARGS_((CONST char *name, - int *lengthPtr)); -MODULE_SCOPE void TclpInitLibraryPath _ANSI_ARGS_((char **valuePtr, - int *lengthPtr, Tcl_Encoding *encodingPtr)); -MODULE_SCOPE void TclpInitLock _ANSI_ARGS_((void)); -MODULE_SCOPE void TclpInitPlatform _ANSI_ARGS_((void)); -MODULE_SCOPE void TclpInitUnlock _ANSI_ARGS_((void)); -MODULE_SCOPE int TclpLoadFile _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *pathPtr, CONST char *sym1, - CONST char *sym2, Tcl_PackageInitProc **proc1Ptr, - Tcl_PackageInitProc **proc2Ptr, + Tcl_FSUnloadFileProc **unloadProcPtr); +MODULE_SCOPE Tcl_Obj * TclLsetList(Tcl_Interp* interp, Tcl_Obj* listPtr, + Tcl_Obj* indexPtr, Tcl_Obj* valuePtr); +MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp* interp, Tcl_Obj* listPtr, + int indexCount, Tcl_Obj *CONST indexArray[], + Tcl_Obj* valuePtr); +MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[], Tcl_Obj **optionsPtrPtr, + int *codePtr, int *levelPtr); +MODULE_SCOPE int TclObjInvokeNamespace(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[], + Tcl_Namespace *nsPtr, int flags); +MODULE_SCOPE int TclObjPrintf(Tcl_Interp *interp, Tcl_Obj *objPtr, + CONST char *format, ...); +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, + int code, int level, Tcl_Obj *returnOpts); +MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); +MODULE_SCOPE int TclpCheckStackSpace(void); +MODULE_SCOPE Tcl_Obj * TclpTempFileName(void); +MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep, + int len); +MODULE_SCOPE int TclpDeleteFile(CONST char *path); +MODULE_SCOPE void TclpFinalizeCondition(Tcl_Condition *condPtr); +MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr); +MODULE_SCOPE void TclpFinalizePipes(void); +MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr, + Tcl_ThreadCreateProc proc, ClientData clientData, + int stackSize, int flags); +MODULE_SCOPE int TclpFindVariable(CONST char *name, int *lengthPtr); +MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, + int *lengthPtr, Tcl_Encoding *encodingPtr); +MODULE_SCOPE void TclpInitLock(void); +MODULE_SCOPE void TclpInitPlatform(void); +MODULE_SCOPE void TclpInitUnlock(void); +MODULE_SCOPE int TclpLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, + CONST char *sym1, CONST char *sym2, + Tcl_PackageInitProc **proc1Ptr, + Tcl_PackageInitProc **proc2Ptr, ClientData *clientDataPtr, - Tcl_FSUnloadFileProc **unloadProcPtr)); -MODULE_SCOPE Tcl_Obj * TclpObjListVolumes _ANSI_ARGS_((void)); -MODULE_SCOPE void TclpMasterLock _ANSI_ARGS_((void)); -MODULE_SCOPE void TclpMasterUnlock _ANSI_ARGS_((void)); -MODULE_SCOPE int TclpMatchFiles _ANSI_ARGS_((Tcl_Interp *interp, - char *separators, Tcl_DString *dirPtr, - char *pattern, char *tail)); -MODULE_SCOPE int TclpObjNormalizePath _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *pathPtr, int nextCheckpoint)); -MODULE_SCOPE void TclpNativeJoinPath _ANSI_ARGS_((Tcl_Obj *prefix, - char *joining)); -MODULE_SCOPE Tcl_Obj * TclpNativeSplitPath _ANSI_ARGS_((Tcl_Obj *pathPtr, - int *lenPtr)); -MODULE_SCOPE Tcl_PathType TclpGetNativePathType _ANSI_ARGS_((Tcl_Obj *pathPtr, - int *driveNameLengthPtr, Tcl_Obj **driveNameRef)); -MODULE_SCOPE int TclCrossFilesystemCopy _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_Obj *source, - Tcl_Obj *target)); -MODULE_SCOPE int TclpMatchInDirectory _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, - CONST char *pattern, Tcl_GlobTypeData *types)); -MODULE_SCOPE ClientData TclpGetNativeCwd _ANSI_ARGS_((ClientData clientData)); + Tcl_FSUnloadFileProc **unloadProcPtr); +MODULE_SCOPE Tcl_Obj * TclpObjListVolumes(void); +MODULE_SCOPE void TclpMasterLock(void); +MODULE_SCOPE void TclpMasterUnlock(void); +MODULE_SCOPE int TclpMatchFiles(Tcl_Interp *interp, char *separators, + Tcl_DString *dirPtr, char *pattern, char *tail); +MODULE_SCOPE int TclpObjNormalizePath(Tcl_Interp *interp, + Tcl_Obj *pathPtr, int nextCheckpoint); +MODULE_SCOPE void TclpNativeJoinPath(Tcl_Obj *prefix, char *joining); +MODULE_SCOPE Tcl_Obj * TclpNativeSplitPath(Tcl_Obj *pathPtr, int *lenPtr); +MODULE_SCOPE Tcl_PathType TclpGetNativePathType(Tcl_Obj *pathPtr, + int *driveNameLengthPtr, Tcl_Obj **driveNameRef); +MODULE_SCOPE int TclCrossFilesystemCopy(Tcl_Interp *interp, + Tcl_Obj *source, Tcl_Obj *target); +MODULE_SCOPE int TclpMatchInDirectory(Tcl_Interp *interp, + Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, + CONST char *pattern, Tcl_GlobTypeData *types); +MODULE_SCOPE ClientData TclpGetNativeCwd(ClientData clientData); MODULE_SCOPE Tcl_FSDupInternalRepProc TclNativeDupInternalRep; -MODULE_SCOPE Tcl_Obj* TclpObjLink _ANSI_ARGS_((Tcl_Obj *pathPtr, - Tcl_Obj *toPtr, int linkType)); -MODULE_SCOPE int TclpObjChdir _ANSI_ARGS_((Tcl_Obj *pathPtr)); -MODULE_SCOPE Tcl_Obj * TclPathPart _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *pathPtr, Tcl_PathPart portion)); -MODULE_SCOPE void TclpCutFileChannel _ANSI_ARGS_((Tcl_Channel chan)); -MODULE_SCOPE void TclpCutSockChannel _ANSI_ARGS_((Tcl_Channel chan)); -MODULE_SCOPE void TclpSpliceFileChannel _ANSI_ARGS_((Tcl_Channel chan)); -MODULE_SCOPE void TclpSpliceSockChannel _ANSI_ARGS_((Tcl_Channel chan)); -MODULE_SCOPE void TclpPanic _ANSI_ARGS_(TCL_VARARGS(CONST char *, - format)); -MODULE_SCOPE char * TclpReadlink _ANSI_ARGS_((CONST char *fileName, - Tcl_DString *linkPtr)); -MODULE_SCOPE void TclpReleaseFile _ANSI_ARGS_((TclFile file)); -MODULE_SCOPE void TclpSetVariables _ANSI_ARGS_((Tcl_Interp *interp)); -MODULE_SCOPE void TclpUnloadFile _ANSI_ARGS_(( - Tcl_LoadHandle loadHandle)); -MODULE_SCOPE VOID * TclpThreadDataKeyGet _ANSI_ARGS_(( - Tcl_ThreadDataKey *keyPtr)); -MODULE_SCOPE void TclpThreadDataKeyInit _ANSI_ARGS_(( - Tcl_ThreadDataKey *keyPtr)); -MODULE_SCOPE void TclpThreadDataKeySet _ANSI_ARGS_(( - Tcl_ThreadDataKey *keyPtr, VOID *data)); -MODULE_SCOPE void TclpThreadExit _ANSI_ARGS_((int status)); -MODULE_SCOPE int TclpThreadGetStackSize _ANSI_ARGS_((void)); -MODULE_SCOPE void TclRememberCondition _ANSI_ARGS_(( - Tcl_Condition *mutex)); -MODULE_SCOPE void TclRememberDataKey _ANSI_ARGS_(( - Tcl_ThreadDataKey *mutex)); -MODULE_SCOPE VOID TclRememberJoinableThread _ANSI_ARGS_(( - Tcl_ThreadId id)); -MODULE_SCOPE void TclRememberMutex _ANSI_ARGS_((Tcl_Mutex *mutex)); -MODULE_SCOPE void TclRemoveScriptLimitCallbacks _ANSI_ARGS_(( - Tcl_Interp *interp)); -MODULE_SCOPE void TclSetBgErrorHandler _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *cmdPrefix)); -MODULE_SCOPE void TclSetProcessGlobalValue _ANSI_ARGS_ (( - ProcessGlobalValue *pgvPtr, Tcl_Obj *newValue, - Tcl_Encoding encoding)); -MODULE_SCOPE VOID TclSignalExitThread _ANSI_ARGS_((Tcl_ThreadId id, - int result)); -MODULE_SCOPE int TclSubstTokens _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Token *tokenPtr, int count, - int *tokensLeftPtr)); -MODULE_SCOPE void TclTransferResult _ANSI_ARGS_(( - Tcl_Interp *sourceInterp, int result, - Tcl_Interp *targetInterp)); -MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized _ANSI_ARGS_(( - ClientData clientData)); -MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType _ANSI_ARGS_(( - Tcl_Obj* pathPtr)); -MODULE_SCOPE Tcl_PackageInitProc* TclpFindSymbol _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_LoadHandle loadHandle, - CONST char *symbol)); -MODULE_SCOPE int TclpDlopen _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *pathPtr, Tcl_LoadHandle *loadHandle, - Tcl_FSUnloadFileProc **unloadProcPtr)); -MODULE_SCOPE int TclpUtime _ANSI_ARGS_((Tcl_Obj *pathPtr, - struct utimbuf *tval)); -MODULE_SCOPE int TclIsEnsemble _ANSI_ARGS_((Command *cmdPtr)); +MODULE_SCOPE Tcl_Obj* TclpObjLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr, + int linkType); +MODULE_SCOPE int TclpObjChdir(Tcl_Obj *pathPtr); +MODULE_SCOPE Tcl_Obj * TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr, + Tcl_PathPart portion); +MODULE_SCOPE void TclpPanic(CONST char *format, ...); +MODULE_SCOPE char * TclpReadlink(CONST char *fileName, + Tcl_DString *linkPtr); +MODULE_SCOPE void TclpReleaseFile(TclFile file); +MODULE_SCOPE void TclpSetInterfaces(void); +MODULE_SCOPE void TclpSetVariables(Tcl_Interp *interp); +MODULE_SCOPE void TclpUnloadFile(Tcl_LoadHandle loadHandle); +MODULE_SCOPE VOID * TclpThreadDataKeyGet(Tcl_ThreadDataKey *keyPtr); +MODULE_SCOPE void TclpThreadDataKeySet(Tcl_ThreadDataKey *keyPtr, + VOID *data); +MODULE_SCOPE void TclpThreadExit(int status); +MODULE_SCOPE int TclpThreadGetStackSize(void); +MODULE_SCOPE void TclRememberCondition(Tcl_Condition *mutex); +MODULE_SCOPE VOID TclRememberJoinableThread(Tcl_ThreadId id); +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 int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, + int count, int *tokensLeftPtr); +MODULE_SCOPE void TclTransferResult(Tcl_Interp *sourceInterp, int result, + Tcl_Interp *targetInterp); +MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData); +MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj* pathPtr); +MODULE_SCOPE Tcl_PackageInitProc* TclpFindSymbol(Tcl_Interp *interp, + Tcl_LoadHandle loadHandle, CONST char *symbol); +MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr, + Tcl_LoadHandle *loadHandle, + Tcl_FSUnloadFileProc **unloadProcPtr); +MODULE_SCOPE int TclpUtime(Tcl_Obj *pathPtr, struct utimbuf *tval); +#ifdef TCL_LOAD_FROM_MEMORY +MODULE_SCOPE void* TclpLoadMemoryGetBuffer(Tcl_Interp *interp, int size); +MODULE_SCOPE int TclpLoadMemory(Tcl_Interp *interp, void *buffer, + int size, int codeSize, Tcl_LoadHandle *loadHandle, + Tcl_FSUnloadFileProc **unloadProcPtr); +#endif +MODULE_SCOPE void TclInitThreadStorage(void); +MODULE_SCOPE void TclpFinalizeThreadDataThread(void); +MODULE_SCOPE void TclFinalizeThreadStorage(void); /* *---------------------------------------------------------------- * Command procedures in the generic core: *---------------------------------------------------------------- */ -MODULE_SCOPE int Tcl_AfterObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_AppendObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_ArrayObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_BinaryObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_BreakObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_CaseObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_CatchObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_CdObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int TclClockClicksObjCmd _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -MODULE_SCOPE int TclClockGetenvObjCmd _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -MODULE_SCOPE int TclClockMicrosecondsObjCmd _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -MODULE_SCOPE int TclClockMillisecondsObjCmd _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -MODULE_SCOPE int TclClockSecondsObjCmd _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -MODULE_SCOPE int TclClockLocaltimeObjCmd _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -MODULE_SCOPE int TclClockMktimeObjCmd _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -MODULE_SCOPE int TclClockOldscanObjCmd _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_CloseObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_ConcatObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_ContinueObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int TclDefaultBgErrorHandlerObjCmd _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_DictObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_EncodingObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_EofObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_ErrorObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_EvalObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_ExecObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_ExitObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_ExprObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_FblockedObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_FconfigureObjCmd _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_FcopyObjCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_FileObjCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_FileEventObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_FlushObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_ForObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_ForeachObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_FormatObjCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_GetsObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_GlobalObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_GlobObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_IfObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_IncrObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_InfoObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_InterpObjCmd _ANSI_ARGS_((ClientData clientData, +MODULE_SCOPE int Tcl_AfterObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_AppendObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_ArrayObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_BinaryObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_BreakObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_CaseObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_CatchObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_CdObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int TclChanTruncateObjCmd( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +MODULE_SCOPE int TclClockClicksObjCmd( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +MODULE_SCOPE int TclClockGetenvObjCmd( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +MODULE_SCOPE int TclClockMicrosecondsObjCmd( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +MODULE_SCOPE int TclClockMillisecondsObjCmd( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +MODULE_SCOPE int TclClockSecondsObjCmd( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +MODULE_SCOPE int TclClockLocaltimeObjCmd( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +MODULE_SCOPE int TclClockMktimeObjCmd( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +MODULE_SCOPE int TclClockOldscanObjCmd( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_CloseObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_ConcatObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_ContinueObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE Tcl_TimerToken TclCreateAbsoluteTimerHandler( + Tcl_Time *timePtr, Tcl_TimerProc *proc, + ClientData clientData); +MODULE_SCOPE int TclDefaultBgErrorHandlerObjCmd( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_DictObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_EncodingObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int TclEncodingDirsObjCmd( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_EofObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_ErrorObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_EvalObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_ExecObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_ExitObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_ExprObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_FblockedObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_FconfigureObjCmd( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_FcopyObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_FileObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_FileEventObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_FlushObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_ForObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_ForeachObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_FormatObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_GetsObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_GlobalObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_GlobObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_IfObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_IncrObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_InfoObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_InterpObjCmd(ClientData clientData, Tcl_Interp *interp, int argc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_JoinObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_LappendObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_LassignObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_LindexObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_LinsertObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_LlengthObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_ListObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_LoadObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_LrangeObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_LrepeatObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_LreplaceObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_LsearchObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_LsetObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_JoinObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_LappendObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_LassignObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_LindexObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_LinsertObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_LlengthObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_ListObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_LoadObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_LrangeObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_LrepeatObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_LreplaceObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_LsearchObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_LsetObjCmd(ClientData clientData, Tcl_Interp* interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_LsortObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_NamespaceObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_OpenObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_PackageObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_PidObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_PutsObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_PwdObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_ReadObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_RegexpObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_RegsubObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_RenameObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_ReturnObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_ScanObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_SeekObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_SetObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_SplitObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_SocketObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_SourceObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_StringObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_SubstObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_SwitchObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_TellObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_TimeObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_TraceObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_UnloadObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_UnsetObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_UpdateObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_UplevelObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_UpvarObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_VariableObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_VwaitObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -MODULE_SCOPE int Tcl_WhileObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_LsortObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_NamespaceObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_OpenObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_PackageObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_PidObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_PutsObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_PwdObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_ReadObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_RegexpObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_RegsubObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_RenameObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_ReturnObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_ScanObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_SeekObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_SetObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_SplitObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_SocketObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_SourceObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_StringObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_SubstObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_SwitchObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_TellObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_TimeObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_TraceObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_UnloadObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_UnsetObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_UpdateObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_UplevelObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_UpvarObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_VariableObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_VwaitObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_WhileObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); /* *---------------------------------------------------------------- * Compilation procedures for commands in the generic core: *---------------------------------------------------------------- */ -MODULE_SCOPE int TclCompileAppendCmd _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); -MODULE_SCOPE int TclCompileBreakCmd _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); -MODULE_SCOPE int TclCompileCatchCmd _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); -MODULE_SCOPE int TclCompileContinueCmd _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); -MODULE_SCOPE int TclCompileExprCmd _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); -MODULE_SCOPE int TclCompileForCmd _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); -MODULE_SCOPE int TclCompileForeachCmd _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); -MODULE_SCOPE int TclCompileIfCmd _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); -MODULE_SCOPE int TclCompileIncrCmd _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); -MODULE_SCOPE int TclCompileLappendCmd _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); -MODULE_SCOPE int TclCompileLassignCmd _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); -MODULE_SCOPE int TclCompileLindexCmd _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); -MODULE_SCOPE int TclCompileListCmd _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); -MODULE_SCOPE int TclCompileLlengthCmd _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); -MODULE_SCOPE int TclCompileLsetCmd _ANSI_ARGS_((Tcl_Interp* interp, - Tcl_Parse* parsePtr, struct CompileEnv* envPtr)); -MODULE_SCOPE int TclCompileRegexpCmd _ANSI_ARGS_((Tcl_Interp* interp, - Tcl_Parse* parsePtr, struct CompileEnv* envPtr)); -MODULE_SCOPE int TclCompileReturnCmd _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); -MODULE_SCOPE int TclCompileSetCmd _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); -MODULE_SCOPE int TclCompileStringCmd _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); -MODULE_SCOPE int TclCompileSwitchCmd _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); -MODULE_SCOPE int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +MODULE_SCOPE int TclCompileAppendCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBreakCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileCatchCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileContinueCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileExprCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileForCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileForeachCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileIfCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileIncrCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileLappendCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileLassignCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileLindexCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileListCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileLlengthCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileLsetCmd(Tcl_Interp* interp, + Tcl_Parse* parsePtr, struct CompileEnv* envPtr); +MODULE_SCOPE int TclCompileRegexpCmd(Tcl_Interp* interp, + Tcl_Parse* parsePtr, struct CompileEnv* envPtr); +MODULE_SCOPE int TclCompileReturnCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileSetCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileSwitchCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileWhileCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr); /* - * Functions defined in generic/tclVar.c and currenttly exported only - * for use by the bytecode compiler and engine. Some of these could later - * be placed in the public interface. + * Functions defined in generic/tclVar.c and currenttly exported only for use + * by the bytecode compiler and engine. Some of these could later be placed in + * the public interface. */ -MODULE_SCOPE Var * TclLookupArrayElement _ANSI_ARGS_((Tcl_Interp *interp, +MODULE_SCOPE Var * TclLookupArrayElement(Tcl_Interp *interp, CONST char *arrayName, CONST char *elName, CONST int flags, CONST char *msg, CONST int createPart1, CONST int createPart2, - Var *arrayPtr)); -MODULE_SCOPE Var * TclObjLookupVar _ANSI_ARGS_((Tcl_Interp *interp, + Var *arrayPtr); +MODULE_SCOPE Var * TclObjLookupVar(Tcl_Interp *interp, Tcl_Obj *part1Ptr, CONST char *part2, int flags, CONST char *msg, CONST int createPart1, - CONST int createPart2, Var **arrayPtrPtr)); -MODULE_SCOPE Tcl_Obj * TclPtrGetVar _ANSI_ARGS_((Tcl_Interp *interp, + CONST int createPart2, Var **arrayPtrPtr); +MODULE_SCOPE Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, CONST char *part1, - CONST char *part2, CONST int flags)); -MODULE_SCOPE Tcl_Obj * TclPtrSetVar _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *part2, CONST int flags); +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 * TclPtrIncrVar _ANSI_ARGS_((Tcl_Interp *interp, + 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)); -MODULE_SCOPE Tcl_Obj * TclPtrIncrWideVar _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *part2, CONST long i, CONST int flags); +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)); + CONST int flags); +#endif +MODULE_SCOPE void TclInvalidateNsPath(Namespace *nsPtr); /* *---------------------------------------------------------------- * Macros used by the Tcl core to create and release Tcl objects. * TclNewObj(objPtr) creates a new object denoting an empty string. - * TclDecrRefCount(objPtr) decrements the object's reference count, - * and frees the object if its reference count is zero. - * These macros are inline versions of Tcl_NewObj() and - * Tcl_DecrRefCount(). Notice that the names differ in not having - * a "_" after the "Tcl". Notice also that these macros reference - * their argument more than once, so you should avoid calling them - * with an expression that is expensive to compute or has - * side effects. The ANSI C "prototypes" for these macros are: - * - * MODULE_SCOPE void TclNewObj _ANSI_ARGS_((Tcl_Obj *objPtr)); - * MODULE_SCOPE void TclDecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr)); - * - * These macros are defined in terms of two macros that depend on - * memory allocator in use: TclAllocObjStorage, TclFreeObjStorage. - * They are defined below. + * TclDecrRefCount(objPtr) decrements the object's reference count, and frees + * the object if its reference count is zero. These macros are inline versions + * of Tcl_NewObj() and Tcl_DecrRefCount(). Notice that the names differ in not + * having a "_" after the "Tcl". Notice also that these macros reference their + * argument more than once, so you should avoid calling them with an + * expression that is expensive to compute or has side effects. The ANSI C + * "prototypes" for these macros are: + * + * MODULE_SCOPE void TclNewObj(Tcl_Obj *objPtr); + * MODULE_SCOPE void TclDecrRefCount(Tcl_Obj *objPtr); + * + * These macros are defined in terms of two macros that depend on memory + * allocator in use: TclAllocObjStorage, TclFreeObjStorage. They are defined + * below. *---------------------------------------------------------------- */ #ifdef TCL_COMPILE_STATS # define TclIncrObjsAllocated() \ @@ -2392,80 +2624,10 @@ #else # define TclIncrObjsAllocated() # define TclIncrObjsFreed() #endif /* TCL_COMPILE_STATS */ -/* - * All context references used in the object freeing code are pointers - * to this structure; every thread will have its own structure - * instance. The purpose of this structure is to allow deeply nested - * collections of Tcl_Objs to be freed without taking a vast depth of - * C stack (which could cause all sorts of breakage.) - */ - -typedef struct PendingObjData { - int deletionCount; /* Count of the number of invokations of - * TclFreeObj() are on the stack (at least - * conceptually; many are actually expanded - * macros). */ - Tcl_Obj *deletionStack; /* Stack of objects that have had TclFreeObj() - * invoked upon them but which can't be deleted - * yet because they are in a nested invokation - * of TclFreeObj(). By postponing this way, we - * limit the maximum overall C stack depth when - * deleting a complex object. The down-side is - * that we alter the overall behaviour by - * altering the order in which objects are - * deleted, and we change the order in which - * the string rep and the internal rep of an - * object are deleted. Note that code which - * assumes the previous behaviour in either of - * these respects is unsafe anyway; it was - * never documented as to exactly what would - * happen in these cases, and the overall - * contract of a user-level Tcl_DecrRefCount() - * is still preserved (assuming that a - * particular T_DRC would delete an object is - * not very safe). */ -} PendingObjData; - -/* - * These are separated out so that some semantic content is attached - * to them. - */ -#define TclObjDeletionLock(contextPtr) (contextPtr)->deletionCount++ -#define TclObjDeletionUnlock(contextPtr) (contextPtr)->deletionCount-- -#define TclObjDeletePending(contextPtr) (contextPtr)->deletionCount > 0 -#define TclObjOnStack(contextPtr) (contextPtr)->deletionStack != NULL -#define TclPushObjToDelete(contextPtr,objPtr) \ - /* Invalidate the string rep first so we can use the bytes value \ - * for our pointer chain. */ \ - if (((objPtr)->bytes != NULL) \ - && ((objPtr)->bytes != tclEmptyStringRep)) { \ - ckfree((char *) (objPtr)->bytes); \ - } \ - /* Now push onto the head of the stack. */ \ - (objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \ - (contextPtr)->deletionStack = (objPtr) -#define TclPopObjToDelete(contextPtr,objPtrVar) \ - (objPtrVar) = (contextPtr)->deletionStack; \ - (contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes - -/* - * Macro to set up the local reference to the deletion context. - */ -#ifndef TCL_THREADS -MODULE_SCOPE PendingObjData tclPendingObjData; -#define TclObjInitDeletionContext(contextPtr) \ - PendingObjData *CONST contextPtr = &tclPendingObjData -#else -MODULE_SCOPE Tcl_ThreadDataKey tclPendingObjDataKey; -#define TclObjInitDeletionContext(contextPtr) \ - PendingObjData *CONST contextPtr = (PendingObjData *) \ - Tcl_GetThreadData(&tclPendingObjDataKey, sizeof(PendingObjData)) -#endif - #ifndef TCL_MEM_DEBUG # define TclNewObj(objPtr) \ TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ (objPtr)->refCount = 0; \ @@ -2473,63 +2635,29 @@ (objPtr)->length = 0; \ (objPtr)->typePtr = NULL # define TclDecrRefCount(objPtr) \ if (--(objPtr)->refCount <= 0) { \ - TclObjInitDeletionContext(contextPtr); \ - if (TclObjDeletePending(contextPtr)) { \ - TclPushObjToDelete(contextPtr,objPtr); \ - } else { \ - TclFreeObjMacro(contextPtr,objPtr); \ - } \ - } - -/* - * Note that the contents of the while loop assume that the string rep - * has already been freed and we don't want to do anything fancy with - * adding to the queue inside ourselves. Must take care to unstack the - * object first since freeing the internal rep can add further objects - * to the stack. The code assumes that it is the first thing in a - * block; all current usages in the core satisfy this. - * - * Optimization opportunity: Allocate the context once in a large - * function (e.g. TclExecuteByteCode) and use it directly instead of - * looking it up each time. - */ -#define TclFreeObjMacro(contextPtr,objPtr) \ - if (((objPtr)->typePtr != NULL) \ - && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \ - TclObjDeletionLock(contextPtr); \ - (objPtr)->typePtr->freeIntRepProc(objPtr); \ - TclObjDeletionUnlock(contextPtr); \ - } \ - if (((objPtr)->bytes != NULL) \ - && ((objPtr)->bytes != tclEmptyStringRep)) { \ - ckfree((char *) (objPtr)->bytes); \ - } \ - TclFreeObjStorage(objPtr); \ - TclIncrObjsFreed(); \ - TclObjDeletionLock(contextPtr); \ - while (TclObjOnStack(contextPtr)) { \ - Tcl_Obj *objToFree; \ - TclPopObjToDelete(contextPtr,objToFree); \ - if ((objToFree->typePtr != NULL) \ - && (objToFree->typePtr->freeIntRepProc != NULL)) { \ - objToFree->typePtr->freeIntRepProc(objToFree); \ - } \ - TclFreeObjStorage(objToFree); \ - TclIncrObjsFreed(); \ - } \ - TclObjDeletionUnlock(contextPtr) + if ((objPtr)->typePtr && (objPtr)->typePtr->freeIntRepProc) { \ + TclFreeObj(objPtr); \ + } else { \ + if ((objPtr)->bytes \ + && ((objPtr)->bytes != tclEmptyStringRep)) { \ + ckfree((char *) (objPtr)->bytes); \ + } \ + TclFreeObjStorage(objPtr); \ + TclIncrObjsFreed(); \ + } \ + } #if defined(PURIFY) /* * The PURIFY mode is like the regular mode, but instead of doing block * Tcl_Obj allocation and keeping a freed list for efficiency, it always - * allocates and frees a single Tcl_Obj so that tools like Purify can - * better track memory leaks + * allocates and frees a single Tcl_Obj so that tools like Purify can better + * track memory leaks */ # define TclAllocObjStorage(objPtr) \ (objPtr) = (Tcl_Obj *) Tcl_Alloc(sizeof(Tcl_Obj)) @@ -2537,21 +2665,23 @@ ckfree((char *) (objPtr)) #elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) /* - * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's - * from per-thread caches. + * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's from + * per-thread caches. */ -MODULE_SCOPE Tcl_Obj * TclThreadAllocObj _ANSI_ARGS_((void)); -MODULE_SCOPE void TclThreadFreeObj _ANSI_ARGS_((Tcl_Obj *)); -MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex _ANSI_ARGS_((void)); -MODULE_SCOPE void * TclpGetAllocCache _ANSI_ARGS_((void)); -MODULE_SCOPE void TclpSetAllocCache _ANSI_ARGS_((void *)); -MODULE_SCOPE void TclFinalizeThreadAlloc _ANSI_ARGS_((void)); -MODULE_SCOPE void TclpFreeAllocMutex _ANSI_ARGS_((Tcl_Mutex* mutex)); +MODULE_SCOPE Tcl_Obj * TclThreadAllocObj(void); +MODULE_SCOPE void TclThreadFreeObj(Tcl_Obj *); +MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void); +MODULE_SCOPE void TclFreeAllocCache(void *); +MODULE_SCOPE void * TclpGetAllocCache(void); +MODULE_SCOPE void TclpSetAllocCache(void *); +MODULE_SCOPE void TclFinalizeThreadAlloc(void); +MODULE_SCOPE void TclpFreeAllocMutex(Tcl_Mutex* mutex); +MODULE_SCOPE void TclpFreeAllocCache(void *); # define TclAllocObjStorage(objPtr) \ (objPtr) = TclThreadAllocObj() # define TclFreeObjStorage(objPtr) \ @@ -2580,11 +2710,11 @@ tclFreeObjList = (objPtr); \ Tcl_MutexUnlock(&tclObjMutex) #endif #else /* TCL_MEM_DEBUG */ -MODULE_SCOPE void TclDbInitNewObj _ANSI_ARGS_((Tcl_Obj *objPtr)); +MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr); # define TclDbNewObj(objPtr, file, line) \ TclIncrObjsAllocated(); \ (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \ TclDbInitNewObj(objPtr); @@ -2601,19 +2731,20 @@ #undef USE_THREAD_ALLOC #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------- - * Macro used by the Tcl core to set a Tcl_Obj's string representation - * to a copy of the "len" bytes starting at "bytePtr". This code - * works even if the byte array contains NULLs as long as the length - * is correct. Because "len" is referenced multiple times, it should - * be as simple an expression as possible. The ANSI C "prototype" for - * this macro is: - * - * MODULE_SCOPE void TclInitStringRep _ANSI_ARGS_(( - * Tcl_Obj *objPtr, char *bytePtr, int len)); + * Macro used by the Tcl core to set a Tcl_Obj's string representation to a + * copy of the "len" bytes starting at "bytePtr". This code works even if the + * byte array contains NULLs as long as the length is correct. Because "len" + * is referenced multiple times, it should be as simple an expression as + * possible. The ANSI C "prototype" for this macro is: + * + * MODULE_SCOPE void TclInitStringRep(Tcl_Obj *objPtr, char *bytePtr, int len); + * + * This macro should only be called on an unshared objPtr where + * objPtr->typePtr->freeIntRepProc == NULL *---------------------------------------------------------------- */ #define TclInitStringRep(objPtr, bytePtr, len) \ if ((len) == 0) { \ @@ -2627,31 +2758,30 @@ (objPtr)->length = (len); \ } /* *---------------------------------------------------------------- - * Macro used by the Tcl core to get the string representation's - * byte array pointer from a Tcl_Obj. This is an inline version - * of Tcl_GetString(). The macro's expression result is the string - * rep's byte pointer which might be NULL. The bytes referenced by - * this pointer must not be modified by the caller. - * The ANSI C "prototype" for this macro is: - * - * MODULE_SCOPE char * TclGetString _ANSI_ARGS_((Tcl_Obj *objPtr)); + * Macro used by the Tcl core to get the string representation's byte array + * pointer from a Tcl_Obj. This is an inline version of Tcl_GetString(). The + * macro's expression result is the string rep's byte pointer which might be + * NULL. The bytes referenced by this pointer must not be modified by the + * caller. The ANSI C "prototype" for this macro is: + * + * MODULE_SCOPE char * TclGetString(Tcl_Obj *objPtr); *---------------------------------------------------------------- */ #define TclGetString(objPtr) \ ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString((objPtr))) /* *---------------------------------------------------------------- * Macro used by the Tcl core to clean out an object's internal - * representation. Does not actually reset the rep's bytes. - * The ANSI C "prototype" for this macro is: + * representation. Does not actually reset the rep's bytes. The ANSI C + * "prototype" for this macro is: * - * MODULE_SCOPE void TclFreeIntRep _ANSI_ARGS_((Tcl_Obj *objPtr)); + * MODULE_SCOPE void TclFreeIntRep(Tcl_Obj *objPtr); *---------------------------------------------------------------- */ #define TclFreeIntRep(objPtr) \ if ((objPtr)->typePtr != NULL && \ @@ -2659,39 +2789,51 @@ (objPtr)->typePtr->freeIntRepProc(objPtr); \ } /* *---------------------------------------------------------------- - * 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. + * Macro used by the Tcl core to clean out an object's string representation. + * The ANSI C "prototype" for this macro is: + * + * MODULE_SCOPE void TclInvalidateStringRep(Tcl_Obj *objPtr); + *---------------------------------------------------------------- + */ + +#define TclInvalidateStringRep(objPtr) \ + if (objPtr->bytes != NULL) { \ + if (objPtr->bytes != tclEmptyStringRep) {\ + ckfree((char *) objPtr->bytes);\ + }\ + objPtr->bytes = NULL;\ + }\ + + +#if 0 +/* + *---------------------------------------------------------------- + * Macro used by the Tcl core to get a Tcl_WideInt value out of a Tcl_Obj of + * 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 /* *---------------------------------------------------------------- - * Macro used by the Tcl core get a unicode char from a utf string. - * It checks to see if we have a one-byte utf char before calling - * the real Tcl_UtfToUniChar, as this will save a lot of time for - * primarily ascii string handling. The macro's expression result - * is 1 for the 1-byte case or the result of Tcl_UtfToUniChar. - * The ANSI C "prototype" for this macro is: - * - * MODULE_SCOPE int TclUtfToUniChar _ANSI_ARGS_(( - * CONST char *string, Tcl_UniChar *ch)); + * Macro used by the Tcl core get a unicode char from a utf string. It checks + * to see if we have a one-byte utf char before calling the real + * Tcl_UtfToUniChar, as this will save a lot of time for primarily ascii + * string handling. The macro's expression result is 1 for the 1-byte case or + * the result of Tcl_UtfToUniChar. The ANSI C "prototype" for this macro is: + * + * MODULE_SCOPE int TclUtfToUniChar(CONST char *string, Tcl_UniChar *ch); *---------------------------------------------------------------- */ #define TclUtfToUniChar(str, chPtr) \ ((((unsigned char) *(str)) < 0xC0) ? \ @@ -2698,18 +2840,17 @@ ((*(chPtr) = (Tcl_UniChar) *(str)), 1) \ : Tcl_UtfToUniChar(str, chPtr)) /* *---------------------------------------------------------------- - * Macro used by the Tcl core to compare Unicode strings. On - * big-endian systems we can use the more efficient memcmp, but - * this would not be lexically correct on little-endian systems. - * The ANSI C "prototype" for this macro is: - * - * MODULE_SCOPE int TclUniCharNcmp _ANSI_ARGS_(( - * CONST Tcl_UniChar *cs, - * CONST Tcl_UniChar *ct, unsigned long n)); + * Macro used by the Tcl core to compare Unicode strings. On big-endian + * systems we can use the more efficient memcmp, but this would not be + * lexically correct on little-endian systems. The ANSI C "prototype" for + * this macro is: + * + * MODULE_SCOPE int TclUniCharNcmp(CONST Tcl_UniChar *cs, + * CONST Tcl_UniChar *ct, unsigned long n); *---------------------------------------------------------------- */ #ifdef WORDS_BIGENDIAN # define TclUniCharNcmp(cs,ct,n) memcmp((cs),(ct),(n)*sizeof(Tcl_UniChar)) @@ -2717,25 +2858,198 @@ # define TclUniCharNcmp Tcl_UniCharNcmp #endif /* WORDS_BIGENDIAN */ /* *---------------------------------------------------------------- - * Macro used by the Tcl core to increment a namespace's export - * export epoch counter. - * The ANSI C "prototype" for this macro is: + * Macro used by the Tcl core to increment a namespace's export export epoch + * counter. The ANSI C "prototype" for this macro is: * - * MODULE_SCOPE void TclInvalidateNsCmdLookup _ANSI_ARGS_(( - * Namespace *nsPtr)); + * MODULE_SCOPE void TclInvalidateNsCmdLookup(Namespace *nsPtr); *---------------------------------------------------------------- */ #define TclInvalidateNsCmdLookup(nsPtr) \ if ((nsPtr)->numExportPatterns) { \ (nsPtr)->exportLookupEpoch++; \ } +/* + *---------------------------------------------------------------------- + * + * Core procedures added to libtommath for bignum manipulation. + * + *---------------------------------------------------------------------- + */ + +MODULE_SCOPE void * TclBNAlloc(size_t nBytes); +MODULE_SCOPE void * TclBNRealloc(void *oldBlock, size_t newNBytes); +MODULE_SCOPE void TclBNFree(void *block); +MODULE_SCOPE void TclBNInitBignumFromLong(mp_int *bignum, long initVal); +MODULE_SCOPE void TclBNInitBignumFromWideInt(mp_int* bignum, + Tcl_WideInt initVal); +MODULE_SCOPE void TclBNInitBignumFromWideUInt(mp_int* bignum, + Tcl_WideUInt initVal); + +/* + *---------------------------------------------------------------- + * Macro used by the Tcl core to check whether a pattern has any characters + * special to [string match]. The ANSI C "prototype" for this macro is: + * + * MODULE_SCOPE int TclMatchIsTrivial(CONST char *pattern); + *---------------------------------------------------------------- + */ + +#define TclMatchIsTrivial(pattern) strpbrk((pattern), "*[]]?\\") == NULL + +/* + *---------------------------------------------------------------- + * Macro used by the Tcl core to write the string rep of a long integer to a + * character buffer. The ANSI C "prototype" for this macro is: + * + * MODULE_SCOPE int TclFormatInt(char *buf, long n); + *---------------------------------------------------------------- + */ + +#define TclFormatInt(buf, n) sprintf((buf), "%ld", (long)(n)) + +/* + *---------------------------------------------------------------- + * Macros used by the Tcl core to set a Tcl_Obj's numeric representation + * avoiding the corresponding function calls in time critical parts of the + * core. They should only be called on unshared objects. The ANSI C + * "prototypes" for these macros are: + * + * MODULE_SCOPE void TclSetIntObj(Tcl_Obj *objPtr, int intValue); + * MODULE_SCOPE void TclSetLongObj(Tcl_Obj *objPtr, long longValue); + * MODULE_SCOPE void TclSetBooleanObj(Tcl_Obj *objPtr, long boolValue); + * MODULE_SCOPE void TclSetWideIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); + * MODULE_SCOPE void TclSetDoubleObj(Tcl_Obj *objPtr, double d); + *---------------------------------------------------------------- + */ + +#define TclSetIntObj(objPtr, i) \ + TclInvalidateStringRep(objPtr);\ + TclFreeIntRep(objPtr); \ + (objPtr)->internalRep.longValue = (long)(i); \ + (objPtr)->typePtr = &tclIntType + +#define TclSetLongObj(objPtr, l) \ + TclSetIntObj((objPtr), (l)) + +/* + * NOTE: There is to be no such thing as a "pure" boolean. Boolean values set + * programmatically go straight to being "int" Tcl_Obj's, with value 0 or 1. + * The only "boolean" Tcl_Obj's shall be those holding the cached boolean + * value of strings like: "yes", "no", "true", "false", "on", "off". + */ + +#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);\ + TclFreeIntRep(objPtr); \ + (objPtr)->internalRep.doubleValue = (double)(d); \ + (objPtr)->typePtr = &tclDoubleType + +/* + *---------------------------------------------------------------- + * Macros used by the Tcl core to create and initialise objects of standard + * types, avoiding the corresponding function calls in time critical parts of + * the core. The ANSI C "prototypes" for these macros are: + * + * MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, int i); + * MODULE_SCOPE void TclNewLongObj(Tcl_Obj *objPtr, long l); + * MODULE_SCOPE void TclNewBooleanObj(Tcl_Obj *objPtr, int b); + * MODULE_SCOPE void TclNewWideObj(Tcl_Obj *objPtr, Tcl_WideInt w); + * MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d); + * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, char *s, int len); + * + *---------------------------------------------------------------- + */ + +#ifndef TCL_MEM_DEBUG +#define TclNewIntObj(objPtr, i) \ + TclIncrObjsAllocated(); \ + TclAllocObjStorage(objPtr); \ + (objPtr)->refCount = 0; \ + (objPtr)->bytes = NULL; \ + (objPtr)->internalRep.longValue = (long)(i); \ + (objPtr)->typePtr = &tclIntType + +#define TclNewLongObj(objPtr, l) \ + TclNewIntObj((objPtr), (l)) + +/* + * NOTE: There is to be no such thing as a "pure" boolean. + * See comment above TclSetBooleanObj macro above. + */ +#define TclNewBooleanObj(objPtr, b) \ + TclNewIntObj((objPtr), ((b)? 1 : 0)) + +#define TclNewDoubleObj(objPtr, d) \ + TclIncrObjsAllocated(); \ + TclAllocObjStorage(objPtr); \ + (objPtr)->refCount = 0; \ + (objPtr)->bytes = NULL; \ + (objPtr)->internalRep.doubleValue = (double)(d); \ + (objPtr)->typePtr = &tclDoubleType + +#define TclNewStringObj(objPtr, s, len) \ + TclNewObj(objPtr); \ + TclInitStringRep((objPtr), (s), (len)) + +#else /* TCL_MEM_DEBUG */ +#define TclNewIntObj(objPtr, i) \ + (objPtr) = Tcl_NewIntObj(i) + +#define TclNewLongObj(objPtr, l) \ + (objPtr) = Tcl_NewLongObj(l) + +#define TclNewBooleanObj(objPtr, b) \ + (objPtr) = Tcl_NewBooleanObj(b) + +#define TclNewDoubleObj(objPtr, d) \ + (objPtr) = Tcl_NewDoubleObj(d) + +#define TclNewStringObj(objPtr, s, len) \ + (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" #endif /* _TCLINT */ - + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclIntDecls.h ================================================================== --- generic/tclIntDecls.h +++ generic/tclIntDecls.h @@ -9,11 +9,15 @@ * Copyright (c) 1998-1999 by Scriptics Corporation. * * 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.75 2004/12/01 23:18:52 dgp Exp $ +<<<<<<< tclIntDecls.h + * RCS: @(#) $Id: tclIntDecls.h,v 1.75.2.12 2005/08/23 06:15:21 dgp Exp $ +======= + * RCS: @(#) $Id: tclIntDecls.h,v 1.75.2.12 2005/08/23 06:15:21 dgp Exp $ +>>>>>>> 1.83 */ #ifndef _TCLINTDECLS #define _TCLINTDECLS @@ -168,15 +172,11 @@ #define TclFindProc_TCL_DECLARED /* 23 */ EXTERN Proc * TclFindProc _ANSI_ARGS_((Interp * iPtr, CONST char * procName)); #endif -#ifndef TclFormatInt_TCL_DECLARED -#define TclFormatInt_TCL_DECLARED -/* 24 */ -EXTERN int TclFormatInt _ANSI_ARGS_((char * buffer, long n)); -#endif +/* Slot 24 is reserved */ #ifndef TclFreePackageInfo_TCL_DECLARED #define TclFreePackageInfo_TCL_DECLARED /* 25 */ EXTERN void TclFreePackageInfo _ANSI_ARGS_((Interp * iPtr)); #endif @@ -273,17 +273,11 @@ /* 46 */ 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 */ EXTERN void TclInitCompiledLocals _ANSI_ARGS_(( Tcl_Interp * interp, CallFrame * framePtr, @@ -686,16 +680,11 @@ /* 138 */ 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 */ EXTERN CONST84_RETURN char * TclpGetCwd _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); @@ -874,18 +863,11 @@ EXTERN int TclUniCharMatch _ANSI_ARGS_(( CONST Tcl_UniChar * string, int strLen, 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 */ EXTERN int TclCallVarTraces _ANSI_ARGS_((Interp * iPtr, Var * arrayPtr, Var * varPtr, @@ -915,22 +897,12 @@ #define Tcl_GetStartupScript_TCL_DECLARED /* 179 */ EXTERN Tcl_Obj * Tcl_GetStartupScript _ANSI_ARGS_(( CONST char ** encodingNamePtr)); #endif -#ifndef TclNewListObjDirect_TCL_DECLARED -#define TclNewListObjDirect_TCL_DECLARED -/* 180 */ -EXTERN Tcl_Obj * TclNewListObjDirect _ANSI_ARGS_((int objc, - Tcl_Obj ** objv)); -#endif -#ifndef TclDbNewListObjDirect_TCL_DECLARED -#define TclDbNewListObjDirect_TCL_DECLARED -/* 181 */ -EXTERN Tcl_Obj * TclDbNewListObjDirect _ANSI_ARGS_((int objc, - Tcl_Obj ** objv, CONST char * file, int line)); -#endif +/* Slot 180 is reserved */ +/* Slot 181 is reserved */ #ifndef TclpLocaltime_TCL_DECLARED #define TclpLocaltime_TCL_DECLARED /* 182 */ EXTERN struct tm * TclpLocaltime _ANSI_ARGS_((CONST time_t * clock)); #endif @@ -937,84 +909,23 @@ #ifndef TclpGmtime_TCL_DECLARED #define TclpGmtime_TCL_DECLARED /* 183 */ EXTERN struct tm * TclpGmtime _ANSI_ARGS_((CONST time_t * clock)); #endif -#ifndef TclThreadStorageLockInit_TCL_DECLARED -#define TclThreadStorageLockInit_TCL_DECLARED -/* 184 */ -EXTERN void TclThreadStorageLockInit _ANSI_ARGS_((void)); -#endif -#ifndef TclThreadStorageLock_TCL_DECLARED -#define TclThreadStorageLock_TCL_DECLARED -/* 185 */ -EXTERN void TclThreadStorageLock _ANSI_ARGS_((void)); -#endif -#ifndef TclThreadStorageUnlock_TCL_DECLARED -#define TclThreadStorageUnlock_TCL_DECLARED -/* 186 */ -EXTERN void TclThreadStorageUnlock _ANSI_ARGS_((void)); -#endif -#ifndef TclThreadStoragePrint_TCL_DECLARED -#define TclThreadStoragePrint_TCL_DECLARED -/* 187 */ -EXTERN void TclThreadStoragePrint _ANSI_ARGS_((FILE * outFile, - int flags)); -#endif -#ifndef TclThreadStorageGetHashTable_TCL_DECLARED -#define TclThreadStorageGetHashTable_TCL_DECLARED -/* 188 */ -EXTERN Tcl_HashTable * TclThreadStorageGetHashTable _ANSI_ARGS_(( - Tcl_ThreadId id)); -#endif -#ifndef TclThreadStorageInit_TCL_DECLARED -#define TclThreadStorageInit_TCL_DECLARED -/* 189 */ -EXTERN Tcl_HashTable * TclThreadStorageInit _ANSI_ARGS_((Tcl_ThreadId id, - void * reserved)); -#endif -#ifndef TclThreadStorageDataKeyInit_TCL_DECLARED -#define TclThreadStorageDataKeyInit_TCL_DECLARED -/* 190 */ -EXTERN void TclThreadStorageDataKeyInit _ANSI_ARGS_(( - Tcl_ThreadDataKey * keyPtr)); -#endif -#ifndef TclThreadStorageDataKeyGet_TCL_DECLARED -#define TclThreadStorageDataKeyGet_TCL_DECLARED -/* 191 */ -EXTERN void * TclThreadStorageDataKeyGet _ANSI_ARGS_(( - Tcl_ThreadDataKey * keyPtr)); -#endif -#ifndef TclThreadStorageDataKeySet_TCL_DECLARED -#define TclThreadStorageDataKeySet_TCL_DECLARED -/* 192 */ -EXTERN void TclThreadStorageDataKeySet _ANSI_ARGS_(( - Tcl_ThreadDataKey * keyPtr, void * data)); -#endif -#ifndef TclFinalizeThreadStorageThread_TCL_DECLARED -#define TclFinalizeThreadStorageThread_TCL_DECLARED -/* 193 */ -EXTERN void TclFinalizeThreadStorageThread _ANSI_ARGS_(( - Tcl_ThreadId id)); -#endif -#ifndef TclFinalizeThreadStorage_TCL_DECLARED -#define TclFinalizeThreadStorage_TCL_DECLARED -/* 194 */ -EXTERN void TclFinalizeThreadStorage _ANSI_ARGS_((void)); -#endif -#ifndef TclFinalizeThreadStorageData_TCL_DECLARED -#define TclFinalizeThreadStorageData_TCL_DECLARED -/* 195 */ -EXTERN void TclFinalizeThreadStorageData _ANSI_ARGS_(( - Tcl_ThreadDataKey * keyPtr)); -#endif -#ifndef TclFinalizeThreadStorageDataKey_TCL_DECLARED -#define TclFinalizeThreadStorageDataKey_TCL_DECLARED -/* 196 */ -EXTERN void TclFinalizeThreadStorageDataKey _ANSI_ARGS_(( - Tcl_ThreadDataKey * keyPtr)); -#endif +/* Slot 184 is reserved */ +/* Slot 185 is reserved */ +/* Slot 186 is reserved */ +/* Slot 187 is reserved */ +/* Slot 188 is reserved */ +/* Slot 189 is reserved */ +/* Slot 190 is reserved */ +/* Slot 191 is reserved */ +/* Slot 192 is reserved */ +/* Slot 193 is reserved */ +/* Slot 194 is reserved */ +/* Slot 195 is reserved */ +/* Slot 196 is reserved */ #ifndef TclCompEvalObj_TCL_DECLARED #define TclCompEvalObj_TCL_DECLARED /* 197 */ EXTERN int TclCompEvalObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); @@ -1023,15 +934,11 @@ #define TclObjGetFrame_TCL_DECLARED /* 198 */ EXTERN int TclObjGetFrame _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CallFrame ** framePtrPtr)); #endif -#ifndef TclMatchIsTrivial_TCL_DECLARED -#define TclMatchIsTrivial_TCL_DECLARED -/* 199 */ -EXTERN int TclMatchIsTrivial _ANSI_ARGS_((CONST char * pattern)); -#endif +/* Slot 199 is reserved */ #ifndef TclpObjRemoveDirectory_TCL_DECLARED #define TclpObjRemoveDirectory_TCL_DECLARED /* 200 */ EXTERN int TclpObjRemoveDirectory _ANSI_ARGS_(( Tcl_Obj * pathPtr, int recursive, @@ -1116,10 +1023,74 @@ #define TclSetObjNameOfExecutable_TCL_DECLARED /* 214 */ EXTERN void TclSetObjNameOfExecutable _ANSI_ARGS_(( Tcl_Obj * name, Tcl_Encoding encoding)); #endif +#ifndef TclStackAlloc_TCL_DECLARED +#define TclStackAlloc_TCL_DECLARED +/* 215 */ +EXTERN char * TclStackAlloc _ANSI_ARGS_((Tcl_Interp * interp, + int numBytes)); +#endif +#ifndef TclStackFree_TCL_DECLARED +#define TclStackFree_TCL_DECLARED +/* 216 */ +EXTERN void TclStackFree _ANSI_ARGS_((Tcl_Interp * interp)); +#endif +#ifndef TclPushStackFrame_TCL_DECLARED +#define TclPushStackFrame_TCL_DECLARED +/* 217 */ +EXTERN int TclPushStackFrame _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_CallFrame ** framePtrPtr, + Tcl_Namespace * namespacePtr, + int isProcCallFrame)); +#endif +#ifndef TclPopStackFrame_TCL_DECLARED +#define TclPopStackFrame_TCL_DECLARED +/* 218 */ +EXTERN void TclPopStackFrame _ANSI_ARGS_((Tcl_Interp * interp)); +#endif +#ifndef TclBN_mp_div_d_TCL_DECLARED +#define TclBN_mp_div_d_TCL_DECLARED +/* 219 */ +EXTERN int TclBN_mp_div_d _ANSI_ARGS_((mp_int * a, mp_digit b, + mp_int * c, mp_digit * d)); +#endif +#ifndef TclBN_mp_mul_d_TCL_DECLARED +#define TclBN_mp_mul_d_TCL_DECLARED +/* 220 */ +EXTERN int TclBN_mp_mul_d _ANSI_ARGS_((mp_int * a, mp_digit b, + mp_int * c)); +#endif +#ifndef TclBN_mp_clear_TCL_DECLARED +#define TclBN_mp_clear_TCL_DECLARED +/* 221 */ +EXTERN void TclBN_mp_clear _ANSI_ARGS_((mp_int * a)); +#endif +#ifndef TclBN_mp_init_TCL_DECLARED +#define TclBN_mp_init_TCL_DECLARED +/* 222 */ +EXTERN int TclBN_mp_init _ANSI_ARGS_((mp_int * a)); +#endif +#ifndef TclBN_mp_read_radix_TCL_DECLARED +#define TclBN_mp_read_radix_TCL_DECLARED +/* 223 */ +EXTERN int TclBN_mp_read_radix _ANSI_ARGS_((mp_int * a, + const char * str, int radix)); +#endif +#ifndef TclGetPlatform_TCL_DECLARED +#define TclGetPlatform_TCL_DECLARED +/* 224 */ +EXTERN TclPlatformType * TclGetPlatform _ANSI_ARGS_((void)); +#endif +#ifndef TclTraceDictPath_TCL_DECLARED +#define TclTraceDictPath_TCL_DECLARED +/* 225 */ +EXTERN Tcl_Obj * TclTraceDictPath _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_Obj * rootPtr, int keyc, + Tcl_Obj *CONST keyv[], int flags)); +#endif typedef struct TclIntStubs { int magic; struct TclIntStubHooks *hooks; @@ -1155,11 +1126,11 @@ void *reserved19; void *reserved20; void *reserved21; int (*tclFindElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int listLength, CONST char ** elementPtr, CONST char ** nextPtr, int * sizePtr, int * bracePtr)); /* 22 */ Proc * (*tclFindProc) _ANSI_ARGS_((Interp * iPtr, CONST char * procName)); /* 23 */ - int (*tclFormatInt) _ANSI_ARGS_((char * buffer, long n)); /* 24 */ + void *reserved24; void (*tclFreePackageInfo) _ANSI_ARGS_((Interp * iPtr)); /* 25 */ void *reserved26; void *reserved27; Tcl_Channel (*tclpGetDefaultStdChannel) _ANSI_ARGS_((int type)); /* 28 */ void *reserved29; @@ -1180,11 +1151,11 @@ int (*tclGuessPackageName) _ANSI_ARGS_((CONST char * fileName, Tcl_DString * bufPtr)); /* 44 */ int (*tclHideUnsafeCommands) _ANSI_ARGS_((Tcl_Interp * interp)); /* 45 */ 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; int (*tclInvokeObjectCommand) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, CONST84 char ** argv)); /* 53 */ int (*tclInvokeStringCommand) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 54 */ @@ -1276,11 +1247,11 @@ void *reserved135; void *reserved136; 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 */ void (*tclHideLiteral) _ANSI_ARGS_((Tcl_Interp * interp, struct CompileEnv * envPtr, int index)); /* 144 */ struct AuxDataType * (*tclGetAuxDataType) _ANSI_ARGS_((char * typeName)); /* 145 */ @@ -1310,36 +1281,36 @@ int (*tclpUtfNcmp2) _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); /* 169 */ int (*tclCheckInterpTraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 170 */ 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 */ void (*tcl_SetStartupScript) _ANSI_ARGS_((Tcl_Obj * pathPtr, CONST char* encodingName)); /* 178 */ Tcl_Obj * (*tcl_GetStartupScript) _ANSI_ARGS_((CONST char ** encodingNamePtr)); /* 179 */ - Tcl_Obj * (*tclNewListObjDirect) _ANSI_ARGS_((int objc, Tcl_Obj ** objv)); /* 180 */ - Tcl_Obj * (*tclDbNewListObjDirect) _ANSI_ARGS_((int objc, Tcl_Obj ** objv, CONST char * file, int line)); /* 181 */ + void *reserved180; + void *reserved181; struct tm * (*tclpLocaltime) _ANSI_ARGS_((CONST time_t * clock)); /* 182 */ struct tm * (*tclpGmtime) _ANSI_ARGS_((CONST time_t * clock)); /* 183 */ - void (*tclThreadStorageLockInit) _ANSI_ARGS_((void)); /* 184 */ - void (*tclThreadStorageLock) _ANSI_ARGS_((void)); /* 185 */ - void (*tclThreadStorageUnlock) _ANSI_ARGS_((void)); /* 186 */ - void (*tclThreadStoragePrint) _ANSI_ARGS_((FILE * outFile, int flags)); /* 187 */ - Tcl_HashTable * (*tclThreadStorageGetHashTable) _ANSI_ARGS_((Tcl_ThreadId id)); /* 188 */ - Tcl_HashTable * (*tclThreadStorageInit) _ANSI_ARGS_((Tcl_ThreadId id, void * reserved)); /* 189 */ - void (*tclThreadStorageDataKeyInit) _ANSI_ARGS_((Tcl_ThreadDataKey * keyPtr)); /* 190 */ - void * (*tclThreadStorageDataKeyGet) _ANSI_ARGS_((Tcl_ThreadDataKey * keyPtr)); /* 191 */ - void (*tclThreadStorageDataKeySet) _ANSI_ARGS_((Tcl_ThreadDataKey * keyPtr, void * data)); /* 192 */ - void (*tclFinalizeThreadStorageThread) _ANSI_ARGS_((Tcl_ThreadId id)); /* 193 */ - void (*tclFinalizeThreadStorage) _ANSI_ARGS_((void)); /* 194 */ - void (*tclFinalizeThreadStorageData) _ANSI_ARGS_((Tcl_ThreadDataKey * keyPtr)); /* 195 */ - void (*tclFinalizeThreadStorageDataKey) _ANSI_ARGS_((Tcl_ThreadDataKey * keyPtr)); /* 196 */ + void *reserved184; + void *reserved185; + void *reserved186; + void *reserved187; + void *reserved188; + void *reserved189; + void *reserved190; + void *reserved191; + void *reserved192; + void *reserved193; + void *reserved194; + void *reserved195; + void *reserved196; int (*tclCompEvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 197 */ int (*tclObjGetFrame) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CallFrame ** framePtrPtr)); /* 198 */ - int (*tclMatchIsTrivial) _ANSI_ARGS_((CONST char * pattern)); /* 199 */ + void *reserved199; int (*tclpObjRemoveDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr, int recursive, Tcl_Obj ** errorPtr)); /* 200 */ int (*tclpObjCopyDirectory) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr, Tcl_Obj ** errorPtr)); /* 201 */ int (*tclpObjCreateDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 202 */ int (*tclpObjDeleteFile) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 203 */ int (*tclpObjCopyFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 204 */ @@ -1351,10 +1322,21 @@ int (*tclSetEncodingSearchPath) _ANSI_ARGS_((Tcl_Obj * searchPath)); /* 210 */ CONST char * (*tclpGetEncodingNameFromEnvironment) _ANSI_ARGS_((Tcl_DString * bufPtr)); /* 211 */ void (*tclpFindExecutable) _ANSI_ARGS_((CONST char * argv0)); /* 212 */ Tcl_Obj * (*tclGetObjNameOfExecutable) _ANSI_ARGS_((void)); /* 213 */ void (*tclSetObjNameOfExecutable) _ANSI_ARGS_((Tcl_Obj * name, Tcl_Encoding encoding)); /* 214 */ + char * (*tclStackAlloc) _ANSI_ARGS_((Tcl_Interp * interp, int numBytes)); /* 215 */ + void (*tclStackFree) _ANSI_ARGS_((Tcl_Interp * interp)); /* 216 */ + int (*tclPushStackFrame) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_CallFrame ** framePtrPtr, Tcl_Namespace * namespacePtr, int isProcCallFrame)); /* 217 */ + void (*tclPopStackFrame) _ANSI_ARGS_((Tcl_Interp * interp)); /* 218 */ + int (*tclBN_mp_div_d) _ANSI_ARGS_((mp_int * a, mp_digit b, mp_int * c, mp_digit * d)); /* 219 */ + int (*tclBN_mp_mul_d) _ANSI_ARGS_((mp_int * a, mp_digit b, mp_int * c)); /* 220 */ + void (*tclBN_mp_clear) _ANSI_ARGS_((mp_int * a)); /* 221 */ + int (*tclBN_mp_init) _ANSI_ARGS_((mp_int * a)); /* 222 */ + int (*tclBN_mp_read_radix) _ANSI_ARGS_((mp_int * a, const char * str, int radix)); /* 223 */ + TclPlatformType * (*tclGetPlatform) _ANSI_ARGS_((void)); /* 224 */ + Tcl_Obj * (*tclTraceDictPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * rootPtr, int keyc, Tcl_Obj *CONST keyv[], int flags)); /* 225 */ } TclIntStubs; #ifdef __cplusplus extern "C" { #endif @@ -1452,14 +1434,11 @@ #endif #ifndef TclFindProc #define TclFindProc \ (tclIntStubsPtr->tclFindProc) /* 23 */ #endif -#ifndef TclFormatInt -#define TclFormatInt \ - (tclIntStubsPtr->tclFormatInt) /* 24 */ -#endif +/* Slot 24 is reserved */ #ifndef TclFreePackageInfo #define TclFreePackageInfo \ (tclIntStubsPtr->tclFreePackageInfo) /* 25 */ #endif /* Slot 26 is reserved */ @@ -1525,14 +1504,11 @@ #define TclInExit \ (tclIntStubsPtr->tclInExit) /* 46 */ #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 */ #endif #ifndef TclInterpInit @@ -1807,14 +1783,11 @@ #ifndef TclGetEnv #define TclGetEnv \ (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 */ #endif #ifndef TclSetByteCodeFromAny @@ -1934,14 +1907,11 @@ #endif #ifndef TclUniCharMatch #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 */ #endif #ifndef TclCleanupVar @@ -1958,90 +1928,42 @@ #endif #ifndef Tcl_GetStartupScript #define Tcl_GetStartupScript \ (tclIntStubsPtr->tcl_GetStartupScript) /* 179 */ #endif -#ifndef TclNewListObjDirect -#define TclNewListObjDirect \ - (tclIntStubsPtr->tclNewListObjDirect) /* 180 */ -#endif -#ifndef TclDbNewListObjDirect -#define TclDbNewListObjDirect \ - (tclIntStubsPtr->tclDbNewListObjDirect) /* 181 */ -#endif +/* Slot 180 is reserved */ +/* Slot 181 is reserved */ #ifndef TclpLocaltime #define TclpLocaltime \ (tclIntStubsPtr->tclpLocaltime) /* 182 */ #endif #ifndef TclpGmtime #define TclpGmtime \ (tclIntStubsPtr->tclpGmtime) /* 183 */ #endif -#ifndef TclThreadStorageLockInit -#define TclThreadStorageLockInit \ - (tclIntStubsPtr->tclThreadStorageLockInit) /* 184 */ -#endif -#ifndef TclThreadStorageLock -#define TclThreadStorageLock \ - (tclIntStubsPtr->tclThreadStorageLock) /* 185 */ -#endif -#ifndef TclThreadStorageUnlock -#define TclThreadStorageUnlock \ - (tclIntStubsPtr->tclThreadStorageUnlock) /* 186 */ -#endif -#ifndef TclThreadStoragePrint -#define TclThreadStoragePrint \ - (tclIntStubsPtr->tclThreadStoragePrint) /* 187 */ -#endif -#ifndef TclThreadStorageGetHashTable -#define TclThreadStorageGetHashTable \ - (tclIntStubsPtr->tclThreadStorageGetHashTable) /* 188 */ -#endif -#ifndef TclThreadStorageInit -#define TclThreadStorageInit \ - (tclIntStubsPtr->tclThreadStorageInit) /* 189 */ -#endif -#ifndef TclThreadStorageDataKeyInit -#define TclThreadStorageDataKeyInit \ - (tclIntStubsPtr->tclThreadStorageDataKeyInit) /* 190 */ -#endif -#ifndef TclThreadStorageDataKeyGet -#define TclThreadStorageDataKeyGet \ - (tclIntStubsPtr->tclThreadStorageDataKeyGet) /* 191 */ -#endif -#ifndef TclThreadStorageDataKeySet -#define TclThreadStorageDataKeySet \ - (tclIntStubsPtr->tclThreadStorageDataKeySet) /* 192 */ -#endif -#ifndef TclFinalizeThreadStorageThread -#define TclFinalizeThreadStorageThread \ - (tclIntStubsPtr->tclFinalizeThreadStorageThread) /* 193 */ -#endif -#ifndef TclFinalizeThreadStorage -#define TclFinalizeThreadStorage \ - (tclIntStubsPtr->tclFinalizeThreadStorage) /* 194 */ -#endif -#ifndef TclFinalizeThreadStorageData -#define TclFinalizeThreadStorageData \ - (tclIntStubsPtr->tclFinalizeThreadStorageData) /* 195 */ -#endif -#ifndef TclFinalizeThreadStorageDataKey -#define TclFinalizeThreadStorageDataKey \ - (tclIntStubsPtr->tclFinalizeThreadStorageDataKey) /* 196 */ -#endif +/* Slot 184 is reserved */ +/* Slot 185 is reserved */ +/* Slot 186 is reserved */ +/* Slot 187 is reserved */ +/* Slot 188 is reserved */ +/* Slot 189 is reserved */ +/* Slot 190 is reserved */ +/* Slot 191 is reserved */ +/* Slot 192 is reserved */ +/* Slot 193 is reserved */ +/* Slot 194 is reserved */ +/* Slot 195 is reserved */ +/* Slot 196 is reserved */ #ifndef TclCompEvalObj #define TclCompEvalObj \ (tclIntStubsPtr->tclCompEvalObj) /* 197 */ #endif #ifndef TclObjGetFrame #define TclObjGetFrame \ (tclIntStubsPtr->tclObjGetFrame) /* 198 */ #endif -#ifndef TclMatchIsTrivial -#define TclMatchIsTrivial \ - (tclIntStubsPtr->tclMatchIsTrivial) /* 199 */ -#endif +/* Slot 199 is reserved */ #ifndef TclpObjRemoveDirectory #define TclpObjRemoveDirectory \ (tclIntStubsPtr->tclpObjRemoveDirectory) /* 200 */ #endif #ifndef TclpObjCopyDirectory @@ -2098,14 +2020,58 @@ #endif #ifndef TclSetObjNameOfExecutable #define TclSetObjNameOfExecutable \ (tclIntStubsPtr->tclSetObjNameOfExecutable) /* 214 */ #endif +#ifndef TclStackAlloc +#define TclStackAlloc \ + (tclIntStubsPtr->tclStackAlloc) /* 215 */ +#endif +#ifndef TclStackFree +#define TclStackFree \ + (tclIntStubsPtr->tclStackFree) /* 216 */ +#endif +#ifndef TclPushStackFrame +#define TclPushStackFrame \ + (tclIntStubsPtr->tclPushStackFrame) /* 217 */ +#endif +#ifndef TclPopStackFrame +#define TclPopStackFrame \ + (tclIntStubsPtr->tclPopStackFrame) /* 218 */ +#endif +#ifndef TclBN_mp_div_d +#define TclBN_mp_div_d \ + (tclIntStubsPtr->tclBN_mp_div_d) /* 219 */ +#endif +#ifndef TclBN_mp_mul_d +#define TclBN_mp_mul_d \ + (tclIntStubsPtr->tclBN_mp_mul_d) /* 220 */ +#endif +#ifndef TclBN_mp_clear +#define TclBN_mp_clear \ + (tclIntStubsPtr->tclBN_mp_clear) /* 221 */ +#endif +#ifndef TclBN_mp_init +#define TclBN_mp_init \ + (tclIntStubsPtr->tclBN_mp_init) /* 222 */ +#endif +#ifndef TclBN_mp_read_radix +#define TclBN_mp_read_radix \ + (tclIntStubsPtr->tclBN_mp_read_radix) /* 223 */ +#endif +#ifndef TclGetPlatform +#define TclGetPlatform \ + (tclIntStubsPtr->tclGetPlatform) /* 224 */ +#endif +#ifndef TclTraceDictPath +#define TclTraceDictPath \ + (tclIntStubsPtr->tclTraceDictPath) /* 225 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ /* !END!: Do not edit above this line. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLINTDECLS */ Index: generic/tclIntPlatDecls.h ================================================================== --- generic/tclIntPlatDecls.h +++ generic/tclIntPlatDecls.h @@ -7,11 +7,11 @@ * versions. Use at your own risk. * * Copyright (c) 1998-1999 by Scriptics Corporation. * All rights reserved. * - * RCS: @(#) $Id: tclIntPlatDecls.h,v 1.26 2004/11/03 19:13:40 davygrvy Exp $ + * RCS: @(#) $Id: tclIntPlatDecls.h,v 1.26.2.1 2005/05/21 15:10:27 kennykb Exp $ */ #ifndef _TCLINTPLATDECLS #define _TCLINTPLATDECLS @@ -247,15 +247,11 @@ #ifndef TclWinNoBackslash_TCL_DECLARED #define TclWinNoBackslash_TCL_DECLARED /* 24 */ EXTERN char * TclWinNoBackslash _ANSI_ARGS_((char * path)); #endif -#ifndef TclWinGetPlatform_TCL_DECLARED -#define TclWinGetPlatform_TCL_DECLARED -/* 25 */ -EXTERN TclPlatformType * TclWinGetPlatform _ANSI_ARGS_((void)); -#endif +/* Slot 25 is reserved */ #ifndef TclWinSetInterfaces_TCL_DECLARED #define TclWinSetInterfaces_TCL_DECLARED /* 26 */ EXTERN void TclWinSetInterfaces _ANSI_ARGS_((int wide)); #endif @@ -346,11 +342,11 @@ void (*tclWinAddProcess) _ANSI_ARGS_((HANDLE hProcess, DWORD id)); /* 20 */ void *reserved21; TclFile (*tclpCreateTempFile) _ANSI_ARGS_((CONST char * contents)); /* 22 */ char * (*tclpGetTZName) _ANSI_ARGS_((int isdst)); /* 23 */ char * (*tclWinNoBackslash) _ANSI_ARGS_((char * path)); /* 24 */ - TclPlatformType * (*tclWinGetPlatform) _ANSI_ARGS_((void)); /* 25 */ + void *reserved25; void (*tclWinSetInterfaces) _ANSI_ARGS_((int wide)); /* 26 */ void (*tclWinFlushDirtyChannels) _ANSI_ARGS_((void)); /* 27 */ void (*tclWinResetInterfaces) _ANSI_ARGS_((void)); /* 28 */ int (*tclWinCPUID) _ANSI_ARGS_((unsigned int index, unsigned int * regs)); /* 29 */ #endif /* __WIN32__ */ @@ -518,14 +514,11 @@ #endif #ifndef TclWinNoBackslash #define TclWinNoBackslash \ (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ #endif -#ifndef TclWinGetPlatform -#define TclWinGetPlatform \ - (tclIntPlatStubsPtr->tclWinGetPlatform) /* 25 */ -#endif +/* Slot 25 is reserved */ #ifndef TclWinSetInterfaces #define TclWinSetInterfaces \ (tclIntPlatStubsPtr->tclWinSetInterfaces) /* 26 */ #endif #ifndef TclWinFlushDirtyChannels Index: generic/tclInterp.c ================================================================== --- generic/tclInterp.c +++ generic/tclInterp.c @@ -1,95 +1,96 @@ -/* +/* * tclInterp.c -- * - * This file implements the "interp" command which allows creation - * and manipulation of Tcl interpreters from within Tcl scripts. + * This file implements the "interp" command which allows creation and + * manipulation of Tcl interpreters from within Tcl scripts. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 2004 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInterp.c,v 1.54 2004/12/02 15:31:28 dkf Exp $ + * RCS: @(#) $Id: tclInterp.c,v 1.54.2.3 2005/08/02 18:15:58 dgp Exp $ */ #include "tclInt.h" /* * A pointer to a string that holds an initialization script that if non-NULL * is evaluated in Tcl_Init() prior to the built-in initialization script * above. This variable can be modified by the procedure below. */ - -static char * tclPreInitScript = NULL; + +static char * tclPreInitScript = NULL; /* Forward declaration */ struct Target; /* * struct Alias: * - * Stores information about an alias. Is stored in the slave interpreter - * and used by the source command to find the target command in the master - * when the source command is invoked. + * Stores information about an alias. Is stored in the slave interpreter and + * used by the source command to find the target command in the master when + * the source command is invoked. */ typedef struct Alias { Tcl_Obj *token; /* Token for the alias command in the slave - * interp. This used to be the command name - * in the slave when the alias was first + * interp. This used to be the command name in + * the slave when the alias was first * created. */ Tcl_Interp *targetInterp; /* Interp in which target command will be * invoked. */ - Tcl_Command slaveCmd; /* Source command in slave interpreter, - * bound to command that invokes the target - * command in the target interpreter. */ + Tcl_Command slaveCmd; /* Source command in slave interpreter, bound + * to command that invokes the target command + * in the target interpreter. */ Tcl_HashEntry *aliasEntryPtr; /* Entry for the alias hash table in slave. - * This is used by alias deletion to remove - * the alias from the slave interpreter - * alias table. */ - struct Target *targetPtr; /* Entry for target command in master. - * This is used in the master interpreter to - * map back from the target command to aliases - * redirecting to it. */ - int objc; /* Count of Tcl_Obj in the prefix of the - * target command to be invoked in the - * target interpreter. Additional arguments - * specified when calling the alias in the - * slave interp will be appended to the prefix - * before the command is invoked. */ - Tcl_Obj *objPtr; /* The first actual prefix object - the target - * command name; this has to be at the end of the - * structure, which will be extended to accomodate - * the remaining objects in the prefix. */ + * This is used by alias deletion to remove + * the alias from the slave interpreter alias + * table. */ + struct Target *targetPtr; /* Entry for target command in master. This + * is used in the master interpreter to map + * back from the target command to aliases + * redirecting to it. */ + int objc; /* Count of Tcl_Obj in the prefix of the + * target command to be invoked in the target + * interpreter. Additional arguments specified + * when calling the alias in the slave interp + * will be appended to the prefix before the + * command is invoked. */ + Tcl_Obj *objPtr; /* The first actual prefix object - the target + * command name; this has to be at the end of + * the structure, which will be extended to + * accomodate the remaining objects in the + * prefix. */ } Alias; /* * * struct Slave: * * Used by the "interp" command to record and find information about slave - * interpreters. Maps from a command name in the master to information about - * a slave interpreter, e.g. what aliases are defined in it. + * interpreters. Maps from a command name in the master to information about a + * slave interpreter, e.g. what aliases are defined in it. */ typedef struct Slave { Tcl_Interp *masterInterp; /* Master interpreter for this slave. */ Tcl_HashEntry *slaveEntryPtr; - /* Hash entry in masters slave table for - * this slave interpreter. Used to find - * this record, and used when deleting the - * slave interpreter to delete it from the - * master's table. */ + /* Hash entry in masters slave table for this + * slave interpreter. Used to find this + * record, and used when deleting the slave + * interpreter to delete it from the master's + * table. */ Tcl_Interp *slaveInterp; /* The slave interpreter. */ Tcl_Command interpCmd; /* Interpreter object command. */ - Tcl_HashTable aliasTable; /* Table which maps from names of commands - * in slave interpreter to struct Alias - * defined below. */ + Tcl_HashTable aliasTable; /* Table which maps from names of commands in + * slave interpreter to struct Alias defined + * below. */ } Slave; /* * struct Target: * @@ -114,26 +115,26 @@ } Target; /* * struct Master: * - * This record is used for two purposes: First, slaveTable (a hashtable) - * maps from names of commands to slave interpreters. This hashtable is - * used to store information about slave interpreters of this interpreter, - * to map over all slaves, etc. The second purpose is to store information - * about all aliases in slaves (or siblings) which direct to target commands - * in this interpreter (using the targetsPtr doubly-linked list). - * - * NB: the flags field in the interp structure, used with SAFE_INTERP - * mask denotes whether the interpreter is safe or not. Safe - * interpreters have restricted functionality, can only create safe slave - * interpreters and can only load safe extensions. + * This record is used for two purposes: First, slaveTable (a hashtable) maps + * from names of commands to slave interpreters. This hashtable is used to + * store information about slave interpreters of this interpreter, to map over + * all slaves, etc. The second purpose is to store information about all + * aliases in slaves (or siblings) which direct to target commands in this + * interpreter (using the targetsPtr doubly-linked list). + * + * NB: the flags field in the interp structure, used with SAFE_INTERP mask + * denotes whether the interpreter is safe or not. Safe interpreters have + * restricted functionality, can only create safe slave interpreters and can + * only load safe extensions. */ typedef struct Master { - Tcl_HashTable slaveTable; /* Hash table for slave interpreters. - * Maps from command names to Slave records. */ + Tcl_HashTable slaveTable; /* Hash table for slave interpreters. Maps + * from command names to Slave records. */ Target *targetsPtr; /* The head of a doubly-linked list of all the * target records which denote aliases from * slaves or sibling interpreters that direct * to commands in this interpreter. This list * is used to remove dangling pointers from @@ -152,14 +153,14 @@ Slave slave; /* Information necessary for this interp to * function as a slave. */ } InterpInfo; /* - * Limit callbacks handled by scripts are modelled as structures which - * are stored in hashes indexed by a two-word key. Note that the type - * of the 'type' field in the key is not int; this is to make sure - * that things are likely to work properly on 64-bit architectures. + * Limit callbacks handled by scripts are modelled as structures which are + * stored in hashes indexed by a two-word key. Note that the type of the + * 'type' field in the key is not int; this is to make sure that things are + * likely to work properly on 64-bit architectures. */ struct ScriptLimitCallback { Tcl_Interp *interp; Tcl_Obj *scriptObj; @@ -183,14 +184,14 @@ static int AliasDelete _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp, Tcl_Obj *namePtr)); static int AliasDescribe _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp, Tcl_Obj *objPtr)); static int AliasList _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp)); + Tcl_Interp *slaveInterp)); static int AliasObjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *currentInterp, int objc, - Tcl_Obj *CONST objv[])); + Tcl_Obj *CONST objv[])); static void AliasObjCmdDeleteProc _ANSI_ARGS_(( ClientData clientData)); static Tcl_Interp * GetInterp _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr)); @@ -200,11 +201,11 @@ ClientData clientData, Tcl_Interp *interp)); static int SlaveBgerror _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, Tcl_Obj *CONST objv[])); static Tcl_Interp * SlaveCreate _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *pathPtr, int safe)); + Tcl_Obj *pathPtr, int safe)); static int SlaveEval _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, Tcl_Obj *CONST objv[])); static int SlaveExpose _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, @@ -214,11 +215,11 @@ Tcl_Obj *CONST objv[])); static int SlaveHidden _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp)); static int SlaveInvokeHidden _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp, - CONST char *namespaceName, + CONST char *namespaceName, int objc, Tcl_Obj *CONST objv[])); static int SlaveMarkTrusted _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp)); static int SlaveObjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, @@ -244,19 +245,20 @@ ClientData clientData, Tcl_Interp *interp)); static void DeleteScriptLimitCallback _ANSI_ARGS_(( ClientData clientData)); static void RunLimitHandlers _ANSI_ARGS_((LimitHandler *handlerPtr, Tcl_Interp *interp)); +static void TimeLimitCallback _ANSI_ARGS_((ClientData clientData)); /* *---------------------------------------------------------------------- * * TclSetPreInitScript -- * - * This routine is used to change the value of the internal - * variable, tclPreInitScript. + * This routine is used to change the value of the internal variable, + * tclPreInitScript. * * Results: * Returns the current value of tclPreInitScript. * * Side effects: @@ -277,213 +279,147 @@ /* *---------------------------------------------------------------------- * * Tcl_Init -- * - * This procedure is typically invoked by Tcl_AppInit procedures - * to find and source the "init.tcl" script, which should exist - * somewhere on the Tcl library path. + * This procedure is typically invoked by Tcl_AppInit procedures to find + * and source the "init.tcl" script, which should exist somewhere on the + * Tcl library path. * * Results: - * Returns a standard Tcl completion code and sets the interp's - * result if there is an error. + * Returns a standard Tcl completion code and sets the interp's result if + * there is an error. * * Side effects: - * Depends on what's in the init.tcl script. + * Depends on what's in the init.tcl script. * *---------------------------------------------------------------------- */ int Tcl_Init(interp) - Tcl_Interp *interp; /* Interpreter to initialize. */ + Tcl_Interp *interp; /* Interpreter to initialize. */ { - int code; - Tcl_DString script, encodingName; - Tcl_Obj *path; - if (tclPreInitScript != NULL) { if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { return (TCL_ERROR); }; } -/* - * In order to find init.tcl during initialization, the following script - * is invoked by Tcl_Init(). It looks in several different directories: - * - * $tcl_library - can specify a primary location, if set, - * no other locations will be checked. This - * is the recommended way for a program that - * embeds Tcl to specifically tell Tcl where - * to find an init.tcl file. - * - * $env(TCL_LIBRARY) - highest priority so user can always override - * the search path unless the application has - * specified an exact directory above - * - * $tclDefaultLibrary - INTERNAL: This variable is set by Tcl - * on those platforms where it can determine - * at runtime the directory where it expects - * the init.tcl file to be. After [tclInit] - * reads and uses this value, it [unset]s it. - * External users of Tcl should not make use - * of the variable to customize [tclInit]. - * - * $tcl_libPath - OBSOLETE: This variable is no longer - * set by Tcl itself, but [tclInit] examines - * it in case some program that embeds Tcl - * is customizing [tclInit] by setting this - * variable to a list of directories in which - * to search. - * - * [tcl::pkgconfig get scriptdir,runtime] - * - the directory determined by configure to - * be the place where Tcl's script library - * is to be installed. - * - * The first directory on this path that contains a valid init.tcl script - * will be set as the value of tcl_library. - * - * Note that this entire search mechanism can be bypassed by defining an - * alternate tclInit procedure before calling Tcl_Init(). - */ - code = Tcl_Eval(interp, + + /* + * In order to find init.tcl during initialization, the following script + * is invoked by Tcl_Init(). It looks in several different directories: + * + * $tcl_library - can specify a primary location, if set, no + * other locations will be checked. This is + * the recommended way for a program that + * embeds Tcl to specifically tell Tcl where to + * find an init.tcl file. + * + * $env(TCL_LIBRARY) - highest priority so user can always override + * the search path unless the application has + * specified an exact directory above + * + * $tclDefaultLibrary - INTERNAL: This variable is set by Tcl + * on those platforms where it can determine at + * runtime the directory where it expects the + * init.tcl file to be. After [tclInit] reads + * and uses this value, it [unset]s it. + * External users of Tcl should not make use of + * the variable to customize [tclInit]. + * + * $tcl_libPath - OBSOLETE: This variable is no longer + * set by Tcl itself, but [tclInit] examines it + * in case some program that embeds Tcl is + * customizing [tclInit] by setting this + * variable to a list of directories in which + * to search. + * + * [tcl::pkgconfig get scriptdir,runtime] + * - the directory determined by configure to be + * the place where Tcl's script library is to + * be installed. + * + * The first directory on this path that contains a valid init.tcl script + * will be set as the value of tcl_library. + * + * Note that this entire search mechanism can be bypassed by defining an + * alternate tclInit procedure before calling Tcl_Init(). + */ + + return Tcl_Eval(interp, "if {[info proc tclInit]==\"\"} {\n" " proc tclInit {} {\n" -" global tcl_libPath tcl_library\n" -" global env tclDefaultLibrary\n" -" variable ::tcl::LibPath\n" -" rename tclInit {}\n" -" set errors {}\n" -" set localPath {}\n" -" set LibPath {}\n" -" if {[info exists tcl_library]} {\n" -" lappend localPath $tcl_library\n" -" } else {\n" -" if {[info exists env(TCL_LIBRARY)]\n" -" && [string length $env(TCL_LIBRARY)]} {\n" -" lappend localPath $env(TCL_LIBRARY)\n" -" lappend LibPath $env(TCL_LIBRARY)\n" -" if {[regexp ^tcl(.*)$ [file tail $env(TCL_LIBRARY)] -> tail]} {\n" -" if {$tail ne [info tclversion]} {\n" -" lappend localPath [file join [file dirname\\\n" -" $env(TCL_LIBRARY)] tcl[info tclversion]]\n" -" lappend LibPath [file join [file dirname\\\n" -" $env(TCL_LIBRARY)] tcl[info tclversion]]\n" -" }\n" -" }\n" -" }\n" -" if {[catch {\n" -" lappend localPath $tclDefaultLibrary\n" -" unset tclDefaultLibrary\n" -" }]} {\n" -" lappend localPath [::tcl::pkgconfig get scriptdir,runtime]\n" -" }\n" -" set parentDir [file normalize [file dirname [file dirname\\\n" -" [info nameofexecutable]]]]\n" -" set grandParentDir [file dirname $parentDir]\n" -" lappend LibPath [file join $parentDir lib tcl[info tclversion]]\n" -" lappend LibPath [file join $grandParentDir lib tcl[info tclversion]]\n" -" lappend LibPath [file join $parentDir library]\n" -" lappend LibPath [file join $grandParentDir library]\n" -" lappend LibPath [file join $grandParentDir\\\n" -" tcl[info patchlevel] library]\n" -" lappend LibPath [file join [file dirname $grandParentDir]\\\n" -" tcl[info patchlevel] library]\n" -" catch {\n" -" set LibPath [concat $LibPath $tcl_libPath]\n" -" }\n" -" }\n" -" foreach i [concat $localPath $LibPath] {\n" -" set tcl_library $i\n" -" set tclfile [file join $i init.tcl]\n" -" if {[file exists $tclfile]} {\n" -" if {![catch {uplevel #0 [list source $tclfile]} msg opts]} {\n" -" return\n" -" } else {\n" -" append errors \"$tclfile: $msg\n\"\n" -" append errors \"[dict get $opts -errorinfo]\n\"\n" -" }\n" -" }\n" -" }\n" -" set msg \"Can't find a usable init.tcl in the following directories: \n\"\n" -" append msg \" $localPath $LibPath\n\n\"\n" +" global tcl_libPath tcl_library env tclDefaultLibrary\n" +" rename tclInit {}\n" +" if {[info exists tcl_library]} {\n" +" set scripts {{set tcl_library}}\n" +" } else {\n" +" set scripts {}\n" +" if {[info exists env(TCL_LIBRARY)] && ($env(TCL_LIBRARY) ne {})} {\n" +" lappend scripts {set env(TCL_LIBRARY)}\n" +" lappend scripts {\n" +"if {[regexp ^tcl(.*)$ [file tail $env(TCL_LIBRARY)] -> tail] == 0} continue\n" +"if {$tail eq [info tclversion]} continue\n" +"file join [file dirname $env(TCL_LIBRARY)] tcl[info tclversion]}\n" +" }\n" +" if {[info exists tclDefaultLibrary]} {\n" +" lappend scripts {set tclDefaultLibrary}\n" +" } else {\n" +" lappend scripts {::tcl::pkgconfig get scriptdir,runtime}\n" +" }\n" +" lappend scripts {\n" +"set parentDir [file dirname [file dirname [info nameofexecutable]]]\n" +"set grandParentDir [file dirname $parentDir]\n" +"file join $parentDir lib tcl[info tclversion]} \\\n" +" {file join $grandParentDir lib tcl[info tclversion]} \\\n" +" {file join $parentDir library} \\\n" +" {file join $grandParentDir library} \\\n" +" {file join $grandParentDir tcl[info patchlevel] library} \\\n" +" {\n" +"file join [file dirname $grandParentDir] tcl[info patchlevel] library}\n" +" if {[info exists tcl_libPath]\n" +" && [catch {llength $tcl_libPath} len] == 0} {\n" +" for {set i 0} {$i < $len} {incr i} {\n" +" lappend scripts [list lindex \\$tcl_libPath $i]\n" +" }\n" +" }\n" +" }\n" +" set dirs {}\n" +" set errors {}\n" +" foreach script $scripts {\n" +" lappend dirs [eval $script]\n" +" set tcl_library [lindex $dirs end]\n" +" set tclfile [file join $tcl_library init.tcl]\n" +" if {[file exists $tclfile]} {\n" +" if {[catch {uplevel #0 [list source $tclfile]} msg opts]} {\n" +" append errors \"$tclfile: $msg\n\"\n" +" append errors \"[dict get $opts -errorinfo]\n\"\n" +" continue\n" +" }\n" +" unset -nocomplain tclDefaultLibrary\n" +" return\n" +" }\n" +" }\n" +" unset -nocomplain tclDefaultLibrary\n" +" set msg \"Can't find a usable init.tcl in the following directories: \n\"\n" +" append msg \" $dirs\n\n\"\n" " append msg \"$errors\n\n\"\n" " append msg \"This probably means that Tcl wasn't installed properly.\n\"\n" " error $msg\n" " }\n" "}\n" "tclInit"); - - if (code != TCL_OK) { - return code; - } - - /* - * Now that [info library] is initialized, make sure that - * [file join [info library] encoding] is on the encoding - * search path. - * - * Relying on use of original built-in commands. - * Should be a safe assumption during interp initialization. - * More robust would be to use C-coded equivalents, but that's such - * a pain... - */ - - Tcl_DStringInit(&script); - Tcl_DStringAppend(&script, "lsearch -exact", -1); - path = Tcl_DuplicateObj(TclGetEncodingSearchPath()); - Tcl_IncrRefCount(path); - Tcl_DStringAppendElement(&script, Tcl_GetString(path)); - Tcl_DStringAppend(&script, " [file join [info library] encoding]", -1); - code = Tcl_EvalEx(interp, Tcl_DStringValue(&script), - Tcl_DStringLength(&script), TCL_EVAL_GLOBAL); - Tcl_DStringFree(&script); - if (code == TCL_OK) { - int index; - Tcl_GetIntFromObj(interp, Tcl_GetObjResult(interp), &index); - if (index != -1) { - /* [info library]/encoding already on the encoding search path */ - goto done; - } - } - Tcl_DStringInit(&script); - Tcl_DStringAppend(&script, "file join [info library] encoding", -1); - code = Tcl_EvalEx(interp, Tcl_DStringValue(&script), - Tcl_DStringLength(&script), TCL_EVAL_GLOBAL); - Tcl_DStringFree(&script); - if (code == TCL_OK) { - Tcl_ListObjAppendElement(NULL, path, Tcl_GetObjResult(interp)); - TclSetEncodingSearchPath(path); - } -done: - /* - * Now that we know the distributed *.enc files are on the encoding - * search path, check whether the [encoding system] matches that - * specified by the environment, and if not, attempt to correct it - */ - TclpGetEncodingNameFromEnvironment(&encodingName); - if (strcmp(Tcl_DStringValue(&encodingName), Tcl_GetEncodingName(NULL))) { - code = Tcl_SetSystemEncoding(NULL, Tcl_DStringValue(&encodingName)); - if (code == TCL_ERROR) { - Tcl_Panic("system encoding \"", Tcl_DStringValue(&encodingName), - "\" not available"); - } - } - Tcl_DStringFree(&encodingName); - Tcl_DecrRefCount(path); - Tcl_ResetResult(interp); - return TCL_OK; } /* *--------------------------------------------------------------------------- * * TclInterpInit -- * - * Initializes the invoking interpreter for using the master, slave - * and safe interp facilities. This is called from inside + * Initializes the invoking interpreter for using the master, slave and + * safe interp facilities. This is called from inside * Tcl_CreateInterp(). * * Results: * Always returns TCL_OK for backwards compatibility. * @@ -498,11 +434,11 @@ TclInterpInit(interp) Tcl_Interp *interp; /* Interpreter to initialize. */ { InterpInfo *interpInfoPtr; Master *masterPtr; - Slave *slavePtr; + Slave *slavePtr; interpInfoPtr = (InterpInfo *) ckalloc(sizeof(InterpInfo)); ((Interp *) interp)->interpInfo = (ClientData) interpInfoPtr; masterPtr = &interpInfoPtr->master; @@ -525,27 +461,26 @@ /* *--------------------------------------------------------------------------- * * InterpInfoDeleteProc -- * - * Invoked when an interpreter is being deleted. It releases all - * storage used by the master/slave/safe interpreter facilities. + * Invoked when an interpreter is being deleted. It releases all storage + * used by the master/slave/safe interpreter facilities. * * Results: * None. * * Side effects: - * Cleans up storage. Sets the interpInfoPtr field of the interp - * to NULL. + * Cleans up storage. Sets the interpInfoPtr field of the interp to NULL. * *--------------------------------------------------------------------------- */ static void InterpInfoDeleteProc(clientData, interp) ClientData clientData; /* Ignored. */ - Tcl_Interp *interp; /* Interp being deleted. All commands for + Tcl_Interp *interp; /* Interp being deleted. All commands for * slave interps should already be deleted. */ { InterpInfo *interpInfoPtr; Slave *slavePtr; Master *masterPtr; @@ -563,12 +498,12 @@ } Tcl_DeleteHashTable(&masterPtr->slaveTable); /* * Tell any interps that have aliases to this interp that they should - * delete those aliases. If the other interp was already dead, it - * would have removed the target record already. + * delete those aliases. If the other interp was already dead, it would + * have removed the target record already. */ for (targetPtr = masterPtr->targetsPtr; targetPtr != NULL; ) { Target *tmpPtr = targetPtr->nextPtr; Tcl_DeleteCommandFromToken(targetPtr->slaveInterp, @@ -577,18 +512,18 @@ } slavePtr = &interpInfoPtr->slave; if (slavePtr->interpCmd != NULL) { /* - * Tcl_DeleteInterp() was called on this interpreter, rather - * "interp delete" or the equivalent deletion of the command in the - * master. First ensure that the cleanup callback doesn't try to - * delete the interp again. + * Tcl_DeleteInterp() was called on this interpreter, rather "interp + * delete" or the equivalent deletion of the command in the master. + * First ensure that the cleanup callback doesn't try to delete the + * interp again. */ slavePtr->slaveInterp = NULL; - Tcl_DeleteCommandFromToken(slavePtr->masterInterp, + Tcl_DeleteCommandFromToken(slavePtr->masterInterp, slavePtr->interpCmd); } /* * There shouldn't be any aliases left. @@ -597,20 +532,20 @@ if (slavePtr->aliasTable.numEntries != 0) { Tcl_Panic("InterpInfoDeleteProc: still exist aliases"); } Tcl_DeleteHashTable(&slavePtr->aliasTable); - ckfree((char *) interpInfoPtr); + ckfree((char *) interpInfoPtr); } /* *---------------------------------------------------------------------- * * Tcl_InterpObjCmd -- * - * This procedure is invoked to process the "interp" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "interp" Tcl command. See + * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -626,475 +561,466 @@ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int index; static CONST char *options[] = { - "alias", "aliases", "bgerror", "create", + "alias", "aliases", "bgerror", "create", "delete", "eval", "exists", "expose", "hide", "hidden", "issafe", "invokehidden", "limit", "marktrusted", "recursionlimit","slaves", "share", "target", "transfer", - NULL + NULL }; enum option { OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CREATE, OPT_DELETE, OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, OPT_LIMIT, OPT_MARKTRUSTED,OPT_RECLIMIT, OPT_SLAVES, OPT_SHARE, OPT_TARGET, OPT_TRANSFER }; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); + return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum option) index) { - case OPT_ALIAS: { - Tcl_Interp *slaveInterp, *masterInterp; - - if (objc < 4) { - aliasArgs: - Tcl_WrongNumArgs(interp, 2, objv, - "slavePath slaveCmd ?masterPath masterCmd? ?args ..?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == (Tcl_Interp *) NULL) { - return TCL_ERROR; - } - if (objc == 4) { - return AliasDescribe(interp, slaveInterp, objv[3]); - } - if ((objc == 5) && (Tcl_GetString(objv[4])[0] == '\0')) { - return AliasDelete(interp, slaveInterp, objv[3]); - } - if (objc > 5) { - masterInterp = GetInterp(interp, objv[4]); - if (masterInterp == (Tcl_Interp *) NULL) { - return TCL_ERROR; - } - if (Tcl_GetString(objv[5])[0] == '\0') { - if (objc == 6) { - return AliasDelete(interp, slaveInterp, objv[3]); - } - } else { - return AliasCreate(interp, slaveInterp, masterInterp, - objv[3], objv[5], objc - 6, objv + 6); - } - } - goto aliasArgs; - } - case OPT_ALIASES: { - Tcl_Interp *slaveInterp; - - slaveInterp = GetInterp2(interp, objc, objv); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return AliasList(interp, slaveInterp); - } - case OPT_BGERROR: { - Tcl_Interp *slaveInterp; - - if (objc != 3 && objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3); - } - case OPT_CREATE: { - int i, last, safe; - Tcl_Obj *slavePtr; - char buf[16 + TCL_INTEGER_SPACE]; - static CONST char *options[] = { - "-safe", "--", NULL - }; - enum option { - OPT_SAFE, OPT_LAST - }; - - safe = Tcl_IsSafe(interp); - - /* - * Weird historical rules: "-safe" is accepted at the end, too. - */ - - slavePtr = NULL; - last = 0; - for (i = 2; i < objc; i++) { - if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) { - if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", - 0, &index) != TCL_OK) { - return TCL_ERROR; - } - if (index == OPT_SAFE) { - safe = 1; - continue; - } - i++; - last = 1; - } - if (slavePtr != NULL) { - Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?"); - return TCL_ERROR; - } - if (i < objc) { - slavePtr = objv[i]; - } - } - buf[0] = '\0'; - if (slavePtr == NULL) { - /* - * Create an anonymous interpreter -- we choose its name and - * the name of the command. We check that the command name - * that we use for the interpreter does not collide with an - * existing command in the master interpreter. - */ - - for (i = 0; ; i++) { - Tcl_CmdInfo cmdInfo; - - sprintf(buf, "interp%d", i); - if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) { - break; - } - } - slavePtr = Tcl_NewStringObj(buf, -1); - } - if (SlaveCreate(interp, slavePtr, safe) == NULL) { - if (buf[0] != '\0') { - Tcl_DecrRefCount(slavePtr); - } - return TCL_ERROR; - } - Tcl_SetObjResult(interp, slavePtr); - return TCL_OK; - } - case OPT_DELETE: { - int i; - InterpInfo *iiPtr; - Tcl_Interp *slaveInterp; - - for (i = 2; i < objc; i++) { - slaveInterp = GetInterp(interp, objv[i]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } else if (slaveInterp == interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot delete the current interpreter", -1)); - return TCL_ERROR; - } - iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; - Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp, - iiPtr->slave.interpCmd); - } - return TCL_OK; - } - case OPT_EVAL: { - Tcl_Interp *slaveInterp; - - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return SlaveEval(interp, slaveInterp, objc - 3, objv + 3); - } - case OPT_EXISTS: { - int exists; - Tcl_Interp *slaveInterp; - - exists = 1; - slaveInterp = GetInterp2(interp, objc, objv); - if (slaveInterp == NULL) { - if (objc > 3) { - return TCL_ERROR; - } - Tcl_ResetResult(interp); - exists = 0; - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists)); - return TCL_OK; - } - case OPT_EXPOSE: { - Tcl_Interp *slaveInterp; - - if ((objc < 4) || (objc > 5)) { - Tcl_WrongNumArgs(interp, 2, objv, - "path hiddenCmdName ?cmdName?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3); - } - case OPT_HIDE: { - Tcl_Interp *slaveInterp; /* A slave. */ - - if ((objc < 4) || (objc > 5)) { - Tcl_WrongNumArgs(interp, 2, objv, - "path cmdName ?hiddenCmdName?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == (Tcl_Interp *) NULL) { - return TCL_ERROR; - } - return SlaveHide(interp, slaveInterp, objc - 3, objv + 3); - } - case OPT_HIDDEN: { - Tcl_Interp *slaveInterp; /* A slave. */ - - slaveInterp = GetInterp2(interp, objc, objv); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return SlaveHidden(interp, slaveInterp); - } - case OPT_ISSAFE: { - Tcl_Interp *slaveInterp; - - slaveInterp = GetInterp2(interp, objc, objv); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, - Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); - return TCL_OK; - } - case OPT_INVOKEHID: { - int i, index; - CONST char *namespaceName; - Tcl_Interp *slaveInterp; - static CONST char *hiddenOptions[] = { - "-global", "-namespace", "--", NULL - }; - enum hiddenOption { - OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST - }; - - namespaceName = NULL; - for (i = 3; i < objc; i++) { - if (Tcl_GetString(objv[i])[0] != '-') { - break; - } - if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, - "option", 0, &index) != TCL_OK) { - return TCL_ERROR; - } - if (index == OPT_GLOBAL) { - namespaceName = "::"; - } else { - if (index == OPT_NAMESPACE) { - if (++i == objc) { /* There must be more arguments. */ - break; - } else { - namespaceName = Tcl_GetString(objv[i]); - } - } else { - i++; - break; - } - } - } - if (objc - i < 1) { - Tcl_WrongNumArgs(interp, 2, objv, - "path ?-namespace ns? ?-global? ?--? cmd ?arg ..?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == (Tcl_Interp *) NULL) { - return TCL_ERROR; - } - return SlaveInvokeHidden(interp, slaveInterp, namespaceName, - objc - i, objv + i); - } - case OPT_LIMIT: { - Tcl_Interp *slaveInterp; - static CONST char *limitTypes[] = { - "commands", "time", NULL - }; - enum LimitTypes { - LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME - }; - int limitType; - - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "path limitType ?options?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[3], limitTypes, "limit type", - 0, &limitType) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum LimitTypes) limitType) { - case LIMIT_TYPE_COMMANDS: - return SlaveCommandLimitCmd(interp, slaveInterp, 4, objc,objv); - case LIMIT_TYPE_TIME: - return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv); - } - } - case OPT_MARKTRUSTED: { - Tcl_Interp *slaveInterp; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "path"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return SlaveMarkTrusted(interp, slaveInterp); - } - case OPT_RECLIMIT: { - Tcl_Interp *slaveInterp; - - if (objc != 3 && objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3); - } - case OPT_SLAVES: { - Tcl_Interp *slaveInterp; - InterpInfo *iiPtr; - Tcl_Obj *resultPtr; - Tcl_HashEntry *hPtr; - Tcl_HashSearch hashSearch; - char *string; - - slaveInterp = GetInterp2(interp, objc, objv); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; - resultPtr = Tcl_NewObj(); - hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch); - for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { - string = Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr); - Tcl_ListObjAppendElement(NULL, resultPtr, - Tcl_NewStringObj(string, -1)); - } - Tcl_SetObjResult(interp, resultPtr); - return TCL_OK; - } - case OPT_SHARE: { - Tcl_Interp *slaveInterp; /* A slave. */ - Tcl_Interp *masterInterp; /* Its master. */ - Tcl_Channel chan; - - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath"); - return TCL_ERROR; - } - masterInterp = GetInterp(interp, objv[2]); - if (masterInterp == NULL) { - return TCL_ERROR; - } - chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), - NULL); - if (chan == NULL) { - TclTransferResult(masterInterp, TCL_OK, interp); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[4]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - Tcl_RegisterChannel(slaveInterp, chan); - return TCL_OK; - } - case OPT_TARGET: { - Tcl_Interp *slaveInterp; - InterpInfo *iiPtr; - Tcl_HashEntry *hPtr; - Alias *aliasPtr; - char *aliasName; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "path alias"); - return TCL_ERROR; - } - - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - - aliasName = Tcl_GetString(objv[3]); - - iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; - hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); - if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, - "\" in path \"", Tcl_GetString(objv[2]), - "\" not found", (char *) NULL); - return TCL_ERROR; - } - aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "target interpreter for alias \"", - aliasName, "\" in path \"", Tcl_GetString(objv[2]), - "\" is not my descendant", (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; - } - case OPT_TRANSFER: { - Tcl_Interp *slaveInterp; /* A slave. */ - Tcl_Interp *masterInterp; /* Its master. */ - Tcl_Channel chan; - - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, - "srcPath channelId destPath"); - return TCL_ERROR; - } - masterInterp = GetInterp(interp, objv[2]); - if (masterInterp == NULL) { - return TCL_ERROR; - } - chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), NULL); - if (chan == NULL) { - TclTransferResult(masterInterp, TCL_OK, interp); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[4]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - Tcl_RegisterChannel(slaveInterp, chan); - if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) { - TclTransferResult(masterInterp, TCL_OK, interp); - return TCL_ERROR; - } - return TCL_OK; - } + case OPT_ALIAS: { + Tcl_Interp *slaveInterp, *masterInterp; + + if (objc < 4) { + aliasArgs: + Tcl_WrongNumArgs(interp, 2, objv, + "slavePath slaveCmd ?masterPath masterCmd? ?args ..?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == (Tcl_Interp *) NULL) { + return TCL_ERROR; + } + if (objc == 4) { + return AliasDescribe(interp, slaveInterp, objv[3]); + } + if ((objc == 5) && (Tcl_GetString(objv[4])[0] == '\0')) { + return AliasDelete(interp, slaveInterp, objv[3]); + } + if (objc > 5) { + masterInterp = GetInterp(interp, objv[4]); + if (masterInterp == (Tcl_Interp *) NULL) { + return TCL_ERROR; + } + if (Tcl_GetString(objv[5])[0] == '\0') { + if (objc == 6) { + return AliasDelete(interp, slaveInterp, objv[3]); + } + } else { + return AliasCreate(interp, slaveInterp, masterInterp, objv[3], + objv[5], objc - 6, objv + 6); + } + } + goto aliasArgs; + } + case OPT_ALIASES: { + Tcl_Interp *slaveInterp; + + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return AliasList(interp, slaveInterp); + } + case OPT_BGERROR: { + Tcl_Interp *slaveInterp; + + if (objc != 3 && objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3); + } + case OPT_CREATE: { + int i, last, safe; + Tcl_Obj *slavePtr; + char buf[16 + TCL_INTEGER_SPACE]; + static CONST char *options[] = { + "-safe", "--", NULL + }; + enum option { + OPT_SAFE, OPT_LAST + }; + + safe = Tcl_IsSafe(interp); + + /* + * Weird historical rules: "-safe" is accepted at the end, too. + */ + + slavePtr = NULL; + last = 0; + for (i = 2; i < objc; i++) { + if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) { + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + if (index == OPT_SAFE) { + safe = 1; + continue; + } + i++; + last = 1; + } + if (slavePtr != NULL) { + Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?"); + return TCL_ERROR; + } + if (i < objc) { + slavePtr = objv[i]; + } + } + buf[0] = '\0'; + if (slavePtr == NULL) { + /* + * Create an anonymous interpreter -- we choose its name and the + * name of the command. We check that the command name that we use + * for the interpreter does not collide with an existing command + * in the master interpreter. + */ + + for (i = 0; ; i++) { + Tcl_CmdInfo cmdInfo; + + sprintf(buf, "interp%d", i); + if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) { + break; + } + } + slavePtr = Tcl_NewStringObj(buf, -1); + } + if (SlaveCreate(interp, slavePtr, safe) == NULL) { + if (buf[0] != '\0') { + Tcl_DecrRefCount(slavePtr); + } + return TCL_ERROR; + } + Tcl_SetObjResult(interp, slavePtr); + return TCL_OK; + } + case OPT_DELETE: { + int i; + InterpInfo *iiPtr; + Tcl_Interp *slaveInterp; + + for (i = 2; i < objc; i++) { + slaveInterp = GetInterp(interp, objv[i]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } else if (slaveInterp == interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot delete the current interpreter", -1)); + return TCL_ERROR; + } + iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; + Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp, + iiPtr->slave.interpCmd); + } + return TCL_OK; + } + case OPT_EVAL: { + Tcl_Interp *slaveInterp; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveEval(interp, slaveInterp, objc - 3, objv + 3); + } + case OPT_EXISTS: { + int exists; + Tcl_Interp *slaveInterp; + + exists = 1; + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { + if (objc > 3) { + return TCL_ERROR; + } + Tcl_ResetResult(interp); + exists = 0; + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists)); + return TCL_OK; + } + case OPT_EXPOSE: { + Tcl_Interp *slaveInterp; + + if ((objc < 4) || (objc > 5)) { + Tcl_WrongNumArgs(interp, 2, objv, "path hiddenCmdName ?cmdName?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3); + } + case OPT_HIDE: { + Tcl_Interp *slaveInterp; /* A slave. */ + + if ((objc < 4) || (objc > 5)) { + Tcl_WrongNumArgs(interp, 2, objv, "path cmdName ?hiddenCmdName?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == (Tcl_Interp *) NULL) { + return TCL_ERROR; + } + return SlaveHide(interp, slaveInterp, objc - 3, objv + 3); + } + case OPT_HIDDEN: { + Tcl_Interp *slaveInterp; /* A slave. */ + + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveHidden(interp, slaveInterp); + } + case OPT_ISSAFE: { + Tcl_Interp *slaveInterp; + + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); + return TCL_OK; + } + case OPT_INVOKEHID: { + int i, index; + CONST char *namespaceName; + Tcl_Interp *slaveInterp; + static CONST char *hiddenOptions[] = { + "-global", "-namespace", "--", NULL + }; + enum hiddenOption { + OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST + }; + + namespaceName = NULL; + for (i = 3; i < objc; i++) { + if (Tcl_GetString(objv[i])[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, "option", + 0, &index) != TCL_OK) { + return TCL_ERROR; + } + if (index == OPT_GLOBAL) { + namespaceName = "::"; + } else if (index == OPT_NAMESPACE) { + if (++i == objc) { /* There must be more arguments. */ + break; + } else { + namespaceName = Tcl_GetString(objv[i]); + } + } else { + i++; + break; + } + } + if (objc - i < 1) { + Tcl_WrongNumArgs(interp, 2, objv, + "path ?-namespace ns? ?-global? ?--? cmd ?arg ..?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == (Tcl_Interp *) NULL) { + return TCL_ERROR; + } + return SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc - i, + objv + i); + } + case OPT_LIMIT: { + Tcl_Interp *slaveInterp; + static CONST char *limitTypes[] = { + "commands", "time", NULL + }; + enum LimitTypes { + LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME + }; + int limitType; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "path limitType ?options?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[3], limitTypes, "limit type", 0, + &limitType) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum LimitTypes) limitType) { + case LIMIT_TYPE_COMMANDS: + return SlaveCommandLimitCmd(interp, slaveInterp, 4, objc,objv); + case LIMIT_TYPE_TIME: + return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv); + } + } + case OPT_MARKTRUSTED: { + Tcl_Interp *slaveInterp; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "path"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveMarkTrusted(interp, slaveInterp); + } + case OPT_RECLIMIT: { + Tcl_Interp *slaveInterp; + + if (objc != 3 && objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3); + } + case OPT_SLAVES: { + Tcl_Interp *slaveInterp; + InterpInfo *iiPtr; + Tcl_Obj *resultPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch hashSearch; + char *string; + + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; + resultPtr = Tcl_NewObj(); + hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch); + for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { + string = Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr); + Tcl_ListObjAppendElement(NULL, resultPtr, + Tcl_NewStringObj(string, -1)); + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + case OPT_SHARE: { + Tcl_Interp *slaveInterp; /* A slave. */ + Tcl_Interp *masterInterp; /* Its master. */ + Tcl_Channel chan; + + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath"); + return TCL_ERROR; + } + masterInterp = GetInterp(interp, objv[2]); + if (masterInterp == NULL) { + return TCL_ERROR; + } + chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), NULL); + if (chan == NULL) { + TclTransferResult(masterInterp, TCL_OK, interp); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[4]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + Tcl_RegisterChannel(slaveInterp, chan); + return TCL_OK; + } + case OPT_TARGET: { + Tcl_Interp *slaveInterp; + InterpInfo *iiPtr; + Tcl_HashEntry *hPtr; + Alias *aliasPtr; + char *aliasName; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "path alias"); + return TCL_ERROR; + } + + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + + aliasName = Tcl_GetString(objv[3]); + + iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; + hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "alias \"", aliasName, "\" in path \"", + Tcl_GetString(objv[2]), "\" not found", (char *) NULL); + return TCL_ERROR; + } + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "target interpreter for alias \"", + aliasName, "\" in path \"", Tcl_GetString(objv[2]), + "\" is not my descendant", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; + } + case OPT_TRANSFER: { + Tcl_Interp *slaveInterp; /* A slave. */ + Tcl_Interp *masterInterp; /* Its master. */ + Tcl_Channel chan; + + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath"); + return TCL_ERROR; + } + masterInterp = GetInterp(interp, objv[2]); + if (masterInterp == NULL) { + return TCL_ERROR; + } + chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), NULL); + if (chan == NULL) { + TclTransferResult(masterInterp, TCL_OK, interp); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[4]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + Tcl_RegisterChannel(slaveInterp, chan); + if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) { + TclTransferResult(masterInterp, TCL_OK, interp); + return TCL_ERROR; + } + return TCL_OK; + } } return TCL_OK; } /* @@ -1104,22 +1030,22 @@ * * Helper function for Tcl_InterpObjCmd() to convert the interp name * potentially specified on the command line to an Tcl_Interp. * * Results: - * The return value is the interp specified on the command line, - * or the interp argument itself if no interp was specified on the - * command line. If the interp could not be found or the wrong - * number of arguments was specified on the command line, the return - * value is NULL and an error message is left in the interp's result. + * The return value is the interp specified on the command line, or the + * interp argument itself if no interp was specified on the command line. + * If the interp could not be found or the wrong number of arguments was + * specified on the command line, the return value is NULL and an error + * message is left in the interp's result. * * Side effects: * None. * *--------------------------------------------------------------------------- */ - + static Tcl_Interp * GetInterp2(interp, objc, objv) Tcl_Interp *interp; /* Default interp if no interp was specified * on the command line. */ int objc; /* Number of arguments. */ @@ -1162,17 +1088,17 @@ { Tcl_Obj *slaveObjPtr, *targetObjPtr; Tcl_Obj **objv; int i; int result; - + objv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * argc); for (i = 0; i < argc; i++) { - objv[i] = Tcl_NewStringObj(argv[i], -1); - Tcl_IncrRefCount(objv[i]); + objv[i] = Tcl_NewStringObj(argv[i], -1); + Tcl_IncrRefCount(objv[i]); } - + slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1); Tcl_IncrRefCount(slaveObjPtr); targetObjPtr = Tcl_NewStringObj(targetCmd, -1); Tcl_IncrRefCount(targetObjPtr); @@ -1238,23 +1164,23 @@ * Tcl_GetAlias -- * * Gets information about an alias. * * Results: - * A standard Tcl result. + * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr, - argvPtr) + argvPtr) Tcl_Interp *interp; /* Interp to start search from. */ - CONST char *aliasName; /* Name of alias to find. */ + CONST char *aliasName; /* Name of alias to find. */ Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */ CONST char **targetNamePtr; /* (Return) name of target command. */ int *argcPtr; /* (Return) count of addnl args. */ CONST char ***argvPtr; /* (Return) additional arguments. */ { @@ -1261,15 +1187,15 @@ InterpInfo *iiPtr; Tcl_HashEntry *hPtr; Alias *aliasPtr; int i, objc; Tcl_Obj **objv; - + iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo; hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, + Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", (char *) NULL); return TCL_ERROR; } aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); objc = aliasPtr->objc; @@ -1283,15 +1209,15 @@ } if (argcPtr != NULL) { *argcPtr = objc - 1; } if (argvPtr != NULL) { - *argvPtr = (CONST char **) + *argvPtr = (CONST char **) ckalloc((unsigned) sizeof(CONST char *) * (objc - 1)); - for (i = 1; i < objc; i++) { - *argvPtr[i - 1] = Tcl_GetString(objv[i]); - } + for (i = 1; i < objc; i++) { + *argvPtr[i - 1] = Tcl_GetString(objv[i]); + } } return TCL_OK; } /* @@ -1310,108 +1236,108 @@ *---------------------------------------------------------------------- */ int Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr, - objvPtr) + objvPtr) Tcl_Interp *interp; /* Interp to start search from. */ CONST char *aliasName; /* Name of alias to find. */ Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */ CONST char **targetNamePtr; /* (Return) name of target command. */ int *objcPtr; /* (Return) count of addnl args. */ Tcl_Obj ***objvPtr; /* (Return) additional args. */ { InterpInfo *iiPtr; Tcl_HashEntry *hPtr; - Alias *aliasPtr; + Alias *aliasPtr; int objc; Tcl_Obj **objv; iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo; hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == (Tcl_HashEntry *) NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, - "\" not found", (char *) NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", + (char *) NULL); + return TCL_ERROR; } aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); objc = aliasPtr->objc; objv = &aliasPtr->objPtr; if (targetInterpPtr != (Tcl_Interp **) NULL) { - *targetInterpPtr = aliasPtr->targetInterp; + *targetInterpPtr = aliasPtr->targetInterp; } if (targetNamePtr != (CONST char **) NULL) { - *targetNamePtr = Tcl_GetString(objv[0]); + *targetNamePtr = Tcl_GetString(objv[0]); } if (objcPtr != (int *) NULL) { - *objcPtr = objc - 1; + *objcPtr = objc - 1; } if (objvPtr != (Tcl_Obj ***) NULL) { - *objvPtr = objv + 1; + *objvPtr = objv + 1; } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclPreventAliasLoop -- * - * When defining an alias or renaming a command, prevent an alias - * loop from being formed. + * When defining an alias or renaming a command, prevent an alias loop + * from being formed. * * Results: * A standard Tcl object result. * * Side effects: - * If TCL_ERROR is returned, the function also stores an error message - * in the interpreter's result object. + * If TCL_ERROR is returned, the function also stores an error message in + * the interpreter's result object. * * NOTE: - * This function is public internal (instead of being static to - * this file) because it is also used from TclRenameCommand. + * This function is public internal (instead of being static to this + * file) because it is also used from TclRenameCommand. * *---------------------------------------------------------------------- */ int TclPreventAliasLoop(interp, cmdInterp, cmd) Tcl_Interp *interp; /* Interp in which to report errors. */ Tcl_Interp *cmdInterp; /* Interp in which the command is - * being defined. */ - Tcl_Command cmd; /* Tcl command we are attempting - * to define. */ + * being defined. */ + Tcl_Command cmd; /* Tcl command we are attempting to + * define. */ { Command *cmdPtr = (Command *) cmd; Alias *aliasPtr, *nextAliasPtr; Tcl_Command aliasCmd; Command *aliasCmdPtr; /* - * If we are not creating or renaming an alias, then it is - * always OK to create or rename the command. + * If we are not creating or renaming an alias, then it is always OK to + * create or rename the command. */ - + if (cmdPtr->objProc != AliasObjCmd) { - return TCL_OK; + return TCL_OK; } /* - * OK, we are dealing with an alias, so traverse the chain of aliases. - * If we encounter the alias we are defining (or renaming to) any in - * the chain then we have a loop. + * OK, we are dealing with an alias, so traverse the chain of aliases. If + * we encounter the alias we are defining (or renaming to) any in the + * chain then we have a loop. */ aliasPtr = (Alias *) cmdPtr->objClientData; nextAliasPtr = aliasPtr; while (1) { Tcl_Obj *cmdNamePtr; - /* - * If the target of the next alias in the chain is the same as - * the source alias, we have a loop. + /* + * If the target of the next alias in the chain is the same as the + * source alias, we have a loop. */ if (Tcl_InterpDeleted(nextAliasPtr->targetInterp)) { /* * The slave interpreter can be deleted while creating the alias. @@ -1423,34 +1349,34 @@ "\": interpreter deleted", (char *) NULL); return TCL_ERROR; } cmdNamePtr = nextAliasPtr->objPtr; aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp, - Tcl_GetString(cmdNamePtr), + Tcl_GetString(cmdNamePtr), Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp), /*flags*/ 0); - if (aliasCmd == (Tcl_Command) NULL) { - return TCL_OK; - } + if (aliasCmd == (Tcl_Command) NULL) { + return TCL_OK; + } aliasCmdPtr = (Command *) aliasCmd; - if (aliasCmdPtr == cmdPtr) { - Tcl_AppendResult(interp, "cannot define or rename alias \"", + if (aliasCmdPtr == cmdPtr) { + Tcl_AppendResult(interp, "cannot define or rename alias \"", Tcl_GetCommandName(cmdInterp, cmd), "\": would create a loop", (char *) NULL); - return TCL_ERROR; - } + return TCL_ERROR; + } - /* + /* * Otherwise, follow the chain one step further. See if the target - * command is an alias - if so, follow the loop to its target - * command. Otherwise we do not have a loop. + * command is an alias - if so, follow the loop to its target command. + * Otherwise we do not have a loop. */ - if (aliasCmdPtr->objProc != AliasObjCmd) { - return TCL_OK; - } - nextAliasPtr = (Alias *) aliasCmdPtr->objClientData; + if (aliasCmdPtr->objProc != AliasObjCmd) { + return TCL_OK; + } + nextAliasPtr = (Alias *) aliasCmdPtr->objClientData; } /* NOTREACHED */ } @@ -1463,12 +1389,12 @@ * * Results: * A standard Tcl result. * * Side effects: - * An alias command is created and entered into the alias table - * for the slave interpreter. + * An alias command is created and entered into the alias table for the + * slave interpreter. * *---------------------------------------------------------------------- */ static int @@ -1490,12 +1416,12 @@ Slave *slavePtr; Master *masterPtr; Tcl_Obj **prefv; int new, i; - aliasPtr = (Alias *) ckalloc((unsigned) (sizeof(Alias) - + objc * sizeof(Tcl_Obj *))); + aliasPtr = (Alias *) ckalloc((unsigned) (sizeof(Alias) + + objc * sizeof(Tcl_Obj *))); aliasPtr->token = namePtr; Tcl_IncrRefCount(aliasPtr->token); aliasPtr->targetInterp = masterInterp; aliasPtr->objc = objc + 1; @@ -1516,24 +1442,24 @@ AliasObjCmdDeleteProc); if (TclPreventAliasLoop(interp, slaveInterp, aliasPtr->slaveCmd) != TCL_OK) { /* - * Found an alias loop! The last call to Tcl_CreateObjCommand made + * Found an alias loop! The last call to Tcl_CreateObjCommand made * the alias point to itself. Delete the command and its alias * record. Be careful to wipe out its client data first, so the * command doesn't try to delete itself. */ Command *cmdPtr; - + Tcl_DecrRefCount(aliasPtr->token); Tcl_DecrRefCount(targetNamePtr); for (i = 0; i < objc; i++) { Tcl_DecrRefCount(objv[i]); } - + cmdPtr = (Command *) aliasPtr->slaveCmd; cmdPtr->clientData = NULL; cmdPtr->deleteProc = NULL; cmdPtr->deleteData = NULL; Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); @@ -1555,40 +1481,39 @@ slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; while (1) { Tcl_Obj *newToken; char *string; - + string = Tcl_GetString(aliasPtr->token); hPtr = Tcl_CreateHashEntry(&slavePtr->aliasTable, string, &new); if (new != 0) { break; } /* - * The alias name cannot be used as unique token, it is already - * taken. We can produce a unique token by prepending "::" - * repeatedly. This algorithm is a stop-gap to try to maintain - * the command name as token for most use cases, fearful of - * possible backwards compat problems. A better algorithm would - * produce unique tokens that need not be related to the command - * name. - * - * ATTENTION: the tests in interp.test and possibly safe.test - * depend on the precise definition of these tokens. - */ - + * The alias name cannot be used as unique token, it is already taken. + * We can produce a unique token by prepending "::" repeatedly. This + * algorithm is a stop-gap to try to maintain the command name as + * token for most use cases, fearful of possible backwards compat + * problems. A better algorithm would produce unique tokens that need + * not be related to the command name. + * + * ATTENTION: the tests in interp.test and possibly safe.test depend + * on the precise definition of these tokens. + */ + newToken = Tcl_NewStringObj("::",-1); Tcl_AppendObjToObj(newToken, aliasPtr->token); Tcl_DecrRefCount(aliasPtr->token); aliasPtr->token = newToken; Tcl_IncrRefCount(aliasPtr->token); } aliasPtr->aliasEntryPtr = hPtr; Tcl_SetHashValue(hPtr, (ClientData) aliasPtr); - + /* * Create the new command. We must do it after deleting any old command, * because the alias may be pointing at a renamed alias, as in: * * interp alias {} foo {} bar # Create an alias "foo" @@ -1649,13 +1574,13 @@ */ slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr)); if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", - Tcl_GetString(namePtr), "\" not found", NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "alias \"", Tcl_GetString(namePtr), + "\" not found", NULL); + return TCL_ERROR; } aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); return TCL_OK; } @@ -1663,14 +1588,13 @@ /* *---------------------------------------------------------------------- * * AliasDescribe -- * - * Sets the interpreter's result object to a Tcl list describing - * the given alias in the given interpreter: its target command - * and the additional arguments to prepend to any invocation - * of the alias. + * Sets the interpreter's result object to a Tcl list describing the + * given alias in the given interpreter: its target command and the + * additional arguments to prepend to any invocation of the alias. * * Results: * A standard Tcl result. * * Side effects: @@ -1685,11 +1609,11 @@ Tcl_Interp *slaveInterp; /* Interpreter containing alias. */ Tcl_Obj *namePtr; /* Name of alias to describe. */ { Slave *slavePtr; Tcl_HashEntry *hPtr; - Alias *aliasPtr; + Alias *aliasPtr; Tcl_Obj *prefixPtr; /* * If the alias has been renamed in the slave, the master can still use * the original name (with which it was created) to find the alias to @@ -1697,11 +1621,11 @@ */ slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr)); if (hPtr == NULL) { - return TCL_OK; + return TCL_OK; } aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); prefixPtr = Tcl_NewListObj(aliasPtr->objc, &aliasPtr->objPtr); Tcl_SetObjResult(interp, prefixPtr); return TCL_OK; @@ -1736,12 +1660,12 @@ slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; entryPtr = Tcl_FirstHashEntry(&slavePtr->aliasTable, &hashSearch); for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) { - aliasPtr = (Alias *) Tcl_GetHashValue(entryPtr); - Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->token); + aliasPtr = (Alias *) Tcl_GetHashValue(entryPtr); + Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->token); } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } @@ -1748,48 +1672,48 @@ /* *---------------------------------------------------------------------- * * AliasObjCmd -- * - * This is the procedure that services invocations of aliases in a - * slave interpreter. One such command exists for each alias. When - * invoked, this procedure redirects the invocation to the target - * command in the master interpreter as designated by the Alias - * record associated with this command. + * This is the procedure that services invocations of aliases in a slave + * interpreter. One such command exists for each alias. When invoked, + * this procedure redirects the invocation to the target command in the + * master interpreter as designated by the Alias record associated with + * this command. * * Results: * A standard Tcl result. * * Side effects: - * Causes forwarding of the invocation; all possible side effects - * may occur as a result of invoking the command to which the - * invocation is forwarded. + * Causes forwarding of the invocation; all possible side effects may + * occur as a result of invoking the command to which the invocation is + * forwarded. * *---------------------------------------------------------------------- */ static int AliasObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Alias record. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument vector. */ + Tcl_Obj *CONST objv[]; /* Argument vector. */ { #define ALIAS_CMDV_PREALLOC 10 - Tcl_Interp *targetInterp; - Alias *aliasPtr; + Tcl_Interp *targetInterp; + Alias *aliasPtr; int result, prefc, cmdc, i; Tcl_Obj **prefv, **cmdv; Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC]; aliasPtr = (Alias *) clientData; targetInterp = aliasPtr->targetInterp; /* - * Append the arguments to the command prefix and invoke the command - * in the target interp's global namespace. + * Append the arguments to the command prefix and invoke the command in + * the target interp's global namespace. */ - + prefc = aliasPtr->objc; prefv = &aliasPtr->objPtr; cmdc = prefc + objc - 1; if (cmdc <= ALIAS_CMDV_PREALLOC) { cmdv = cmdArr; @@ -1796,13 +1720,13 @@ } else { cmdv = (Tcl_Obj **) ckalloc((unsigned) (cmdc * sizeof(Tcl_Obj *))); } prefv = &aliasPtr->objPtr; - memcpy((VOID *) cmdv, (VOID *) prefv, - (size_t) (prefc * sizeof(Tcl_Obj *))); - memcpy((VOID *) (cmdv+prefc), (VOID *) (objv+1), + memcpy((VOID *) cmdv, (VOID *) prefv, + (size_t) (prefc * sizeof(Tcl_Obj *))); + memcpy((VOID *) (cmdv+prefc), (VOID *) (objv+1), (size_t) ((objc-1) * sizeof(Tcl_Obj *))); Tcl_ResetResult(targetInterp); for (i=0; itoken); objv = &aliasPtr->objPtr; for (i = 0; i < aliasPtr->objc; i++) { Tcl_DecrRefCount(objv[i]); } @@ -1886,24 +1810,24 @@ /* *---------------------------------------------------------------------- * * Tcl_CreateSlave -- * - * Creates a slave interpreter. The slavePath argument denotes the - * name of the new slave relative to the current interpreter; the - * slave is a direct descendant of the one-before-last component of - * the path, e.g. it is a descendant of the current interpreter if - * the slavePath argument contains only one component. Optionally makes - * the slave interpreter safe. + * Creates a slave interpreter. The slavePath argument denotes the name + * of the new slave relative to the current interpreter; the slave is a + * direct descendant of the one-before-last component of the path, + * e.g. it is a descendant of the current interpreter if the slavePath + * argument contains only one component. Optionally makes the slave + * interpreter safe. * * Results: * Returns the interpreter structure created, or NULL if an error * occurred. * * Side effects: - * Creates a new interpreter and a new interpreter object command in - * the interpreter indicated by the slavePath argument. + * Creates a new interpreter and a new interpreter object command in the + * interpreter indicated by the slavePath argument. * *---------------------------------------------------------------------- */ Tcl_Interp * @@ -1928,12 +1852,11 @@ * Tcl_GetSlave -- * * Finds a slave interpreter by its path name. * * Results: - * Returns a Tcl_Interp * for the named interpreter or NULL if not - * found. + * Returns a Tcl_Interp * for the named interpreter or NULL if not found. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -1975,11 +1898,11 @@ Tcl_Interp *interp; /* Get the master of this interpreter. */ { Slave *slavePtr; /* Slave record of this interpreter. */ if (interp == (Tcl_Interp *) NULL) { - return NULL; + return NULL; } slavePtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->slave; return slavePtr->masterInterp; } @@ -1987,23 +1910,21 @@ *---------------------------------------------------------------------- * * Tcl_GetInterpPath -- * * Sets the result of the asking interpreter to a proper Tcl list - * containing the names of interpreters between the asking and - * target interpreters. The target interpreter must be either the - * same as the asking interpreter or one of its slaves (including - * recursively). + * containing the names of interpreters between the asking and target + * interpreters. The target interpreter must be either the same as the + * asking interpreter or one of its slaves (including recursively). * * Results: - * TCL_OK if the target interpreter is the same as, or a descendant - * of, the asking interpreter; TCL_ERROR else. This way one can - * distinguish between the case where the asking and target interps - * are the same (an empty list is the result, and TCL_OK is returned) - * and when the target is not a descendant of the asking interpreter - * (in which case the Tcl result is an error message and the function - * returns TCL_ERROR). + * TCL_OK if the target interpreter is the same as, or a descendant of, + * the asking interpreter; TCL_ERROR else. This way one can distinguish + * between the case where the asking and target interps are the same (an + * empty list is the result, and TCL_OK is returned) and when the target + * is not a descendant of the asking interpreter (in which case the Tcl + * result is an error message and the function returns TCL_ERROR). * * Side effects: * None. * *---------------------------------------------------------------------- @@ -2013,24 +1934,23 @@ Tcl_GetInterpPath(askingInterp, targetInterp) Tcl_Interp *askingInterp; /* Interpreter to start search from. */ Tcl_Interp *targetInterp; /* Interpreter to find. */ { InterpInfo *iiPtr; - + if (targetInterp == askingInterp) { - return TCL_OK; + return TCL_OK; } if (targetInterp == NULL) { return TCL_ERROR; } iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo; if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; } - Tcl_AppendElement(askingInterp, - Tcl_GetHashKey(&iiPtr->master.slaveTable, - iiPtr->slave.slaveEntryPtr)); + Tcl_AppendElement(askingInterp, Tcl_GetHashKey(&iiPtr->master.slaveTable, + iiPtr->slave.slaveEntryPtr)); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -2039,11 +1959,11 @@ * * Helper function to find a slave interpreter given a pathname. * * Results: * Returns the slave interpreter known by that name in the calling - * interpreter, or NULL if no interpreter known by that name exists. + * interpreter, or NULL if no interpreter known by that name exists. * * Side effects: * Assigns to the pointer variable passed in, if not NULL. * *---------------------------------------------------------------------- @@ -2050,17 +1970,17 @@ */ static Tcl_Interp * GetInterp(interp, pathPtr) Tcl_Interp *interp; /* Interp. to start search from. */ - Tcl_Obj *pathPtr; /* List object containing name of interp. to + Tcl_Obj *pathPtr; /* List object containing name of interp. to * be found. */ { Tcl_HashEntry *hPtr; /* Search element. */ Slave *slavePtr; /* Interim slave record. */ Tcl_Obj **objv; - int objc, i; + int objc, i; Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */ InterpInfo *masterInfoPtr; if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { return NULL; @@ -2067,43 +1987,43 @@ } searchInterp = interp; for (i = 0; i < objc; i++) { masterInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo; - hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable, + hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable, Tcl_GetString(objv[i])); - if (hPtr == NULL) { + if (hPtr == NULL) { searchInterp = NULL; break; } - slavePtr = (Slave *) Tcl_GetHashValue(hPtr); - searchInterp = slavePtr->slaveInterp; - if (searchInterp == NULL) { + slavePtr = (Slave *) Tcl_GetHashValue(hPtr); + searchInterp = slavePtr->slaveInterp; + if (searchInterp == NULL) { break; } } if (searchInterp == NULL) { Tcl_AppendResult(interp, "could not find interpreter \"", - Tcl_GetString(pathPtr), "\"", (char *) NULL); + Tcl_GetString(pathPtr), "\"", (char *) NULL); } return searchInterp; } /* *---------------------------------------------------------------------- * * SlaveBgerror -- * - * Helper function to set/query the background error handling - * command prefix of an interp + * Helper function to set/query the background error handling command + * prefix of an interp * * Results: * A standard Tcl result. * * Side effects: - * When (objc == 1), slaveInterp will be set to a new background - * handler of objv[0]. + * When (objc == 1), slaveInterp will be set to a new background handler + * of objv[0]. * *---------------------------------------------------------------------- */ static int @@ -2114,11 +2034,11 @@ Tcl_Obj *CONST objv[]; /* Argument strings. */ { if (objc) { int length; - if (TCL_ERROR == Tcl_ListObjLength(NULL, objv[0], &length) + if (TCL_ERROR == Tcl_ListObjLength(NULL, objv[0], &length) || (length < 1)) { Tcl_AppendResult(interp, "cmdPrefix must be list of length >= 1", (char *) NULL); return TCL_ERROR; } @@ -2131,13 +2051,13 @@ /* *---------------------------------------------------------------------- * * SlaveCreate -- * - * Helper function to do the actual work of creating a slave interp - * and new object command. Also optionally makes the new slave - * interpreter "safe". + * Helper function to do the actual work of creating a slave interp and + * new object command. Also optionally makes the new slave interpreter + * "safe". * * Results: * Returns the new Tcl_Interp * if successful or NULL if not. If failed, * the result of the invoking interpreter contains an error message. * @@ -2158,22 +2078,20 @@ InterpInfo *masterInfoPtr; Tcl_HashEntry *hPtr; char *path; int new, objc; Tcl_Obj **objv; - Tcl_Obj* clockObj; - int status; if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { return NULL; } if (objc < 2) { masterInterp = interp; path = Tcl_GetString(pathPtr); } else { Tcl_Obj *objPtr; - + objPtr = Tcl_NewListObj(objc - 1, objv); masterInterp = GetInterp(interp, objPtr); Tcl_DecrRefCount(objPtr); if (masterInterp == NULL) { return NULL; @@ -2185,63 +2103,68 @@ } masterInfoPtr = (InterpInfo *) ((Interp *) masterInterp)->interpInfo; hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, &new); if (new == 0) { - Tcl_AppendResult(interp, "interpreter named \"", path, + Tcl_AppendResult(interp, "interpreter named \"", path, "\" already exists, cannot create", (char *) NULL); - return NULL; + return NULL; } slaveInterp = Tcl_CreateInterp(); slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; slavePtr->masterInterp = masterInterp; slavePtr->slaveEntryPtr = hPtr; slavePtr->slaveInterp = slaveInterp; slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path, - SlaveObjCmd, (ClientData) slaveInterp, SlaveObjCmdDeleteProc); + SlaveObjCmd, (ClientData) slaveInterp, SlaveObjCmdDeleteProc); Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); Tcl_SetHashValue(hPtr, (ClientData) slavePtr); Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); - + /* * Inherit the recursion limit. */ + ((Interp *) slaveInterp)->maxNestingDepth = - ((Interp *) masterInterp)->maxNestingDepth ; + ((Interp *) masterInterp)->maxNestingDepth; if (safe) { - if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) { - goto error; - } + if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) { + goto error; + } } else { - if (Tcl_Init(slaveInterp) == TCL_ERROR) { - goto error; - } + if (Tcl_Init(slaveInterp) == TCL_ERROR) { + goto error; + } + /* - * This will create the "memory" command in slave interpreters - * if we compiled with TCL_MEM_DEBUG, otherwise it does nothing. + * This will create the "memory" command in slave interpreters if we + * compiled with TCL_MEM_DEBUG, otherwise it does nothing. */ + Tcl_InitMemory(slaveInterp); } /* * Inherit the TIP#143 limits. */ + InheritLimitsFromMaster(slaveInterp, masterInterp); - if ( safe ) { - clockObj = Tcl_NewStringObj( "clock", -1 ); - Tcl_IncrRefCount( clockObj ); - status = AliasCreate( interp, slaveInterp, masterInterp, - clockObj, clockObj, 0, (Tcl_Obj *CONST *) NULL ); - Tcl_DecrRefCount( clockObj ); - if ( status != TCL_OK ) { + if (safe) { + Tcl_Obj* clockObj = Tcl_NewStringObj("clock", -1); + int status; + + Tcl_IncrRefCount(clockObj); + status = AliasCreate(interp, slaveInterp, masterInterp, clockObj, + clockObj, 0, (Tcl_Obj *CONST *) NULL); + Tcl_DecrRefCount(clockObj); + if (status != TCL_OK) { goto error2; } } - return slaveInterp; error: TclTransferResult(slaveInterp, TCL_ERROR, interp); @@ -2254,12 +2177,12 @@ /* *---------------------------------------------------------------------- * * SlaveObjCmd -- * - * Command to manipulate an interpreter, e.g. to send commands to it - * to be evaluated. One such command exists for each slave interpreter. + * Command to manipulate an interpreter, e.g. to send commands to it to + * be evaluated. One such command exists for each slave interpreter. * * Results: * A standard Tcl result. * * Side effects: @@ -2285,175 +2208,162 @@ enum options { OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_EVAL, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT }; - + slaveInterp = (Tcl_Interp *) clientData; if (slaveInterp == NULL) { Tcl_Panic("SlaveObjCmd: interpreter has been deleted"); } if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); + return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum options) index) { - case OPT_ALIAS: { - if (objc > 2) { - if (objc == 3) { - return AliasDescribe(interp, slaveInterp, objv[2]); - } - if (Tcl_GetString(objv[3])[0] == '\0') { - if (objc == 4) { - return AliasDelete(interp, slaveInterp, objv[2]); - } - } else { - return AliasCreate(interp, slaveInterp, interp, objv[2], - objv[3], objc - 4, objv + 4); - } - } - Tcl_WrongNumArgs(interp, 2, objv, - "aliasName ?targetName? ?args..?"); - return TCL_ERROR; - } - case OPT_ALIASES: { - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL); - return TCL_ERROR; - } - return AliasList(interp, slaveInterp); - } - case OPT_BGERROR: { - if (objc != 2 && objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?cmdPrefix?"); - return TCL_ERROR; - } - return SlaveBgerror(interp, slaveInterp, objc - 2, objv + 2); - } - case OPT_EVAL: { - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?"); - return TCL_ERROR; - } - return SlaveEval(interp, slaveInterp, objc - 2, objv + 2); - } - case OPT_EXPOSE: { - if ((objc < 3) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?"); - return TCL_ERROR; - } - return SlaveExpose(interp, slaveInterp, objc - 2, objv + 2); - } - case OPT_HIDE: { - if ((objc < 3) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?"); - return TCL_ERROR; - } - return SlaveHide(interp, slaveInterp, objc - 2, objv + 2); - } - case OPT_HIDDEN: { - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; - } - return SlaveHidden(interp, slaveInterp); - } - case OPT_ISSAFE: { - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, - Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); - return TCL_OK; - } - case OPT_INVOKEHIDDEN: { - int i, index; - CONST char *namespaceName; - static CONST char *hiddenOptions[] = { - "-global", "-namespace", "--", NULL - }; - enum hiddenOption { - OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST - }; - - namespaceName = NULL; - for (i = 2; i < objc; i++) { - if (Tcl_GetString(objv[i])[0] != '-') { - break; - } - if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, - "option", 0, &index) != TCL_OK) { - return TCL_ERROR; - } - if (index == OPT_GLOBAL) { - namespaceName = "::"; - } else { - if (index == OPT_NAMESPACE) { - if (++i == objc) { /* There must be more arguments. */ - break; - } else { - namespaceName = Tcl_GetString(objv[i]); - } - } else { - i++; - break; - } - } - } - if (objc - i < 1) { - Tcl_WrongNumArgs(interp, 2, objv, - "?-namespace ns? ?-global? ?--? cmd ?arg ..?"); - return TCL_ERROR; - } - return SlaveInvokeHidden(interp, slaveInterp, namespaceName, - objc - i, objv + i); - } - case OPT_LIMIT: { - static CONST char *limitTypes[] = { - "commands", "time", NULL - }; - enum LimitTypes { - LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME - }; - int limitType; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "limitType ?options?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[2], limitTypes, "limit type", - 0, &limitType) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum LimitTypes) limitType) { - case LIMIT_TYPE_COMMANDS: - return SlaveCommandLimitCmd(interp, slaveInterp, 3, objc,objv); - case LIMIT_TYPE_TIME: - return SlaveTimeLimitCmd(interp, slaveInterp, 3, objc, objv); - } - } - case OPT_MARKTRUSTED: { - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; - } - return SlaveMarkTrusted(interp, slaveInterp); - } - case OPT_RECLIMIT: { - if (objc != 2 && objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?newlimit?"); - return TCL_ERROR; - } - return SlaveRecursionLimit(interp, slaveInterp, objc - 2, objv + 2); - } + case OPT_ALIAS: + if (objc > 2) { + if (objc == 3) { + return AliasDescribe(interp, slaveInterp, objv[2]); + } + if (Tcl_GetString(objv[3])[0] == '\0') { + if (objc == 4) { + return AliasDelete(interp, slaveInterp, objv[2]); + } + } else { + return AliasCreate(interp, slaveInterp, interp, objv[2], + objv[3], objc - 4, objv + 4); + } + } + Tcl_WrongNumArgs(interp, 2, objv, "aliasName ?targetName? ?args..?"); + return TCL_ERROR; + case OPT_ALIASES: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL); + return TCL_ERROR; + } + return AliasList(interp, slaveInterp); + case OPT_BGERROR: + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?cmdPrefix?"); + return TCL_ERROR; + } + return SlaveBgerror(interp, slaveInterp, objc - 2, objv + 2); + case OPT_EVAL: + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?"); + return TCL_ERROR; + } + return SlaveEval(interp, slaveInterp, objc - 2, objv + 2); + case OPT_EXPOSE: + if ((objc < 3) || (objc > 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?"); + return TCL_ERROR; + } + return SlaveExpose(interp, slaveInterp, objc - 2, objv + 2); + case OPT_HIDE: + if ((objc < 3) || (objc > 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?"); + return TCL_ERROR; + } + return SlaveHide(interp, slaveInterp, objc - 2, objv + 2); + case OPT_HIDDEN: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + return SlaveHidden(interp, slaveInterp); + case OPT_ISSAFE: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); + return TCL_OK; + case OPT_INVOKEHIDDEN: { + int i, index; + CONST char *namespaceName; + static CONST char *hiddenOptions[] = { + "-global", "-namespace", "--", + NULL + }; + enum hiddenOption { + OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST + }; + + namespaceName = NULL; + for (i = 2; i < objc; i++) { + if (Tcl_GetString(objv[i])[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, "option", + 0, &index) != TCL_OK) { + return TCL_ERROR; + } + if (index == OPT_GLOBAL) { + namespaceName = "::"; + } else if (index == OPT_NAMESPACE) { + if (++i == objc) { /* There must be more arguments. */ + break; + } else { + namespaceName = Tcl_GetString(objv[i]); + } + } else { + i++; + break; + } + } + if (objc - i < 1) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-namespace ns? ?-global? ?--? cmd ?arg ..?"); + return TCL_ERROR; + } + return SlaveInvokeHidden(interp, slaveInterp, namespaceName, + objc - i, objv + i); + } + case OPT_LIMIT: { + static CONST char *limitTypes[] = { + "commands", "time", NULL + }; + enum LimitTypes { + LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME + }; + int limitType; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "limitType ?options?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[2], limitTypes, "limit type", 0, + &limitType) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum LimitTypes) limitType) { + case LIMIT_TYPE_COMMANDS: + return SlaveCommandLimitCmd(interp, slaveInterp, 3, objc,objv); + case LIMIT_TYPE_TIME: + return SlaveTimeLimitCmd(interp, slaveInterp, 3, objc, objv); + } + } + case OPT_MARKTRUSTED: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + return SlaveMarkTrusted(interp, slaveInterp); + case OPT_RECLIMIT: + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?newlimit?"); + return TCL_ERROR; + } + return SlaveRecursionLimit(interp, slaveInterp, objc - 2, objv + 2); } return TCL_ERROR; } @@ -2468,12 +2378,12 @@ * * Results: * None. * * Side effects: - * Cleans up all state associated with the slave interpreter and - * destroys the slave interpreter. + * Cleans up all state associated with the slave interpreter and destroys + * the slave interpreter. * *---------------------------------------------------------------------- */ static void @@ -2491,13 +2401,13 @@ */ Tcl_DeleteHashEntry(slavePtr->slaveEntryPtr); /* - * Set to NULL so that when the InterpInfo is cleaned up in the slave - * it does not try to delete the command causing all sorts of grief. - * See SlaveRecordDeleteProc(). + * Set to NULL so that when the InterpInfo is cleaned up in the slave it + * does not try to delete the command causing all sorts of grief. See + * SlaveRecordDeleteProc(). */ slavePtr->interpCmd = NULL; if (slavePtr->slaveInterp != NULL) { @@ -2529,11 +2439,11 @@ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int result; Tcl_Obj *objPtr; - + Tcl_Preserve((ClientData) slaveInterp); Tcl_AllowExceptions(slaveInterp); if (objc == 1) { result = Tcl_EvalObjEx(slaveInterp, objv[0], 0); @@ -2558,12 +2468,12 @@ * * Results: * A standard Tcl result. * * Side effects: - * After this call scripts in the slave will be able to invoke - * the newly exposed command. + * After this call scripts in the slave will be able to invoke the newly + * exposed command. * *---------------------------------------------------------------------- */ static int @@ -2572,11 +2482,11 @@ Tcl_Interp *slaveInterp; /* Interp in which command will be exposed. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument strings. */ { char *name; - + if (Tcl_IsSafe(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "permission denied: safe interpreter cannot expose commands", -1)); return TCL_ERROR; @@ -2600,12 +2510,12 @@ * * Results: * A standard Tcl result. * * Side effects: - * When (objc == 1), slaveInterp will be set to a new recursion - * limit of objv[0]. + * When (objc == 1), slaveInterp will be set to a new recursion limit of + * objv[0]. * *---------------------------------------------------------------------- */ static int @@ -2639,15 +2549,15 @@ Tcl_SetObjResult(interp, Tcl_NewStringObj( "falling back due to new recursion limit", -1)); return TCL_ERROR; } Tcl_SetObjResult(interp, objv[0]); - return TCL_OK; + return TCL_OK; } else { limit = Tcl_SetRecursionLimit(slaveInterp, 0); Tcl_SetObjResult(interp, Tcl_NewIntObj(limit)); - return TCL_OK; + return TCL_OK; } } /* *---------------------------------------------------------------------- @@ -2658,12 +2568,12 @@ * * Results: * A standard Tcl result. * * Side effects: - * After this call scripts in the slave will no longer be able - * to invoke the named command. + * After this call scripts in the slave will no longer be able to invoke + * the named command. * *---------------------------------------------------------------------- */ static int @@ -2672,21 +2582,20 @@ Tcl_Interp *slaveInterp; /* Interp in which command will be exposed. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument strings. */ { char *name; - + if (Tcl_IsSafe(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "permission denied: safe interpreter cannot hide commands", -1)); return TCL_ERROR; } name = Tcl_GetString(objv[(objc == 1) ? 0 : 1]); - if (Tcl_HideCommand(slaveInterp, Tcl_GetString(objv[0]), - name) != TCL_OK) { + if (Tcl_HideCommand(slaveInterp, Tcl_GetString(objv[0]), name) != TCL_OK) { TclTransferResult(slaveInterp, TCL_ERROR, interp); return TCL_ERROR; } return TCL_OK; } @@ -2715,17 +2624,16 @@ { Tcl_Obj *listObjPtr = Tcl_NewObj(); /* Local object pointer. */ Tcl_HashTable *hTblPtr; /* For local searches. */ Tcl_HashEntry *hPtr; /* For local searches. */ Tcl_HashSearch hSearch; /* For local searches. */ - + hTblPtr = ((Interp *) slaveInterp)->hiddenCmdTablePtr; if (hTblPtr != (Tcl_HashTable *) NULL) { for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); - hPtr != (Tcl_HashEntry *) NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { Tcl_ListObjAppendElement(NULL, listObjPtr, Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1)); } } Tcl_SetObjResult(interp, listObjPtr); @@ -2749,36 +2657,36 @@ */ static int SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc, objv) Tcl_Interp *interp; /* Interp for error return. */ - Tcl_Interp *slaveInterp; /* The slave interpreter in which command - * will be invoked. */ + Tcl_Interp *slaveInterp; /* The slave interpreter in which command will + * be invoked. */ CONST char *namespaceName; /* The namespace to use, if any. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int result; - + if (Tcl_IsSafe(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "not allowed to invoke hidden commands from safe interpreter", -1)); return TCL_ERROR; } Tcl_Preserve((ClientData) slaveInterp); Tcl_AllowExceptions(slaveInterp); - + if (namespaceName == NULL) { - result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); + result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); } else { Namespace *nsPtr, *dummy1, *dummy2; CONST char *tail; result = TclGetNamespaceForQualName(slaveInterp, namespaceName, - (Namespace *) NULL, TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY + (Namespace *) NULL, TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG | TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); if (result == TCL_OK) { result = TclObjInvokeNamespace(slaveInterp, objc, objv, (Tcl_Namespace *)nsPtr, TCL_INVOKE_HIDDEN); @@ -2786,11 +2694,11 @@ } TclTransferResult(slaveInterp, result, interp); Tcl_Release((ClientData) slaveInterp); - return result; + return result; } /* *---------------------------------------------------------------------- * @@ -2800,21 +2708,21 @@ * * Results: * A standard Tcl result. * * Side effects: - * After this call the hard-wired security checks in the core no - * longer prevent the slave from performing certain operations. + * After this call the hard-wired security checks in the core no longer + * prevent the slave from performing certain operations. * *---------------------------------------------------------------------- */ static int SlaveMarkTrusted(interp, slaveInterp) Tcl_Interp *interp; /* Interp for error return. */ - Tcl_Interp *slaveInterp; /* The slave interpreter which will be - * marked trusted. */ + Tcl_Interp *slaveInterp; /* The slave interpreter which will be marked + * trusted. */ { if (Tcl_IsSafe(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "permission denied: safe interpreter cannot mark trusted", -1)); @@ -2845,11 +2753,11 @@ Tcl_Interp *interp; /* Is this interpreter "safe" ? */ { Interp *iPtr; if (interp == (Tcl_Interp *) NULL) { - return 0; + return 0; } iPtr = (Interp *) interp; return ( (iPtr->flags) & SAFE_INTERP ) ? 1 : 0 ; } @@ -2858,86 +2766,84 @@ *---------------------------------------------------------------------- * * Tcl_MakeSafe -- * * Makes its argument interpreter contain only functionality that is - * defined to be part of Safe Tcl. Unsafe commands are hidden, the - * env array is unset, and the standard channels are removed. + * defined to be part of Safe Tcl. Unsafe commands are hidden, the env + * array is unset, and the standard channels are removed. * * Results: * None. * * Side effects: - * Hides commands in its argument interpreter, and removes settings - * and channels. + * Hides commands in its argument interpreter, and removes settings and + * channels. * *---------------------------------------------------------------------- */ int Tcl_MakeSafe(interp) Tcl_Interp *interp; /* Interpreter to be made safe. */ { - Tcl_Channel chan; /* Channel to remove from - * safe interpreter. */ + Tcl_Channel chan; /* Channel to remove from safe interpreter. */ Interp *iPtr = (Interp *) interp; TclHideUnsafeCommands(interp); - + iPtr->flags |= SAFE_INTERP; /* - * Unsetting variables : (which should not have been set - * in the first place, but...) + * Unsetting variables : (which should not have been set in the first + * place, but...) */ /* * No env array in a safe slave. */ Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY); - /* + /* * Remove unsafe parts of tcl_platform */ Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY); Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY); Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY); Tcl_UnsetVar2(interp, "tcl_platform", "user", TCL_GLOBAL_ONLY); /* - * Unset path informations variables - * (the only one remaining is [info nameofexecutable]) + * Unset path informations variables (the only one remaining is [info + * nameofexecutable]) */ Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY); Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY); - + /* - * Remove the standard channels from the interpreter; safe interpreters - * do not ordinarily have access to stdin, stdout and stderr. + * Remove the standard channels from the interpreter; safe interpreters do + * not ordinarily have access to stdin, stdout and stderr. * * NOTE: These channels are not added to the interpreter by the * Tcl_CreateInterp call, but may be added later, by another I/O - * operation. We want to ensure that the interpreter does not have - * these channels even if it is being made safe after being used for - * some time.. + * operation. We want to ensure that the interpreter does not have these + * channels even if it is being made safe after being used for some time.. */ chan = Tcl_GetStdChannel(TCL_STDIN); if (chan != (Tcl_Channel) NULL) { - Tcl_UnregisterChannel(interp, chan); + Tcl_UnregisterChannel(interp, chan); } chan = Tcl_GetStdChannel(TCL_STDOUT); if (chan != (Tcl_Channel) NULL) { - Tcl_UnregisterChannel(interp, chan); + Tcl_UnregisterChannel(interp, chan); } chan = Tcl_GetStdChannel(TCL_STDERR); if (chan != (Tcl_Channel) NULL) { - Tcl_UnregisterChannel(interp, chan); + Tcl_UnregisterChannel(interp, chan); } return TCL_OK; } @@ -2944,13 +2850,13 @@ /* *---------------------------------------------------------------------- * * Tcl_LimitExceeded -- * - * Tests whether any limit has been exceededin the given - * interpreter (i.e. whether the interpreter is currently unable - * to process further scripts). + * Tests whether any limit has been exceeded in the given interpreter + * (i.e. whether the interpreter is currently unable to process further + * scripts). * * Results: * A boolean value. * * Side effects: @@ -2971,13 +2877,13 @@ /* *---------------------------------------------------------------------- * * Tcl_LimitReady -- * - * Find out whether any limit has been set on the interpreter, - * and if so check whether the granularity of that limit is such - * that the full limit check should be carried out. + * Find out whether any limit has been set on the interpreter, and if so + * check whether the granularity of that limit is such that the full + * limit check should be carried out. * * Results: * A boolean value that indicates whether to call Tcl_LimitCheck. * * Side effects: @@ -2995,16 +2901,16 @@ if (iPtr->limit.active != 0) { register int ticker = ++iPtr->limit.granularityTicker; if ((iPtr->limit.active & TCL_LIMIT_COMMANDS) && ((iPtr->limit.cmdGranularity == 1) || - (ticker % iPtr->limit.cmdGranularity == 0))) { + (ticker % iPtr->limit.cmdGranularity == 0))) { return 1; } if ((iPtr->limit.active & TCL_LIMIT_TIME) && ((iPtr->limit.timeGranularity == 1) || - (ticker % iPtr->limit.timeGranularity == 0))) { + (ticker % iPtr->limit.timeGranularity == 0))) { return 1; } } return 0; } @@ -3012,24 +2918,24 @@ /* *---------------------------------------------------------------------- * * Tcl_LimitCheck -- * - * Check all currently set limits in the interpreter (where - * permitted by granularity). If a limit is exceeded, call its - * callbacks and, if the limit is still exceeded after the - * callbacks have run, make the interpreter generate an error - * that cannot be caught within the limited interpreter. + * Check all currently set limits in the interpreter (where permitted by + * granularity). If a limit is exceeded, call its callbacks and, if the + * limit is still exceeded after the callbacks have run, make the + * interpreter generate an error that cannot be caught within the limited + * interpreter. * * Results: - * A Tcl result value (TCL_OK if no limit is exceeded, and - * TCL_ERROR if a limit has been exceeded). + * A Tcl result value (TCL_OK if no limit is exceeded, and TCL_ERROR if a + * limit has been exceeded). * * Side effects: - * May invoke system calls. May invoke other interpreters. May - * be reentrant. May put the interpreter into a state where it - * can no longer execute commands without outside intervention. + * May invoke system calls. May invoke other interpreters. May be + * reentrant. May put the interpreter into a state where it can no longer + * execute commands without outside intervention. * *---------------------------------------------------------------------- */ int @@ -3061,21 +2967,21 @@ Tcl_Release(interp); } if ((iPtr->limit.active & TCL_LIMIT_TIME) && ((iPtr->limit.timeGranularity == 1) || - (ticker % iPtr->limit.timeGranularity == 0))) { + (ticker % iPtr->limit.timeGranularity == 0))) { Tcl_Time now; Tcl_GetTime(&now); if (iPtr->limit.time.sec < now.sec || (iPtr->limit.time.sec == now.sec && iPtr->limit.time.usec < now.usec)) { iPtr->limit.exceeded |= TCL_LIMIT_TIME; Tcl_Preserve(interp); RunLimitHandlers(iPtr->limit.timeHandlers, interp); - if (iPtr->limit.time.sec >= now.sec || + if (iPtr->limit.time.sec > now.sec || (iPtr->limit.time.sec == now.sec && iPtr->limit.time.usec >= now.usec)) { iPtr->limit.exceeded &= ~TCL_LIMIT_TIME; } else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) { Tcl_ResetResult(interp); @@ -3093,13 +2999,13 @@ /* *---------------------------------------------------------------------- * * RunLimitHandlers -- * - * Invoke all the limit handlers in a list (for a particular - * limit). Note that no particular limit handler callback will - * be invoked reentrantly. + * Invoke all the limit handlers in a list (for a particular limit). + * Note that no particular limit handler callback will be invoked + * reentrantly. * * Results: * None. * * Side effects: @@ -3115,42 +3021,44 @@ { LimitHandler *nextPtr; for (; handlerPtr!=NULL ; handlerPtr=nextPtr) { if (handlerPtr->flags & (LIMIT_HANDLER_DELETED|LIMIT_HANDLER_ACTIVE)) { /* - * Reentrant call or something seriously strange in the - * delete code. + * Reentrant call or something seriously strange in the delete + * code. */ + nextPtr = handlerPtr->nextPtr; continue; } /* - * Set the ACTIVE flag while running the limit handler itself - * so we cannot reentrantly call this handler and know to use - * the alternate method of deletion if necessary. + * Set the ACTIVE flag while running the limit handler itself so we + * cannot reentrantly call this handler and know to use the alternate + * method of deletion if necessary. */ handlerPtr->flags |= LIMIT_HANDLER_ACTIVE; (handlerPtr->handlerProc)(handlerPtr->clientData, interp); handlerPtr->flags &= ~LIMIT_HANDLER_ACTIVE; /* - * Rediscover this value; it might have changed during the - * processing of a limit handler. We have to record it here - * because we might delete the structure below, and reading a - * value out of a deleted structure is unsafe (even if - * actually legal with some malloc()/free() implementations.) + * Rediscover this value; it might have changed during the processing + * of a limit handler. We have to record it here because we might + * delete the structure below, and reading a value out of a deleted + * structure is unsafe (even if actually legal with some + * malloc()/free() implementations.) */ nextPtr = handlerPtr->nextPtr; /* - * If we deleted the current handler while we were executing - * it, we will have spliced it out of the list and set the + * If we deleted the current handler while we were executing it, we + * will have spliced it out of the list and set the * LIMIT_HANDLER_DELETED flag. */ + if (handlerPtr->flags & LIMIT_HANDLER_DELETED) { if (handlerPtr->deleteProc != NULL) { (handlerPtr->deleteProc)(handlerPtr->clientData); } ckfree((char *) handlerPtr); @@ -3241,14 +3149,14 @@ * * Results: * None. * * Side effects: - * The handler is spliced out of the internal linked list for the - * limit, and if not currently being invoked, deleted. Otherwise - * it is just marked for deletion and removed when the limit - * handler has finished executing. + * The handler is spliced out of the internal linked list for the limit, + * and if not currently being invoked, deleted. Otherwise it is just + * marked for deletion and removed when the limit handler has finished + * executing. * *---------------------------------------------------------------------- */ void @@ -3278,12 +3186,12 @@ (handlerPtr->clientData != clientData)) { continue; } /* - * We've found the handler to delete; mark it as doomed if not - * already so marked (which shouldn't actually happen). + * We've found the handler to delete; mark it as doomed if not already + * so marked (which shouldn't actually happen). */ if (handlerPtr->flags & LIMIT_HANDLER_DELETED) { return; } @@ -3308,13 +3216,13 @@ if (handlerPtr->nextPtr != NULL) { handlerPtr->nextPtr->prevPtr = handlerPtr->prevPtr; } /* - * If nothing is currently executing the handler, delete its - * client data and the overall handler structure now. - * Otherwise it will all go away when the handler returns. + * If nothing is currently executing the handler, delete its client + * data and the overall handler structure now. Otherwise it will all + * go away when the handler returns. */ if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { if (handlerPtr->deleteProc != NULL) { (handlerPtr->deleteProc)(handlerPtr->clientData); @@ -3328,12 +3236,12 @@ /* *---------------------------------------------------------------------- * * TclLimitRemoveAllHandlers -- * - * Remove all limit callback handlers for an interpreter. This - * is invoked as part of deleting the interpreter. + * Remove all limit callback handlers for an interpreter. This is invoked + * as part of deleting the interpreter. * * Results: * None. * * Side effects: @@ -3368,13 +3276,13 @@ handlerPtr->flags |= LIMIT_HANDLER_DELETED; handlerPtr->prevPtr = NULL; handlerPtr->nextPtr = NULL; /* - * If nothing is currently executing the handler, delete its - * client data and the overall handler structure now. - * Otherwise it will all go away when the handler returns. + * If nothing is currently executing the handler, delete its client + * data and the overall handler structure now. Otherwise it will all + * go away when the handler returns. */ if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { if (handlerPtr->deleteProc != NULL) { (handlerPtr->deleteProc)(handlerPtr->clientData); @@ -3401,31 +3309,40 @@ handlerPtr->flags |= LIMIT_HANDLER_DELETED; handlerPtr->prevPtr = NULL; handlerPtr->nextPtr = NULL; /* - * If nothing is currently executing the handler, delete its - * client data and the overall handler structure now. - * Otherwise it will all go away when the handler returns. + * If nothing is currently executing the handler, delete its client + * data and the overall handler structure now. Otherwise it will all + * go away when the handler returns. */ if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { if (handlerPtr->deleteProc != NULL) { (handlerPtr->deleteProc)(handlerPtr->clientData); } ckfree((char *) handlerPtr); } } + + /* + * Delete the timer callback that is used to trap limits that occur in + * [vwait]s... + */ + + if (iPtr->limit.timeEvent != NULL) { + Tcl_DeleteTimerHandler(iPtr->limit.timeEvent); + iPtr->limit.timeEvent = NULL; + } } /* *---------------------------------------------------------------------- * * Tcl_LimitTypeEnabled -- * - * Check whether a particular limit has been enabled for an - * interpreter. + * Check whether a particular limit has been enabled for an interpreter. * * Results: * A boolean value. * * Side effects: @@ -3447,16 +3364,15 @@ /* *---------------------------------------------------------------------- * * Tcl_LimitTypeExceeded -- * - * Check whether a particular limit has been exceeded for an - * interpreter. + * Check whether a particular limit has been exceeded for an interpreter. * * Results: - * A boolean value (note that Tcl_LimitExceeded will always - * return non-zero when this function returns non-zero). + * A boolean value (note that Tcl_LimitExceeded will always return + * non-zero when this function returns non-zero). * * Side effects: * None. * *---------------------------------------------------------------------- @@ -3481,13 +3397,13 @@ * * Results: * None. * * Side effects: - * The limit is turned on and will be checked in future at an - * interval determined by the frequency of calling of - * Tcl_LimitReady and the granularity of the limit in question. + * The limit is turned on and will be checked in future at an interval + * determined by the frequency of calling of Tcl_LimitReady and the + * granularity of the limit in question. * *---------------------------------------------------------------------- */ void @@ -3509,14 +3425,14 @@ * * Results: * None. * * Side effects: - * The limit is disabled. If the limit was exceeded when this - * function was called, the limit will no longer be exceeded - * afterwards and the interpreter will be free to execute further - * scripts (assuming it isn't also deleted, of course). + * The limit is disabled. If the limit was exceeded when this function + * was called, the limit will no longer be exceeded afterwards and the + * interpreter will be free to execute further scripts (assuming it isn't + * also deleted, of course). * *---------------------------------------------------------------------- */ void @@ -3539,14 +3455,13 @@ * * Results: * None. * * Side effects: - * Also resets whether the command limit was exceeded. This - * might permit a small amount of further execution in the - * interpreter even if the limit itself is theoretically - * exceeded. + * Also resets whether the command limit was exceeded. This might permit + * a small amount of further execution in the interpreter even if the + * limit itself is theoretically exceeded. * *---------------------------------------------------------------------- */ void @@ -3563,12 +3478,12 @@ /* *---------------------------------------------------------------------- * * Tcl_LimitGetCommands -- * - * Get the number of commands that may be executed in the - * interpreter before the command-limit is reached. + * Get the number of commands that may be executed in the interpreter + * before the command-limit is reached. * * Results: * An upper bound on the number of commands. * * Side effects: @@ -3589,20 +3504,20 @@ /* *---------------------------------------------------------------------- * * Tcl_LimitSetTime -- * - * Set the time limit for an interpreter by copying it from the - * value pointed to by the timeLimitPtr argument. + * Set the time limit for an interpreter by copying it from the value + * pointed to by the timeLimitPtr argument. * * Results: * None. * * Side effects: - * Also resets whether the time limit was exceeded. This might - * permit a small amount of further execution in the interpreter - * even if the limit itself is theoretically exceeded. + * Also resets whether the time limit was exceeded. This might permit a + * small amount of further execution in the interpreter even if the limit + * itself is theoretically exceeded. * *---------------------------------------------------------------------- */ void @@ -3609,25 +3524,70 @@ Tcl_LimitSetTime(interp, timeLimitPtr) Tcl_Interp *interp; Tcl_Time *timeLimitPtr; { Interp *iPtr = (Interp *) interp; + Tcl_Time nextMoment; memcpy(&iPtr->limit.time, timeLimitPtr, sizeof(Tcl_Time)); + if (iPtr->limit.timeEvent != NULL) { + Tcl_DeleteTimerHandler(iPtr->limit.timeEvent); + } + nextMoment.sec = timeLimitPtr->sec; + nextMoment.usec = timeLimitPtr->usec+10; + if (nextMoment.usec >= 1000000) { + nextMoment.sec++; + nextMoment.usec -= 1000000; + } + iPtr->limit.timeEvent = TclCreateAbsoluteTimerHandler(&nextMoment, + TimeLimitCallback, (ClientData) interp); iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS; } + +/* + *---------------------------------------------------------------------- + * + * TimeLimitCallback -- + * + * Callback that allows time limits to be enforced even when doing a + * blocking wait for events. + * + * Results: + * None. + * + * Side effects: + * May put the interpreter into a state where it can no longer execute + * commands. May make callbacks into other interpreters. + * + *---------------------------------------------------------------------- + */ + +static void +TimeLimitCallback(clientData) + ClientData clientData; +{ + Tcl_Interp *interp = (Tcl_Interp *) clientData; + + Tcl_Preserve((ClientData) interp); + ((Interp *)interp)->limit.timeEvent = NULL; + if (Tcl_LimitCheck(interp) != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (while waiting for event)"); + Tcl_BackgroundError(interp); + } + Tcl_Release((ClientData) interp); +} /* *---------------------------------------------------------------------- * * Tcl_LimitGetTime -- * * Get the current time limit. * * Results: - * The time limit (by it being copied into the variable pointed - * to by the timeLimitPtr). + * The time limit (by it being copied into the variable pointed to by the + * timeLimitPtr). * * Side effects: * None. * *---------------------------------------------------------------------- @@ -3646,12 +3606,12 @@ /* *---------------------------------------------------------------------- * * Tcl_LimitSetGranularity -- * - * Set the granularity divisor (which must be positive) for a - * particular limit. + * Set the granularity divisor (which must be positive) for a particular + * limit. * * Results: * None. * * Side effects: @@ -3711,27 +3671,26 @@ case TCL_LIMIT_TIME: return iPtr->limit.timeGranularity; } Tcl_Panic("unknown type of resource limit"); return -1; /* NOT REACHED */ -} +} /* *---------------------------------------------------------------------- * * DeleteScriptLimitCallback -- * - * Callback for when a script limit (a limit callback implemented - * as a Tcl script in a master interpreter, as set up from Tcl) - * is deleted. + * Callback for when a script limit (a limit callback implemented as a + * Tcl script in a master interpreter, as set up from Tcl) is deleted. * * Results: * None. * * Side effects: - * The reference to the script callback from the controlling - * interpreter is removed. + * The reference to the script callback from the controlling interpreter + * is removed. * *---------------------------------------------------------------------- */ static void @@ -3749,19 +3708,19 @@ /* *---------------------------------------------------------------------- * * CallScriptLimitCallback -- * - * Invoke a script limit callback. Used to implement limit - * callbacks set at the Tcl level on child interpreters. + * Invoke a script limit callback. Used to implement limit callbacks set + * at the Tcl level on child interpreters. * * Results: * None. * * Side effects: - * Depends on the callback script. Errors are reported as - * background errors. + * Depends on the callback script. Errors are reported as background + * errors. * *---------------------------------------------------------------------- */ static void @@ -3788,23 +3747,22 @@ /* *---------------------------------------------------------------------- * * SetScriptLimitCallback -- * - * Install (or remove, if scriptObj is NULL) a limit callback - * script that is called when the target interpreter exceeds the - * type of limit specified. Each interpreter may only have one - * callback set on another interpreter through this mechanism - * (though as many interpreters may be limited as the programmer - * chooses overall). + * Install (or remove, if scriptObj is NULL) a limit callback script that + * is called when the target interpreter exceeds the type of limit + * specified. Each interpreter may only have one callback set on another + * interpreter through this mechanism (though as many interpreters may be + * limited as the programmer chooses overall). * * Results: * None. * * Side effects: - * A limit callback implemented as an invokation of a Tcl script - * in another interpreter is either installed or removed. + * A limit callback implemented as an invokation of a Tcl script in + * another interpreter is either installed or removed. * *---------------------------------------------------------------------- */ static void @@ -3859,20 +3817,19 @@ /* *---------------------------------------------------------------------- * * TclRemoveScriptLimitCallbacks -- * - * Remove all script-implemented limit callbacks that make calls - * back into the given interpreter. This invoked as part of - * deleting an interpreter. + * Remove all script-implemented limit callbacks that make calls back + * into the given interpreter. This invoked as part of deleting an + * interpreter. * * Results: * None. * * Side effects: - * The script limit callbacks are removed or marked for later - * removal. + * The script limit callbacks are removed or marked for later removal. * *---------------------------------------------------------------------- */ void @@ -3898,14 +3855,13 @@ /* *---------------------------------------------------------------------- * * TclInitLimitSupport -- * - * Initialise all the parts of the interpreter relating to - * resource limit management. This allows an interpreter to both - * have limits set upon itself and set limits upon other - * interpreters. + * Initialise all the parts of the interpreter relating to resource limit + * management. This allows an interpreter to both have limits set upon + * itself and set limits upon other interpreters. * * Results: * None. * * Side effects: @@ -3926,10 +3882,11 @@ iPtr->limit.cmdCount = 0; iPtr->limit.cmdHandlers = NULL; iPtr->limit.cmdGranularity = 1; memset(&iPtr->limit.time, 0, sizeof(Tcl_Time)); iPtr->limit.timeHandlers = NULL; + iPtr->limit.timeEvent = NULL; iPtr->limit.timeGranularity = 10; Tcl_InitHashTable(&iPtr->limit.callbacks, sizeof(struct ScriptLimitCallbackKey)/sizeof(int)); } @@ -3936,21 +3893,21 @@ /* *---------------------------------------------------------------------- * * InheritLimitsFromMaster -- * - * Derive the interpreter limit configuration for a slave - * interpreter from the limit config for the master. + * Derive the interpreter limit configuration for a slave interpreter + * from the limit config for the master. * * Results: * None. * * Side effects: - * The slave interpreter limits are set so that if the master has - * a limit, it may not exceed it by handing off work to slave - * interpreters. Note that this does not transfer limit - * callbacks from the master to the slave. + * The slave interpreter limits are set so that if the master has a + * limit, it may not exceed it by handing off work to slave interpreters. + * Note that this does not transfer limit callbacks from the master to + * the slave. * *---------------------------------------------------------------------- */ static void @@ -4027,10 +3984,11 @@ } else { goto putEmptyCommandInDict; } } else { Tcl_Obj *empty; + putEmptyCommandInDict: TclNewObj(empty); Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), empty); } @@ -4149,13 +4107,12 @@ /* *---------------------------------------------------------------------- * * SlaveTimeLimitCmd -- * - * Implementation of the [interp limit $i time] and [$i limit - * time] subcommands. See the interp manual page for a full - * description. + * Implementation of the [interp limit $i time] and [$i limit time] + * subcommands. See the interp manual page for a full description. * * Results: * A standard Tcl result. * * Side effects: @@ -4340,14 +4297,14 @@ } } if (milliObj != NULL || secObj != NULL) { if (milliObj != NULL) { /* - * Setting -milliseconds but clearing -seconds, or - * resetting -milliseconds but not resetting -seconds? - * Bad voodoo! + * Setting -milliseconds but clearing -seconds, or resetting + * -milliseconds but not resetting -seconds? Bad voodoo! */ + if (secObj != NULL && secLen == 0 && milliLen > 0) { Tcl_AppendResult(interp, "may only set -milliseconds ", "if -seconds is not also being reset", NULL); return TCL_ERROR; } @@ -4359,14 +4316,14 @@ } if (milliLen > 0 || secLen > 0) { /* * Force usec to be in range [0..1000000), possibly - * incrementing sec in the process. This makes it - * much easier for people to write scripts that do - * small time increments. + * incrementing sec in the process. This makes it much easier + * for people to write scripts that do small time increments. */ + limitMoment.sec += limitMoment.usec / 1000000; limitMoment.usec %= 1000000; Tcl_LimitSetTime(slaveInterp, &limitMoment); Tcl_LimitTypeSet(slaveInterp, TCL_LIMIT_TIME); @@ -4382,5 +4339,13 @@ Tcl_LimitSetGranularity(slaveInterp, TCL_LIMIT_TIME, gran); } return TCL_OK; } } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclLink.c ================================================================== --- generic/tclLink.c +++ generic/tclLink.c @@ -1,101 +1,105 @@ -/* +/* * tclLink.c -- * - * This file implements linked variables (a C variable that is - * tied to a Tcl variable). The idea of linked variables was - * first suggested by Andreas Stolcke and this implementation is - * based heavily on a prototype implementation provided by - * him. + * This file implements linked variables (a C variable that is tied to a + * Tcl variable). The idea of linked variables was first suggested by + * Andreas Stolcke and this implementation is based heavily on a + * prototype implementation provided by him. * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLink.c,v 1.8 2002/08/05 03:24:41 dgp Exp $ + * RCS: @(#) $Id: tclLink.c,v 1.8.6.5 2005/09/09 18:48:40 dgp Exp $ */ #include "tclInt.h" /* - * For each linked variable there is a data structure of the following - * type, which describes the link and is the clientData for the trace - * set on the Tcl variable. + * For each linked variable there is a data structure of the following type, + * which describes the link and is the clientData for the trace set on the Tcl + * variable. */ typedef struct Link { Tcl_Interp *interp; /* Interpreter containing Tcl variable. */ - Tcl_Obj *varName; /* Name of variable (must be global). This - * is needed during trace callbacks, since - * the actual variable may be aliased at - * that time via upvar. */ + Tcl_Obj *varName; /* Name of variable (must be global). This is + * needed during trace callbacks, since the + * actual variable may be aliased at that time + * via upvar. */ char *addr; /* Location of C variable. */ int type; /* Type of link (TCL_LINK_INT, etc.). */ union { + char c; + unsigned char uc; int i; - double d; + unsigned int ui; + short s; + unsigned short us; + long l; + unsigned long ul; Tcl_WideInt w; - } lastValue; /* Last known value of C variable; used to + Tcl_WideUInt uw; + float f; + double d; + } lastValue; /* Last known value of C variable; used to * avoid string conversions. */ - int flags; /* Miscellaneous one-bit values; see below - * for definitions. */ + int flags; /* Miscellaneous one-bit values; see below for + * definitions. */ } Link; /* * Definitions for flag bits: * LINK_READ_ONLY - 1 means errors should be generated if Tcl * script attempts to write variable. - * LINK_BEING_UPDATED - 1 means that a call to Tcl_UpdateLinkedVar - * is in progress for this variable, so - * trace callbacks on the variable should - * be ignored. + * LINK_BEING_UPDATED - 1 means that a call to Tcl_UpdateLinkedVar is + * in progress for this variable, so trace + * callbacks on the variable should be ignored. */ #define LINK_READ_ONLY 1 #define LINK_BEING_UPDATED 2 /* * Forward references to procedures defined later in this file: */ -static char * LinkTraceProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, CONST char *name1, - CONST char *name2, int flags)); -static Tcl_Obj * ObjValue _ANSI_ARGS_((Link *linkPtr)); +static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp, + CONST char *name1, CONST char *name2, int flags); +static Tcl_Obj * ObjValue(Link *linkPtr); /* *---------------------------------------------------------------------- * * Tcl_LinkVar -- * - * Link a C variable to a Tcl variable so that changes to either - * one causes the other to change. + * Link a C variable to a Tcl variable so that changes to either one + * causes the other to change. * * Results: - * The return value is TCL_OK if everything went well or TCL_ERROR - * if an error occurred (the interp's result is also set after - * errors). + * The return value is TCL_OK if everything went well or TCL_ERROR if an + * error occurred (the interp's result is also set after errors). * * Side effects: - * The value at *addr is linked to the Tcl variable "varName", - * using "type" to convert between string values for Tcl and - * binary values for *addr. + * The value at *addr is linked to the Tcl variable "varName", using + * "type" to convert between string values for Tcl and binary values for + * *addr. * *---------------------------------------------------------------------- */ int Tcl_LinkVar(interp, varName, addr, type) Tcl_Interp *interp; /* Interpreter in which varName exists. */ CONST char *varName; /* Name of a global variable in interp. */ - char *addr; /* Address of a C variable to be linked - * to varName. */ - int type; /* Type of C variable: TCL_LINK_INT, etc. - * Also may have TCL_LINK_READ_ONLY - * OR'ed in. */ + char *addr; /* Address of a C variable to be linked to + * varName. */ + int type; /* Type of C variable: TCL_LINK_INT, etc. Also + * may have TCL_LINK_READ_ONLY OR'ed in. */ { Tcl_Obj *objPtr; Link *linkPtr; int code; @@ -137,20 +141,20 @@ * * Results: * None. * * Side effects: - * If "varName" was previously linked to a C variable, the link - * is broken to make the variable independent. If there was no - * previous link for "varName" then nothing happens. + * If "varName" was previously linked to a C variable, the link is broken + * to make the variable independent. If there was no previous link for + * "varName" then nothing happens. * *---------------------------------------------------------------------- */ void Tcl_UnlinkVar(interp, varName) - Tcl_Interp *interp; /* Interpreter containing variable to unlink. */ + Tcl_Interp *interp; /* Interpreter containing variable to unlink */ CONST char *varName; /* Global variable in interp to unlink. */ { Link *linkPtr; linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, @@ -168,20 +172,20 @@ /* *---------------------------------------------------------------------- * * Tcl_UpdateLinkedVar -- * - * This procedure is invoked after a linked variable has been - * changed by C code. It updates the Tcl variable so that - * traces on the variable will trigger. + * This procedure is invoked after a linked variable has been changed by + * C code. It updates the Tcl variable so that traces on the variable + * will trigger. * * Results: * None. * * Side effects: - * The Tcl variable "varName" is updated from its C value, - * causing traces on the variable to trigger. + * The Tcl variable "varName" is updated from its C value, causing traces + * on the variable to trigger. * *---------------------------------------------------------------------- */ void @@ -207,22 +211,22 @@ /* *---------------------------------------------------------------------- * * LinkTraceProc -- * - * This procedure is invoked when a linked Tcl variable is read, - * written, or unset from Tcl. It's responsible for keeping the - * C variable in sync with the Tcl variable. + * This procedure is invoked when a linked Tcl variable is read, written, + * or unset from Tcl. It's responsible for keeping the C variable in sync + * with the Tcl variable. * * Results: - * If all goes well, NULL is returned; otherwise an error message - * is returned. + * If all goes well, NULL is returned; otherwise an error message is + * returned. * * Side effects: - * The C variable may be updated to make it consistent with the - * Tcl variable, or the Tcl variable may be overwritten to reject - * a modification. + * The C variable may be updated to make it consistent with the Tcl + * variable, or the Tcl variable may be overwritten to reject a + * modification. * *---------------------------------------------------------------------- */ static char * @@ -234,16 +238,19 @@ int flags; /* Miscellaneous additional information. */ { Link *linkPtr = (Link *) clientData; int changed, valueLength; CONST char *value; - char **pp, *result; - Tcl_Obj *objPtr, *valueObj; + char **pp; + Tcl_Obj *valueObj; + int valueInt; + Tcl_WideInt valueWide; + double valueDouble; /* - * If the variable is being unset, then just re-create it (with a - * trace) unless the whole interpreter is going away. + * If the variable is being unset, then just re-create it (with a trace) + * unless the whole interpreter is going away. */ if (flags & TCL_TRACE_UNSETS) { if (flags & TCL_INTERP_DESTROYED) { Tcl_DecrRefCount(linkPtr->varName); @@ -257,23 +264,22 @@ } return NULL; } /* - * If we were invoked because of a call to Tcl_UpdateLinkedVar, then - * don't do anything at all. In particular, we don't want to get - * upset that the variable is being modified, even if it is - * supposed to be read-only. + * If we were invoked because of a call to Tcl_UpdateLinkedVar, then don't + * do anything at all. In particular, we don't want to get upset that the + * variable is being modified, even if it is supposed to be read-only. */ if (linkPtr->flags & LINK_BEING_UPDATED) { return NULL; } /* - * For read accesses, update the Tcl variable if the C variable - * has changed since the last time we updated the Tcl variable. + * For read accesses, update the Tcl variable if the C variable has + * changed since the last time we updated the Tcl variable. */ if (flags & TCL_TRACE_READS) { switch (linkPtr->type) { case TCL_LINK_INT: @@ -284,10 +290,42 @@ changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d; break; case TCL_LINK_WIDE_INT: changed = *(Tcl_WideInt *)(linkPtr->addr) != linkPtr->lastValue.w; break; + case TCL_LINK_WIDE_UINT: + changed = *(Tcl_WideUInt *)(linkPtr->addr) != + linkPtr->lastValue.uw; + break; + case TCL_LINK_CHAR: + changed = *(char *)(linkPtr->addr) != linkPtr->lastValue.c; + break; + case TCL_LINK_UCHAR: + changed = *(unsigned char *)(linkPtr->addr) != + linkPtr->lastValue.uc; + break; + case TCL_LINK_SHORT: + changed = *(short *)(linkPtr->addr) != linkPtr->lastValue.s; + break; + case TCL_LINK_USHORT: + changed = *(unsigned short *)(linkPtr->addr) != + linkPtr->lastValue.us; + break; + case TCL_LINK_UINT: + changed = *(unsigned int *)(linkPtr->addr) != + linkPtr->lastValue.ui; + break; + case TCL_LINK_LONG: + changed = *(long *)(linkPtr->addr) != linkPtr->lastValue.l; + break; + case TCL_LINK_ULONG: + changed = *(unsigned long *)(linkPtr->addr) != + linkPtr->lastValue.ul; + break; + case TCL_LINK_FLOAT: + changed = *(float *)(linkPtr->addr) != linkPtr->lastValue.f; + break; case TCL_LINK_STRING: changed = 1; break; default: return "internal error: bad linked variable type"; @@ -298,16 +336,16 @@ } return NULL; } /* - * For writes, first make sure that the variable is writable. Then - * convert the Tcl value to C if possible. If the variable isn't - * writable or can't be converted, then restore the varaible's old - * value and return an error. Another tricky thing: we have to save - * and restore the interpreter's result, since the variable access - * could occur when the result has been partially set. + * For writes, first make sure that the variable is writable. Then convert + * the Tcl value to C if possible. If the variable isn't writable or can't + * be converted, then restore the varaible's old value and return an + * error. Another tricky thing: we have to save and restore the interp's + * result, since the variable access could occur when the result has been + * partially set. */ if (linkPtr->flags & LINK_READ_ONLY) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); @@ -319,63 +357,158 @@ * This shouldn't ever happen. */ return "internal error: linked variable couldn't be read"; } - objPtr = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(objPtr); - Tcl_ResetResult(interp); - result = NULL; - switch (linkPtr->type) { case TCL_LINK_INT: - if (Tcl_GetIntFromObj(interp, valueObj, &linkPtr->lastValue.i) + if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK) { - Tcl_SetObjResult(interp, objPtr); Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - result = "variable must have integer value"; - goto end; + return "variable must have integer value"; } *(int *)(linkPtr->addr) = linkPtr->lastValue.i; break; case TCL_LINK_WIDE_INT: - if (Tcl_GetWideIntFromObj(interp, valueObj, &linkPtr->lastValue.w) + if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w) != TCL_OK) { - Tcl_SetObjResult(interp, objPtr); Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - result = "variable must have integer value"; - goto end; + return "variable must have integer value"; } *(Tcl_WideInt *)(linkPtr->addr) = linkPtr->lastValue.w; break; case TCL_LINK_DOUBLE: - if (Tcl_GetDoubleFromObj(interp, valueObj, &linkPtr->lastValue.d) + if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) != TCL_OK) { - Tcl_SetObjResult(interp, objPtr); +#ifdef ACCEPT_NAN + if (valueObj->typePtr != &tclDoubleType) { +#endif Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - result = "variable must have real value"; - goto end; + return "variable must have real value"; +#ifdef ACCEPT_NAN + } + linkPtr->lastValue.d = valueObj->internalRep.doubleValue; +#endif } *(double *)(linkPtr->addr) = linkPtr->lastValue.d; break; case TCL_LINK_BOOLEAN: - if (Tcl_GetBooleanFromObj(interp, valueObj, &linkPtr->lastValue.i) + if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK) { - Tcl_SetObjResult(interp, objPtr); Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - result = "variable must have boolean value"; - goto end; + return "variable must have boolean value"; } *(int *)(linkPtr->addr) = linkPtr->lastValue.i; break; + + case TCL_LINK_CHAR: + if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK + || valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return "variable must have char value"; + } + linkPtr->lastValue.c = (char)valueInt; + *(char *)(linkPtr->addr) = linkPtr->lastValue.c; + break; + + case TCL_LINK_UCHAR: + if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK + || valueInt < 0 || valueInt > UCHAR_MAX) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return "variable must have unsigned char value"; + } + linkPtr->lastValue.uc = (unsigned char) valueInt; + *(unsigned char *)(linkPtr->addr) = linkPtr->lastValue.uc; + break; + + case TCL_LINK_SHORT: + if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK + || valueInt < SHRT_MIN || valueInt > SHRT_MAX) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return "variable must have short value"; + } + linkPtr->lastValue.s = (short)valueInt; + *(short *)(linkPtr->addr) = linkPtr->lastValue.s; + break; + + case TCL_LINK_USHORT: + if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK + || valueInt < 0 || valueInt > USHRT_MAX) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return "variable must have unsigned short value"; + } + linkPtr->lastValue.us = (unsigned short)valueInt; + *(unsigned short *)(linkPtr->addr) = linkPtr->lastValue.us; + break; + + case TCL_LINK_UINT: + if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK + || valueWide < 0 || valueWide > UINT_MAX) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return "variable must have unsigned int value"; + } + linkPtr->lastValue.ui = (unsigned int)valueWide; + *(unsigned int *)(linkPtr->addr) = linkPtr->lastValue.ui; + break; + + case TCL_LINK_LONG: + if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK + || valueWide < LONG_MIN || valueWide > LONG_MAX) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return "variable must have long value"; + } + linkPtr->lastValue.l = (long)valueWide; + *(long *)(linkPtr->addr) = linkPtr->lastValue.l; + break; + + case TCL_LINK_ULONG: + if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK + || valueWide < 0 || valueWide > ULONG_MAX) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return "variable must have unsigned long value"; + } + linkPtr->lastValue.ul = (unsigned long)valueWide; + *(unsigned long *)(linkPtr->addr) = linkPtr->lastValue.ul; + break; + + case TCL_LINK_WIDE_UINT: + /* + * FIXME: represent as a bignum. + */ + if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return "variable must have unsigned wide int value"; + } + linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide; + *(Tcl_WideUInt *)(linkPtr->addr) = linkPtr->lastValue.uw; + break; + + case TCL_LINK_FLOAT: + if (Tcl_GetDoubleFromObj(interp, valueObj, &valueDouble) != TCL_OK + || valueDouble < FLT_MIN || valueDouble > FLT_MAX) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return "variable must have float value"; + } + linkPtr->lastValue.f = (float)valueDouble; + *(float *)(linkPtr->addr) = linkPtr->lastValue.f; + break; case TCL_LINK_STRING: value = Tcl_GetStringFromObj(valueObj, &valueLength); valueLength++; pp = (char **)(linkPtr->addr); @@ -387,26 +520,24 @@ break; default: return "internal error: bad linked variable type"; } - end: - Tcl_DecrRefCount(objPtr); - return result; + return NULL; } /* *---------------------------------------------------------------------- * * ObjValue -- * - * Converts the value of a C variable to a Tcl_Obj* for use in a - * Tcl variable to which it is linked. + * Converts the value of a C variable to a Tcl_Obj* for use in a Tcl + * variable to which it is linked. * * Results: - * The return value is a pointer to a Tcl_Obj that represents - * the value of the C variable given by linkPtr. + * The return value is a pointer to a Tcl_Obj that represents the value + * of the C variable given by linkPtr. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -429,20 +560,58 @@ linkPtr->lastValue.d = *(double *)(linkPtr->addr); return Tcl_NewDoubleObj(linkPtr->lastValue.d); case TCL_LINK_BOOLEAN: linkPtr->lastValue.i = *(int *)(linkPtr->addr); return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0); + case TCL_LINK_CHAR: + linkPtr->lastValue.c = *(char *)(linkPtr->addr); + return Tcl_NewIntObj(linkPtr->lastValue.c); + case TCL_LINK_UCHAR: + linkPtr->lastValue.uc = *(unsigned char *)(linkPtr->addr); + return Tcl_NewIntObj(linkPtr->lastValue.uc); + case TCL_LINK_SHORT: + linkPtr->lastValue.s = *(short *)(linkPtr->addr); + return Tcl_NewIntObj(linkPtr->lastValue.s); + case TCL_LINK_USHORT: + linkPtr->lastValue.us = *(unsigned short *)(linkPtr->addr); + return Tcl_NewIntObj(linkPtr->lastValue.us); + case TCL_LINK_UINT: + linkPtr->lastValue.ui = *(unsigned int *)(linkPtr->addr); + return Tcl_NewWideIntObj(linkPtr->lastValue.ui); + case TCL_LINK_LONG: + linkPtr->lastValue.l = *(long *)(linkPtr->addr); + return Tcl_NewWideIntObj(linkPtr->lastValue.l); + case TCL_LINK_ULONG: + linkPtr->lastValue.ul = *(unsigned long *)(linkPtr->addr); + return Tcl_NewWideIntObj(linkPtr->lastValue.ul); + case TCL_LINK_FLOAT: + linkPtr->lastValue.f = *(float *)(linkPtr->addr); + return Tcl_NewDoubleObj(linkPtr->lastValue.f); + case TCL_LINK_WIDE_UINT: + linkPtr->lastValue.uw = *(Tcl_WideUInt *)(linkPtr->addr); + /* + * FIXME: represent as a bignum. + */ + return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw); case TCL_LINK_STRING: p = *(char **)(linkPtr->addr); if (p == NULL) { return Tcl_NewStringObj("NULL", 4); } return Tcl_NewStringObj(p, -1); /* - * This code only gets executed if the link type is unknown - * (shouldn't ever happen). + * This code only gets executed if the link type is unknown (shouldn't + * ever happen). */ default: return Tcl_NewStringObj("??", 2); } } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclListObj.c ================================================================== --- generic/tclListObj.c +++ generic/tclListObj.c @@ -1,74 +1,143 @@ -/* +/* * tclListObj.c -- * - * This file contains procedures that implement the Tcl list object - * type. + * This file contains functions that implement the Tcl list object type. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1998 by Scriptics Corporation. * Copyright (c) 2001 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. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclListObj.c,v 1.20 2004/11/11 01:17:51 das Exp $ + * RCS: @(#) $Id: tclListObj.c,v 1.20.2.4 2005/09/09 18:48:40 dgp Exp $ */ #include "tclInt.h" /* - * Prototypes for procedures defined later in this file: + * Prototypes for functions defined later in this file: */ -static void DupListInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, - Tcl_Obj *copyPtr)); -static void FreeListInternalRep _ANSI_ARGS_((Tcl_Obj *listPtr)); -static int SetListFromAny _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); -static void UpdateStringOfList _ANSI_ARGS_((Tcl_Obj *listPtr)); +static List * NewListIntRep(int objc, Tcl_Obj *CONST objv[]); +static void DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); +static void FreeListInternalRep(Tcl_Obj *listPtr); +static int SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +static void UpdateStringOfList(Tcl_Obj *listPtr); /* - * The structure below defines the list Tcl object type by means of - * procedures that can be invoked by generic object code. + * The structure below defines the list Tcl object type by means of functions + * that can be invoked by generic object code. * * The internal representation of a list object is a two-pointer - * representation. The first pointer designates a List structure that - * contains an array of pointers to the element objects, together with - * integers that represent the current element count and the allocated - * size of the array. The second pointer is normally NULL; during - * execution of functions in this file that operate on nested sublists, - * it is occasionally used as working storage to avoid an auxiliary - * stack. + * representation. The first pointer designates a List structure that contains + * an array of pointers to the element objects, together with integers that + * represent the current element count and the allocated size of the array. + * The second pointer is normally NULL; during execution of functions in this + * file that operate on nested sublists, it is occasionally used as working + * storage to avoid an auxiliary stack. */ Tcl_ObjType tclListType = { - "list", /* name */ - FreeListInternalRep, /* freeIntRepProc */ - DupListInternalRep, /* dupIntRepProc */ - UpdateStringOfList, /* updateStringProc */ - SetListFromAny /* setFromAnyProc */ + "list", /* name */ + FreeListInternalRep, /* freeIntRepProc */ + DupListInternalRep, /* dupIntRepProc */ + UpdateStringOfList, /* updateStringProc */ + NULL /* setFromAnyProc */ }; + + +/* + *---------------------------------------------------------------------- + * + * NewListIntRep -- + * + * If objc>0 and objv!=NULL, this function creates a list internal rep + * with objc elements given in the array objv. + * If objc>0 and objv==NULL it creates the list internal rep of a list + * with 0 elements, where enough space has been preallocated to store + * objc elements. + * If objc<=0, it returns NULL. + * + * Results: + * A new List struct is returned. If objc<=0 or if the allocation fails + * for lack of memory, NULL is returned. The list returned has refCount + * 0. + * + * Side effects: + * The ref counts of the elements in objv are incremented since the + * resulting list now refers to them. + * + *---------------------------------------------------------------------- + */ + +static List* +NewListIntRep(objc, objv) + int objc; + Tcl_Obj *CONST objv[]; +{ + Tcl_Obj **elemPtrs; + List *listRepPtr; + int i; + + if (objc <= 0) { + return NULL; + } + + /* + * First check to see if we'd overflow and try to allocate an object + * larger than our memory allocator allows. Note that this is actually a + * fairly small value when you're on a serious 64-bit machine, but that + * requires API changes to fix. + */ + + if (objc > INT_MAX/sizeof(Tcl_Obj *)) { + return NULL; + } + + listRepPtr = (List *) attemptckalloc(sizeof(List) + + ((objc-1) * sizeof(Tcl_Obj *))); + if (listRepPtr == NULL) { + return NULL; + } + + listRepPtr->canonicalFlag = 0; + listRepPtr->refCount = 0; + listRepPtr->maxElemCount = objc; + + if (objv) { + listRepPtr->elemCount = objc; + elemPtrs = &listRepPtr->elements; + for (i = 0; i < objc; i++) { + elemPtrs[i] = objv[i]; + Tcl_IncrRefCount(elemPtrs[i]); + } + } else { + listRepPtr->elemCount = 0; + } + return listRepPtr; +} /* *---------------------------------------------------------------------- * * Tcl_NewListObj -- * - * This procedure is normally called when not debugging: i.e., when + * This function is normally called when not debugging: i.e., when * TCL_MEM_DEBUG is not defined. It creates a new list object from an * (objc,objv) array: that is, each of the objc elements of the array * referenced by objv is inserted as an element into a new Tcl object. * - * When TCL_MEM_DEBUG is defined, this procedure just returns the - * result of calling the debugging version Tcl_DbNewListObj. + * When TCL_MEM_DEBUG is defined, this function just returns the result + * of calling the debugging version Tcl_DbNewListObj. * * Results: * A new list object is returned that is initialized from the object * pointers in objv. If objc is less than or equal to zero, an empty - * object is returned. The new object's string representation - * is left NULL. The resulting new list object has ref count 0. + * object is returned. The new object's string representation is left + * NULL. The resulting new list object has ref count 0. * * Side effects: * The ref counts of the elements in objv are incremented since the * resulting list now refers to them. * @@ -91,61 +160,63 @@ Tcl_Obj * Tcl_NewListObj(objc, objv) int objc; /* Count of objects referenced by objv. */ Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */ { - register Tcl_Obj *listPtr; - register Tcl_Obj **elemPtrs; - register List *listRepPtr; - int i; + List *listRepPtr; + Tcl_Obj *listPtr; TclNewObj(listPtr); - if (objc > 0) { - Tcl_InvalidateStringRep(listPtr); - - elemPtrs = (Tcl_Obj **) - ckalloc((unsigned) (objc * sizeof(Tcl_Obj *))); - for (i = 0; i < objc; i++) { - elemPtrs[i] = objv[i]; - Tcl_IncrRefCount(elemPtrs[i]); - } - - listRepPtr = (List *) ckalloc(sizeof(List)); - listRepPtr->maxElemCount = objc; - listRepPtr->elemCount = objc; - listRepPtr->elements = elemPtrs; - - listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; - listPtr->internalRep.twoPtrValue.ptr2 = NULL; - listPtr->typePtr = &tclListType; - } + if (objc <= 0) { + return listPtr; + } + + /* + * Create the internal rep. + */ + + listRepPtr = NewListIntRep(objc, objv); + if (!listRepPtr) { + Tcl_Panic("Not enough memory to create the list\n"); + } + + /* + * Now create the object. + */ + + Tcl_InvalidateStringRep(listPtr); + listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; + listPtr->internalRep.twoPtrValue.ptr2 = NULL; + listPtr->typePtr = &tclListType; + listRepPtr->refCount++; + return listPtr; } #endif /* if TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_DbNewListObj -- * - * This procedure is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. It creates new list objects. It is the - * same as the Tcl_NewListObj procedure above except that it calls + * This function is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. It creates new list objects. It is the same + * as the Tcl_NewListObj function above except that it calls * Tcl_DbCkalloc directly with the file name and line number from its * caller. This simplifies debugging since then the [memory active] - * command will report the correct file name and line number when + * command will report the correct file name and line number when * reporting objects that haven't been freed. * - * When TCL_MEM_DEBUG is not defined, this procedure just returns the + * When TCL_MEM_DEBUG is not defined, this function just returns the * result of calling Tcl_NewListObj. * * Results: * A new list object is returned that is initialized from the object * pointers in objv. If objc is less than or equal to zero, an empty - * object is returned. The new object's string representation - * is left NULL. The new list object has ref count 0. + * object is returned. The new object's string representation is left + * NULL. The new list object has ref count 0. * * Side effects: * The ref counts of the elements in objv are incremented since the * resulting list now refers to them. * @@ -157,40 +228,42 @@ Tcl_Obj * Tcl_DbNewListObj(objc, objv, file, line) int objc; /* Count of objects referenced by objv. */ Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */ CONST char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ -{ - register Tcl_Obj *listPtr; - register Tcl_Obj **elemPtrs; - register List *listRepPtr; - int i; + * function; used for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ +{ + Tcl_Obj *listPtr; + List *listRepPtr; TclDbNewObj(listPtr, file, line); - if (objc > 0) { - Tcl_InvalidateStringRep(listPtr); - - elemPtrs = (Tcl_Obj **) - ckalloc((unsigned) (objc * sizeof(Tcl_Obj *))); - for (i = 0; i < objc; i++) { - elemPtrs[i] = objv[i]; - Tcl_IncrRefCount(elemPtrs[i]); - } - - listRepPtr = (List *) ckalloc(sizeof(List)); - listRepPtr->maxElemCount = objc; - listRepPtr->elemCount = objc; - listRepPtr->elements = elemPtrs; - - listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; - listPtr->internalRep.twoPtrValue.ptr2 = NULL; - listPtr->typePtr = &tclListType; - } + if (objc <= 0) { + return listPtr; + } + + /* + * Create the internal rep. + */ + + listRepPtr = NewListIntRep(objc, objv); + if (!listRepPtr) { + Tcl_Panic("Not enough memory to create the list\n"); + } + + /* + * Now create the object. + */ + + Tcl_InvalidateStringRep(listPtr); + listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; + listPtr->internalRep.twoPtrValue.ptr2 = NULL; + listPtr->typePtr = &tclListType; + listRepPtr->refCount++; + return listPtr; } #else /* if not TCL_MEM_DEBUG */ @@ -197,150 +270,36 @@ Tcl_Obj * Tcl_DbNewListObj(objc, objv, file, line) int objc; /* Count of objects referenced by objv. */ Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */ CONST char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + * function; used for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { return Tcl_NewListObj(objc, objv); } #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * - * TclNewListObjDirect, TclDbNewListObjDirect -- - * - * Version of Tcl_NewListOb/Tcl_DbNewListObj that does not copy - * the array of Tcl_Objs. It still scans it though to update the - * reference counts. - * - * Results: - * A new list object is returned that is initialized from the object - * pointers in objv. If objc is less than or equal to zero, an empty - * object is returned (and "ownership" of the array of objects is - * not transferred.) The new object's string representation is left - * NULL. The resulting new list object has ref count 0. - * - * Side effects: - * The ref counts of the elements in objv are incremented since the - * resulting list now refers to them. - * - *---------------------------------------------------------------------- - */ - -#ifdef TCL_MEM_DEBUG -#undef TclNewListObjDirect -Tcl_Obj * -TclNewListObjDirect(objc, objv) - int objc; /* Count of objects referenced by objv. */ - Tcl_Obj **objv; /* An array of pointers to Tcl objects. */ -{ - return TclDbNewListObjDirect(objc, objv, "unknown", 0); -} -#else /* !TCL_MEM_DEBUG */ -Tcl_Obj * -TclNewListObjDirect(objc, objv) - int objc; /* Count of objects referenced by objv. */ - Tcl_Obj **objv; /* An array of pointers to Tcl objects. */ -{ - register Tcl_Obj *listPtr; - - TclNewObj(listPtr); - - if (objc > 0) { - register List *listRepPtr; - int i; - - Tcl_InvalidateStringRep(listPtr); - - for (i=0 ; imaxElemCount = objc; - listRepPtr->elemCount = objc; - listRepPtr->elements = objv; - - listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; - listPtr->internalRep.twoPtrValue.ptr2 = NULL; - listPtr->typePtr = &tclListType; - } - return listPtr; -} -#endif /* TCL_MEM_DEBUG */ - -#ifdef TCL_MEM_DEBUG -Tcl_Obj * -TclDbNewListObjDirect(objc, objv, file, line) - int objc; /* Count of objects referenced by objv. */ - Tcl_Obj **objv; /* An array of pointers to Tcl objects. */ - CONST char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ -{ - register Tcl_Obj *listPtr; - - TclDbNewObj(listPtr, file, line); - - if (objc > 0) { - register List *listRepPtr; - int i; - - Tcl_InvalidateStringRep(listPtr); - - for (i=0 ; imaxElemCount = objc; - listRepPtr->elemCount = objc; - listRepPtr->elements = objv; - - listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; - listPtr->internalRep.twoPtrValue.ptr2 = NULL; - listPtr->typePtr = &tclListType; - } - return listPtr; -} -#else /* !TCL_MEM_DEBUG */ -Tcl_Obj * -TclDbNewListObjDirect(objc, objv, file, line) - int objc; /* Count of objects referenced by objv. */ - Tcl_Obj **objv; /* An array of pointers to Tcl objects. */ - CONST char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ -{ - return TclNewListObjDirect(objc, objv); -} -#endif /* TCL_MEM_DEBUG */ - -/* - *---------------------------------------------------------------------- - * * Tcl_SetListObj -- * - * Modify an object to be a list containing each of the objc elements - * of the object array referenced by objv. + * Modify an object to be a list containing each of the objc elements of + * the object array referenced by objv. * * Results: * None. * * Side effects: * The object is made a list object and is initialized from the object * pointers in objv. If objc is less than or equal to zero, an empty - * object is returned. The new object's string representation - * is left NULL. The ref counts of the elements in objv are incremented - * since the list now refers to them. The object's old string and - * internal representations are freed and its type is set NULL. + * object is returned. The new object's string representation is left + * NULL. The ref counts of the elements in objv are incremented since the + * list now refers to them. The object's old string and internal + * representations are freed and its type is set NULL. * *---------------------------------------------------------------------- */ void @@ -347,13 +306,11 @@ Tcl_SetListObj(objPtr, objc, objv) Tcl_Obj *objPtr; /* Object whose internal rep to init. */ int objc; /* Count of objects referenced by objv. */ Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */ { - register Tcl_Obj **elemPtrs; - register List *listRepPtr; - int i; + List *listRepPtr; if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetListObj called with shared object"); } @@ -365,30 +322,23 @@ objPtr->typePtr = NULL; Tcl_InvalidateStringRep(objPtr); /* * Set the object's type to "list" and initialize the internal rep. - * However, if there are no elements to put in the list, just give - * the object an empty string rep and a NULL type. + * However, if there are no elements to put in the list, just give the + * object an empty string rep and a NULL type. */ if (objc > 0) { - elemPtrs = (Tcl_Obj **) - ckalloc((unsigned) (objc * sizeof(Tcl_Obj *))); - for (i = 0; i < objc; i++) { - elemPtrs[i] = objv[i]; - Tcl_IncrRefCount(elemPtrs[i]); - } - - listRepPtr = (List *) ckalloc(sizeof(List)); - listRepPtr->maxElemCount = objc; - listRepPtr->elemCount = objc; - listRepPtr->elements = elemPtrs; - + listRepPtr = NewListIntRep(objc, objv); + if (!listRepPtr) { + Tcl_Panic("Cannot allocate enough memory for Tcl_SetListObj"); + } objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclListType; + listRepPtr->refCount++; } else { objPtr->bytes = tclEmptyStringRep; objPtr->length = 0; } } @@ -396,27 +346,27 @@ /* *---------------------------------------------------------------------- * * Tcl_ListObjGetElements -- * - * This procedure returns an (objc,objv) array of the elements in a - * list object. + * This function returns an (objc,objv) array of the elements in a list + * object. * * Results: * The return value is normally TCL_OK; in this case *objcPtr is set to * the count of list elements and *objvPtr is set to a pointer to an - * array of (*objcPtr) pointers to each list element. If listPtr does - * not refer to a list object and the object can not be converted to - * one, TCL_ERROR is returned and an error message will be left in - * the interpreter's result if interp is not NULL. + * array of (*objcPtr) pointers to each list element. If listPtr does not + * refer to a list object and the object can not be converted to one, + * TCL_ERROR is returned and an error message will be left in the + * interpreter's result if interp is not NULL. * * The objects referenced by the returned array should be treated as * readonly and their ref counts are _not_ incremented; the caller must - * do that if it holds on to a reference. Furthermore, the pointer - * and length returned by this procedure may change as soon as any - * procedure is called on the list object; be careful about retaining - * the pointer in a local data structure. + * do that if it holds on to a reference. Furthermore, the pointer and + * length returned by this function may change as soon as any function is + * called on the list object; be careful about retaining the pointer in a + * local data structure. * * Side effects: * The possible conversion of the object referenced by listPtr * to a list object. * @@ -424,52 +374,61 @@ */ int Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) Tcl_Interp *interp; /* Used to report errors if not NULL. */ - register Tcl_Obj *listPtr; /* List object for which an element array - * is to be returned. */ + register Tcl_Obj *listPtr; /* List object for which an element array is + * to be returned. */ int *objcPtr; /* Where to store the count of objects * referenced by objv. */ - Tcl_Obj ***objvPtr; /* Where to store the pointer to an array - * of pointers to the list's objects. */ + Tcl_Obj ***objvPtr; /* Where to store the pointer to an array of + * pointers to the list's objects. */ { register List *listRepPtr; if (listPtr->typePtr != &tclListType) { - int result = SetListFromAny(interp, listPtr); + int result, length; + + (void) Tcl_GetStringFromObj(listPtr, &length); + if (!length) { + *objcPtr = 0; + *objvPtr = NULL; + return TCL_OK; + } + + result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; *objcPtr = listRepPtr->elemCount; - *objvPtr = listRepPtr->elements; + *objvPtr = &listRepPtr->elements; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ListObjAppendList -- * - * This procedure appends the objects in the list referenced by + * This function appends the objects in the list referenced by * elemListPtr to the list object referenced by listPtr. If listPtr is * not already a list object, an attempt will be made to convert it to * one. * * Results: - * The return value is normally TCL_OK. If listPtr or elemListPtr do - * not refer to list objects and they can not be converted to one, - * TCL_ERROR is returned and an error message is left in - * the interpreter's result if interp is not NULL. + * The return value is normally TCL_OK. If listPtr or elemListPtr do not + * refer to list objects and they can not be converted to one, TCL_ERROR + * is returned and an error message is left in the interpreter's result + * if interp is not NULL. * * Side effects: * The reference counts of the elements in elemListPtr are incremented * since the list now refers to them. listPtr and elemListPtr are - * converted, if necessary, to list objects. Also, appending the - * new elements may cause listObj's array of element pointers to grow. + * converted, if necessary, to list objects. Also, appending the new + * elements may cause listObj's array of element pointers to grow. * listPtr's old string representation, if any, is invalidated. * *---------------------------------------------------------------------- */ @@ -477,25 +436,21 @@ Tcl_ListObjAppendList(interp, listPtr, elemListPtr) Tcl_Interp *interp; /* Used to report errors if not NULL. */ register Tcl_Obj *listPtr; /* List object to append elements to. */ Tcl_Obj *elemListPtr; /* List obj with elements to append. */ { - register List *listRepPtr; int listLen, objc, result; Tcl_Obj **objv; if (Tcl_IsShared(listPtr)) { Tcl_Panic("Tcl_ListObjAppendList called with shared object"); } - if (listPtr->typePtr != &tclListType) { - result = SetListFromAny(interp, listPtr); - if (result != TCL_OK) { - return result; - } - } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; - listLen = listRepPtr->elemCount; + + result = Tcl_ListObjLength(interp, listPtr, &listLen); + if (result != TCL_OK) { + return result; + } result = Tcl_ListObjGetElements(interp, elemListPtr, &objc, &objv); if (result != TCL_OK) { return result; } @@ -511,28 +466,28 @@ /* *---------------------------------------------------------------------- * * Tcl_ListObjAppendElement -- * - * This procedure is a special purpose version of - * Tcl_ListObjAppendList: it appends a single object referenced by - * objPtr to the list object referenced by listPtr. If listPtr is not - * already a list object, an attempt will be made to convert it to one. + * This function is a special purpose version of Tcl_ListObjAppendList: + * it appends a single object referenced by objPtr to the list object + * referenced by listPtr. If listPtr is not already a list object, an + * attempt will be made to convert it to one. * * Results: - * The return value is normally TCL_OK; in this case objPtr is added - * to the end of listPtr's list. If listPtr does not refer to a list - * object and the object can not be converted to one, TCL_ERROR is - * returned and an error message will be left in the interpreter's - * result if interp is not NULL. + * The return value is normally TCL_OK; in this case objPtr is added to + * the end of listPtr's list. If listPtr does not refer to a list object + * and the object can not be converted to one, TCL_ERROR is returned and + * an error message will be left in the interpreter's result if interp is + * not NULL. * * Side effects: - * The ref count of objPtr is incremented since the list now refers - * to it. listPtr will be converted, if necessary, to a list object. - * Also, appending the new element may cause listObj's array of element - * pointers to grow. listPtr's old string representation, if any, - * is invalidated. + * The ref count of objPtr is incremented since the list now refers to + * it. listPtr will be converted, if necessary, to a list object. Also, + * appending the new element may cause listObj's array of element + * pointers to grow. listPtr's old string representation, if any, is + * invalidated. * *---------------------------------------------------------------------- */ int @@ -541,51 +496,78 @@ Tcl_Obj *listPtr; /* List object to append objPtr to. */ Tcl_Obj *objPtr; /* Object to append to listPtr's list. */ { register List *listRepPtr; register Tcl_Obj **elemPtrs; - int numElems, numRequired; + int numElems, numRequired, newMax, newSize, i; if (Tcl_IsShared(listPtr)) { Tcl_Panic("Tcl_ListObjAppendElement called with shared object"); } if (listPtr->typePtr != &tclListType) { - int result = SetListFromAny(interp, listPtr); + int result, length; + + (void) Tcl_GetStringFromObj(listPtr, &length); + if (!length) { + Tcl_SetListObj(listPtr, 1, &objPtr); + return TCL_OK; + } + + result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; - elemPtrs = listRepPtr->elements; numElems = listRepPtr->elemCount; numRequired = numElems + 1 ; /* - * If there is no room in the current array of element pointers, - * allocate a new, larger array and copy the pointers to it. + * If there is no room in the current array of element pointers, allocate + * a new, larger array and copy the pointers to it. If the List struct is + * shared, allocate a new one. */ - if (numRequired > listRepPtr->maxElemCount) { - int newMax = (2 * numRequired); - Tcl_Obj **newElemPtrs = (Tcl_Obj **) - ckalloc((unsigned) (newMax * sizeof(Tcl_Obj *))); - - memcpy((VOID *) newElemPtrs, (VOID *) elemPtrs, - (size_t) (numElems * sizeof(Tcl_Obj *))); - + if (numRequired > listRepPtr->maxElemCount){ + newMax = (2 * numRequired); + newSize = sizeof(List)+((newMax-1)*sizeof(Tcl_Obj*)); + } else { + newMax = listRepPtr->maxElemCount; + newSize = 0; + } + + if (listRepPtr->refCount > 1) { + List *oldListRepPtr = listRepPtr; + Tcl_Obj **oldElems; + + listRepPtr = NewListIntRep(newMax, NULL); + if (!listRepPtr) { + Tcl_Panic("Not enough memory to allocate list"); + } + oldElems = &oldListRepPtr->elements; + elemPtrs = &listRepPtr->elements; + for (i=0; ielemCount = numElems; + listRepPtr->refCount++; + oldListRepPtr->refCount--; + listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; + } else if (newSize) { + listRepPtr = (List *) ckrealloc((char *)listRepPtr, newSize); listRepPtr->maxElemCount = newMax; - listRepPtr->elements = newElemPtrs; - ckfree((char *) elemPtrs); - elemPtrs = newElemPtrs; + listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; } /* - * Add objPtr to the end of listPtr's array of element - * pointers. Increment the ref count for the (now shared) objPtr. + * Add objPtr to the end of listPtr's array of element pointers. Increment + * the ref count for the (now shared) objPtr. */ + elemPtrs = &listRepPtr->elements; elemPtrs[numElems] = objPtr; Tcl_IncrRefCount(objPtr); listRepPtr->elemCount++; /* @@ -600,24 +582,24 @@ /* *---------------------------------------------------------------------- * * Tcl_ListObjIndex -- * - * This procedure returns a pointer to the index'th object from the - * list referenced by listPtr. The first element has index 0. If index - * is negative or greater than or equal to the number of elements in - * the list, a NULL is returned. If listPtr is not a list object, an - * attempt will be made to convert it to a list. + * This function returns a pointer to the index'th object from the list + * referenced by listPtr. The first element has index 0. If index is + * negative or greater than or equal to the number of elements in the + * list, a NULL is returned. If listPtr is not a list object, an attempt + * will be made to convert it to a list. * * Results: - * The return value is normally TCL_OK; in this case objPtrPtr is set - * to the Tcl_Obj pointer for the index'th list element or NULL if - * index is out of range. This object should be treated as readonly and - * its ref count is _not_ incremented; the caller must do that if it - * holds on to the reference. If listPtr does not refer to a list and - * can't be converted to one, TCL_ERROR is returned and an error - * message is left in the interpreter's result if interp is not NULL. + * The return value is normally TCL_OK; in this case objPtrPtr is set to + * the Tcl_Obj pointer for the index'th list element or NULL if index is + * out of range. This object should be treated as readonly and its ref + * count is _not_ incremented; the caller must do that if it holds on to + * the reference. If listPtr does not refer to a list and can't be + * converted to one, TCL_ERROR is returned and an error message is left + * in the interpreter's result if interp is not NULL. * * Side effects: * listPtr will be converted, if necessary, to a list object. * *---------------------------------------------------------------------- @@ -631,21 +613,29 @@ Tcl_Obj **objPtrPtr; /* The resulting Tcl_Obj* is stored here. */ { register List *listRepPtr; if (listPtr->typePtr != &tclListType) { - int result = SetListFromAny(interp, listPtr); + int result, length; + + (void) Tcl_GetStringFromObj(listPtr, &length); + if (!length) { + *objPtrPtr = NULL; + return TCL_OK; + } + + result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; if ((index < 0) || (index >= listRepPtr->elemCount)) { *objPtrPtr = NULL; } else { - *objPtrPtr = listRepPtr->elements[index]; + *objPtrPtr = (&listRepPtr->elements)[index]; } return TCL_OK; } @@ -652,20 +642,20 @@ /* *---------------------------------------------------------------------- * * Tcl_ListObjLength -- * - * This procedure returns the number of elements in a list object. If - * the object is not already a list object, an attempt will be made to + * This function returns the number of elements in a list object. If the + * object is not already a list object, an attempt will be made to * convert it to one. * * Results: - * The return value is normally TCL_OK; in this case *intPtr will be - * set to the integer count of list elements. If listPtr does not refer - * to a list object and the object can not be converted to one, - * TCL_ERROR is returned and an error message will be left in - * the interpreter's result if interp is not NULL. + * The return value is normally TCL_OK; in this case *intPtr will be set + * to the integer count of list elements. If listPtr does not refer to a + * list object and the object can not be converted to one, TCL_ERROR is + * returned and an error message will be left in the interpreter's result + * if interp is not NULL. * * Side effects: * The possible conversion of the argument object to a list object. * *---------------------------------------------------------------------- @@ -678,11 +668,19 @@ register int *intPtr; /* The resulting int is stored here. */ { register List *listRepPtr; if (listPtr->typePtr != &tclListType) { - int result = SetListFromAny(interp, listPtr); + int result, length; + + (void) Tcl_GetStringFromObj(listPtr, &length); + if (!length) { + *intPtr = 0; + return TCL_OK; + } + + result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } @@ -693,40 +691,40 @@ /* *---------------------------------------------------------------------- * * Tcl_ListObjReplace -- - * - * This procedure replaces zero or more elements of the list referenced - * by listPtr with the objects from an (objc,objv) array. - * The objc elements of the array referenced by objv replace the - * count elements in listPtr starting at first. + * + * This function replaces zero or more elements of the list referenced by + * listPtr with the objects from an (objc,objv) array. The objc elements + * of the array referenced by objv replace the count elements in listPtr + * starting at first. * * If the argument first is zero or negative, it refers to the first * element. If first is greater than or equal to the number of elements * in the list, then no elements are deleted; the new elements are - * appended to the list. Count gives the number of elements to - * replace. If count is zero or negative then no elements are deleted; - * the new elements are simply inserted before first. + * appended to the list. Count gives the number of elements to replace. + * If count is zero or negative then no elements are deleted; the new + * elements are simply inserted before first. * * The argument objv refers to an array of objc pointers to the new - * elements to be added to listPtr in place of those that were - * deleted. If objv is NULL, no new elements are added. If listPtr is - * not a list object, an attempt will be made to convert it to one. + * elements to be added to listPtr in place of those that were deleted. + * If objv is NULL, no new elements are added. If listPtr is not a list + * object, an attempt will be made to convert it to one. * * Results: - * The return value is normally TCL_OK. If listPtr does - * not refer to a list object and can not be converted to one, - * TCL_ERROR is returned and an error message will be left in - * the interpreter's result if interp is not NULL. + * The return value is normally TCL_OK. If listPtr does not refer to a + * list object and can not be converted to one, TCL_ERROR is returned and + * an error message will be left in the interpreter's result if interp is + * not NULL. * * Side effects: - * The ref counts of the objc elements in objv are incremented since - * the resulting list now refers to them. Similarly, the ref counts for - * replaced objects are decremented. listPtr is converted, if - * necessary, to a list object. listPtr's old string representation, if - * any, is freed. + * The ref counts of the objc elements in objv are incremented since the + * resulting list now refers to them. Similarly, the ref counts for + * replaced objects are decremented. listPtr is converted, if necessary, + * to a list object. listPtr's old string representation, if any, is + * freed. * *---------------------------------------------------------------------- */ int @@ -734,140 +732,180 @@ Tcl_Interp *interp; /* Used for error reporting if not NULL. */ Tcl_Obj *listPtr; /* List object whose elements to replace. */ int first; /* Index of first element to replace. */ int count; /* Number of elements to replace. */ int objc; /* Number of objects to insert. */ - Tcl_Obj *CONST objv[]; /* An array of objc pointers to Tcl objects - * to insert. */ + Tcl_Obj *CONST objv[]; /* An array of objc pointers to Tcl objects to + * insert. */ { List *listRepPtr; - register Tcl_Obj **elemPtrs, **newPtrs; + register Tcl_Obj **elemPtrs; Tcl_Obj *victimPtr; int numElems, numRequired, numAfterLast; int start, shift, newMax, i, j, result; + int isShared; if (Tcl_IsShared(listPtr)) { Tcl_Panic("Tcl_ListObjReplace called with shared object"); } if (listPtr->typePtr != &tclListType) { - result = SetListFromAny(interp, listPtr); - if (result != TCL_OK) { - return result; + int length; + + (void) Tcl_GetStringFromObj(listPtr, &length); + if (!length) { + if (objc) { + Tcl_SetListObj(listPtr, objc, NULL); + } else { + return TCL_OK; + } + } else { + result = SetListFromAny(interp, listPtr); + if (result != TCL_OK) { + return result; + } } } + listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; - elemPtrs = listRepPtr->elements; + elemPtrs = &listRepPtr->elements; numElems = listRepPtr->elemCount; - if (first < 0) { + if (first < 0) { first = 0; } if (first >= numElems) { - first = numElems; /* so we'll insert after last element */ + first = numElems; /* So we'll insert after last element. */ } if (count < 0) { count = 0; + } else if (numElems < first+count) { + count = numElems - first; } + isShared = (listRepPtr->refCount > 1); numRequired = (numElems - count + objc); - if (numRequired <= listRepPtr->maxElemCount) { + + if ((numRequired <= listRepPtr->maxElemCount) + && !isShared) { /* - * Enough room in the current array. First "delete" count - * elements starting at first. + * Can use the current List struct. First "delete" count elements + * starting at first. */ - for (i = 0, j = first; i < count; i++, j++) { + for (j = first; j < first + count; j++) { victimPtr = elemPtrs[j]; TclDecrRefCount(victimPtr); } /* - * Shift the elements after the last one removed to their - * new locations. + * Shift the elements after the last one removed to their new + * locations. */ start = (first + count); numAfterLast = (numElems - start); shift = (objc - count); /* numNewElems - numDeleted */ if ((numAfterLast > 0) && (shift != 0)) { Tcl_Obj **src, **dst; src = elemPtrs + start; dst = src + shift; - memmove((VOID*) dst, (VOID*) src, - (size_t) (numAfterLast * sizeof(Tcl_Obj*))); - } - - /* - * Insert the new elements into elemPtrs before "first". - */ - - for (i=0,j=first ; ielemCount = numRequired; + memmove((VOID*) dst, (VOID*) src, + (size_t) (numAfterLast * sizeof(Tcl_Obj*))); + } } else { /* - * Not enough room in the current array. Allocate a larger array and - * insert elements into it. - */ - - newMax = (2 * numRequired); - newPtrs = (Tcl_Obj **) - ckalloc((unsigned) (newMax * sizeof(Tcl_Obj *))); - - /* - * Copy over the elements before "first". - */ - - if (first > 0) { - memcpy((VOID *) newPtrs, (VOID *) elemPtrs, - (size_t) (first * sizeof(Tcl_Obj *))); - } - - /* - * "Delete" count elements starting at first. - */ - - for (i = 0, j = first; i < count; i++, j++) { - victimPtr = elemPtrs[j]; - TclDecrRefCount(victimPtr); - } - - /* - * Copy the elements after the last one removed, shifted to - * their new locations. - */ - - start = (first + count); - numAfterLast = (numElems - start); - if (numAfterLast > 0) { - memcpy((VOID *) &(newPtrs[first + objc]), - (VOID *) &(elemPtrs[start]), - (size_t) (numAfterLast * sizeof(Tcl_Obj *))); - } - - /* - * Insert the new elements before "first" and update the - * count of elements. - */ - - for (i = 0, j = first; i < objc; i++, j++) { - newPtrs[j] = objv[i]; - Tcl_IncrRefCount(objv[i]); - } - - listRepPtr->elemCount = numRequired; - listRepPtr->maxElemCount = newMax; - listRepPtr->elements = newPtrs; - ckfree((char *) elemPtrs); - } + * Cannot use the current List struct - it is shared, too small, or + * both. Allocate a new struct and insert elements into it. + */ + + List *oldListRepPtr = listRepPtr; + Tcl_Obj **oldPtrs = elemPtrs; + + if (numRequired > listRepPtr->maxElemCount){ + newMax = (2 * numRequired); + } else { + newMax = listRepPtr->maxElemCount; + } + + listRepPtr = NewListIntRep(newMax, NULL); + if (!listRepPtr) { + Tcl_Panic("Not enough memory to allocate list"); + } + + listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; + listRepPtr->refCount++; + + elemPtrs = &listRepPtr->elements; + + if (isShared) { + /* + * The old struct will remain in place; need new refCounts for the + * new List struct references. Copy over only the surviving + * elements. + */ + + for (i=0; i < first; i++) { + elemPtrs[i] = oldPtrs[i]; + Tcl_IncrRefCount(elemPtrs[i]); + } + for (i= first + count, j = first + objc; + j < numRequired; i++, j++) { + elemPtrs[j] = oldPtrs[i]; + Tcl_IncrRefCount(elemPtrs[j]); + } + + oldListRepPtr->refCount--; + } else { + /* + * The old struct will be removed; use its inherited refCounts. + */ + + if (first > 0) { + memcpy((VOID *) elemPtrs, (VOID *) oldPtrs, + (size_t) (first * sizeof(Tcl_Obj *))); + } + + /* + * "Delete" count elements starting at first. + */ + + for (j = first; j < first + count; j++) { + victimPtr = oldPtrs[j]; + TclDecrRefCount(victimPtr); + } + + /* + * Copy the elements after the last one removed, shifted to their + * new locations. + */ + + start = (first + count); + numAfterLast = (numElems - start); + if (numAfterLast > 0) { + memcpy((VOID *) &(elemPtrs[first + objc]), + (VOID *) &(oldPtrs[start]), + (size_t) (numAfterLast * sizeof(Tcl_Obj *))); + } + + ckfree((char *) oldListRepPtr); + } + } + + /* + * Insert the new elements into elemPtrs before "first". + */ + + for (i=0,j=first ; ielemCount = numRequired; /* * Invalidate and free any old string representation since it no longer * reflects the list's internal representation. */ @@ -878,49 +916,47 @@ /* *---------------------------------------------------------------------- * * TclLsetList -- - * - * Core of the 'lset' command when objc == 4. Objv[2] may be - * either a scalar index or a list of indices. + * + * Core of the 'lset' command when objc == 4. Objv[2] may be either a + * scalar index or a list of indices. * * Results: - * Returns the new value of the list variable, or NULL if an - * error occurs. + * Returns the new value of the list variable, or NULL if an error + * occurs. * * Side effects: - * Surgery is performed on the list value to produce the - * result. - * - * On entry, the reference count of the variable value does not reflect - * any references held on the stack. The first action of this function - * is to determine whether the object is shared, and to duplicate it if - * it is. The reference count of the duplicate is incremented. - * At this point, the reference count will be 1 for either case, so that - * the object will appear to be unshared. - * - * If an error occurs, and the object has been duplicated, the reference - * count on the duplicate is decremented so that it is now 0: this dismisses - * any memory that was allocated by this procedure. - * - * If no error occurs, the reference count of the original object is - * incremented if the object has not been duplicated, and nothing is - * done to a reference count of the duplicate. Now the reference count - * of an unduplicated object is 2 (the returned pointer, plus the one - * stored in the variable). The reference count of a duplicate object - * is 1, reflecting that the returned pointer is the only active - * reference. The caller is expected to store the returned value back - * in the variable and decrement its reference count. (INST_STORE_* - * does exactly this.) - * - * Tcl_LsetFlat and related functions maintain a linked list of - * Tcl_Obj's whose string representations must be spoilt by threading - * via 'ptr2' of the two-pointer internal representation. On entry - * to Tcl_LsetList, the values of 'ptr2' are immaterial; on exit, - * the 'ptr2' field of any Tcl_Obj that has been modified is set to - * NULL. + * Surgery is performed on the list value to produce the result. + * + * On entry, the reference count of the variable value does not reflect + * any references held on the stack. The first action of this function is + * to determine whether the object is shared, and to duplicate it if it + * is. The reference count of the duplicate is incremented. At this + * point, the reference count will be 1 for either case, so that the + * object will appear to be unshared. + * + * If an error occurs, and the object has been duplicated, the reference + * count on the duplicate is decremented so that it is now 0: this + * dismisses any memory that was allocated by this function. + * + * If no error occurs, the reference count of the original object is + * incremented if the object has not been duplicated, and nothing is done + * to a reference count of the duplicate. Now the reference count of an + * unduplicated object is 2 (the returned pointer, plus the one stored in + * the variable). The reference count of a duplicate object is 1, + * reflecting that the returned pointer is the only active reference. + * The caller is expected to store the returned value back in the + * variable and decrement its reference count. (INST_STORE_* does exactly + * this.) + * + * Tcl_LsetFlat and related functions maintain a linked list of Tcl_Obj's + * whose string representations must be spoilt by threading via 'ptr2' of + * the two-pointer internal representation. On entry to Tcl_LsetList, the + * values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any + * Tcl_Obj that has been modified is set to NULL. * *---------------------------------------------------------------------- */ Tcl_Obj* @@ -930,26 +966,19 @@ Tcl_Obj* indexArgPtr; /* Index or index-list arg to 'lset' */ Tcl_Obj* valuePtr; /* Value arg to 'lset' */ { int indexCount; /* Number of indices in the index list */ Tcl_Obj** indices; /* Vector of indices in the index list*/ - int duplicated; /* Flag == 1 if the obj has been - * duplicated, 0 otherwise */ Tcl_Obj* retValuePtr; /* Pointer to the list to be returned */ int index; /* Current index in the list - discarded */ - int result; /* Status return from library calls */ - Tcl_Obj* subListPtr; /* Pointer to the current sublist */ - int elemCount; /* Count of elements in the current sublist */ - Tcl_Obj** elemPtrs; /* Pointers to elements of current sublist */ - Tcl_Obj* chainPtr; /* Pointer to the enclosing sublist - * of the current sublist */ int i; + List *indexListRepPtr; /* - * Determine whether the index arg designates a list or a single - * index. We have to be careful about the order of the checks to - * avoid repeated shimmering; see TIP #22 and #23 for details. + * Determine whether the index arg designates a list or a single index. + * We have to be careful about the order of the checks to avoid repeated + * shimmering; see TIP #22 and #23 for details. */ if (indexArgPtr->typePtr != &tclListType && TclGetIntForIndex(NULL, indexArgPtr, 0, &index) == TCL_OK) { /* @@ -960,223 +989,94 @@ } else if (Tcl_ListObjGetElements(NULL, indexArgPtr, &indexCount, &indices) != TCL_OK) { /* * indexArgPtr designates something that is neither an index nor a - * well formed list. Report the error via TclLsetFlat. + * well formed list. Report the error via TclLsetFlat. */ return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr); } /* - * At this point, we know that argPtr designates a well formed list, - * and the 'else if' above has parsed it into indexCount and indices. - * If there are no indices, simply return 'valuePtr', counting the - * returned pointer as a reference. - */ - - if (indexCount == 0) { - Tcl_IncrRefCount(valuePtr); - return valuePtr; - } - - /* - * Duplicate the list arg if necessary. - */ - - if (Tcl_IsShared(listPtr)) { - duplicated = 1; - listPtr = Tcl_DuplicateObj(listPtr); - Tcl_IncrRefCount(listPtr); + * At this point, we know that argPtr designates a well formed list, and + * the 'else if' above has parsed it into indexCount and indices. + * Increase the reference count of the internal rep of indexArgPtr, in + * order to insure the validity of pointers even if indexArgPtr shimmers + * to another type. + */ + + if (indexCount) { + indexListRepPtr = (List *) indexArgPtr->internalRep.twoPtrValue.ptr1; + indexListRepPtr->refCount++; } else { - duplicated = 0; - } - - /* - * It would be tempting simply to go off to TclLsetFlat to finish the - * processing. Alas, it is also incorrect! The problem is that - * 'indexArgPtr' may designate a sublist of 'listPtr' whose value - * is to be manipulated. The fact that 'listPtr' is itself unshared - * does not guarantee that no sublist is. Therefore, it's necessary - * to replicate all the work here, expanding the index list on each - * trip through the loop. - */ - - /* - * Anchor the linked list of Tcl_Obj's whose string reps must be - * invalidated if the operation succeeds. - */ - - retValuePtr = listPtr; - chainPtr = NULL; - - /* - * Handle each index arg by diving into the appropriate sublist - */ - - for (i=0 ; ; i++) { - /* - * Take the sublist apart. - */ - - result = Tcl_ListObjGetElements(interp, listPtr, &elemCount, &elemPtrs); - if (result != TCL_OK) { - break; - } - listPtr->internalRep.twoPtrValue.ptr2 = (VOID *) chainPtr; - - /* - * Reconstitute the index array - */ - - result = Tcl_ListObjGetElements(interp, indexArgPtr, &indexCount, - &indices); - if (result != TCL_OK) { - /* - * Shouldn't be able to get here, because we already - * parsed the thing successfully once. - */ - break; - } - - /* - * Determine the index of the requested element. - */ - - result = TclGetIntForIndex(interp, indices[i], elemCount-1, &index); - if (result != TCL_OK) { - break; - } - - /* - * Check that the index is in range. - */ - - if (index<0 || index>=elemCount) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("list index out of range", -1)); - result = TCL_ERROR; - break; - } - - /* - * Break the loop after extracting the innermost sublist - */ - - if (i >= indexCount-1) { - result = TCL_OK; - break; - } - - /* - * Extract the appropriate sublist, and make sure that it is unshared. - */ - - subListPtr = elemPtrs[index]; - if (Tcl_IsShared(subListPtr)) { - subListPtr = Tcl_DuplicateObj(subListPtr); - result = TclListObjSetElement(interp, listPtr, index, subListPtr); - if (result != TCL_OK) { - /* - * We actually shouldn't be able to get here, because - * we've already checked everything that TclListObjSetElement - * checks. If we were to get here, it would result in leaking - * subListPtr. - */ - break; - } - } - - /* - * Chain the current sublist onto the linked list of Tcl_Obj's - * whose string reps must be spoilt. - */ - - chainPtr = listPtr; - listPtr = subListPtr; - } - - /* - * Store the new element into the correct slot in the innermost sublist. - */ - - if (result == TCL_OK) { - result = TclListObjSetElement(interp, listPtr, index, valuePtr); - } - - if (result == TCL_OK) { - listPtr->internalRep.twoPtrValue.ptr2 = (VOID *) chainPtr; - - /* Spoil all the string reps */ - - while (listPtr != NULL) { - subListPtr = (Tcl_Obj *) listPtr->internalRep.twoPtrValue.ptr2; - Tcl_InvalidateStringRep(listPtr); - listPtr->internalRep.twoPtrValue.ptr2 = NULL; - listPtr = subListPtr; - } - - /* Return the new list if everything worked. */ - - if (!duplicated) { - Tcl_IncrRefCount(retValuePtr); - } - return retValuePtr; - } - - /* Clean up the one dangling reference otherwise */ - - if (duplicated) { - Tcl_DecrRefCount(retValuePtr); - } - return NULL; + indexListRepPtr = NULL; /* avoid compiler warning*/ + } + + /* + * Let TclLsetFlat handle the actual lset'ting. + */ + + retValuePtr = TclLsetFlat(interp, listPtr, indexCount, indices, valuePtr); + + /* + * If we are the only users of indexListRepPtr, we free it before + * returning. + */ + + if (indexCount) { + if (--indexListRepPtr->refCount <= 0) { + for (i=0; i=5. Objv[2], ... , - * objv[objc-2] contain scalar indices. + * Core of the 'lset' command when objc>=5. Objv[2], ... , objv[objc-2] + * contain scalar indices. * * Results: - * Returns the new value of the list variable, or NULL if an - * error occurs. + * Returns the new value of the list variable, or NULL if an error + * occurs. * * Side effects: - * Surgery is performed on the list value to produce the - * result. - * - * On entry, the reference count of the variable value does not reflect - * any references held on the stack. The first action of this function - * is to determine whether the object is shared, and to duplicate it if - * it is. The reference count of the duplicate is incremented. - * At this point, the reference count will be 1 for either case, so that - * the object will appear to be unshared. - * - * If an error occurs, and the object has been duplicated, the reference - * count on the duplicate is decremented so that it is now 0: this dismisses - * any memory that was allocated by this procedure. - * - * If no error occurs, the reference count of the original object is - * incremented if the object has not been duplicated, and nothing is - * done to a reference count of the duplicate. Now the reference count - * of an unduplicated object is 2 (the returned pointer, plus the one - * stored in the variable). The reference count of a duplicate object - * is 1, reflecting that the returned pointer is the only active - * reference. The caller is expected to store the returned value back - * in the variable and decrement its reference count. (INST_STORE_* - * does exactly this.) - * - * Tcl_LsetList and related functions maintain a linked list of - * Tcl_Obj's whose string representations must be spoilt by threading - * via 'ptr2' of the two-pointer internal representation. On entry - * to Tcl_LsetList, the values of 'ptr2' are immaterial; on exit, - * the 'ptr2' field of any Tcl_Obj that has been modified is set to - * NULL. + * Surgery is performed on the list value to produce the result. + * + * On entry, the reference count of the variable value does not reflect + * any references held on the stack. The first action of this function is + * to determine whether the object is shared, and to duplicate it if it + * is. The reference count of the duplicate is incremented. At this + * point, the reference count will be 1 for either case, so that the + * object will appear to be unshared. + * + * If an error occurs, and the object has been duplicated, the reference + * count on the duplicate is decremented so that it is now 0: this + * dismisses any memory that was allocated by this function. + * + * If no error occurs, the reference count of the original object is + * incremented if the object has not been duplicated, and nothing is done + * to a reference count of the duplicate. Now the reference count of an + * unduplicated object is 2 (the returned pointer, plus the one stored in + * the variable). The reference count of a duplicate object is 1, + * reflecting that the returned pointer is the only active reference. + * The caller is expected to store the returned value back in the + * variable and decrement its reference count. (INST_STORE_* does exactly + * this.) + * + * Tcl_LsetList and related functions maintain a linked list of Tcl_Obj's + * whose string representations must be spoilt by threading via 'ptr2' of + * the two-pointer internal representation. On entry to Tcl_LsetList, the + * values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any + * Tcl_Obj that has been modified is set to NULL. * *---------------------------------------------------------------------- */ Tcl_Obj* @@ -1186,26 +1086,26 @@ int indexCount; /* Number of index args */ Tcl_Obj *CONST indexArray[]; /* Index args */ Tcl_Obj* valuePtr; /* Value arg to 'lset' */ { - int duplicated; /* Flag == 1 if the obj has been - * duplicated, 0 otherwise */ + int duplicated; /* Flag == 1 if the obj has been duplicated, 0 + * otherwise */ Tcl_Obj* retValuePtr; /* Pointer to the list to be returned */ int elemCount; /* Length of one sublist being changed */ Tcl_Obj** elemPtrs; /* Pointers to the elements of a sublist */ Tcl_Obj* subListPtr; /* Pointer to the current sublist */ int index; /* Index of the element to replace in the * current sublist */ - Tcl_Obj* chainPtr; /* Pointer to the enclosing list of - * the current sublist. */ + Tcl_Obj* chainPtr; /* Pointer to the enclosing list of the + * current sublist. */ int result; /* Status return from library calls */ int i; /* - * If there are no indices, then simply return the new value, - * counting the returned pointer as a reference + * If there are no indices, then simply return the new value, counting the + * returned pointer as a reference. */ if (indexCount == 0) { Tcl_IncrRefCount(valuePtr); return valuePtr; @@ -1230,11 +1130,11 @@ retValuePtr = listPtr; chainPtr = NULL; /* - * Handle each index arg by diving into the appropriate sublist + * Handle each index arg by diving into the appropriate sublist. */ for (i=0 ; ; i++) { /* * Take the sublist apart. @@ -1241,10 +1141,16 @@ */ result = Tcl_ListObjGetElements(interp, listPtr, &elemCount, &elemPtrs); if (result != TCL_OK) { break; + } + if (elemCount == 0) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("list index out of range", -1)); + result = TCL_ERROR; + break; } listPtr->internalRep.twoPtrValue.ptr2 = (VOID *) chainPtr; /* * Determine the index of the requested element. @@ -1282,23 +1188,24 @@ subListPtr = elemPtrs[index]; if (Tcl_IsShared(subListPtr)) { subListPtr = Tcl_DuplicateObj(subListPtr); result = TclListObjSetElement(interp, listPtr, index, subListPtr); if (result != TCL_OK) { - /* - * We actually shouldn't be able to get here. - * If we do, it would result in leaking subListPtr, - * but everything's been validated already; the error - * exit from TclListObjSetElement should never happen. + /* + * We actually shouldn't be able to get here. If we do, it + * would result in leaking subListPtr, but everything's been + * validated already; the error exit from TclListObjSetElement + * should never happen. */ + break; } } - /* - * Chain the current sublist onto the linked list of Tcl_Obj's - * whose string reps must be spoilt. + /* + * Chain the current sublist onto the linked list of Tcl_Obj's whose + * string reps must be spoilt. */ chainPtr = listPtr; listPtr = subListPtr; } @@ -1343,30 +1250,27 @@ * TclListObjSetElement -- * * Set a single element of a list to a specified value * * Results: - * - * The return value is normally TCL_OK. If listPtr does not - * refer to a list object and cannot be converted to one, TCL_ERROR - * is returned and an error message will be left in the interpreter - * result if interp is not NULL. Similarly, if index designates - * an element outside the range [0..listLength-1], where - * listLength is the count of elements in the list object designated - * by listPtr, TCL_ERROR is returned and an error message is left - * in the interpreter result. + * The return value is normally TCL_OK. If listPtr does not refer to a + * list object and cannot be converted to one, TCL_ERROR is returned and + * an error message will be left in the interpreter result if interp is + * not NULL. Similarly, if index designates an element outside the range + * [0..listLength-1], where listLength is the count of elements in the + * list object designated by listPtr, TCL_ERROR is returned and an error + * message is left in the interpreter result. * * Side effects: - * - * Tcl_Panic if listPtr designates a shared object. Otherwise, - * attempts to convert it to a list. Decrements the ref count of - * the object at the specified index within the list, replaces with - * the object designated by valuePtr, and increments the ref count - * of the replacement object. - * - * It is the caller's responsibility to invalidate the string - * representation of the object. + * Tcl_Panic if listPtr designates a shared object. Otherwise, attempts + * to convert it to a list with a non-shared internal rep. Decrements the + * ref count of the object at the specified index within the list, + * replaces with the object designated by valuePtr, and increments the + * ref count of the replacement object. + * + * It is the caller's responsibility to invalidate the string + * representation of the object. * *---------------------------------------------------------------------- */ int @@ -1374,53 +1278,94 @@ Tcl_Interp* interp; /* Tcl interpreter; used for error reporting * if not NULL */ Tcl_Obj* listPtr; /* List object in which element should be * stored */ int index; /* Index of element to store */ - Tcl_Obj* valuePtr; /* Tcl object to store in the designated - * list element */ + Tcl_Obj* valuePtr; /* Tcl object to store in the designated list + * element */ { int result; /* Return value from this function */ - List* listRepPtr; /* Internal representation of the list - * being modified */ + List* listRepPtr; /* Internal representation of the list being + * modified */ Tcl_Obj** elemPtrs; /* Pointers to elements of the list */ int elemCount; /* Number of elements in the list */ + int i; - /* Ensure that the listPtr parameter designates an unshared list */ + /* + * Ensure that the listPtr parameter designates an unshared list. + */ if (Tcl_IsShared(listPtr)) { Tcl_Panic("Tcl_ListObjSetElement called with shared object"); } if (listPtr->typePtr != &tclListType) { + int length; + + (void) Tcl_GetStringFromObj(listPtr, &length); + if (!length) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("list index out of range", -1)); + return TCL_ERROR; + } result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } + listRepPtr = (List*) listPtr->internalRep.twoPtrValue.ptr1; - elemPtrs = listRepPtr->elements; elemCount = listRepPtr->elemCount; + elemPtrs = &listRepPtr->elements; - /* Ensure that the index is in bounds */ + /* + * Ensure that the index is in bounds. + */ if (index<0 || index>=elemCount) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("list index out of range", -1)); return TCL_ERROR; } } - /* Add a reference to the new list element */ + /* + * If the internal rep is shared, replace it with an unshared copy. + */ + + if (listRepPtr->refCount > 1) { + List *oldListRepPtr = listRepPtr; + Tcl_Obj **oldElemPtrs = elemPtrs; + + listRepPtr = NewListIntRep(listRepPtr->maxElemCount, NULL); + listRepPtr->canonicalFlag = oldListRepPtr->canonicalFlag; + elemPtrs = &listRepPtr->elements; + for (i=0; i < elemCount; i++) { + elemPtrs[i] = oldElemPtrs[i]; + Tcl_IncrRefCount(elemPtrs[i]); + } + listRepPtr->refCount++; + listRepPtr->elemCount = elemCount; + listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; + oldListRepPtr->refCount--; + } + + /* + * Add a reference to the new list element. + */ Tcl_IncrRefCount(valuePtr); - /* Remove a reference from the old list element */ + /* + * Remove a reference from the old list element. + */ Tcl_DecrRefCount(elemPtrs[index]); - /* Stash the new object in the list */ + /* + * Stash the new object in the list. + */ elemPtrs[index] = valuePtr; return TCL_OK; } @@ -1436,32 +1381,33 @@ * Results: * None. * * Side effects: * Frees listPtr's List* internal representation and sets listPtr's - * internalRep.twoPtrValue.ptr1 to NULL. Decrements the ref counts - * of all element objects, which may free them. + * internalRep.twoPtrValue.ptr1 to NULL. Decrements the ref counts of all + * element objects, which may free them. * *---------------------------------------------------------------------- */ static void FreeListInternalRep(listPtr) Tcl_Obj *listPtr; /* List object with internal rep to free. */ { register List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; - register Tcl_Obj **elemPtrs = listRepPtr->elements; + register Tcl_Obj **elemPtrs = &listRepPtr->elements; register Tcl_Obj *objPtr; int numElems = listRepPtr->elemCount; int i; - for (i = 0; i < numElems; i++) { - objPtr = elemPtrs[i]; - Tcl_DecrRefCount(objPtr); + if (--listRepPtr->refCount <= 0) { + for (i = 0; i < numElems; i++) { + objPtr = elemPtrs[i]; + Tcl_DecrRefCount(objPtr); + } + ckfree((char *) listRepPtr); } - ckfree((char *) elemPtrs); - ckfree((char *) listRepPtr); listPtr->internalRep.twoPtrValue.ptr1 = NULL; listPtr->internalRep.twoPtrValue.ptr2 = NULL; } @@ -1468,70 +1414,41 @@ /* *---------------------------------------------------------------------- * * DupListInternalRep -- * - * Initialize the internal representation of a list Tcl_Obj to a - * copy of the internal representation of an existing list object. + * Initialize the internal representation of a list Tcl_Obj to share the + * internal representation of an existing list object. * * Results: * None. * * Side effects: - * "srcPtr"s list internal rep pointer should not be NULL and we assume - * it is not NULL. We set "copyPtr"s internal rep to a pointer to a - * newly allocated List structure that, in turn, points to "srcPtr"s - * element objects. Those element objects are not actually copied but - * are shared between "srcPtr" and "copyPtr". The ref count of each - * element object is incremented. + * The reference count of the List internal rep is incremented. * *---------------------------------------------------------------------- */ static void DupListInternalRep(srcPtr, copyPtr) Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ Tcl_Obj *copyPtr; /* Object with internal rep to set. */ { - List *srcListRepPtr = (List *) srcPtr->internalRep.twoPtrValue.ptr1; - int numElems = srcListRepPtr->elemCount; - int maxElems = srcListRepPtr->maxElemCount; - register Tcl_Obj **srcElemPtrs = srcListRepPtr->elements; - register Tcl_Obj **copyElemPtrs; - register List *copyListRepPtr; - int i; - - /* - * Allocate a new List structure that points to "srcPtr"s element - * objects. Increment the ref counts for those (now shared) element - * objects. - */ - - copyElemPtrs = (Tcl_Obj **) - ckalloc((unsigned) maxElems * sizeof(Tcl_Obj *)); - for (i = 0; i < numElems; i++) { - copyElemPtrs[i] = srcElemPtrs[i]; - Tcl_IncrRefCount(copyElemPtrs[i]); - } - - copyListRepPtr = (List *) ckalloc(sizeof(List)); - copyListRepPtr->maxElemCount = maxElems; - copyListRepPtr->elemCount = numElems; - copyListRepPtr->elements = copyElemPtrs; - - copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) copyListRepPtr; + List *listRepPtr = (List *) srcPtr->internalRep.twoPtrValue.ptr1; + + listRepPtr->refCount++; + copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; copyPtr->internalRep.twoPtrValue.ptr2 = NULL; copyPtr->typePtr = &tclListType; } /* *---------------------------------------------------------------------- * * SetListFromAny -- * - * Attempt to generate a list internal form for the Tcl object - * "objPtr". + * Attempt to generate a list internal form for the Tcl object "objPtr". * * Results: * The return value is TCL_OK or TCL_ERROR. If an error occurs during * conversion, an error message is left in the interpreter's result * unless "interp" is NULL. @@ -1563,15 +1480,14 @@ string = Tcl_GetStringFromObj(objPtr, &length); /* * Parse the string into separate string objects, and create a List - * structure that points to the element string objects. We use a - * modified version of Tcl_SplitList's implementation to avoid one - * malloc and a string copy for each list element. First, estimate the - * number of elements by counting the number of space characters in the - * list. + * structure that points to the element string objects. We use a modified + * version of Tcl_SplitList's implementation to avoid one malloc and a + * string copy for each list element. First, estimate the number of + * elements by counting the number of space characters in the list. */ limit = (string + length); estCount = 1; for (p = string; p < limit; p++) { @@ -1579,29 +1495,35 @@ estCount++; } } /* - * Allocate a new List structure with enough room for "estCount" - * elements. Each element is a pointer to a Tcl_Obj with the appropriate - * string rep. The initial "estCount" elements are set using the - * corresponding "argv" strings. + * Allocate a new List structure with enough room for "estCount" elements. + * Each element is a pointer to a Tcl_Obj with the appropriate string rep. + * The initial "estCount" elements are set using the corresponding "argv" + * strings. */ - elemPtrs = (Tcl_Obj **) - ckalloc((unsigned) (estCount * sizeof(Tcl_Obj *))); + listRepPtr = NewListIntRep(estCount, NULL); + if (!listRepPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "Not enough memory to allocate the list internal rep", -1)); + return TCL_ERROR; + } + elemPtrs = &listRepPtr->elements; + for (p = string, lenRemain = length, i = 0; lenRemain > 0; p = nextElem, lenRemain = (limit - nextElem), i++) { result = TclFindElement(interp, p, lenRemain, &elemStart, &nextElem, - &elemSize, &hasBrace); + &elemSize, &hasBrace); if (result != TCL_OK) { for (j = 0; j < i; j++) { elemPtr = elemPtrs[j]; Tcl_DecrRefCount(elemPtr); } - ckfree((char *) elemPtrs); + ckfree((char *) listRepPtr); return result; } if (elemStart >= limit) { break; } @@ -1614,34 +1536,32 @@ * "elemSize" bytes starting at "elemStart". */ s = ckalloc((unsigned) elemSize + 1); if (hasBrace) { - memcpy((VOID *) s, (VOID *) elemStart, (size_t) elemSize); + memcpy((VOID *) s, (VOID *) elemStart, (size_t) elemSize); s[elemSize] = 0; } else { elemSize = TclCopyAndCollapse(elemSize, elemStart, s); } TclNewObj(elemPtr); - elemPtr->bytes = s; + elemPtr->bytes = s; elemPtr->length = elemSize; elemPtrs[i] = elemPtr; - Tcl_IncrRefCount(elemPtr); /* since list now holds ref to it */ + Tcl_IncrRefCount(elemPtr); /* since list now holds ref to it */ } - listRepPtr = (List *) ckalloc(sizeof(List)); - listRepPtr->maxElemCount = estCount; - listRepPtr->elemCount = i; - listRepPtr->elements = elemPtrs; + listRepPtr->elemCount = i; /* - * Free the old internalRep before setting the new one. We do this as - * late as possible to allow the conversion code, in particular + * 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. */ + listRepPtr->refCount++; TclFreeIntRep(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclListType; return TCL_OK; @@ -1650,22 +1570,22 @@ /* *---------------------------------------------------------------------- * * UpdateStringOfList -- * - * Update the string representation for a list object. - * Note: This procedure does not invalidate an existing old string rep - * so storage will be lost if this has not already been done. + * Update the string representation for a list object. Note: This + * function does not invalidate an existing old string rep so storage + * will be lost if this has not already been done. * * Results: * None. * * Side effects: - * The object's string is set to a valid string that results from - * the list-to-string conversion. This string will be empty if the - * list has no elements. The list internal representation - * should not be NULL and we assume it is not NULL. + * The object's string is set to a valid string that results from the + * list-to-string conversion. This string will be empty if the list has + * no elements. The list internal representation should not be NULL and + * we assume it is not NULL. * *---------------------------------------------------------------------- */ static void @@ -1677,14 +1597,15 @@ List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; int numElems = listRepPtr->elemCount; register int i; char *elem, *dst; int length; + Tcl_Obj **elemPtrs; /* - * Convert each element of the list to string form and then convert it - * to proper list element form, adding it to the result buffer. + * Convert each element of the list to string form and then convert it to + * proper list element form, adding it to the result buffer. */ /* * Pass 1: estimate space, gather flags. */ @@ -1693,24 +1614,33 @@ flagPtr = localFlags; } else { flagPtr = (int *) ckalloc((unsigned) numElems*sizeof(int)); } listPtr->length = 1; + elemPtrs = &listRepPtr->elements; for (i = 0; i < numElems; i++) { - elem = Tcl_GetStringFromObj(listRepPtr->elements[i], &length); + elem = Tcl_GetStringFromObj(elemPtrs[i], &length); listPtr->length += Tcl_ScanCountedElement(elem, length, &flagPtr[i]) + 1; + + /* + * Check for continued sanity. [Bug 1267380] + */ + + if (listPtr->length < 1) { + Tcl_Panic("string representation size exceeds sane bounds"); + } } /* * Pass 2: copy into string rep buffer. */ listPtr->bytes = ckalloc((unsigned) listPtr->length); dst = listPtr->bytes; for (i = 0; i < numElems; i++) { - elem = Tcl_GetStringFromObj(listRepPtr->elements[i], &length); + elem = Tcl_GetStringFromObj(elemPtrs[i], &length); dst += Tcl_ConvertCountedElement(elem, length, dst, flagPtr[i] | (i==0 ? 0 : TCL_DONT_QUOTE_HASH)); *dst = ' '; dst++; } @@ -1722,6 +1652,22 @@ } else { dst--; *dst = 0; } listPtr->length = dst - listPtr->bytes; + + /* + * Mark the list as being canonical; although it has a string rep, it is + * one we derived through proper "canonical" quoting and so it's known to + * be free from nasties relating to [concat] and [eval]. + */ + + listRepPtr->canonicalFlag = 1; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclLiteral.c ================================================================== --- generic/tclLiteral.c +++ generic/tclLiteral.c @@ -1,28 +1,28 @@ -/* +/* * tclLiteral.c -- * - * Implementation of the global and ByteCode-local literal tables - * used to manage the Tcl objects created for literal values during - * compilation of Tcl scripts. This implementation borrows heavily - * from the more general hashtable implementation of Tcl hash tables - * that appears in tclHash.c. + * Implementation of the global and ByteCode-local literal tables used to + * manage the Tcl objects created for literal values during compilation + * of Tcl scripts. This implementation borrows heavily from the more + * general hashtable implementation of Tcl hash tables that appears in + * tclHash.c. * * Copyright (c) 1997-1998 Sun Microsystems, Inc. * Copyright (c) 2004 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. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLiteral.c,v 1.20 2004/08/02 15:33:36 dgp Exp $ + * RCS: @(#) $Id: tclLiteral.c,v 1.20.2.3 2005/08/02 18:16:00 dgp Exp $ */ #include "tclInt.h" #include "tclCompile.h" /* - * When there are this many entries per bucket, on average, rebuild - * a literal's hash table to make it larger. + * When there are this many entries per bucket, on average, rebuild a + * literal's hash table to make it larger. */ #define REBUILD_MULTIPLIER 3 /* @@ -49,26 +49,27 @@ * structure. * * Results: * None. * - * Side effects: + * Side effects: * The literal table is made ready for use. * *---------------------------------------------------------------------- */ void TclInitLiteralTable(tablePtr) - register LiteralTable *tablePtr; /* Pointer to table structure, which - * is supplied by the caller. */ + register LiteralTable *tablePtr; + /* Pointer to table structure, which is + * supplied by the caller. */ { -#if (TCL_SMALL_HASH_TABLE != 4) +#if (TCL_SMALL_HASH_TABLE != 4) Tcl_Panic("TclInitLiteralTable: TCL_SMALL_HASH_TABLE is %d, not 4\n", TCL_SMALL_HASH_TABLE); #endif - + tablePtr->buckets = tablePtr->staticBuckets; tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0; tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0; tablePtr->numBuckets = TCL_SMALL_HASH_TABLE; tablePtr->numEntries = 0; @@ -79,13 +80,13 @@ /* *---------------------------------------------------------------------- * * TclCleanupLiteralTable -- * - * This procedure frees the internal representation of every - * literal in a literal table. It is called prior to deleting - * an interp, so that variable refs will be cleaned up properly. + * This procedure frees the internal representation of every literal in a + * literal table. It is called prior to deleting an interp, so that + * variable refs will be cleaned up properly. * * Results: * None. * * Side effects: @@ -94,62 +95,60 @@ *---------------------------------------------------------------------- */ void TclCleanupLiteralTable( interp, tablePtr ) - Tcl_Interp* interp; /* Interpreter containing literals to purge */ - LiteralTable* tablePtr; /* Points to the literal table being cleaned */ + Tcl_Interp* interp; /* Interpreter containing literals to + * purge. */ + LiteralTable* tablePtr; /* Points to the literal table being + * cleaned. */ { int i; - LiteralEntry* entryPtr; /* Pointer to the current entry in the - * hash table of literals */ - LiteralEntry* nextPtr; /* Pointer to the next entry in tbe - * bucket */ - Tcl_Obj* objPtr; /* Pointer to a literal object whose internal - * rep is being freed */ - Tcl_ObjType* typePtr; /* Pointer to the object's type */ - int didOne; /* Flag for whether we've removed a literal - * in the current bucket */ + LiteralEntry* entryPtr; /* Pointer to the current entry in the hash + * table of literals. */ + LiteralEntry* nextPtr; /* Pointer to the next entry in the bucket. */ + Tcl_Obj* objPtr; /* Pointer to a literal object whose internal + * rep is being freed. */ + Tcl_ObjType* typePtr; /* Pointer to the object's type. */ + int didOne; /* Flag for whether we've removed a literal in + * the current bucket. */ #ifdef TCL_COMPILE_DEBUG TclVerifyGlobalLiteralTable( (Interp*) interp ); #endif /* TCL_COMPILE_DEBUG */ - for ( i = 0; i < tablePtr->numBuckets; i++ ) { - - /* - * It is tempting simply to walk each hash bucket once and - * delete the internal representations of each literal in turn. - * It's also wrong. The problem is that freeing a literal's - * internal representation can delete other literals to which - * it refers, making nextPtr invalid. So each time we free an - * internal rep, we start its bucket over again. - */ - didOne = 1; - while ( didOne ) { - didOne = 0; - entryPtr = tablePtr->buckets[i]; - while ( entryPtr != NULL ) { - objPtr = entryPtr->objPtr; - nextPtr = entryPtr->nextPtr; - typePtr = objPtr->typePtr; - if ( ( typePtr != NULL ) - && ( typePtr->freeIntRepProc != NULL ) ) { - if ( objPtr->bytes == NULL ) { - Tcl_Panic( "literal without a string rep" ); - } - objPtr->typePtr = NULL; - typePtr->freeIntRepProc( objPtr ); - didOne = 1; - } else { - entryPtr = nextPtr; - } - } - } - } -} - + for (i=0 ; inumBuckets ; i++) { + /* + * It is tempting simply to walk each hash bucket once and delete the + * internal representations of each literal in turn. It's also wrong. + * The problem is that freeing a literal's internal representation can + * delete other literals to which it refers, making nextPtr invalid. + * So each time we free an internal rep, we start its bucket over + * again. + */ + + do { + didOne = 0; + entryPtr = tablePtr->buckets[i]; + while (entryPtr != NULL) { + objPtr = entryPtr->objPtr; + nextPtr = entryPtr->nextPtr; + typePtr = objPtr->typePtr; + if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { + if (objPtr->bytes == NULL) { + Tcl_Panic( "literal without a string rep" ); + } + objPtr->typePtr = NULL; + typePtr->freeIntRepProc(objPtr); + didOne = 1; + } else { + entryPtr = nextPtr; + } + } + } while (didOne); + } +} /* *---------------------------------------------------------------------- * * TclDeleteLiteralTable -- @@ -160,14 +159,13 @@ * * Results: * None. * * Side effects: - * Each literal in the table is released: i.e., its reference count - * in the global literal table is decremented and, if it becomes zero, - * the literal is freed. In addition, the table's bucket array is - * freed. + * Each literal in the table is released: i.e., its reference count in + * the global literal table is decremented and, if it becomes zero, the + * literal is freed. In addition, the table's bucket array is freed. * *---------------------------------------------------------------------- */ void @@ -177,28 +175,28 @@ LiteralTable *tablePtr; /* Points to the literal table to delete. */ { LiteralEntry *entryPtr, *nextPtr; Tcl_Obj *objPtr; int i; - + /* - * Release remaining literals in the table. Note that releasing a - * literal might release other literals, modifying the table, so we - * restart the search from the bucket chain we last found an entry. + * Release remaining literals in the table. Note that releasing a literal + * might release other literals, modifying the table, so we restart the + * search from the bucket chain we last found an entry. */ #ifdef TCL_COMPILE_DEBUG TclVerifyGlobalLiteralTable((Interp *) interp); #endif /*TCL_COMPILE_DEBUG*/ /* * We used to call TclReleaseLiteral for each literal in the table, which * is rather inefficient as it causes one lookup-by-hash for each - * reference to the literal. - * We now rely at interp-deletion on each bytecode object to release its - * references to the literal Tcl_Obj without requiring that it updates the - * global table itself, and deal here only with the table. + * reference to the literal. We now rely at interp-deletion on each + * bytecode object to release its references to the literal Tcl_Obj + * without requiring that it updates the global table itself, and deal + * here only with the table. */ for (i = 0; i < tablePtr->numBuckets; i++) { entryPtr = tablePtr->buckets[i]; while (entryPtr != NULL) { @@ -207,11 +205,11 @@ nextPtr = entryPtr->nextPtr; ckfree((char *) entryPtr); entryPtr = nextPtr; } } - + /* * Free up the table's bucket array if it was dynamically allocated. */ if (tablePtr->buckets != tablePtr->staticBuckets) { @@ -222,76 +220,75 @@ /* *---------------------------------------------------------------------- * * TclRegisterLiteral -- * - * Find, or if necessary create, an object in a CompileEnv literal - * array that has a string representation matching the argument string. + * Find, or if necessary create, an object in a CompileEnv literal array + * that has a string representation matching the argument string. * * Results: - * The index in the CompileEnv's literal array that references a - * shared literal matching the string. The object is created if - * necessary. + * The index in the CompileEnv's literal array that references a shared + * literal matching the string. The object is created if necessary. * * Side effects: - * To maximize sharing, we look up the string in the interpreter's - * global literal table. If not found, we create a new shared literal - * in the global table. We then add a reference to the shared - * literal in the CompileEnv's literal array. - * - * If onHeap is 1, this procedure is given ownership of the string: if - * an object is created then its string representation is set directly - * from string, otherwise the string is freed. Typically, a caller sets - * onHeap 1 if "string" is an already heap-allocated buffer holding the - * result of backslash substitutions. + * To maximize sharing, we look up the string in the interpreter's global + * literal table. If not found, we create a new shared literal in the + * global table. We then add a reference to the shared literal in the + * CompileEnv's literal array. + * + * If LITERAL_ON_HEAP is set in flags, this procedure is given ownership + * of the string: if an object is created then its string representation + * is set directly from string, otherwise the string is freed. Typically, + * a caller sets LITERAL_ON_HEAP if "string" is an already heap-allocated + * buffer holding the result of backslash substitutions. * *---------------------------------------------------------------------- */ int -TclRegisterLiteral(envPtr, bytes, length, onHeap) +TclRegisterLiteral(envPtr, bytes, length, flags) CompileEnv *envPtr; /* Points to the CompileEnv in whose object * array an object is found or created. */ register char *bytes; /* Points to string for which to find or * create an object in CompileEnv's object * array. */ - int length; /* Number of bytes in the string. If < 0, - * the string consists of all bytes up to - * the first null character. */ - int onHeap; /* If 1 then the caller already malloc'd - * bytes and ownership is passed to this - * procedure. */ + int length; /* Number of bytes in the string. If < 0, the + * string consists of all bytes up to the + * first null character. */ + int flags; /* If LITERAL_ON_HEAP then the caller already + * malloc'd bytes and ownership is passed to + * this procedure. If LITERAL_NS_SCOPE then + * the literal shouldnot be shared accross + * namespaces. */ { Interp *iPtr = envPtr->iPtr; LiteralTable *globalTablePtr = &(iPtr->literalTable); LiteralTable *localTablePtr = &(envPtr->localLitTable); register LiteralEntry *globalPtr, *localPtr; register Tcl_Obj *objPtr; unsigned int hash; int localHash, globalHash, objIndex; - long n; - char buf[TCL_INTEGER_SPACE]; + Namespace *nsPtr; if (length < 0) { - length = (bytes? strlen(bytes) : 0); + length = (bytes ? strlen(bytes) : 0); } hash = HashString(bytes, length); /* - * Is the literal already in the CompileEnv's local literal array? - * If so, just return its index. + * Is the literal already in the CompileEnv's local literal array? If so, + * just return its index. */ localHash = (hash & localTablePtr->mask); for (localPtr = localTablePtr->buckets[localHash]; - localPtr != NULL; localPtr = localPtr->nextPtr) { + localPtr != NULL; localPtr = localPtr->nextPtr) { objPtr = localPtr->objPtr; if ((objPtr->length == length) && ((length == 0) || ((objPtr->bytes[0] == bytes[0]) - && (memcmp(objPtr->bytes, bytes, (unsigned) length) - == 0)))) { - if (onHeap) { + && (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) { + if (flags & LITERAL_ON_HEAP) { ckfree(bytes); } objIndex = (localPtr - envPtr->literalArrayPtr); #ifdef TCL_COMPILE_DEBUG TclVerifyLocalLiteralTable(envPtr); @@ -300,39 +297,50 @@ return objIndex; } } /* - * The literal is new to this CompileEnv. Is it in the interpreter's - * global literal table? + * The literal is new to this CompileEnv. Should it be shared accross + * namespaces? If it is a fully qualified name, the namespace + * specification is not needed to avoid sharing. + */ + + if ((flags & LITERAL_NS_SCOPE) && iPtr->varFramePtr + && ((length <2) || (bytes[0] != ':') || (bytes[1] != ':'))) { + nsPtr = iPtr->varFramePtr->nsPtr; + } else { + nsPtr = NULL; + } + + /* + * Is it in the interpreter's global literal table? */ globalHash = (hash & globalTablePtr->mask); for (globalPtr = globalTablePtr->buckets[globalHash]; - globalPtr != NULL; globalPtr = globalPtr->nextPtr) { + globalPtr != NULL; globalPtr = globalPtr->nextPtr) { objPtr = globalPtr->objPtr; - if ((objPtr->length == length) && ((length == 0) + if ((globalPtr->nsPtr == nsPtr) + && (objPtr->length == length) && ((length == 0) || ((objPtr->bytes[0] == bytes[0]) - && (memcmp(objPtr->bytes, bytes, (unsigned) length) - == 0)))) { + && (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) { /* * A global literal was found. Add an entry to the CompileEnv's * local literal array. */ - - if (onHeap) { + + if (flags & LITERAL_ON_HEAP) { ckfree(bytes); } objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash); #ifdef TCL_COMPILE_DEBUG if (globalPtr->refCount < 1) { Tcl_Panic("TclRegisterLiteral: global literal \"%.*s\" had bad refCount %d", - (length>60? 60 : length), bytes, - globalPtr->refCount); + (length>60? 60 : length), bytes, globalPtr->refCount); } TclVerifyLocalLiteralTable(envPtr); -#endif /*TCL_COMPILE_DEBUG*/ +#endif /*TCL_COMPILE_DEBUG*/ return objIndex; } } /* @@ -341,47 +349,54 @@ * Convert the object to an integer object if possible. */ TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); - if (onHeap) { + if (flags & LITERAL_ON_HEAP) { objPtr->bytes = bytes; objPtr->length = length; } else { TclInitStringRep(objPtr, bytes, length); } +#if 0 if (TclLooksLikeInt(bytes, length)) { /* * From here we use the objPtr, because it is NULL terminated */ + + long n; + char buf[TCL_INTEGER_SPACE]; + if (TclGetLong((Tcl_Interp *) NULL, objPtr->bytes, &n) == TCL_OK) { TclFormatInt(buf, n); if (strcmp(objPtr->bytes, buf) == 0) { objPtr->internalRep.longValue = n; objPtr->typePtr = &tclIntType; } } } - +#endif + #ifdef TCL_COMPILE_DEBUG if (TclLookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) { Tcl_Panic("TclRegisterLiteral: literal \"%.*s\" found globally but shouldn't be", - (length>60? 60 : length), bytes); + (length>60? 60 : length), bytes); } #endif globalPtr = (LiteralEntry *) ckalloc((unsigned) sizeof(LiteralEntry)); globalPtr->objPtr = objPtr; globalPtr->refCount = 0; + globalPtr->nsPtr = nsPtr; globalPtr->nextPtr = globalTablePtr->buckets[globalHash]; globalTablePtr->buckets[globalHash] = globalPtr; globalTablePtr->numEntries++; /* - * If the global literal table has exceeded a decent size, rebuild it - * with more buckets. + * If the global literal table has exceeded a decent size, rebuild it with + * more buckets. */ if (globalTablePtr->numEntries >= globalTablePtr->rebuildSize) { RebuildLiteralTable(globalTablePtr); } @@ -391,59 +406,61 @@ TclVerifyGlobalLiteralTable(iPtr); TclVerifyLocalLiteralTable(envPtr); { LiteralEntry *entryPtr; int found, i; + found = 0; - for (i = 0; i < globalTablePtr->numBuckets; i++) { - for (entryPtr = globalTablePtr->buckets[i]; - entryPtr != NULL; entryPtr = entryPtr->nextPtr) { - if ((entryPtr == globalPtr) - && (entryPtr->objPtr == objPtr)) { + for (i=0 ; inumBuckets ; i++) { + for (entryPtr=globalTablePtr->buckets[i]; entryPtr!=NULL ; + entryPtr=entryPtr->nextPtr) { + if ((entryPtr == globalPtr) && (entryPtr->objPtr == objPtr)) { found = 1; } } } if (!found) { Tcl_Panic("TclRegisterLiteral: literal \"%.*s\" wasn't global", - (length>60? 60 : length), bytes); + (length>60? 60 : length), bytes); } } #endif /*TCL_COMPILE_DEBUG*/ -#ifdef TCL_COMPILE_STATS + +#ifdef TCL_COMPILE_STATS iPtr->stats.numLiteralsCreated++; - iPtr->stats.totalLitStringBytes += (double) (length + 1); + iPtr->stats.totalLitStringBytes += (double) (length + 1); iPtr->stats.currentLitStringBytes += (double) (length + 1); iPtr->stats.literalCount[TclLog2(length)]++; #endif /*TCL_COMPILE_STATS*/ + return objIndex; } /* *---------------------------------------------------------------------- * * TclLookupLiteralEntry -- * * Finds the LiteralEntry that corresponds to a literal Tcl object - * holding a literal. + * holding a literal. * * Results: - * Returns the matching LiteralEntry if found, otherwise NULL. + * Returns the matching LiteralEntry if found, otherwise NULL. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ LiteralEntry * TclLookupLiteralEntry(interp, objPtr) - Tcl_Interp *interp; /* Interpreter for which objPtr was created - * to hold a literal. */ - register Tcl_Obj *objPtr; /* Points to a Tcl object holding a - * literal that was previously created by a - * call to TclRegisterLiteral. */ + Tcl_Interp *interp; /* Interpreter for which objPtr was created to + * hold a literal. */ + register Tcl_Obj *objPtr; /* Points to a Tcl object holding a literal + * that was previously created by a call to + * TclRegisterLiteral. */ { Interp *iPtr = (Interp *) interp; LiteralTable *globalTablePtr = &(iPtr->literalTable); register LiteralEntry *entryPtr; char *bytes; @@ -450,27 +467,27 @@ int length, globalHash; bytes = Tcl_GetStringFromObj(objPtr, &length); globalHash = (HashString(bytes, length) & globalTablePtr->mask); for (entryPtr = globalTablePtr->buckets[globalHash]; - entryPtr != NULL; entryPtr = entryPtr->nextPtr) { - if (entryPtr->objPtr == objPtr) { - return entryPtr; - } + entryPtr != NULL; entryPtr = entryPtr->nextPtr) { + if (entryPtr->objPtr == objPtr) { + return entryPtr; + } } return NULL; } /* *---------------------------------------------------------------------- * * TclHideLiteral -- * - * Remove a literal entry from the literal hash tables, leaving it in - * the literal array so existing references continue to function. - * This makes it possible to turn a shared literal into a private - * literal that cannot be shared. + * Remove a literal entry from the literal hash tables, leaving it in the + * literal array so existing references continue to function. This makes + * it possible to turn a shared literal into a private literal that + * cannot be shared. * * Results: * None. * * Side effects: @@ -480,16 +497,16 @@ *---------------------------------------------------------------------- */ void TclHideLiteral(interp, envPtr, index) - Tcl_Interp *interp; /* Interpreter for which objPtr was created - * to hold a literal. */ - register CompileEnv *envPtr; /* Points to CompileEnv whose literal array - * contains the entry being hidden. */ - int index; /* The index of the entry in the literal - * array. */ + Tcl_Interp *interp; /* Interpreter for which objPtr was created to + * hold a literal. */ + register CompileEnv *envPtr;/* Points to CompileEnv whose literal array + * contains the entry being hidden. */ + int index; /* The index of the entry in the literal + * array. */ { LiteralEntry **nextPtrPtr, *entryPtr, *lPtr; LiteralTable *localTablePtr = &(envPtr->localLitTable); int localHash, length; char *bytes; @@ -497,13 +514,13 @@ lPtr = &(envPtr->literalArrayPtr[index]); /* * To avoid unwanted sharing we need to copy the object and remove it from - * the local and global literal tables. It still has a slot in the literal - * array so it can be referred to by byte codes, but it will not be matched - * by literal searches. + * the local and global literal tables. It still has a slot in the + * literal array so it can be referred to by byte codes, but it will not + * be matched by literal searches. */ newObjPtr = Tcl_DuplicateObj(lPtr->objPtr); Tcl_IncrRefCount(newObjPtr); TclReleaseLiteral(interp, lPtr->objPtr); @@ -511,11 +528,11 @@ bytes = Tcl_GetStringFromObj(newObjPtr, &length); localHash = (HashString(bytes, length) & localTablePtr->mask); nextPtrPtr = &localTablePtr->buckets[localHash]; - for (entryPtr = *nextPtrPtr; entryPtr != NULL; entryPtr = *nextPtrPtr) { + for (entryPtr=*nextPtrPtr ; entryPtr!=NULL ; entryPtr=*nextPtrPtr) { if (entryPtr == lPtr) { *nextPtrPtr = lPtr->nextPtr; lPtr->nextPtr = NULL; localTablePtr->numEntries--; break; @@ -527,35 +544,34 @@ /* *---------------------------------------------------------------------- * * TclAddLiteralObj -- * - * Add a single literal object to the literal array. This - * function does not add the literal to the local or global - * literal tables. The caller is expected to add the entry - * to whatever tables are appropriate. + * Add a single literal object to the literal array. This function does + * not add the literal to the local or global literal tables. The caller + * is expected to add the entry to whatever tables are appropriate. * * Results: * The index in the CompileEnv's literal array that references the - * literal. Stores the pointer to the new literal entry in the - * location referenced by the localPtrPtr argument. + * literal. Stores the pointer to the new literal entry in the location + * referenced by the localPtrPtr argument. * * Side effects: - * Expands the literal array if necessary. Increments the refcount - * on the literal object. + * Expands the literal array if necessary. Increments the refcount on the + * literal object. * *---------------------------------------------------------------------- */ int TclAddLiteralObj(envPtr, objPtr, litPtrPtr) - register CompileEnv *envPtr; /* Points to CompileEnv in whose literal - * array the object is to be inserted. */ - Tcl_Obj *objPtr; /* The object to insert into the array. */ - LiteralEntry **litPtrPtr; /* The location where the pointer to the - * new literal entry should be stored. - * May be NULL. */ + register CompileEnv *envPtr;/* Points to CompileEnv in whose literal array + * the object is to be inserted. */ + Tcl_Obj *objPtr; /* The object to insert into the array. */ + LiteralEntry **litPtrPtr; /* The location where the pointer to the new + * literal entry should be stored. May be + * NULL. */ { register LiteralEntry *lPtr; int objIndex; if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) { @@ -588,29 +604,29 @@ * The index in the CompileEnv's literal array that references the * literal. * * Side effects: * Increments the ref count of the global LiteralEntry since the - * CompileEnv now refers to the literal. Expands the literal array - * if necessary. May rebuild the hash bucket array of the CompileEnv's + * CompileEnv now refers to the literal. Expands the literal array if + * necessary. May rebuild the hash bucket array of the CompileEnv's * literal array if it becomes too large. * *---------------------------------------------------------------------- */ static int AddLocalLiteralEntry(envPtr, globalPtr, localHash) - register CompileEnv *envPtr; /* Points to CompileEnv in whose literal - * array the object is to be inserted. */ - LiteralEntry *globalPtr; /* Points to the global LiteralEntry for - * the literal to add to the CompileEnv. */ - int localHash; /* Hash value for the literal's string. */ + register CompileEnv *envPtr;/* Points to CompileEnv in whose literal array + * the object is to be inserted. */ + LiteralEntry *globalPtr; /* Points to the global LiteralEntry for the + * literal to add to the CompileEnv. */ + int localHash; /* Hash value for the literal's string. */ { register LiteralTable *localTablePtr = &(envPtr->localLitTable); LiteralEntry *localPtr; int objIndex; - + objIndex = TclAddLiteralObj(envPtr, globalPtr->objPtr, &localPtr); /* * Add the literal to the local table. */ @@ -633,94 +649,96 @@ #ifdef TCL_COMPILE_DEBUG TclVerifyLocalLiteralTable(envPtr); { char *bytes; int length, found, i; + found = 0; - for (i = 0; i < localTablePtr->numBuckets; i++) { - for (localPtr = localTablePtr->buckets[i]; - localPtr != NULL; localPtr = localPtr->nextPtr) { + for (i=0 ; inumBuckets ; i++) { + for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL ; + localPtr=localPtr->nextPtr) { if (localPtr->objPtr == globalPtr->objPtr) { found = 1; } } } + if (!found) { bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length); Tcl_Panic("AddLocalLiteralEntry: literal \"%.*s\" wasn't found locally", - (length>60? 60 : length), bytes); + (length>60? 60 : length), bytes); } } #endif /*TCL_COMPILE_DEBUG*/ + return objIndex; } /* *---------------------------------------------------------------------- * * ExpandLocalLiteralArray -- * - * Procedure that uses malloc to allocate more storage for a - * CompileEnv's local literal array. + * Procedure that uses malloc to allocate more storage for a CompileEnv's + * local literal array. * * Results: * None. * * Side effects: - * The literal array in *envPtr is reallocated to a new array of - * double the size, and if envPtr->mallocedLiteralArray is non-zero - * the old array is freed. Entries are copied from the old array - * to the new one. The local literal table is updated to refer to - * the new entries. + * The literal array in *envPtr is reallocated to a new array of double + * the size, and if envPtr->mallocedLiteralArray is non-zero the old + * array is freed. Entries are copied from the old array to the new one. + * The local literal table is updated to refer to the new entries. * *---------------------------------------------------------------------- */ static void ExpandLocalLiteralArray(envPtr) - register CompileEnv *envPtr; /* Points to the CompileEnv whose object - * array must be enlarged. */ + register CompileEnv *envPtr;/* Points to the CompileEnv whose object array + * must be enlarged. */ { /* - * The current allocated local literal entries are stored between - * elements 0 and (envPtr->literalArrayNext - 1) [inclusive]. + * The current allocated local literal entries are stored between elements + * 0 and (envPtr->literalArrayNext - 1) [inclusive]. */ LiteralTable *localTablePtr = &(envPtr->localLitTable); int currElems = envPtr->literalArrayNext; size_t currBytes = (currElems * sizeof(LiteralEntry)); register LiteralEntry *currArrayPtr = envPtr->literalArrayPtr; register LiteralEntry *newArrayPtr = (LiteralEntry *) ckalloc((unsigned) (2 * currBytes)); int i; - + /* * Copy from the old literal array to the new, then update the local * literal table's bucket array. */ memcpy((VOID *) newArrayPtr, (VOID *) currArrayPtr, currBytes); - for (i = 0; i < currElems; i++) { + for (i=0 ; inumBuckets; i++) { + for (i=0 ; inumBuckets ; i++) { if (localTablePtr->buckets[i] != NULL) { - localTablePtr->buckets[i] = newArrayPtr - + (localTablePtr->buckets[i] - currArrayPtr); + localTablePtr->buckets[i] = + newArrayPtr + (localTablePtr->buckets[i] - currArrayPtr); } } /* - * Free the old literal array if needed, and mark the new literal - * array as malloced. + * Free the old literal array if needed, and mark the new literal array as + * malloced. */ - + if (envPtr->mallocedLiteralArray) { ckfree((char *) currArrayPtr); } envPtr->literalArrayPtr = newArrayPtr; envPtr->literalArrayEnd = (2 * currElems); @@ -731,29 +749,29 @@ *---------------------------------------------------------------------- * * TclReleaseLiteral -- * * This procedure releases a reference to one of the shared Tcl objects - * that hold literals. It is called to release the literals referenced - * by a ByteCode that is being destroyed, and it is also called by + * that hold literals. It is called to release the literals referenced by + * a ByteCode that is being destroyed, and it is also called by * TclDeleteLiteralTable. * * Results: * None. * * Side effects: - * The reference count for the global LiteralTable entry that - * corresponds to the literal is decremented. If no other reference - * to a global literal object remains, it is freed. + * The reference count for the global LiteralTable entry that corresponds + * to the literal is decremented. If no other reference to a global + * literal object remains, it is freed. * *---------------------------------------------------------------------- */ void TclReleaseLiteral(interp, objPtr) - Tcl_Interp *interp; /* Interpreter for which objPtr was created - * to hold a literal. */ + Tcl_Interp *interp; /* Interpreter for which objPtr was created to + * hold a literal. */ register Tcl_Obj *objPtr; /* Points to a literal object that was * previously created by a call to * TclRegisterLiteral. */ { Interp *iPtr = (Interp *) interp; @@ -764,28 +782,27 @@ bytes = Tcl_GetStringFromObj(objPtr, &length); index = (HashString(bytes, length) & globalTablePtr->mask); /* - * Check to see if the object is in the global literal table and - * remove this reference. The object may not be in the table if - * it is a hidden local literal. + * Check to see if the object is in the global literal table and remove + * this reference. The object may not be in the table if it is a hidden + * local literal. */ for (prevPtr = NULL, entryPtr = globalTablePtr->buckets[index]; entryPtr != NULL; prevPtr = entryPtr, entryPtr = entryPtr->nextPtr) { if (entryPtr->objPtr == objPtr) { entryPtr->refCount--; /* - * If the literal is no longer being used by any ByteCode, - * delete the entry then remove the reference corresponding - * to the global literal table entry (decrement the ref count - * of the object). + * If the literal is no longer being used by any ByteCode, delete + * the entry then remove the reference corresponding to the global + * literal table entry (decrement the ref count of the object). */ - + if (entryPtr->refCount == 0) { if (prevPtr == NULL) { globalTablePtr->buckets[index] = entryPtr->nextPtr; } else { prevPtr->nextPtr = entryPtr->nextPtr; @@ -802,12 +819,11 @@ break; } } /* - * Remove the reference corresponding to the local literal table - * entry. + * Remove the reference corresponding to the local literal table entry. */ Tcl_DecrRefCount(objPtr); } @@ -814,46 +830,44 @@ /* *---------------------------------------------------------------------- * * HashString -- * - * Compute a one-word summary of a text string, which can be - * used to generate a hash index. + * Compute a one-word summary of a text string, which can be used to + * generate a hash index. * * Results: - * The return value is a one-word summary of the information in - * string. + * The return value is a one-word summary of the information in string. * * Side effects: * None. * *---------------------------------------------------------------------- */ static unsigned int HashString(bytes, length) - register CONST char *bytes; /* String for which to compute hash - * value. */ + register CONST char *bytes; /* String for which to compute hash value. */ int length; /* Number of bytes in the string. */ { register unsigned int result; register int i; /* - * I tried a zillion different hash functions and asked many other - * people for advice. Many people had their own favorite functions, - * all different, but no-one had much idea why they were good ones. - * I chose the one below (multiply by 9 and add new character) - * because of the following reasons: - * - * 1. Multiplying by 10 is perfect for keys that are decimal strings, - * and multiplying by 9 is just about as good. - * 2. Times-9 is (shift-left-3) plus (old). This means that each - * character's bits hang around in the low-order bits of the - * hash value for ever, plus they spread fairly rapidly up to - * the high-order bits to fill out the hash value. This seems - * works well both for decimal and non-decimal strings. + * I tried a zillion different hash functions and asked many other people + * for advice. Many people had their own favorite functions, all + * different, but no-one had much idea why they were good ones. I chose + * the one below (multiply by 9 and add new character) because of the + * following reasons: + * + * 1. Multiplying by 10 is perfect for keys that are decimal strings, and + * multiplying by 9 is just about as good. + * 2. Times-9 is (shift-left-3) plus (old). This means that each + * character's bits hang around in the low-order bits of the hash value + * for ever, plus they spread fairly rapidly up to the high-order bits + * to fill out the hash value. This seems works well both for decimal + * and non-decimal strings. */ result = 0; for (i=0 ; inumBuckets; oldBuckets = tablePtr->buckets; /* - * Allocate and initialize the new bucket array, and set up - * hashing constants for new array size. + * Allocate and initialize the new bucket array, and set up hashing + * constants for new array size. */ tablePtr->numBuckets *= 4; tablePtr->buckets = (LiteralEntry **) ckalloc((unsigned) (tablePtr->numBuckets * sizeof(LiteralEntry *))); @@ -911,18 +926,15 @@ /* * Rehash all of the existing entries into the new bucket array. */ - for (oldChainPtr = oldBuckets; - oldSize > 0; - oldSize--, oldChainPtr++) { - for (entryPtr = *oldChainPtr; entryPtr != NULL; - entryPtr = *oldChainPtr) { + for (oldChainPtr=oldBuckets ; oldSize>0 ; oldSize--,oldChainPtr++) { + for (entryPtr=*oldChainPtr ; entryPtr!=NULL ; entryPtr=*oldChainPtr) { bytes = Tcl_GetStringFromObj(entryPtr->objPtr, &length); index = (HashString(bytes, length) & tablePtr->mask); - + *oldChainPtr = entryPtr->nextPtr; bucketPtr = &(tablePtr->buckets[index]); entryPtr->nextPtr = *bucketPtr; *bucketPtr = entryPtr; } @@ -941,17 +953,16 @@ /* *---------------------------------------------------------------------- * * TclLiteralStats -- * - * Return statistics describing the layout of the hash table - * in its hash buckets. + * Return statistics describing the layout of the hash table in its hash + * buckets. * * Results: - * The return value is a malloc-ed string containing information - * about tablePtr. It is the caller's responsibility to free - * this string. + * The return value is a malloc-ed string containing information about + * tablePtr. It is the caller's responsibility to free this string. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -966,12 +977,12 @@ double average, tmp; register LiteralEntry *entryPtr; char *result, *p; /* - * Compute a histogram of bucket usage. For each bucket chain i, - * j is the number of entries in the chain. + * Compute a histogram of bucket usage. For each bucket chain i, j is the + * number of entries in the chain. */ for (i = 0; i < NUM_COUNTERS; i++) { count[i] = 0; } @@ -978,11 +989,11 @@ overflow = 0; average = 0.0; for (i = 0; i < tablePtr->numBuckets; i++) { j = 0; for (entryPtr = tablePtr->buckets[i]; entryPtr != NULL; - entryPtr = entryPtr->nextPtr) { + entryPtr = entryPtr->nextPtr) { j++; } if (j < NUM_COUNTERS) { count[j]++; } else { @@ -1030,12 +1041,12 @@ *---------------------------------------------------------------------- */ void TclVerifyLocalLiteralTable(envPtr) - CompileEnv *envPtr; /* Points to CompileEnv whose literal - * table is to be validated. */ + CompileEnv *envPtr; /* Points to CompileEnv whose literal table is + * to be validated. */ { register LiteralTable *localTablePtr = &(envPtr->localLitTable); register LiteralEntry *localPtr; char *bytes; register int i; @@ -1042,32 +1053,31 @@ int length, count; count = 0; for (i = 0; i < localTablePtr->numBuckets; i++) { for (localPtr = localTablePtr->buckets[i]; - localPtr != NULL; localPtr = localPtr->nextPtr) { + localPtr != NULL; localPtr = localPtr->nextPtr) { count++; if (localPtr->refCount != -1) { bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); Tcl_Panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" had bad refCount %d", - (length>60? 60 : length), bytes, - localPtr->refCount); + (length>60? 60 : length), bytes, localPtr->refCount); } if (TclLookupLiteralEntry((Tcl_Interp *) envPtr->iPtr, localPtr->objPtr) == NULL) { bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); Tcl_Panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" is not global", - (length>60? 60 : length), bytes); + (length>60? 60 : length), bytes); } if (localPtr->objPtr->bytes == NULL) { Tcl_Panic("TclVerifyLocalLiteralTable: literal has NULL string rep"); } } } if (count != localTablePtr->numEntries) { Tcl_Panic("TclVerifyLocalLiteralTable: local literal table had %d entries, should be %d", - count, localTablePtr->numEntries); + count, localTablePtr->numEntries); } } /* *---------------------------------------------------------------------- @@ -1085,12 +1095,12 @@ *---------------------------------------------------------------------- */ void TclVerifyGlobalLiteralTable(iPtr) - Interp *iPtr; /* Points to interpreter whose global - * literal table is to be validated. */ + Interp *iPtr; /* Points to interpreter whose global literal + * table is to be validated. */ { register LiteralTable *globalTablePtr = &(iPtr->literalTable); register LiteralEntry *globalPtr; char *bytes; register int i; @@ -1097,24 +1107,31 @@ int length, count; count = 0; for (i = 0; i < globalTablePtr->numBuckets; i++) { for (globalPtr = globalTablePtr->buckets[i]; - globalPtr != NULL; globalPtr = globalPtr->nextPtr) { + globalPtr != NULL; globalPtr = globalPtr->nextPtr) { count++; if (globalPtr->refCount < 1) { bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length); Tcl_Panic("TclVerifyGlobalLiteralTable: global literal \"%.*s\" had bad refCount %d", - (length>60? 60 : length), bytes, - globalPtr->refCount); + (length>60? 60 : length), bytes, globalPtr->refCount); } if (globalPtr->objPtr->bytes == NULL) { Tcl_Panic("TclVerifyGlobalLiteralTable: literal has NULL string rep"); } } } if (count != globalTablePtr->numEntries) { Tcl_Panic("TclVerifyGlobalLiteralTable: global literal table had %d entries, should be %d", - count, globalTablePtr->numEntries); + count, globalTablePtr->numEntries); } } #endif /*TCL_COMPILE_DEBUG*/ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclLoad.c ================================================================== --- generic/tclLoad.c +++ generic/tclLoad.c @@ -1,38 +1,37 @@ -/* +/* * tclLoad.c -- * - * This file provides the generic portion (those that are the same - * on all platforms) of Tcl's dynamic loading facilities. + * This file provides the generic portion (those that are the same on all + * platforms) of Tcl's dynamic loading facilities. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLoad.c,v 1.13 2004/03/09 12:59:05 vincentdarley Exp $ + * RCS: @(#) $Id: tclLoad.c,v 1.13.2.1 2005/08/02 18:16:01 dgp Exp $ */ #include "tclInt.h" /* - * The following structure describes a package that has been loaded - * either dynamically (with the "load" command) or statically (as - * indicated by a call to TclGetLoadedPackages). All such packages - * are linked together into a single list for the process. Packages - * are never unloaded, until the application exits, when - * TclFinalizeLoad is called, and these structures are freed. + * The following structure describes a package that has been loaded either + * dynamically (with the "load" command) or statically (as indicated by a call + * to TclGetLoadedPackages). All such packages are linked together into a + * single list for the process. Packages are never unloaded, until the + * application exits, when TclFinalizeLoad is called, and these structures are + * freed. */ typedef struct LoadedPackage { - char *fileName; /* Name of the file from which the - * package was loaded. An empty string - * means the package is loaded statically. - * Malloc-ed. */ + char *fileName; /* Name of the file from which the package was + * loaded. An empty string means the package + * is loaded statically. Malloc-ed. */ char *packageName; /* Name of package prefix for the package, * properly capitalized (first letter UC, - * others LC), no "_", as in "Net". + * others LC), no "_", as in "Net". * Malloc-ed. */ Tcl_LoadHandle loadHandle; /* Token for the loaded file which should be * passed to (*unLoadProcPtr)() when the file * is no longer needed. If fileName is NULL, * then this field is irrelevant. */ @@ -42,34 +41,33 @@ * interpreter. */ Tcl_PackageInitProc *safeInitProc; /* Initialization procedure to call to * incorporate this package into a safe * interpreter (one that will execute - * untrusted scripts). NULL means the - * package can't be used in unsafe - * interpreters. */ + * untrusted scripts). NULL means the package + * can't be used in unsafe interpreters. */ Tcl_PackageUnloadProc *unloadProc; - /* Finalisation procedure to unload a package - * from a trusted interpreter. NULL means - * that the package cannot be unloaded. */ + /* Finalisation procedure to unload a package + * from a trusted interpreter. NULL means that + * the package cannot be unloaded. */ Tcl_PackageUnloadProc *safeUnloadProc; - /* Finalisation procedure to unload a package - * from a safe interpreter. NULL means - * that the package cannot be unloaded. */ - int interpRefCount; /* How many times the package has been loaded - in trusted interpreters. */ - int safeInterpRefCount; /* How many times the package has been loaded - in safe interpreters. */ + /* Finalisation procedure to unload a package + * from a safe interpreter. NULL means that + * the package cannot be unloaded. */ + int interpRefCount; /* How many times the package has been loaded + * in trusted interpreters. */ + int safeInterpRefCount; /* How many times the package has been loaded + * in safe interpreters. */ Tcl_FSUnloadFileProc *unLoadProcPtr; /* Procedure to use to unload this package. * If NULL, then we do not attempt to unload * the package. If fileName is NULL, then * this field is irrelevant. */ struct LoadedPackage *nextPtr; /* Next in list of all packages loaded into - * this application process. NULL means - * end of list. */ + * this application process. NULL means end of + * list. */ } LoadedPackage; /* * TCL_THREADS * There is a global list of packages that is anchored at firstPackagePtr. @@ -81,23 +79,23 @@ * this process. */ TCL_DECLARE_MUTEX(packageMutex) /* - * The following structure represents a particular package that has - * been incorporated into a particular interpreter (by calling its - * initialization procedure). There is a list of these structures for - * each interpreter, with an AssocData value (key "load") for the - * interpreter that points to the first package (if any). + * The following structure represents a particular package that has been + * incorporated into a particular interpreter (by calling its initialization + * procedure). There is a list of these structures for each interpreter, with + * an AssocData value (key "load") for the interpreter that points to the + * first package (if any). */ typedef struct InterpPackage { LoadedPackage *pkgPtr; /* Points to detailed information about * package. */ struct InterpPackage *nextPtr; - /* Next package in this interpreter, or - * NULL for end of list. */ + /* Next package in this interpreter, or NULL + * for end of list. */ } InterpPackage; /* * Prototypes for procedures that are private to this file: */ @@ -108,12 +106,12 @@ /* *---------------------------------------------------------------------- * * Tcl_LoadObjCmd -- * - * This procedure is invoked to process the "load" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "load" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -129,33 +127,32 @@ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Interp *target; LoadedPackage *pkgPtr, *defaultPtr; - Tcl_DString pkgName, tmp, initName, safeInitName, - unloadName, safeUnloadName; + Tcl_DString pkgName, tmp, initName, safeInitName; + Tcl_DString unloadName, safeUnloadName; Tcl_PackageInitProc *initProc, *safeInitProc, *unloadProc, *safeUnloadProc; InterpPackage *ipFirstPtr, *ipPtr; - int code, namesMatch, filesMatch; + int code, namesMatch, filesMatch, offset; CONST char *symbols[4]; Tcl_PackageInitProc **procPtrs[4]; ClientData clientData; char *p, *fullFileName, *packageName; Tcl_LoadHandle loadHandle; Tcl_FSUnloadFileProc *unLoadProcPtr = NULL; Tcl_UniChar ch; - int offset; if ((objc < 2) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?"); + Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?"); return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { return TCL_ERROR; } fullFileName = Tcl_GetString(objv[1]); - + Tcl_DStringInit(&pkgName); Tcl_DStringInit(&initName); Tcl_DStringInit(&safeInitName); Tcl_DStringInit(&unloadName); Tcl_DStringInit(&safeUnloadName); @@ -180,28 +177,29 @@ * Figure out which interpreter we're going to load the package into. */ target = interp; if (objc == 4) { - char *slaveIntName; - slaveIntName = Tcl_GetString(objv[3]); + char *slaveIntName = Tcl_GetString(objv[3]); + target = Tcl_GetSlave(interp, slaveIntName); if (target == NULL) { code = TCL_ERROR; goto done; } } /* * Scan through the packages that are currently loaded to see if the - * package we want is already loaded. We'll use a loaded package if - * it meets any of the following conditions: + * package we want is already loaded. We'll use a loaded package if it + * meets any of the following conditions: * - Its name and file match the once we're looking for. * - Its file matches, and we weren't given a name. - * - Its name matches, the file name was specified as empty, and there - * is only no statically loaded package with the same name. + * - Its name matches, the file name was specified as empty, and there is + * only no statically loaded package with the same name. */ + Tcl_MutexLock(&packageMutex); defaultPtr = NULL; for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { if (packageName == NULL) { @@ -229,12 +227,11 @@ if (namesMatch && (fullFileName[0] == 0)) { defaultPtr = pkgPtr; } if (filesMatch && !namesMatch && (fullFileName[0] != 0)) { /* - * Can't have two different packages loaded from the same - * file. + * Can't have two different packages loaded from the same file. */ Tcl_AppendResult(interp, "file \"", fullFileName, "\" is already loaded for package \"", pkgPtr->packageName, "\"", (char *) NULL); @@ -248,12 +245,12 @@ pkgPtr = defaultPtr; } /* * Scan through the list of packages already loaded in the target - * interpreter. If the package we want is already loaded there, - * then there's nothing for us to do. + * interpreter. If the package we want is already loaded there, then + * there's nothing for us to do. */ if (pkgPtr != NULL) { ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", (Tcl_InterpDeleteProc **) NULL); @@ -265,12 +262,12 @@ } } if (pkgPtr == NULL) { /* - * The desired file isn't currently loaded, so load it. It's an - * error if the desired package is a static one. + * The desired file isn't currently loaded, so load it. It's an error + * if the desired package is a static one. */ if (fullFileName[0] == 0) { Tcl_AppendResult(interp, "package \"", packageName, "\" isn't loaded statically", (char *) NULL); @@ -284,26 +281,28 @@ if (packageName != NULL) { Tcl_DStringAppend(&pkgName, packageName, -1); } else { int retc; + /* * Threading note - this call used to be protected by a mutex. */ + retc = TclGuessPackageName(fullFileName, &pkgName); if (!retc) { Tcl_Obj *splitPtr; Tcl_Obj *pkgGuessPtr; int pElements; char *pkgGuess; /* - * The platform-specific code couldn't figure out the - * module name. Make a guess by taking the last element - * of the file name, stripping off any leading "lib", - * and then using all of the alphabetic and underline - * characters that follow that. + * The platform-specific code couldn't figure out the module + * name. Make a guess by taking the last element of the file + * name, stripping off any leading "lib", and then using all + * of the alphabetic and underline characters that follow + * that. */ splitPtr = Tcl_FSSplitPath(objv[1], &pElements); Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr); pkgGuess = Tcl_GetString(pkgGuessPtr); @@ -335,49 +334,51 @@ /* * Fix the capitalization in the package name so that the first * character is in caps (or title case) but the others are all * lower-case. */ - + Tcl_DStringSetLength(&pkgName, Tcl_UtfToTitle(Tcl_DStringValue(&pkgName))); /* - * Compute the names of the two initialization procedures, - * based on the package name. + * Compute the names of the two initialization procedures, based on + * the package name. */ - + Tcl_DStringAppend(&initName, Tcl_DStringValue(&pkgName), -1); Tcl_DStringAppend(&initName, "_Init", 5); Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1); Tcl_DStringAppend(&safeInitName, "_SafeInit", 9); - Tcl_DStringAppend(&unloadName, Tcl_DStringValue(&pkgName), -1); + Tcl_DStringAppend(&unloadName, Tcl_DStringValue(&pkgName), -1); Tcl_DStringAppend(&unloadName, "_Unload", 7); - Tcl_DStringAppend(&safeUnloadName, Tcl_DStringValue(&pkgName), -1); + Tcl_DStringAppend(&safeUnloadName, Tcl_DStringValue(&pkgName), -1); Tcl_DStringAppend(&safeUnloadName, "_SafeUnload", 11); /* - * Call platform-specific code to load the package and find the - * two initialization procedures. + * Call platform-specific code to load the package and find the two + * initialization procedures. */ - symbols[0] = Tcl_DStringValue(&initName); - symbols[1] = Tcl_DStringValue(&safeInitName); - symbols[2] = Tcl_DStringValue(&unloadName); - symbols[3] = Tcl_DStringValue(&safeUnloadName); - procPtrs[0] = &initProc; - procPtrs[1] = &safeInitProc; - procPtrs[2] = &unloadProc; - procPtrs[3] = &safeUnloadProc; + symbols[0] = Tcl_DStringValue(&initName); + symbols[1] = Tcl_DStringValue(&safeInitName); + symbols[2] = Tcl_DStringValue(&unloadName); + symbols[3] = Tcl_DStringValue(&safeUnloadName); + procPtrs[0] = &initProc; + procPtrs[1] = &safeInitProc; + procPtrs[2] = &unloadProc; + procPtrs[3] = &safeUnloadProc; + Tcl_MutexLock(&packageMutex); code = TclLoadFile(interp, objv[1], 4, symbols, procPtrs, &loadHandle, &clientData, &unLoadProcPtr); Tcl_MutexUnlock(&packageMutex); - loadHandle = (Tcl_LoadHandle) clientData; + loadHandle = (Tcl_LoadHandle) clientData; if (code != TCL_OK) { goto done; } + if (*procPtrs[0] /* initProc */ == NULL) { Tcl_AppendResult(interp, "couldn't find procedure ", Tcl_DStringValue(&initName), (char *) NULL); if (unLoadProcPtr != NULL) { (*unLoadProcPtr)(loadHandle); @@ -399,57 +400,58 @@ strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName)); pkgPtr->loadHandle = loadHandle; pkgPtr->unLoadProcPtr = unLoadProcPtr; pkgPtr->initProc = *procPtrs[0]; pkgPtr->safeInitProc = *procPtrs[1]; - pkgPtr->unloadProc = (Tcl_PackageUnloadProc*) *procPtrs[2]; - pkgPtr->safeUnloadProc = (Tcl_PackageUnloadProc*) *procPtrs[3]; - pkgPtr->interpRefCount = 0; - pkgPtr->safeInterpRefCount = 0; + pkgPtr->unloadProc = (Tcl_PackageUnloadProc*) *procPtrs[2]; + pkgPtr->safeUnloadProc = (Tcl_PackageUnloadProc*) *procPtrs[3]; + pkgPtr->interpRefCount = 0; + pkgPtr->safeInterpRefCount = 0; + Tcl_MutexLock(&packageMutex); pkgPtr->nextPtr = firstPackagePtr; firstPackagePtr = pkgPtr; Tcl_MutexUnlock(&packageMutex); } /* - * Invoke the package's initialization procedure (either the - * normal one or the safe one, depending on whether or not the - * interpreter is safe). + * Invoke the package's initialization procedure (either the normal one or + * the safe one, depending on whether or not the interpreter is safe). */ if (Tcl_IsSafe(target)) { if (pkgPtr->safeInitProc != NULL) { code = (*pkgPtr->safeInitProc)(target); } else { Tcl_AppendResult(interp, - "can't use package in a safe interpreter: ", - "no ", pkgPtr->packageName, "_SafeInit procedure", - (char *) NULL); + "can't use package in a safe interpreter: no ", + pkgPtr->packageName, "_SafeInit procedure", (char *) NULL); code = TCL_ERROR; goto done; } } else { code = (*pkgPtr->initProc)(target); } /* - * Record the fact that the package has been loaded in the - * target interpreter. + * Record the fact that the package has been loaded in the target + * interpreter. */ if (code == TCL_OK) { - /* - * Update the proper reference count. - */ - Tcl_MutexLock(&packageMutex); - if (Tcl_IsSafe(target)) { - ++pkgPtr->safeInterpRefCount; - } else { - ++pkgPtr->interpRefCount; - } - Tcl_MutexUnlock(&packageMutex); + /* + * Update the proper reference count. + */ + + Tcl_MutexLock(&packageMutex); + if (Tcl_IsSafe(target)) { + ++pkgPtr->safeInterpRefCount; + } else { + ++pkgPtr->interpRefCount; + } + Tcl_MutexUnlock(&packageMutex); + /* * Refetch ipFirstPtr: loading the package may have introduced * additional static packages at the head of the linked list! */ @@ -462,11 +464,11 @@ (ClientData) ipPtr); } else { TclTransferResult(target, code, interp); } - done: + done: Tcl_DStringFree(&pkgName); Tcl_DStringFree(&initName); Tcl_DStringFree(&safeInitName); Tcl_DStringFree(&unloadName); Tcl_DStringFree(&safeUnloadName); @@ -477,12 +479,12 @@ /* *---------------------------------------------------------------------- * * Tcl_UnloadObjCmd -- * - * This procedure is invoked to process the "unload" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "unload" Tcl command. See + * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -497,26 +499,17 @@ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Interp *target; /* Which interpreter to unload from. */ - LoadedPackage *pkgPtr; - LoadedPackage *defaultPtr; - Tcl_DString pkgName; - Tcl_DString tmp; + LoadedPackage *pkgPtr, *defaultPtr; + Tcl_DString pkgName, tmp; Tcl_PackageUnloadProc *unloadProc; - InterpPackage *ipFirstPtr; - InterpPackage *ipPtr; - int i; - int index; - int code; - int complain = 1; - int keepLibrary = 0; - int trustedRefCount = -1; - int safeRefCount = -1; - char *fullFileName = ""; - char *packageName; + InterpPackage *ipFirstPtr, *ipPtr; + int i, index, code, complain = 1, keepLibrary = 0; + int trustedRefCount = -1, safeRefCount = -1; + char *fullFileName = "", *packageName; static CONST char *options[] = { "-nocomplain", "-keeplibrary", "--", NULL }; enum options { UNLOAD_NOCOMPLAIN, UNLOAD_KEEPLIB, UNLOAD_LAST @@ -526,19 +519,19 @@ if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { fullFileName = Tcl_GetString(objv[i]); if (fullFileName[0] == '-') { /* - * It looks like the command contains an option so signal - * an error + * It looks like the command contains an option so signal an + * error */ return TCL_ERROR; } else { /* - * This clearly isn't an option; assume it's the - * filename. We must clear the error. + * This clearly isn't an option; assume it's the filename. We + * must clear the error. */ Tcl_ResetResult(interp); break; } @@ -553,20 +546,20 @@ case UNLOAD_LAST: /* -- */ i++; goto endOfForLoop; } } - endOfForLoop: + endOfForLoop: if ((objc-i < 1) || (objc-i > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "?switches? fileName ?packageName? ?interp?"); return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { return TCL_ERROR; } - + fullFileName = Tcl_GetString(objv[i]); Tcl_DStringInit(&pkgName); Tcl_DStringInit(&tmp); packageName = NULL; @@ -598,16 +591,16 @@ } } /* * Scan through the packages that are currently loaded to see if the - * package we want is already loaded. We'll use a loaded package if - * it meets any of the following conditions: + * package we want is already loaded. We'll use a loaded package if it + * meets any of the following conditions: * - Its name and file match the once we're looking for. * - Its file matches, and we weren't given a name. - * - Its name matches, the file name was specified as empty, and there - * is only no statically loaded package with the same name. + * - Its name matches, the file name was specified as empty, and there is + * only no statically loaded package with the same name. */ Tcl_MutexLock(&packageMutex); defaultPtr = NULL; @@ -655,12 +648,11 @@ code = TCL_ERROR; goto done; } if (pkgPtr == NULL) { /* - * The DLL pointed by the provided filename has never been - * loaded. + * The DLL pointed by the provided filename has never been loaded. */ Tcl_AppendResult(interp, "file \"", fullFileName, "\" has never been loaded", (char *) NULL); code = TCL_ERROR; @@ -667,12 +659,12 @@ goto done; } /* * Scan through the list of packages already loaded in the target - * interpreter. If the package we want is already loaded there, - * then we should proceed with unloading. + * interpreter. If the package we want is already loaded there, then we + * should proceed with unloading. */ code = TCL_ERROR; if (pkgPtr != NULL) { ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", @@ -686,21 +678,21 @@ } if (code != TCL_OK) { /* * The package has not been loaded in this interpreter. */ + Tcl_AppendResult(interp, "file \"", fullFileName, "\" has never been loaded in this interpreter", (char *) NULL); code = TCL_ERROR; goto done; } /* - * Ensure that the DLL can be unloaded. If it is a trusted - * interpreter, pkgPtr->unloadProc must not be NULL for the DLL to - * be unloadable. If the interpreter is a safe one, - * pkgPtr->safeUnloadProc must be non-NULL. + * Ensure that the DLL can be unloaded. If it is a trusted interpreter, + * pkgPtr->unloadProc must not be NULL for the DLL to be unloadable. If + * the interpreter is a safe one, pkgPtr->safeUnloadProc must be non-NULL. */ if (Tcl_IsSafe(target)) { if (pkgPtr->safeUnloadProc == NULL) { Tcl_AppendResult(interp, "file \"", fullFileName, @@ -721,17 +713,16 @@ unloadProc = pkgPtr->unloadProc; } /* * We are ready to unload the package. First, evaluate the unload - * procedure. If this fails, we cannot proceed with unload. Also, - * we must specify the proper flag to pass to the unload callback. - * TCL_UNLOAD_DETACH_FROM_INTERPRETER is defined when the callback - * should only remove itself from the interpreter; the library - * will be unloaded in a future call of unload. In case the - * library will be unloaded just after the callback returns, - * TCL_UNLOAD_DETACH_FROM_PROCESS is passed. + * procedure. If this fails, we cannot proceed with unload. Also, we must + * specify the proper flag to pass to the unload callback. + * TCL_UNLOAD_DETACH_FROM_INTERPRETER is defined when the callback should + * only remove itself from the interpreter; the library will be unloaded + * in a future call of unload. In case the library will be unloaded just + * after the callback returns, TCL_UNLOAD_DETACH_FROM_PROCESS is passed. */ code = TCL_UNLOAD_DETACH_FROM_INTERPRETER; if (!keepLibrary) { Tcl_MutexLock(&packageMutex); @@ -754,28 +745,32 @@ TclTransferResult(target, code, interp); goto done; } /* - * The unload procedure executed fine. Examine the reference - * count to see if we unload the DLL. + * The unload procedure executed fine. Examine the reference count to see + * if we unload the DLL. */ Tcl_MutexLock(&packageMutex); if (Tcl_IsSafe(target)) { --pkgPtr->safeInterpRefCount; + /* - * Do not let counter get negative + * Do not let counter get negative. */ + if (pkgPtr->safeInterpRefCount < 0) { pkgPtr->safeInterpRefCount = 0; } } else { --pkgPtr->interpRefCount; + /* - * Do not let counter get negative + * Do not let counter get negative. */ + if (pkgPtr->interpRefCount < 0) { pkgPtr->interpRefCount = 0; } } trustedRefCount = pkgPtr->interpRefCount; @@ -789,14 +784,14 @@ * Unload the shared library from the application memory... */ #if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__) /* - * Some Unix dlls are poorly behaved - registering things like - * atexit calls that can't be unregistered. If you unload - * such dlls, you get a core on exit because it wants to call - * a function in the dll after it's been unloaded. + * Some Unix dlls are poorly behaved - registering things like atexit + * calls that can't be unregistered. If you unload such dlls, you get + * a core on exit because it wants to call a function in the dll after + * it's been unloaded. */ if (pkgPtr->fileName[0] != '\0') { Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr; @@ -820,12 +815,11 @@ } } } /* - * Remove this library from the interpreter's library - * cache. + * Remove this library from the interpreter's library cache. */ ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", (Tcl_InterpDeleteProc **) NULL); ipPtr = ipFirstPtr; @@ -861,22 +855,22 @@ "\" cannot be unloaded: unloading disabled", (char *) NULL); code = TCL_ERROR; #endif } - done: + done: Tcl_DStringFree(&pkgName); Tcl_DStringFree(&tmp); if (!complain && code!=TCL_OK) { code = TCL_OK; Tcl_ResetResult(interp); } if (code == TCL_OK) { #if 0 /* - * Result of [unload] was not documented in TIP#100, so force - * to be the empty string by commenting this out. DKF. + * Result of [unload] was not documented in TIP#100, so force to be + * the empty string by commenting this out. DKF. */ Tcl_Obj *resultObjPtr, *objPtr[2]; /* @@ -906,41 +900,41 @@ /* *---------------------------------------------------------------------- * * Tcl_StaticPackage -- * - * This procedure is invoked to indicate that a particular - * package has been linked statically with an application. + * This procedure is invoked to indicate that a particular package has + * been linked statically with an application. * * Results: * None. * * Side effects: - * Once this procedure completes, the package becomes loadable - * via the "load" command with an empty file name. + * Once this procedure completes, the package becomes loadable via the + * "load" command with an empty file name. * *---------------------------------------------------------------------- */ void Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) - Tcl_Interp *interp; /* If not NULL, it means that the - * package has already been loaded - * into the given interpreter by - * calling the appropriate init proc. */ - CONST char *pkgName; /* Name of package (must be properly - * capitalized: first letter upper - * case, others lower case). */ - Tcl_PackageInitProc *initProc; /* Procedure to call to incorporate - * this package into a trusted - * interpreter. */ - Tcl_PackageInitProc *safeInitProc; /* Procedure to call to incorporate - * this package into a safe interpreter - * (one that will execute untrusted - * scripts). NULL means the package - * can't be used in safe - * interpreters. */ + Tcl_Interp *interp; /* If not NULL, it means that the package has + * already been loaded into the given + * interpreter by calling the appropriate init + * proc. */ + CONST char *pkgName; /* Name of package (must be properly + * capitalized: first letter upper case, + * others lower case). */ + Tcl_PackageInitProc *initProc; + /* Procedure to call to incorporate this + * package into a trusted interpreter. */ + Tcl_PackageInitProc *safeInitProc; + /* Procedure to call to incorporate this + * package into a safe interpreter (one that + * will execute untrusted scripts). NULL means + * the package can't be used in safe + * interpreters. */ { LoadedPackage *pkgPtr; InterpPackage *ipPtr, *ipFirstPtr; /* @@ -957,12 +951,12 @@ } } Tcl_MutexUnlock(&packageMutex); /* - * If the package is not yet recorded as being loaded statically, - * add it to the list now. + * If the package is not yet recorded as being loaded statically, add it + * to the list now. */ if ( pkgPtr == NULL ) { pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage)); pkgPtr->fileName = (char *) ckalloc((unsigned) 1); @@ -980,12 +974,12 @@ } if (interp != NULL) { /* - * If we're loading the package into an interpreter, - * determine whether it's already loaded. + * If we're loading the package into an interpreter, determine whether + * it's already loaded. */ ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad", (Tcl_InterpDeleteProc **) NULL); for ( ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr ) { @@ -993,12 +987,12 @@ return; } } /* - * Package isn't loade in the current interp yet. Mark it as - * now being loaded. + * Package isn't loade in the current interp yet. Mark it as now being + * loaded. */ ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage)); ipPtr->pkgPtr = pkgPtr; ipPtr->nextPtr = ipFirstPtr; @@ -1010,44 +1004,42 @@ /* *---------------------------------------------------------------------- * * TclGetLoadedPackages -- * - * This procedure returns information about all of the files - * that are loaded (either in a particular intepreter, or - * for all interpreters). + * This procedure returns information about all of the files that are + * loaded (either in a particular intepreter, or for all interpreters). * * Results: - * The return value is a standard Tcl completion code. If - * successful, a list of lists is placed in the interp's result. - * Each sublist corresponds to one loaded file; its first - * element is the name of the file (or an empty string for - * something that's statically loaded) and the second element - * is the name of the package in that file. + * The return value is a standard Tcl completion code. If successful, a + * list of lists is placed in the interp's result. Each sublist + * corresponds to one loaded file; its first element is the name of the + * file (or an empty string for something that's statically loaded) and + * the second element is the name of the package in that file. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclGetLoadedPackages(interp, targetName) - Tcl_Interp *interp; /* Interpreter in which to return - * information or error message. */ - char *targetName; /* Name of target interpreter or NULL. - * If NULL, return info about all interps; + Tcl_Interp *interp; /* Interpreter in which to return information + * or error message. */ + char *targetName; /* Name of target interpreter or NULL. If + * NULL, return info about all interps; * otherwise, just return info about this * interpreter. */ { Tcl_Interp *target; LoadedPackage *pkgPtr; InterpPackage *ipPtr; char *prefix; if (targetName == NULL) { - /* + /* * Return information about all of the available packages. */ prefix = "{"; Tcl_MutexLock(&packageMutex); @@ -1062,12 +1054,12 @@ Tcl_MutexUnlock(&packageMutex); return TCL_OK; } /* - * Return information about only the packages that are loaded in - * a given interpreter. + * Return information about only the packages that are loaded in a given + * interpreter. */ target = Tcl_GetSlave(interp, targetName); if (target == NULL) { return TCL_ERROR; @@ -1089,20 +1081,20 @@ /* *---------------------------------------------------------------------- * * LoadCleanupProc -- * - * This procedure is called to delete all of the InterpPackage - * structures for an interpreter when the interpreter is deleted. - * It gets invoked via the Tcl AssocData mechanism. + * This procedure is called to delete all of the InterpPackage structures + * for an interpreter when the interpreter is deleted. It gets invoked + * via the Tcl AssocData mechanism. * * Results: * None. * * Side effects: - * Storage for all of the InterpPackage procedures for interp - * get deleted. + * Storage for all of the InterpPackage procedures for interp get + * deleted. * *---------------------------------------------------------------------- */ static void @@ -1124,12 +1116,12 @@ /* *---------------------------------------------------------------------- * * TclFinalizeLoad -- * - * This procedure is invoked just before the application exits. - * It frees all of the LoadedPackage structures. + * This procedure is invoked just before the application exits. It frees + * all of the LoadedPackage structures. * * Results: * None. * * Side effects: @@ -1142,35 +1134,44 @@ TclFinalizeLoad() { LoadedPackage *pkgPtr; /* - * No synchronization here because there should just be - * one thread alive at this point. Logically, - * packageMutex should be grabbed at this point, but - * the Mutexes get finalized before the call to this routine. - * The only subsystem left alive at this point is the - * memory allocator. + * No synchronization here because there should just be one thread alive + * at this point. Logically, packageMutex should be grabbed at this point, + * but the Mutexes get finalized before the call to this routine. The + * only subsystem left alive at this point is the memory allocator. */ while (firstPackagePtr != NULL) { pkgPtr = firstPackagePtr; firstPackagePtr = pkgPtr->nextPtr; + #if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__) /* - * Some Unix dlls are poorly behaved - registering things like - * atexit calls that can't be unregistered. If you unload - * such dlls, you get a core on exit because it wants to - * call a function in the dll after it's been unloaded. + * Some Unix dlls are poorly behaved - registering things like atexit + * calls that can't be unregistered. If you unload such dlls, you get + * a core on exit because it wants to call a function in the dll after + * it's been unloaded. */ + if (pkgPtr->fileName[0] != '\0') { Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr; if (unLoadProcPtr != NULL) { - (*unLoadProcPtr)(pkgPtr->loadHandle); + (*unLoadProcPtr)(pkgPtr->loadHandle); } } #endif + ckfree(pkgPtr->fileName); ckfree(pkgPtr->packageName); ckfree((char *) pkgPtr); } } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclMain.c ================================================================== --- generic/tclMain.c +++ generic/tclMain.c @@ -1,58 +1,64 @@ -/* +/* * tclMain.c -- * * Main program for Tcl shells and other Tcl-based applications. * * Copyright (c) 1988-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 2000 Ajuba Solutions. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclMain.c,v 1.30 2004/11/13 00:19:10 dgp Exp $ + * RCS: @(#) $Id: tclMain.c,v 1.30.2.3 2005/10/08 13:44:37 dgp Exp $ */ #include "tclInt.h" -# undef TCL_STORAGE_CLASS -# define TCL_STORAGE_CLASS DLLEXPORT +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLEXPORT + +/* + * The default prompt used when the user has not overridden it. + */ + +#define DEFAULT_PRIMARY_PROMPT "% " /* - * Declarations for various library procedures and variables (don't want - * to include tclPort.h here, because people might copy this file out of - * the Tcl source directory to make their own modified versions). + * Declarations for various library procedures and variables (don't want to + * include tclPort.h here, because people might copy this file out of the Tcl + * source directory to make their own modified versions). */ extern DLLIMPORT int isatty _ANSI_ARGS_((int fd)); static Tcl_Obj *tclStartupScriptPath = NULL; static Tcl_Obj *tclStartupScriptEncoding = NULL; static Tcl_MainLoopProc *mainLoopProc = NULL; -/* - * Structure definition for information used to keep the state of - * an interactive command processor that reads lines from standard - * input and writes prompts and results to standard output. +/* + * Structure definition for information used to keep the state of an + * interactive command processor that reads lines from standard input and + * writes prompts and results to standard output. */ typedef enum { - PROMPT_NONE, /* Print no prompt */ - PROMPT_START, /* Print prompt for command start */ - PROMPT_CONTINUE /* Print prompt for command continuation */ + PROMPT_NONE, /* Print no prompt */ + PROMPT_START, /* Print prompt for command start */ + PROMPT_CONTINUE /* Print prompt for command continuation */ } PromptType; typedef struct InteractiveState { - Tcl_Channel input; /* The standard input channel from which - * lines are read. */ - int tty; /* Non-zero means standard input is a - * terminal-like device. Zero means it's - * a file. */ - Tcl_Obj *commandPtr; /* Used to assemble lines of input into - * Tcl commands. */ + Tcl_Channel input; /* The standard input channel from which lines + * are read. */ + int tty; /* Non-zero means standard input is a + * terminal-like device. Zero means it's a + * file. */ + Tcl_Obj *commandPtr; /* Used to assemble lines of input into Tcl + * commands. */ PromptType prompt; /* Next prompt to print */ Tcl_Interp *interp; /* Interpreter that evaluates interactive * commands. */ } InteractiveState; @@ -62,28 +68,29 @@ static void Prompt _ANSI_ARGS_((Tcl_Interp *interp, PromptType *promptPtr)); static void StdinProc _ANSI_ARGS_((ClientData clientData, int mask)); - /* *---------------------------------------------------------------------- * * Tcl_SetStartupScript -- * - * Sets the path and encoding of the startup script to be evaluated - * by Tcl_Main, used to override the command line processing. + * Sets the path and encoding of the startup script to be evaluated by + * Tcl_Main, used to override the command line processing. * * Results: - * None. + * None. * * Side effects: * *---------------------------------------------------------------------- */ -void Tcl_SetStartupScript(path, encoding) + +void +Tcl_SetStartupScript(path, encoding) Tcl_Obj *path; /* Filesystem path of startup script file */ CONST char *encoding; /* Encoding of the data in that file */ { Tcl_Obj *newEncoding = NULL; if (encoding != NULL) { @@ -104,34 +111,35 @@ tclStartupScriptEncoding = newEncoding; if (tclStartupScriptEncoding != NULL) { Tcl_IncrRefCount(tclStartupScriptEncoding); } } - /* *---------------------------------------------------------------------- * * Tcl_GetStartupScript -- * - * Gets the path and encoding of the startup script to be evaluated - * by Tcl_Main. + * Gets the path and encoding of the startup script to be evaluated by + * Tcl_Main. * * Results: * The path of the startup script; NULL if none has been set. * * Side effects: - * If encodingPtr is not NULL, stores a (CONST char *) in it - * pointing to the encoding name registered for the startup - * script. Tcl retains ownership of the string, and may free - * it. Caller should make a copy for long-term use. + * If encodingPtr is not NULL, stores a (CONST char *) in it pointing to + * the encoding name registered for the startup script. Tcl retains + * ownership of the string, and may free it. Caller should make a copy + * for long-term use. * *---------------------------------------------------------------------- */ -Tcl_Obj *Tcl_GetStartupScript(encodingPtr) - CONST char** encodingPtr; /* When not NULL, points to storage for - * the (CONST char *) that points to the + +Tcl_Obj * +Tcl_GetStartupScript(encodingPtr) + CONST char **encodingPtr; /* When not NULL, points to storage for the + * (CONST char *) that points to the * registered encoding name for the startup * script */ { if (encodingPtr != NULL) { if (tclStartupScriptEncoding == NULL) { @@ -140,97 +148,104 @@ *encodingPtr = Tcl_GetString(tclStartupScriptEncoding); } } return tclStartupScriptPath; } - + /* *---------------------------------------------------------------------- * * TclSetStartupScriptPath -- * - * Primes the startup script VFS path, used to override the - * command line processing. + * Primes the startup script VFS path, used to override the command line + * processing. * * Results: - * None. + * None. * * Side effects: - * This procedure initializes the VFS path of the Tcl script to - * run at startup. + * This procedure initializes the VFS path of the Tcl script to run at + * startup. * *---------------------------------------------------------------------- */ -void TclSetStartupScriptPath(path) + +void +TclSetStartupScriptPath(path) Tcl_Obj *path; { Tcl_SetStartupScript(path, NULL); } - + /* *---------------------------------------------------------------------- * * TclGetStartupScriptPath -- * - * Gets the startup script VFS path, used to override the - * command line processing. + * Gets the startup script VFS path, used to override the command line + * processing. * * Results: * The startup script VFS path, NULL if none has been set. * * Side effects: * None. * *---------------------------------------------------------------------- */ -Tcl_Obj *TclGetStartupScriptPath() + +Tcl_Obj * +TclGetStartupScriptPath() { return Tcl_GetStartupScript(NULL); } - + /* *---------------------------------------------------------------------- * * TclSetStartupScriptFileName -- * - * Primes the startup script file name, used to override the - * command line processing. + * Primes the startup script file name, used to override the command line + * processing. * * Results: - * None. + * None. * * Side effects: - * This procedure initializes the file name of the Tcl script to - * run at startup. + * This procedure initializes the file name of the Tcl script to run at + * startup. * *---------------------------------------------------------------------- */ -void TclSetStartupScriptFileName(fileName) + +void +TclSetStartupScriptFileName(fileName) CONST char *fileName; { Tcl_Obj *path = Tcl_NewStringObj(fileName,-1); Tcl_SetStartupScript(path, NULL); } - /* *---------------------------------------------------------------------- * * TclGetStartupScriptFileName -- * - * Gets the startup script file name, used to override the - * command line processing. + * Gets the startup script file name, used to override the command line + * processing. * * Results: * The startup script file name, NULL if none has been set. * * Side effects: * None. * *---------------------------------------------------------------------- */ -CONST char *TclGetStartupScriptFileName() + +CONST char * +TclGetStartupScriptFileName() { Tcl_Obj *path = Tcl_GetStartupScript(NULL); if (path == NULL) { return NULL; @@ -239,49 +254,50 @@ } /*---------------------------------------------------------------------- * * Tcl_SourceRCFile -- - * - * This procedure is typically invoked by Tcl_Main of Tk_Main - * procedure to source an application specific rc file into the - * interpreter at startup time. - * + * + * This procedure is typically invoked by Tcl_Main of Tk_Main procedure + * to source an application specific rc file into the interpreter at + * startup time. + * * Results: - * None. + * None. * * Side effects: - * Depends on what's in the rc script. + * Depends on what's in the rc script. * *---------------------------------------------------------------------- */ - + void Tcl_SourceRCFile(interp) - Tcl_Interp *interp; /* Interpreter to source rc file into. */ + Tcl_Interp *interp; /* Interpreter to source rc file into. */ { - Tcl_DString temp; + Tcl_DString temp; CONST char *fileName; Tcl_Channel errChannel; fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); - if (fileName != NULL) { - Tcl_Channel c; - CONST char *fullName; + if (fileName != NULL) { + Tcl_Channel c; + CONST char *fullName; Tcl_DStringInit(&temp); fullName = Tcl_TranslateFileName(interp, fileName, &temp); - if (fullName == NULL) { + if (fullName == NULL) { /* - * Couldn't translate the file name (e.g. it referred to a - * bogus user or there was no HOME environment variable). - * Just do nothing. + * Couldn't translate the file name (e.g. it referred to a bogus + * user or there was no HOME environment variable). Just do + * nothing. */ } else { - /* - * Test for the existence of the rc file before trying to read it. + /* + * Test for the existence of the rc file before trying to read it. */ + c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); if (c != (Tcl_Channel) NULL) { Tcl_Close(NULL, c); if (Tcl_EvalFile(interp, fullName) != TCL_OK) { errChannel = Tcl_GetStdChannel(TCL_STDERR); @@ -301,17 +317,17 @@ * Tcl_Main -- * * Main program for tclsh and most other Tcl-based applications. * * Results: - * None. This procedure never returns (it exits the process when - * it's done). + * None. This procedure never returns (it exits the process when it's + * done). * * Side effects: - * This procedure initializes the Tcl world and then starts - * interpreting commands; almost anything could happen, depending - * on the script being interpreted. + * This procedure initializes the Tcl world and then starts interpreting + * commands; almost anything could happen, depending on the script being + * interpreted. * *---------------------------------------------------------------------- */ void @@ -318,40 +334,35 @@ Tcl_Main(argc, argv, appInitProc) int argc; /* Number of arguments. */ char **argv; /* Array of argument strings. */ Tcl_AppInitProc *appInitProc; /* Application-specific initialization - * procedure to call after most - * initialization but before starting to - * execute commands. */ -{ - Tcl_Obj *path; - Tcl_Obj *resultPtr; - Tcl_Obj *commandPtr = NULL; - CONST char *encodingName = NULL; - char *args; - PromptType prompt = PROMPT_START; - int code, length, tty; - int exitCode = 0; + * procedure to call after most initialization + * but before starting to execute commands. */ +{ + Tcl_Obj *path, *resultPtr, *argvPtr, *commandPtr = NULL; + CONST char *encodingName = NULL; + PromptType prompt = PROMPT_START; + int code, length, tty, exitCode = 0; Tcl_Channel inChannel, outChannel, errChannel; Tcl_Interp *interp; - Tcl_DString argString; + Tcl_DString appName; Tcl_FindExecutable(argv[0]); interp = Tcl_CreateInterp(); Tcl_InitMemory(interp); /* - * If the application has not already set a startup script, parse - * the first few command line arguments to determine the script - * path and encoding. + * If the application has not already set a startup script, parse the + * first few command line arguments to determine the script path and + * encoding. */ if (NULL == Tcl_GetStartupScript(NULL)) { - /* + /* * Check whether first 3 args (argv[1] - argv[3]) look like * -encoding ENCODING FILENAME * or like * FILENAME */ @@ -366,44 +377,44 @@ argc--; argv++; } } - /* - * The CONST casting is safe, and better we do it here than force - * all callers of Tcl_Main to do it. (Those callers are likely - * in a main() that can't easily change its signature.) - */ - - args = Tcl_Merge(argc-1, (CONST char **)argv+1); - Tcl_ExternalToUtfDString(NULL, args, -1, &argString); - Tcl_SetVar(interp, "argv", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY); - Tcl_DStringFree(&argString); - ckfree(args); - path = Tcl_GetStartupScript(&encodingName); if (path == NULL) { - Tcl_ExternalToUtfDString(NULL, argv[0], -1, &argString); + Tcl_ExternalToUtfDString(NULL, argv[0], -1, &appName); } else { CONST char *pathName = Tcl_GetStringFromObj(path, &length); - Tcl_ExternalToUtfDString(NULL, pathName, length, &argString); - path = Tcl_NewStringObj(Tcl_DStringValue(&argString), -1); + Tcl_ExternalToUtfDString(NULL, pathName, length, &appName); + path = Tcl_NewStringObj(Tcl_DStringValue(&appName), -1); Tcl_SetStartupScript(path, encodingName); } + Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&appName), TCL_GLOBAL_ONLY); + Tcl_DStringFree(&appName); + argc--; + argv++; + + Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY); - Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc-1), - TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY); + argvPtr = Tcl_NewListObj(0, NULL); + while (argc--) { + Tcl_DString ds; + Tcl_ExternalToUtfDString(NULL, *argv++, -1, &ds); + Tcl_ListObjAppendElement(NULL, argvPtr, Tcl_NewStringObj( + Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); + Tcl_DStringFree(&ds); + } + Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY); /* * Set the "tcl_interactive" variable. */ tty = isatty(0); Tcl_SetVar(interp, "tcl_interactive", ((path == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY); - + /* * Invoke application-specific initialization. */ Tcl_Preserve((ClientData) interp); @@ -422,13 +433,12 @@ if (Tcl_LimitExceeded(interp)) { goto done; } /* - * If a script file was specified then just source that file - * and quit. Must fetch it again, as the appInitProc might - * have reset it. + * If a script file was specified then just source that file and quit. + * Must fetch it again, as the appInitProc might have reset it. */ path = Tcl_GetStartupScript(&encodingName); if (path != NULL) { code = Tcl_FSEvalFileEx(interp, path, encodingName); @@ -450,34 +460,34 @@ } exitCode = 1; } goto done; } - Tcl_DStringFree(&argString); /* - * We're running interactively. Source a user-specific startup - * file if the application specified one and if the file exists. + * We're running interactively. Source a user-specific startup file if the + * application specified one and if the file exists. */ Tcl_SourceRCFile(interp); if (Tcl_LimitExceeded(interp)) { goto done; } /* - * Process commands from stdin until there's an end-of-file. Note - * that we need to fetch the standard channels again after every - * eval, since they may have been changed. + * Process commands from stdin until there's an end-of-file. Note that we + * need to fetch the standard channels again after every eval, since they + * may have been changed. */ commandPtr = Tcl_NewObj(); Tcl_IncrRefCount(commandPtr); /* * Get a new value for tty if anyone writes to ::tcl_interactive */ + Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, TCL_LINK_BOOLEAN); inChannel = Tcl_GetStdChannel(TCL_STDIN); outChannel = Tcl_GetStdChannel(TCL_STDOUT); while ((inChannel != (Tcl_Channel) NULL) && !Tcl_InterpDeleted(interp)) { if (tty) { @@ -488,35 +498,33 @@ if (Tcl_LimitExceeded(interp)) { break; } inChannel = Tcl_GetStdChannel(TCL_STDIN); if (inChannel == (Tcl_Channel) NULL) { - break; + break; } } if (Tcl_IsShared(commandPtr)) { Tcl_DecrRefCount(commandPtr); commandPtr = Tcl_DuplicateObj(commandPtr); Tcl_IncrRefCount(commandPtr); } - length = Tcl_GetsObj(inChannel, commandPtr); + length = Tcl_GetsObj(inChannel, commandPtr); if (length < 0) { if (Tcl_InputBlocked(inChannel)) { - /* - * This can only happen if stdin has been set to - * non-blocking. In that case cycle back and try - * again. This sets up a tight polling loop (since - * we have no event loop running). If this causes - * bad CPU hogging, we might try toggling the blocking + * This can only happen if stdin has been set to non-blocking. + * In that case cycle back and try again. This sets up a tight + * polling loop (since we have no event loop running). If this + * causes bad CPU hogging, we might try toggling the blocking * on stdin instead. */ continue; } - /* + /* * Either EOF, or an error on stdin; we're done */ break; } @@ -557,25 +565,25 @@ Tcl_WriteObj(outChannel, resultPtr); Tcl_WriteChars(outChannel, "\n", 1); } Tcl_DecrRefCount(resultPtr); } - if (mainLoopProc != NULL) { + if (mainLoopProc != NULL) { /* - * If a main loop has been defined while running interactively, - * we want to start a fileevent based prompt by establishing a + * If a main loop has been defined while running interactively, we + * want to start a fileevent based prompt by establishing a * channel handler for stdin. */ InteractiveState *isPtr = NULL; if (inChannel) { - if (tty) { + if (tty) { Prompt(interp, &prompt); - } - isPtr = (InteractiveState *) + } + isPtr = (InteractiveState *) ckalloc((int) sizeof(InteractiveState)); isPtr->input = inChannel; isPtr->tty = tty; isPtr->commandPtr = commandPtr; isPtr->prompt = prompt; @@ -610,29 +618,28 @@ errChannel = Tcl_GetStdChannel(TCL_STDERR); } #ifdef TCL_MEM_DEBUG /* - * This code here only for the (unsupported and deprecated) - * [checkmem] command. + * This code here only for the (unsupported and deprecated) [checkmem] + * command. */ if (tclMemDumpFileName != NULL) { mainLoopProc = NULL; Tcl_DeleteInterp(interp); } #endif } - done: + done: if ((exitCode == 0) && (mainLoopProc != NULL) && !Tcl_LimitExceeded(interp)) { - /* - * If everything has gone OK so far, call the main loop proc, - * if it exists. Packages (like Tk) can set it to start processing - * events at this point. + * If everything has gone OK so far, call the main loop proc, if it + * exists. Packages (like Tk) can set it to start processing events at + * this point. */ (*mainLoopProc)(); mainLoopProc = NULL; } @@ -639,39 +646,40 @@ if (commandPtr != NULL) { Tcl_DecrRefCount(commandPtr); } /* - * Rather than calling exit, invoke the "exit" command so that - * users can replace "exit" with some other command to do additional - * cleanup on exit. The Tcl_Eval call should never return. + * Rather than calling exit, invoke the "exit" command so that users can + * replace "exit" with some other command to do additional cleanup on + * exit. The Tcl_EvalObjEx call should never return. */ if (!Tcl_InterpDeleted(interp)) { if (!Tcl_LimitExceeded(interp)) { - char buffer[TCL_INTEGER_SPACE + 5]; - - sprintf(buffer, "exit %d", exitCode); - Tcl_Eval(interp, buffer); - } - - /* - * If Tcl_Eval returns, trying to eval [exit], something - * unusual is happening. Maybe interp has been deleted; maybe - * [exit] was redefined, maybe we've blown up because of an - * exceeded limit. We still want to cleanup and exit. - */ - - if (!Tcl_InterpDeleted(interp)) { - Tcl_DeleteInterp(interp); - } + Tcl_Obj *cmd = Tcl_NewObj(); + TclObjPrintf(NULL, cmd, "exit %d", exitCode); + Tcl_IncrRefCount(cmd); + Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL); + Tcl_DecrRefCount(cmd); + } + + /* + * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual + * is happening. Maybe interp has been deleted; maybe [exit] was + * redefined, maybe we've blown up because of an exceeded limit. We + * still want to cleanup and exit. + */ + + if (!Tcl_InterpDeleted(interp)) { + Tcl_DeleteInterp(interp); + } } Tcl_SetStartupScript(NULL, NULL); /* - * If we get here, the master interp has been deleted. Allow - * its destruction with the last matching Tcl_Release. + * If we get here, the master interp has been deleted. Allow its + * destruction with the last matching Tcl_Release. */ Tcl_Release((ClientData) interp); Tcl_Exit(exitCode); } @@ -685,12 +693,12 @@ * * Results: * Returns the previously defined main loop procedure. * * Side effects: - * This procedure will be called before Tcl exits, allowing for - * the creation of an event loop. + * This procedure will be called before Tcl exits, allowing for the + * creation of an event loop. * *--------------------------------------------------------------- */ void @@ -703,30 +711,29 @@ /* *---------------------------------------------------------------------- * * StdinProc -- * - * This procedure is invoked by the event dispatcher whenever - * standard input becomes readable. It grabs the next line of - * input characters, adds them to a command being assembled, and - * executes the command if it's complete. + * This procedure is invoked by the event dispatcher whenever standard + * input becomes readable. It grabs the next line of input characters, + * adds them to a command being assembled, and executes the command if + * it's complete. * * Results: * None. * * Side effects: - * Could be almost arbitrary, depending on the command that's - * typed. + * Could be almost arbitrary, depending on the command that's typed. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static void StdinProc(clientData, mask) - ClientData clientData; /* The state of interactive cmd line */ - int mask; /* Not used. */ + ClientData clientData; /* The state of interactive cmd line */ + int mask; /* Not used. */ { InteractiveState *isPtr = (InteractiveState *) clientData; Tcl_Channel chan = isPtr->input; Tcl_Obj *commandPtr = isPtr->commandPtr; Tcl_Interp *interp = isPtr->interp; @@ -742,14 +749,15 @@ if (Tcl_InputBlocked(chan)) { return; } if (isPtr->tty) { /* - * Would be better to find a way to exit the mainLoop? - * Or perhaps evaluate [exit]? Leaving as is for now due - * to compatibility concerns. + * Would be better to find a way to exit the mainLoop? Or perhaps + * evaluate [exit]? Leaving as is for now due to compatibility + * concerns. */ + Tcl_Exit(0); } Tcl_DeleteChannelHandler(chan, StdinProc, (ClientData) isPtr); return; } @@ -759,21 +767,20 @@ Tcl_DecrRefCount(commandPtr); commandPtr = Tcl_DuplicateObj(commandPtr); Tcl_IncrRefCount(commandPtr); } Tcl_AppendToObj(commandPtr, "\n", 1); - isPtr->prompt = PROMPT_CONTINUE; - goto prompt; + isPtr->prompt = PROMPT_CONTINUE; + goto prompt; } isPtr->prompt = PROMPT_START; /* * Disable the stdin channel handler while evaluating the command; - * otherwise if the command re-enters the event loop we might - * process commands from stdin before the current command is - * finished. Among other things, this will trash the text of the - * command being evaluated. + * otherwise if the command re-enters the event loop we might process + * commands from stdin before the current command is finished. Among other + * things, this will trash the text of the command being evaluated. */ Tcl_CreateChannelHandler(chan, 0, StdinProc, (ClientData) isPtr); code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL); isPtr->input = chan = Tcl_GetStdChannel(TCL_STDIN); @@ -804,11 +811,11 @@ /* * If a tty stdin is still around, output a prompt. */ - prompt: + prompt: if (isPtr->tty && (isPtr->input != (Tcl_Channel) NULL)) { Prompt(interp, &(isPtr->prompt)); isPtr->input = Tcl_GetStdChannel(TCL_STDIN); } } @@ -816,29 +823,28 @@ /* *---------------------------------------------------------------------- * * Prompt -- * - * Issue a prompt on standard output, or invoke a script - * to issue the prompt. + * Issue a prompt on standard output, or invoke a script to issue the + * prompt. * * Results: * None. * * Side effects: - * A prompt gets output, and a Tcl script may be evaluated - * in interp. + * A prompt gets output, and a Tcl script may be evaluated in interp. * *---------------------------------------------------------------------- */ static void Prompt(interp, promptPtr) - Tcl_Interp *interp; /* Interpreter to use for prompting. */ - PromptType *promptPtr; /* Points to type of prompt to print. - * Filled with PROMPT_NONE after a - * prompt is printed. */ + Tcl_Interp *interp; /* Interpreter to use for prompting. */ + PromptType *promptPtr; /* Points to type of prompt to print. Filled + * with PROMPT_NONE after a prompt is + * printed. */ { Tcl_Obj *promptCmdPtr; int code; Tcl_Channel outChannel, errChannel; @@ -847,34 +853,45 @@ } promptCmdPtr = Tcl_GetVar2Ex(interp, ((*promptPtr == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"), NULL, TCL_GLOBAL_ONLY); + if (Tcl_InterpDeleted(interp)) { return; } if (promptCmdPtr == NULL) { - defaultPrompt: + defaultPrompt: outChannel = Tcl_GetStdChannel(TCL_STDOUT); if ((*promptPtr == PROMPT_START) && (outChannel != (Tcl_Channel) NULL)) { - Tcl_WriteChars(outChannel, "% ", 2); + Tcl_WriteChars(outChannel, DEFAULT_PRIMARY_PROMPT, + strlen(DEFAULT_PRIMARY_PROMPT)); } } else { code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL); if (code != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (script that generates prompt)"); errChannel = Tcl_GetStdChannel(TCL_STDERR); - if (errChannel != (Tcl_Channel) NULL) { - Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); - Tcl_WriteChars(errChannel, "\n", 1); - } + if (errChannel != (Tcl_Channel) NULL) { + Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); + Tcl_WriteChars(errChannel, "\n", 1); + } goto defaultPrompt; } } + outChannel = Tcl_GetStdChannel(TCL_STDOUT); if (outChannel != (Tcl_Channel) NULL) { Tcl_Flush(outChannel); } *promptPtr = PROMPT_NONE; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclNamesp.c ================================================================== --- generic/tclNamesp.c +++ generic/tclNamesp.c @@ -3,27 +3,27 @@ * * Contains support for namespaces, which provide a separate context of * commands and global variables. The global :: namespace is the * traditional Tcl "global" scope. Other namespaces are created as * children of the global namespace. These other namespaces contain - * special-purpose commands and variables for packages. Also includes + * special-purpose commands and variables for packages. Also includes * the TIP#112 ensemble machinery. * * Copyright (c) 1993-1997 Lucent Technologies. * Copyright (c) 1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. - * Copyright (c) 2002-2004 Donal K. Fellows. + * Copyright (c) 2002-2005 Donal K. Fellows. * * Originally implemented by * Michael J. McLennan * Bell Labs Innovations for Lucent Technologies * mmclennan@lucent.com * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclNamesp.c,v 1.66 2004/12/02 10:48:30 dkf Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.66.2.10 2005/09/15 20:58:39 dgp Exp $ */ #include "tclInt.h" /* @@ -32,12 +32,12 @@ */ #define NUM_TRAIL_ELEMS 5 /* - * Thread-local storage used to avoid having a global lock on data - * that is not limited to a single interpreter. + * Thread-local storage used to avoid having a global lock on data that is not + * limited to a single interpreter. */ typedef struct ThreadSpecificData { long numNsCreated; /* Count of the number of namespaces created * within the thread. This value is used as a @@ -51,77 +51,75 @@ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* - * This structure contains a cached pointer to a namespace that is the - * result of resolving the namespace's name in some other namespace. It is - * the internal representation for a nsName object. It contains the - * pointer along with some information that is used to check the cached - * pointer's validity. + * This structure contains a cached pointer to a namespace that is the result + * of resolving the namespace's name in some other namespace. It is the + * internal representation for a nsName object. It contains the pointer along + * with some information that is used to check the cached pointer's validity. */ typedef struct ResolvedNsName { Namespace *nsPtr; /* A cached namespace pointer. */ - long nsId; /* nsPtr's unique namespace id. Used to - * verify that nsPtr is still valid - * (e.g., it's possible that the namespace - * was deleted and a new one created at - * the same address). */ + long nsId; /* nsPtr's unique namespace id. Used to verify + * that nsPtr is still valid (e.g., it's + * possible that the namespace was deleted and + * a new one created at the same address). */ Namespace *refNsPtr; /* Points to the namespace containing the - * reference (not the namespace that - * contains the referenced namespace). */ - int refCount; /* Reference count: 1 for each nsName - * object that has a pointer to this - * ResolvedNsName structure as its internal - * rep. This structure can be freed when - * refCount becomes zero. */ + * reference (not the namespace that contains + * the referenced namespace). */ + int refCount; /* Reference count: 1 for each nsName object + * that has a pointer to this ResolvedNsName + * structure as its internal rep. This + * structure can be freed when refCount + * becomes zero. */ } ResolvedNsName; /* - * The client data for an ensemble command. This consists of the - * table of commands that are actually exported by the namespace, and - * an epoch counter that, combined with the exportLookupEpoch field of - * the namespace structure, defines whether the table contains valid - * data or will need to be recomputed next time the ensemble command - * is called. + * The client data for an ensemble command. This consists of the table of + * commands that are actually exported by the namespace, and an epoch counter + * that, combined with the exportLookupEpoch field of the namespace structure, + * defines whether the table contains valid data or will need to be recomputed + * next time the ensemble command is called. */ typedef struct EnsembleConfig { Namespace *nsPtr; /* The namspace backing this ensemble up. */ Tcl_Command token; /* The token for the command that provides - * ensemble support for the namespace, or - * NULL if the command has been deleted (or - * never existed; the global namespace never - * has an ensemble command.) */ + * ensemble support for the namespace, or NULL + * if the command has been deleted (or never + * existed; the global namespace never has an + * ensemble command.) */ int epoch; /* The epoch at which this ensemble's table of * exported commands is valid. */ - char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all + char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all * consistent points, this will have the same * number of entries as there are entries in * the subcommandTable hash. */ Tcl_HashTable subcommandTable; /* Hash table of ensemble subcommand names, * which are its keys so this also provides * the storage management for those subcommand - * names. The contents of the entry values are + * names. The contents of the entry values are * object version the prefix lists to use when * substituting for the command/subcommand to * build the ensemble implementation command. * Has to be stored here as well as in * subcommandDict because that field is NULL * when we are deriving the ensemble from the - * namespace exports list. - * FUTURE WORK: use object hash table here. */ + * namespace exports list. FUTURE WORK: use + * object hash table here. */ struct EnsembleConfig *next;/* The next ensemble in the linked list of * ensembles associated with a namespace. If * this field points to this ensemble, the * structure has already been unlinked from * all lists, and cannot be found by scanning * the list from the namespace's ensemble * field. */ - int flags; /* ORed combo of ENS_DEAD and ENS_PREFIX. */ + int flags; /* ORed combo of ENS_DEAD and + * TCL_ENSEMBLE_PREFIX. */ /* OBJECT FIELDS FOR ENSEMBLE CONFIGURATION */ Tcl_Obj *subcommandDict; /* Dictionary providing mapping from * subcommands to their implementing command @@ -130,37 +128,35 @@ * exports. */ Tcl_Obj *subcmdList; /* List of commands that this ensemble * actually provides, and whose implementation * will be built using the subcommandDict (if * present and defined) and by simple mapping - * to the namespace otherwise. If NULL, + * to the namespace otherwise. If NULL, * indicates that we are using the (dynamic) * list of currently exported commands. */ Tcl_Obj *unknownHandler; /* Script prefix used to handle the case when * no match is found (according to the rule - * defined by flag bit ENS_PREFIX) or NULL to - * use the default error-generating behaviour. - * The script execution gets all the arguments - * to the ensemble command (including objv[0]) - * and will have the results passed directly - * back to the caller (including the error - * code) unless the code is TCL_CONTINUE in - * which case the subcommand will be reparsed - * by the ensemble core, presumably because - * the ensemble itself has been updated. */ + * defined by flag bit TCL_ENSEMBLE_PREFIX) or + * NULL to use the default error-generating + * behaviour. The script execution gets all + * the arguments to the ensemble command + * (including objv[0]) and will have the + * results passed directly back to the caller + * (including the error code) unless the code + * is TCL_CONTINUE in which case the + * subcommand will be reparsed by the ensemble + * core, presumably because the ensemble + * itself has been updated. */ } EnsembleConfig; #define ENS_DEAD 0x1 /* Flag value to say that the ensemble is dead * and on its way out. */ -#define ENS_PREFIX 0x2 /* Flag value to say whether to allow - * unambiguous prefixes of commands or to - * require exact matches for command names. */ /* - * The data cached in a subcommand's Tcl_Obj rep. This structure is - * not shared between Tcl_Objs referring to the same subcommand, even - * where one is a duplicate of another. + * The data cached in a subcommand's Tcl_Obj rep. This structure is not shared + * between Tcl_Objs referring to the same subcommand, even where one is a + * duplicate of another. */ typedef struct EnsembleCmdRep { Namespace *nsPtr; /* The namespace backing the ensemble which * this is a subcommand of. */ @@ -175,111 +171,90 @@ * command that implements this ensemble * subcommand. */ } EnsembleCmdRep; /* - * Declarations for procedures local to this file: - */ - -static void DeleteImportedCmd _ANSI_ARGS_((ClientData clientData)); -static void DupNsNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, - Tcl_Obj *copyPtr)); -static char * ErrorCodeRead _ANSI_ARGS_(( ClientData clientData, - Tcl_Interp *interp, CONST char *name1, - CONST char *name2, int flags)); -static char * ErrorInfoRead _ANSI_ARGS_(( ClientData clientData, - Tcl_Interp *interp, CONST char *name1, - CONST char *name2, int flags)); -static char * EstablishErrorCodeTraces _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp, - CONST char *name1, CONST char *name2, int flags)); -static char * EstablishErrorInfoTraces _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp, - CONST char *name1, CONST char *name2, int flags)); -static void FreeNsNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); -static int GetNamespaceFromObj _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_Obj *objPtr, - Tcl_Namespace **nsPtrPtr)); -static int InvokeImportedCmd _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceChildrenCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceCodeCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceCurrentCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceDeleteCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceEnsembleCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceEvalCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceExistsCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceExportCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceForgetCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static void NamespaceFree _ANSI_ARGS_((Namespace *nsPtr)); -static int NamespaceImportCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceInscopeCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceOriginCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceParentCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceQualifiersCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceTailCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int NamespaceWhichCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int SetNsNameFromAny _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_Obj *objPtr)); -static void UpdateStringOfNsName _ANSI_ARGS_((Tcl_Obj *objPtr)); -static EnsembleConfig * FindEnsemble _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *cmdNameObj, int flags)); -static int NsEnsembleImplementationCmd _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static void BuildEnsembleConfig _ANSI_ARGS_(( - EnsembleConfig *ensemblePtr)); -static int NsEnsembleStringOrder _ANSI_ARGS_((CONST VOID *strPtr1, - CONST VOID *strPtr2)); -static void DeleteEnsembleConfig _ANSI_ARGS_(( - ClientData clientData)); -static void MakeCachedEnsembleCommand _ANSI_ARGS_(( - Tcl_Obj *objPtr, EnsembleConfig *ensemblePtr, - CONST char *subcmdName, Tcl_Obj *prefixObjPtr)); -static void FreeEnsembleCmdRep _ANSI_ARGS_((Tcl_Obj *objPtr)); -static void DupEnsembleCmdRep _ANSI_ARGS_((Tcl_Obj *objPtr, - Tcl_Obj *copyPtr)); -static void StringOfEnsembleCmdRep _ANSI_ARGS_((Tcl_Obj *objPtr)); - -/* - * This structure defines a Tcl object type that contains a - * namespace reference. It is used in commands that take the - * name of a namespace as an argument. The namespace reference - * is resolved, and the result in cached in the object. + * Declarations for functions local to this file: + */ + +static void DeleteImportedCmd(ClientData clientData); +static int DoImport(Tcl_Interp *interp, + Namespace *nsPtr, Tcl_HashEntry *hPtr, + CONST char *cmdName, CONST char *pattern, + Namespace *importNsPtr, int allowOverwrite); +static void DupNsNameInternalRep(Tcl_Obj *objPtr,Tcl_Obj *copyPtr); +static char * ErrorCodeRead(ClientData clientData,Tcl_Interp *interp, + CONST char *name1, CONST char *name2, int flags); +static char * ErrorInfoRead(ClientData clientData,Tcl_Interp *interp, + CONST char *name1, CONST char *name2, int flags); +static char * EstablishErrorCodeTraces(ClientData clientData, + Tcl_Interp *interp, CONST char *name1, + CONST char *name2, int flags); +static char * EstablishErrorInfoTraces(ClientData clientData, + Tcl_Interp *interp, CONST char *name1, + CONST char *name2, int flags); +static void FreeNsNameInternalRep(Tcl_Obj *objPtr); +static int InvokeImportedCmd(ClientData clientData, + Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]); +static int NamespaceChildrenCmd(ClientData dummy, + Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]); +static int NamespaceCodeCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int NamespaceCurrentCmd(ClientData dummy, + Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]); +static int NamespaceDeleteCmd(ClientData dummy,Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int NamespaceEnsembleCmd(ClientData dummy, + Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]); +static int NamespaceEvalCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int NamespaceExistsCmd(ClientData dummy,Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int NamespaceExportCmd(ClientData dummy,Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int NamespaceForgetCmd(ClientData dummy,Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static void NamespaceFree(Namespace *nsPtr); +static int NamespaceImportCmd(ClientData dummy,Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int NamespaceInscopeCmd(ClientData dummy, + Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]); +static int NamespaceOriginCmd(ClientData dummy,Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int NamespaceParentCmd(ClientData dummy,Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int NamespacePathCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int NamespaceQualifiersCmd(ClientData dummy, + Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]); +static int NamespaceTailCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int NamespaceWhichCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int SetNsNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +static void UpdateStringOfNsName(Tcl_Obj *objPtr); +static int NsEnsembleImplementationCmd(ClientData clientData, + Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]); +static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr); +static int NsEnsembleStringOrder(CONST VOID *strPtr1, + CONST VOID *strPtr2); +static void DeleteEnsembleConfig(ClientData clientData); +static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr, + EnsembleConfig *ensemblePtr, + CONST char *subcmdName, Tcl_Obj *prefixObjPtr); +static void FreeEnsembleCmdRep(Tcl_Obj *objPtr); +static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); +static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr); +static void UnlinkNsPath(Namespace *nsPtr); +static void SetNsPath(Namespace *nsPtr, int pathLength, + Tcl_Namespace *pathAry[]); + +/* + * This structure defines a Tcl object type that contains a namespace + * reference. It is used in commands that take the name of a namespace as an + * argument. The namespace reference is resolved, and the result in cached in + * the object. */ Tcl_ObjType tclNsNameType = { "nsName", /* the type's name */ FreeNsNameInternalRep, /* freeIntRepProc */ @@ -287,17 +262,17 @@ UpdateStringOfNsName, /* updateStringProc */ SetNsNameFromAny /* setFromAnyProc */ }; /* - * This structure defines a Tcl object type that contains a reference - * to an ensemble subcommand (e.g. the "length" in [string length ab]) - * It is used to cache the mapping between the subcommand itself and - * the real command that implements it. + * This structure defines a Tcl object type that contains a reference to an + * ensemble subcommand (e.g. the "length" in [string length ab]) It is used to + * cache the mapping between the subcommand itself and the real command that + * implements it. */ -Tcl_ObjType tclEnsembleCmdType = { +static Tcl_ObjType ensembleCmdType = { "ensembleCommand", /* the type's name */ FreeEnsembleCmdRep, /* freeIntRepProc */ DupEnsembleCmdRep, /* dupIntRepProc */ StringOfEnsembleCmdRep, /* updateStringProc */ NULL /* setFromAnyProc */ @@ -306,12 +281,12 @@ /* *---------------------------------------------------------------------- * * TclInitNamespaceSubsystem -- * - * This procedure is called to initialize all the structures that - * are used by namespaces on a per-process basis. + * This function is called to initialize all the structures that are used + * by namespaces on a per-process basis. * * Results: * None. * * Side effects: @@ -344,12 +319,12 @@ *---------------------------------------------------------------------- */ Tcl_Namespace * Tcl_GetCurrentNamespace(interp) - register Tcl_Interp *interp; /* Interpreter whose current namespace is - * being queried. */ + register Tcl_Interp *interp;/* Interpreter whose current namespace is + * being queried. */ { register Interp *iPtr = (Interp *) interp; register Namespace *nsPtr; if (iPtr->varFramePtr != NULL) { @@ -376,12 +351,12 @@ *---------------------------------------------------------------------- */ Tcl_Namespace * Tcl_GetGlobalNamespace(interp) - register Tcl_Interp *interp; /* Interpreter whose global namespace - * should be returned. */ + register Tcl_Interp *interp;/* Interpreter whose global namespace should + * be returned. */ { register Interp *iPtr = (Interp *) interp; return (Tcl_Namespace *) iPtr->globalNsPtr; } @@ -389,13 +364,13 @@ /* *---------------------------------------------------------------------- * * Tcl_PushCallFrame -- * - * Pushes a new call frame onto the interpreter's Tcl call stack. - * Called when executing a Tcl procedure or a "namespace eval" or - * "namespace inscope" command. + * Pushes a new call frame onto the interpreter's Tcl call stack. Called + * when executing a Tcl procedure or a "namespace eval" or "namespace + * inscope" command. * * Results: * Returns TCL_OK if successful, or TCL_ERROR (along with an error * message in the interpreter's result object) if something goes wrong. * @@ -405,35 +380,33 @@ *---------------------------------------------------------------------- */ int Tcl_PushCallFrame(interp, callFramePtr, namespacePtr, isProcCallFrame) - Tcl_Interp *interp; /* Interpreter in which the new call frame - * is to be pushed. */ - Tcl_CallFrame *callFramePtr; /* Points to a call frame structure to - * push. Storage for this has already been - * allocated by the caller; typically this - * is the address of a CallFrame structure - * allocated on the caller's C stack. The - * call frame will be initialized by this - * procedure. The caller can pop the frame - * later with Tcl_PopCallFrame, and it is - * responsible for freeing the frame's - * storage. */ - Tcl_Namespace *namespacePtr; /* Points to the namespace in which the - * frame will execute. If NULL, the - * interpreter's current namespace will - * be used. */ - int isProcCallFrame; /* If nonzero, the frame represents a - * called Tcl procedure and may have local - * vars. Vars will ordinarily be looked up - * in the frame. If new variables are - * created, they will be created in the - * frame. If 0, the frame is for a - * "namespace eval" or "namespace inscope" - * command and var references are treated - * as references to namespace variables. */ + Tcl_Interp *interp; /* Interpreter in which the new call frame is + * to be pushed. */ + Tcl_CallFrame *callFramePtr;/* Points to a call frame structure to push. + * Storage for this has already been allocated + * by the caller; typically this is the + * address of a CallFrame structure allocated + * on the caller's C stack. The call frame + * will be initialized by this function. The + * caller can pop the frame later with + * Tcl_PopCallFrame, and it is responsible for + * freeing the frame's storage. */ + Tcl_Namespace *namespacePtr;/* Points to the namespace in which the frame + * will execute. If NULL, the interpreter's + * current namespace will be used. */ + int isProcCallFrame; /* If nonzero, the frame represents a called + * Tcl procedure and may have local vars. Vars + * will ordinarily be looked up in the frame. + * If new variables are created, they will be + * created in the frame. If 0, the frame is + * for a "namespace eval" or "namespace + * inscope" command and var references are + * treated as references to namespace + * variables. */ { Interp *iPtr = (Interp *) interp; register CallFrame *framePtr = (CallFrame *) callFramePtr; register Namespace *nsPtr; @@ -457,18 +430,18 @@ if (iPtr->varFramePtr != NULL) { framePtr->level = (iPtr->varFramePtr->level + 1); } else { framePtr->level = 1; } - framePtr->procPtr = NULL; /* no called procedure */ - framePtr->varTablePtr = NULL; /* and no local variables */ + framePtr->procPtr = NULL; /* no called procedure */ + framePtr->varTablePtr = NULL; /* and no local variables */ framePtr->numCompiledLocals = 0; framePtr->compiledLocals = NULL; /* - * Push the new call frame onto the interpreter's stack of procedure - * call frames making it the current frame. + * Push the new call frame onto the interpreter's stack of procedure call + * frames making it the current frame. */ iPtr->framePtr = framePtr; iPtr->varFramePtr = framePtr; return TCL_OK; @@ -485,13 +458,12 @@ * Results: * None. * * Side effects: * Modifies the call stack of the interpreter. Resets various fields of - * the popped call frame. If a namespace has been deleted and - * has no more activations on the call stack, the namespace is - * destroyed. + * the popped call frame. If a namespace has been deleted and has no more + * activations on the call stack, the namespace is destroyed. * *---------------------------------------------------------------------- */ void @@ -501,14 +473,13 @@ register Interp *iPtr = (Interp *) interp; register CallFrame *framePtr = iPtr->framePtr; Namespace *nsPtr; /* - * It's important to remove the call frame from the interpreter's stack - * of call frames before deleting local variables, so that traces - * invoked by the variable deletion don't see the partially-deleted - * frame. + * It's important to remove the call frame from the interpreter's stack of + * call frames before deleting local variables, so that traces invoked by + * the variable deletion don't see the partially-deleted frame. */ iPtr->framePtr = framePtr->callerPtr; iPtr->varFramePtr = framePtr->callerVarPtr; @@ -520,22 +491,73 @@ if (framePtr->numCompiledLocals > 0) { TclDeleteCompiledLocalVars(iPtr, framePtr); } /* - * Decrement the namespace's count of active call frames. If the - * namespace is "dying" and there are no more active call frames, - * call Tcl_DeleteNamespace to destroy it. + * Decrement the namespace's count of active call frames. If the namespace + * is "dying" and there are no more active call frames, call + * Tcl_DeleteNamespace to destroy it. */ nsPtr = framePtr->nsPtr; nsPtr->activationCount--; if ((nsPtr->flags & NS_DYING) && (nsPtr->activationCount == 0)) { Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr); } framePtr->nsPtr = NULL; } + +/* + *---------------------------------------------------------------------- + * + * TclPushStackFrame -- + * + * Allocates a new call frame in the interpreter's execution stack, then + * pushes it onto the interpreter's Tcl call stack. Called when executing + * a Tcl procedure or a "namespace eval" or "namespace inscope" command. + * + * Results: + * Returns TCL_OK if successful, or TCL_ERROR (along with an error + * message in the interpreter's result object) if something goes wrong. + * + * Side effects: + * Modifies the interpreter's Tcl call stack. + * + *---------------------------------------------------------------------- + */ + +int +TclPushStackFrame(interp, framePtrPtr, namespacePtr, isProcCallFrame) + Tcl_Interp *interp; /* Interpreter in which the new call frame is + * to be pushed. */ + Tcl_CallFrame **framePtrPtr;/* Place to store a pointer to the stack + * allocated call frame.*/ + Tcl_Namespace *namespacePtr;/* Points to the namespace in which the frame + * will execute. If NULL, the interpreter's + * current namespace will be used. */ + int isProcCallFrame; /* If nonzero, the frame represents a called + * Tcl procedure and may have local vars. Vars + * will ordinarily be looked up in the frame. + * If new variables are created, they will be + * created in the frame. If 0, the frame is + * for a "namespace eval" or "namespace + * inscope" command and var references are + * treated as references to namespace + * variables. */ +{ + *framePtrPtr = (Tcl_CallFrame *) TclStackAlloc(interp, sizeof(CallFrame)); + return Tcl_PushCallFrame(interp, *framePtrPtr, namespacePtr, + isProcCallFrame); +} + +void +TclPopStackFrame(interp) + Tcl_Interp* interp; /* Interpreter with call frame to pop. */ +{ + Tcl_PopCallFrame(interp); + TclStackFree(interp); +} /* *---------------------------------------------------------------------- * * EstablishErrorCodeTraces -- @@ -570,12 +592,12 @@ /* *---------------------------------------------------------------------- * * ErrorCodeRead -- * - * Called when the ::errorCode variable is read. Copies the - * current value of the interp's errorCode field into ::errorCode. + * Called when the ::errorCode variable is read. Copies the current value + * of the interp's errorCode field into ::errorCode. * * Results: * None. * * Side effects: @@ -592,13 +614,15 @@ CONST char *name2; int flags; { Interp *iPtr = (Interp *)interp; - if (flags & TCL_INTERP_DESTROYED) return NULL; - if (iPtr->errorCode == NULL) return NULL; - Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL, iPtr->errorCode, TCL_GLOBAL_ONLY); + if (flags & TCL_INTERP_DESTROYED || iPtr->errorCode == NULL) { + return NULL; + } + Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL, iPtr->errorCode, + TCL_GLOBAL_ONLY); return NULL; } /* *---------------------------------------------------------------------- @@ -635,12 +659,12 @@ /* *---------------------------------------------------------------------- * * ErrorInfoRead -- * - * Called when the ::errorInfo variable is read. Copies the - * current value of the interp's errorInfo field into ::errorInfo. + * Called when the ::errorInfo variable is read. Copies the current value + * of the interp's errorInfo field into ::errorInfo. * * Results: * None. * * Side effects: @@ -657,53 +681,52 @@ CONST char *name2; int flags; { Interp *iPtr = (Interp *)interp; - if (flags & TCL_INTERP_DESTROYED) return NULL; - if (iPtr->errorInfo == NULL) return NULL; - Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo, TCL_GLOBAL_ONLY); + if (flags & TCL_INTERP_DESTROYED || iPtr->errorInfo == NULL) { + return NULL; + } + Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo, + TCL_GLOBAL_ONLY); return NULL; } /* *---------------------------------------------------------------------- * * Tcl_CreateNamespace -- * - * Creates a new namespace with the given name. If there is no - * active namespace (i.e., the interpreter is being initialized), - * the global :: namespace is created and returned. + * Creates a new namespace with the given name. If there is no active + * namespace (i.e., the interpreter is being initialized), the global :: + * namespace is created and returned. * * Results: - * Returns a pointer to the new namespace if successful. If the - * namespace already exists or if another error occurs, this routine - * returns NULL, along with an error message in the interpreter's - * result object. + * Returns a pointer to the new namespace if successful. If the namespace + * already exists or if another error occurs, this routine returns NULL, + * along with an error message in the interpreter's result object. * * Side effects: - * If the name contains "::" qualifiers and a parent namespace does - * not already exist, it is automatically created. + * If the name contains "::" qualifiers and a parent namespace does not + * already exist, it is automatically created. * *---------------------------------------------------------------------- */ Tcl_Namespace * Tcl_CreateNamespace(interp, name, clientData, deleteProc) - Tcl_Interp *interp; /* Interpreter in which a new namespace - * is being created. Also used for - * error reporting. */ - CONST char *name; /* Name for the new namespace. May be a - * qualified name with names of ancestor - * namespaces separated by "::"s. */ - ClientData clientData; /* One-word value to store with - * namespace. */ + Tcl_Interp *interp; /* Interpreter in which a new namespace is + * being created. Also used for error + * reporting. */ + CONST char *name; /* Name for the new namespace. May be a + * qualified name with names of ancestor + * namespaces separated by "::"s. */ + ClientData clientData; /* One-word value to store with namespace. */ Tcl_NamespaceDeleteProc *deleteProc; - /* Procedure called to delete client - * data when the namespace is deleted. - * NULL if no procedure should be - * called. */ + /* Function called to delete client data when + * the namespace is deleted. NULL if no + * function should be called. */ { Interp *iPtr = (Interp *) interp; register Namespace *nsPtr, *ancestorPtr; Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr; Namespace *globalNsPtr = iPtr->globalNsPtr; @@ -712,18 +735,17 @@ Tcl_DString buffer1, buffer2; int newEntry; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* - * If there is no active namespace, the interpreter is being - * initialized. + * If there is no active namespace, the interpreter is being initialized. */ if ((globalNsPtr == NULL) && (iPtr->varFramePtr == NULL)) { /* - * Treat this namespace as the global namespace, and avoid - * looking for a parent. + * Treat this namespace as the global namespace, and avoid looking for + * a parent. */ parentPtr = NULL; simpleName = ""; } else if (*name == '\0') { @@ -740,34 +762,33 @@ /*flags*/ (TCL_CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG), &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName); /* * If the unqualified name at the end is empty, there were trailing - * "::"s after the namespace's name which we ignore. The new - * namespace was already (recursively) created and is pointed to - * by parentPtr. + * "::"s after the namespace's name which we ignore. The new namespace + * was already (recursively) created and is pointed to by parentPtr. */ if (*simpleName == '\0') { return (Tcl_Namespace *) parentPtr; } /* - * Check for a bad namespace name and make sure that the name - * does not already exist in the parent namespace. + * Check for a bad namespace name and make sure that the name does not + * already exist in the parent namespace. */ if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) { Tcl_AppendResult(interp, "can't create namespace \"", name, - "\": already exists", (char *) NULL); + "\": already exists", (char *) NULL); return NULL; } } /* - * Create the new namespace and root it in its parent. Increment the - * count of namespaces created. + * Create the new namespace and root it in its parent. Increment the count + * of namespaces created. */ nsPtr = (Namespace *) ckalloc(sizeof(Namespace)); nsPtr->name = (char *) ckalloc((unsigned) (strlen(simpleName)+1)); strcpy(nsPtr->name, simpleName); @@ -791,20 +812,24 @@ nsPtr->cmdResProc = NULL; nsPtr->varResProc = NULL; nsPtr->compiledVarResProc = NULL; nsPtr->exportLookupEpoch = 0; nsPtr->ensembles = NULL; + nsPtr->commandPathLength = 0; + nsPtr->commandPathArray = NULL; + nsPtr->commandPathSourceList = NULL; if (parentPtr != NULL) { entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName, &newEntry); Tcl_SetHashValue(entryPtr, (ClientData) nsPtr); } else { - /* - * In the global namespace create traces to maintain the - * ::errorInfo and ::errorCode variables. + /* + * In the global namespace create traces to maintain the ::errorInfo + * and ::errorCode variables. */ + iPtr->globalNsPtr = nsPtr; EstablishErrorInfoTraces(NULL, interp, NULL, NULL, 0); EstablishErrorCodeTraces(NULL, interp, NULL, NULL, 0); } @@ -851,61 +876,61 @@ * * Results: * None. * * Side effects: - * When a namespace is deleted, it is automatically removed as a - * child of its parent namespace. Also, all its commands, variables - * and child namespaces are deleted. + * When a namespace is deleted, it is automatically removed as a child of + * its parent namespace. Also, all its commands, variables and child + * namespaces are deleted. * *---------------------------------------------------------------------- */ void Tcl_DeleteNamespace(namespacePtr) - Tcl_Namespace *namespacePtr; /* Points to the namespace to delete. */ + Tcl_Namespace *namespacePtr; /* Points to the namespace to delete */ { register Namespace *nsPtr = (Namespace *) namespacePtr; Interp *iPtr = (Interp *) nsPtr->interp; Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace((Tcl_Interp *) iPtr); Tcl_HashEntry *entryPtr; /* - * If the namespace has associated ensemble commands, delete them - * first. This leaves the actual contents of the namespace alone - * (unless they are linked ensemble commands, of course.) Note - * that this code is actually reentrant so command delete traces - * won't purturb things badly. + * If the namespace has associated ensemble commands, delete them first. + * This leaves the actual contents of the namespace alone (unless they are + * linked ensemble commands, of course). Note that this code is actually + * reentrant so command delete traces won't purturb things badly. */ while (nsPtr->ensembles != NULL) { - /* - * Splice out and link to indicate that we've already been - * killed. - */ EnsembleConfig *ensemblePtr = (EnsembleConfig *) nsPtr->ensembles; + + /* + * Splice out and link to indicate that we've already been killed. + */ + nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next; ensemblePtr->next = ensemblePtr; Tcl_DeleteCommandFromToken(nsPtr->interp, ensemblePtr->token); } /* * If the namespace is on the call frame stack, it is marked as "dying" - * (NS_DYING is OR'd into its flags): the namespace can't be looked up - * by name but its commands and variables are still usable by those - * active call frames. When all active call frames referring to the - * namespace have been popped from the Tcl stack, Tcl_PopCallFrame will - * call this procedure again to delete everything in the namespace. - * If no nsName objects refer to the namespace (i.e., if its refCount - * is zero), its commands and variables are deleted and the storage for - * its namespace structure is freed. Otherwise, if its refCount is - * nonzero, the namespace's commands and variables are deleted but the - * structure isn't freed. Instead, NS_DEAD is OR'd into the structure's - * flags to allow the namespace resolution code to recognize that the - * namespace is "deleted". The structure's storage is freed by - * FreeNsNameInternalRep when its refCount reaches 0. + * (NS_DYING is OR'd into its flags): the namespace can't be looked up by + * name but its commands and variables are still usable by those active + * call frames. When all active call frames referring to the namespace + * have been popped from the Tcl stack, Tcl_PopCallFrame will call this + * function again to delete everything in the namespace. If no nsName + * objects refer to the namespace (i.e., if its refCount is zero), its + * commands and variables are deleted and the storage for its namespace + * structure is freed. Otherwise, if its refCount is nonzero, the + * namespace's commands and variables are deleted but the structure isn't + * freed. Instead, NS_DEAD is OR'd into the structure's flags to allow the + * namespace resolution code to recognize that the namespace is "deleted". + * The structure's storage is freed by FreeNsNameInternalRep when its + * refCount reaches 0. */ if (nsPtr->activationCount > 0) { nsPtr->flags |= NS_DYING; if (nsPtr->parentPtr != NULL) { @@ -926,13 +951,13 @@ TclTeardownNamespace(nsPtr); if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) { /* * If this is the global namespace, then it may have residual - * "errorInfo" and "errorCode" variables for errors that - * occurred while it was being torn down. Try to clear the - * variable list one last time. + * "errorInfo" and "errorCode" variables for errors that occurred + * while it was being torn down. Try to clear the variable list + * one last time. */ TclDeleteVars((Interp *) nsPtr->interp, &nsPtr->varTable); Tcl_DeleteHashTable(&nsPtr->childTable); @@ -947,11 +972,14 @@ NamespaceFree(nsPtr); } else { nsPtr->flags |= NS_DEAD; } } else { - /* Restore the ::errorInfo and ::errorCode traces */ + /* + * Restore the ::errorInfo and ::errorCode traces. + */ + EstablishErrorInfoTraces(NULL, nsPtr->interp, NULL, NULL, 0); EstablishErrorCodeTraces(NULL, nsPtr->interp, NULL, NULL, 0); } } } @@ -964,11 +992,11 @@ * Used internally to dismantle and unlink a namespace when it is * deleted. Divorces the namespace from its parent, and deletes all * commands, variables, and child namespaces. * * This is kept separate from Tcl_DeleteNamespace so that the global - * namespace can be handled specially. + * namespace can be handled specially. * * Results: * None. * * Side effects: @@ -989,50 +1017,18 @@ Tcl_Namespace *childNsPtr; Tcl_Command cmd; int i; /* - * Start by destroying the namespace's variable table, - * since variables might trigger traces. - * Variable table should be cleared but not freed! + * Start by destroying the namespace's variable table, since variables + * might trigger traces. Variable table should be cleared but not freed! * TclDeleteVars frees it, so we reinitialize it afterwards. */ TclDeleteVars(iPtr, &nsPtr->varTable); Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS); - /* - * Remove the namespace from its parent's child hashtable. - */ - - if (nsPtr->parentPtr != NULL) { - entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable, - nsPtr->name); - if (entryPtr != NULL) { - Tcl_DeleteHashEntry(entryPtr); - } - } - nsPtr->parentPtr = NULL; - - /* - * Delete all the child namespaces. - * - * BE CAREFUL: When each child is deleted, it will divorce - * itself from its parent. You can't traverse a hash table - * properly if its elements are being deleted. We use only - * the Tcl_FirstHashEntry function to be safe. - * - * Don't optimize to Tcl_NextHashEntry() because of traces. - */ - - for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); - entryPtr != NULL; - entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) { - childNsPtr = (Tcl_Namespace *) Tcl_GetHashValue(entryPtr); - Tcl_DeleteNamespace(childNsPtr); - } - /* * Delete all commands in this namespace. Be careful when traversing the * hash table: when each command is deleted, it removes itself from the * command table. * @@ -1045,10 +1041,57 @@ cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmd); } Tcl_DeleteHashTable(&nsPtr->cmdTable); Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); + + /* + * Remove the namespace from its parent's child hashtable. + */ + + if (nsPtr->parentPtr != NULL) { + entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable, + nsPtr->name); + if (entryPtr != NULL) { + Tcl_DeleteHashEntry(entryPtr); + } + } + nsPtr->parentPtr = NULL; + + /* + * Delete the namespace path if one is installed. + */ + + if (nsPtr->commandPathLength != 0) { + UnlinkNsPath(nsPtr); + nsPtr->commandPathLength = 0; + } + if (nsPtr->commandPathSourceList != NULL) { + NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList; + do { + nsPathPtr->nsPtr = NULL; + nsPathPtr = nsPathPtr->nextPtr; + } while (nsPathPtr != NULL); + } + + /* + * Delete all the child namespaces. + * + * BE CAREFUL: When each child is deleted, it will divorce itself from its + * parent. You can't traverse a hash table properly if its elements are + * being deleted. We use only the Tcl_FirstHashEntry function to be + * safe. + * + * Don't optimize to Tcl_NextHashEntry() because of traces. + */ + + for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); + entryPtr != NULL; + entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) { + childNsPtr = (Tcl_Namespace *) Tcl_GetHashValue(entryPtr); + Tcl_DeleteNamespace(childNsPtr); + } /* * Free the namespace's export pattern array. */ @@ -1071,13 +1114,13 @@ } nsPtr->deleteProc = NULL; nsPtr->clientData = NULL; /* - * Reset the namespace's id field to ensure that this namespace won't - * be interpreted as valid by, e.g., the cache validation code for - * cached command references in Tcl_GetCommandFromObj. + * Reset the namespace's id field to ensure that this namespace won't be + * interpreted as valid by, e.g., the cache validation code for cached + * command references in Tcl_GetCommandFromObj. */ nsPtr->nsId = 0; } @@ -1084,13 +1127,12 @@ /* *---------------------------------------------------------------------- * * NamespaceFree -- * - * Called after a namespace has been deleted, when its - * reference count reaches 0. Frees the data structure - * representing the namespace. + * Called after a namespace has been deleted, when its reference count + * reaches 0. Frees the data structure representing the namespace. * * Results: * None. * * Side effects: @@ -1119,14 +1161,14 @@ *---------------------------------------------------------------------- * * Tcl_Export -- * * Makes all the commands matching a pattern available to later be - * imported from the namespace specified by namespacePtr (or the - * current namespace if namespacePtr is NULL). The specified pattern is - * appended onto the namespace's export pattern list, which is - * optionally cleared beforehand. + * imported from the namespace specified by namespacePtr (or the current + * namespace if namespacePtr is NULL). The specified pattern is appended + * onto the namespace's export pattern list, which is optionally cleared + * beforehand. * * Results: * Returns TCL_OK if successful, or TCL_ERROR (along with an error * message in the interpreter's result) if something goes wrong. * @@ -1137,23 +1179,22 @@ *---------------------------------------------------------------------- */ int Tcl_Export(interp, namespacePtr, pattern, resetListFirst) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Namespace *namespacePtr; /* Points to the namespace from which - * commands are to be exported. NULL for - * the current namespace. */ - CONST char *pattern; /* String pattern indicating which commands - * to export. This pattern may not include - * any namespace qualifiers; only commands - * in the specified namespace may be - * exported. */ - int resetListFirst; /* If nonzero, resets the namespace's - * export list before appending. */ -{ -#define INIT_EXPORT_PATTERNS 5 + Tcl_Interp *interp; /* Current interpreter. */ + Tcl_Namespace *namespacePtr;/* Points to the namespace from which commands + * are to be exported. NULL for the current + * namespace. */ + CONST char *pattern; /* String pattern indicating which commands to + * export. This pattern may not include any + * namespace qualifiers; only commands in the + * specified namespace may be exported. */ + int resetListFirst; /* If nonzero, resets the namespace's export + * list before appending. */ +{ +#define INIT_EXPORT_PATTERNS 5 Namespace *nsPtr, *exportNsPtr, *dummyPtr; Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); CONST char *simplePattern; char *patternCpy; int neededElems, len, i; @@ -1201,10 +1242,11 @@ } /* * Make sure that we don't already have the pattern in the array */ + if (nsPtr->exportArrayPtr != NULL) { for (i = 0; i < nsPtr->numExportPatterns; i++) { if (strcmp(pattern, nsPtr->exportArrayPtr[i]) == 0) { /* * The pattern already exists in the list @@ -1213,12 +1255,12 @@ } } } /* - * Make sure there is room in the namespace's pattern array for the - * new pattern. + * Make sure there is room in the namespace's pattern array for the new + * pattern. */ neededElems = nsPtr->numExportPatterns + 1; if (nsPtr->exportArrayPtr == NULL) { nsPtr->exportArrayPtr = (char **) @@ -1226,11 +1268,11 @@ nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = INIT_EXPORT_PATTERNS; } else if (neededElems > nsPtr->maxExportPatterns) { int numNewElems = 2 * nsPtr->maxExportPatterns; size_t currBytes = nsPtr->numExportPatterns * sizeof(char *); - size_t newBytes = numNewElems * sizeof(char *); + size_t newBytes = numNewElems * sizeof(char *); char **newPtr = (char **) ckalloc((unsigned) newBytes); memcpy((VOID *) newPtr, (VOID *) nsPtr->exportArrayPtr, currBytes); ckfree((char *) nsPtr->exportArrayPtr); nsPtr->exportArrayPtr = (char **) newPtr; @@ -1247,14 +1289,13 @@ nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy; nsPtr->numExportPatterns++; /* - * The list of commands actually exported from the namespace might - * have changed (probably will have!) However, we do not need to - * recompute this just yet; next time we need the info will be - * soon enough. + * The list of commands actually exported from the namespace might have + * changed (probably will have!) However, we do not need to recompute this + * just yet; next time we need the info will be soon enough. */ TclInvalidateNsCmdLookup(nsPtr); return TCL_OK; @@ -1270,28 +1311,28 @@ * specified namespace. * * Results: * The return value is normally TCL_OK; in this case the object * referenced by objPtr has each export pattern appended to it. If an - * error occurs, TCL_ERROR is returned and the interpreter's result - * holds an error message. + * error occurs, TCL_ERROR is returned and the interpreter's result holds + * an error message. * * Side effects: - * If necessary, the object referenced by objPtr is converted into - * a list object. + * If necessary, the object referenced by objPtr is converted into a list + * object. * *---------------------------------------------------------------------- */ int Tcl_AppendExportList(interp, namespacePtr, objPtr) - Tcl_Interp *interp; /* Interpreter used for error reporting. */ - Tcl_Namespace *namespacePtr; /* Points to the namespace whose export - * pattern list is appended onto objPtr. - * NULL for the current namespace. */ - Tcl_Obj *objPtr; /* Points to the Tcl object onto which the - * export pattern list is appended. */ + Tcl_Interp *interp; /* Interpreter used for error reporting. */ + Tcl_Namespace *namespacePtr;/* Points to the namespace whose export + * pattern list is appended onto objPtr. NULL + * for the current namespace. */ + Tcl_Obj *objPtr; /* Points to the Tcl object onto which the + * export pattern list is appended. */ { Namespace *nsPtr; int i, result; /* @@ -1322,44 +1363,44 @@ *---------------------------------------------------------------------- * * Tcl_Import -- * * Imports all of the commands matching a pattern into the namespace - * specified by namespacePtr (or the current namespace if contextNsPtr - * is NULL). This is done by creating a new command (the "imported - * command") that points to the real command in its original namespace. + * specified by namespacePtr (or the current namespace if contextNsPtr is + * NULL). This is done by creating a new command (the "imported command") + * that points to the real command in its original namespace. * - * If matching commands are on the autoload path but haven't been - * loaded yet, this command forces them to be loaded, then creates - * the links to them. + * If matching commands are on the autoload path but haven't been loaded + * yet, this command forces them to be loaded, then creates the links to + * them. * * Results: * Returns TCL_OK if successful, or TCL_ERROR (along with an error * message in the interpreter's result) if something goes wrong. * * Side effects: - * Creates new commands in the importing namespace. These indirect - * calls back to the real command and are deleted if the real commands - * are deleted. + * Creates new commands in the importing namespace. These indirect calls + * back to the real command and are deleted if the real commands are + * deleted. * *---------------------------------------------------------------------- */ int Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Namespace *namespacePtr; /* Points to the namespace into which the - * commands are to be imported. NULL for - * the current namespace. */ - CONST char *pattern; /* String pattern indicating which commands - * to import. This pattern should be - * qualified by the name of the namespace - * from which to import the command(s). */ - int allowOverwrite; /* If nonzero, allow existing commands to - * be overwritten by imported commands. - * If 0, return an error if an imported - * cmd conflicts with an existing one. */ + Tcl_Interp *interp; /* Current interpreter. */ + Tcl_Namespace *namespacePtr;/* Points to the namespace into which the + * commands are to be imported. NULL for the + * current namespace. */ + CONST char *pattern; /* String pattern indicating which commands to + * import. This pattern should be qualified by + * the name of the namespace from which to + * import the command(s). */ + int allowOverwrite; /* If nonzero, allow existing commands to be + * overwritten by imported commands. If 0, + * return an error if an imported cmd + * conflicts with an existing one. */ { Namespace *nsPtr, *importNsPtr, *dummyPtr; CONST char *simplePattern; register Tcl_HashEntry *hPtr; Tcl_HashSearch search; @@ -1373,18 +1414,17 @@ } else { nsPtr = (Namespace *) namespacePtr; } /* - * First, invoke the "auto_import" command with the pattern - * being imported. This command is part of the Tcl library. - * It looks for imported commands in autoloaded libraries and - * loads them in. That way, they will be found when we try - * to create links below. - * - * Note that we don't just call Tcl_EvalObjv() directly because we - * do not want absence of the command to be a failure case. + * First, invoke the "auto_import" command with the pattern being + * imported. This command is part of the Tcl library. It looks for + * imported commands in autoloaded libraries and loads them in. That way, + * they will be found when we try to create links below. + * + * Note that we don't just call Tcl_EvalObjv() directly because we do not + * want absence of the command to be a failure case. */ if (Tcl_FindCommand(interp,"auto_import",NULL,TCL_GLOBAL_ONLY) != NULL) { Tcl_Obj *objv[2]; int result; @@ -1403,13 +1443,12 @@ } Tcl_ResetResult(interp); } /* - * From the pattern, find the namespace from which we are importing - * and get the simple pattern (no namespace qualifiers or ::'s) at - * the end. + * From the pattern, find the namespace from which we are importing and + * get the simple pattern (no namespace qualifiers or ::'s) at the end. */ if (strlen(pattern) == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern", -1)); return TCL_ERROR; @@ -1441,151 +1480,195 @@ * exported commands that match the string pattern. Create an "imported * command" in the current namespace for each imported command; these * commands redirect their invocations to the "real" command. */ + if ((simplePattern != NULL) && TclMatchIsTrivial(simplePattern)) { + hPtr = Tcl_FindHashEntry(&importNsPtr->cmdTable, simplePattern); + if (hPtr == NULL) { + return TCL_OK; + } + return DoImport(interp, nsPtr, hPtr, simplePattern, pattern, + importNsPtr, allowOverwrite); + } for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search); (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) { char *cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr); - if (Tcl_StringMatch(cmdName, simplePattern)) { - /* - * The command cmdName in the source namespace matches the - * pattern. Check whether it was exported. If it wasn't, - * we ignore it. - */ - Tcl_HashEntry *found; - int wasExported = 0, i; - - for (i = 0; i < importNsPtr->numExportPatterns; i++) { - if (Tcl_StringMatch(cmdName, importNsPtr->exportArrayPtr[i])) { - wasExported = 1; - break; - } - } - if (!wasExported) { - continue; - } - - /* - * Unless there is a name clash, create an imported command - * in the current namespace that refers to cmdPtr. - */ - - found = Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName); - if ((found == NULL) || allowOverwrite) { - /* - * Create the imported command and its client data. - * To create the new command in the current namespace, - * generate a fully qualified name for it. - */ - - Tcl_DString ds; - Tcl_Command importedCmd; - ImportedCmdData *dataPtr; - Command *cmdPtr; - ImportRef *refPtr; - - Tcl_DStringInit(&ds); - Tcl_DStringAppend(&ds, nsPtr->fullName, -1); - if (nsPtr != ((Interp *) interp)->globalNsPtr) { - Tcl_DStringAppend(&ds, "::", 2); - } - Tcl_DStringAppend(&ds, cmdName, -1); - - /* - * Check whether creating the new imported command in the - * current namespace would create a cycle of imported - * command references. - */ - - cmdPtr = (Command *) Tcl_GetHashValue(hPtr); - if (found != NULL && cmdPtr->deleteProc == DeleteImportedCmd) { - Command *overwrite = (Command *) Tcl_GetHashValue(found); - Command *link = cmdPtr; - - while (link->deleteProc == DeleteImportedCmd) { - ImportedCmdData *dataPtr; - - dataPtr = (ImportedCmdData *) link->objClientData; - link = dataPtr->realCmdPtr; - if (overwrite == link) { - Tcl_AppendResult(interp, "import pattern \"", - pattern, - "\" would create a loop containing ", - "command \"", Tcl_DStringValue(&ds), - "\"", (char *) NULL); - Tcl_DStringFree(&ds); - return TCL_ERROR; - } - } - } - - dataPtr = (ImportedCmdData *) ckalloc(sizeof(ImportedCmdData)); - importedCmd = Tcl_CreateObjCommand(interp, - Tcl_DStringValue(&ds), InvokeImportedCmd, - (ClientData) dataPtr, DeleteImportedCmd); - dataPtr->realCmdPtr = cmdPtr; - dataPtr->selfPtr = (Command *) importedCmd; - dataPtr->selfPtr->compileProc = cmdPtr->compileProc; - Tcl_DStringFree(&ds); - - /* - * Create an ImportRef structure describing this new import - * command and add it to the import ref list in the "real" - * command. - */ - - refPtr = (ImportRef *) ckalloc(sizeof(ImportRef)); - refPtr->importedCmdPtr = (Command *) importedCmd; - refPtr->nextPtr = cmdPtr->importRefPtr; - cmdPtr->importRefPtr = refPtr; - } else { - Tcl_AppendResult(interp, "can't import command \"", cmdName, - "\": already exists", (char *) NULL); - return TCL_ERROR; - } - } + if (Tcl_StringMatch(cmdName, simplePattern) && + DoImport(interp, nsPtr, hPtr, cmdName, pattern, importNsPtr, + allowOverwrite) == TCL_ERROR) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DoImport -- + * + * Import a particular command from one namespace into another. Helper + * for Tcl_Import(). + * + * Results: + * Standard Tcl result code. If TCL_ERROR, appends an error message to + * the interpreter result. + * + * Side effects: + * A new command is created in the target namespace unless this is a + * reimport of exactly the same command as before. + * + *---------------------------------------------------------------------- + */ + +static int +DoImport(interp, nsPtr, hPtr, cmdName, pattern, importNsPtr, allowOverwrite) + Tcl_Interp *interp; + Namespace *nsPtr; + Tcl_HashEntry *hPtr; + CONST char *cmdName; + CONST char *pattern; + Namespace *importNsPtr; + int allowOverwrite; +{ + int i = 0, exported = 0; + Tcl_HashEntry *found; + + /* + * The command cmdName in the source namespace matches the pattern. Check + * whether it was exported. If it wasn't, we ignore it. + */ + + while (!exported && (i < importNsPtr->numExportPatterns)) { + exported |= Tcl_StringMatch(cmdName, importNsPtr->exportArrayPtr[i++]); + } + if (!exported) { + return TCL_OK; + } + + /* + * Unless there is a name clash, create an imported command in the current + * namespace that refers to cmdPtr. + */ + + found = Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName); + if ((found == NULL) || allowOverwrite) { + /* + * Create the imported command and its client data. To create the new + * command in the current namespace, generate a fully qualified name + * for it. + */ + + Tcl_DString ds; + Tcl_Command importedCmd; + ImportedCmdData *dataPtr; + Command *cmdPtr; + ImportRef *refPtr; + + Tcl_DStringInit(&ds); + Tcl_DStringAppend(&ds, nsPtr->fullName, -1); + if (nsPtr != ((Interp *) interp)->globalNsPtr) { + Tcl_DStringAppend(&ds, "::", 2); + } + Tcl_DStringAppend(&ds, cmdName, -1); + + /* + * Check whether creating the new imported command in the current + * namespace would create a cycle of imported command references. + */ + + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + if (found != NULL && cmdPtr->deleteProc == DeleteImportedCmd) { + Command *overwrite = (Command *) Tcl_GetHashValue(found); + Command *link = cmdPtr; + + while (link->deleteProc == DeleteImportedCmd) { + ImportedCmdData *dataPtr; + + dataPtr = (ImportedCmdData *) link->objClientData; + link = dataPtr->realCmdPtr; + if (overwrite == link) { + Tcl_AppendResult(interp, "import pattern \"", pattern, + "\" would create a loop containing command \"", + Tcl_DStringValue(&ds), "\"", (char *) NULL); + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + } + } + + dataPtr = (ImportedCmdData *) ckalloc(sizeof(ImportedCmdData)); + importedCmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), + InvokeImportedCmd, (ClientData) dataPtr, DeleteImportedCmd); + dataPtr->realCmdPtr = cmdPtr; + dataPtr->selfPtr = (Command *) importedCmd; + dataPtr->selfPtr->compileProc = cmdPtr->compileProc; + Tcl_DStringFree(&ds); + + /* + * Create an ImportRef structure describing this new import command + * and add it to the import ref list in the "real" command. + */ + + refPtr = (ImportRef *) ckalloc(sizeof(ImportRef)); + refPtr->importedCmdPtr = (Command *) importedCmd; + refPtr->nextPtr = cmdPtr->importRefPtr; + cmdPtr->importRefPtr = refPtr; + } else { + Command *overwrite = (Command *) Tcl_GetHashValue(found); + + if (overwrite->deleteProc == DeleteImportedCmd) { + ImportedCmdData *dataPtr = (ImportedCmdData *) + overwrite->objClientData; + if (dataPtr->realCmdPtr == (Command *) Tcl_GetHashValue(hPtr)) { + /* Repeated import of same command -- acceptable */ + return TCL_OK; + } + } + Tcl_AppendResult(interp, "can't import command \"", cmdName, + "\": already exists", (char *) NULL); + return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ForgetImport -- * - * Deletes commands previously imported into the namespace indicated. The - * by namespacePtr, or the current namespace of interp, when - * namespacePtr is NULL. The pattern controls which imported commands - * are deleted. A simple pattern, one without namespace separators, - * matches the current command names of imported commands in the - * namespace. Matching imported commands are deleted. A qualified - * pattern is interpreted as deletion selection on the basis of where - * the command is imported from. The original command and "first link" - * command for each imported command are determined, and they are matched - * against the pattern. A match leads to deletion of the imported - * command. + * Deletes commands previously imported into the namespace indicated. + * The by namespacePtr, or the current namespace of interp, when + * namespacePtr is NULL. The pattern controls which imported commands are + * deleted. A simple pattern, one without namespace separators, matches + * the current command names of imported commands in the namespace. + * Matching imported commands are deleted. A qualified pattern is + * interpreted as deletion selection on the basis of where the command is + * imported from. The original command and "first link" command for each + * imported command are determined, and they are matched against the + * pattern. A match leads to deletion of the imported command. * * Results: - * Returns TCL_ERROR and records an error message in the interp - * result if a namespace qualified pattern refers to a namespace - * that does not exist. Otherwise, returns TCL_OK. + * Returns TCL_ERROR and records an error message in the interp result if + * a namespace qualified pattern refers to a namespace that does not + * exist. Otherwise, returns TCL_OK. * * Side effects: - * May delete commands. + * May delete commands. * *---------------------------------------------------------------------- */ int Tcl_ForgetImport(interp, namespacePtr, pattern) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Namespace *namespacePtr; /* Points to the namespace from which - * previously imported commands should be - * removed. NULL for current namespace. */ - CONST char *pattern; /* String pattern indicating which imported - * commands to remove. */ + Tcl_Interp *interp; /* Current interpreter. */ + Tcl_Namespace *namespacePtr;/* Points to the namespace from which + * previously imported commands should be + * removed. NULL for current namespace. */ + CONST char *pattern; /* String pattern indicating which imported + * commands to remove. */ { Namespace *nsPtr, *sourceNsPtr, *dummyPtr; CONST char *simplePattern; char *cmdName; register Tcl_HashEntry *hPtr; @@ -1600,12 +1683,12 @@ } else { nsPtr = (Namespace *) namespacePtr; } /* - * Parse the pattern into its namespace-qualification (if any) - * and the simple pattern. + * Parse the pattern into its namespace-qualification (if any) and the + * simple pattern. */ TclGetNamespaceForQualName(interp, pattern, nsPtr, /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern); @@ -1617,17 +1700,25 @@ return TCL_ERROR; } if (strcmp(pattern, simplePattern) == 0) { /* - * The pattern is simple. - * Delete any imported commands that match it. + * The pattern is simple. Delete any imported commands that match it. */ + if (TclMatchIsTrivial(simplePattern)) { + Command *cmdPtr; + hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); + if ((hPtr != NULL) + && (cmdPtr = (Command *) Tcl_GetHashValue(hPtr)) + && (cmdPtr->deleteProc == DeleteImportedCmd)) { + Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + } + return TCL_OK; + } for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); - (hPtr != NULL); - hPtr = Tcl_NextHashEntry(&search)) { + (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) { Command *cmdPtr = (Command *) Tcl_GetHashValue(hPtr); if (cmdPtr->deleteProc != DeleteImportedCmd) { continue; } cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr); @@ -1636,26 +1727,29 @@ } } return TCL_OK; } - /* The pattern was namespace-qualified */ + /* + * The pattern was namespace-qualified. + */ for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) { Tcl_CmdInfo info; Tcl_Command token = (Tcl_Command) Tcl_GetHashValue(hPtr); Tcl_Command origin = TclGetOriginalCommand(token); if (Tcl_GetCommandInfoFromToken(origin, &info) == 0) { - continue; /* Not an imported command */ + continue; /* Not an imported command */ } if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) { /* - * Original not in namespace we're matching. - * Check the first link in the import chain. + * Original not in namespace we're matching. Check the first link + * in the import chain. */ + Command *cmdPtr = (Command *) token; ImportedCmdData *dataPtr = (ImportedCmdData *) cmdPtr->objClientData; Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr; if (firstToken == origin) { @@ -1679,30 +1773,30 @@ * * TclGetOriginalCommand -- * * An imported command is created in an namespace when a "real" command * is imported from another namespace. If the specified command is an - * imported command, this procedure returns the original command it - * refers to. + * imported command, this function returns the original command it refers + * to. * * Results: * If the command was imported into a sequence of namespaces a, b,...,n * where each successive namespace just imports the command from the - * previous namespace, this procedure returns the Tcl_Command token in - * the first namespace, a. Otherwise, if the specified command is not - * an imported command, the procedure returns NULL. + * previous namespace, this function returns the Tcl_Command token in the + * first namespace, a. Otherwise, if the specified command is not an + * imported command, the function returns NULL. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Command TclGetOriginalCommand(command) - Tcl_Command command; /* The imported command for which the - * original command should be returned. */ + Tcl_Command command; /* The imported command for which the original + * command should be returned. */ { register Command *cmdPtr = (Command *) command; ImportedCmdData *dataPtr; if (cmdPtr->deleteProc != DeleteImportedCmd) { @@ -1719,20 +1813,20 @@ /* *---------------------------------------------------------------------- * * InvokeImportedCmd -- * - * Invoked by Tcl whenever the user calls an imported command that - * was created by Tcl_Import. Finds the "real" command (in another + * Invoked by Tcl whenever the user calls an imported command that was + * created by Tcl_Import. Finds the "real" command (in another * namespace), and passes control to it. * * Results: - * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * Returns a result in the interpreter's result object. If anything - * goes wrong, the result object is set to an error message. + * Returns a result in the interpreter's result object. If anything goes + * wrong, the result object is set to an error message. * *---------------------------------------------------------------------- */ static int @@ -1754,15 +1848,15 @@ *---------------------------------------------------------------------- * * DeleteImportedCmd -- * * Invoked by Tcl whenever an imported command is deleted. The "real" - * command keeps a list of all the imported commands that refer to it, - * so those imported commands can be deleted when the real command is - * deleted. This procedure removes the imported command reference from - * the real command's list, and frees up the memory associated with - * the imported command. + * command keeps a list of all the imported commands that refer to it, so + * those imported commands can be deleted when the real command is + * deleted. This function removes the imported command reference from the + * real command's list, and frees up the memory associated with the + * imported command. * * Results: * None. * * Side effects: @@ -1809,74 +1903,74 @@ *---------------------------------------------------------------------- * * TclGetNamespaceForQualName -- * * Given a qualified name specifying a command, variable, or namespace, - * and a namespace in which to resolve the name, this procedure returns - * a pointer to the namespace that contains the item. A qualified name - * consists of the "simple" name of an item qualified by the names of - * an arbitrary number of containing namespace separated by "::"s. If - * the qualified name starts with "::", it is interpreted absolutely - * from the global namespace. Otherwise, it is interpreted relative to - * the namespace specified by cxtNsPtr if it is non-NULL. If cxtNsPtr - * is NULL, the name is interpreted relative to the current namespace. - * - * A relative name like "foo::bar::x" can be found starting in either - * the current namespace or in the global namespace. So each search - * usually follows two tracks, and two possible namespaces are - * returned. If the procedure sets either *nsPtrPtr or *altNsPtrPtr to - * NULL, then that path failed. + * and a namespace in which to resolve the name, this function returns a + * pointer to the namespace that contains the item. A qualified name + * consists of the "simple" name of an item qualified by the names of an + * arbitrary number of containing namespace separated by "::"s. If the + * qualified name starts with "::", it is interpreted absolutely from the + * global namespace. Otherwise, it is interpreted relative to the + * namespace specified by cxtNsPtr if it is non-NULL. If cxtNsPtr is + * NULL, the name is interpreted relative to the current namespace. + * + * A relative name like "foo::bar::x" can be found starting in either the + * current namespace or in the global namespace. So each search usually + * follows two tracks, and two possible namespaces are returned. If the + * function sets either *nsPtrPtr or *altNsPtrPtr to NULL, then that path + * failed. * * If "flags" contains TCL_GLOBAL_ONLY, the relative qualified name is - * sought only in the global :: namespace. The alternate search - * (also) starting from the global namespace is ignored and - * *altNsPtrPtr is set NULL. - * - * If "flags" contains TCL_NAMESPACE_ONLY, the relative qualified - * name is sought only in the namespace specified by cxtNsPtr. The - * alternate search starting from the global namespace is ignored and - * *altNsPtrPtr is set NULL. If both TCL_GLOBAL_ONLY and - * TCL_NAMESPACE_ONLY are specified, TCL_GLOBAL_ONLY is ignored and - * the search starts from the namespace specified by cxtNsPtr. - * - * If "flags" contains TCL_CREATE_NS_IF_UNKNOWN, all namespace - * components of the qualified name that cannot be found are - * automatically created within their specified parent. This makes sure - * that functions like Tcl_CreateCommand always succeed. There is no - * alternate search path, so *altNsPtrPtr is set NULL. - * - * If "flags" contains TCL_FIND_ONLY_NS, the qualified name is treated as a - * reference to a namespace, and the entire qualified name is - * followed. If the name is relative, the namespace is looked up only - * in the current namespace. A pointer to the namespace is stored in - * *nsPtrPtr and NULL is stored in *simpleNamePtr. Otherwise, if - * TCL_FIND_ONLY_NS is not specified, only the leading components are - * treated as namespace names, and a pointer to the simple name of the - * final component is stored in *simpleNamePtr. + * sought only in the global :: namespace. The alternate search (also) + * starting from the global namespace is ignored and *altNsPtrPtr is set + * NULL. + * + * If "flags" contains TCL_NAMESPACE_ONLY, the relative qualified name is + * sought only in the namespace specified by cxtNsPtr. The alternate + * search starting from the global namespace is ignored and *altNsPtrPtr + * is set NULL. If both TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY are + * specified, TCL_GLOBAL_ONLY is ignored and the search starts from the + * namespace specified by cxtNsPtr. + * + * If "flags" contains TCL_CREATE_NS_IF_UNKNOWN, all namespace components + * of the qualified name that cannot be found are automatically created + * within their specified parent. This makes sure that functions like + * Tcl_CreateCommand always succeed. There is no alternate search path, + * so *altNsPtrPtr is set NULL. + * + * If "flags" contains TCL_FIND_ONLY_NS, the qualified name is treated as + * a reference to a namespace, and the entire qualified name is followed. + * If the name is relative, the namespace is looked up only in the + * current namespace. A pointer to the namespace is stored in *nsPtrPtr + * and NULL is stored in *simpleNamePtr. Otherwise, if TCL_FIND_ONLY_NS + * is not specified, only the leading components are treated as namespace + * names, and a pointer to the simple name of the final component is + * stored in *simpleNamePtr. * * Results: * It sets *nsPtrPtr and *altNsPtrPtr to point to the two possible * namespaces which represent the last (containing) namespace in the - * qualified name. If the procedure sets either *nsPtrPtr or *altNsPtrPtr - * to NULL, then the search along that path failed. The procedure also + * qualified name. If the function sets either *nsPtrPtr or *altNsPtrPtr + * to NULL, then the search along that path failed. The function also * stores a pointer to the simple name of the final component in * *simpleNamePtr. If the qualified name is "::" or was treated as a - * namespace reference (TCL_FIND_ONLY_NS), the procedure stores a pointer + * namespace reference (TCL_FIND_ONLY_NS), the function stores a pointer * to the namespace in *nsPtrPtr, NULL in *altNsPtrPtr, and sets * *simpleNamePtr to point to an empty string. * - * If there is an error, this procedure returns TCL_ERROR. If "flags" + * If there is an error, this function returns TCL_ERROR. If "flags" * contains TCL_LEAVE_ERR_MSG, an error message is returned in the * interpreter's result object. Otherwise, the interpreter's result * object is left unchanged. * - * *actualCxtPtrPtr is set to the actual context namespace. It is - * set to the input context namespace pointer in cxtNsPtr. If cxtNsPtr - * is NULL, it is set to the current namespace context. + * *actualCxtPtrPtr is set to the actual context namespace. It is set to + * the input context namespace pointer in cxtNsPtr. If cxtNsPtr is NULL, + * it is set to the current namespace context. * - * For backwards compatibility with the TclPro byte code loader, - * this function always returns TCL_OK. + * For backwards compatibility with the TclPro byte code loader, this + * function always returns TCL_OK. * * Side effects: * If "flags" contains TCL_CREATE_NS_IF_UNKNOWN, new namespaces may be * created. * @@ -1884,47 +1978,45 @@ */ int TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr) - Tcl_Interp *interp; /* Interpreter in which to find the - * namespace containing qualName. */ - CONST char *qualName; /* A namespace-qualified name of an - * command, variable, or namespace. */ - Namespace *cxtNsPtr; /* The namespace in which to start the - * search for qualName's namespace. If NULL - * start from the current namespace. - * Ignored if TCL_GLOBAL_ONLY is set. */ - int flags; /* Flags controlling the search: an OR'd - * combination of TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY, - * TCL_CREATE_NS_IF_UNKNOWN, and - * TCL_FIND_ONLY_NS. */ - Namespace **nsPtrPtr; /* Address where procedure stores a pointer - * to containing namespace if qualName is - * found starting from *cxtNsPtr or, if - * TCL_GLOBAL_ONLY is set, if qualName is - * found in the global :: namespace. NULL - * is stored otherwise. */ - Namespace **altNsPtrPtr; /* Address where procedure stores a pointer - * to containing namespace if qualName is - * found starting from the global :: - * namespace. NULL is stored if qualName - * isn't found starting from :: or if the - * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, - * TCL_CREATE_NS_IF_UNKNOWN, TCL_FIND_ONLY_NS - * flag is set. */ - Namespace **actualCxtPtrPtr; /* Address where procedure stores a pointer - * to the actual namespace from which the - * search started. This is either cxtNsPtr, - * the :: namespace if TCL_GLOBAL_ONLY was - * specified, or the current namespace if - * cxtNsPtr was NULL. */ - CONST char **simpleNamePtr; /* Address where procedure stores the - * simple name at end of the qualName, or - * NULL if qualName is "::" or the flag - * TCL_FIND_ONLY_NS was specified. */ + Tcl_Interp *interp; /* Interpreter in which to find the namespace + * containing qualName. */ + CONST char *qualName; /* A namespace-qualified name of an command, + * variable, or namespace. */ + Namespace *cxtNsPtr; /* The namespace in which to start the search + * for qualName's namespace. If NULL start + * from the current namespace. Ignored if + * TCL_GLOBAL_ONLY is set. */ + int flags; /* Flags controlling the search: an OR'd + * combination of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, TCL_FIND_ONLY_NS, and + * TCL_CREATE_NS_IF_UNKNOWN. */ + Namespace **nsPtrPtr; /* Address where function stores a pointer to + * containing namespace if qualName is found + * starting from *cxtNsPtr or, if + * TCL_GLOBAL_ONLY is set, if qualName is + * found in the global :: namespace. NULL is + * stored otherwise. */ + Namespace **altNsPtrPtr; /* Address where function stores a pointer to + * containing namespace if qualName is found + * starting from the global :: namespace. + * NULL is stored if qualName isn't found + * starting from :: or if the TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, TCL_FIND_ONLY_NS, + * TCL_CREATE_NS_IF_UNKNOWN flag is set. */ + Namespace **actualCxtPtrPtr;/* Address where function stores a pointer to + * the actual namespace from which the search + * started. This is either cxtNsPtr, the :: + * namespace if TCL_GLOBAL_ONLY was specified, + * or the current namespace if cxtNsPtr was + * NULL. */ + CONST char **simpleNamePtr; /* Address where function stores the simple + * name at end of the qualName, or NULL if + * qualName is "::" or the flag + * TCL_FIND_ONLY_NS was specified. */ { Interp *iPtr = (Interp *) interp; Namespace *nsPtr = cxtNsPtr; Namespace *altNsPtr; Namespace *globalNsPtr = iPtr->globalNsPtr; @@ -1934,15 +2026,15 @@ Tcl_DString buffer; int len; /* * Determine the context namespace nsPtr in which to start the primary - * search. If the qualName name starts with a "::" or TCL_GLOBAL_ONLY - * was specified, search from the global namespace. Otherwise, use the + * search. If the qualName name starts with a "::" or TCL_GLOBAL_ONLY was + * specified, search from the global namespace. Otherwise, use the * namespace given in cxtNsPtr, or if that is NULL, use the current - * namespace context. Note that we always treat two or more - * adjacent ":"s as a namespace separator. + * namespace context. Note that we always treat two or more adjacent ":"s + * as a namespace separator. */ if (flags & TCL_GLOBAL_ONLY) { nsPtr = globalNsPtr; } else if (nsPtr == NULL) { @@ -1989,14 +2081,14 @@ Tcl_DStringInit(&buffer); end = start; while (*start != '\0') { /* - * Find the next namespace qualifier (i.e., a name ending in "::") - * or the end of the qualified name (i.e., a name ending in "\0"). - * Set len to the number of characters, starting from start, - * in the name; set end to point after the "::"s or at the "\0". + * Find the next namespace qualifier (i.e., a name ending in "::") or + * the end of the qualified name (i.e., a name ending in "\0"). Set + * len to the number of characters, starting from start, in the name; + * set end to point after the "::"s or at the "\0". */ len = 0; for (end = start; *end != '\0'; end++) { if ((*end == ':') && (*(end+1) == ':')) { @@ -2010,12 +2102,12 @@ } if (*end=='\0' && !(end-start>=2 && *(end-1)==':' && *(end-2)==':')) { /* * qualName ended with a simple name at start. If TCL_FIND_ONLY_NS - * was specified, look this up as a namespace. Otherwise, - * start is the name of a cmd or var and we are done. + * was specified, look this up as a namespace. Otherwise, start is + * the name of a cmd or var and we are done. */ if (flags & TCL_FIND_ONLY_NS) { nsName = start; } else { @@ -2027,13 +2119,13 @@ } } else { /* * start points to the beginning of a namespace qualifier ending * in "::". end points to the start of a name in that namespace - * that might be empty. Copy the namespace qualifier to a - * buffer so it can be null terminated. We can't modify the - * incoming qualName since it may be a string constant. + * that might be empty. Copy the namespace qualifier to a buffer + * so it can be null terminated. We can't modify the incoming + * qualName since it may be a string constant. */ Tcl_DStringSetLength(&buffer, 0); Tcl_DStringAppend(&buffer, start, len); nsName = Tcl_DStringValue(&buffer); @@ -2040,27 +2132,27 @@ } /* * Look up the namespace qualifier nsName in the current namespace * context. If it isn't found but TCL_CREATE_NS_IF_UNKNOWN is set, - * create that qualifying namespace. This is needed for procedures - * like Tcl_CreateCommand that cannot fail. + * create that qualifying namespace. This is needed for functions like + * Tcl_CreateCommand that cannot fail. */ if (nsPtr != NULL) { entryPtr = Tcl_FindHashEntry(&nsPtr->childTable, nsName); if (entryPtr != NULL) { nsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); } else if (flags & TCL_CREATE_NS_IF_UNKNOWN) { - Tcl_CallFrame frame; + Tcl_CallFrame *framePtr; - (void) Tcl_PushCallFrame(interp, &frame, + (void) TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0); nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName, (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); - Tcl_PopCallFrame(interp); + TclPopStackFrame(interp); if (nsPtr == NULL) { Tcl_Panic("Could not create namespace '%s'", nsName); } } else { /* namespace not found and wasn't created */ @@ -2100,28 +2192,28 @@ * We ignore trailing "::"s in a namespace name, but in a command or * variable name, trailing "::"s refer to the cmd or var named {}. */ if ((flags & TCL_FIND_ONLY_NS) || (end>start && *(end-1)!=':')) { - *simpleNamePtr = NULL; /* found namespace name */ + *simpleNamePtr = NULL; /* found namespace name */ } else { - *simpleNamePtr = end; /* found cmd/var: points to empty string */ + *simpleNamePtr = end; /* found cmd/var: points to empty string */ } /* - * As a special case, if we are looking for a namespace and qualName - * is "" and the current active namespace (nsPtr) is not the global - * namespace, return NULL (no namespace was found). This is because - * namespaces can not have empty names except for the global namespace. + * As a special case, if we are looking for a namespace and qualName is "" + * and the current active namespace (nsPtr) is not the global namespace, + * return NULL (no namespace was found). This is because namespaces can + * not have empty names except for the global namespace. */ if ((flags & TCL_FIND_ONLY_NS) && (*qualName == '\0') && (nsPtr != globalNsPtr)) { nsPtr = NULL; } - *nsPtrPtr = nsPtr; + *nsPtrPtr = nsPtr; *altNsPtrPtr = altNsPtr; Tcl_DStringFree(&buffer); return TCL_OK; } @@ -2131,56 +2223,56 @@ * Tcl_FindNamespace -- * * Searches for a namespace. * * Results: - * Returns a pointer to the namespace if it is found. Otherwise, - * returns NULL and leaves an error message in the interpreter's - * result object if "flags" contains TCL_LEAVE_ERR_MSG. + * Returns a pointer to the namespace if it is found. Otherwise, returns + * NULL and leaves an error message in the interpreter's result object if + * "flags" contains TCL_LEAVE_ERR_MSG. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Namespace * Tcl_FindNamespace(interp, name, contextNsPtr, flags) - Tcl_Interp *interp; /* The interpreter in which to find the - * namespace. */ - CONST char *name; /* Namespace name. If it starts with "::", - * will be looked up in global namespace. - * Else, looked up first in contextNsPtr - * (current namespace if contextNsPtr is - * NULL), then in global namespace. */ - Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag is set - * or if the name starts with "::". - * Otherwise, points to namespace in which - * to resolve name; if NULL, look up name - * in the current namespace. */ - register int flags; /* Flags controlling namespace lookup: an - * OR'd combination of TCL_GLOBAL_ONLY and - * TCL_LEAVE_ERR_MSG flags. */ + Tcl_Interp *interp; /* The interpreter in which to find the + * namespace. */ + CONST char *name; /* Namespace name. If it starts with "::", + * will be looked up in global namespace. + * Else, looked up first in contextNsPtr + * (current namespace if contextNsPtr is + * NULL), then in global namespace. */ + Tcl_Namespace *contextNsPtr;/* Ignored if TCL_GLOBAL_ONLY flag is set or + * if the name starts with "::". Otherwise, + * points to namespace in which to resolve + * name; if NULL, look up name in the current + * namespace. */ + register int flags; /* Flags controlling namespace lookup: an OR'd + * combination of TCL_GLOBAL_ONLY and + * TCL_LEAVE_ERR_MSG flags. */ { Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; CONST char *dummy; /* - * Find the namespace(s) that contain the specified namespace name. - * Add the TCL_FIND_ONLY_NS flag to resolve the name all the way down - * to its last component, a namespace. + * Find the namespace(s) that contain the specified namespace name. Add + * the TCL_FIND_ONLY_NS flag to resolve the name all the way down to its + * last component, a namespace. */ TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, flags|TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); if (nsPtr != NULL) { return (Tcl_Namespace *) nsPtr; } else if (flags & TCL_LEAVE_ERR_MSG) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "unknown namespace \"", name, - "\"", (char *) NULL); + Tcl_AppendResult(interp, "unknown namespace \"", name, "\"", + (char *) NULL); } return NULL; } /* @@ -2189,72 +2281,69 @@ * Tcl_FindCommand -- * * Searches for a command. * * Results: - * Returns a token for the command if it is found. Otherwise, if it - * can't be found or there is an error, returns NULL and leaves an - * error message in the interpreter's result object if "flags" - * contains TCL_LEAVE_ERR_MSG. + * Returns a token for the command if it is found. Otherwise, if it can't + * be found or there is an error, returns NULL and leaves an error + * message in the interpreter's result object if "flags" contains + * TCL_LEAVE_ERR_MSG. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Command Tcl_FindCommand(interp, name, contextNsPtr, flags) - Tcl_Interp *interp; /* The interpreter in which to find the - * command and to report errors. */ - CONST char *name; /* Command's name. If it starts with "::", - * will be looked up in global namespace. - * Else, looked up first in contextNsPtr - * (current namespace if contextNsPtr is - * NULL), then in global namespace. */ - Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag set. - * Otherwise, points to namespace in which - * to resolve name. If NULL, look up name - * in the current namespace. */ - int flags; /* An OR'd combination of flags: - * TCL_GLOBAL_ONLY (look up name only in - * global namespace), TCL_NAMESPACE_ONLY - * (look up only in contextNsPtr, or the - * current namespace if contextNsPtr is - * NULL), and TCL_LEAVE_ERR_MSG. If both - * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY - * are given, TCL_GLOBAL_ONLY is - * ignored. */ + Tcl_Interp *interp; /* The interpreter in which to find the + * command and to report errors. */ + CONST char *name; /* Command's name. If it starts with "::", + * will be looked up in global namespace. + * Else, looked up first in contextNsPtr + * (current namespace if contextNsPtr is + * NULL), then in global namespace. */ + Tcl_Namespace *contextNsPtr;/* Ignored if TCL_GLOBAL_ONLY flag set. + * Otherwise, points to namespace in which to + * resolve name. If NULL, look up name in the + * current namespace. */ + int flags; /* An OR'd combination of flags: + * TCL_GLOBAL_ONLY (look up name only in + * global namespace), TCL_NAMESPACE_ONLY (look + * up only in contextNsPtr, or the current + * namespace if contextNsPtr is NULL), and + * TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY + * and TCL_NAMESPACE_ONLY are given, + * TCL_GLOBAL_ONLY is ignored. */ { Interp *iPtr = (Interp*)interp; - - ResolverScheme *resPtr; - Namespace *nsPtr[2], *cxtNsPtr; - CONST char *simpleName; + Namespace *cxtNsPtr; register Tcl_HashEntry *entryPtr; register Command *cmdPtr; - register int search; + CONST char *simpleName; int result; - Tcl_Command cmd; /* - * If this namespace has a command resolver, then give it first - * crack at the command resolution. If the interpreter has any - * command resolvers, consult them next. The command resolver - * procedures may return a Tcl_Command value, they may signal - * to continue onward, or they may signal an error. + * If this namespace has a command resolver, then give it first crack at + * the command resolution. If the interpreter has any command resolvers, + * consult them next. The command resolver functions may return a + * Tcl_Command value, they may signal to continue onward, or they may + * signal an error. */ - if ((flags & TCL_GLOBAL_ONLY) != 0) { + + if (flags & TCL_GLOBAL_ONLY) { cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); } else if (contextNsPtr != NULL) { cxtNsPtr = (Namespace *) contextNsPtr; } else { cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } if (cxtNsPtr->cmdResProc != NULL || iPtr->resolverPtr != NULL) { - resPtr = iPtr->resolverPtr; + ResolverScheme *resPtr = iPtr->resolverPtr; + Tcl_Command cmd; if (cxtNsPtr->cmdResProc) { result = (*cxtNsPtr->cmdResProc)(interp, name, (Tcl_Namespace *) cxtNsPtr, flags, &cmd); } else { @@ -2278,83 +2367,139 @@ /* * Find the namespace(s) that contain the command. */ - TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, - flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); - - /* - * Look for the command in the command table of its namespace. - * Be sure to check both possible search paths: from the specified - * namespace context and from the global namespace. - */ - cmdPtr = NULL; - for (search = 0; (search < 2) && (cmdPtr == NULL); search++) { - if ((nsPtr[search] != NULL) && (simpleName != NULL)) { - entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable, - simpleName); + if (cxtNsPtr->commandPathLength!=0 && strncmp(name, "::", 2)) { + int i; + Namespace *pathNsPtr, *realNsPtr, *dummyNsPtr; + + (void) TclGetNamespaceForQualName(interp, name, cxtNsPtr, + TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, + &simpleName); + if (realNsPtr != NULL && simpleName != NULL) { + entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); if (entryPtr != NULL) { cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); } } + + /* + * Next, check along the path. + */ + + for (i=0 ; icommandPathLength && cmdPtr==NULL ; i++) { + pathNsPtr = cxtNsPtr->commandPathArray[i].nsPtr; + if (pathNsPtr == NULL) { + continue; + } + (void) TclGetNamespaceForQualName(interp, name, pathNsPtr, + TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, + &simpleName); + if (realNsPtr != NULL && simpleName != NULL) { + entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); + if (entryPtr != NULL) { + cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); + } + } + } + + /* + * If we've still not found the command, look in the global namespace + * as a last resort. + */ + + if (cmdPtr == NULL) { + (void) TclGetNamespaceForQualName(interp, name, NULL, + TCL_GLOBAL_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, + &simpleName); + if (realNsPtr != NULL && simpleName != NULL) { + entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); + if (entryPtr != NULL) { + cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); + } + } + } + } else { + Namespace *nsPtr[2]; + register int search; + + TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, + flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); + + /* + * Look for the command in the command table of its namespace. Be sure + * to check both possible search paths: from the specified namespace + * context and from the global namespace. + */ + + for (search = 0; (search < 2) && (cmdPtr == NULL); search++) { + if ((nsPtr[search] != NULL) && (simpleName != NULL)) { + entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable, + simpleName); + if (entryPtr != NULL) { + cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); + } + } + } } + if (cmdPtr != NULL) { return (Tcl_Command) cmdPtr; - } else if (flags & TCL_LEAVE_ERR_MSG) { + } + + if (flags & TCL_LEAVE_ERR_MSG) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "unknown command \"", name, "\"", (char *) NULL); } - return (Tcl_Command) NULL; } /* *---------------------------------------------------------------------- * * Tcl_FindNamespaceVar -- * * Searches for a namespace variable, a variable not local to a - * procedure. The variable can be either a scalar or an array, but - * may not be an element of an array. + * procedure. The variable can be either a scalar or an array, but may + * not be an element of an array. * * Results: * Returns a token for the variable if it is found. Otherwise, if it - * can't be found or there is an error, returns NULL and leaves an - * error message in the interpreter's result object if "flags" - * contains TCL_LEAVE_ERR_MSG. + * can't be found or there is an error, returns NULL and leaves an error + * message in the interpreter's result object if "flags" contains + * TCL_LEAVE_ERR_MSG. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Var Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags) - Tcl_Interp *interp; /* The interpreter in which to find the - * variable. */ - CONST char *name; /* Variable's name. If it starts with "::", - * will be looked up in global namespace. - * Else, looked up first in contextNsPtr - * (current namespace if contextNsPtr is - * NULL), then in global namespace. */ - Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag set. - * Otherwise, points to namespace in which - * to resolve name. If NULL, look up name - * in the current namespace. */ - int flags; /* An OR'd combination of flags: - * TCL_GLOBAL_ONLY (look up name only in - * global namespace), TCL_NAMESPACE_ONLY - * (look up only in contextNsPtr, or the - * current namespace if contextNsPtr is - * NULL), and TCL_LEAVE_ERR_MSG. If both - * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY - * are given, TCL_GLOBAL_ONLY is - * ignored. */ + Tcl_Interp *interp; /* The interpreter in which to find the + * variable. */ + CONST char *name; /* Variable's name. If it starts with "::", + * will be looked up in global namespace. + * Else, looked up first in contextNsPtr + * (current namespace if contextNsPtr is + * NULL), then in global namespace. */ + Tcl_Namespace *contextNsPtr;/* Ignored if TCL_GLOBAL_ONLY flag set. + * Otherwise, points to namespace in which to + * resolve name. If NULL, look up name in the + * current namespace. */ + int flags; /* An OR'd combination of flags: + * TCL_GLOBAL_ONLY (look up name only in + * global namespace), TCL_NAMESPACE_ONLY (look + * up only in contextNsPtr, or the current + * namespace if contextNsPtr is NULL), and + * TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY + * and TCL_NAMESPACE_ONLY are given, + * TCL_GLOBAL_ONLY is ignored. */ { Interp *iPtr = (Interp*)interp; ResolverScheme *resPtr; Namespace *nsPtr[2], *cxtNsPtr; CONST char *simpleName; @@ -2363,15 +2508,15 @@ register int search; int result; Tcl_Var var; /* - * If this namespace has a variable resolver, then give it first - * crack at the variable resolution. It may return a Tcl_Var - * value, it may signal to continue onward, or it may signal - * an error. + * If this namespace has a variable resolver, then give it first crack at + * the variable resolution. It may return a Tcl_Var value, it may signal + * to continue onward, or it may signal an error. */ + if ((flags & TCL_GLOBAL_ONLY) != 0) { cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); } else if (contextNsPtr != NULL) { cxtNsPtr = (Namespace *) contextNsPtr; } else { @@ -2409,13 +2554,13 @@ TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); /* - * Look for the variable in the variable table of its namespace. - * Be sure to check both possible search paths: from the specified - * namespace context and from the global namespace. + * Look for the variable in the variable table of its namespace. Be sure + * to check both possible search paths: from the specified namespace + * context and from the global namespace. */ varPtr = NULL; for (search = 0; (search < 2) && (varPtr == NULL); search++) { if ((nsPtr[search] != NULL) && (simpleName != NULL)) { @@ -2427,12 +2572,12 @@ } if (varPtr != NULL) { return (Tcl_Var) varPtr; } else if (flags & TCL_LEAVE_ERR_MSG) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "unknown variable \"", name, - "\"", (char *) NULL); + Tcl_AppendResult(interp, "unknown variable \"", name, "\"", + (char *) NULL); } return (Tcl_Var) NULL; } /* @@ -2442,29 +2587,29 @@ * * Called when a command is added to a namespace to check for existing * command references that the new command may invalidate. Consider the * following cases that could happen when you add a command "foo" to a * namespace "b": - * 1. It could shadow a command named "foo" at the global scope. - * If it does, all command references in the namespace "b" are + * 1. It could shadow a command named "foo" at the global scope. If + * it does, all command references in the namespace "b" are * suspect. - * 2. Suppose the namespace "b" resides in a namespace "a". - * Then to "a" the new command "b::foo" could shadow another - * command "b::foo" in the global namespace. If so, then all - * command references in "a" are suspect. - * The same checks are applied to all parent namespaces, until we - * reach the global :: namespace. + * 2. Suppose the namespace "b" resides in a namespace "a". Then to + * "a" the new command "b::foo" could shadow another command + * "b::foo" in the global namespace. If so, then all command + * references in "a" * are suspect. + * The same checks are applied to all parent namespaces, until we reach + * the global :: namespace. * * Results: * None. * * Side effects: * If the new command shadows an existing command, the cmdRefEpoch - * counter is incremented in each namespace that sees the shadow. - * This invalidates all command references that were previously cached - * in that namespace. The next time the commands are used, they are - * resolved from scratch. + * counter is incremented in each namespace that sees the shadow. This + * invalidates all command references that were previously cached in that + * namespace. The next time the commands are used, they are resolved from + * scratch. * *---------------------------------------------------------------------- */ void @@ -2478,11 +2623,11 @@ Namespace *trailNsPtr, *shadowNsPtr; Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); int found, i; /* - * This procedure generates an array used to hold the trail list. This + * This function generates an array used to hold the trail list. This * starts out with stack-allocated space but uses dynamically-allocated * storage if needed. */ Namespace *(trailStorage[NUM_TRAIL_ELEMS]); @@ -2489,37 +2634,36 @@ Namespace **trailPtr = trailStorage; int trailFront = -1; int trailSize = NUM_TRAIL_ELEMS; /* - * Start at the namespace containing the new command, and work up - * through the list of parents. Stop just before the global namespace, - * since the global namespace can't "shadow" its own entries. + * Start at the namespace containing the new command, and work up through + * the list of parents. Stop just before the global namespace, since the + * global namespace can't "shadow" its own entries. * * The namespace "trail" list we build consists of the names of each * namespace that encloses the new command, in order from outermost to * innermost: for example, "a" then "b". Each iteration of this loop * eventually extends the trail upwards by one namespace, nsPtr. We use * this trail list to see if nsPtr (e.g. "a" in 2. above) could have * now-invalid cached command references. This will happen if nsPtr - * (e.g. "a") contains a sequence of child namespaces (e.g. "b") - * such that there is a identically-named sequence of child namespaces - * starting from :: (e.g. "::b") whose tail namespace contains a command - * also named cmdName. + * (e.g. "a") contains a sequence of child namespaces (e.g. "b") such that + * there is a identically-named sequence of child namespaces starting from + * :: (e.g. "::b") whose tail namespace contains a command also named + * cmdName. */ cmdName = Tcl_GetHashKey(newCmdPtr->hPtr->tablePtr, newCmdPtr->hPtr); - for (nsPtr = newCmdPtr->nsPtr; - (nsPtr != NULL) && (nsPtr != globalNsPtr); - nsPtr = nsPtr->parentPtr) { + for (nsPtr=newCmdPtr->nsPtr ; (nsPtr!=NULL) && (nsPtr!=globalNsPtr) ; + nsPtr=nsPtr->parentPtr) { /* * Find the maximal sequence of child namespaces contained in nsPtr - * such that there is a identically-named sequence of child - * namespaces starting from ::. shadowNsPtr will be the tail of this - * sequence, or the deepest namespace under :: that might contain a - * command now shadowed by cmdName. We check below if shadowNsPtr - * actually contains a command cmdName. + * such that there is a identically-named sequence of child namespaces + * starting from ::. shadowNsPtr will be the tail of this sequence, or + * the deepest namespace under :: that might contain a command now + * shadowed by cmdName. We check below if shadowNsPtr actually + * contains a command cmdName. */ found = 1; shadowNsPtr = globalNsPtr; @@ -2534,21 +2678,22 @@ break; } } /* - * If shadowNsPtr contains a command named cmdName, we invalidate - * all of the command refs cached in nsPtr. As a boundary case, + * If shadowNsPtr contains a command named cmdName, we invalidate all + * of the command refs cached in nsPtr. As a boundary case, * shadowNsPtr is initially :: and we check for case 1. above. */ if (found) { hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName); if (hPtr != NULL) { nsPtr->cmdRefEpoch++; + TclInvalidateNsPath(nsPtr); - /* + /* * If the shadowed command was compiled to bytecodes, we * invalidate all the bytecodes in nsPtr, to force a new * compilation. We use the resolverEpoch to signal the need * for a fresh compilation of every bytecode. */ @@ -2558,21 +2703,20 @@ } } } /* - * Insert nsPtr at the front of the trail list: i.e., at the end - * of the trailPtr array. + * Insert nsPtr at the front of the trail list: i.e., at the end of + * the trailPtr array. */ trailFront++; if (trailFront == trailSize) { size_t currBytes = trailSize * sizeof(Namespace *); int newSize = 2*trailSize; size_t newBytes = newSize * sizeof(Namespace *); - Namespace **newPtr = - (Namespace **) ckalloc((unsigned) newBytes); + Namespace **newPtr = (Namespace **) ckalloc((unsigned) newBytes); memcpy((VOID *) newPtr, (VOID *) trailPtr, currBytes); if (trailPtr != trailStorage) { ckfree((char *) trailPtr); } @@ -2592,37 +2736,37 @@ } /* *---------------------------------------------------------------------- * - * GetNamespaceFromObj -- + * TclGetNamespaceFromObj -- * * Gets the namespace specified by the name in a Tcl_Obj. * * Results: - * Returns TCL_OK if the namespace was resolved successfully, and - * stores a pointer to the namespace in the location specified by - * nsPtrPtr. If the namespace can't be found, the procedure stores - * NULL in *nsPtrPtr and returns TCL_OK. If anything else goes wrong, - * this procedure returns TCL_ERROR. + * Returns TCL_OK if the namespace was resolved successfully, and stores + * a pointer to the namespace in the location specified by nsPtrPtr. If + * the namespace can't be found, the function stores NULL in *nsPtrPtr + * and returns TCL_OK. If anything else goes wrong, this function returns + * TCL_ERROR. * * Side effects: * May update the internal representation for the object, caching the - * namespace reference. The next time this procedure is called, the + * namespace reference. The next time this function is called, the * namespace value can be found quickly. * - * If anything goes wrong, an error message is left in the - * interpreter's result object. + * If anything goes wrong, an error message is left in the interpreter's + * result object. * *---------------------------------------------------------------------- */ -static int -GetNamespaceFromObj(interp, objPtr, nsPtrPtr) +int +TclGetNamespaceFromObj(interp, objPtr, nsPtrPtr) Tcl_Interp *interp; /* The current interpreter. */ - Tcl_Obj *objPtr; /* The object to be resolved as the name - * of a namespace. */ + Tcl_Obj *objPtr; /* The object to be resolved as the name of a + * namespace. */ Tcl_Namespace **nsPtrPtr; /* Result namespace pointer goes here. */ { Interp *iPtr = (Interp *) interp; register ResolvedNsName *resNamePtr; register Namespace *nsPtr; @@ -2630,13 +2774,13 @@ CallFrame *savedFramePtr; int result = TCL_OK; char *name; /* - * If the namespace name is fully qualified, do as if the lookup were - * done from the global namespace; this helps avoid repeated lookups - * of fully qualified names. + * If the namespace name is fully qualified, do as if the lookup were done + * from the global namespace; this helps avoid repeated lookups of fully + * qualified names. */ savedFramePtr = iPtr->varFramePtr; name = TclGetString(objPtr); if ((*name++ == ':') && (*name == ':')) { @@ -2645,12 +2789,12 @@ currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); /* * Get the internal representation, converting to a namespace type if - * needed. The internal representation is a ResolvedNsName that points - * to the actual namespace. + * needed. The internal representation is a ResolvedNsName that points to + * the actual namespace. */ if (objPtr->typePtr != &tclNsNameType) { result = tclNsNameType.setFromAnyProc(interp, objPtr); if (result != TCL_OK) { @@ -2658,21 +2802,20 @@ } } resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; /* - * Check the context namespace of the resolved symbol to make sure that - * it is fresh. If not, then force another conversion to the namespace - * type, to discard the old rep and create a new one. Note that we - * verify that the namespace id of the cached namespace is the same as - * the id when we cached it; this insures that the namespace wasn't - * deleted and a new one created at the same address. + * Check the context namespace of the resolved symbol to make sure that it + * is fresh. If not, then force another conversion to the namespace type, + * to discard the old rep and create a new one. Note that we verify that + * the namespace id of the cached namespace is the same as the id when we + * cached it; this insures that the namespace wasn't deleted and a new one + * created at the same address. */ nsPtr = NULL; - if ((resNamePtr != NULL) - && (resNamePtr->refNsPtr == currNsPtr) + if ((resNamePtr != NULL) && (resNamePtr->refNsPtr == currNsPtr) && (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) { nsPtr = resNamePtr->nsPtr; if (nsPtr->flags & NS_DEAD) { nsPtr = NULL; } @@ -2700,17 +2843,18 @@ /* *---------------------------------------------------------------------- * * Tcl_NamespaceObjCmd -- * - * Invoked to implement the "namespace" command that creates, deletes, - * or manipulates Tcl namespaces. Handles the following syntax: + * Invoked to implement the "namespace" command that creates, deletes, or + * manipulates Tcl namespaces. Handles the following syntax: * * namespace children ?name? ?pattern? * namespace code arg * namespace current * namespace delete ?name name...? + * namespace ensemble subcommand ?arg...? * namespace eval name arg ?arg...? * namespace exists name * namespace export ?-clear? ?pattern pattern...? * namespace forget ?pattern pattern...? * namespace import ?-force? ?pattern pattern...? @@ -2724,17 +2868,16 @@ * Results: * Returns TCL_OK if the command is successful. Returns TCL_ERROR if * anything goes wrong. * * Side effects: - * Based on the subcommand name (e.g., "import"), this procedure - * dispatches to a corresponding procedure NamespaceXXXCmd defined - * statically in this file. This procedure's side effects depend on - * whatever that subcommand procedure does. If there is an error, this - * procedure returns an error message in the interpreter's result - * object. Otherwise it may return a result in the interpreter's result - * object. + * Based on the subcommand name (e.g., "import"), this function + * dispatches to a corresponding function NamespaceXXXCmd defined + * statically in this file. This function's side effects depend on + * whatever that subcommand function does. If there is an error, this + * function returns an error message in the interpreter's result object. + * Otherwise it may return a result in the interpreter's result object. * *---------------------------------------------------------------------- */ int @@ -2745,17 +2888,17 @@ register Tcl_Obj *CONST objv[]; /* Argument objects. */ { static CONST char *subCmds[] = { "children", "code", "current", "delete", "ensemble", "eval", "exists", "export", "forget", "import", - "inscope", "origin", "parent", "qualifiers", + "inscope", "origin", "parent", "path", "qualifiers", "tail", "which", (char *) NULL }; enum NSSubCmdIdx { NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, NSEnsembleIdx, NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx, - NSInscopeIdx, NSOriginIdx, NSParentIdx, NSQualifiersIdx, + NSInscopeIdx, NSOriginIdx, NSParentIdx, NSPathIdx, NSQualifiersIdx, NSTailIdx, NSWhichIdx }; int index, result; if (objc < 2) { @@ -2811,10 +2954,13 @@ result = NamespaceOriginCmd(clientData, interp, objc, objv); break; case NSParentIdx: result = NamespaceParentCmd(clientData, interp, objc, objv); break; + case NSPathIdx: + result = NamespacePathCmd(clientData, interp, objc, objv); + break; case NSQualifiersIdx: result = NamespaceQualifiersCmd(clientData, interp, objc, objv); break; case NSTailIdx: result = NamespaceTailCmd(clientData, interp, objc, objv); @@ -2830,21 +2976,21 @@ *---------------------------------------------------------------------- * * NamespaceChildrenCmd -- * * Invoked to implement the "namespace children" command that returns a - * list containing the fully-qualified names of the child namespaces of - * a given namespace. Handles the following syntax: + * list containing the fully-qualified names of the child namespaces of a + * given namespace. Handles the following syntax: * * namespace children ?name? ?pattern? * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * Returns a result in the interpreter's result object. If anything - * goes wrong, the result is an error message. + * Returns a result in the interpreter's result object. If anything goes + * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -2868,11 +3014,11 @@ */ if (objc == 2) { nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } else if ((objc == 3) || (objc == 4)) { - if (GetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { + if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { return TCL_ERROR; } if (namespacePtr == NULL) { Tcl_AppendResult(interp, "unknown namespace \"", TclGetString(objv[2]), @@ -2904,15 +3050,22 @@ pattern = Tcl_DStringValue(&buffer); } } /* - * Create a list containing the full names of all child namespaces - * whose names match the specified pattern, if any. + * Create a list containing the full names of all child namespaces whose + * names match the specified pattern, if any. */ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { + if (Tcl_FindHashEntry(&nsPtr->childTable, pattern) != NULL) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(pattern, -1)); + } + goto searchDone; + } entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); while (entryPtr != NULL) { childNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); if ((pattern == NULL) || Tcl_StringMatch(childNsPtr->fullName, pattern)) { @@ -2920,10 +3073,11 @@ Tcl_ListObjAppendElement(interp, listPtr, elemPtr); } entryPtr = Tcl_NextHashEntry(&search); } + searchDone: Tcl_SetObjResult(interp, listPtr); Tcl_DStringFree(&buffer); return TCL_OK; } @@ -2940,19 +3094,19 @@ * Here "arg" can be a list. "namespace code arg" produces a result * equivalent to that produced by the command * * list ::namespace inscope [namespace current] $arg * - * However, if "arg" is itself a scoped value starting with - * "::namespace inscope", then the result is just "arg". + * However, if "arg" is itself a scoped value starting with "::namespace + * inscope", then the result is just "arg". * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * If anything goes wrong, this procedure returns an error - * message as the result in the interpreter's result object. + * If anything goes wrong, this function returns an error message as the + * result in the interpreter's result object. * *---------------------------------------------------------------------- */ static int @@ -2991,14 +3145,14 @@ } } /* * Otherwise, construct a scoped command by building a list with - * "namespace inscope", the full name of the current namespace, and - * the argument "arg". By constructing a list, we ensure that scoped - * commands are interpreted properly when they are executed later, - * by the "namespace inscope" command. + * "namespace inscope", the full name of the current namespace, and the + * argument "arg". By constructing a list, we ensure that scoped commands + * are interpreted properly when they are executed later, by the + * "namespace inscope" command. */ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("::namespace", -1)); @@ -3022,22 +3176,22 @@ /* *---------------------------------------------------------------------- * * NamespaceCurrentCmd -- * - * Invoked to implement the "namespace current" command which returns - * the fully-qualified name of the current namespace. Handles the - * following syntax: + * Invoked to implement the "namespace current" command which returns the + * fully-qualified name of the current namespace. Handles the following + * syntax: * * namespace current * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * Returns a result in the interpreter's result object. If anything - * goes wrong, the result is an error message. + * Returns a result in the interpreter's result object. If anything goes + * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -3053,14 +3207,14 @@ Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } /* - * The "real" name of the global namespace ("::") is the null string, - * but we return "::" for it as a convenience to programmers. Note that - * "" and "::" are treated as synonyms by the namespace code so that it - * is still easy to do things like: + * The "real" name of the global namespace ("::") is the null string, but + * we return "::" for it as a convenience to programmers. Note that "" and + * "::" are treated as synonyms by the namespace code so that it is still + * easy to do things like: * * namespace [namespace current]::bar { ... } */ currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); @@ -3083,25 +3237,24 @@ * namespace delete ?name name...? * * Each name identifies a namespace. It may include a sequence of * namespace qualifiers separated by "::"s. If a namespace is found, it * is deleted: all variables and procedures contained in that namespace - * are deleted. If that namespace is being used on the call stack, it - * is kept alive (but logically deleted) until it is removed from the - * call stack: that is, it can no longer be referenced by name but any + * are deleted. If that namespace is being used on the call stack, it is + * kept alive (but logically deleted) until it is removed from the call + * stack: that is, it can no longer be referenced by name but any * currently executing procedure that refers to it is allowed to do so * until the procedure returns. If the namespace can't be found, this - * procedure returns an error. If no namespaces are specified, this + * function returns an error. If no namespaces are specified, this * command does nothing. * * Results: - * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Deletes the specified namespaces. If anything goes wrong, this - * procedure returns an error message in the interpreter's - * result object. + * function returns an error message in the interpreter's result object. * *---------------------------------------------------------------------- */ static int @@ -3119,13 +3272,13 @@ Tcl_WrongNumArgs(interp, 2, objv, "?name name...?"); return TCL_ERROR; } /* - * Destroying one namespace may cause another to be destroyed. Break - * this into two passes: first check to make sure that all namespaces on - * the command line are valid, and report any errors. + * Destroying one namespace may cause another to be destroyed. Break this + * into two passes: first check to make sure that all namespaces on the + * command line are valid, and report any errors. */ for (i = 2; i < objc; i++) { name = TclGetString(objv[i]); namespacePtr = Tcl_FindNamespace(interp, name, @@ -3156,28 +3309,28 @@ /* *---------------------------------------------------------------------- * * NamespaceEvalCmd -- * - * Invoked to implement the "namespace eval" command. Executes - * commands in a namespace. If the namespace does not already exist, - * it is created. Handles the following syntax: + * Invoked to implement the "namespace eval" command. Executes commands + * in a namespace. If the namespace does not already exist, it is + * created. Handles the following syntax: * * namespace eval name arg ?arg...? * * If more than one arg argument is specified, the command that is - * executed is the result of concatenating the arguments together with - * a space between each argument. + * executed is the result of concatenating the arguments together with a + * space between each argument. * * Results: - * Returns TCL_OK if the namespace is found and the commands are - * executed successfully. Returns TCL_ERROR if anything goes wrong. + * Returns TCL_OK if the namespace is found and the commands are executed + * successfully. Returns TCL_ERROR if anything goes wrong. * * Side effects: - * Returns the result of the command in the interpreter's result - * object. If anything goes wrong, this procedure returns an error - * message as the result. + * Returns the result of the command in the interpreter's result object. + * If anything goes wrong, this function returns an error message as the + * result. * *---------------------------------------------------------------------- */ static int @@ -3186,11 +3339,11 @@ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Namespace *namespacePtr; - CallFrame frame, *framePtr; + CallFrame *framePtr, **framePtrPtr; Tcl_Obj *objPtr; int result; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); @@ -3200,11 +3353,11 @@ /* * Try to resolve the namespace reference, caching the result in the * namespace object along the way. */ - result = GetNamespaceFromObj(interp, objv[2], &namespacePtr); + result = TclGetNamespaceFromObj(interp, objv[2], &namespacePtr); if (result != TCL_OK) { return result; } /* @@ -3211,83 +3364,82 @@ * If the namespace wasn't found, try to create it. */ if (namespacePtr == NULL) { char *name = TclGetString(objv[2]); - namespacePtr = Tcl_CreateNamespace(interp, name, (ClientData) NULL, + namespacePtr = Tcl_CreateNamespace(interp, name, (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); if (namespacePtr == NULL) { return TCL_ERROR; } } /* - * Make the specified namespace the current namespace and evaluate - * the command(s). + * Make the specified namespace the current namespace and evaluate the + * command(s). */ /* This is needed to satisfy GCC 3.3's strict aliasing rules */ - framePtr = &frame; - result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, + framePtrPtr = &framePtr; + result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, namespacePtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { return TCL_ERROR; } - frame.objc = objc; - frame.objv = objv; /* ref counts do not need to be incremented here */ + framePtr->objc = objc; + framePtr->objv = objv; /* Reference counts do not need to be + * incremented here. */ if (objc == 4) { result = Tcl_EvalObjEx(interp, objv[3], 0); } else { /* * More than one argument: concatenate them together with spaces - * between, then evaluate the result. Tcl_EvalObjEx will delete - * the object when it decrements its refcount after eval'ing it. + * between, then evaluate the result. Tcl_EvalObjEx will delete the + * object when it decrements its refcount after eval'ing it. */ + objPtr = Tcl_ConcatObj(objc-3, objv+3); result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); } if (result == TCL_ERROR) { - Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine); - Tcl_Obj *msg = Tcl_NewStringObj("\n (in namespace eval \"", -1); - Tcl_IncrRefCount(errorLine); - Tcl_IncrRefCount(msg); - TclAppendLimitedToObj(msg, namespacePtr->fullName, -1, 200, ""); - Tcl_AppendToObj(msg, "\" script line ", -1); - Tcl_AppendObjToObj(msg, errorLine); - Tcl_DecrRefCount(errorLine); - Tcl_AppendToObj(msg, ")", -1); - TclAppendObjToErrorInfo(interp, msg); - Tcl_DecrRefCount(msg); + int length = strlen(namespacePtr->fullName); + int limit = 200; + int overflow = (length > limit); + + TclFormatToErrorInfo(interp, + "\n (in namespace eval \"%.*s%s\" script line %d)", + (overflow ? limit : length), namespacePtr->fullName, + (overflow ? "..." : ""), interp->errorLine); } /* * Restore the previous "current" namespace. */ - Tcl_PopCallFrame(interp); + TclPopStackFrame(interp); return result; } /* *---------------------------------------------------------------------- * * NamespaceExistsCmd -- * - * Invoked to implement the "namespace exists" command that returns - * true if the given namespace currently exists, and false otherwise. - * Handles the following syntax: + * Invoked to implement the "namespace exists" command that returns true + * if the given namespace currently exists, and false otherwise. Handles + * the following syntax: * * namespace exists name * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * Returns a result in the interpreter's result object. If anything - * goes wrong, the result is an error message. + * Returns a result in the interpreter's result object. If anything goes + * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -3306,11 +3458,11 @@ /* * Check whether the given namespace exists */ - if (GetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { + if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(namespacePtr != NULL)); return TCL_OK; @@ -3321,22 +3473,22 @@ * * NamespaceExportCmd -- * * Invoked to implement the "namespace export" command that specifies * which commands are exported from a namespace. The exported commands - * are those that can be imported into another namespace using - * "namespace import". Both commands defined in a namespace and - * commands the namespace has imported can be exported by a - * namespace. This command has the following syntax: + * are those that can be imported into another namespace using "namespace + * import". Both commands defined in a namespace and commands the + * namespace has imported can be exported by a namespace. This command + * has the following syntax: * * namespace export ?-clear? ?pattern pattern...? * - * Each pattern may contain "string match"-style pattern matching - * special characters, but the pattern may not include any namespace - * qualifiers: that is, the pattern must specify commands in the - * current (exporting) namespace. The specified patterns are appended - * onto the namespace's list of export patterns. + * Each pattern may contain "string match"-style pattern matching special + * characters, but the pattern may not include any namespace qualifiers: + * that is, the pattern must specify commands in the current (exporting) + * namespace. The specified patterns are appended onto the namespace's + * list of export patterns. * * To reset the namespace's export pattern list, specify the "-clear" * flag. * * If there are no export patterns and the "-clear" flag isn't given, @@ -3344,12 +3496,12 @@ * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * Returns a result in the interpreter's result object. If anything - * goes wrong, the result is an error message. + * Returns a result in the interpreter's result object. If anything goes + * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -3381,12 +3533,12 @@ firstArg++; } } /* - * If no pattern arguments are given, and "-clear" isn't specified, - * return the namespace's current export pattern list. + * If no pattern arguments are given, and "-clear" isn't specified, return + * the namespace's current export pattern list. */ patternCt = (objc - firstArg); if (patternCt == 0) { if (firstArg > 2) { @@ -3421,30 +3573,30 @@ /* *---------------------------------------------------------------------- * * NamespaceForgetCmd -- * - * Invoked to implement the "namespace forget" command to remove - * imported commands from a namespace. Handles the following syntax: + * Invoked to implement the "namespace forget" command to remove imported + * commands from a namespace. Handles the following syntax: * * namespace forget ?pattern pattern...? * * Each pattern is a name like "foo::*" or "a::b::x*". That is, the - * pattern may include the special pattern matching characters - * recognized by the "string match" command, but only in the command - * name at the end of the qualified name; the special pattern - * characters may not appear in a namespace name. All of the commands - * that match that pattern are checked to see if they have an imported - * command in the current namespace that refers to the matched - * command. If there is an alias, it is removed. - * + * pattern may include the special pattern matching characters recognized + * by the "string match" command, but only in the command name at the end + * of the qualified name; the special pattern characters may not appear + * in a namespace name. All of the commands that match that pattern are + * checked to see if they have an imported command in the current + * namespace that refers to the matched command. If there is an alias, it + * is removed. + * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * Imported commands are removed from the current namespace. If - * anything goes wrong, this procedure returns an error message in the + * Imported commands are removed from the current namespace. If anything + * goes wrong, this function returns an error message in the * interpreter's result object. * *---------------------------------------------------------------------- */ @@ -3481,32 +3633,31 @@ * Invoked to implement the "namespace import" command that imports * commands into a namespace. Handles the following syntax: * * namespace import ?-force? ?pattern pattern...? * - * Each pattern is a namespace-qualified name like "foo::*", - * "a::b::x*", or "bar::p". That is, the pattern may include the - * special pattern matching characters recognized by the "string match" - * command, but only in the command name at the end of the qualified - * name; the special pattern characters may not appear in a namespace - * name. All of the commands that match the pattern and which are - * exported from their namespace are made accessible from the current - * namespace context. This is done by creating a new "imported command" - * in the current namespace that points to the real command in its - * original namespace; when the imported command is called, it invokes - * the real command. + * Each pattern is a namespace-qualified name like "foo::*", "a::b::x*", + * or "bar::p". That is, the pattern may include the special pattern + * matching characters recognized by the "string match" command, but only + * in the command name at the end of the qualified name; the special + * pattern characters may not appear in a namespace name. All of the + * commands that match the pattern and which are exported from their + * namespace are made accessible from the current namespace context. This + * is done by creating a new "imported command" in the current namespace + * that points to the real command in its original namespace; when the + * imported command is called, it invokes the real command. * * If an imported command conflicts with an existing command, it is * treated as an error. But if the "-force" option is included, then * existing commands are overwritten by the imported commands. - * + * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Adds imported commands to the current namespace. If anything goes - * wrong, this procedure returns an error message in the interpreter's + * wrong, this function returns an error message in the interpreter's * result object. * *---------------------------------------------------------------------- */ @@ -3560,34 +3711,33 @@ * * NamespaceInscopeCmd -- * * Invoked to implement the "namespace inscope" command that executes a * script in the context of a particular namespace. This command is not - * expected to be used directly by programmers; calls to it are - * generated implicitly when programs use "namespace code" commands - * to register callback scripts. Handles the following syntax: + * expected to be used directly by programmers; calls to it are generated + * implicitly when programs use "namespace code" commands to register + * callback scripts. Handles the following syntax: * * namespace inscope name arg ?arg...? * * The "namespace inscope" command is much like the "namespace eval" * command except that it has lappend semantics and the namespace must - * already exist. It treats the first argument as a list, and appends - * any arguments after the first onto the end as proper list elements. - * For example, + * already exist. It treats the first argument as a list, and appends any + * arguments after the first onto the end as proper list elements. For + * example, * - * namespace inscope ::foo a b c d + * namespace inscope ::foo {a b} c d e * * is equivalent to * - * namespace eval ::foo [concat a [list b c d]] + * namespace eval ::foo [concat {a b} [list c d e]] * - * This lappend semantics is important because many callback scripts - * are actually prefixes. + * This lappend semantics is important because many callback scripts are + * actually prefixes. * * Results: - * Returns TCL_OK to indicate success, or TCL_ERROR to indicate - * failure. + * Returns TCL_OK to indicate success, or TCL_ERROR to indicate failure. * * Side effects: * Returns a result in the Tcl interpreter's result object. * *---------------------------------------------------------------------- @@ -3599,11 +3749,11 @@ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Namespace *namespacePtr; - Tcl_CallFrame frame; + Tcl_CallFrame *framePtr; int i, result; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); return TCL_ERROR; @@ -3611,11 +3761,11 @@ /* * Resolve the namespace reference. */ - result = GetNamespaceFromObj(interp, objv[2], &namespacePtr); + result = TclGetNamespaceFromObj(interp, objv[2], &namespacePtr); if (result != TCL_OK) { return result; } if (namespacePtr == NULL) { Tcl_AppendResult(interp, "unknown namespace \"", TclGetString(objv[2]), @@ -3625,19 +3775,19 @@ /* * Make the specified namespace the current namespace. */ - result = Tcl_PushCallFrame(interp, &frame, namespacePtr, + result = TclPushStackFrame(interp, &framePtr, namespacePtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { return result; } /* - * Execute the command. If there is just one argument, just treat it as - * a script and evaluate it. Otherwise, create a list from the arguments + * Execute the command. If there is just one argument, just treat it as a + * script and evaluate it. Otherwise, create a list from the arguments * after the first one, then concatenate the first argument and the list * of extra arguments to form the command to evaluate. */ if (objc == 4) { @@ -3661,28 +3811,25 @@ result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT); Tcl_DecrRefCount(listPtr); /* we're done with the list object */ } if (result == TCL_ERROR) { - Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine); - Tcl_Obj *msg = Tcl_NewStringObj("\n (in namespace inscope \"", -1); - Tcl_IncrRefCount(errorLine); - Tcl_IncrRefCount(msg); - TclAppendLimitedToObj(msg, namespacePtr->fullName, -1, 200, ""); - Tcl_AppendToObj(msg, "\" script line ", -1); - Tcl_AppendObjToObj(msg, errorLine); - Tcl_DecrRefCount(errorLine); - Tcl_AppendToObj(msg, ")", -1); - TclAppendObjToErrorInfo(interp, msg); - Tcl_DecrRefCount(msg); + int length = strlen(namespacePtr->fullName); + int limit = 200; + int overflow = (length > limit); + + TclFormatToErrorInfo(interp, + "\n (in namespace inscope \"%.*s%s\" script line %d)", + (overflow ? limit : length), namespacePtr->fullName, + (overflow ? "..." : ""), interp->errorLine); } /* * Restore the previous "current" namespace. */ - Tcl_PopCallFrame(interp); + TclPopStackFrame(interp); return result; } /* *---------------------------------------------------------------------- @@ -3701,16 +3848,16 @@ * into a sequence of namespaces a, b,...,n where each successive * namespace just imports the command from the previous namespace, this * command returns the fully-qualified name of the original command in * the first namespace, a. If "name" does not refer to an alias, its * fully-qualified name is returned. The returned name is stored in the - * interpreter's result object. This procedure returns TCL_OK if + * interpreter's result object. This function returns TCL_OK if * successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * If anything goes wrong, this procedure returns an error message in - * the interpreter's result object. + * If anything goes wrong, this function returns an error message in the + * interpreter's result object. * *---------------------------------------------------------------------- */ static int @@ -3737,12 +3884,12 @@ origCommand = TclGetOriginalCommand(command); resultPtr = Tcl_NewObj(); if (origCommand == (Tcl_Command) NULL) { /* * The specified command isn't an imported command. Return the - * command's name qualified by the full name of the namespace it - * was defined in. + * command's name qualified by the full name of the namespace it was + * defined in. */ Tcl_GetCommandFullName(interp, command, resultPtr); } else { Tcl_GetCommandFullName(interp, origCommand, resultPtr); @@ -3764,12 +3911,12 @@ * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * Returns a result in the interpreter's result object. If anything - * goes wrong, the result is an error message. + * Returns a result in the interpreter's result object. If anything goes + * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -3783,11 +3930,11 @@ int result; if (objc == 2) { nsPtr = Tcl_GetCurrentNamespace(interp); } else if (objc == 3) { - result = GetNamespaceFromObj(interp, objv[2], &nsPtr); + result = TclGetNamespaceFromObj(interp, objv[2], &nsPtr); if (result != TCL_OK) { return result; } if (nsPtr == NULL) { Tcl_AppendResult(interp, "unknown namespace \"", @@ -3812,29 +3959,266 @@ } /* *---------------------------------------------------------------------- * + * NamespacePathCmd -- + * + * Invoked to implement the "namespace path" command that reads and + * writes the current namespace's command resolution path. Has one + * optional argument: if present, it is a list of named namespaces to set + * the path to, and if absent, the current path should be returned. + * Handles the following syntax: + * + * namespace path ?nsList? + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong + * (most notably if the namespace list contains the name of something + * other than a namespace). In the successful-exit case, may set the + * interpreter result to the list of names of the namespaces on the + * current namespace's path. + * + * Side effects: + * May update the namespace path (triggering a recomputing of all command + * names that depend on the namespace for resolution). + * + *---------------------------------------------------------------------- + */ + +static int +NamespacePathCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + int i, nsObjc, result = TCL_ERROR; + Tcl_Obj **nsObjv; + Tcl_Namespace **namespaceList = NULL; + Tcl_Namespace *staticNs[4]; + + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?pathList?"); + return TCL_ERROR; + } + + /* + * If no path is given, return the current path. + */ + + if (objc == 2) { + /* + * Not a very fast way to compute this, but easy to get right. + */ + + for (i=0 ; icommandPathLength ; i++) { + if (nsPtr->commandPathArray[i].nsPtr != NULL) { + Tcl_AppendElement(interp, + nsPtr->commandPathArray[i].nsPtr->fullName); + } + } + return TCL_OK; + } + + /* + * There is a path given, so parse it into an array of namespace pointers. + */ + + if (Tcl_ListObjGetElements(interp, objv[2], &nsObjc, &nsObjv) != TCL_OK) { + goto badNamespace; + } + if (nsObjc != 0) { + if (nsObjc > 4) { + namespaceList = (Tcl_Namespace **) + ckalloc(sizeof(Tcl_Namespace *) * nsObjc); + } else { + namespaceList = staticNs; + } + + for (i=0 ; icommandPathSourceList; + if (tmpPathArray[i].nextPtr != NULL) { + tmpPathArray[i].nextPtr->prevPtr = &tmpPathArray[i]; + } + tmpPathArray[i].nsPtr->commandPathSourceList = &tmpPathArray[i]; + } + if (nsPtr->commandPathLength != 0) { + UnlinkNsPath(nsPtr); + } + nsPtr->commandPathArray = tmpPathArray; + } else { + if (nsPtr->commandPathLength != 0) { + UnlinkNsPath(nsPtr); + } + } + + nsPtr->commandPathLength = pathLength; + nsPtr->cmdRefEpoch++; + nsPtr->resolverEpoch++; +} + +/* + *---------------------------------------------------------------------- + * + * UnlinkNsPath -- + * + * Delete the given namespace's command name resolution path. Only call + * if the path is non-empty. Caller must reset the counter containing the + * path size. + * + * Results: + * nothing + * + * Side effects: + * Deletes the array of path entries and unlinks those path entries from + * the target namespace's list of interested namespaces. + * + *---------------------------------------------------------------------- + */ + +static void +UnlinkNsPath(nsPtr) + Namespace *nsPtr; +{ + int i; + for (i=0 ; icommandPathLength ; i++) { + NamespacePathEntry *nsPathPtr = &nsPtr->commandPathArray[i]; + if (nsPathPtr->prevPtr != NULL) { + nsPathPtr->prevPtr->nextPtr = nsPathPtr->nextPtr; + } + if (nsPathPtr->nextPtr != NULL) { + nsPathPtr->nextPtr->prevPtr = nsPathPtr->prevPtr; + } + if (nsPathPtr->nsPtr != NULL) { + if (nsPathPtr->nsPtr->commandPathSourceList == nsPathPtr) { + nsPathPtr->nsPtr->commandPathSourceList = nsPathPtr->nextPtr; + } + } + } + ckfree((char *) nsPtr->commandPathArray); +} + +/* + *---------------------------------------------------------------------- + * + * TclInvalidateNsPath -- + * + * Invalidate the name resolution caches for all names looked up in + * namespaces whose name path includes the given namespace. + * + * Results: + * nothing + * + * Side effects: + * Increments the command reference epoch in each namespace whose path + * includes the given namespace. This causes any cached resolved names + * whose root cacheing context starts at that namespace to be recomputed + * the next time they are used. + * + *---------------------------------------------------------------------- + */ + +void +TclInvalidateNsPath(nsPtr) + Namespace *nsPtr; +{ + NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList; + while (nsPathPtr != NULL) { + if (nsPathPtr->nsPtr != NULL) { + nsPathPtr->creatorNsPtr->cmdRefEpoch++; + } + nsPathPtr = nsPathPtr->nextPtr; + } +} + +/* + *---------------------------------------------------------------------- + * * NamespaceQualifiersCmd -- * * Invoked to implement the "namespace qualifiers" command that returns * any leading namespace qualifiers in a string. These qualifiers are * namespace names separated by "::"s. For example, for "::foo::p" this - * command returns "::foo", and for "::" it returns "". This command - * is the complement of the "namespace tail" command. Note that this - * command does not check whether the "namespace" names are, in fact, - * the names of currently defined namespaces. Handles the following - * syntax: + * command returns "::foo", and for "::" it returns "". This command is + * the complement of the "namespace tail" command. Note that this command + * does not check whether the "namespace" names are, in fact, the names + * of currently defined namespaces. Handles the following syntax: * * namespace qualifiers string * * Results: - * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * Returns a result in the interpreter's result object. If anything - * goes wrong, the result is an error message. + * Returns a result in the interpreter's result object. If anything goes + * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -3851,12 +4235,12 @@ Tcl_WrongNumArgs(interp, 2, objv, "string"); return TCL_ERROR; } /* - * Find the end of the string, then work backward and find - * the start of the last "::" qualifier. + * Find the end of the string, then work backward and find the start of + * the last "::" qualifier. */ name = TclGetString(objv[2]); for (p = name; *p != '\0'; p++) { /* empty body */ @@ -3882,26 +4266,26 @@ *---------------------------------------------------------------------- * * NamespaceTailCmd -- * * Invoked to implement the "namespace tail" command that returns the - * trailing name at the end of a string with "::" namespace - * qualifiers. These qualifiers are namespace names separated by - * "::"s. For example, for "::foo::p" this command returns "p", and for - * "::" it returns "". This command is the complement of the "namespace - * qualifiers" command. Note that this command does not check whether - * the "namespace" names are, in fact, the names of currently defined - * namespaces. Handles the following syntax: + * trailing name at the end of a string with "::" namespace qualifiers. + * These qualifiers are namespace names separated by "::"s. For example, + * for "::foo::p" this command returns "p", and for "::" it returns "". + * This command is the complement of the "namespace qualifiers" command. + * Note that this command does not check whether the "namespace" names + * are, in fact, the names of currently defined namespaces. Handles the + * following syntax: * * namespace tail string * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * Returns a result in the interpreter's result object. If anything - * goes wrong, the result is an error message. + * Returns a result in the interpreter's result object. If anything goes + * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int @@ -3917,12 +4301,12 @@ Tcl_WrongNumArgs(interp, 2, objv, "string"); return TCL_ERROR; } /* - * Find the end of the string, then work backward and find the - * last "::" qualifier. + * Find the end of the string, then work backward and find the last "::" + * qualifier. */ name = TclGetString(objv[2]); for (p = name; *p != '\0'; p++) { /* empty body */ @@ -3954,19 +4338,19 @@ * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * Returns a result in the interpreter's result object. If anything - * goes wrong, the result is an error message. + * Returns a result in the interpreter's result object. If anything goes + * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceWhichCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ + ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { static CONST char *opts[] = { @@ -3987,27 +4371,30 @@ if (Tcl_GetIndexFromObj(interp, objv[2], opts, "option", 0, &lookupType) != TCL_OK) { /* * Preserve old style of error message! */ + Tcl_ResetResult(interp); goto badArgs; } } resultPtr = Tcl_NewObj(); switch (lookupType) { case 0: { /* -command */ Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objv[objc-1]); - if (cmd != (Tcl_Command) NULL) { + + if (cmd != (Tcl_Command) NULL) { Tcl_GetCommandFullName(interp, cmd, resultPtr); } break; } case 1: { /* -variable */ Tcl_Var var = Tcl_FindNamespaceVar(interp, TclGetString(objv[objc-1]), NULL, /*flags*/ 0); + if (var != (Tcl_Var) NULL) { Tcl_GetVariableFullName(interp, var, resultPtr); } break; } @@ -4026,39 +4413,39 @@ * * Results: * None. * * Side effects: - * Decrements the ref count of any Namespace structure pointed - * to by the nsName's internal representation. If there are no more - * references to the namespace, it's structure will be freed. + * Decrements the ref count of any Namespace structure pointed to by the + * nsName's internal representation. If there are no more references to + * the namespace, it's structure will be freed. * *---------------------------------------------------------------------- */ static void FreeNsNameInternalRep(objPtr) - register Tcl_Obj *objPtr; /* nsName object with internal - * representation to free */ + register Tcl_Obj *objPtr; /* nsName object with internal representation + * to free */ { register ResolvedNsName *resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; Namespace *nsPtr; /* - * Decrement the reference count of the namespace. If there are no - * more references, free it up. + * Decrement the reference count of the namespace. If there are no more + * references, free it up. */ if (resNamePtr != NULL) { resNamePtr->refCount--; if (resNamePtr->refCount == 0) { /* - * Decrement the reference count for the cached namespace. If - * the namespace is dead, and there are no more references to - * it, free it. + * Decrement the reference count for the cached namespace. If the + * namespace is dead, and there are no more references to it, free + * it. */ nsPtr = resNamePtr->nsPtr; nsPtr->refCount--; if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) { @@ -4080,12 +4467,12 @@ * Results: * None. * * Side effects: * copyPtr's internal rep is set to refer to the same namespace - * referenced by srcPtr's internal rep. Increments the ref count of - * the ResolvedNsName structure used to hold the namespace reference. + * referenced by srcPtr's internal rep. Increments the ref count of the + * ResolvedNsName structure used to hold the namespace reference. * *---------------------------------------------------------------------- */ static void @@ -4106,33 +4493,32 @@ /* *---------------------------------------------------------------------- * * SetNsNameFromAny -- * - * Attempt to generate a nsName internal representation for a - * Tcl object. + * Attempt to generate a nsName internal representation for a Tcl object. * * Results: - * Returns TCL_OK if the value could be converted to a proper - * namespace reference. Otherwise, it returns TCL_ERROR, along - * with an error message in the interpreter's result object. + * Returns TCL_OK if the value could be converted to a proper namespace + * reference. Otherwise, it returns TCL_ERROR, along with an error + * message in the interpreter's result object. * * Side effects: - * If successful, the object is made a nsName object. Its internal rep - * is set to point to a ResolvedNsName, which contains a cached pointer - * to the Namespace. Reference counts are kept on both the - * ResolvedNsName and the Namespace, so we can keep track of their - * usage and free them when appropriate. + * If successful, the object is made a nsName object. Its internal rep is + * set to point to a ResolvedNsName, which contains a cached pointer to + * the Namespace. Reference counts are kept on both the ResolvedNsName + * and the Namespace, so we can keep track of their usage and free them + * when appropriate. * *---------------------------------------------------------------------- */ static int SetNsNameFromAny(interp, objPtr) - Tcl_Interp *interp; /* Points to the namespace in which to - * resolve name. Also used for error - * reporting if not NULL. */ + Tcl_Interp *interp; /* Points to the namespace in which to resolve + * name. Also used for error reporting if not + * NULL. */ register Tcl_Obj *objPtr; /* The object to convert. */ { char *name; CONST char *dummy; Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; @@ -4146,14 +4532,14 @@ if (name == NULL) { name = TclGetString(objPtr); } /* - * Look for the namespace "name" in the current namespace. If there is - * an error parsing the (possibly qualified) name, return an error. - * If the namespace isn't found, we convert the object to an nsName - * object with a NULL ResolvedNsName* internal rep. + * Look for the namespace "name" in the current namespace. If there is an + * error parsing the (possibly qualified) name, return an error. If the + * namespace isn't found, we convert the object to an nsName object with a + * NULL ResolvedNsName* internal rep. */ TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); @@ -4175,13 +4561,13 @@ } else { resNamePtr = NULL; } /* - * 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. + * 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.otherValuePtr = (VOID *) resNamePtr; objPtr->typePtr = &tclNsNameType; @@ -4191,20 +4577,20 @@ /* *---------------------------------------------------------------------- * * UpdateStringOfNsName -- * - * Updates the string representation for a nsName object. - * Note: This procedure does not free an existing old string rep - * so storage will be lost if this has not already been done. + * Updates the string representation for a nsName object. Note: This + * function does not free an existing old string rep so storage will be + * lost if this has not already been done. * * Results: * None. * * Side effects: - * The object's string is set to a copy of the fully qualified - * namespace name. + * The object's string is set to a copy of the fully qualified namespace + * name. * *---------------------------------------------------------------------- */ static void @@ -4227,12 +4613,12 @@ name = nsPtr->fullName; } } /* - * The following sets the string rep to an empty string on the heap - * if the internal rep is NULL. + * The following sets the string rep to an empty string on the heap if the + * internal rep is NULL. */ length = strlen(name); if (length == 0) { objPtr->bytes = tclEmptyStringRep; @@ -4247,23 +4633,23 @@ /* *---------------------------------------------------------------------- * * NamespaceEnsembleCmd -- * - * Invoked to implement the "namespace ensemble" command that - * creates and manipulates ensembles built on top of namespaces. - * Handles the following syntax: + * Invoked to implement the "namespace ensemble" command that creates and + * manipulates ensembles built on top of namespaces. Handles the + * following syntax: * * namespace ensemble name ?dictionary? * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * Creates the ensemble for the namespace if one did not - * previously exist. Alternatively, alters the way that the - * ensemble's subcommand => implementation prefix is configured. + * Creates the ensemble for the namespace if one did not previously + * exist. Alternatively, alters the way that the ensemble's subcommand => + * implementation prefix is configured. * *---------------------------------------------------------------------- */ static int @@ -4272,11 +4658,11 @@ Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Namespace *nsPtr; - EnsembleConfig *ensemblePtr; + Tcl_Command token; static CONST char *subcommands[] = { "configure", "create", "exists", NULL }; enum EnsSubcmds { ENS_CONFIG, ENS_CREATE, ENS_EXISTS @@ -4315,11 +4701,11 @@ switch ((enum EnsSubcmds) index) { case ENS_CREATE: { char *name; Tcl_DictSearch search; - Tcl_Obj *listObj, *nameObj = NULL; + Tcl_Obj *listObj; int done, len, allocatedMapFlag = 0; /* * Defaults */ Tcl_Obj *subcmdObj = NULL; @@ -4329,23 +4715,22 @@ objv += 3; objc -= 3; /* - * Work out what name to use for the command to create. If - * supplied, it is either fully specified or relative to the - * current namespace. If not supplied, it is exactly the name - * of the current namespace. + * Work out what name to use for the command to create. If supplied, + * it is either fully specified or relative to the current namespace. + * If not supplied, it is exactly the name of the current namespace. */ name = nsPtr->fullName; /* - * Parse the option list, applying type checks as we go. Note - * that we are not incrementing any reference counts in the - * objects at this stage, so the presence of an option - * multiple times won't cause any memory leaks. + * Parse the option list, applying type checks as we go. Note that we + * are not incrementing any reference counts in the objects at this + * stage, so the presence of an option multiple times won't cause any + * memory leaks. */ for (; objc>1 ; objc-=2,objv+=2 ) { if (Tcl_GetIndexFromObj(interp, objv[0], createOptions, "option", 0, &index) != TCL_OK) { @@ -4367,13 +4752,15 @@ } subcmdObj = (len > 0 ? objv[1] : NULL); continue; case CRT_MAP: { Tcl_Obj *patchedDict = NULL, *subcmdObj; + /* * Verify that the map is sensible. */ + if (Tcl_DictObjFirst(interp, objv[1], &search, &subcmdObj, &listObj, &done) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } @@ -4412,12 +4799,12 @@ return TCL_ERROR; } cmd = TclGetString(listv[0]); if (!(cmd[0] == ':' && cmd[1] == ':')) { Tcl_Obj *newList = Tcl_NewListObj(len, listv); - Tcl_Obj *newCmd = - Tcl_NewStringObj(nsPtr->fullName, -1); + Tcl_Obj *newCmd = Tcl_NewStringObj(nsPtr->fullName,-1); + if (nsPtr->parentPtr) { Tcl_AppendStringsToObj(newCmd, "::", NULL); } Tcl_AppendObjToObj(newCmd, listv[0]); Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd); @@ -4426,10 +4813,11 @@ } Tcl_DictObjPut(NULL, patchedDict, subcmdObj, newList); } Tcl_DictObjNext(&search, &subcmdObj, &listObj, &done); } while (!done); + if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } mapObj = (patchedDict ? patchedDict : objv[1]); if (patchedDict) { @@ -4457,116 +4845,92 @@ continue; } } /* - * Make the name of the ensemble into a fully qualified name. - * This might allocate an object. - */ - - if (!(name[0] == ':' && name[1] == ':')) { - nameObj = Tcl_NewStringObj(nsPtr->fullName, -1); - if (nsPtr->parentPtr == NULL) { - Tcl_AppendStringsToObj(nameObj, name, NULL); - } else { - Tcl_AppendStringsToObj(nameObj, "::", name, NULL); - } - Tcl_IncrRefCount(nameObj); - name = TclGetString(nameObj); - } - - /* - * Create the ensemble. Note that this might delete another - * ensemble linked to the same namespace, so we must be - * careful. However, we should be OK because we only link the - * namespace into the list once we've created it (and after - * any deletions have occurred.) - */ - - ensemblePtr = (EnsembleConfig *) ckalloc(sizeof(EnsembleConfig)); - ensemblePtr->nsPtr = nsPtr; - ensemblePtr->epoch = 0; - Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS); - ensemblePtr->subcommandArrayPtr = NULL; - ensemblePtr->subcmdList = subcmdObj; - if (subcmdObj != NULL) { - Tcl_IncrRefCount(subcmdObj); - } - ensemblePtr->subcommandDict = mapObj; - if (mapObj != NULL) { - Tcl_IncrRefCount(mapObj); - } - ensemblePtr->flags = (permitPrefix ? ENS_PREFIX : 0); - ensemblePtr->unknownHandler = unknownObj; - if (unknownObj != NULL) { - Tcl_IncrRefCount(unknownObj); - } - ensemblePtr->token = Tcl_CreateObjCommand(interp, name, - NsEnsembleImplementationCmd, (ClientData)ensemblePtr, - DeleteEnsembleConfig); - ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles; - nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr; - /* - * Trigger an eventual recomputation of the ensemble command - * set. Note that this is slightly tricky, as it means that - * we are not actually counting the number of namespace export - * actions, but it is the simplest way to go! - */ - nsPtr->exportLookupEpoch++; - Tcl_SetResult(interp, name, TCL_VOLATILE); - if (nameObj != NULL) { - Tcl_DecrRefCount(nameObj); - } + * Create the ensemble. Note that this might delete another ensemble + * linked to the same namespace, so we must be careful. However, we + * should be OK because we only link the namespace into the list once + * we've created it (and after any deletions have occurred.) + */ + + token = Tcl_CreateEnsemble(interp, name, NULL, + (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0)); + Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); + Tcl_SetEnsembleMappingDict(interp, token, mapObj); + Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj); + + /* + * Tricky! Must ensure that the result is not shared (command delete + * traces could have corrupted the pristine object that we started + * with). [Snit test rename-1.5] + */ + + Tcl_ResetResult(interp); + Tcl_GetCommandFullName(interp, token, Tcl_GetObjResult(interp)); return TCL_OK; } case ENS_EXISTS: if (objc != 4) { Tcl_WrongNumArgs(interp, 3, objv, "cmdname"); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj( - FindEnsemble(interp, objv[3], 0) != NULL)); + Tcl_FindEnsemble(interp, objv[3], 0) != NULL)); return TCL_OK; case ENS_CONFIG: if (objc < 4 || (objc != 5 && objc & 1)) { Tcl_WrongNumArgs(interp, 3, objv, "cmdname ?opt? ?value? ..."); return TCL_ERROR; } - ensemblePtr = FindEnsemble(interp, objv[3], TCL_LEAVE_ERR_MSG); - if (ensemblePtr == NULL) { + token = Tcl_FindEnsemble(interp, objv[3], TCL_LEAVE_ERR_MSG); + if (token == NULL) { return TCL_ERROR; } if (objc == 5) { + Tcl_Obj *resultObj; + if (Tcl_GetIndexFromObj(interp, objv[4], configOptions, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum EnsConfigOpts) index) { case CONF_SUBCMDS: - if (ensemblePtr->subcmdList != NULL) { - Tcl_SetObjResult(interp, ensemblePtr->subcmdList); + Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj); + if (resultObj != NULL) { + Tcl_SetObjResult(interp, resultObj); } break; case CONF_MAP: - if (ensemblePtr->subcommandDict != NULL) { - Tcl_SetObjResult(interp, ensemblePtr->subcommandDict); + Tcl_GetEnsembleMappingDict(NULL, token, &resultObj); + if (resultObj != NULL) { + Tcl_SetObjResult(interp, resultObj); } break; - case CONF_NAMESPACE: - Tcl_SetResult(interp, ensemblePtr->nsPtr->fullName, + case CONF_NAMESPACE: { + Tcl_Namespace *namespacePtr; + + Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); + Tcl_SetResult(interp, ((Namespace *)namespacePtr)->fullName, TCL_VOLATILE); break; - case CONF_PREFIX: + } + case CONF_PREFIX: { + int flags; + + Tcl_GetEnsembleFlags(NULL, token, &flags); Tcl_SetObjResult(interp, - Tcl_NewBooleanObj(ensemblePtr->flags & ENS_PREFIX)); + Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX)); break; + } case CONF_UNKNOWN: - if (ensemblePtr->unknownHandler != NULL) { - Tcl_SetObjResult(interp, ensemblePtr->unknownHandler); + Tcl_GetEnsembleUnknownHandler(NULL, token, &resultObj); + if (resultObj != NULL) { + Tcl_SetObjResult(interp, resultObj); } break; } return TCL_OK; @@ -4573,68 +4937,84 @@ } else if (objc == 4) { /* * Produce list of all information. */ - Tcl_Obj *resultObj; - - TclNewObj(resultObj); - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(configOptions[CONF_MAP], -1)); - if (ensemblePtr->subcommandDict != NULL) { - Tcl_ListObjAppendElement(NULL, resultObj, - ensemblePtr->subcommandDict); - } else { - Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj()); - } - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(configOptions[CONF_NAMESPACE], -1)); - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1)); - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(configOptions[CONF_PREFIX], -1)); - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewBooleanObj(ensemblePtr->flags & ENS_PREFIX)); - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(configOptions[CONF_SUBCMDS], -1)); - if (ensemblePtr->subcmdList != NULL) { - Tcl_ListObjAppendElement(NULL, resultObj, - ensemblePtr->subcmdList); - } else { - Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj()); - } - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(configOptions[CONF_UNKNOWN], -1)); - if (ensemblePtr->unknownHandler != NULL) { - Tcl_ListObjAppendElement(NULL, resultObj, - ensemblePtr->unknownHandler); - } else { - Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj()); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; - + Tcl_Obj *resultObj, *tmpObj; + Tcl_Namespace *namespacePtr; + int flags; + + TclNewObj(resultObj); + + /* -map option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(configOptions[CONF_MAP], -1)); + Tcl_GetEnsembleMappingDict(NULL, token, &tmpObj); + if (tmpObj != NULL) { + Tcl_ListObjAppendElement(NULL, resultObj, tmpObj); + } else { + Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj()); + } + + /* -namespace option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(configOptions[CONF_NAMESPACE], -1)); + Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(((Namespace *)namespacePtr)->fullName, + -1)); + + /* -prefix option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(configOptions[CONF_PREFIX], -1)); + Tcl_GetEnsembleFlags(NULL, token, &flags); + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX)); + + /* -subcommands option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(configOptions[CONF_SUBCMDS], -1)); + Tcl_GetEnsembleSubcommandList(NULL, token, &tmpObj); + if (tmpObj != NULL) { + Tcl_ListObjAppendElement(NULL, resultObj, tmpObj); + } else { + Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj()); + } + + /* -unknown option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(configOptions[CONF_UNKNOWN], -1)); + Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj); + if (tmpObj != NULL) { + Tcl_ListObjAppendElement(NULL, resultObj, tmpObj); + } else { + Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj()); + } + + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; } else { Tcl_DictSearch search; Tcl_Obj *listObj; int done, len, allocatedMapFlag = 0; - /* - * Defaults - */ - Tcl_Obj *subcmdObj = ensemblePtr->subcmdList; - Tcl_Obj *mapObj = ensemblePtr->subcommandDict; - Tcl_Obj *unknownObj = ensemblePtr->unknownHandler; - int permitPrefix = ensemblePtr->flags & ENS_PREFIX; + Tcl_Obj *subcmdObj, *mapObj, *unknownObj; /* Defaults */ + int permitPrefix, flags; + + Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj); + Tcl_GetEnsembleMappingDict(NULL, token, &mapObj); + Tcl_GetEnsembleUnknownHandler(NULL, token, &unknownObj); + Tcl_GetEnsembleFlags(NULL, token, &flags); + permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0; objv += 4; objc -= 4; /* - * Parse the option list, applying type checks as we go. - * Note that we are not incrementing any reference counts - * in the objects at this stage, so the presence of an - * option multiple times won't cause any memory leaks. + * Parse the option list, applying type checks as we go. Note that + * we are not incrementing any reference counts in the objects at + * this stage, so the presence of an option multiple times won't + * cause any memory leaks. */ for (; objc>0 ; objc-=2,objv+=2 ) { if (Tcl_GetIndexFromObj(interp, objv[0], configOptions, "option", 0, &index) != TCL_OK) { @@ -4653,13 +5033,15 @@ } subcmdObj = (len > 0 ? objv[1] : NULL); continue; case CONF_MAP: { Tcl_Obj *patchedDict = NULL, *subcmdObj; + /* * Verify that the map is sensible. */ + if (Tcl_DictObjFirst(interp, objv[1], &search, &subcmdObj, &listObj, &done) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } @@ -4751,57 +5133,19 @@ continue; } } /* - * Update the namespace now that we've finished the - * parsing stage. - */ - - if (ensemblePtr->subcmdList != subcmdObj) { - if (ensemblePtr->subcmdList != NULL) { - Tcl_DecrRefCount(ensemblePtr->subcmdList); - } - ensemblePtr->subcmdList = subcmdObj; - if (subcmdObj != NULL) { - Tcl_IncrRefCount(subcmdObj); - } - } - if (ensemblePtr->subcommandDict != mapObj) { - if (ensemblePtr->subcommandDict != NULL) { - Tcl_DecrRefCount(ensemblePtr->subcommandDict); - } - ensemblePtr->subcommandDict = mapObj; - if (mapObj != NULL) { - Tcl_IncrRefCount(mapObj); - } - } - if (ensemblePtr->unknownHandler != unknownObj) { - if (ensemblePtr->unknownHandler != NULL) { - Tcl_DecrRefCount(ensemblePtr->unknownHandler); - } - ensemblePtr->unknownHandler = unknownObj; - if (unknownObj != NULL) { - Tcl_IncrRefCount(unknownObj); - } - } - if (permitPrefix) { - ensemblePtr->flags |= ENS_PREFIX; - } else { - ensemblePtr->flags &= ~ENS_PREFIX; - } - /* - * Trigger an eventual recomputation of the ensemble - * command set. Note that this is slightly tricky, as it - * means that we are not actually counting the number of - * namespace export actions, but it is the simplest way to - * go! Also note that this nsPtr and ensemblePtr->nsPtr - * are quite possibly not the same namespace; we want to - * bump the epoch for the ensemble's namespace, not the - * current namespace. - */ - ensemblePtr->nsPtr->exportLookupEpoch++; + * Update the namespace now that we've finished the parsing stage. + */ + + flags = (permitPrefix ? flags|TCL_ENSEMBLE_PREFIX + : flags&~TCL_ENSEMBLE_PREFIX); + Tcl_SetEnsembleSubcommandList(NULL, token, subcmdObj); + Tcl_SetEnsembleMappingDict(NULL, token, mapObj); + Tcl_SetEnsembleUnknownHandler(NULL, token, unknownObj); + Tcl_SetEnsembleFlags(NULL, token, flags); return TCL_OK; } default: Tcl_Panic("unexpected ensemble command"); @@ -4810,47 +5154,572 @@ } /* *---------------------------------------------------------------------- * - * FindEnsemble -- + * Tcl_CreateEnsemble -- + * + * Create a simple ensemble attached to the given namespace. + * + * Results: + * The token for the command created. + * + * Side effects: + * The ensemble is created and marked for compilation. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +Tcl_CreateEnsemble(interp, name, namespacePtr, flags) + Tcl_Interp *interp; + CONST char *name; + Tcl_Namespace *namespacePtr; + int flags; +{ + Namespace *nsPtr = (Namespace *) namespacePtr; + EnsembleConfig *ensemblePtr = + (EnsembleConfig *) ckalloc(sizeof(EnsembleConfig)); + Tcl_Obj *nameObj = NULL; + + if (nsPtr == NULL) { + nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + } + + /* + * Make the name of the ensemble into a fully qualified name. This might + * allocate a temporary object. + */ + + if (!(name[0] == ':' && name[1] == ':')) { + nameObj = Tcl_NewStringObj(nsPtr->fullName, -1); + if (nsPtr->parentPtr == NULL) { + Tcl_AppendStringsToObj(nameObj, name, NULL); + } else { + Tcl_AppendStringsToObj(nameObj, "::", name, NULL); + } + Tcl_IncrRefCount(nameObj); + name = TclGetString(nameObj); + } + + ensemblePtr->nsPtr = nsPtr; + ensemblePtr->epoch = 0; + Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS); + ensemblePtr->subcommandArrayPtr = NULL; + ensemblePtr->subcmdList = NULL; + ensemblePtr->subcommandDict = NULL; + ensemblePtr->flags = flags; + ensemblePtr->unknownHandler = NULL; + ensemblePtr->token = Tcl_CreateObjCommand(interp, name, + NsEnsembleImplementationCmd, (ClientData)ensemblePtr, + DeleteEnsembleConfig); + ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles; + nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr; + + /* + * Trigger an eventual recomputation of the ensemble command set. Note + * that this is slightly tricky, as it means that we are not actually + * counting the number of namespace export actions, but it is the simplest + * way to go! + */ + + nsPtr->exportLookupEpoch++; + + if (nameObj != NULL) { + TclDecrRefCount(nameObj); + } + return ensemblePtr->token; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetEnsembleSubcommandList -- + * + * Set the subcommand list for a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an ensemble + * or the subcommand list - if non-NULL - is not a list). + * + * Side effects: + * The ensemble is updated and marked for recompilation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetEnsembleSubcommandList(interp, token, subcmdList) + Tcl_Interp *interp; + Tcl_Command token; + Tcl_Obj *subcmdList; +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + Tcl_Obj *oldList; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + } + return TCL_ERROR; + } + if (subcmdList != NULL) { + int length; + if (Tcl_ListObjLength(interp, subcmdList, &length) != TCL_OK) { + return TCL_ERROR; + } + if (length < 1) { + subcmdList = NULL; + } + } + + ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; + oldList = ensemblePtr->subcmdList; + ensemblePtr->subcmdList = subcmdList; + if (subcmdList != NULL) { + Tcl_IncrRefCount(subcmdList); + } + if (oldList != NULL) { + TclDecrRefCount(oldList); + } + + /* + * Trigger an eventual recomputation of the ensemble command set. Note + * that this is slightly tricky, as it means that we are not actually + * counting the number of namespace export actions, but it is the simplest + * way to go! + */ + + ensemblePtr->nsPtr->exportLookupEpoch++; + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetEnsembleMappingDict -- + * + * Set the mapping dictionary for a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an ensemble + * or the mapping - if non-NULL - is not a dict). + * + * Side effects: + * The ensemble is updated and marked for recompilation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetEnsembleMappingDict(interp, token, mapDict) + Tcl_Interp *interp; + Tcl_Command token; + Tcl_Obj *mapDict; +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + Tcl_Obj *oldDict; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + } + return TCL_ERROR; + } + if (mapDict != NULL) { + int size; + if (Tcl_DictObjSize(interp, mapDict, &size) != TCL_OK) { + return TCL_ERROR; + } + if (size < 1) { + mapDict = NULL; + } + } + + ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; + oldDict = ensemblePtr->subcommandDict; + ensemblePtr->subcommandDict = mapDict; + if (mapDict != NULL) { + Tcl_IncrRefCount(mapDict); + } + if (oldDict != NULL) { + TclDecrRefCount(oldDict); + } + + /* + * Trigger an eventual recomputation of the ensemble command set. Note + * that this is slightly tricky, as it means that we are not actually + * counting the number of namespace export actions, but it is the simplest + * way to go! + */ + + ensemblePtr->nsPtr->exportLookupEpoch++; + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetEnsembleUnknownHandler -- + * + * Set the unknown handler for a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an ensemble + * or the unknown handler - if non-NULL - is not a list). + * + * Side effects: + * The ensemble is updated and marked for recompilation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetEnsembleUnknownHandler(interp, token, unknownList) + Tcl_Interp *interp; + Tcl_Command token; + Tcl_Obj *unknownList; +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + Tcl_Obj *oldList; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + } + return TCL_ERROR; + } + if (unknownList != NULL) { + int length; + + if (Tcl_ListObjLength(interp, unknownList, &length) != TCL_OK) { + return TCL_ERROR; + } + if (length < 1) { + unknownList = NULL; + } + } + + ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; + oldList = ensemblePtr->unknownHandler; + ensemblePtr->unknownHandler = unknownList; + if (unknownList != NULL) { + Tcl_IncrRefCount(unknownList); + } + if (oldList != NULL) { + TclDecrRefCount(oldList); + } + + /* + * Trigger an eventual recomputation of the ensemble command set. Note + * that this is slightly tricky, as it means that we are not actually + * counting the number of namespace export actions, but it is the simplest + * way to go! + */ + + ensemblePtr->nsPtr->exportLookupEpoch++; + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetEnsembleFlags -- + * + * Set the flags for a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an + * ensemble). + * + * Side effects: + * The ensemble is updated and marked for recompilation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetEnsembleFlags(interp, token, flags) + Tcl_Interp *interp; + Tcl_Command token; + int flags; +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + } + return TCL_ERROR; + } + + ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; + /* + * This API refuses to set the ENS_DEAD flag... + */ + ensemblePtr->flags &= ENS_DEAD; + ensemblePtr->flags |= flags & ~ENS_DEAD; + + /* + * Trigger an eventual recomputation of the ensemble command set. Note + * that this is slightly tricky, as it means that we are not actually + * counting the number of namespace export actions, but it is the simplest + * way to go! + */ + + ensemblePtr->nsPtr->exportLookupEpoch++; + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetEnsembleSubcommandList -- + * + * Get the list of subcommands associated with a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an + * ensemble). The list of subcommands is returned by updating the + * variable pointed to by the last parameter (NULL if this is to be + * derived from the mapping dictionary or the associated namespace's + * exported commands). + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetEnsembleSubcommandList(interp, token, subcmdListPtr) + Tcl_Interp *interp; + Tcl_Command token; + Tcl_Obj **subcmdListPtr; +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + } + return TCL_ERROR; + } + + ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; + *subcmdListPtr = ensemblePtr->subcmdList; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetEnsembleMappingDict -- + * + * Get the command mapping dictionary associated with a particular + * ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an + * ensemble). The mapping dict is returned by updating the variable + * pointed to by the last parameter (NULL if none is installed). + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetEnsembleMappingDict(interp, token, mapDictPtr) + Tcl_Interp *interp; + Tcl_Command token; + Tcl_Obj **mapDictPtr; +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + } + return TCL_ERROR; + } + + ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; + *mapDictPtr = ensemblePtr->subcommandDict; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetEnsembleUnknownHandler -- + * + * Get the unknown handler associated with a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an + * ensemble). The unknown handler is returned by updating the variable + * pointed to by the last parameter (NULL if no handler is installed). + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetEnsembleUnknownHandler(interp, token, unknownListPtr) + Tcl_Interp *interp; + Tcl_Command token; + Tcl_Obj **unknownListPtr; +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + } + return TCL_ERROR; + } + + ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; + *unknownListPtr = ensemblePtr->unknownHandler; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetEnsembleFlags -- + * + * Get the flags for a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an + * ensemble). The flags are returned by updating the variable pointed to + * by the last parameter. + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetEnsembleFlags(interp, token, flagsPtr) + Tcl_Interp *interp; + Tcl_Command token; + int *flagsPtr; +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + } + return TCL_ERROR; + } + + ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; + *flagsPtr = ensemblePtr->flags; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetEnsembleNamespace -- + * + * Get the namespace associated with a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an + * ensemble). Namespace is returned by updating the variable pointed to + * by the last parameter. + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetEnsembleNamespace(interp, token, namespacePtrPtr) + Tcl_Interp *interp; + Tcl_Command token; + Tcl_Namespace **namespacePtrPtr; +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + } + return TCL_ERROR; + } + + ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; + *namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FindEnsemble -- * - * Given a command name, get the ensemble configuration structure - * for it, allowing for [namespace import]s. [Bug 1017022] + * Given a command name, get the ensemble token for it, allowing for + * [namespace import]s. [Bug 1017022] * * Results: - * A pointer to the config struct, or NULL if the command either - * does not exist or is not an ensemble. + * The token for the ensemble command with the given name, or NULL if the + * command either does not exist or is not an ensemble (when an error + * message will be written into the interp if thats non-NULL). * * Side effects: * None * *---------------------------------------------------------------------- */ -static EnsembleConfig * -FindEnsemble(interp, cmdNameObj, flags) - Tcl_Interp *interp; /* Where to do the lookup, and where - * to write the errors if - * TCL_LEAVE_ERR_MSG is set in the - * flags. */ - Tcl_Obj *cmdNameObj; /* Name of command to look up. */ - int flags; /* Either 0 or TCL_LEAVE_ERR_MSG; other - * flags are probably not useful. */ +Tcl_Command +Tcl_FindEnsemble(interp, cmdNameObj, flags) + Tcl_Interp *interp; /* Where to do the lookup, and where to write + * the errors if TCL_LEAVE_ERR_MSG is set in + * the flags. */ + Tcl_Obj *cmdNameObj; /* Name of command to look up. */ + int flags; /* Either 0 or TCL_LEAVE_ERR_MSG; other flags + * are probably not useful. */ { Command *cmdPtr; cmdPtr = (Command *) Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags); if (cmdPtr == NULL) { return NULL; } + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { /* - * Reuse existing infrastructure for following import link - * chains rather than duplicating it. + * Reuse existing infrastructure for following import link chains + * rather than duplicating it. */ + cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) { if (flags & TCL_LEAVE_ERR_MSG) { Tcl_AppendResult(interp, "\"", TclGetString(cmdNameObj), @@ -4857,17 +5726,18 @@ "\" is not an ensemble command", NULL); } return NULL; } } - return (EnsembleConfig *) cmdPtr->objClientData; + + return (Tcl_Command) cmdPtr; } /* *---------------------------------------------------------------------- * - * TclIsEnsemble -- + * Tcl_IsEnsemble -- * * Simple test for ensemble-hood that takes into account imported * ensemble commands as well. * * Results: @@ -4878,13 +5748,14 @@ * *---------------------------------------------------------------------- */ int -TclIsEnsemble(cmdPtr) - Command *cmdPtr; +Tcl_IsEnsemble(token) + Tcl_Command token; { + Command *cmdPtr = (Command *) token; if (cmdPtr->objProc == NsEnsembleImplementationCmd) { return 1; } cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) { @@ -4897,22 +5768,22 @@ *---------------------------------------------------------------------- * * NsEnsembleImplementationCmd -- * * Implements an ensemble of commands (being those exported by a - * namespace other than the global namespace) as a command with - * the same (short) name as the namespace in the parent namespace. + * namespace other than the global namespace) as a command with the same + * (short) name as the namespace in the parent namespace. * * Results: - * A standard Tcl result code. Will be TCL_ERROR if the command - * is not an unambiguous prefix of any command exported by the - * ensemble's namespace. + * A standard Tcl result code. Will be TCL_ERROR if the command is not an + * unambiguous prefix of any command exported by the ensemble's + * namespace. * * Side effects: - * Depends on the command within the namespace that gets executed. - * If the ensemble itself returns TCL_ERROR, a descriptive error - * message will be placed in the interpreter's result. + * Depends on the command within the namespace that gets executed. If the + * ensemble itself returns TCL_ERROR, a descriptive error message will be + * placed in the interpreter's result. * *---------------------------------------------------------------------- */ static int @@ -4921,27 +5792,25 @@ Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { EnsembleConfig *ensemblePtr = (EnsembleConfig *) clientData; - /* The ensemble itself. */ - Tcl_Obj **tempObjv; /* Space used to construct the list of - * arguments to pass to the command - * that implements the ensemble - * subcommand. */ - int result; /* The result of the subcommand - * execution. */ - Tcl_Obj *prefixObj; /* An object containing the prefix - * words of the command that implements - * the subcommand. */ - Tcl_HashEntry *hPtr; /* Used for efficient lookup of fully - * specified but not yet cached command - * names. */ - Tcl_Obj **prefixObjv; /* The list of objects to substitute in - * as the target command prefix. */ - int prefixObjc; /* Size of prefixObjv of course! */ - int reparseCount = 0; /* Number of reparses. */ + /* The ensemble itself. */ + Tcl_Obj **tempObjv; /* Space used to construct the list of + * arguments to pass to the command that + * implements the ensemble subcommand. */ + int result; /* The result of the subcommand execution. */ + Tcl_Obj *prefixObj; /* An object containing the prefix words of + * the command that implements the + * subcommand. */ + Tcl_HashEntry *hPtr; /* Used for efficient lookup of fully + * specified but not yet cached command + * names. */ + Tcl_Obj **prefixObjv; /* The list of objects to substitute in as the + * target command prefix. */ + int prefixObjc; /* Size of prefixObjv of course! */ + int reparseCount = 0; /* Number of reparses. */ if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument ...?"); return TCL_ERROR; } @@ -4949,10 +5818,11 @@ restartEnsembleParse: if (ensemblePtr->nsPtr->flags & NS_DEAD) { /* * Don't know how we got here, but make things give up quickly. */ + if (!Tcl_InterpDeleted(interp)) { Tcl_AppendResult(interp, "ensemble activated for deleted namespace", NULL); } return TCL_ERROR; @@ -4961,18 +5831,17 @@ if (ensemblePtr->epoch != ensemblePtr->nsPtr->exportLookupEpoch) { ensemblePtr->epoch = ensemblePtr->nsPtr->exportLookupEpoch; BuildEnsembleConfig(ensemblePtr); } else { /* - * Table of subcommands is still valid; therefore there might - * be a valid cache of discovered information which we can - * reuse. Do the check here, and if we're still valid, we can - * jump straight to the part where we do the invocation of the - * subcommand. + * Table of subcommands is still valid; therefore there might be a + * valid cache of discovered information which we can reuse. Do the + * check here, and if we're still valid, we can jump straight to the + * part where we do the invocation of the subcommand. */ - if (objv[1]->typePtr == &tclEnsembleCmdType) { + if (objv[1]->typePtr == &ensembleCmdType) { EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *) objv[1]->internalRep.otherValuePtr; if (ensembleCmd->nsPtr == ensemblePtr->nsPtr && ensembleCmd->epoch == ensemblePtr->epoch && ensembleCmd->token == ensemblePtr->token) { @@ -4982,12 +5851,12 @@ } } } /* - * Look in the hashtable for the subcommand name; this is the - * fastest way of all. + * Look in the hashtable for the subcommand name; this is the fastest way + * of all. */ hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, TclGetString(objv[1])); if (hPtr != NULL) { @@ -4997,60 +5866,63 @@ /* * Cache for later in the subcommand object. */ MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj); - } else if (!(ensemblePtr->flags & ENS_PREFIX)) { + } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) { /* * Can't find and we are prohibited from using unambiguous prefixes. */ + goto unknownOrAmbiguousSubcommand; } else { /* - * If we've not already confirmed the command with the hash as - * part of building our export table, we need to scan the - * sorted array for matches. + * If we've not already confirmed the command with the hash as part of + * building our export table, we need to scan the sorted array for + * matches. */ - char *subcmdName; /* Name of the subcommand, or unique - * prefix of it (will be an error for - * a non-unique prefix). */ - char *fullName = NULL; /* Full name of the subcommand. */ + char *subcmdName; /* Name of the subcommand, or unique prefix of + * it (will be an error for a non-unique + * prefix). */ + char *fullName = NULL; /* Full name of the subcommand. */ int stringLength, i; int tableLength = ensemblePtr->subcommandTable.numEntries; subcmdName = TclGetString(objv[1]); stringLength = objv[1]->length; for (i=0 ; isubcommandArrayPtr[i], - (unsigned)stringLength); + (unsigned) stringLength); if (cmp == 0) { if (fullName != NULL) { /* - * Since there's never the exact-match case to - * worry about (hash search filters this), getting - * here indicates that our subcommand is an - * ambiguous prefix of (at least) two exported - * subcommands, which is an error case. + * Since there's never the exact-match case to worry about + * (hash search filters this), getting here indicates that + * our subcommand is an ambiguous prefix of (at least) two + * exported subcommands, which is an error case. */ + goto unknownOrAmbiguousSubcommand; } fullName = ensemblePtr->subcommandArrayPtr[i]; } else if (cmp < 0) { /* - * Because we are searching a sorted table, we can now - * stop searching because we have gone past anything - * that could possibly match. + * Because we are searching a sorted table, we can now stop + * searching because we have gone past anything that could + * possibly match. */ + break; } } if (fullName == NULL) { /* * The subcommand is not a prefix of anything, so bail out! */ + goto unknownOrAmbiguousSubcommand; } hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, fullName); if (hPtr == NULL) { Tcl_Panic("full name %s not found in supposedly synchronized hash", @@ -5064,18 +5936,17 @@ MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj); } /* - * Do the real work of execution of the subcommand by building an - * array of objects (note that this is potentially not the same - * length as the number of arguments to this ensemble command), - * populating it and then feeding it back through the main - * command-lookup engine. In theory, we could look up the command - * in the namespace ourselves, as we already have the namespace in - * which it is guaranteed to exist, but we don't do that (the - * cacheing of the command object used should help with that.) + * Do the real work of execution of the subcommand by building an array of + * objects (note that this is potentially not the same length as the + * number of arguments to this ensemble command), populating it and then + * feeding it back through the main command-lookup engine. In theory, we + * could look up the command in the namespace ourselves, as we already + * have the namespace in which it is guaranteed to exist, but we don't do + * that (the cacheing of the command object used should help with that.) */ Tcl_IncrRefCount(prefixObj); runResultingSubcommand: { @@ -5111,14 +5982,14 @@ return result; } unknownOrAmbiguousSubcommand: /* - * Have not been able to match the subcommand asked for with a - * real subcommand that we export. See whether a handler has been - * registered for dealing with this situation. Will only call (at - * most) once for any particular ensemble invocation. + * Have not been able to match the subcommand asked for with a real + * subcommand that we export. See whether a handler has been registered + * for dealing with this situation. Will only call (at most) once for any + * particular ensemble invocation. */ if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) { int paramc, i; Tcl_Obj **paramv, *unknownCmd, *ensObj; @@ -5147,13 +6018,13 @@ TCL_STATIC); return TCL_ERROR; } /* - * Namespace is still there. Check if the result is a - * valid list. If it is, and it is non-empty, that list - * is what we are using as our replacement. + * Namespace is still there. Check if the result is a valid list. + * If it is, and it is non-empty, that list is what we are using + * as our replacement. */ if (Tcl_ListObjLength(interp, prefixObj, &prefixObjc) != TCL_OK) { Tcl_DecrRefCount(prefixObj); Tcl_AddErrorInfo(interp, @@ -5187,10 +6058,11 @@ case TCL_CONTINUE: Tcl_AppendResult(interp, "continue", NULL); break; default: { char buf[TCL_INTEGER_SPACE]; + sprintf(buf, "%d", result); Tcl_AppendResult(interp, buf, NULL); } } Tcl_AddErrorInfo(interp, @@ -5206,24 +6078,24 @@ return TCL_ERROR; } /* * Cannot determine what subcommand to hand off to, so generate a - * (standard) failure message. Note the one odd case compared - * with standard ensemble-like command, which is where a namespace - * has no exported commands at all... + * (standard) failure message. Note the one odd case compared with + * standard ensemble-like command, which is where a namespace has no + * exported commands at all... */ Tcl_ResetResult(interp); if (ensemblePtr->subcommandTable.numEntries == 0) { - Tcl_AppendResult(interp, "unknown subcommand \"", TclGetString(objv[1]), + Tcl_AppendResult(interp, "unknown subcommand \"",TclGetString(objv[1]), "\": namespace ", ensemblePtr->nsPtr->fullName, " does not export any commands", NULL); return TCL_ERROR; } Tcl_AppendResult(interp, "unknown ", - (ensemblePtr->flags & ENS_PREFIX ? "or ambiguous " : ""), + (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? "or ambiguous " : ""), "subcommand \"", TclGetString(objv[1]), "\": must be ", NULL); if (ensemblePtr->subcommandTable.numEntries == 1) { Tcl_AppendResult(interp, ensemblePtr->subcommandArrayPtr[0], NULL); } else { int i; @@ -5240,15 +6112,14 @@ /* *---------------------------------------------------------------------- * * MakeCachedEnsembleCommand -- * - * Cache what we've computed so far; it's not nice to repeatedly - * copy strings about. Note that to do this, we start by - * deleting any old representation that there was (though if it - * was an out of date ensemble rep, we can skip some of the - * deallocation process.) + * Cache what we've computed so far; it's not nice to repeatedly copy + * strings about. Note that to do this, we start by deleting any old + * representation that there was (though if it was an out of date + * ensemble rep, we can skip some of the deallocation process.) * * Results: * None * * Side effects: @@ -5264,11 +6135,11 @@ Tcl_Obj *prefixObjPtr; { register EnsembleCmdRep *ensembleCmd; int length; - if (objPtr->typePtr == &tclEnsembleCmdType) { + if (objPtr->typePtr == &ensembleCmdType) { ensembleCmd = (EnsembleCmdRep *) objPtr->internalRep.otherValuePtr; Tcl_DecrRefCount(ensembleCmd->realPrefixObj); ensembleCmd->nsPtr->refCount--; if ((ensembleCmd->nsPtr->refCount == 0) && (ensembleCmd->nsPtr->flags & NS_DEAD)) { @@ -5275,22 +6146,24 @@ NamespaceFree(ensembleCmd->nsPtr); } ckfree(ensembleCmd->fullSubcmdName); } else { /* - * Kill the old internal rep, and replace it with a brand new - * one of our own. + * Kill the old internal rep, and replace it with a brand new one of + * our own. */ + TclFreeIntRep(objPtr); ensembleCmd = (EnsembleCmdRep *) ckalloc(sizeof(EnsembleCmdRep)); objPtr->internalRep.otherValuePtr = (VOID *) ensembleCmd; - objPtr->typePtr = &tclEnsembleCmdType; + objPtr->typePtr = &ensembleCmdType; } /* * Populate the internal rep. */ + ensembleCmd->nsPtr = ensemblePtr->nsPtr; ensembleCmd->epoch = ensemblePtr->epoch; ensembleCmd->token = ensemblePtr->token; ensemblePtr->nsPtr->refCount++; ensembleCmd->realPrefixObj = prefixObjPtr; @@ -5303,15 +6176,15 @@ /* *---------------------------------------------------------------------- * * DeleteEnsembleConfig -- * - * Destroys the data structure used to represent an ensemble. - * This is called when the ensemble's command is deleted (which - * happens automatically if the ensemble's namespace is deleted.) - * Maintainers should note that ensembles should be deleted by - * deleting their commands. + * Destroys the data structure used to represent an ensemble. This is + * called when the ensemble's command is deleted (which happens + * automatically if the ensemble's namespace is deleted.) Maintainers + * should note that ensembles should be deleted by deleting their + * commands. * * Results: * None. * * Side effects: @@ -5328,12 +6201,12 @@ Namespace *nsPtr = ensemblePtr->nsPtr; Tcl_HashSearch search; Tcl_HashEntry *hEnt; /* - * Unlink from the ensemble chain if it has not been marked as - * having been done already. + * Unlink from the ensemble chain if it has not been marked as having been + * done already. */ if (ensemblePtr->next != ensemblePtr) { EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles; if (ensPtr == ensemblePtr) { @@ -5348,12 +6221,12 @@ } } } /* - * Mark the namespace as dead so code that uses Tcl_Preserve() can - * tell whether disaster happened anyway. + * Mark the namespace as dead so code that uses Tcl_Preserve() can tell + * whether disaster happened anyway. */ ensemblePtr->flags |= ENS_DEAD; /* @@ -5379,56 +6252,57 @@ if (ensemblePtr->unknownHandler != NULL) { Tcl_DecrRefCount(ensemblePtr->unknownHandler); } /* - * Arrange for the structure to be reclaimed. Note that this is - * complex because we have to make sure that we can react sensibly - * when an ensemble is deleted during the process of initialising - * the ensemble (especially the unknown callback.) + * Arrange for the structure to be reclaimed. Note that this is complex + * because we have to make sure that we can react sensibly when an + * ensemble is deleted during the process of initialising the ensemble + * (especially the unknown callback.) */ Tcl_EventuallyFree((ClientData) ensemblePtr, TCL_DYNAMIC); } /* *---------------------------------------------------------------------- * - * BuildEnsembleConfig -- + * BuildEnsembleConfig -- * - * Create the internal data structures that describe how an - * ensemble looks, being a hash mapping from the full command - * name to the Tcl list that describes the implementation prefix - * words, and a sorted array of all the full command names to - * allow for reasonably efficient unambiguous prefix handling. + * Create the internal data structures that describe how an ensemble + * looks, being a hash mapping from the full command name to the Tcl list + * that describes the implementation prefix words, and a sorted array of + * all the full command names to allow for reasonably efficient + * unambiguous prefix handling. * * Results: * None. * * Side effects: - * Reallocates and rebuilds the hash table and array stored at - * the ensemblePtr argument. For large ensembles or large - * namespaces, this is a potentially expensive operation. + * Reallocates and rebuilds the hash table and array stored at the + * ensemblePtr argument. For large ensembles or large namespaces, this is + * a potentially expensive operation. * *---------------------------------------------------------------------- */ static void BuildEnsembleConfig(ensemblePtr) EnsembleConfig *ensemblePtr; { - Tcl_HashSearch search; /* Used for scanning the set of - * commands in the namespace that - * backs up this ensemble. */ + Tcl_HashSearch search; /* Used for scanning the set of commands in + * the namespace that backs up this + * ensemble. */ int i, j, isNew; Tcl_HashTable *hash = &ensemblePtr->subcommandTable; Tcl_HashEntry *hPtr; if (hash->numEntries != 0) { /* * Remove pre-existing table. */ + Tcl_HashSearch search; ckfree((char *)ensemblePtr->subcommandArrayPtr); hPtr = Tcl_FirstHashEntry(hash, &search); while (hPtr != NULL) { @@ -5439,14 +6313,13 @@ Tcl_DeleteHashTable(hash); Tcl_InitHashTable(hash, TCL_STRING_KEYS); } /* - * See if we've got an export list. If so, we will only export - * exactly those commands, which may be either implemented by the - * prefix in the subcommandDict or mapped directly onto the - * namespace's commands. + * See if we've got an export list. If so, we will only export exactly + * those commands, which may be either implemented by the prefix in the + * subcommandDict or mapped directly onto the namespace's commands. */ if (ensemblePtr->subcmdList != NULL) { Tcl_Obj **subcmdv, *target, *cmdObj, *cmdPrefixObj; int subcmdc; @@ -5460,28 +6333,31 @@ /* Skip non-unique cases. */ if (!isNew) { continue; } + /* * Look in our dictionary (if present) for the command. */ + if (ensemblePtr->subcommandDict != NULL) { Tcl_DictObjGet(NULL, ensemblePtr->subcommandDict, subcmdv[i], &target); if (target != NULL) { Tcl_SetHashValue(hPtr, (ClientData) target); Tcl_IncrRefCount(target); continue; } } + /* - * Not there, so map onto the namespace. Note in this - * case that we do not guarantee that the command is - * actually there; that is the programmer's responsibility - * (or [::unknown] of course). + * Not there, so map onto the namespace. Note in this case that we + * do not guarantee that the command is actually there; that is + * the programmer's responsibility (or [::unknown] of course). */ + cmdObj = Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1); if (ensemblePtr->nsPtr->parentPtr != NULL) { Tcl_AppendStringsToObj(cmdObj, "::", name, NULL); } else { Tcl_AppendStringsToObj(cmdObj, name, NULL); @@ -5490,43 +6366,43 @@ Tcl_SetHashValue(hPtr, (ClientData) cmdPrefixObj); Tcl_IncrRefCount(cmdPrefixObj); } } else if (ensemblePtr->subcommandDict != NULL) { /* - * No subcmd list, but we do have a mapping dictionary so we - * should use the keys of that. Convert the dictionary's - * contents into the form required for the ensemble's internal - * hashtable. + * No subcmd list, but we do have a mapping dictionary so we should + * use the keys of that. Convert the dictionary's contents into the + * form required for the ensemble's internal hashtable. */ + Tcl_DictSearch dictSearch; Tcl_Obj *keyObj, *valueObj; int done; Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch, &keyObj, &valueObj, &done); while (!done) { char *name = TclGetString(keyObj); + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); Tcl_SetHashValue(hPtr, (ClientData) valueObj); Tcl_IncrRefCount(valueObj); Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done); } } else { /* - * Discover what commands are actually exported by the - * namespace. What we have is an array of patterns and a hash - * table whose keys are the command names exported by the - * namespace (the contents do not matter here.) We must find - * out what commands are actually exported by filtering each - * command in the namespace against each of the patterns in - * the export list. Note that we use an intermediate hash - * table to make memory management easier, and because that - * makes exact matching far easier too. - * - * Suggestion for future enhancement: compute the unique - * prefixes and place them in the hash too, which should make - * for even faster matching. + * Discover what commands are actually exported by the namespace. + * What we have is an array of patterns and a hash table whose keys + * are the command names exported by the namespace (the contents do + * not matter here.) We must find out what commands are actually + * exported by filtering each command in the namespace against each of + * the patterns in the export list. Note that we use an intermediate + * hash table to make memory management easier, and because that makes + * exact matching far easier too. + * + * Suggestion for future enhancement: compute the unique prefixes and + * place them in the hash too, which should make for even faster + * matching. */ hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search); for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) { char *nsCmdName = /* Name of command in namespace. */ @@ -5536,13 +6412,13 @@ if (Tcl_StringMatch(nsCmdName, ensemblePtr->nsPtr->exportArrayPtr[i])) { hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew); /* - * Remember, hash entries have a full reference to - * the substituted part of the command (as a list) - * as their content! + * Remember, hash entries have a full reference to the + * substituted part of the command (as a list) as their + * content! */ if (isNew) { Tcl_Obj *cmdObj, *cmdPrefixObj; @@ -5565,44 +6441,40 @@ ensemblePtr->subcommandArrayPtr = NULL; return; } /* - * Create a sorted array of all subcommands in the ensemble; hash - * tables are all very well for a quick look for an exact match, - * but they can't determine things like whether a string is a - * prefix of another (not without lots of preparation anyway) and - * they're no good for when we're generating the error message - * either. - * - * We do this by filling an array with the names (we use the hash - * keys directly to save a copy, since any time we change the - * array we change the hash too, and vice versa) and running - * quicksort over the array. + * Create a sorted array of all subcommands in the ensemble; hash tables + * are all very well for a quick look for an exact match, but they can't + * determine things like whether a string is a prefix of another (not + * without lots of preparation anyway) and they're no good for when we're + * generating the error message either. + * + * We do this by filling an array with the names (we use the hash keys + * directly to save a copy, since any time we change the array we change + * the hash too, and vice versa) and running quicksort over the array. */ ensemblePtr->subcommandArrayPtr = (char **) ckalloc(sizeof(char *) * hash->numEntries); /* - * Fill array from both ends as this makes us less likely to end - * up with performance problems in qsort(), which is good. Note - * that doing this makes this code much more opaque, but the naive - * alternatve: - * - * for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ; - * hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search),i++) { - * ensemblePtr->subcommandArrayPtr[i] = - * Tcl_GetHashKey(hash, &hPtr); + * Fill array from both ends as this makes us less likely to end up with + * performance problems in qsort(), which is good. Note that doing this + * makes this code much more opaque, but the naive alternatve: + * + * for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ; + * hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search),i++) { + * ensemblePtr->subcommandArrayPtr[i] = Tcl_GetHashKey(hash, &hPtr); * } * - * can produce long runs of precisely ordered table entries when - * the commands in the namespace are declared in a sorted fashion - * (an ordering some people like) and the hashing functions (or - * the command names themselves) are fairly unfortunate. By - * filling from both ends, it requires active malice (and probably - * a debugger) to get qsort() to have awful runtime behaviour. + * can produce long runs of precisely ordered table entries when the + * commands in the namespace are declared in a sorted fashion (an ordering + * some people like) and the hashing functions (or the command names + * themselves) are fairly unfortunate. By filling from both ends, it + * requires active malice (and probably a debugger) to get qsort() to have + * awful runtime behaviour. */ i = 0; j = hash->numEntries; hPtr = Tcl_FirstHashEntry(hash, &search); @@ -5624,16 +6496,16 @@ /* *---------------------------------------------------------------------- * * NsEnsembleStringOrder -- * - * Helper function to compare two pointers to two strings for use - * with qsort(). + * Helper function to compare two pointers to two strings for use with + * qsort(). * * Results: - * -1 if the first string is smaller, 1 if the second string is - * smaller, and 0 if they are equal. + * -1 if the first string is smaller, 1 if the second string is smaller, + * and 0 if they are equal. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -5656,11 +6528,11 @@ * * Results: * None. * * Side effects: - * Memory is deallocated. If this held the last reference to a + * Memory is deallocated. If this held the last reference to a * namespace's main structure, that main structure will also be * destroyed. * *---------------------------------------------------------------------- */ @@ -5685,19 +6557,19 @@ /* *---------------------------------------------------------------------- * * DupEnsembleCmdRep -- * - * Makes one Tcl_Obj into a copy of another that is a subcommand - * of an ensemble. + * Makes one Tcl_Obj into a copy of another that is a subcommand of an + * ensemble. * * Results: * None. * * Side effects: - * Memory is allocated, and the namespace that the ensemble is - * built on top of gains another reference. + * Memory is allocated, and the namespace that the ensemble is built on + * top of gains another reference. * *---------------------------------------------------------------------- */ static void @@ -5708,11 +6580,11 @@ objPtr->internalRep.otherValuePtr; EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *) ckalloc(sizeof(EnsembleCmdRep)); int length = strlen(ensembleCmd->fullSubcmdName); - copyPtr->typePtr = &tclEnsembleCmdType; + copyPtr->typePtr = &ensembleCmdType; copyPtr->internalRep.otherValuePtr = (VOID *) ensembleCopy; ensembleCopy->nsPtr = ensembleCmd->nsPtr; ensembleCopy->epoch = ensembleCmd->epoch; ensembleCopy->token = ensembleCmd->token; ensembleCopy->nsPtr->refCount++; @@ -5726,12 +6598,12 @@ /* *---------------------------------------------------------------------- * * StringOfEnsembleCmdRep -- * - * Creates a string representation of a Tcl_Obj that holds a - * subcommand of an ensemble. + * Creates a string representation of a Tcl_Obj that holds a subcommand + * of an ensemble. * * Results: * None. * * Side effects: @@ -5750,5 +6622,13 @@ objPtr->length = length; objPtr->bytes = ckalloc((unsigned) length+1); memcpy(objPtr->bytes, ensembleCmd->fullSubcmdName, (unsigned) length+1); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclNotify.c ================================================================== --- generic/tclNotify.c +++ generic/tclNotify.c @@ -1,31 +1,31 @@ -/* +/* * tclNotify.c -- * - * This file implements the generic portion of the Tcl notifier. - * The notifier is lowest-level part of the event system. It - * manages an event queue that holds Tcl_Event structures. The - * platform specific portion of the notifier is defined in the - * tcl*Notify.c files in each platform directory. + * This file implements the generic portion of the Tcl notifier. The + * notifier is lowest-level part of the event system. It manages an event + * queue that holds Tcl_Event structures. The platform specific portion + * of the notifier is defined in the tcl*Notify.c files in each platform + * directory. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1998 by Scriptics Corporation. * Copyright (c) 2003 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. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclNotify.c,v 1.16 2004/11/30 19:34:49 dgp Exp $ + * RCS: @(#) $Id: tclNotify.c,v 1.16.2.2 2005/08/02 18:16:02 dgp Exp $ */ #include "tclInt.h" extern TclStubs tclStubs; /* - * For each event source (created with Tcl_CreateEventSource) there - * is a structure of the following type: + * For each event source (created with Tcl_CreateEventSource) there is a + * structure of the following type: */ typedef struct EventSource { Tcl_EventSetupProc *setupProc; Tcl_EventCheckProc *checkProc; @@ -34,53 +34,54 @@ } EventSource; /* * The following structure keeps track of the state of the notifier on a * per-thread basis. The first three elements keep track of the event queue. - * In addition to the first (next to be serviced) and last events in the queue, - * we keep track of a "marker" event. This provides a simple priority + * In addition to the first (next to be serviced) and last events in the + * queue, we keep track of a "marker" event. This provides a simple priority * mechanism whereby events can be inserted at the front of the queue but - * behind all other high-priority events already in the queue (this is used for - * things like a sequence of Enter and Leave events generated during a grab in - * Tk). These elements are protected by the queueMutex so that any thread - * can queue an event on any notifier. Note that all of the values in this - * structure will be initialized to 0. + * behind all other high-priority events already in the queue (this is used + * for things like a sequence of Enter and Leave events generated during a + * grab in Tk). These elements are protected by the queueMutex so that any + * thread can queue an event on any notifier. Note that all of the values in + * this structure will be initialized to 0. */ typedef struct ThreadSpecificData { Tcl_Event *firstEventPtr; /* First pending event, or NULL if none. */ Tcl_Event *lastEventPtr; /* Last pending event, or NULL if none. */ - Tcl_Event *markerEventPtr; /* Last high-priority event in queue, or - * NULL if none. */ + Tcl_Event *markerEventPtr; /* Last high-priority event in queue, or NULL + * if none. */ Tcl_Mutex queueMutex; /* Mutex to protect access to the previous * three fields. */ int serviceMode; /* One of TCL_SERVICE_NONE or * TCL_SERVICE_ALL. */ - int blockTimeSet; /* 0 means there is no maximum block - * time: block forever. */ - Tcl_Time blockTime; /* If blockTimeSet is 1, gives the - * maximum elapsed time for the next block. */ - int inTraversal; /* 1 if Tcl_SetMaxBlockTime is being - * called during an event source traversal. */ + int blockTimeSet; /* 0 means there is no maximum block time: + * block forever. */ + Tcl_Time blockTime; /* If blockTimeSet is 1, gives the maximum + * elapsed time for the next block. */ + int inTraversal; /* 1 if Tcl_SetMaxBlockTime is being called + * during an event source traversal. */ EventSource *firstEventSourcePtr; - /* Pointer to first event source in - * list of event sources for this thread. */ + /* Pointer to first event source in list of + * event sources for this thread. */ Tcl_ThreadId threadId; /* Thread that owns this notifier instance. */ ClientData clientData; /* Opaque handle for platform specific * notifier. */ + int initialized; /* 1 if notifier has been initialized. */ struct ThreadSpecificData *nextPtr; /* Next notifier in global list of notifiers. * Access is controlled by the listLock global * mutex. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* - * Global list of notifiers. Access to this list is controlled by the - * listLock mutex. If this becomes a performance bottleneck, this could - * be replaced with a hashtable. + * Global list of notifiers. Access to this list is controlled by the listLock + * mutex. If this becomes a performance bottleneck, this could be replaced + * with a hashtable. */ static ThreadSpecificData *firstNotifierPtr = NULL; TCL_DECLARE_MUTEX(listLock) @@ -114,18 +115,23 @@ ThreadSpecificData *tsdPtr; Tcl_ThreadId threadId = Tcl_GetCurrentThread(); Tcl_MutexLock(&listLock); for (tsdPtr = firstNotifierPtr; tsdPtr && tsdPtr->threadId != threadId; - tsdPtr = tsdPtr->nextPtr) { + tsdPtr = tsdPtr->nextPtr) { /* Empty loop body. */ } + if (NULL == tsdPtr) { - /* Notifier not yet initialized in this thread */ + /* + * Notifier not yet initialized in this thread. + */ + tsdPtr = TCL_TSD_INIT(&dataKey); tsdPtr->threadId = threadId; tsdPtr->clientData = tclStubs.tcl_InitNotifier(); + tsdPtr->initialized = 1; tsdPtr->nextPtr = firstNotifierPtr; firstNotifierPtr = tsdPtr; } Tcl_MutexUnlock(&listLock); } @@ -133,27 +139,26 @@ /* *---------------------------------------------------------------------- * * TclFinalizeNotifier -- * - * Finalize the thread local data structures for the notifier - * subsystem. + * Finalize the thread local data structures for the notifier subsystem. * * Results: - * None. + * None. * * Side effects: - * Removes the notifier associated with the current thread from - * the global notifier list. This is done only if the notifier - * was initialized for this thread by call to TclInitNotifier(). - * This is always true for threads which have been seeded with - * an Tcl interpreter, since the call to Tcl_CreateInterp will, - * among other things, call TclInitializeSubsystems() and this - * one will, in turn, call the TclInitNotifier() for the thread. - * For threads created without the Tcl interpreter, though, - * nobody is explicitly nor implicitly calling the TclInitNotifier - * hence, TclFinalizeNotifier should not be performed at all. + * Removes the notifier associated with the current thread from the + * global notifier list. This is done only if the notifier was + * initialized for this thread by call to TclInitNotifier(). This is + * always true for threads which have been seeded with an Tcl + * interpreter, since the call to Tcl_CreateInterp will, among other + * things, call TclInitializeSubsystems() and this one will, in turn, + * call the TclInitNotifier() for the thread. For threads created without + * the Tcl interpreter, though, nobody is explicitly nor implicitly + * calling the TclInitNotifier hence, TclFinalizeNotifier should not be + * performed at all. * *---------------------------------------------------------------------- */ void @@ -161,12 +166,12 @@ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); ThreadSpecificData **prevPtrPtr; Tcl_Event *evPtr, *hold; - if (tsdPtr->threadId == (Tcl_ThreadId)0) { - return; /* Notifier not initialized for the current thread */ + if (!tsdPtr->initialized) { + return; /* Notifier not initialized for the current thread */ } Tcl_MutexLock(&(tsdPtr->queueMutex)); for (evPtr = tsdPtr->firstEventPtr; evPtr != (Tcl_Event *) NULL; ) { hold = evPtr; @@ -182,36 +187,37 @@ if (tclStubs.tcl_FinalizeNotifier) { tclStubs.tcl_FinalizeNotifier(tsdPtr->clientData); } Tcl_MutexFinalize(&(tsdPtr->queueMutex)); for (prevPtrPtr = &firstNotifierPtr; *prevPtrPtr != NULL; - prevPtrPtr = &((*prevPtrPtr)->nextPtr)) { + prevPtrPtr = &((*prevPtrPtr)->nextPtr)) { if (*prevPtrPtr == tsdPtr) { *prevPtrPtr = tsdPtr->nextPtr; break; } } + tsdPtr->initialized = 0; Tcl_MutexUnlock(&listLock); } /* *---------------------------------------------------------------------- * * Tcl_SetNotifier -- * - * Install a set of alternate functions for use with the notifier. - # In particular, this can be used to install the Xt-based - * notifier for use with the Browser plugin. + * Install a set of alternate functions for use with the notifier. In + * particular, this can be used to install the Xt-based notifier for use + * with the Browser plugin. * * Results: * None. * * Side effects: - * Overstomps part of the stub vector. This relies on hooks - * added to the default procedures in case those are called - * directly (i.e., not through the stub table.) + * Overstomps part of the stub vector. This relies on hooks added to the + * default functions in case those are called directly (i.e., not through + * the stub table.) * *---------------------------------------------------------------------- */ void @@ -233,49 +239,50 @@ /* *---------------------------------------------------------------------- * * Tcl_CreateEventSource -- * - * This procedure is invoked to create a new source of events. - * The source is identified by a procedure that gets invoked - * during Tcl_DoOneEvent to check for events on that source - * and queue them. + * This function is invoked to create a new source of events. The source + * is identified by a function that gets invoked during Tcl_DoOneEvent to + * check for events on that source and queue them. * * * Results: * None. * * Side effects: * SetupProc and checkProc will be invoked each time that Tcl_DoOneEvent - * runs out of things to do. SetupProc will be invoked before - * Tcl_DoOneEvent calls select or whatever else it uses to wait - * for events. SetupProc typically calls functions like - * Tcl_SetMaxBlockTime to indicate what to wait for. + * runs out of things to do. SetupProc will be invoked before + * Tcl_DoOneEvent calls select or whatever else it uses to wait for + * events. SetupProc typically calls functions like Tcl_SetMaxBlockTime + * to indicate what to wait for. * * CheckProc is called after select or whatever operation was actually - * used to wait. It figures out whether anything interesting actually + * used to wait. It figures out whether anything interesting actually * happened (e.g. by calling Tcl_AsyncReady), and then calls * Tcl_QueueEvent to queue any events that are ready. * - * Each of these procedures is passed two arguments, e.g. + * Each of these functions is passed two arguments, e.g. * (*checkProc)(ClientData clientData, int flags)); - * ClientData is the same as the clientData argument here, and flags - * is a combination of things like TCL_FILE_EVENTS that indicates - * what events are of interest: setupProc and checkProc use flags - * to figure out whether their events are relevant or not. + * ClientData is the same as the clientData argument here, and flags is a + * combination of things like TCL_FILE_EVENTS that indicates what events + * are of interest: setupProc and checkProc use flags to figure out + * whether their events are relevant or not. * *---------------------------------------------------------------------- */ void Tcl_CreateEventSource(setupProc, checkProc, clientData) - Tcl_EventSetupProc *setupProc; /* Procedure to invoke to figure out - * what to wait for. */ - Tcl_EventCheckProc *checkProc; /* Procedure to call after waiting - * to see what happened. */ - ClientData clientData; /* One-word argument to pass to - * setupProc and checkProc. */ + Tcl_EventSetupProc *setupProc; + /* Function to invoke to figure out what to + * wait for. */ + Tcl_EventCheckProc *checkProc; + /* Function to call after waiting to see what + * happened. */ + ClientData clientData; /* One-word argument to pass to setupProc and + * checkProc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); EventSource *sourcePtr = (EventSource *) ckalloc(sizeof(EventSource)); sourcePtr->setupProc = setupProc; @@ -288,32 +295,33 @@ /* *---------------------------------------------------------------------- * * Tcl_DeleteEventSource -- * - * This procedure is invoked to delete the source of events - * given by proc and clientData. + * This function is invoked to delete the source of events given by proc + * and clientData. * * Results: * None. * * Side effects: - * The given event source is cancelled, so its procedure will - * never again be called. If no such source exists, nothing - * happens. + * The given event source is cancelled, so its function will never again + * be called. If no such source exists, nothing happens. * *---------------------------------------------------------------------- */ void Tcl_DeleteEventSource(setupProc, checkProc, clientData) - Tcl_EventSetupProc *setupProc; /* Procedure to invoke to figure out - * what to wait for. */ - Tcl_EventCheckProc *checkProc; /* Procedure to call after waiting - * to see what happened. */ - ClientData clientData; /* One-word argument to pass to - * setupProc and checkProc. */ + Tcl_EventSetupProc *setupProc; + /* Function to invoke to figure out what to + * wait for. */ + Tcl_EventCheckProc *checkProc; + /* Function to call after waiting to see what + * happened. */ + ClientData clientData; /* One-word argument to pass to setupProc and + * checkProc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); EventSource *sourcePtr, *prevPtr; for (sourcePtr = tsdPtr->firstEventSourcePtr, prevPtr = NULL; @@ -337,12 +345,11 @@ /* *---------------------------------------------------------------------- * * Tcl_QueueEvent -- * - * Queue an event on the event queue associated with the - * current thread. + * Queue an event on the event queue associated with the current thread. * * Results: * None. * * Side effects: @@ -351,16 +358,15 @@ *---------------------------------------------------------------------- */ void Tcl_QueueEvent(evPtr, position) - Tcl_Event* evPtr; /* Event to add to queue. The storage - * space must have been allocated the caller - * with malloc (ckalloc), and it becomes - * the property of the event queue. It - * will be freed after the event has been - * handled. */ + Tcl_Event* evPtr; /* Event to add to queue. The storage space + * must have been allocated the caller with + * malloc (ckalloc), and it becomes the + * property of the event queue. It will be + * freed after the event has been handled. */ Tcl_QueuePosition position; /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, * TCL_QUEUE_MARK. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); QueueEvent(tsdPtr, evPtr, position); @@ -383,16 +389,15 @@ */ void Tcl_ThreadQueueEvent(threadId, evPtr, position) Tcl_ThreadId threadId; /* Identifier for thread to use. */ - Tcl_Event* evPtr; /* Event to add to queue. The storage - * space must have been allocated the caller - * with malloc (ckalloc), and it becomes - * the property of the event queue. It - * will be freed after the event has been - * handled. */ + Tcl_Event* evPtr; /* Event to add to queue. The storage space + * must have been allocated the caller with + * malloc (ckalloc), and it becomes the + * property of the event queue. It will be + * freed after the event has been handled. */ Tcl_QueuePosition position; /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, * TCL_QUEUE_MARK. */ { ThreadSpecificData *tsdPtr; @@ -400,11 +405,11 @@ * Find the notifier associated with the specified thread. */ Tcl_MutexLock(&listLock); for (tsdPtr = firstNotifierPtr; tsdPtr && tsdPtr->threadId != threadId; - tsdPtr = tsdPtr->nextPtr) { + tsdPtr = tsdPtr->nextPtr) { /* Empty loop body. */ } /* * Queue the event if there was a notifier associated with the thread. @@ -419,16 +424,16 @@ /* *---------------------------------------------------------------------- * * QueueEvent -- * - * Insert an event into the specified thread's event queue at one - * of three positions: the head, the tail, or before a floating - * marker. Events inserted before the marker will be processed in - * first-in-first-out order, but before any events inserted at - * the tail of the queue. Events inserted at the head of the - * queue will be processed in last-in-first-out order. + * Insert an event into the specified thread's event queue at one of + * three positions: the head, the tail, or before a floating marker. + * Events inserted before the marker will be processed in first-in- + * first-out order, but before any events inserted at the tail of the + * queue. Events inserted at the head of the queue will be processed in + * last-in-first-out order. * * Results: * None. * * Side effects: @@ -439,16 +444,15 @@ static void QueueEvent(tsdPtr, evPtr, position) ThreadSpecificData *tsdPtr; /* Handle to thread local data that indicates * which event queue to use. */ - Tcl_Event* evPtr; /* Event to add to queue. The storage - * space must have been allocated the caller - * with malloc (ckalloc), and it becomes - * the property of the event queue. It - * will be freed after the event has been - * handled. */ + Tcl_Event* evPtr; /* Event to add to queue. The storage space + * must have been allocated the caller with + * malloc (ckalloc), and it becomes the + * property of the event queue. It will be + * freed after the event has been handled. */ Tcl_QueuePosition position; /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, * TCL_QUEUE_MARK. */ { Tcl_MutexLock(&(tsdPtr->queueMutex)); if (position == TCL_QUEUE_TAIL) { @@ -469,16 +473,16 @@ */ evPtr->nextPtr = tsdPtr->firstEventPtr; if (tsdPtr->firstEventPtr == NULL) { tsdPtr->lastEventPtr = evPtr; - } + } tsdPtr->firstEventPtr = evPtr; } else if (position == TCL_QUEUE_MARK) { /* - * Insert the event after the current marker event and advance - * the marker to the new event. + * Insert the event after the current marker event and advance the + * marker to the new event. */ if (tsdPtr->markerEventPtr == NULL) { evPtr->nextPtr = tsdPtr->firstEventPtr; tsdPtr->firstEventPtr = evPtr; @@ -497,14 +501,14 @@ /* *---------------------------------------------------------------------- * * Tcl_DeleteEvents -- * - * Calls a procedure for each event in the queue and deletes those - * for which the procedure returns 1. Events for which the - * procedure returns 0 are left in the queue. Operates on the - * queue associated with the current thread. + * Calls a function for each event in the queue and deletes those for + * which the function returns 1. Events for which the function returns 0 + * are left in the queue. Operates on the queue associated with the + * current thread. * * Results: * None. * * Side effects: @@ -513,132 +517,130 @@ *---------------------------------------------------------------------- */ void Tcl_DeleteEvents(proc, clientData) - Tcl_EventDeleteProc *proc; /* The procedure to call. */ - ClientData clientData; /* type-specific data. */ + Tcl_EventDeleteProc *proc; /* The function to call. */ + ClientData clientData; /* The type-specific data. */ { Tcl_Event *evPtr, *prevPtr, *hold; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); Tcl_MutexLock(&(tsdPtr->queueMutex)); for (prevPtr = (Tcl_Event *) NULL, evPtr = tsdPtr->firstEventPtr; - evPtr != (Tcl_Event *) NULL; - ) { - if ((*proc) (evPtr, clientData) == 1) { - if (tsdPtr->firstEventPtr == evPtr) { - tsdPtr->firstEventPtr = evPtr->nextPtr; - } else { - prevPtr->nextPtr = evPtr->nextPtr; - } - if (evPtr->nextPtr == (Tcl_Event *) NULL) { - tsdPtr->lastEventPtr = prevPtr; - } - if (tsdPtr->markerEventPtr == evPtr) { - tsdPtr->markerEventPtr = prevPtr; - } - hold = evPtr; - evPtr = evPtr->nextPtr; - ckfree((char *) hold); - } else { - prevPtr = evPtr; - evPtr = evPtr->nextPtr; - } + evPtr != (Tcl_Event *) NULL; /*EMPTY STEP*/) { + if ((*proc) (evPtr, clientData) == 1) { + if (tsdPtr->firstEventPtr == evPtr) { + tsdPtr->firstEventPtr = evPtr->nextPtr; + } else { + prevPtr->nextPtr = evPtr->nextPtr; + } + if (evPtr->nextPtr == (Tcl_Event *) NULL) { + tsdPtr->lastEventPtr = prevPtr; + } + if (tsdPtr->markerEventPtr == evPtr) { + tsdPtr->markerEventPtr = prevPtr; + } + hold = evPtr; + evPtr = evPtr->nextPtr; + ckfree((char *) hold); + } else { + prevPtr = evPtr; + evPtr = evPtr->nextPtr; + } } Tcl_MutexUnlock(&(tsdPtr->queueMutex)); } /* *---------------------------------------------------------------------- * * Tcl_ServiceEvent -- * - * Process one event from the event queue, or invoke an - * asynchronous event handler. Operates on event queue for - * current thread. + * Process one event from the event queue, or invoke an asynchronous + * event handler. Operates on event queue for current thread. * * Results: - * The return value is 1 if the procedure actually found an event - * to process. If no processing occurred, then 0 is returned. + * The return value is 1 if the function actually found an event to + * process. If no processing occurred, then 0 is returned. * * Side effects: - * Invokes all of the event handlers for the highest priority - * event in the event queue. May collapse some events into a - * single event or discard stale events. + * Invokes all of the event handlers for the highest priority event in + * the event queue. May collapse some events into a single event or + * discard stale events. * *---------------------------------------------------------------------- */ int Tcl_ServiceEvent(flags) int flags; /* Indicates what events should be processed. * May be any combination of TCL_WINDOW_EVENTS * TCL_FILE_EVENTS, TCL_TIMER_EVENTS, or other - * flags defined elsewhere. Events not - * matching this will be skipped for processing - * later. */ + * flags defined elsewhere. Events not + * matching this will be skipped for + * processing later. */ { Tcl_Event *evPtr, *prevPtr; Tcl_EventProc *proc; int result; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* - * Asynchronous event handlers are considered to be the highest - * priority events, and so must be invoked before we process events - * on the event queue. + * Asynchronous event handlers are considered to be the highest priority + * events, and so must be invoked before we process events on the event + * queue. */ - + if (Tcl_AsyncReady()) { (void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0); return 1; } /* * No event flags is equivalent to TCL_ALL_EVENTS. */ - + if ((flags & TCL_ALL_EVENTS) == 0) { flags |= TCL_ALL_EVENTS; } /* - * Loop through all the events in the queue until we find one - * that can actually be handled. + * Loop through all the events in the queue until we find one that can + * actually be handled. */ Tcl_MutexLock(&(tsdPtr->queueMutex)); for (evPtr = tsdPtr->firstEventPtr; evPtr != NULL; - evPtr = evPtr->nextPtr) { + evPtr = evPtr->nextPtr) { /* - * Call the handler for the event. If it actually handles the - * event then free the storage for the event. There are two - * tricky things here, both stemming from the fact that the event - * code may be re-entered while servicing the event: + * Call the handler for the event. If it actually handles the event + * then free the storage for the event. There are two tricky things + * here, both stemming from the fact that the event code may be + * re-entered while servicing the event: * * 1. Set the "proc" field to NULL. This is a signal to ourselves - * that we shouldn't reexecute the handler if the event loop - * is re-entered. + * that we shouldn't reexecute the handler if the event loop is + * re-entered. * 2. When freeing the event, must search the queue again from the - * front to find it. This is because the event queue could - * change almost arbitrarily while handling the event, so we - * can't depend on pointers found now still being valid when - * the handler returns. + * front to find it. This is because the event queue could change + * almost arbitrarily while handling the event, so we can't depend + * on pointers found now still being valid when the handler + * returns. */ proc = evPtr->proc; if (proc == NULL) { continue; } evPtr->proc = NULL; /* - * Release the lock before calling the event procedure. This - * allows other threads to post events if we enter a recursive - * event loop in this thread. Note that we are making the assumption - * that if the proc returns 0, the event is still in the list. + * Release the lock before calling the event function. This allows + * other threads to post events if we enter a recursive event loop in + * this thread. Note that we are making the assumption that if the + * proc returns 0, the event is still in the list. */ Tcl_MutexUnlock(&(tsdPtr->queueMutex)); result = (*proc)(evPtr, flags); Tcl_MutexLock(&(tsdPtr->queueMutex)); @@ -656,12 +658,12 @@ if (tsdPtr->markerEventPtr == evPtr) { tsdPtr->markerEventPtr = NULL; } } else { for (prevPtr = tsdPtr->firstEventPtr; - prevPtr && prevPtr->nextPtr != evPtr; - prevPtr = prevPtr->nextPtr) { + prevPtr && prevPtr->nextPtr != evPtr; + prevPtr = prevPtr->nextPtr) { /* Empty loop body. */ } if (prevPtr) { prevPtr->nextPtr = evPtr->nextPtr; if (evPtr->nextPtr == NULL) { @@ -679,12 +681,12 @@ } Tcl_MutexUnlock(&(tsdPtr->queueMutex)); return 1; } else { /* - * The event wasn't actually handled, so we have to restore - * the proc field to allow the event to be attempted again. + * The event wasn't actually handled, so we have to restore the + * proc field to allow the event to be attempted again. */ evPtr->proc = proc; } } @@ -725,11 +727,11 @@ * * Results: * Returns the previous service mode. * * Side effects: - * Invokes the notifier service mode hook procedure. + * Invokes the notifier service mode hook function. * *---------------------------------------------------------------------- */ int @@ -751,14 +753,14 @@ /* *---------------------------------------------------------------------- * * Tcl_SetMaxBlockTime -- * - * This procedure is invoked by event sources to tell the notifier - * how long it may block the next time it blocks. The timePtr - * argument gives a maximum time; the actual time may be less if - * some other event source requested a smaller time. + * This function is invoked by event sources to tell the notifier how + * long it may block the next time it blocks. The timePtr argument gives + * a maximum time; the actual time may be less if some other event source + * requested a smaller time. * * Results: * None. * * Side effects: @@ -767,13 +769,13 @@ *---------------------------------------------------------------------- */ void Tcl_SetMaxBlockTime(timePtr) - Tcl_Time *timePtr; /* Specifies a maximum elapsed time for - * the next blocking operation in the - * event tsdPtr-> */ + Tcl_Time *timePtr; /* Specifies a maximum elapsed time for the + * next blocking operation in the event + * tsdPtr-> */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->blockTimeSet || (timePtr->sec < tsdPtr->blockTime.sec) || ((timePtr->sec == tsdPtr->blockTime.sec) @@ -781,12 +783,12 @@ tsdPtr->blockTime = *timePtr; tsdPtr->blockTimeSet = 1; } /* - * If we are called outside an event source traversal, set the - * timeout immediately. + * If we are called outside an event source traversal, set the timeout + * immediately. */ if (!tsdPtr->inTraversal) { if (tsdPtr->blockTimeSet) { Tcl_SetTimer(&tsdPtr->blockTime); @@ -799,31 +801,31 @@ /* *---------------------------------------------------------------------- * * Tcl_DoOneEvent -- * - * Process a single event of some sort. If there's no work to - * do, wait for an event to occur, then process it. + * Process a single event of some sort. If there's no work to do, wait + * for an event to occur, then process it. * * Results: - * The return value is 1 if the procedure actually found an event - * to process. If no processing occurred, then 0 is returned (this - * can happen if the TCL_DONT_WAIT flag is set or if there are no - * event handlers to wait for in the set specified by flags). + * The return value is 1 if the function actually found an event to + * process. If no processing occurred, then 0 is returned (this can + * happen if the TCL_DONT_WAIT flag is set or if there are no event + * handlers to wait for in the set specified by flags). * * Side effects: - * May delay execution of process while waiting for an event, - * unless TCL_DONT_WAIT is set in the flags argument. Event - * sources are invoked to check for and queue events. Event - * handlers may produce arbitrary side effects. + * May delay execution of process while waiting for an event, unless + * TCL_DONT_WAIT is set in the flags argument. Event sources are invoked + * to check for and queue events. Event handlers may produce arbitrary + * side effects. * *---------------------------------------------------------------------- */ int Tcl_DoOneEvent(flags) - int flags; /* Miscellaneous flag values: may be any + int flags; /* Miscellaneous flag values: may be any * combination of TCL_DONT_WAIT, * TCL_WINDOW_EVENTS, TCL_FILE_EVENTS, * TCL_TIMER_EVENTS, TCL_IDLE_EVENTS, or * others defined by event sources. */ { @@ -831,12 +833,11 @@ EventSource *sourcePtr; Tcl_Time *timePtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* - * The first thing we do is to service any asynchronous event - * handlers. + * The first thing we do is to service any asynchronous event handlers. */ if (Tcl_AsyncReady()) { (void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0); return 1; @@ -849,33 +850,32 @@ if ((flags & TCL_ALL_EVENTS) == 0) { flags |= TCL_ALL_EVENTS; } /* - * Set the service mode to none so notifier event routines won't - * try to service events recursively. + * Set the service mode to none so notifier event routines won't try to + * service events recursively. */ oldMode = tsdPtr->serviceMode; tsdPtr->serviceMode = TCL_SERVICE_NONE; /* - * The core of this procedure is an infinite loop, even though - * we only service one event. The reason for this is that we - * may be processing events that don't do anything inside of Tcl. + * The core of this function is an infinite loop, even though we only + * service one event. The reason for this is that we may be processing + * events that don't do anything inside of Tcl. */ while (1) { - /* - * If idle events are the only things to service, skip the - * main part of the loop and go directly to handle idle - * events (i.e. don't wait even if TCL_DONT_WAIT isn't set). + * If idle events are the only things to service, skip the main part + * of the loop and go directly to handle idle events (i.e. don't wait + * even if TCL_DONT_WAIT isn't set). */ if ((flags & TCL_ALL_EVENTS) == TCL_IDLE_EVENTS) { - flags = TCL_IDLE_EVENTS|TCL_DONT_WAIT; + flags = TCL_IDLE_EVENTS | TCL_DONT_WAIT; goto idleEvents; } /* * Ask Tcl to service a queued event, if there are any. @@ -885,12 +885,12 @@ result = 1; break; } /* - * If TCL_DONT_WAIT is set, be sure to poll rather than - * blocking, otherwise reset the block time to infinity. + * If TCL_DONT_WAIT is set, be sure to poll rather than blocking, + * otherwise reset the block time to infinity. */ if (flags & TCL_DONT_WAIT) { tsdPtr->blockTime.sec = 0; tsdPtr->blockTime.usec = 0; @@ -898,17 +898,17 @@ } else { tsdPtr->blockTimeSet = 0; } /* - * Set up all the event sources for new events. This will - * cause the block time to be updated if necessary. + * Set up all the event sources for new events. This will cause the + * block time to be updated if necessary. */ tsdPtr->inTraversal = 1; for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL; - sourcePtr = sourcePtr->nextPtr) { + sourcePtr = sourcePtr->nextPtr) { if (sourcePtr->setupProc) { (sourcePtr->setupProc)(sourcePtr->clientData, flags); } } tsdPtr->inTraversal = 0; @@ -918,12 +918,12 @@ } else { timePtr = NULL; } /* - * Wait for a new event or a timeout. If Tcl_WaitForEvent - * returns -1, we should abort Tcl_DoOneEvent. + * Wait for a new event or a timeout. If Tcl_WaitForEvent returns -1, + * we should abort Tcl_DoOneEvent. */ result = Tcl_WaitForEvent(timePtr); if (result < 0) { result = 0; @@ -933,11 +933,11 @@ /* * Check all the event sources for new events. */ for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL; - sourcePtr = sourcePtr->nextPtr) { + sourcePtr = sourcePtr->nextPtr) { if (sourcePtr->checkProc) { (sourcePtr->checkProc)(sourcePtr->clientData, flags); } } @@ -949,16 +949,16 @@ result = 1; break; } /* - * We've tried everything at this point, but nobody we know - * about had anything to do. Check for idle events. If none, - * either quit or go back to the top and try again. + * We've tried everything at this point, but nobody we know about had + * anything to do. Check for idle events. If none, either quit or go + * back to the top and try again. */ - idleEvents: + idleEvents: if (flags & TCL_IDLE_EVENTS) { if (TclServiceIdle()) { result = 1; break; } @@ -966,27 +966,25 @@ if (flags & TCL_DONT_WAIT) { break; } /* - * If Tcl_WaitForEvent has returned 1, - * indicating that one system event has been dispatched - * (and thus that some Tcl code might have been indirectly executed), - * we break out of the loop. - * We do this to give VwaitCmd for instance a chance to check - * if that system event had the side effect of changing the - * variable (so the vwait can return and unwind properly). - * - * NB: We will process idle events if any first, because - * otherwise we might never do the idle events if the notifier - * always gets system events. + * If Tcl_WaitForEvent has returned 1, indicating that one system + * event has been dispatched (and thus that some Tcl code might have + * been indirectly executed), we break out of the loop. We do this to + * give VwaitCmd for instance a chance to check if that system event + * had the side effect of changing the variable (so the vwait can + * return and unwind properly). + * + * NB: We will process idle events if any first, because otherwise we + * might never do the idle events if the notifier always gets + * system events. */ if (result) { break; } - } tsdPtr->serviceMode = oldMode; return result; } @@ -994,16 +992,15 @@ /* *---------------------------------------------------------------------- * * Tcl_ServiceAll -- * - * This routine checks all of the event sources, processes - * events that are on the Tcl event queue, and then calls the - * any idle handlers. Platform specific notifier callbacks that - * generate events should call this routine before returning to - * the system in order to ensure that Tcl gets a chance to - * process the new events. + * This routine checks all of the event sources, processes events that + * are on the Tcl event queue, and then calls the any idle handlers. + * Platform specific notifier callbacks that generate events should call + * this routine before returning to the system in order to ensure that + * Tcl gets a chance to process the new events. * * Results: * Returns 1 if an event or idle handler was invoked, else 0. * * Side effects: @@ -1022,14 +1019,14 @@ if (tsdPtr->serviceMode == TCL_SERVICE_NONE) { return result; } /* - * We need to turn off event servicing like we to in Tcl_DoOneEvent, - * to avoid recursive calls. + * We need to turn off event servicing like we to in Tcl_DoOneEvent, to + * avoid recursive calls. */ - + tsdPtr->serviceMode = TCL_SERVICE_NONE; /* * Check async handlers first. */ @@ -1037,26 +1034,26 @@ if (Tcl_AsyncReady()) { (void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0); } /* - * Make a single pass through all event sources, queued events, - * and idle handlers. Note that we wait to update the notifier - * timer until the end so we can avoid multiple changes. + * Make a single pass through all event sources, queued events, and idle + * handlers. Note that we wait to update the notifier timer until the end + * so we can avoid multiple changes. */ tsdPtr->inTraversal = 1; tsdPtr->blockTimeSet = 0; for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL; - sourcePtr = sourcePtr->nextPtr) { + sourcePtr = sourcePtr->nextPtr) { if (sourcePtr->setupProc) { (sourcePtr->setupProc)(sourcePtr->clientData, TCL_ALL_EVENTS); } } for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL; - sourcePtr = sourcePtr->nextPtr) { + sourcePtr = sourcePtr->nextPtr) { if (sourcePtr->checkProc) { (sourcePtr->checkProc)(sourcePtr->clientData, TCL_ALL_EVENTS); } } @@ -1080,12 +1077,12 @@ /* *---------------------------------------------------------------------- * * Tcl_ThreadAlert -- * - * This function wakes up the notifier associated with the - * specified thread (if there is one). + * This function wakes up the notifier associated with the specified + * thread (if there is one). * * Results: * None. * * Side effects: @@ -1099,14 +1096,13 @@ Tcl_ThreadId threadId; /* Identifier for thread to use. */ { ThreadSpecificData *tsdPtr; /* - * Find the notifier associated with the specified thread. - * Note that we need to hold the listLock while calling - * Tcl_AlertNotifier to avoid a race condition where - * the specified thread might destroy its notifier. + * Find the notifier associated with the specified thread. Note that we + * need to hold the listLock while calling Tcl_AlertNotifier to avoid a + * race condition where the specified thread might destroy its notifier. */ Tcl_MutexLock(&listLock); for (tsdPtr = firstNotifierPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) { if (tsdPtr->threadId == threadId) { @@ -1116,5 +1112,13 @@ break; } } Tcl_MutexUnlock(&listLock); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclObj.c ================================================================== --- generic/tclObj.c +++ generic/tclObj.c @@ -1,23 +1,27 @@ /* * tclObj.c -- * - * This file contains Tcl object-related procedures that are used by - * many Tcl commands. + * This file contains Tcl object-related procedures that are used by many + * Tcl commands. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation. * Copyright (c) 2001 by ActiveState Corporation. + * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * 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.72 2004/10/06 15:59:25 dgp Exp $ + * RCS: @(#) $Id: tclObj.c,v 1.72.2.42 2005/10/08 06:07:58 dgp Exp $ */ #include "tclInt.h" -#include "tclCompile.h" +#include "tommath.h" +#include + +#define BIGNUM_AUTO_NARROW 1 /* * Table of all object types. */ @@ -30,84 +34,169 @@ */ Tcl_Obj *tclFreeObjList = NULL; /* - * The object allocator is single threaded. This mutex is referenced - * by the TclNewObj macro, however, so must be visible. + * The object allocator is single threaded. This mutex is referenced by the + * TclNewObj macro, however, so must be visible. */ #ifdef TCL_THREADS Tcl_Mutex tclObjMutex; #endif /* - * Pointer to a heap-allocated string of length zero that the Tcl core uses - * as the value of an empty string representation for an object. This value - * is shared by all new objects allocated by Tcl_NewObj. + * Pointer to a heap-allocated string of length zero that the Tcl core uses as + * the value of an empty string representation for an object. This value is + * shared by all new objects allocated by Tcl_NewObj. */ char tclEmptyString = '\0'; char *tclEmptyStringRep = &tclEmptyString; #if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) /* - * Thread local table that is used to check that a Tcl_Obj - * was not allocated by some other thread. + * Thread local table that is used to check that a Tcl_Obj was not allocated + * by some other thread. */ typedef struct ThreadSpecificData { Tcl_HashTable *objThreadMap; } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; #endif /* TCL_MEM_DEBUG && TCL_THREADS */ + /* - * Nested Tcl_Obj deletion management support. Note that the code - * that implements all this is written as macros in tclInt.h + * Nested Tcl_Obj deletion management support + * + * All context references used in the object freeing code are pointers to this + * structure; every thread will have its own structure instance. The purpose + * of this structure is to allow deeply nested collections of Tcl_Objs to be + * freed without taking a vast depth of C stack (which could cause all sorts + * of breakage.) */ -#ifdef TCL_THREADS +typedef struct PendingObjData { + int deletionCount; /* Count of the number of invokations of + * TclFreeObj() are on the stack (at least + * conceptually; many are actually expanded + * macros). */ + Tcl_Obj *deletionStack; /* Stack of objects that have had TclFreeObj() + * invoked upon them but which can't be + * deleted yet because they are in a nested + * invokation of TclFreeObj(). By postponing + * this way, we limit the maximum overall C + * stack depth when deleting a complex object. + * The down-side is that we alter the overall + * behaviour by altering the order in which + * objects are deleted, and we change the + * order in which the string rep and the + * internal rep of an object are deleted. Note + * that code which assumes the previous + * behaviour in either of these respects is + * unsafe anyway; it was never documented as + * to exactly what would happen in these + * cases, and the overall contract of a + * user-level Tcl_DecrRefCount() is still + * preserved (assuming that a particular T_DRC + * would delete an object is not very + * safe). */ +} PendingObjData; /* - * Lookup key for the thread-local data used in the implementation in - * tclInt.h. + * These are separated out so that some semantic content is attached + * to them. */ -Tcl_ThreadDataKey tclPendingObjDataKey; +#define ObjDeletionLock(contextPtr) ((contextPtr)->deletionCount++) +#define ObjDeletionUnlock(contextPtr) ((contextPtr)->deletionCount--) +#define ObjDeletePending(contextPtr) ((contextPtr)->deletionCount > 0) +#define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL) +#define PushObjToDelete(contextPtr,objPtr) \ + /* Invalidate the string rep first so we can use the bytes value \ + * for our pointer chain. */ \ + if (((objPtr)->bytes != NULL) \ + && ((objPtr)->bytes != tclEmptyStringRep)) { \ + ckfree((char *) (objPtr)->bytes); \ + } \ + /* Now push onto the head of the stack. */ \ + (objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \ + (contextPtr)->deletionStack = (objPtr) +#define PopObjToDelete(contextPtr,objPtrVar) \ + (objPtrVar) = (contextPtr)->deletionStack; \ + (contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes +/* + * Macro to set up the local reference to the deletion context. + */ +#ifndef TCL_THREADS +static PendingObjData pendingObjData; +#define ObjInitDeletionContext(contextPtr) \ + PendingObjData *CONST contextPtr = &pendingObjData #else - -/* - * Declaration of the singleton structure referenced in the - * implementation in tclInt.h. - */ -PendingObjData tclPendingObjData = { 0, NULL }; - +static Tcl_ThreadDataKey pendingObjDataKey; +#define ObjInitDeletionContext(contextPtr) \ + PendingObjData *CONST contextPtr = (PendingObjData *) \ + Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData)) #endif + +/* + * Macros to pack/unpack a bignum's fields in a Tcl_Obj internal rep + */ + +#define PACK_BIGNUM(bignum, objPtr) \ + 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) \ + 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.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 UpdateStringOfBoolean _ANSI_ARGS_((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 +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 GetBignumFromObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, int copy, mp_int *bignumValue)); + /* * Prototypes for the array hash key methods. */ static Tcl_HashEntry * AllocObjEntry _ANSI_ARGS_(( @@ -115,21 +204,19 @@ static int CompareObjKeys _ANSI_ARGS_(( VOID *keyPtr, Tcl_HashEntry *hPtr)); static void FreeObjEntry _ANSI_ARGS_(( Tcl_HashEntry *hPtr)); static unsigned int HashObjKey _ANSI_ARGS_(( - Tcl_HashTable *tablePtr, - VOID *keyPtr)); + Tcl_HashTable *tablePtr, VOID *keyPtr)); /* * Prototypes for the CommandName object type. */ static void DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, Tcl_Obj *copyPtr)); -static void FreeCmdNameInternalRep _ANSI_ARGS_(( - Tcl_Obj *objPtr)); +static void FreeCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); /* @@ -141,11 +228,11 @@ Tcl_ObjType tclBooleanType = { "boolean", /* name */ (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ - UpdateStringOfBoolean, /* updateStringProc */ + (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ SetBooleanFromAny /* setFromAnyProc */ }; Tcl_ObjType tclDoubleType = { "double", /* name */ @@ -161,20 +248,28 @@ (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ UpdateStringOfInt, /* updateStringProc */ 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 */ + NULL /* setFromAnyProc */ }; /* * The structure below defines the Tcl obj hash key type. */ @@ -187,21 +282,21 @@ FreeObjEntry /* freeEntryProc */ }; /* * The structure below defines the command name Tcl object type by means of - * procedures that can be invoked by generic object code. Objects of this - * type cache the Command pointer that results from looking up command names - * in the command hashtable. Such objects appear as the zeroth ("command - * name") argument in a Tcl command. + * procedures that can be invoked by generic object code. Objects of this type + * cache the Command pointer that results from looking up command names in the + * command hashtable. Such objects appear as the zeroth ("command name") + * argument in a Tcl command. * * NOTE: the ResolvedCmdName that gets cached is stored in the - * twoPtrValue.ptr1 field, and the twoPtrValue.ptr2 field is unused. - * You might think you could use the simpler otherValuePtr field to - * store the single ResolvedCmdName pointer, but DO NOT DO THIS. It - * seems that some extensions use the second internal pointer field - * of the twoPtrValue field for their own purposes. + * twoPtrValue.ptr1 field, and the twoPtrValue.ptr2 field is unused. You might + * think you could use the simpler otherValuePtr field to store the single + * ResolvedCmdName pointer, but DO NOT DO THIS. It seems that some extensions + * use the second internal pointer field of the twoPtrValue field for their + * own purposes. */ static Tcl_ObjType tclCmdNameType = { "cmdName", /* name */ FreeCmdNameInternalRep, /* freeIntRepProc */ @@ -210,60 +305,59 @@ SetCmdNameFromAny /* setFromAnyProc */ }; /* - * Structure containing a cached pointer to a command that is the result - * of resolving the command's name in some namespace. It is the internal - * representation for a cmdName object. It contains the pointer along - * with some information that is used to check the pointer's validity. + * Structure containing a cached pointer to a command that is the result of + * resolving the command's name in some namespace. It is the internal + * representation for a cmdName object. It contains the pointer along with + * some information that is used to check the pointer's validity. */ typedef struct ResolvedCmdName { Command *cmdPtr; /* A cached Command pointer. */ Namespace *refNsPtr; /* Points to the namespace containing the - * reference (not the namespace that - * contains the referenced command). */ + * reference (not the namespace that contains + * the referenced command). */ long refNsId; /* refNsPtr's unique namespace id. Used to - * verify that refNsPtr is still valid - * (e.g., it's possible that the cmd's - * containing namespace was deleted and a - * new one created at the same address). */ + * verify that refNsPtr is still valid (e.g., + * it's possible that the cmd's containing + * namespace was deleted and a new one created + * at the same address). */ int refNsCmdEpoch; /* Value of the referencing namespace's * cmdRefEpoch when the pointer was cached. * Before using the cached pointer, we check * if the namespace's epoch was incremented; * if so, this cached pointer is invalid. */ int cmdEpoch; /* Value of the command's cmdEpoch when this - * pointer was cached. Before using the - * cached pointer, we check if the cmd's - * epoch was incremented; if so, the cmd was - * renamed, deleted, hidden, or exposed, and - * so the pointer is invalid. */ - int refCount; /* Reference count: 1 for each cmdName - * object that has a pointer to this - * ResolvedCmdName structure as its internal - * rep. This structure can be freed when - * refCount becomes zero. */ + * pointer was cached. Before using the cached + * pointer, we check if the cmd's epoch was + * incremented; if so, the cmd was renamed, + * deleted, hidden, or exposed, and so the + * pointer is invalid. */ + int refCount; /* Reference count: 1 for each cmdName object + * that has a pointer to this ResolvedCmdName + * structure as its internal rep. This + * structure can be freed when refCount + * becomes zero. */ } ResolvedCmdName; /* *------------------------------------------------------------------------- * * TclInitObjectSubsystem -- * - * This procedure is invoked to perform once-only initialization of - * the type table. It also registers the object types defined in - * this file. + * This procedure is invoked to perform once-only initialization of the + * type table. It also registers the object types defined in this file. * * Results: * None. * * Side effects: - * Initializes the table of defined object types "typeTable" with - * builtin object types defined in this file. + * Initializes the table of defined object types "typeTable" with builtin + * object types defined in this file. * *------------------------------------------------------------------------- */ void @@ -272,29 +366,22 @@ Tcl_MutexLock(&tableMutex); typeTableInitialized = 1; Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS); Tcl_MutexUnlock(&tableMutex); - Tcl_RegisterObjType(&tclBooleanType); Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); Tcl_RegisterObjType(&tclEndOffsetType); Tcl_RegisterObjType(&tclIntType); - Tcl_RegisterObjType(&tclWideIntType); Tcl_RegisterObjType(&tclStringType); - Tcl_RegisterObjType(&tclListType); Tcl_RegisterObjType(&tclDictType); Tcl_RegisterObjType(&tclByteCodeType); - Tcl_RegisterObjType(&tclProcBodyType); Tcl_RegisterObjType(&tclArraySearchType); - Tcl_RegisterObjType(&tclIndexType); Tcl_RegisterObjType(&tclNsNameType); - Tcl_RegisterObjType(&tclEnsembleCmdType); Tcl_RegisterObjType(&tclCmdNameType); - Tcl_RegisterObjType(&tclLocalVarNameType); Tcl_RegisterObjType(&tclRegexpType); - Tcl_RegisterObjType(&tclLevelReferenceType); + Tcl_RegisterObjType(&tclProcBodyType); #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); tclObjsAlloced = 0; tclObjsFreed = 0; @@ -309,141 +396,130 @@ } /* *---------------------------------------------------------------------- * - * TclFinalizeCompExecEnv -- + * TclFinalizeObjects -- * - * This procedure is called by Tcl_Finalize to clean up the Tcl - * compilation and execution environment so it can later be properly - * reinitialized. + * This procedure is called by Tcl_Finalize to clean up all + * registered Tcl_ObjType's and to reset the tclFreeObjList. * * Results: * None. * * Side effects: - * Cleans up the compilation and execution environment + * None. * *---------------------------------------------------------------------- */ void -TclFinalizeCompExecEnv() +TclFinalizeObjects() { Tcl_MutexLock(&tableMutex); if (typeTableInitialized) { Tcl_DeleteHashTable(&typeTable); typeTableInitialized = 0; } Tcl_MutexUnlock(&tableMutex); + + /* + * All we do here is reset the head pointer of the linked list of + * free Tcl_Obj's to NULL; the memory finalization will take care + * of releasing memory for us. + */ Tcl_MutexLock(&tclObjMutex); tclFreeObjList = NULL; Tcl_MutexUnlock(&tclObjMutex); - - TclFinalizeCompilation(); - TclFinalizeExecution(); } /* *-------------------------------------------------------------- * * Tcl_RegisterObjType -- * - * This procedure is called to register a new Tcl object type - * in the table of all object types supported by Tcl. + * This procedure is called to register a new Tcl object type in the + * table of all object types supported by Tcl. * * Results: * None. * * Side effects: - * The type is registered in the Tcl type table. If there was already - * a type with the same name as in typePtr, it is replaced with the - * new type. + * The type is registered in the Tcl type table. If there was already a + * type with the same name as in typePtr, it is replaced with the new + * type. * *-------------------------------------------------------------- */ void Tcl_RegisterObjType(typePtr) - Tcl_ObjType *typePtr; /* Information about object type; - * storage must be statically - * allocated (must live forever). */ -{ - register Tcl_HashEntry *hPtr; - int new; - - /* - * If there's already an object type with the given name, remove it. - */ + Tcl_ObjType *typePtr; /* Information about object type; storage must + * be statically allocated (must live + * forever). */ +{ + int new; Tcl_MutexLock(&tableMutex); - hPtr = Tcl_FindHashEntry(&typeTable, typePtr->name); - if (hPtr != (Tcl_HashEntry *) NULL) { - Tcl_DeleteHashEntry(hPtr); - } - - /* - * Now insert the new object type. - */ - - hPtr = Tcl_CreateHashEntry(&typeTable, typePtr->name, &new); - if (new) { - Tcl_SetHashValue(hPtr, typePtr); - } + Tcl_SetHashValue( + Tcl_CreateHashEntry(&typeTable, typePtr->name, &new), typePtr); Tcl_MutexUnlock(&tableMutex); } /* *---------------------------------------------------------------------- * * Tcl_AppendAllObjTypes -- * * This procedure appends onto the argument object the name of each - * object type as a list element. This includes the builtin object - * types (e.g. int, list) as well as those added using - * Tcl_NewObj. These names can be used, for example, with - * Tcl_GetObjType to get pointers to the corresponding Tcl_ObjType - * structures. + * object type as a list element. This includes the builtin object types + * (e.g. int, list) as well as those added using Tcl_NewObj. These names + * can be used, for example, with Tcl_GetObjType to get pointers to the + * corresponding Tcl_ObjType structures. * * Results: * The return value is normally TCL_OK; in this case the object - * referenced by objPtr has each type name appended to it. If an - * error occurs, TCL_ERROR is returned and the interpreter's result - * holds an error message. + * referenced by objPtr has each type name appended to it. If an error + * occurs, TCL_ERROR is returned and the interpreter's result holds an + * error message. * * Side effects: - * If necessary, the object referenced by objPtr is converted into - * a list object. + * If necessary, the object referenced by objPtr is converted into a list + * object. * *---------------------------------------------------------------------- */ int Tcl_AppendAllObjTypes(interp, objPtr) Tcl_Interp *interp; /* Interpreter used for error reporting. */ Tcl_Obj *objPtr; /* Points to the Tcl object onto which the - * name of each registered type is appended - * as a list element. */ + * name of each registered type is appended as + * a list element. */ { register Tcl_HashEntry *hPtr; Tcl_HashSearch search; - Tcl_ObjType *typePtr; - int result; + int objc; + Tcl_Obj **objv; + + /* + * Get the test for a valid list out of the way first. + */ + + if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { + return TCL_ERROR; + } /* - * This code assumes that types names do not contain embedded NULLs. + * Type names are NUL-terminated, not counted strings. + * This code relies on that. */ Tcl_MutexLock(&tableMutex); for (hPtr = Tcl_FirstHashEntry(&typeTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr); - result = Tcl_ListObjAppendElement(interp, objPtr, - Tcl_NewStringObj(typePtr->name, -1)); - if (result == TCL_ERROR) { - Tcl_MutexUnlock(&tableMutex); - return result; - } + Tcl_ListObjAppendElement(NULL, objPtr, + Tcl_NewStringObj(Tcl_GetHashKey(&typeTable, hPtr), -1)); } Tcl_MutexUnlock(&tableMutex); return TCL_OK; } @@ -453,13 +529,12 @@ * Tcl_GetObjType -- * * This procedure looks up an object type by name. * * Results: - * If an object type with name matching "typeName" is found, a pointer - * to its Tcl_ObjType structure is returned; otherwise, NULL is - * returned. + * If an object type with name matching "typeName" is found, a pointer to + * its Tcl_ObjType structure is returned; otherwise, NULL is returned. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -468,21 +543,19 @@ Tcl_ObjType * Tcl_GetObjType(typeName) CONST char *typeName; /* Name of Tcl object type to look up. */ { register Tcl_HashEntry *hPtr; - Tcl_ObjType *typePtr; + Tcl_ObjType *typePtr = NULL; Tcl_MutexLock(&tableMutex); hPtr = Tcl_FindHashEntry(&typeTable, typeName); if (hPtr != (Tcl_HashEntry *) NULL) { typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr); - Tcl_MutexUnlock(&tableMutex); - return typePtr; } Tcl_MutexUnlock(&tableMutex); - return NULL; + return typePtr; } /* *---------------------------------------------------------------------- * @@ -490,14 +563,14 @@ * * Convert the Tcl object "objPtr" to have type "typePtr" if possible. * * Results: * The return value is TCL_OK on success and TCL_ERROR on failure. If - * TCL_ERROR is returned, then the interpreter's result contains an - * error message unless "interp" is NULL. Passing a NULL "interp" - * allows this procedure to be used as a test whether the conversion - * could be done (and in fact was done). + * TCL_ERROR is returned, then the interpreter's result contains an error + * message unless "interp" is NULL. Passing a NULL "interp" allows this + * procedure to be used as a test whether the conversion could be done + * (and in fact was done). * * Side effects: * Any internal representation for the old type is freed. * *---------------------------------------------------------------------- @@ -512,12 +585,12 @@ if (objPtr->typePtr == typePtr) { return TCL_OK; } /* - * Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal - * form as appropriate for the target type. This frees the old internal + * Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal form + * as appropriate for the target type. This frees the old internal * representation. */ if (typePtr->setFromAnyProc == NULL) { Tcl_Panic("may not convert object to type %s", typePtr->name); @@ -529,35 +602,38 @@ /* *---------------------------------------------------------------------- * * TclDbInitNewObj -- * - * Called via the TclNewObj or TclDbNewObj macros when TCL_MEM_DEBUG - * is enabled. This function will initialize the members of a - * Tcl_Obj struct. Initilization would be done inline via the - * TclNewObj macro when compiling without TCL_MEM_DEBUG. + * Called via the TclNewObj or TclDbNewObj macros when TCL_MEM_DEBUG is + * enabled. This function will initialize the members of a Tcl_Obj + * struct. Initilization would be done inline via the TclNewObj macro + * when compiling without TCL_MEM_DEBUG. * * Results: * The Tcl_Obj struct members are initialized. * * Side effects: * None. *---------------------------------------------------------------------- */ + #ifdef TCL_MEM_DEBUG void TclDbInitNewObj(objPtr) register Tcl_Obj *objPtr; { objPtr->refCount = 0; objPtr->bytes = tclEmptyStringRep; objPtr->length = 0; objPtr->typePtr = NULL; -# ifdef TCL_THREADS + +#ifdef TCL_THREADS /* - * Add entry to a thread local map used to check if a Tcl_Obj - * was allocated by the currently executing thread. + * Add entry to a thread local map used to check if a Tcl_Obj was + * allocated by the currently executing thread. */ + if (!TclInExit()) { Tcl_HashEntry *hPtr; Tcl_HashTable *tablePtr; int new; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -572,11 +648,11 @@ if (!new) { Tcl_Panic("expected to create new entry for object map"); } Tcl_SetHashValue(hPtr, NULL); } -# endif /* TCL_THREADS */ +#endif /* TCL_THREADS */ } #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- @@ -584,24 +660,24 @@ * Tcl_NewObj -- * * This procedure is normally called when not debugging: i.e., when * TCL_MEM_DEBUG is not defined. It creates new Tcl objects that denote * the empty string. These objects have a NULL object type and NULL - * string representation byte pointer. Type managers call this routine - * to allocate new objects that they further initialize. + * string representation byte pointer. Type managers call this routine to + * allocate new objects that they further initialize. * - * When TCL_MEM_DEBUG is defined, this procedure just returns the - * result of calling the debugging version Tcl_DbNewObj. + * When TCL_MEM_DEBUG is defined, this procedure just returns the result + * of calling the debugging version Tcl_DbNewObj. * * Results: * The result is a newly allocated object that represents the empty - * string. The new object's typePtr is set NULL and its ref count - * is set to 0. + * string. The new object's typePtr is set NULL and its ref count is set + * to 0. * * Side effects: - * If compiling with TCL_COMPILE_STATS, this procedure increments - * the global count of allocated objects (tclObjsAlloced). + * If compiling with TCL_COMPILE_STATS, this procedure increments the + * global count of allocated objects (tclObjsAlloced). * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG @@ -619,12 +695,11 @@ Tcl_NewObj() { register Tcl_Obj *objPtr; /* - * Use the macro defined in tclInt.h - it will use the - * correct allocator. + * Use the macro defined in tclInt.h - it will use the correct allocator. */ TclNewObj(objPtr); return objPtr; } @@ -635,26 +710,26 @@ * * Tcl_DbNewObj -- * * This procedure is normally called when debugging: i.e., when * TCL_MEM_DEBUG is defined. It creates new Tcl objects that denote the - * empty string. It is the same as the Tcl_NewObj procedure above - * except that it calls Tcl_DbCkalloc directly with the file name and - * line number from its caller. This simplifies debugging since then - * the [memory active] command will report the correct file name and line + * empty string. It is the same as the Tcl_NewObj procedure above except + * that it calls Tcl_DbCkalloc directly with the file name and line + * number from its caller. This simplifies debugging since then the + * [memory active] command will report the correct file name and line * number when reporting objects that haven't been freed. * * When TCL_MEM_DEBUG is not defined, this procedure just returns the * result of calling Tcl_NewObj. * * Results: - * The result is a newly allocated that represents the empty string. - * The new object's typePtr is set NULL and its ref count is set to 0. + * The result is a newly allocated that represents the empty string. The + * new object's typePtr is set NULL and its ref count is set to 0. * * Side effects: - * If compiling with TCL_COMPILE_STATS, this procedure increments - * the global count of allocated objects (tclObjsAlloced). + * If compiling with TCL_COMPILE_STATS, this procedure increments the + * global count of allocated objects (tclObjsAlloced). * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG @@ -661,18 +736,17 @@ Tcl_Obj * Tcl_DbNewObj(file, line) register CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ - register int line; /* Line number in the source file; used - * for debugging. */ + register int line; /* Line number in the source file; used for + * debugging. */ { register Tcl_Obj *objPtr; /* - * Use the macro defined in tclInt.h - it will use the - * correct allocator. + * Use the macro defined in tclInt.h - it will use the correct allocator. */ TclDbNewObj(objPtr, file, line); return objPtr; } @@ -680,12 +754,12 @@ Tcl_Obj * Tcl_DbNewObj(file, line) CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { return Tcl_NewObj(); } #endif /* TCL_MEM_DEBUG */ @@ -692,12 +766,12 @@ /* *---------------------------------------------------------------------- * * TclAllocateFreeObjects -- * - * Procedure to allocate a number of free Tcl_Objs. This is done using - * a single ckalloc to reduce the overhead for Tcl_Obj allocation. + * Procedure to allocate a number of free Tcl_Objs. This is done using a + * single ckalloc to reduce the overhead for Tcl_Obj allocation. * * Assumes mutex is held. * * Results: * None. @@ -721,12 +795,14 @@ register int i; /* * This has been noted by Purify to be a potential leak. The problem is * that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated - * Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of - * actually freeing the memory. These never do get freed properly. + * Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of actually + * freeing the memory. TclFinalizeObjects() does not ckfree() this memory, + * but leaves it to Tcl's memory subsystem finalization to release it. + * Purify apparently can't figure that out, and fires a false alarm. */ basePtr = (char *) ckalloc(bytesToAlloc); memset(basePtr, 0, bytesToAlloc); @@ -744,26 +820,25 @@ /* *---------------------------------------------------------------------- * * TclFreeObj -- * - * This procedure frees the memory associated with the argument - * object. It is called by the tcl.h macro Tcl_DecrRefCount when an - * object's ref count is zero. It is only "public" since it must - * be callable by that macro wherever the macro is used. It should not - * be directly called by clients. + * This procedure frees the memory associated with the argument object. + * It is called by the tcl.h macro Tcl_DecrRefCount when an object's ref + * count is zero. It is only "public" since it must be callable by that + * macro wherever the macro is used. It should not be directly called by + * clients. * * Results: * None. * * Side effects: - * Deallocates the storage for the object's Tcl_Obj structure - * after deallocating the string representation and calling the - * type-specific Tcl_FreeInternalRepProc to deallocate the object's - * internal representation. If compiling with TCL_COMPILE_STATS, - * this procedure increments the global count of freed objects - * (tclObjsFreed). + * Deallocates the storage for the object's Tcl_Obj structure after + * deallocating the string representation and calling the type-specific + * Tcl_FreeInternalRepProc to deallocate the object's internal + * representation. If compiling with TCL_COMPILE_STATS, this procedure + * increments the global count of freed objects (tclObjsFreed). * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG @@ -770,63 +845,113 @@ void TclFreeObj(objPtr) register Tcl_Obj *objPtr; /* The object to be freed. */ { register Tcl_ObjType *typePtr = objPtr->typePtr; + /* * This macro declares a variable, so must come here... */ - TclObjInitDeletionContext(context); + + ObjInitDeletionContext(context); if (objPtr->refCount < -1) { Tcl_Panic("Reference count for %lx was negative", objPtr); } - if (TclObjDeletePending(context)) { - TclPushObjToDelete(context, objPtr); + if (ObjDeletePending(context)) { + PushObjToDelete(context, objPtr); } else { if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { - TclObjDeletionLock(context); + ObjDeletionLock(context); typePtr->freeIntRepProc(objPtr); - TclObjDeletionUnlock(context); + ObjDeletionUnlock(context); } - Tcl_InvalidateStringRep(objPtr); + TclInvalidateStringRep(objPtr); Tcl_MutexLock(&tclObjMutex); ckfree((char *) objPtr); Tcl_MutexUnlock(&tclObjMutex); #ifdef TCL_COMPILE_STATS tclObjsFreed++; #endif /* TCL_COMPILE_STATS */ - TclObjDeletionLock(context); - while (TclObjOnStack(context)) { + ObjDeletionLock(context); + while (ObjOnStack(context)) { Tcl_Obj *objToFree; - TclPopObjToDelete(context,objToFree); + PopObjToDelete(context,objToFree); TclFreeIntRep(objToFree); Tcl_MutexLock(&tclObjMutex); ckfree((char *) objToFree); Tcl_MutexUnlock(&tclObjMutex); #ifdef TCL_COMPILE_STATS tclObjsFreed++; #endif /* TCL_COMPILE_STATS */ } - TclObjDeletionUnlock(context); + ObjDeletionUnlock(context); } } #else /* TCL_MEM_DEBUG */ void TclFreeObj(objPtr) register Tcl_Obj *objPtr; /* The object to be freed. */ { - TclObjInitDeletionContext(context); - if (TclObjDeletePending(context)) { - TclPushObjToDelete(context, objPtr); + if (!objPtr->typePtr || !objPtr->typePtr->freeIntRepProc) { + /* + * objPtr can be freed safely, as it will not attempt to free any + * other objects: it will not cause recursive calls to this function. + */ + + if (objPtr->bytes && (objPtr->bytes != tclEmptyStringRep)) { + ckfree((char *) objPtr->bytes); + } + TclFreeObjStorage(objPtr); + TclIncrObjsFreed(); } else { - TclFreeObjMacro(context, objPtr); + /* + * This macro declares a variable, so must come here... + */ + + ObjInitDeletionContext(context); + + if (ObjDeletePending(context)) { + PushObjToDelete(context, objPtr); + } else { + /* + * Note that the contents of the while loop assume that the string + * rep has already been freed and we don't want to do anything + * fancy with adding to the queue inside ourselves. Must take care + * to unstack the object first since freeing the internal rep can + * add further objects to the stack. The code assumes that it is + * the first thing in a block; all current usages in the core + * satisfy this. + */ + + ObjDeletionLock(context); + objPtr->typePtr->freeIntRepProc(objPtr); + ObjDeletionUnlock(context); + + if (objPtr->bytes && (objPtr->bytes != tclEmptyStringRep)) { + ckfree((char *) objPtr->bytes); + } + TclFreeObjStorage(objPtr); + TclIncrObjsFreed(); + ObjDeletionLock(context); + while (ObjOnStack(context)) { + Tcl_Obj *objToFree; + PopObjToDelete(context,objToFree); + if ((objToFree->typePtr != NULL) + && (objToFree->typePtr->freeIntRepProc != NULL)) { + objToFree->typePtr->freeIntRepProc(objToFree); + } + TclFreeObjStorage(objToFree); + TclIncrObjsFreed(); + } + ObjDeletionUnlock(context); + } } } #endif /* @@ -836,26 +961,26 @@ * * Create and return a new object that is a duplicate of the argument * object. * * Results: - * The return value is a pointer to a newly created Tcl_Obj. This - * object has reference count 0 and the same type, if any, as the - * source object objPtr. Also: + * The return value is a pointer to a newly created Tcl_Obj. This object + * has reference count 0 and the same type, if any, as the source object + * objPtr. Also: * 1) If the source object has a valid string rep, we copy it; - * otherwise, the duplicate's string rep is set NULL to mark - * it invalid. + * otherwise, the duplicate's string rep is set NULL to mark it + * invalid. * 2) If the source object has an internal representation (i.e. its - * typePtr is non-NULL), the new object's internal rep is set to - * a copy; otherwise the new internal rep is marked invalid. + * typePtr is non-NULL), the new object's internal rep is set to a + * copy; otherwise the new internal rep is marked invalid. * * Side effects: - * What constitutes "copying" the internal representation depends on - * the type. For example, if the argument object is a list, - * the element objects it points to will not actually be copied but - * will be shared with the duplicate list. That is, the ref counts of - * the element objects will be incremented. + * What constitutes "copying" the internal representation depends on the + * type. For example, if the argument object is a list, the element + * objects it points to will not actually be copied but will be shared + * with the duplicate list. That is, the ref counts of the element + * objects will be incremented. * *---------------------------------------------------------------------- */ Tcl_Obj * @@ -905,12 +1030,12 @@ *---------------------------------------------------------------------- */ char * Tcl_GetString(objPtr) - register Tcl_Obj *objPtr; /* Object whose string rep byte pointer - * should be returned. */ + register Tcl_Obj *objPtr; /* Object whose string rep byte pointer should + * be returned. */ { if (objPtr->bytes != NULL) { return objPtr->bytes; } @@ -925,20 +1050,20 @@ /* *---------------------------------------------------------------------- * * Tcl_GetStringFromObj -- * - * Returns the string representation's byte array pointer and length - * for an object. + * Returns the string representation's byte array pointer and length for + * an object. * * Results: - * Returns a pointer to the string representation of objPtr. If - * lengthPtr isn't NULL, the length of the string representation is - * stored at *lengthPtr. The byte array referenced by the returned - * pointer must not be modified by the caller. Furthermore, the - * caller must copy the bytes if they need to retain them since the - * object's string rep can change as a result of other operations. + * Returns a pointer to the string representation of objPtr. If lengthPtr + * isn't NULL, the length of the string representation is stored at + * *lengthPtr. The byte array referenced by the returned pointer must not + * be modified by the caller. Furthermore, the caller must copy the bytes + * if they need to retain them since the object's string rep can change + * as a result of other operations. * * Side effects: * May call the object's updateStringProc to update the string * representation from the internal representation. * @@ -977,45 +1102,41 @@ * * Results: * None. * * Side effects: - * Deallocates the storage for any old string representation, then - * sets the string representation NULL to mark it invalid. + * Deallocates the storage for any old string representation, then sets + * the string representation NULL to mark it invalid. * *---------------------------------------------------------------------- */ void Tcl_InvalidateStringRep(objPtr) - register Tcl_Obj *objPtr; /* Object whose string rep byte pointer - * should be freed. */ -{ - if (objPtr->bytes != NULL) { - if (objPtr->bytes != tclEmptyStringRep) { - ckfree((char *) objPtr->bytes); - } - objPtr->bytes = NULL; - } -} + register Tcl_Obj *objPtr; /* Object whose string rep byte pointer should + * be freed. */ +{ + TclInvalidateStringRep(objPtr); +} + /* *---------------------------------------------------------------------- * * Tcl_NewBooleanObj -- * * This procedure is normally called when not debugging: i.e., when - * TCL_MEM_DEBUG is not defined. It creates a new boolean object and - * initializes it from the argument boolean value. A nonzero - * "boolValue" is coerced to 1. + * TCL_MEM_DEBUG is not defined. It creates a new Tcl_Obj and + * initializes it from the argument boolean value. A nonzero "boolValue" + * is coerced to 1. * - * When TCL_MEM_DEBUG is defined, this procedure just returns the - * result of calling the debugging version Tcl_DbNewBooleanObj. + * When TCL_MEM_DEBUG is defined, this procedure just returns the result + * of calling the debugging version Tcl_DbNewBooleanObj. * * Results: - * The newly created object is returned. This object will have an - * invalid string representation. The returned object has ref count 0. + * The newly created object is returned. This object will have an invalid + * string representation. The returned object has ref count 0. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -1037,15 +1158,11 @@ Tcl_NewBooleanObj(boolValue) register int boolValue; /* Boolean used to initialize new object. */ { register Tcl_Obj *objPtr; - TclNewObj(objPtr); - objPtr->bytes = NULL; - - objPtr->internalRep.longValue = (boolValue? 1 : 0); - objPtr->typePtr = &tclBooleanType; + TclNewBooleanObj(objPtr, boolValue); return objPtr; } #endif /* TCL_MEM_DEBUG */ /* @@ -1056,19 +1173,19 @@ * This procedure is normally called when debugging: i.e., when * TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the * same as the Tcl_NewBooleanObj procedure above except that it calls * Tcl_DbCkalloc directly with the file name and line number from its * caller. This simplifies debugging since then the [memory active] - * command will report the correct file name and line number when + * command will report the correct file name and line number when * reporting objects that haven't been freed. * * When TCL_MEM_DEBUG is not defined, this procedure just returns the * result of calling Tcl_NewBooleanObj. * * Results: - * The newly created object is returned. This object will have an - * invalid string representation. The returned object has ref count 0. + * The newly created object is returned. This object will have an invalid + * string representation. The returned object has ref count 0. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -1079,20 +1196,20 @@ Tcl_Obj * Tcl_DbNewBooleanObj(boolValue, file, line) register int boolValue; /* Boolean used to initialize new object. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; objPtr->internalRep.longValue = (boolValue? 1 : 0); - objPtr->typePtr = &tclBooleanType; + objPtr->typePtr = &tclIntType; return objPtr; } #else /* if not TCL_MEM_DEBUG */ @@ -1099,12 +1216,12 @@ Tcl_Obj * Tcl_DbNewBooleanObj(boolValue, file, line) register int boolValue; /* Boolean used to initialize new object. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { return Tcl_NewBooleanObj(boolValue); } #endif /* TCL_MEM_DEBUG */ @@ -1118,12 +1235,12 @@ * * Results: * None. * * Side effects: - * The object's old string rep, if any, is freed. Also, any old - * internal rep is freed. + * The object's old string rep, if any, is freed. Also, any old internal + * rep is freed. * *---------------------------------------------------------------------- */ void @@ -1133,33 +1250,28 @@ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetBooleanObj called with shared object"); } - TclFreeIntRep(objPtr); - objPtr->internalRep.longValue = (boolValue? 1 : 0); - objPtr->typePtr = &tclBooleanType; - Tcl_InvalidateStringRep(objPtr); + TclSetBooleanObj(objPtr, boolValue); } /* *---------------------------------------------------------------------- * * Tcl_GetBooleanFromObj -- * - * Attempt to return a boolean from the Tcl object "objPtr". If the - * object is not already a boolean, an attempt will be made to convert - * it to one. + * Attempt to return a boolean from the Tcl object "objPtr". This + * includes conversion from any of Tcl's numeric types. * * Results: * The return value is a standard Tcl object result. If an error occurs * during conversion, an error message is left in the interpreter's * result unless "interp" is NULL. * * Side effects: - * If the object is not already a boolean, the conversion will free - * any old internal representation. + * The intrep of *objPtr may be changed. * *---------------------------------------------------------------------- */ int @@ -1166,22 +1278,52 @@ Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr; /* The object from which to get boolean. */ register int *boolPtr; /* Place to store resulting boolean. */ { - register int result; - - if (objPtr->typePtr == &tclBooleanType) { - result = TCL_OK; - } else { - result = SetBooleanFromAny(interp, objPtr); - } - - if (result == TCL_OK) { - *boolPtr = (int) objPtr->internalRep.longValue; - } - return result; + do { + if (objPtr->typePtr == &tclIntType) { + *boolPtr = (objPtr->internalRep.longValue != 0); + return TCL_OK; + } + 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 + 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; } /* *---------------------------------------------------------------------- * @@ -1194,266 +1336,178 @@ * The return value is a standard 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 integer 1 or 0 is stored as "objPtr"s - * internal representation and the type of "objPtr" is set to boolean. + * If no error occurs, an integer 1 or 0 is stored as "objPtr"s internal + * representation and the type of "objPtr" is set to boolean. * *---------------------------------------------------------------------- */ static int SetBooleanFromAny(interp, objPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr; /* The object to convert. */ { - char *string, *end; - register char c; - char lowerCase[8]; - int newBool, length; - register int i; - - /* - * Get the string representation. Make it up-to-date if necessary. - */ - - string = Tcl_GetStringFromObj(objPtr, &length); - - /* - * Use the obvious shortcuts for numerical values; if objPtr is not - * of numerical type, parse its string rep. - */ - - if (objPtr->typePtr == &tclIntType) { - newBool = (objPtr->internalRep.longValue != 0); - goto goodBoolean; - } else if (objPtr->typePtr == &tclDoubleType) { - newBool = (objPtr->internalRep.doubleValue != 0.0); - goto goodBoolean; - } else if (objPtr->typePtr == &tclWideIntType) { - newBool = (objPtr->internalRep.wideValue != 0); - goto goodBoolean; - } - - /* - * Parse the string as a boolean. We use an implementation here - * that doesn't report errors in interp if interp is NULL. - * - * First we define a macro to factor out the to-lower-case code. - * The len parameter is the maximum number of characters to copy - * to allow the following comparisons to proceed correctly, - * including (properly) the trailing \0 character. This is done - * in multiple places so the number of copying steps is minimised - * and only performed when needed. - */ - -#define SBFA_TOLOWER(len) \ - for (i=0 ; i<(len) && ibytes == NULL) { + if (objPtr->typePtr == &tclIntType) { + switch (objPtr->internalRep.longValue) { + case 0L: case 1L: + return TCL_OK; + } + 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; + } + } + + 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); + + if ((length == 0) || (length > 5)) { + /* longest valid boolean string rep. is "false" */ + return TCL_ERROR; + } + + switch (str[0]) { + case '0': + if (length == 1) { + newBool = 0; + goto numericBoolean; + } + return TCL_ERROR; + case '1': + if (length == 1) { + newBool = 1; + goto numericBoolean; + } + return TCL_ERROR; + } + + /* + * Force to lower case for case-insensitive detection. Filter out known + * invalid characters at the same time. + */ + + for (i=0; i < length; i++) { + char c = str[i]; + switch (c) { + case 'A': case 'E': case 'F': case 'L': case 'N': + case 'O': case 'R': case 'S': case 'T': case 'U': case 'Y': + lowerCase[i] = c + (char) ('a' - 'A'); + break; + case 'a': case 'e': case 'f': case 'l': case 'n': + case 'o': case 'r': case 's': case 't': case 'u': case 'y': + lowerCase[i] = c; + break; + default: + return TCL_ERROR; + } + } + lowerCase[length] = 0; + switch (lowerCase[0]) { + case 'y': /* * Checking the 'y' is redundant, but makes the code clearer. */ if (strncmp(lowerCase, "yes", (size_t) length) == 0) { newBool = 1; goto goodBoolean; } - goto badBoolean; - case 'n': case 'N': - SBFA_TOLOWER(3); + return TCL_ERROR; + case 'n': if (strncmp(lowerCase, "no", (size_t) length) == 0) { newBool = 0; goto goodBoolean; } - goto badBoolean; - case 't': case 'T': - SBFA_TOLOWER(5); + return TCL_ERROR; + case 't': if (strncmp(lowerCase, "true", (size_t) length) == 0) { newBool = 1; goto goodBoolean; } - goto badBoolean; - case 'f': case 'F': - SBFA_TOLOWER(6); + return TCL_ERROR; + case 'f': if (strncmp(lowerCase, "false", (size_t) length) == 0) { newBool = 0; goto goodBoolean; } - goto badBoolean; - case 'o': case 'O': + return TCL_ERROR; + case 'o': if (length < 2) { - goto badBoolean; + return TCL_ERROR; } - SBFA_TOLOWER(4); if (strncmp(lowerCase, "on", (size_t) length) == 0) { newBool = 1; goto goodBoolean; } else if (strncmp(lowerCase, "off", (size_t) length) == 0) { newBool = 0; goto goodBoolean; } - goto badBoolean; -#undef SBFA_TOLOWER - case '0': - if (string[1] == '\0') { - newBool = 0; - goto goodBoolean; - } - goto parseNumeric; - case '1': - if (string[1] == '\0') { - newBool = 1; - goto goodBoolean; - } - /* deliberate fall-through */ + return TCL_ERROR; default: - parseNumeric: - { - double dbl; - /* - * Boolean values can be extracted from ints or doubles. - * Note that we don't use strtoul or strtoull here because - * we don't care about what the value is, just whether it - * is equal to zero or not. - */ -#ifdef TCL_WIDE_INT_IS_LONG - newBool = strtol(string, &end, 0); - if (end != string) { - /* - * Make sure the string has no garbage after the end of - * the int. - */ - while ((end < (string+length)) - && isspace(UCHAR(*end))) { /* INTL: ISO only */ - end++; - } - if (end == (string+length)) { - newBool = (newBool != 0); - goto goodBoolean; - } - } -#else /* !TCL_WIDE_INT_IS_LONG */ - Tcl_WideInt wide = strtoll(string, &end, 0); - if (end != string) { - /* - * Make sure the string has no garbage after the end of - * the wide int. - */ - while ((end < (string+length)) - && isspace(UCHAR(*end))) { /* INTL: ISO only */ - end++; - } - if (end == (string+length)) { - newBool = (wide != Tcl_LongAsWide(0)); - goto goodBoolean; - } - } -#endif /* TCL_WIDE_INT_IS_LONG */ - /* - * Still might be a string containing the characters - * representing an int or double that wasn't handled - * above. This would be a string like "27" or "1.0" that - * is non-zero and not "1". Such a string would result in - * the boolean value true. We try converting to double. If - * that succeeds and the resulting double is non-zero, we - * have a "true". Note that numbers can't have embedded - * NULLs. - */ - - dbl = strtod(string, &end); - if (end == string) { - goto badBoolean; - } - - /* - * Make sure the string has no garbage after the end of - * the double. - */ - - while ((end < (string+length)) - && isspace(UCHAR(*end))) { /* INTL: ISO only */ - end++; - } - if (end != (string+length)) { - goto badBoolean; - } - newBool = (dbl != 0.0); - } - } - - /* - * Free the old internalRep before setting the new one. We do this as - * late as possible to allow the conversion code, in particular + return TCL_ERROR; + } + + /* + * 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. */ - goodBoolean: + goodBoolean: TclFreeIntRep(objPtr); objPtr->internalRep.longValue = newBool; objPtr->typePtr = &tclBooleanType; return TCL_OK; - badBoolean: - if (interp != NULL) { - Tcl_Obj *msg = - Tcl_NewStringObj("expected boolean value but got \"", -1); - TclAppendLimitedToObj(msg, string, length, 50, ""); - Tcl_AppendToObj(msg, "\"", -1); - Tcl_SetObjResult(interp, msg); - } - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * UpdateStringOfBoolean -- - * - * Update the string representation for a boolean object. - * Note: This procedure does not free an existing old string rep - * so storage will be lost if this has not already been done. - * - * Results: - * None. - * - * Side effects: - * The object's string is set to a valid string that results from - * the boolean-to-string conversion. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfBoolean(objPtr) - register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ -{ - char *s = ckalloc((unsigned) 2); - - s[0] = (char) (objPtr->internalRep.longValue? '1' : '0'); - s[1] = '\0'; - objPtr->bytes = s; - objPtr->length = 1; + numericBoolean: + TclFreeIntRep(objPtr); + objPtr->internalRep.longValue = newBool; + objPtr->typePtr = &tclIntType; + return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -1461,12 +1515,12 @@ * * This procedure is normally called when not debugging: i.e., when * TCL_MEM_DEBUG is not defined. It creates a new double object and * initializes it from the argument double value. * - * When TCL_MEM_DEBUG is defined, this procedure just returns the - * result of calling the debugging version Tcl_DbNewDoubleObj. + * When TCL_MEM_DEBUG is defined, this procedure just returns the result + * of calling the debugging version Tcl_DbNewDoubleObj. * * Results: * The newly created object is returned. This object will have an * invalid string representation. The returned object has ref count 0. * @@ -1492,15 +1546,11 @@ Tcl_NewDoubleObj(dblValue) register double dblValue; /* Double used to initialize the object. */ { register Tcl_Obj *objPtr; - TclNewObj(objPtr); - objPtr->bytes = NULL; - - objPtr->internalRep.doubleValue = dblValue; - objPtr->typePtr = &tclDoubleType; + TclNewDoubleObj(objPtr, dblValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ /* @@ -1511,19 +1561,19 @@ * This procedure is normally called when debugging: i.e., when * TCL_MEM_DEBUG is defined. It creates new double objects. It is the * same as the Tcl_NewDoubleObj procedure above except that it calls * Tcl_DbCkalloc directly with the file name and line number from its * caller. This simplifies debugging since then the [memory active] - * command will report the correct file name and line number when + * command will report the correct file name and line number when * reporting objects that haven't been freed. * * When TCL_MEM_DEBUG is not defined, this procedure just returns the * result of calling Tcl_NewDoubleObj. * * Results: - * The newly created object is returned. This object will have an - * invalid string representation. The returned object has ref count 0. + * The newly created object is returned. This object will have an invalid + * string representation. The returned object has ref count 0. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -1534,12 +1584,12 @@ Tcl_Obj * Tcl_DbNewDoubleObj(dblValue, file, line) register double dblValue; /* Double used to initialize the object. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; @@ -1554,12 +1604,12 @@ Tcl_Obj * Tcl_DbNewDoubleObj(dblValue, file, line) register double dblValue; /* Double used to initialize the object. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { return Tcl_NewDoubleObj(dblValue); } #endif /* TCL_MEM_DEBUG */ @@ -1573,12 +1623,12 @@ * * Results: * None. * * Side effects: - * The object's old string rep, if any, is freed. Also, any old - * internal rep is freed. + * The object's old string rep, if any, is freed. Also, any old internal + * rep is freed. * *---------------------------------------------------------------------- */ void @@ -1588,33 +1638,29 @@ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetDoubleObj called with shared object"); } - TclFreeIntRep(objPtr); - objPtr->internalRep.doubleValue = dblValue; - objPtr->typePtr = &tclDoubleType; - Tcl_InvalidateStringRep(objPtr); + TclSetDoubleObj(objPtr, dblValue); } /* *---------------------------------------------------------------------- * * Tcl_GetDoubleFromObj -- * - * Attempt to return a double from the Tcl object "objPtr". If the - * object is not already a double, an attempt will be made to convert - * it to one. + * Attempt to return a double from the Tcl object "objPtr". If the object + * is not already a double, an attempt will be made to convert it to one. * * Results: * The return value is a standard Tcl object result. If an error occurs * during conversion, an error message is left in the interpreter's * result unless "interp" is NULL. * * Side effects: - * If the object is not already a double, the conversion will free - * any old internal representation. + * If the object is not already a double, the conversion will free any + * old internal representation. * *---------------------------------------------------------------------- */ int @@ -1621,25 +1667,40 @@ Tcl_GetDoubleFromObj(interp, objPtr, dblPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ 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 == &tclDoubleType) { - *dblPtr = objPtr->internalRep.doubleValue; - return TCL_OK; - } else if (objPtr->typePtr == &tclIntType) { - *dblPtr = objPtr->internalRep.longValue; - return TCL_OK; - } - - result = SetDoubleFromAny(interp, objPtr); - if (result == TCL_OK) { - *dblPtr = objPtr->internalRep.doubleValue; - } - return result; + 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 (objPtr->typePtr == &tclIntType) { + *dblPtr = objPtr->internalRep.longValue; + 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; } /* *---------------------------------------------------------------------- * @@ -1663,88 +1724,31 @@ static int SetDoubleFromAny(interp, objPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr; /* The object to convert. */ { - 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 = strtod(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; - } - if (errno != 0) { - if (interp != NULL) { - TclExprFloatError(interp, newDouble); - } - 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; - } - - /* - * 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); } /* *---------------------------------------------------------------------- * * UpdateStringOfDouble -- * - * Update the string representation for a double-precision floating - * point object. This must obey the current tcl_precision value for + * Update the string representation for a double-precision floating point + * object. This must obey the current tcl_precision value for * double-to-string conversions. Note: This procedure does not free an * existing old string rep so storage will be lost if this has not * already been done. * * Results: * None. * * Side effects: - * The object's string is set to a valid string that results from - * the double-to-string conversion. + * The object's string is set to a valid string that results from the + * double-to-string conversion. * *---------------------------------------------------------------------- */ static void @@ -1772,22 +1776,22 @@ * Tcl_NewIntObj to create a new integer object end up calling the * debugging procedure Tcl_DbNewLongObj instead. * * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, * calls to Tcl_NewIntObj result in a call to one of the two - * Tcl_NewIntObj implementations below. We provide two implementations - * so that the Tcl core can be compiled to do memory debugging of the - * core even if a client does not request it for itself. + * Tcl_NewIntObj implementations below. We provide two implementations so + * that the Tcl core can be compiled to do memory debugging of the core + * even if a client does not request it for itself. * * Integer and long integer objects share the same "integer" type * implementation. We store all integers as longs and Tcl_GetIntFromObj - * checks whether the current value of the long can be represented by - * an int. + * checks whether the current value of the long can be represented by an + * int. * * Results: - * The newly created object is returned. This object will have an - * invalid string representation. The returned object has ref count 0. + * The newly created object is returned. This object will have an invalid + * string representation. The returned object has ref count 0. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -1809,15 +1813,11 @@ Tcl_NewIntObj(intValue) register int intValue; /* Int used to initialize the new object. */ { register Tcl_Obj *objPtr; - TclNewObj(objPtr); - objPtr->bytes = NULL; - - objPtr->internalRep.longValue = (long)intValue; - objPtr->typePtr = &tclIntType; + TclNewIntObj(objPtr, intValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ /* @@ -1830,12 +1830,12 @@ * * Results: * None. * * Side effects: - * The object's old string rep, if any, is freed. Also, any old - * internal rep is freed. + * The object's old string rep, if any, is freed. Also, any old internal + * rep is freed. * *---------------------------------------------------------------------- */ void @@ -1845,14 +1845,11 @@ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetIntObj called with shared object"); } - TclFreeIntRep(objPtr); - objPtr->internalRep.longValue = (long) intValue; - objPtr->typePtr = &tclIntType; - Tcl_InvalidateStringRep(objPtr); + TclSetIntObj(objPtr, intValue); } /* *---------------------------------------------------------------------- * @@ -1861,22 +1858,22 @@ * Attempt to return an int from the Tcl object "objPtr". If the object * is not already an int, an attempt will be made to convert it to one. * * Integer and long integer objects share the same "integer" type * implementation. We store all integers as longs and Tcl_GetIntFromObj - * checks whether the current value of the long can be represented by - * an int. + * checks whether the current value of the long can be represented by an + * int. * * Results: * The return value is a standard Tcl object result. If an error occurs - * during conversion or if the long integer held by the object - * can not be represented by an int, an error message is left in - * the interpreter's result unless "interp" is NULL. + * during conversion or if the long integer held by the object can not be + * represented by an int, an error message is left in the interpreter's + * result unless "interp" is NULL. * * Side effects: - * If the object is not already an int, the conversion will free - * any old internal representation. + * If the object is not already an int, the conversion will free any old + * internal representation. * *---------------------------------------------------------------------- */ int @@ -1883,246 +1880,68 @@ Tcl_GetIntFromObj(interp, objPtr, intPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr; /* The object from which to get a int. */ register int *intPtr; /* Place to store resulting int. */ { - register long l = 0; - int result; - - /* 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. */ - - if (objPtr->typePtr == &tclIntType) { - l = objPtr->internalRep.longValue; - } else if (objPtr->typePtr == &tclWideIntType) { -#ifndef TCL_WIDE_INT_IS_LONG - /* - * 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. - */ - Tcl_WideInt w = objPtr->internalRep.wideValue; - if (w >= -(Tcl_WideInt)(ULONG_MAX) - && w <= (Tcl_WideInt)(ULONG_MAX)) { - l = Tcl_WideAsLong(w); - } else { - goto tooBig; - } -#else - l = objPtr->internalRep.longValue; -#endif - } else { - Tcl_Panic("string->integer conversion failed to convert the obj."); - } - - if (((long)((int)l)) == l) { - *intPtr = (int)l; - return TCL_OK; - } -#ifndef TCL_WIDE_INT_IS_LONG - tooBig: -#endif - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent as non-long integer", - -1)); - } - return TCL_ERROR; + long l; + + if (Tcl_GetLongFromObj(interp, objPtr, &l) != TCL_OK) { + return TCL_ERROR; + } + if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < -(long)UINT_MAX))) { + if (interp != NULL) { + 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)l; + return TCL_OK; } /* *---------------------------------------------------------------------- * * SetIntFromAny -- * - * Attempts to force the internal representation for a Tcl object - * to tclIntType, specifically. + * Attempts to force the internal representation for a Tcl object to + * tclIntType, specifically. * * 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. + * 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. * *---------------------------------------------------------------------- */ static int 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; - int isWide = 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, but don't depend on strtoul to handle sign - * characters; it won't in some implementations. - */ - - 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; - } - 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; - } - - /* - * 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 the resulting integer will exceed the range of a long, - * put it into a wide instead. (Tcl Bug #868489) - */ - -#ifndef TCL_WIDE_INT_IS_LONG - if ((isNegative && newLong > (unsigned long) (LONG_MAX) + 1) - || (!isNegative && newLong > LONG_MAX)) { - isWide = 1; - } -#endif - - /* - * 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); - if (isWide) { - objPtr->internalRep.wideValue = - (isNegative ? -(Tcl_WideInt)newLong : (Tcl_WideInt)newLong); - objPtr->typePtr = &tclWideIntType; - } else { - objPtr->internalRep.longValue = - (isNegative ? -(long)newLong : (long)newLong); - objPtr->typePtr = &tclIntType; - } - return TCL_OK; + long l; + return Tcl_GetLongFromObj(interp, objPtr, &l); } /* *---------------------------------------------------------------------- * * UpdateStringOfInt -- * - * Update the string representation for an integer object. - * Note: This procedure does not free an existing old string rep - * so storage will be lost if this has not already been done. + * Update the string representation for an integer object. Note: This + * procedure does not free an existing old string rep so storage will be + * lost if this has not already been done. * * Results: * None. * * Side effects: - * The object's string is set to a valid string that results from - * the int-to-string conversion. + * The object's string is set to a valid string that results from the + * int-to-string conversion. * *---------------------------------------------------------------------- */ static void @@ -2143,27 +1962,27 @@ *---------------------------------------------------------------------- * * Tcl_NewLongObj -- * * If a client is compiled with TCL_MEM_DEBUG defined, calls to - * Tcl_NewLongObj to create a new long integer object end up calling - * the debugging procedure Tcl_DbNewLongObj instead. + * Tcl_NewLongObj to create a new long integer object end up calling the + * debugging procedure Tcl_DbNewLongObj instead. * * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, * calls to Tcl_NewLongObj result in a call to one of the two * Tcl_NewLongObj implementations below. We provide two implementations * so that the Tcl core can be compiled to do memory debugging of the * core even if a client does not request it for itself. * * Integer and long integer objects share the same "integer" type * implementation. We store all integers as longs and Tcl_GetIntFromObj - * checks whether the current value of the long can be represented by - * an int. + * checks whether the current value of the long can be represented by an + * int. * * Results: - * The newly created object is returned. This object will have an - * invalid string representation. The returned object has ref count 0. + * The newly created object is returned. This object will have an invalid + * string representation. The returned object has ref count 0. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -2187,15 +2006,11 @@ register long longValue; /* Long integer used to initialize the * new object. */ { register Tcl_Obj *objPtr; - TclNewObj(objPtr); - objPtr->bytes = NULL; - - objPtr->internalRep.longValue = longValue; - objPtr->typePtr = &tclIntType; + TclNewLongObj(objPtr, longValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ /* @@ -2202,30 +2017,29 @@ *---------------------------------------------------------------------- * * Tcl_DbNewLongObj -- * * If a client is compiled with TCL_MEM_DEBUG defined, calls to - * Tcl_NewIntObj and Tcl_NewLongObj to create new integer or - * long integer objects end up calling the debugging procedure - * Tcl_DbNewLongObj instead. We provide two implementations of - * Tcl_DbNewLongObj so that whether the Tcl core is compiled to do - * memory debugging of the core is independent of whether a client - * requests debugging for itself. - * - * When the core is compiled with TCL_MEM_DEBUG defined, - * Tcl_DbNewLongObj calls Tcl_DbCkalloc directly with the file name and - * line number from its caller. This simplifies debugging since then - * the [memory active] command will report the caller's file name and - * line number when reporting objects that haven't been freed. + * Tcl_NewIntObj and Tcl_NewLongObj to create new integer or long integer + * objects end up calling the debugging procedure Tcl_DbNewLongObj + * instead. We provide two implementations of Tcl_DbNewLongObj so that + * whether the Tcl core is compiled to do memory debugging of the core is + * independent of whether a client requests debugging for itself. + * + * When the core is compiled with TCL_MEM_DEBUG defined, Tcl_DbNewLongObj + * calls Tcl_DbCkalloc directly with the file name and line number from + * its caller. This simplifies debugging since then the [memory active] + * command will report the caller's file name and line number when + * reporting objects that haven't been freed. * * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, * this procedure just returns the result of calling Tcl_NewLongObj. * * Results: - * The newly created long integer object is returned. This object - * will have an invalid string representation. The returned object has - * ref count 0. + * The newly created long integer object is returned. This object will + * have an invalid string representation. The returned object has ref + * count 0. * * Side effects: * Allocates memory. * *---------------------------------------------------------------------- @@ -2233,16 +2047,16 @@ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewLongObj(longValue, file, line) - register long longValue; /* Long integer used to initialize the - * new object. */ + register long longValue; /* Long integer used to initialize the new + * object. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; @@ -2254,16 +2068,16 @@ #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_DbNewLongObj(longValue, file, line) - register long longValue; /* Long integer used to initialize the - * new object. */ + register long longValue; /* Long integer used to initialize the new + * object. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { return Tcl_NewLongObj(longValue); } #endif /* TCL_MEM_DEBUG */ @@ -2277,12 +2091,12 @@ * * Results: * None. * * Side effects: - * The object's old string rep, if any, is freed. Also, any old - * internal rep is freed. + * The object's old string rep, if any, is freed. Also, any old internal + * rep is freed. * *---------------------------------------------------------------------- */ void @@ -2293,23 +2107,20 @@ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetLongObj called with shared object"); } - TclFreeIntRep(objPtr); - objPtr->internalRep.longValue = longValue; - objPtr->typePtr = &tclIntType; - Tcl_InvalidateStringRep(objPtr); + TclSetLongObj(objPtr, longValue); } /* *---------------------------------------------------------------------- * * Tcl_GetLongFromObj -- * - * Attempt to return an long integer from the Tcl object "objPtr". If - * the object is not already an int object, an attempt will be made to + * Attempt to return an long integer from the Tcl object "objPtr". If the + * object is not already an int object, an attempt will be made to * convert it to one. * * Results: * The return value is a standard Tcl object result. If an error occurs * during conversion, an error message is left in the interpreter's @@ -2326,201 +2137,127 @@ Tcl_GetLongFromObj(interp, objPtr, longPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ 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; - } - } - -#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. - */ - 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)); - } - return TCL_ERROR; - } - } -#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, but don't depend on strtoull to handle sign - * characters; it won't in some implementations. - */ - - errno = 0; -#ifdef TCL_STRTOUL_SIGN_CHECK - for (; isspace(UCHAR(*p)) ; p++) { /* INTL: ISO space. */ - /* Empty loop body. */ - } - if (*p == '-') { - p++; - newWide = -((Tcl_WideInt)strtoull(p, &end, 0)); - } else if (*p == '+') { - p++; - newWide = strtoull(p, &end, 0); - } else -#else - newWide = strtoull(p, &end, 0); -#endif - 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; - } - 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; - } - - /* - * 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; - } - - /* - * 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; - } -#endif - objPtr->typePtr = &tclWideIntType; - return TCL_OK; -} + do { + if (objPtr->typePtr == &tclIntType) { + *longPtr = objPtr->internalRep.longValue; + return TCL_OK; + } +#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; + } + goto tooLarge; + } +#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; + } + 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 + 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 /* *---------------------------------------------------------------------- * * UpdateStringOfWideInt -- * - * Update the string representation for a wide integer object. - * Note: This procedure does not free an existing old string rep - * so storage will be lost if this has not already been done. + * Update the string representation for a wide integer object. Note: + * This procedure does not free an existing old string rep so storage + * will be lost if this has not already been done. * * Results: * None. * * Side effects: - * The object's string is set to a valid string that results from - * the wideInt-to-string conversion. + * The object's string is set to a valid string that results from the + * wideInt-to-string conversion. * *---------------------------------------------------------------------- */ -#ifndef TCL_WIDE_INT_IS_LONG static void UpdateStringOfWideInt(objPtr) register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ { char buffer[TCL_INTEGER_SPACE+2]; register unsigned len; register Tcl_WideInt wideVal = objPtr->internalRep.wideValue; /* - * Note that sprintf will generate a compiler warning under - * Mingw claiming %I64 is an unknown format specifier. - * Just ignore this warning. We can't use %L as the format - * specifier since that gets printed as a 32 bit value. + * Note that sprintf will generate a compiler warning under Mingw claiming + * %I64 is an unknown format specifier. Just ignore this warning. We can't + * use %L as the format specifier since that gets printed as a 32 bit + * value. */ + sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal); len = strlen(buffer); objPtr->bytes = ckalloc((unsigned) len + 1); memcpy(objPtr->bytes, buffer, len + 1); objPtr->length = len; } -#endif /* TCL_WIDE_INT_IS_LONG */ +#endif /* !NO_WIDE_TYPE */ /* *---------------------------------------------------------------------- * * Tcl_NewWideIntObj -- @@ -2529,17 +2266,17 @@ * Tcl_NewWideIntObj to create a new 64-bit integer object end up calling * the debugging procedure Tcl_DbNewWideIntObj instead. * * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, * calls to Tcl_NewWideIntObj result in a call to one of the two - * Tcl_NewWideIntObj implementations below. We provide two implementations - * so that the Tcl core can be compiled to do memory debugging of the - * core even if a client does not request it for itself. + * Tcl_NewWideIntObj implementations below. We provide two + * implementations so that the Tcl core can be compiled to do memory + * debugging of the core even if a client does not request it for itself. * * Results: - * The newly created object is returned. This object will have an - * invalid string representation. The returned object has ref count 0. + * The newly created object is returned. This object will have an invalid + * string representation. The returned object has ref count 0. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -2564,14 +2301,11 @@ * the new object. */ { register Tcl_Obj *objPtr; TclNewObj(objPtr); - objPtr->bytes = NULL; - - objPtr->internalRep.wideValue = wideValue; - objPtr->typePtr = &tclWideIntType; + Tcl_SetWideIntObj(objPtr, wideValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ /* @@ -2578,31 +2312,29 @@ *---------------------------------------------------------------------- * * Tcl_DbNewWideIntObj -- * * If a client is compiled with TCL_MEM_DEBUG defined, calls to - * Tcl_NewWideIntObj to create new wide integer end up calling - * the debugging procedure Tcl_DbNewWideIntObj instead. We - * provide two implementations of Tcl_DbNewWideIntObj so that - * whether the Tcl core is compiled to do memory debugging of the - * core is independent of whether a client requests debugging for - * itself. + * Tcl_NewWideIntObj to create new wide integer end up calling the + * debugging procedure Tcl_DbNewWideIntObj instead. We provide two + * implementations of Tcl_DbNewWideIntObj so that whether the Tcl core is + * compiled to do memory debugging of the core is independent of whether + * a client requests debugging for itself. * * When the core is compiled with TCL_MEM_DEBUG defined, - * Tcl_DbNewWideIntObj calls Tcl_DbCkalloc directly with the file - * name and line number from its caller. This simplifies - * debugging since then the checkmem command will report the - * caller's file name and line number when reporting objects that - * haven't been freed. + * Tcl_DbNewWideIntObj calls Tcl_DbCkalloc directly with the file name + * and line number from its caller. This simplifies debugging since then + * the checkmem command will report the caller's file name and line + * number when reporting objects that haven't been freed. * * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, * this procedure just returns the result of calling Tcl_NewWideIntObj. * * Results: - * The newly created wide integer object is returned. This object - * will have an invalid string representation. The returned object has - * ref count 0. + * The newly created wide integer object is returned. This object will + * have an invalid string representation. The returned object has ref + * count 0. * * Side effects: * Allocates memory. * *---------------------------------------------------------------------- @@ -2610,36 +2342,33 @@ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewWideIntObj(wideValue, file, line) - register Tcl_WideInt wideValue; /* Wide integer used to initialize - * the new object. */ - CONST char *file; /* The name of the source file - * calling this procedure; used for + register Tcl_WideInt wideValue; /* Wide integer used to initialize the + * new object. */ + CONST char *file; /* The name of the source file calling + * this procedure; used for * debugging. */ int line; /* Line number in the source file; * used for debugging. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); - objPtr->bytes = NULL; - - objPtr->internalRep.wideValue = wideValue; - objPtr->typePtr = &tclWideIntType; + Tcl_SetWideIntObj(objPtr, wideValue); return objPtr; } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_DbNewWideIntObj(wideValue, file, line) - register Tcl_WideInt wideValue; /* Long integer used to initialize - * the new object. */ - CONST char *file; /* The name of the source file - * calling this procedure; used for + register Tcl_WideInt wideValue; /* Long integer used to initialize the + * new object. */ + CONST char *file; /* The name of the source file calling + * this procedure; used for * debugging. */ int line; /* Line number in the source file; * used for debugging. */ { return Tcl_NewWideIntObj(wideValue); @@ -2649,19 +2378,19 @@ /* *---------------------------------------------------------------------- * * Tcl_SetWideIntObj -- * - * Modify an object to be a wide integer object and to have the - * specified wide integer value. + * Modify an object to be a wide integer object and to have the specified + * wide integer value. * * Results: * None. * * Side effects: - * The object's old string rep, if any, is freed. Also, any old - * internal rep is freed. + * The object's old string rep, if any, is freed. Also, any old internal + * rep is freed. * *---------------------------------------------------------------------- */ void @@ -2672,24 +2401,32 @@ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetWideIntObj called with shared object"); } - TclFreeIntRep(objPtr); - objPtr->internalRep.wideValue = wideValue; - objPtr->typePtr = &tclWideIntType; - Tcl_InvalidateStringRep(objPtr); + 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 + } } /* *---------------------------------------------------------------------- * * Tcl_GetWideIntFromObj -- * - * Attempt to return a wide integer from the Tcl object "objPtr". If - * the object is not already a wide int object, an attempt will be made - * to convert it to one. + * Attempt to return a wide integer from the Tcl object "objPtr". If the + * object is not already a wide int object, an attempt will be made to + * convert it to one. * * Results: * The return value is a standard Tcl object result. If an error occurs * during conversion, an error message is left in the interpreter's * result unless "interp" is NULL. @@ -2705,34 +2442,559 @@ Tcl_GetWideIntFromObj(interp, objPtr, wideIntPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ 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; +} + +/* + *---------------------------------------------------------------------- + * + * FreeBignum -- + * + * This procedure frees the internal rep of a bignum. + * + * Results: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +FreeBignum(Tcl_Obj *objPtr) +{ + mp_int toFree; /* Bignum to free */ + + UNPACK_BIGNUM(objPtr, toFree); + mp_clear(&toFree); + if (objPtr->internalRep.ptrAndLongRep.value < 0) { + ckfree((char *)objPtr->internalRep.ptrAndLongRep.ptr); + } +} + +/* + *---------------------------------------------------------------------- + * + * DupBignum -- + * + * This procedure duplicates the internal rep of a bignum. + * + * Results: + * None. + * + * Side effects: + * The destination object receies a copy of the source object + * + *---------------------------------------------------------------------- + */ + +static void +DupBignum(srcPtr, copyPtr) + Tcl_Obj* srcPtr; + Tcl_Obj* copyPtr; +{ + mp_int bignumVal; + mp_int bignumCopy; + + copyPtr->typePtr = &tclBignumType; + UNPACK_BIGNUM(srcPtr, bignumVal); + if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) { + Tcl_Panic("initialization failure in DupBignum"); + } + PACK_BIGNUM(bignumCopy, copyPtr); +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfBignum -- + * + * This procedure updates the string representation of a bignum object. + * + * Results: + * None. + * + * Side effects: + * The object's string is set to whatever results from the bignum- + * to-string conversion. + * + * The object's existing string representation is NOT freed; memory will leak + * if the string rep is still valid at the time this procedure is called. + */ + +static void +UpdateStringOfBignum(Tcl_Obj* objPtr) +{ + mp_int bignumVal; + int size; + int status; + char* stringVal; + + UNPACK_BIGNUM(objPtr, bignumVal); + status = mp_radix_size(&bignumVal, 10, &size); + if (status != MP_OKAY) { + Tcl_Panic("radix size failure in UpdateStringOfBignum"); + } + 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) { + Tcl_Panic("conversion failure in UpdateStringOfBignum"); + } + objPtr->bytes = stringVal; + objPtr->length = size - 1; /* size includes a trailing null byte */ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_NewBignumObj -- + * + * Creates an initializes a bignum object. + * + * Results: + * Returns the newly created object. + * + * Side effects: + * The bignum value is cleared, since ownership has transferred to Tcl. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG +#undef Tcl_NewBignumObj +Tcl_Obj* +Tcl_NewBignumObj(mp_int* bignumValue) +{ + return Tcl_DbNewBignumObj(bignumValue, "unknown", 0); +} +#else +Tcl_Obj * +Tcl_NewBignumObj(mp_int* bignumValue) +{ + Tcl_Obj* objPtr; + TclNewObj(objPtr); + Tcl_SetBignumObj(objPtr, bignumValue); + return objPtr; +} +#endif + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbNewBignumObj -- + * + * This procedure is normally called when debugging: that is, when + * TCL_MEM_DEBUG is defined. It constructs a bignum object, recording + * the creation point so that [memory active] can report it. + * + * Results: + * Returns the newly created object. + * + * Side effects: + * The bignum value is cleared, since ownership has transferred to Tcl. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG +Tcl_Obj* +Tcl_DbNewBignumObj(mp_int* bignumValue, CONST char* file, int line) +{ + Tcl_Obj* objPtr; + + TclDbNewObj(objPtr, file, line); + Tcl_SetBignumObj(objPtr, bignumValue); + return objPtr; +} +#else +Tcl_Obj* +Tcl_DbNewBignumObj(mp_int* bignumValue, CONST char* file, int line) +{ + return Tcl_NewBignumObj(bignumValue); +} +#endif + +/* + *---------------------------------------------------------------------- + * + * 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, + * 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 a copy of the value in objPtr, + * so it becomes the responsibility of the caller to call mp_clear on + * it. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetBignumFromObj( + Tcl_Interp* interp, /* Tcl interpreter for error reporting */ + Tcl_Obj* objPtr, /* Object to read */ + mp_int* bignumValue) /* Returned bignum value. */ +{ + 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. + * + *---------------------------------------------------------------------- + */ + +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); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetBignumObj -- + * + * This procedure sets the value of a Tcl_Obj to a large integer. + * + * Results: + * None. + * + * Side effects: + * Object value is stored. The bignum value is cleared, since ownership + * has transferred to Tcl. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetBignumObj( + Tcl_Obj* objPtr, /* Object to set */ + mp_int* bignumValue) /* Value to store */ +{ + if (Tcl_IsShared(objPtr)) { + Tcl_Panic("Tcl_SetBignumObj called with shared object"); + } +#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); + + /* + * Clear the mp_int value. + * Don't call mp_clear() because it would free the digit array + * we just packed into the Tcl_Obj. + */ + + 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; } /* *---------------------------------------------------------------------- * * Tcl_DbIncrRefCount -- * * This procedure is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. This checks to see whether or not - * the memory has been freed before incrementing the ref count. + * TCL_MEM_DEBUG is defined. This checks to see whether or not the memory + * has been freed before incrementing the ref count. * - * When TCL_MEM_DEBUG is not defined, this procedure just increments - * the reference count of the object. + * When TCL_MEM_DEBUG is not defined, this procedure just increments the + * reference count of the object. * * Results: * None. * * Side effects: @@ -2741,34 +3003,36 @@ *---------------------------------------------------------------------- */ void Tcl_DbIncrRefCount(objPtr, file, line) - register Tcl_Obj *objPtr; /* The object we are registering a - * reference to. */ + register Tcl_Obj *objPtr; /* The object we are registering a reference + * to. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { #ifdef TCL_MEM_DEBUG if (objPtr->refCount == 0x61616161) { fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); Tcl_Panic("Trying to increment refCount of previously disposed object."); } + # ifdef TCL_THREADS /* - * Check to make sure that the Tcl_Obj was allocated by the - * current thread. Don't do this check when shutting down - * since thread local storage can be finalized before the - * last Tcl_Obj is freed. + * Check to make sure that the Tcl_Obj was allocated by the current + * thread. Don't do this check when shutting down since thread local + * storage can be finalized before the last Tcl_Obj is freed. */ + if (!TclInExit()) { Tcl_HashTable *tablePtr; Tcl_HashEntry *hPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + tablePtr = tsdPtr->objThreadMap; if (!tablePtr) { Tcl_Panic("object table not initialized"); } hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); @@ -2787,15 +3051,15 @@ *---------------------------------------------------------------------- * * Tcl_DbDecrRefCount -- * * This procedure is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. This checks to see whether or not - * the memory has been freed before decrementing the ref count. + * TCL_MEM_DEBUG is defined. This checks to see whether or not the memory + * has been freed before decrementing the ref count. * - * When TCL_MEM_DEBUG is not defined, this procedure just decrements - * the reference count of the object. + * When TCL_MEM_DEBUG is not defined, this procedure just decrements the + * reference count of the object. * * Results: * None. * * Side effects: @@ -2808,38 +3072,40 @@ Tcl_DbDecrRefCount(objPtr, file, line) register Tcl_Obj *objPtr; /* The object we are releasing a reference * to. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { #ifdef TCL_MEM_DEBUG if (objPtr->refCount == 0x61616161) { fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); Tcl_Panic("Trying to decrement refCount of previously disposed object."); } + # ifdef TCL_THREADS /* - * Check to make sure that the Tcl_Obj was allocated by the - * current thread. Don't do this check when shutting down - * since thread local storage can be finalized before the - * last Tcl_Obj is freed. + * Check to make sure that the Tcl_Obj was allocated by the current + * thread. Don't do this check when shutting down since thread local + * storage can be finalized before the last Tcl_Obj is freed. */ + if (!TclInExit()) { Tcl_HashTable *tablePtr; Tcl_HashEntry *hPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + tablePtr = tsdPtr->objThreadMap; if (!tablePtr) { Tcl_Panic("object table not initialized"); } hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); if (!hPtr) { Tcl_Panic("%s%s", - "Trying to decr ref count of", + "Trying to decr ref count of ", "Tcl_Obj allocated in another thread"); } /* If the Tcl_Obj is going to be deleted, remove the entry */ if ((((objPtr)->refCount) - 1) <= 0) { @@ -2857,15 +3123,15 @@ *---------------------------------------------------------------------- * * Tcl_DbIsShared -- * * This procedure is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. It tests whether the object has a ref - * count greater than one. + * TCL_MEM_DEBUG is defined. It tests whether the object has a ref count + * greater than one. * - * When TCL_MEM_DEBUG is not defined, this procedure just tests - * if the object has a ref count greater than one. + * When TCL_MEM_DEBUG is not defined, this procedure just tests if the + * object has a ref count greater than one. * * Results: * None. * * Side effects: @@ -2877,26 +3143,27 @@ int Tcl_DbIsShared(objPtr, file, line) register Tcl_Obj *objPtr; /* The object to test for being shared. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { #ifdef TCL_MEM_DEBUG if (objPtr->refCount == 0x61616161) { fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); Tcl_Panic("Trying to check whether previously disposed object is shared."); } + # ifdef TCL_THREADS /* - * Check to make sure that the Tcl_Obj was allocated by the - * current thread. Don't do this check when shutting down - * since thread local storage can be finalized before the - * last Tcl_Obj is freed. + * Check to make sure that the Tcl_Obj was allocated by the current + * thread. Don't do this check when shutting down since thread local + * storage can be finalized before the last Tcl_Obj is freed. */ + if (!TclInExit()) { Tcl_HashTable *tablePtr; Tcl_HashEntry *hPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); tablePtr = tsdPtr->objThreadMap; @@ -2910,10 +3177,11 @@ "Tcl_Obj allocated in another thread"); } } # endif #endif + #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); if ((objPtr)->refCount <= 1) { tclObjsShared[1]++; } else if ((objPtr)->refCount < TCL_MAX_SHARED_OBJ_STATS) { @@ -2921,20 +3189,21 @@ } else { tclObjsShared[0]++; } Tcl_MutexUnlock(&tclObjMutex); #endif + return ((objPtr)->refCount > 1); } /* *---------------------------------------------------------------------- * * Tcl_InitObjHashTable -- * - * Given storage for a hash table, set up the fields to prepare - * the hash table for use, the keys are Tcl_Obj *. + * Given storage for a hash table, set up the fields to prepare the hash + * table for use, the keys are Tcl_Obj *. * * Results: * None. * * Side effects: @@ -2944,12 +3213,13 @@ *---------------------------------------------------------------------- */ void Tcl_InitObjHashTable(tablePtr) - register Tcl_HashTable *tablePtr; /* Pointer to table record, which - * is supplied by the caller. */ + register Tcl_HashTable *tablePtr; + /* Pointer to table record, which is supplied + * by the caller. */ { Tcl_InitCustomHashTable(tablePtr, TCL_CUSTOM_PTR_KEYS, &tclObjHashKeyType); } @@ -2990,12 +3260,12 @@ * CompareObjKeys -- * * Compares two Tcl_Obj * keys. * * Results: - * The return value is 0 if they are different and 1 if they are - * the same. + * The return value is 0 if they are different and 1 if they are the + * same. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -3012,26 +3282,29 @@ register int l1, l2; /* * If the object pointers are the same then they match. */ + if (objPtr1 == objPtr2) { return 1; } /* * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being * in a register. */ + p1 = TclGetString(objPtr1); l1 = objPtr1->length; p2 = TclGetString(objPtr2); l2 = objPtr2->length; /* * Only compare if the string representations are of the same length. */ + if (l1 == l2) { for (;; p1++, p2++, l1--) { if (*p1 != *p2) { break; } @@ -3077,12 +3350,12 @@ * * Compute a one-word summary of the string representation of the * Tcl_Obj, which can be used to generate a hash index. * * Results: - * The return value is a one-word summary of the information in - * the string representation of the Tcl_Obj. + * The return value is a one-word summary of the information in the + * string representation of the Tcl_Obj. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -3098,23 +3371,23 @@ int length = objPtr->length; unsigned int result = 0; int i; /* - * I tried a zillion different hash functions and asked many other - * people for advice. Many people had their own favorite functions, - * all different, but no-one had much idea why they were good ones. - * I chose the one below (multiply by 9 and add new character) - * because of the following reasons: - * - * 1. Multiplying by 10 is perfect for keys that are decimal strings, - * and multiplying by 9 is just about as good. - * 2. Times-9 is (shift-left-3) plus (old). This means that each - * character's bits hang around in the low-order bits of the - * hash value for ever, plus they spread fairly rapidly up to - * the high-order bits to fill out the hash value. This seems - * works well both for decimal and non-decimal strings. + * I tried a zillion different hash functions and asked many other people + * for advice. Many people had their own favorite functions, all + * different, but no-one had much idea why they were good ones. I chose + * the one below (multiply by 9 and add new character) because of the + * following reasons: + * + * 1. Multiplying by 10 is perfect for keys that are decimal strings, and + * multiplying by 9 is just about as good. + * 2. Times-9 is (shift-left-3) plus (old). This means that each + * character's bits hang around in the low-order bits of the hash value + * for ever, plus they spread fairly rapidly up to the high-order bits + * to fill out the hash value. This seems works well both for decimal + * and *non-decimal strings. */ for (i=0 ; ivarFramePtr; name = Tcl_GetString(objPtr); if ((*name++ == ':') && (*name == ':')) { @@ -3172,12 +3445,12 @@ iPtr->varFramePtr = NULL; } /* * Get the internal representation, converting to a command type if - * needed. The internal representation is a ResolvedCmdName that points - * to the actual command. + * needed. The internal representation is a ResolvedCmdName that points to + * the actual command. */ if (objPtr->typePtr != &tclCmdNameType) { result = tclCmdNameType.setFromAnyProc(interp, objPtr); if (result != TCL_OK) { @@ -3198,15 +3471,15 @@ } /* * Check the context namespace and the namespace epoch of the resolved * symbol to make sure that it is fresh. If not, then force another - * conversion to the command type, to discard the old rep and create a - * new one. Note that we verify that the namespace id of the context - * namespace is the same as the one we cached; this insures that the - * namespace wasn't deleted and a new one created at the same address - * with the same command epoch. + * conversion to the command type, to discard the old rep and create a new + * one. Note that we verify that the namespace id of the context namespace + * is the same as the one we cached; this insures that the namespace + * wasn't deleted and a new one created at the same address with the same + * command epoch. */ cmdPtr = NULL; if ((resPtr != NULL) && (resPtr->refNsPtr == currNsPtr) @@ -3244,33 +3517,49 @@ * Results: * None. * * Side effects: * The object's old internal rep is freed. It's string rep is not - * changed. The refcount in the Command structure is incremented to - * keep it from being freed if the command is later deleted until + * changed. The refcount in the Command structure is incremented to keep + * it from being freed if the command is later deleted until * TclExecuteByteCode has a chance to recognize that it was deleted. * *---------------------------------------------------------------------- */ void TclSetCmdNameObj(interp, objPtr, cmdPtr) Tcl_Interp *interp; /* Points to interpreter containing command * that should be cached in objPtr. */ - register Tcl_Obj *objPtr; /* Points to Tcl object to be changed to - * a CmdName object. */ + register Tcl_Obj *objPtr; /* Points to Tcl object to be changed to a + * CmdName object. */ Command *cmdPtr; /* Points to Command structure that the * CmdName object should refer to. */ { Interp *iPtr = (Interp *) interp; register ResolvedCmdName *resPtr; register Namespace *currNsPtr; + CallFrame *savedFramePtr; + char *name; if (objPtr->typePtr == &tclCmdNameType) { return; } + + /* + * If the variable name is fully qualified, do as if the lookup were done + * from the global namespace; this helps avoid repeated lookups of fully + * qualified names. It costs close to nothing, and may be very helpful for + * OO applications which pass along a command name ("this"), [Patch + * 456668] (Copied over from Tcl_GetCommandFromObj) + */ + + savedFramePtr = iPtr->varFramePtr; + name = Tcl_GetString(objPtr); + if ((*name++ == ':') && (*name == ':')) { + iPtr->varFramePtr = NULL; + } /* * Get the current namespace. */ @@ -3291,10 +3580,12 @@ TclFreeIntRep(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclCmdNameType; + + iPtr->varFramePtr = savedFramePtr; } /* *---------------------------------------------------------------------- * @@ -3306,14 +3597,14 @@ * Results: * None. * * Side effects: * Decrements the ref count of any cached ResolvedCmdName structure - * pointed to by the cmdName's internal representation. If this is - * the last use of the ResolvedCmdName, it is freed. This in turn - * decrements the ref count of the Command structure pointed to by - * the ResolvedSymbol, which may free the Command structure. + * pointed to by the cmdName's internal representation. If this is the + * last use of the ResolvedCmdName, it is freed. This in turn decrements + * the ref count of the Command structure pointed to by the + * ResolvedSymbol, which may free the Command structure. * *---------------------------------------------------------------------- */ static void @@ -3324,20 +3615,20 @@ register ResolvedCmdName *resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; if (resPtr != NULL) { /* - * Decrement the reference count of the ResolvedCmdName structure. - * If there are no more uses, free the ResolvedCmdName structure. + * Decrement the reference count of the ResolvedCmdName structure. If + * there are no more uses, free the ResolvedCmdName structure. */ resPtr->refCount--; if (resPtr->refCount == 0) { /* - * Now free the cached command, unless it is still in its - * hash table or if there are other references to it - * from other cmdName objects. + * Now free the cached command, unless it is still in its hash + * table or if there are other references to it from other cmdName + * objects. */ Command *cmdPtr = resPtr->cmdPtr; TclCleanupCommand(cmdPtr); ckfree((char *) resPtr); @@ -3348,32 +3639,32 @@ /* *---------------------------------------------------------------------- * * DupCmdNameInternalRep -- * - * Initialize the internal representation of an cmdName Tcl_Obj to a - * copy of the internal representation of an existing cmdName object. + * Initialize the internal representation of an cmdName Tcl_Obj to a copy + * of the internal representation of an existing cmdName object. * * Results: * None. * * Side effects: * "copyPtr"s internal rep is set to point to the ResolvedCmdName - * structure corresponding to "srcPtr"s internal rep. Increments the - * ref count of the ResolvedCmdName structure pointed to by the - * cmdName's internal representation. + * structure corresponding to "srcPtr"s internal rep. Increments the ref + * count of the ResolvedCmdName structure pointed to by the cmdName's + * internal representation. * *---------------------------------------------------------------------- */ static void DupCmdNameInternalRep(srcPtr, copyPtr) Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ { - register ResolvedCmdName *resPtr = - (ResolvedCmdName *) srcPtr->internalRep.twoPtrValue.ptr1; + register ResolvedCmdName *resPtr = (ResolvedCmdName *) + srcPtr->internalRep.twoPtrValue.ptr1; copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; copyPtr->internalRep.twoPtrValue.ptr2 = NULL; if (resPtr != NULL) { resPtr->refCount++; @@ -3392,14 +3683,14 @@ * The return value is a standard Tcl result. The conversion always * succeeds and TCL_OK is returned. * * Side effects: * A pointer to a ResolvedCmdName structure that holds a cached pointer - * to the command with a name that matches objPtr's string rep is - * stored as objPtr's internal representation. This ResolvedCmdName - * pointer will be NULL if no matching command was found. The ref count - * of the cached Command's structure (if any) is also incremented. + * to the command with a name that matches objPtr's string rep is stored + * as objPtr's internal representation. This ResolvedCmdName pointer will + * be NULL if no matching command was found. The ref count of the cached + * Command's structure (if any) is also incremented. * *---------------------------------------------------------------------- */ static int @@ -3456,17 +3747,25 @@ } else { resPtr = NULL; /* no command named "name" was found */ } /* - * Free the old internalRep before setting the new one. We do this as - * late as possible to allow the conversion code, in particular - * GetStringFromObj, to use that old internalRep. If no Command - * structure was found, leave NULL as the cached value. + * Free the old internalRep before setting the new one. We do this as late + * as possible to allow the conversion code, in particular + * GetStringFromObj, to use that old internalRep. If no Command structure + * was found, leave NULL as the cached value. */ TclFreeIntRep(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclCmdNameType; return TCL_OK; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclPanic.c ================================================================== --- generic/tclPanic.c +++ generic/tclPanic.c @@ -1,46 +1,44 @@ -/* +/* * tclPanic.c -- * - * Source code for the "Tcl_Panic" library procedure for Tcl; - * individual applications will probably call Tcl_SetPanicProc() - * to set an application-specific panic procedure. + * Source code for the "Tcl_Panic" library procedure for Tcl; individual + * applications will probably call Tcl_SetPanicProc() to set an + * application-specific panic procedure. * * Copyright (c) 1988-1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPanic.c,v 1.5 2004/04/06 22:25:54 dgp Exp $ + * RCS: @(#) $Id: tclPanic.c,v 1.5.2.2 2005/09/15 20:58:40 dgp Exp $ */ #include "tclInt.h" /* - * The panicProc variable contains a pointer to an application - * specific panic procedure. + * The panicProc variable contains a pointer to an application specific panic + * procedure. */ static Tcl_PanicProc *panicProc = NULL; /* - * The platformPanicProc variable contains a pointer to a platform - * specific panic procedure, if any. ( TclpPanic may be NULL via - * a macro. ) + * The platformPanicProc variable contains a pointer to a platform specific + * panic procedure, if any. (TclpPanic may be NULL via a macro.) */ -static Tcl_PanicProc * CONST platformPanicProc = TclpPanic; - +static Tcl_PanicProc *CONST platformPanicProc = TclpPanic; /* *---------------------------------------------------------------------- * * Tcl_SetPanicProc -- * - * Replace the default panic behavior with the specified functiion. + * Replace the default panic behavior with the specified function. * * Results: * None. * * Side effects: @@ -71,11 +69,11 @@ * *---------------------------------------------------------------------- */ void -Tcl_PanicVA (format, argList) +Tcl_PanicVA(format, argList) CONST char *format; /* Format string, suitable for passing to * fprintf. */ va_list argList; /* Variable argument list. */ { char *arg1, *arg2, *arg3, *arg4; /* Additional arguments (variable in @@ -88,11 +86,11 @@ arg4 = va_arg(argList, char *); arg5 = va_arg(argList, char *); arg6 = va_arg(argList, char *); arg7 = va_arg(argList, char *); arg8 = va_arg(argList, char *); - + if (panicProc != NULL) { (void) (*panicProc)(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); } else if (platformPanicProc != NULL) { (void) (*platformPanicProc)(format, arg1, arg2, arg3, arg4, @@ -120,16 +118,23 @@ * The process dies, entering the debugger if possible. * *---------------------------------------------------------------------- */ - /* VARARGS ARGSUSED */ + /* ARGSUSED */ void -Tcl_Panic TCL_VARARGS_DEF(CONST char *,arg1) +Tcl_Panic(CONST char *format, ...) { va_list argList; - CONST char *format; - format = TCL_VARARGS_START(CONST char *,arg1,argList); + va_start(argList, format); Tcl_PanicVA(format, argList); va_end (argList); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclParse.c ================================================================== --- generic/tclParse.c +++ generic/tclParse.c @@ -1,60 +1,58 @@ -/* +/* * tclParse.c -- * - * This file contains procedures that parse Tcl scripts. They - * do so in a general-purpose fashion that can be used for many - * different purposes, including compilation, direct execution, - * code analysis, etc. + * This file contains functions that parse Tcl scripts. They do so in a + * general-purpose fashion that can be used for many different purposes, + * including compilation, direct execution, code analysis, etc. * * Copyright (c) 1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 Ajuba Solutions. * Contributions from Don Porter, NIST, 2002. (not subject to US copyright) * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclParse.c,v 1.39 2004/10/26 21:52:37 dgp Exp $ + * RCS: @(#) $Id: tclParse.c,v 1.39.2.4 2005/10/08 13:44:37 dgp Exp $ */ #include "tclInt.h" /* - * The following table provides parsing information about each possible - * 8-bit character. The table is designed to be referenced with either - * signed or unsigned characters, so it has 384 entries. The first 128 - * entries correspond to negative character values, the next 256 correspond - * to positive character values. The last 128 entries are identical to the - * first 128. The table is always indexed with a 128-byte offset (the 128th - * entry corresponds to a character value of 0). - * - * The macro CHAR_TYPE is used to index into the table and return - * information about its character argument. The following return - * values are defined. - * - * TYPE_NORMAL - All characters that don't have special significance - * to the Tcl parser. - * TYPE_SPACE - The character is a whitespace character other - * than newline. - * TYPE_COMMAND_END - Character is newline or semicolon. - * TYPE_SUBS - Character begins a substitution or has other - * special meaning in ParseTokens: backslash, dollar - * sign, or open bracket. - * TYPE_QUOTE - Character is a double quote. - * TYPE_CLOSE_PAREN - Character is a right parenthesis. - * TYPE_CLOSE_BRACK - Character is a right square bracket. - * TYPE_BRACE - Character is a curly brace (either left or right). + * The following table provides parsing information about each possible 8-bit + * character. The table is designed to be referenced with either signed or + * unsigned characters, so it has 384 entries. The first 128 entries + * correspond to negative character values, the next 256 correspond to + * positive character values. The last 128 entries are identical to the first + * 128. The table is always indexed with a 128-byte offset (the 128th entry + * corresponds to a character value of 0). + * + * The macro CHAR_TYPE is used to index into the table and return information + * about its character argument. The following return values are defined. + * + * TYPE_NORMAL - All characters that don't have special significance to + * the Tcl parser. + * TYPE_SPACE - The character is a whitespace character other than + * newline. + * TYPE_COMMAND_END - Character is newline or semicolon. + * TYPE_SUBS - Character begins a substitution or has other special + * meaning in ParseTokens: backslash, dollar sign, or + * open bracket. + * TYPE_QUOTE - Character is a double quote. + * TYPE_CLOSE_PAREN - Character is a right parenthesis. + * TYPE_CLOSE_BRACK - Character is a right square bracket. + * TYPE_BRACE - Character is a curly brace (either left or right). */ -#define TYPE_NORMAL 0 -#define TYPE_SPACE 0x1 -#define TYPE_COMMAND_END 0x2 -#define TYPE_SUBS 0x4 -#define TYPE_QUOTE 0x8 -#define TYPE_CLOSE_PAREN 0x10 -#define TYPE_CLOSE_BRACK 0x20 -#define TYPE_BRACE 0x40 +#define TYPE_NORMAL 0 +#define TYPE_SPACE 0x1 +#define TYPE_COMMAND_END 0x2 +#define TYPE_SUBS 0x4 +#define TYPE_QUOTE 0x8 +#define TYPE_CLOSE_PAREN 0x10 +#define TYPE_CLOSE_BRACK 0x20 +#define TYPE_BRACE 0x40 #define CHAR_TYPE(c) (charTypeTable+128)[(int)(c)] static CONST char charTypeTable[] = { /* @@ -168,20 +166,20 @@ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, }; /* - * Prototypes for local procedures defined in this file: + * Prototypes for local functions defined in this file: */ static int CommandComplete _ANSI_ARGS_((CONST char *script, int numBytes)); -static int ParseComment _ANSI_ARGS_((CONST char *src, int numBytes, - Tcl_Parse *parsePtr)); +static int ParseComment _ANSI_ARGS_((CONST char *src, + int numBytes, Tcl_Parse *parsePtr)); static int ParseTokens _ANSI_ARGS_((CONST char *src, int numBytes, int mask, int flags, Tcl_Parse *parsePtr)); - + /* *---------------------------------------------------------------------- * * TclParseInit -- * @@ -198,13 +196,13 @@ void TclParseInit(interp, string, numBytes, parsePtr) Tcl_Interp *interp; /* Interpreter to use for error reporting */ CONST char *string; /* String to be parsed. */ - int numBytes; /* Total number of bytes in string. If < 0, - * the script consists of all bytes up to - * the first null character. */ + int numBytes; /* Total number of bytes in string. If < 0, + * the script consists of all bytes up to the + * first null character. */ Tcl_Parse *parsePtr; /* Points to struct to initialize */ { parsePtr->numWords = 0; parsePtr->tokenPtr = parsePtr->staticTokens; parsePtr->numTokens = 0; @@ -214,77 +212,73 @@ parsePtr->term = parsePtr->end; parsePtr->interp = interp; parsePtr->incomplete = 0; parsePtr->errorType = TCL_PARSE_SUCCESS; } + /* *---------------------------------------------------------------------- * * Tcl_ParseCommand -- * - * Given a string, this procedure parses the first Tcl command - * in the string and returns information about the structure of - * the command. + * Given a string, this function parses the first Tcl command in the + * string and returns information about the structure of the command. * * Results: - * The return value is TCL_OK if the command was parsed - * successfully and TCL_ERROR otherwise. If an error occurs - * and interp isn't NULL then an error message is left in - * its result. On a successful return, parsePtr is filled in - * with information about the command that was parsed. + * The return value is TCL_OK if the command was parsed successfully and + * TCL_ERROR otherwise. If an error occurs and interp isn't NULL then an + * error message is left in its result. On a successful return, parsePtr + * is filled in with information about the command that was parsed. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the command, then additional space is - * malloc-ed. If the procedure returns TCL_OK then the caller must - * eventually invoke Tcl_FreeParse to release any additional space - * that was allocated. + * If there is insufficient space in parsePtr to hold all the information + * about the command, then additional space is malloc-ed. If the function + * returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to + * release any additional space that was allocated. * *---------------------------------------------------------------------- */ int -Tcl_ParseCommand(interp, string, numBytes, nested, parsePtr) - Tcl_Interp *interp; /* Interpreter to use for error reporting; - * if NULL, then no error message is - * provided. */ - CONST char *string; /* First character of string containing - * one or more Tcl commands. */ +Tcl_ParseCommand(interp, start, numBytes, nested, parsePtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting; if + * NULL, then no error message is provided. */ + CONST char *start; /* First character of string containing one or + * more Tcl commands. */ register int numBytes; /* Total number of bytes in string. If < 0, - * the script consists of all bytes up to - * the first null character. */ + * the script consists of all bytes up to the + * first null character. */ int nested; /* Non-zero means this is a nested command: - * close bracket should be considered - * a command terminator. If zero, then close + * close bracket should be considered a + * command terminator. If zero, then close * bracket has no special meaning. */ register Tcl_Parse *parsePtr; - /* Structure to fill in with information - * about the parsed command; any previous - * information in the structure is - * ignored. */ + /* Structure to fill in with information about + * the parsed command; any previous + * information in the structure is ignored. */ { - register CONST char *src; /* Points to current character - * in the command. */ + register CONST char *src; /* Points to current character in the + * command. */ char type; /* Result returned by CHAR_TYPE(*src). */ Tcl_Token *tokenPtr; /* Pointer to token being filled in. */ int wordIndex; /* Index of word token for current word. */ - int terminators; /* CHAR_TYPE bits that indicate the end - * of a command. */ + int terminators; /* CHAR_TYPE bits that indicate the end of a + * command. */ CONST char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to * point to char after terminating one. */ int scanned; - - if ((string == NULL) && (numBytes>0)) { + + if ((start == NULL) && (numBytes>0)) { if (interp != NULL) { Tcl_SetResult(interp, "can't parse a NULL pointer", TCL_STATIC); } return TCL_ERROR; } if (numBytes < 0) { - numBytes = strlen(string); + numBytes = strlen(start); } - TclParseInit(interp, string, numBytes, parsePtr); + TclParseInit(interp, start, numBytes, parsePtr); parsePtr->commentStart = NULL; parsePtr->commentSize = 0; parsePtr->commandStart = NULL; parsePtr->commandSize = 0; if (nested != 0) { @@ -296,21 +290,22 @@ /* * Parse any leading space and comments before the first word of the * command. */ - scanned = ParseComment(string, numBytes, parsePtr); - src = (string + scanned); numBytes -= scanned; + scanned = ParseComment(start, numBytes, parsePtr); + src = (start + scanned); + numBytes -= scanned; if (numBytes == 0) { if (nested) { parsePtr->incomplete = nested; } } /* - * The following loop parses the words of the command, one word - * in each iteration through the loop. + * The following loop parses the words of the command, one word in each + * iteration through the loop. */ parsePtr->commandStart = src; while (1) { int expandWord = 0; @@ -330,11 +325,12 @@ * Skip white space before the word. Also skip a backslash-newline * sequence: it should be treated just like white space. */ scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type); - src += scanned; numBytes -= scanned; + src += scanned; + numBytes -= scanned; if (numBytes == 0) { parsePtr->term = src; break; } if ((type & terminators) != 0) { @@ -346,21 +342,22 @@ parsePtr->numTokens++; parsePtr->numWords++; /* * At this point the word can have one of four forms: something - * enclosed in quotes, something enclosed in braces, and - * expanding word, or an unquoted word (anything else). + * enclosed in quotes, something enclosed in braces, and expanding + * word, or an unquoted word (anything else). */ -parseWord: + parseWord: if (*src == '"') { if (Tcl_ParseQuotedString(interp, src, numBytes, parsePtr, 1, &termPtr) != TCL_OK) { goto error; } - src = termPtr; numBytes = parsePtr->end - src; + src = termPtr; + numBytes = parsePtr->end - src; } else if (*src == '{') { static char expPfx[] = "expand"; CONST size_t expPfxLen = sizeof(expPfx) - 1; int expIdx = wordIndex + 1; Tcl_Token *expPtr; @@ -367,53 +364,61 @@ if (Tcl_ParseBraces(interp, src, numBytes, parsePtr, 1, &termPtr) != TCL_OK) { goto error; } - src = termPtr; numBytes = parsePtr->end - src; + src = termPtr; + numBytes = parsePtr->end - src; - /* - * Check whether the braces contained - * the word expansion prefix. + /* + * Check whether the braces contained the word expansion prefix. */ expPtr = &parsePtr->tokenPtr[expIdx]; - if ( (expPfxLen == (size_t) expPtr->size) - /* Same length as prefix */ - && (0 == expandWord) - /* Haven't seen prefix already */ - && (1 == parsePtr->numTokens - expIdx) - /* Only one token */ - && (0 == strncmp(expPfx,expPtr->start,expPfxLen)) - /* Is the prefix */ - && (numBytes > 0) - && (TclParseWhiteSpace(termPtr, numBytes, parsePtr, &type) - == 0) - && (type != TYPE_COMMAND_END) - /* Non-whitespace follows */ - ) { + if ( + (0 == expandWord) + /* Haven't seen prefix already */ + && (1 == parsePtr->numTokens - expIdx) + /* Only one token */ + && (((expPfxLen == (size_t) expPtr->size) + /* Same length as prefix */ + && (0 == strncmp(expPfx,expPtr->start,expPfxLen))) +#ifdef ALLOW_EMPTY_EXPAND + /* + * Allow {} in addition to {expand} + */ + || (0 == (size_t) expPtr->size) +#endif + ) + /* Is the prefix */ + && (numBytes > 0) + && (TclParseWhiteSpace(termPtr, numBytes, parsePtr, + &type) == 0) + && (type != TYPE_COMMAND_END) + /* Non-whitespace follows */ + ) { expandWord = 1; parsePtr->numTokens--; goto parseWord; } } else { /* - * This is an unquoted word. Call ParseTokens and let it do - * all of the work. + * This is an unquoted word. Call ParseTokens and let it do all of + * the work. */ if (ParseTokens(src, numBytes, TYPE_SPACE|terminators, TCL_SUBST_ALL, parsePtr) != TCL_OK) { goto error; } - src = parsePtr->term; numBytes = parsePtr->end - src; + src = parsePtr->term; + numBytes = parsePtr->end - src; } /* - * Finish filling in the token for the word and check for the - * special case of a word consisting of a single range of - * literal text. + * Finish filling in the token for the word and check for the special + * case of a word consisting of a single range of literal text. */ tokenPtr = &parsePtr->tokenPtr[wordIndex]; tokenPtr->size = src - tokenPtr->start; tokenPtr->numComponents = parsePtr->numTokens - (wordIndex + 1); @@ -424,32 +429,32 @@ if (expandWord) { tokenPtr->type = TCL_TOKEN_EXPAND_WORD; } /* - * Do two additional checks: (a) make sure we're really at the - * end of a word (there might have been garbage left after a - * quoted or braced word), and (b) check for the end of the - * command. + * Do two additional checks: (a) make sure we're really at the end of + * a word (there might have been garbage left after a quoted or braced + * word), and (b) check for the end of the command. */ scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type); if (scanned) { - src += scanned; numBytes -= scanned; + src += scanned; + numBytes -= scanned; continue; } if (numBytes == 0) { parsePtr->term = src; break; } if ((type & terminators) != 0) { parsePtr->term = src; - src++; + src++; break; } - if (src[-1] == '"') { + if (src[-1] == '"') { if (interp != NULL) { Tcl_SetResult(interp, "extra characters after close-quote", TCL_STATIC); } parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA; @@ -465,52 +470,53 @@ } parsePtr->commandSize = src - parsePtr->commandStart; return TCL_OK; - error: + error: Tcl_FreeParse(parsePtr); parsePtr->commandSize = parsePtr->end - parsePtr->commandStart; return TCL_ERROR; } - + /* *---------------------------------------------------------------------- * * TclParseWhiteSpace -- * - * Scans up to numBytes bytes starting at src, consuming white - * space as defined by Tcl's parsing rules. + * Scans up to numBytes bytes starting at src, consuming white space as + * defined by Tcl's parsing rules. * * Results: - * Returns the number of bytes recognized as white space. Records - * at parsePtr, information about the parse. Records at typePtr - * the character type of the non-whitespace character that terminated - * the scan. + * Returns the number of bytes recognized as white space. Records at + * parsePtr, information about the parse. Records at typePtr the + * character type of the non-whitespace character that terminated the + * scan. * * Side effects: * None. * *---------------------------------------------------------------------- */ + int TclParseWhiteSpace(src, numBytes, parsePtr, typePtr) CONST char *src; /* First character to parse. */ register int numBytes; /* Max number of bytes to scan. */ Tcl_Parse *parsePtr; /* Information about parse in progress. - * Updated if parsing indicates - * an incomplete command. */ - char *typePtr; /* Points to location to store character - * type of character that ends run - * of whitespace */ + * Updated if parsing indicates an incomplete + * command. */ + char *typePtr; /* Points to location to store character type + * of character that ends run of whitespace */ { register char type = TYPE_NORMAL; register CONST char *p = src; while (1) { while (numBytes && ((type = CHAR_TYPE(*p)) & TYPE_SPACE)) { - numBytes--; p++; + numBytes--; + p++; } if (numBytes && (type & TYPE_SUBS)) { if (*p != '\\') { break; } @@ -536,35 +542,34 @@ /* *---------------------------------------------------------------------- * * TclParseHex -- * - * Scans a hexadecimal number as a Tcl_UniChar value. - * (e.g., for parsing \x and \u escape sequences). - * At most numBytes bytes are scanned. + * Scans a hexadecimal number as a Tcl_UniChar value (e.g., for parsing + * \x and \u escape sequences). At most numBytes bytes are scanned. * * Results: - * The numeric value is stored in *resultPtr. - * Returns the number of bytes consumed. + * The numeric value is stored in *resultPtr. Returns the number of bytes + * consumed. * * Notes: - * Relies on the following properties of the ASCII - * character set, with which UTF-8 is compatible: + * Relies on the following properties of the ASCII character set, with + * which UTF-8 is compatible: * - * The digits '0' .. '9' and the letters 'A' .. 'Z' and 'a' .. 'z' - * occupy consecutive code points, and '0' < 'A' < 'a'. + * The digits '0' .. '9' and the letters 'A' .. 'Z' and 'a' .. 'z' occupy + * consecutive code points, and '0' < 'A' < 'a'. * *---------------------------------------------------------------------- */ + int TclParseHex(src, numBytes, resultPtr) CONST char *src; /* First character to parse. */ int numBytes; /* Max number of byes to scan */ - Tcl_UniChar *resultPtr; /* Points to storage provided by - * caller where the Tcl_UniChar - * resulting from the conversion is - * to be written. */ + Tcl_UniChar *resultPtr; /* Points to storage provided by caller where + * the Tcl_UniChar resulting from the + * conversion is to be written. */ { Tcl_UniChar result = 0; register CONST char *p = src; while (numBytes--) { @@ -593,37 +598,37 @@ /* *---------------------------------------------------------------------- * * TclParseBackslash -- * - * Scans up to numBytes bytes starting at src, consuming a - * backslash sequence as defined by Tcl's parsing rules. + * Scans up to numBytes bytes starting at src, consuming a backslash + * sequence as defined by Tcl's parsing rules. * * Results: * Records at readPtr the number of bytes making up the backslash - * sequence. Records at dst the UTF-8 encoded equivalent of - * that backslash sequence. Returns the number of bytes written - * to dst, at most TCL_UTF_MAX. Either readPtr or dst may be - * NULL, if the results are not needed, but the return value is - * the same either way. + * sequence. Records at dst the UTF-8 encoded equivalent of that + * backslash sequence. Returns the number of bytes written to dst, at + * most TCL_UTF_MAX. Either readPtr or dst may be NULL, if the results + * are not needed, but the return value is the same either way. * * Side effects: * None. * *---------------------------------------------------------------------- */ + int TclParseBackslash(src, numBytes, readPtr, dst) - CONST char * src; /* Points to the backslash character of a - * a backslash sequence */ - int numBytes; /* Max number of bytes to scan */ - int *readPtr; /* NULL, or points to storage where the - * number of bytes scanned should be written. */ - char *dst; /* NULL, or points to buffer where the UTF-8 - * encoding of the backslash sequence is to be - * written. At most TCL_UTF_MAX bytes will be - * written there. */ + CONST char *src; /* Points to the backslash character of a a + * backslash sequence. */ + int numBytes; /* Max number of bytes to scan. */ + int *readPtr; /* NULL, or points to storage where the number + * of bytes scanned should be written. */ + char *dst; /* NULL, or points to buffer where the UTF-8 + * encoding of the backslash sequence is to be + * written. At most TCL_UTF_MAX bytes will be + * written there. */ { register CONST char *p = src+1; Tcl_UniChar result; int count; char buf[TCL_UTF_MAX]; @@ -634,211 +639,233 @@ } return 0; } if (dst == NULL) { - dst = buf; + dst = buf; } if (numBytes == 1) { - /* Can only scan the backslash. Return it. */ + /* + * Can only scan the backslash, so return it. + */ + result = '\\'; count = 1; goto done; } count = 2; switch (*p) { - /* - * Note: in the conversions below, use absolute values (e.g., - * 0xa) rather than symbolic values (e.g. \n) that get converted - * by the compiler. It's possible that compilers on some - * platforms will do the symbolic conversions differently, which - * could result in non-portable Tcl scripts. - */ - - case 'a': - result = 0x7; - break; - case 'b': - result = 0x8; - break; - case 'f': - result = 0xc; - break; - case 'n': - result = 0xa; - break; - case 'r': - result = 0xd; - break; - case 't': - result = 0x9; - break; - case 'v': - result = 0xb; - break; - case 'x': - count += TclParseHex(p+1, numBytes-1, &result); - if (count == 2) { - /* No hexadigits -> This is just "x". */ - result = 'x'; - } else { - /* Keep only the last byte (2 hex digits) */ - result = (unsigned char) result; - } - break; - case 'u': - count += TclParseHex(p+1, (numBytes > 5) ? 4 : numBytes-1, &result); - if (count == 2) { - /* No hexadigits -> This is just "u". */ - result = 'u'; - } - break; - case '\n': - count--; - do { - p++; count++; - } while ((count < numBytes) && ((*p == ' ') || (*p == '\t'))); - result = ' '; - break; - case 0: - result = '\\'; - count = 1; - break; - default: - /* - * Check for an octal number \oo?o? - */ - if (isdigit(UCHAR(*p)) && (UCHAR(*p) < '8')) { /* INTL: digit */ - result = (unsigned char)(*p - '0'); - p++; - if ((numBytes == 2) || !isdigit(UCHAR(*p)) /* INTL: digit */ - || (UCHAR(*p) >= '8')) { - break; - } - count = 3; - result = (unsigned char)((result << 3) + (*p - '0')); - p++; - if ((numBytes == 3) || !isdigit(UCHAR(*p)) /* INTL: digit */ - || (UCHAR(*p) >= '8')) { - break; - } - count = 4; - result = (unsigned char)((result << 3) + (*p - '0')); - break; - } - /* - * We have to convert here in case the user has put a - * backslash in front of a multi-byte utf-8 character. - * While this means nothing special, we shouldn't break up - * a correct utf-8 character. [Bug #217987] test subst-3.2 - */ - if (Tcl_UtfCharComplete(p, numBytes - 1)) { - count = Tcl_UtfToUniChar(p, &result) + 1; /* +1 for '\' */ - } else { - char utfBytes[TCL_UTF_MAX]; - memcpy(utfBytes, p, (size_t) (numBytes - 1)); - utfBytes[numBytes - 1] = '\0'; - count = Tcl_UtfToUniChar(utfBytes, &result) + 1; - } - break; - } - - done: + /* + * Note: in the conversions below, use absolute values (e.g., 0xa) + * rather than symbolic values (e.g. \n) that get converted by the + * compiler. It's possible that compilers on some platforms will do + * the symbolic conversions differently, which could result in + * non-portable Tcl scripts. + */ + + case 'a': + result = 0x7; + break; + case 'b': + result = 0x8; + break; + case 'f': + result = 0xc; + break; + case 'n': + result = 0xa; + break; + case 'r': + result = 0xd; + break; + case 't': + result = 0x9; + break; + case 'v': + result = 0xb; + break; + case 'x': + count += TclParseHex(p+1, numBytes-1, &result); + if (count == 2) { + /* + * No hexadigits -> This is just "x". + */ + + result = 'x'; + } else { + /* + * Keep only the last byte (2 hex digits). + */ + result = (unsigned char) result; + } + break; + case 'u': + count += TclParseHex(p+1, (numBytes > 5) ? 4 : numBytes-1, &result); + if (count == 2) { + /* + * No hexadigits -> This is just "u". + */ + result = 'u'; + } + break; + case '\n': + count--; + do { + p++; + count++; + } while ((count < numBytes) && ((*p == ' ') || (*p == '\t'))); + result = ' '; + break; + case 0: + result = '\\'; + count = 1; + break; + default: + /* + * Check for an octal number \oo?o? + */ + + if (isdigit(UCHAR(*p)) && (UCHAR(*p) < '8')) { /* INTL: digit */ + result = (unsigned char)(*p - '0'); + p++; + if ((numBytes == 2) || !isdigit(UCHAR(*p)) /* INTL: digit */ + || (UCHAR(*p) >= '8')) { + break; + } + count = 3; + result = (unsigned char)((result << 3) + (*p - '0')); + p++; + if ((numBytes == 3) || !isdigit(UCHAR(*p)) /* INTL: digit */ + || (UCHAR(*p) >= '8')) { + break; + } + count = 4; + result = (unsigned char)((result << 3) + (*p - '0')); + break; + } + + /* + * We have to convert here in case the user has put a backslash in + * front of a multi-byte utf-8 character. While this means nothing + * special, we shouldn't break up a correct utf-8 character. [Bug + * #217987] test subst-3.2 + */ + + if (Tcl_UtfCharComplete(p, numBytes - 1)) { + count = Tcl_UtfToUniChar(p, &result) + 1; /* +1 for '\' */ + } else { + char utfBytes[TCL_UTF_MAX]; + + memcpy(utfBytes, p, (size_t) (numBytes - 1)); + utfBytes[numBytes - 1] = '\0'; + count = Tcl_UtfToUniChar(utfBytes, &result) + 1; + } + break; + } + + done: if (readPtr != NULL) { - *readPtr = count; + *readPtr = count; } return Tcl_UniCharToUtf((int) result, dst); } /* *---------------------------------------------------------------------- * * ParseComment -- * - * Scans up to numBytes bytes starting at src, consuming a - * Tcl comment as defined by Tcl's parsing rules. + * Scans up to numBytes bytes starting at src, consuming a Tcl comment as + * defined by Tcl's parsing rules. * * Results: - * Records in parsePtr information about the parse. Returns the - * number of bytes consumed. + * Records in parsePtr information about the parse. Returns the number of + * bytes consumed. * * Side effects: * None. * *---------------------------------------------------------------------- */ + static int ParseComment(src, numBytes, parsePtr) CONST char *src; /* First character to parse. */ register int numBytes; /* Max number of bytes to scan. */ Tcl_Parse *parsePtr; /* Information about parse in progress. - * Updated if parsing indicates - * an incomplete command. */ + * Updated if parsing indicates an incomplete + * command. */ { register CONST char *p = src; while (numBytes) { char type; int scanned; + do { scanned = TclParseWhiteSpace(p, numBytes, parsePtr, &type); - p += scanned; numBytes -= scanned; + p += scanned; + numBytes -= scanned; } while (numBytes && (*p == '\n') && (p++,numBytes--)); + if ((numBytes == 0) || (*p != '#')) { break; } if (parsePtr->commentStart == NULL) { parsePtr->commentStart = p; } + while (numBytes) { if (*p == '\\') { scanned = TclParseWhiteSpace(p, numBytes, parsePtr, &type); if (scanned) { - p += scanned; numBytes -= scanned; + p += scanned; + numBytes -= scanned; } else { /* - * General backslash substitution in comments isn't - * part of the formal spec, but test parse-15.47 - * and history indicate that it has been the de facto - * rule. Don't change it now. + * General backslash substitution in comments isn't part + * of the formal spec, but test parse-15.47 and history + * indicate that it has been the de facto rule. Don't + * change it now. */ + TclParseBackslash(p, numBytes, &scanned, NULL); - p += scanned; numBytes -= scanned; + p += scanned; + numBytes -= scanned; } } else { - p++; numBytes--; + p++; + numBytes--; if (p[-1] == '\n') { break; } } } parsePtr->commentSize = p - parsePtr->commentStart; } return (p - src); } - + /* *---------------------------------------------------------------------- * * ParseTokens -- * - * This procedure forms the heart of the Tcl parser. It parses one - * or more tokens from a string, up to a termination point - * specified by the caller. This procedure is used to parse - * unquoted command words (those not in quotes or braces), words in - * quotes, and array indices for variables. No more than numBytes - * bytes will be scanned. + * This function forms the heart of the Tcl parser. It parses one or more + * tokens from a string, up to a termination point specified by the + * caller. This function is used to parse unquoted command words (those + * not in quotes or braces), words in quotes, and array indices for + * variables. No more than numBytes bytes will be scanned. * * Results: - * Tokens are added to parsePtr and parsePtr->term is filled in - * with the address of the character that terminated the parse (the - * first one whose CHAR_TYPE matched mask or the character at - * parsePtr->end). The return value is TCL_OK if the parse - * completed successfully and TCL_ERROR otherwise. If a parse - * error occurs and parsePtr->interp isn't NULL, then an error - * message is left in the interpreter's result. + * Tokens are added to parsePtr and parsePtr->term is filled in with the + * address of the character that terminated the parse (the first one + * whose CHAR_TYPE matched mask or the character at parsePtr->end). The + * return value is TCL_OK if the parse completed successfully and + * TCL_ERROR otherwise. If a parse error occurs and parsePtr->interp is + * not NULL, then an error message is left in the interpreter's result. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -846,35 +873,35 @@ static int ParseTokens(src, numBytes, mask, flags, parsePtr) register CONST char *src; /* First character to parse. */ register int numBytes; /* Max number of bytes to scan. */ - int flags; /* OR-ed bits indicating what substitutions - to perform: TCL_SUBST_COMMANDS, - TCL_SUBST_VARIABLES, and + int flags; /* OR-ed bits indicating what substitutions to + perform: TCL_SUBST_COMMANDS, + TCL_SUBST_VARIABLES, and TCL_SUBST_BACKSLASHES */ - int mask; /* Specifies when to stop parsing. The - * parse stops at the first unquoted - * character whose CHAR_TYPE contains - * any of the bits in mask. */ + int mask; /* Specifies when to stop parsing. The parse + * stops at the first unquoted character whose + * CHAR_TYPE contains any of the bits in + * mask. */ Tcl_Parse *parsePtr; /* Information about parse in progress. * Updated with additional tokens and * termination information. */ { - char type; + char type; int originalTokens, varToken; int noSubstCmds = !(flags & TCL_SUBST_COMMANDS); int noSubstVars = !(flags & TCL_SUBST_VARIABLES); int noSubstBS = !(flags & TCL_SUBST_BACKSLASHES); Tcl_Token *tokenPtr; Tcl_Parse nested; /* - * Each iteration through the following loop adds one token of - * type TCL_TOKEN_TEXT, TCL_TOKEN_BS, TCL_TOKEN_COMMAND, or - * TCL_TOKEN_VARIABLE to parsePtr. For TCL_TOKEN_VARIABLE tokens, - * additional tokens are added for the parsed variable name. + * Each iteration through the following loop adds one token of type + * TCL_TOKEN_TEXT, TCL_TOKEN_BS, TCL_TOKEN_COMMAND, or TCL_TOKEN_VARIABLE + * to parsePtr. For TCL_TOKEN_VARIABLE tokens, additional tokens are added + * for the parsed variable name. */ originalTokens = parsePtr->numTokens; while (numBytes && !((type = CHAR_TYPE(*src)) & mask)) { if (parsePtr->numTokens == parsePtr->tokensAvailable) { @@ -884,15 +911,15 @@ tokenPtr->start = src; tokenPtr->numComponents = 0; if ((type & TYPE_SUBS) == 0) { /* - * This is a simple range of characters. Scan to find the end - * of the range. + * This is a simple range of characters. Scan to find the end of + * the range. */ - while ((++src, --numBytes) + while ((++src, --numBytes) && !(CHAR_TYPE(*src) & (mask | TYPE_SUBS))) { /* empty loop */ } tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = src - tokenPtr->start; @@ -900,16 +927,18 @@ } else if (*src == '$') { if (noSubstVars) { tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = 1; parsePtr->numTokens++; - src++; numBytes--; + src++; + numBytes--; continue; } + /* - * This is a variable reference. Call Tcl_ParseVarName to do - * all the dirty work of parsing the name. + * This is a variable reference. Call Tcl_ParseVarName to do all + * the dirty work of parsing the name. */ varToken = parsePtr->numTokens; if (Tcl_ParseVarName(parsePtr->interp, src, numBytes, parsePtr, 1) != TCL_OK) { @@ -920,20 +949,23 @@ } else if (*src == '[') { if (noSubstCmds) { tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = 1; parsePtr->numTokens++; - src++; numBytes--; + src++; + numBytes--; continue; } + /* - * Command substitution. Call Tcl_ParseCommand recursively - * (and repeatedly) to parse the nested command(s), then - * throw away the parse information. + * Command substitution. Call Tcl_ParseCommand recursively (and + * repeatedly) to parse the nested command(s), then throw away the + * parse information. */ - src++; numBytes--; + src++; + numBytes--; while (1) { if (Tcl_ParseCommand(parsePtr->interp, src, numBytes, 1, &nested) != TCL_OK) { parsePtr->errorType = nested.errorType; parsePtr->term = nested.term; @@ -952,22 +984,22 @@ ckfree((char *) nested.tokenPtr); } /* * Check for the closing ']' that ends the command - * substitution. It must have been the last character of - * the parsed command. + * substitution. It must have been the last character of the + * parsed command. */ if ((nested.term < parsePtr->end) && (*nested.term == ']') && !nested.incomplete) { break; } if (numBytes == 0) { if (parsePtr->interp != NULL) { Tcl_SetResult(parsePtr->interp, - "missing close-bracket", TCL_STATIC); + "missing close-bracket", TCL_STATIC); } parsePtr->errorType = TCL_PARSE_MISSING_BRACKET; parsePtr->term = tokenPtr->start; parsePtr->incomplete = 1; return TCL_ERROR; @@ -979,35 +1011,42 @@ } else if (*src == '\\') { if (noSubstBS) { tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = 1; parsePtr->numTokens++; - src++; numBytes--; + src++; + numBytes--; continue; } + /* * Backslash substitution. */ + TclParseBackslash(src, numBytes, &tokenPtr->size, NULL); if (tokenPtr->size == 1) { - /* Just a backslash, due to end of string */ + /* + * Just a backslash, due to end of string. + */ + tokenPtr->type = TCL_TOKEN_TEXT; parsePtr->numTokens++; - src++; numBytes--; + src++; + numBytes--; continue; } if (src[1] == '\n') { if (numBytes == 2) { parsePtr->incomplete = 1; } /* - * Note: backslash-newline is special in that it is - * treated the same as a space character would be. This - * means that it could terminate the token. + * Note: backslash-newline is special in that it is treated + * the same as a space character would be. This means that it + * could terminate the token. */ if (mask & TYPE_SPACE) { if (parsePtr->numTokens == originalTokens) { goto finishToken; @@ -1022,89 +1061,90 @@ numBytes -= tokenPtr->size; } else if (*src == 0) { tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = 1; parsePtr->numTokens++; - src++; numBytes--; + src++; + numBytes--; } else { Tcl_Panic("ParseTokens encountered unknown character"); } } if (parsePtr->numTokens == originalTokens) { /* - * There was nothing in this range of text. Add an empty token - * for the empty range, so that there is always at least one - * token added. + * There was nothing in this range of text. Add an empty token for + * the empty range, so that there is always at least one token added. */ + if (parsePtr->numTokens == parsePtr->tokensAvailable) { TclExpandTokenArray(parsePtr); } tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; tokenPtr->start = src; tokenPtr->numComponents = 0; - finishToken: + finishToken: tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = 0; parsePtr->numTokens++; } parsePtr->term = src; return TCL_OK; } - + /* *---------------------------------------------------------------------- * * Tcl_FreeParse -- * - * This procedure is invoked to free any dynamic storage that may - * have been allocated by a previous call to Tcl_ParseCommand. + * This function is invoked to free any dynamic storage that may have + * been allocated by a previous call to Tcl_ParseCommand. * * Results: * None. * * Side effects: - * If there is any dynamically allocated memory in *parsePtr, - * it is freed. + * If there is any dynamically allocated memory in *parsePtr, it is + * freed. * *---------------------------------------------------------------------- */ void Tcl_FreeParse(parsePtr) - Tcl_Parse *parsePtr; /* Structure that was filled in by a - * previous call to Tcl_ParseCommand. */ + Tcl_Parse *parsePtr; /* Structure that was filled in by a previous + * call to Tcl_ParseCommand. */ { if (parsePtr->tokenPtr != parsePtr->staticTokens) { ckfree((char *) parsePtr->tokenPtr); parsePtr->tokenPtr = parsePtr->staticTokens; } } - + /* *---------------------------------------------------------------------- * * TclExpandTokenArray -- * - * This procedure is invoked when the current space for tokens in - * a Tcl_Parse structure fills up; it allocates memory to grow the - * token array + * This function is invoked when the current space for tokens in a + * Tcl_Parse structure fills up; it allocates memory to grow the token + * array * * Results: * None. * * Side effects: - * Memory is allocated for a new larger token array; the memory - * for the old array is freed, if it had been dynamically allocated. + * Memory is allocated for a new larger token array; the memory for the + * old array is freed, if it had been dynamically allocated. * *---------------------------------------------------------------------- */ void TclExpandTokenArray(parsePtr) - Tcl_Parse *parsePtr; /* Parse structure whose token space - * has overflowed. */ + Tcl_Parse *parsePtr; /* Parse structure whose token space has + * overflowed. */ { int newCount; Tcl_Token *newPtr; newCount = parsePtr->tokensAvailable*2; @@ -1115,124 +1155,122 @@ ckfree((char *) parsePtr->tokenPtr); } parsePtr->tokenPtr = newPtr; parsePtr->tokensAvailable = newCount; } - + /* *---------------------------------------------------------------------- * * Tcl_ParseVarName -- * - * Given a string starting with a $ sign, parse off a variable - * name and return information about the parse. No more than - * numBytes bytes will be scanned. + * Given a string starting with a $ sign, parse off a variable name and + * return information about the parse. No more than numBytes bytes will + * be scanned. * * Results: - * The return value is TCL_OK if the command was parsed - * successfully and TCL_ERROR otherwise. If an error occurs and - * interp isn't NULL then an error message is left in its result. - * On a successful return, tokenPtr and numTokens fields of - * parsePtr are filled in with information about the variable name - * that was parsed. The "size" field of the first new token gives - * the total number of bytes in the variable name. Other fields in - * parsePtr are undefined. + * The return value is TCL_OK if the command was parsed successfully and + * TCL_ERROR otherwise. If an error occurs and interp isn't NULL then an + * error message is left in its result. On a successful return, tokenPtr + * and numTokens fields of parsePtr are filled in with information about + * the variable name that was parsed. The "size" field of the first new + * token gives the total number of bytes in the variable name. Other + * fields in parsePtr are undefined. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the command, then additional space is - * malloc-ed. If the procedure returns TCL_OK then the caller must - * eventually invoke Tcl_FreeParse to release any additional space - * that was allocated. + * If there is insufficient space in parsePtr to hold all the information + * about the command, then additional space is malloc-ed. If the function + * returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to + * release any additional space that was allocated. * *---------------------------------------------------------------------- */ int -Tcl_ParseVarName(interp, string, numBytes, parsePtr, append) - Tcl_Interp *interp; /* Interpreter to use for error reporting; - * if NULL, then no error message is - * provided. */ - CONST char *string; /* String containing variable name. First - * character must be "$". */ - register int numBytes; /* Total number of bytes in string. If < 0, +Tcl_ParseVarName(interp, start, numBytes, parsePtr, append) + Tcl_Interp *interp; /* Interpreter to use for error reporting; if + * NULL, then no error message is provided. */ + CONST char *start; /* Start of variable substitution string. + * First character must be "$". */ + register int numBytes; /* Total number of bytes in string. If < 0, * the string consists of all bytes up to the * first null character. */ - Tcl_Parse *parsePtr; /* Structure to fill in with information - * about the variable name. */ + Tcl_Parse *parsePtr; /* Structure to fill in with information about + * the variable name. */ int append; /* Non-zero means append tokens to existing * information in parsePtr; zero means ignore - * existing tokens in parsePtr and reinitialize - * it. */ + * existing tokens in parsePtr and + * reinitialize it. */ { Tcl_Token *tokenPtr; register CONST char *src; unsigned char c; int varIndex, offset; Tcl_UniChar ch; unsigned array; - if ((numBytes == 0) || (string == NULL)) { + if ((numBytes == 0) || (start == NULL)) { return TCL_ERROR; } if (numBytes < 0) { - numBytes = strlen(string); + numBytes = strlen(start); } if (!append) { - TclParseInit(interp, string, numBytes, parsePtr); + TclParseInit(interp, start, numBytes, parsePtr); } /* - * Generate one token for the variable, an additional token for the - * name, plus any number of additional tokens for the index, if - * there is one. + * Generate one token for the variable, an additional token for the name, + * plus any number of additional tokens for the index, if there is one. */ - src = string; + src = start; if ((parsePtr->numTokens + 2) > parsePtr->tokensAvailable) { TclExpandTokenArray(parsePtr); } tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; tokenPtr->type = TCL_TOKEN_VARIABLE; tokenPtr->start = src; varIndex = parsePtr->numTokens; parsePtr->numTokens++; tokenPtr++; - src++; numBytes--; + src++; + numBytes--; if (numBytes == 0) { goto justADollarSign; } tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->start = src; tokenPtr->numComponents = 0; /* * The name of the variable can have three forms: - * 1. The $ sign is followed by an open curly brace. Then - * the variable name is everything up to the next close - * curly brace, and the variable is a scalar variable. - * 2. The $ sign is not followed by an open curly brace. Then - * the variable name is everything up to the next - * character that isn't a letter, digit, or underscore. - * :: sequences are also considered part of the variable - * name, in order to support namespaces. If the following - * character is an open parenthesis, then the information - * between parentheses is the array element name. - * 3. The $ sign is followed by something that isn't a letter, - * digit, or underscore: in this case, there is no variable - * name and the token is just "$". + * 1. The $ sign is followed by an open curly brace. Then the variable + * name is everything up to the next close curly brace, and the + * variable is a scalar variable. + * 2. The $ sign is not followed by an open curly brace. Then the + * variable name is everything up to the next character that isn't a + * letter, digit, or underscore. :: sequences are also considered part + * of the variable name, in order to support namespaces. If the + * following character is an open parenthesis, then the information + * between parentheses is the array element name. + * 3. The $ sign is followed by something that isn't a letter, digit, or + * underscore: in this case, there is no variable name and the token is + * just "$". */ if (*src == '{') { - src++; numBytes--; + src++; + numBytes--; tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->start = src; tokenPtr->numComponents = 0; while (numBytes && (*src != '}')) { - numBytes--; src++; + numBytes--; + src++; } if (numBytes == 0) { if (interp != NULL) { Tcl_SetResult(interp, "missing close-brace for variable name", TCL_STATIC); @@ -1248,56 +1286,61 @@ src++; } else { tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->start = src; tokenPtr->numComponents = 0; + while (numBytes) { if (Tcl_UtfCharComplete(src, numBytes)) { - offset = Tcl_UtfToUniChar(src, &ch); + offset = Tcl_UtfToUniChar(src, &ch); } else { char utfBytes[TCL_UTF_MAX]; + memcpy(utfBytes, src, (size_t) numBytes); utfBytes[numBytes] = '\0'; - offset = Tcl_UtfToUniChar(utfBytes, &ch); + offset = Tcl_UtfToUniChar(utfBytes, &ch); } c = UCHAR(ch); if (isalnum(c) || (c == '_')) { /* INTL: ISO only, UCHAR. */ - src += offset; numBytes -= offset; + src += offset; + numBytes -= offset; continue; } if ((c == ':') && (numBytes != 1) && (src[1] == ':')) { - src += 2; numBytes -= 2; + src += 2; + numBytes -= 2; while (numBytes && (*src == ':')) { - src++; numBytes--; + src++; + numBytes--; } continue; } break; } /* * Support for empty array names here. */ + array = (numBytes && (*src == '(')); tokenPtr->size = src - tokenPtr->start; if ((tokenPtr->size == 0) && !array) { goto justADollarSign; } parsePtr->numTokens++; if (array) { /* - * This is a reference to an array element. Call - * ParseTokens recursively to parse the element name, - * since it could contain any number of substitutions. + * This is a reference to an array element. Call ParseTokens + * recursively to parse the element name, since it could contain + * any number of substitutions. */ if (TCL_OK != ParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN, TCL_SUBST_ALL, parsePtr)) { goto error; } - if ((parsePtr->term == (src + numBytes)) - || (*parsePtr->term != ')')) { + if ((parsePtr->term == src+numBytes) || (*parsePtr->term != ')')) { if (parsePtr->interp != NULL) { Tcl_SetResult(parsePtr->interp, "missing )", TCL_STATIC); } parsePtr->errorType = TCL_PARSE_MISSING_PAREN; @@ -1312,69 +1355,67 @@ tokenPtr->size = src - tokenPtr->start; tokenPtr->numComponents = parsePtr->numTokens - (varIndex + 1); return TCL_OK; /* - * The dollar sign isn't followed by a variable name. - * replace the TCL_TOKEN_VARIABLE token with a - * TCL_TOKEN_TEXT token for the dollar sign. + * The dollar sign isn't followed by a variable name. Replace the + * TCL_TOKEN_VARIABLE token with a TCL_TOKEN_TEXT token for the dollar + * sign. */ - justADollarSign: + justADollarSign: tokenPtr = &parsePtr->tokenPtr[varIndex]; tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = 1; tokenPtr->numComponents = 0; return TCL_OK; - error: + error: Tcl_FreeParse(parsePtr); return TCL_ERROR; } - + /* *---------------------------------------------------------------------- * * Tcl_ParseVar -- * - * Given a string starting with a $ sign, parse off a variable - * name and return its value. + * Given a string starting with a $ sign, parse off a variable name and + * return its value. * * Results: - * The return value is the contents of the variable given by - * the leading characters of string. If termPtr isn't NULL, - * *termPtr gets filled in with the address of the character - * just after the last one in the variable specifier. If the - * variable doesn't exist, then the return value is NULL and - * an error message will be left in interp's result. + * The return value is the contents of the variable given by the leading + * characters of string. If termPtr isn't NULL, *termPtr gets filled in + * with the address of the character just after the last one in the + * variable specifier. If the variable doesn't exist, then the return + * value is NULL and an error message will be left in interp's result. * * Side effects: * None. * *---------------------------------------------------------------------- */ CONST char * -Tcl_ParseVar(interp, string, termPtr) +Tcl_ParseVar(interp, start, termPtr) Tcl_Interp *interp; /* Context for looking up variable. */ - register CONST char *string; /* String containing variable name. + register CONST char *start; /* Start of variable substitution. * First character must be "$". */ CONST char **termPtr; /* If non-NULL, points to word to fill * in with character just after last * one in the variable specifier. */ - { Tcl_Parse parse; register Tcl_Obj *objPtr; int code; - if (Tcl_ParseVarName(interp, string, -1, &parse, 0) != TCL_OK) { + if (Tcl_ParseVarName(interp, start, -1, &parse, 0) != TCL_OK) { return NULL; } if (termPtr != NULL) { - *termPtr = string + parse.tokenPtr->size; + *termPtr = start + parse.tokenPtr->size; } if (parse.numTokens == 1) { /* * There isn't a variable name after all: the $ is just a $. */ @@ -1387,95 +1428,93 @@ return NULL; } objPtr = Tcl_GetObjResult(interp); /* - * At this point we should have an object containing the value of - * a variable. Just return the string from that object. + * At this point we should have an object containing the value of a + * variable. Just return the string from that object. * * This should have returned the object for the user to manage, but - * instead we have some weak reference to the string value in the - * object, which is why we make sure the object exists after resetting - * the result. This isn't ideal, but it's the best we can do with the - * current documented interface. -- hobbs + * instead we have some weak reference to the string value in the object, + * which is why we make sure the object exists after resetting the result. + * This isn't ideal, but it's the best we can do with the current + * documented interface. -- hobbs */ if (!Tcl_IsShared(objPtr)) { Tcl_IncrRefCount(objPtr); } Tcl_ResetResult(interp); return TclGetString(objPtr); } - + /* *---------------------------------------------------------------------- * * Tcl_ParseBraces -- * * Given a string in braces such as a Tcl command argument or a string - * value in a Tcl expression, this procedure parses the string and - * returns information about the parse. No more than numBytes bytes - * will be scanned. + * value in a Tcl expression, this function parses the string and returns + * information about the parse. No more than numBytes bytes will be + * scanned. * * Results: * The return value is TCL_OK if the string was parsed successfully and - * TCL_ERROR otherwise. If an error occurs and interp isn't NULL then - * an error message is left in its result. On a successful return, - * tokenPtr and numTokens fields of parsePtr are filled in with - * information about the string that was parsed. Other fields in - * parsePtr are undefined. termPtr is set to point to the character - * just after the last one in the braced string. + * TCL_ERROR otherwise. If an error occurs and interp isn't NULL then an + * error message is left in its result. On a successful return, tokenPtr + * and numTokens fields of parsePtr are filled in with information about + * the string that was parsed. Other fields in parsePtr are undefined. + * termPtr is set to point to the character just after the last one in + * the braced string. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the command, then additional space is - * malloc-ed. If the procedure returns TCL_OK then the caller must - * eventually invoke Tcl_FreeParse to release any additional space - * that was allocated. + * If there is insufficient space in parsePtr to hold all the information + * about the command, then additional space is malloc-ed. If the function + * returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to + * release any additional space that was allocated. * *---------------------------------------------------------------------- */ int -Tcl_ParseBraces(interp, string, numBytes, parsePtr, append, termPtr) - Tcl_Interp *interp; /* Interpreter to use for error reporting; - * if NULL, then no error message is - * provided. */ - CONST char *string; /* String containing the string in braces. - * The first character must be '{'. */ +Tcl_ParseBraces(interp, start, numBytes, parsePtr, append, termPtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting; if + * NULL, then no error message is provided. */ + CONST char *start; /* Start of string enclosed in braces. The + * first character must be {'. */ register int numBytes; /* Total number of bytes in string. If < 0, - * the string consists of all bytes up to - * the first null character. */ + * the string consists of all bytes up to the + * first null character. */ register Tcl_Parse *parsePtr; - /* Structure to fill in with information - * about the string. */ + /* Structure to fill in with information about + * the string. */ int append; /* Non-zero means append tokens to existing - * information in parsePtr; zero means - * ignore existing tokens in parsePtr and + * information in parsePtr; zero means ignore + * existing tokens in parsePtr and * reinitialize it. */ CONST char **termPtr; /* If non-NULL, points to word in which to - * store a pointer to the character just - * after the terminating '}' if the parse - * was successful. */ + * store a pointer to the character just after + * the terminating '}' if the parse was + * successful. */ { Tcl_Token *tokenPtr; register CONST char *src; int startIndex, level, length; - if ((numBytes == 0) || (string == NULL)) { + if ((numBytes == 0) || (start == NULL)) { return TCL_ERROR; } if (numBytes < 0) { - numBytes = strlen(string); + numBytes = strlen(start); } if (!append) { - TclParseInit(interp, string, numBytes, parsePtr); + TclParseInit(interp, start, numBytes, parsePtr); } - src = string; + src = start; startIndex = parsePtr->numTokens; if (parsePtr->numTokens == parsePtr->tokensAvailable) { TclExpandTokenArray(parsePtr); } @@ -1489,238 +1528,240 @@ if (CHAR_TYPE(*src) != TYPE_NORMAL) { break; } } if (numBytes == 0) { - register int openBrace = 0; - - parsePtr->errorType = TCL_PARSE_MISSING_BRACE; - parsePtr->term = string; - parsePtr->incomplete = 1; - if (interp == NULL) { - /* - * Skip straight to the exit code since we have no - * interpreter to put error message in. - */ - goto error; - } - - Tcl_SetResult(interp, "missing close-brace", TCL_STATIC); - - /* - * Guess if the problem is due to comments by searching - * the source string for a possible open brace within the - * context of a comment. Since we aren't performing a - * full Tcl parse, just look for an open brace preceded - * by a '#' on the same line. - */ - - for (; src > string; src--) { - switch (*src) { - case '{': - openBrace = 1; - break; - case '\n': - openBrace = 0; - break; - case '#' : - if (openBrace && (isspace(UCHAR(src[-1])))) { - Tcl_AppendResult(interp, - ": possible unbalanced brace in comment", - (char *) NULL); - goto error; - } - break; - } - } - - error: - Tcl_FreeParse(parsePtr); - return TCL_ERROR; - } - switch (*src) { - case '{': - level++; - break; - case '}': - if (--level == 0) { - - /* - * Decide if we need to finish emitting a - * partially-finished token. There are 3 cases: - * {abc \newline xyz} or {xyz} - * - finish emitting "xyz" token - * {abc \newline} - * - don't emit token after \newline - * {} - finish emitting zero-sized token - * - * The last case ensures that there is a token - * (even if empty) that describes the braced string. - */ - - if ((src != tokenPtr->start) - || (parsePtr->numTokens == startIndex)) { - tokenPtr->size = (src - tokenPtr->start); - parsePtr->numTokens++; - } - if (termPtr != NULL) { - *termPtr = src+1; - } - return TCL_OK; - } - break; - case '\\': - TclParseBackslash(src, numBytes, &length, NULL); - if ((length > 1) && (src[1] == '\n')) { - /* - * A backslash-newline sequence must be collapsed, even - * inside braces, so we have to split the word into - * multiple tokens so that the backslash-newline can be - * represented explicitly. - */ - - if (numBytes == 2) { - parsePtr->incomplete = 1; - } - tokenPtr->size = (src - tokenPtr->start); - if (tokenPtr->size != 0) { - parsePtr->numTokens++; - } - if ((parsePtr->numTokens+1) >= parsePtr->tokensAvailable) { - TclExpandTokenArray(parsePtr); - } - tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; - tokenPtr->type = TCL_TOKEN_BS; - tokenPtr->start = src; - tokenPtr->size = length; - tokenPtr->numComponents = 0; - parsePtr->numTokens++; - - src += length - 1; - numBytes -= length - 1; - tokenPtr++; - tokenPtr->type = TCL_TOKEN_TEXT; - tokenPtr->start = src + 1; - tokenPtr->numComponents = 0; - } else { - src += length - 1; - numBytes -= length - 1; - } - break; - } - } -} - + goto missingBraceError; + } + + switch (*src) { + case '{': + level++; + break; + case '}': + if (--level == 0) { + /* + * Decide if we need to finish emitting a partially-finished + * token. There are 3 cases: + * {abc \newline xyz} or {xyz} + * - finish emitting "xyz" token + * {abc \newline} + * - don't emit token after \newline + * {} - finish emitting zero-sized token + * + * The last case ensures that there is a token (even if empty) + * that describes the braced string. + */ + + if ((src != tokenPtr->start) + || (parsePtr->numTokens == startIndex)) { + tokenPtr->size = (src - tokenPtr->start); + parsePtr->numTokens++; + } + if (termPtr != NULL) { + *termPtr = src+1; + } + return TCL_OK; + } + break; + case '\\': + TclParseBackslash(src, numBytes, &length, NULL); + if ((length > 1) && (src[1] == '\n')) { + /* + * A backslash-newline sequence must be collapsed, even inside + * braces, so we have to split the word into multiple tokens + * so that the backslash-newline can be represented + * explicitly. + */ + + if (numBytes == 2) { + parsePtr->incomplete = 1; + } + tokenPtr->size = (src - tokenPtr->start); + if (tokenPtr->size != 0) { + parsePtr->numTokens++; + } + if ((parsePtr->numTokens+1) >= parsePtr->tokensAvailable) { + TclExpandTokenArray(parsePtr); + } + tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; + tokenPtr->type = TCL_TOKEN_BS; + tokenPtr->start = src; + tokenPtr->size = length; + tokenPtr->numComponents = 0; + parsePtr->numTokens++; + + src += length - 1; + numBytes -= length - 1; + tokenPtr++; + tokenPtr->type = TCL_TOKEN_TEXT; + tokenPtr->start = src + 1; + tokenPtr->numComponents = 0; + } else { + src += length - 1; + numBytes -= length - 1; + } + break; + } + } + + missingBraceError: + parsePtr->errorType = TCL_PARSE_MISSING_BRACE; + parsePtr->term = start; + parsePtr->incomplete = 1; + if (interp == NULL) { + /* + * Skip straight to the exit code since we have no interpreter to put + * error message in. + */ + + goto error; + } + + Tcl_SetResult(interp, "missing close-brace", TCL_STATIC); + + /* + * Guess if the problem is due to comments by searching the source string + * for a possible open brace within the context of a comment. Since we + * aren't performing a full Tcl parse, just look for an open brace + * preceded by a '#' on the same line. + */ + + { + register int openBrace = 0; + + for (; src > start; src--) { + switch (*src) { + case '{': + openBrace = 1; + break; + case '\n': + openBrace = 0; + break; + case '#' : + if (openBrace && (isspace(UCHAR(src[-1])))) { + Tcl_AppendResult(interp, + ": possible unbalanced brace in comment", + (char *) NULL); + goto error; + } + break; + } + } + } + + error: + Tcl_FreeParse(parsePtr); + return TCL_ERROR; +} + /* *---------------------------------------------------------------------- * * Tcl_ParseQuotedString -- * - * Given a double-quoted string such as a quoted Tcl command argument - * or a quoted value in a Tcl expression, this procedure parses the - * string and returns information about the parse. No more than - * numBytes bytes will be scanned. + * Given a double-quoted string such as a quoted Tcl command argument or + * a quoted value in a Tcl expression, this function parses the string + * and returns information about the parse. No more than numBytes bytes + * will be scanned. * * Results: * The return value is TCL_OK if the string was parsed successfully and - * TCL_ERROR otherwise. If an error occurs and interp isn't NULL then - * an error message is left in its result. On a successful return, - * tokenPtr and numTokens fields of parsePtr are filled in with - * information about the string that was parsed. Other fields in - * parsePtr are undefined. termPtr is set to point to the character - * just after the quoted string's terminating close-quote. + * TCL_ERROR otherwise. If an error occurs and interp isn't NULL then an + * error message is left in its result. On a successful return, tokenPtr + * and numTokens fields of parsePtr are filled in with information about + * the string that was parsed. Other fields in parsePtr are undefined. + * termPtr is set to point to the character just after the quoted + * string's terminating close-quote. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the command, then additional space is - * malloc-ed. If the procedure returns TCL_OK then the caller must - * eventually invoke Tcl_FreeParse to release any additional space - * that was allocated. + * If there is insufficient space in parsePtr to hold all the information + * about the command, then additional space is malloc-ed. If the function + * returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to + * release any additional space that was allocated. * *---------------------------------------------------------------------- */ int -Tcl_ParseQuotedString(interp, string, numBytes, parsePtr, append, termPtr) - Tcl_Interp *interp; /* Interpreter to use for error reporting; - * if NULL, then no error message is - * provided. */ - CONST char *string; /* String containing the quoted string. - * The first character must be '"'. */ +Tcl_ParseQuotedString(interp, start, numBytes, parsePtr, append, termPtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting; if + * NULL, then no error message is provided. */ + CONST char *start; /* Start of the quoted string. The first + * character must be '"'. */ register int numBytes; /* Total number of bytes in string. If < 0, - * the string consists of all bytes up to - * the first null character. */ + * the string consists of all bytes up to the + * first null character. */ register Tcl_Parse *parsePtr; - /* Structure to fill in with information - * about the string. */ + /* Structure to fill in with information about + * the string. */ int append; /* Non-zero means append tokens to existing - * information in parsePtr; zero means - * ignore existing tokens in parsePtr and + * information in parsePtr; zero means ignore + * existing tokens in parsePtr and * reinitialize it. */ CONST char **termPtr; /* If non-NULL, points to word in which to - * store a pointer to the character just - * after the quoted string's terminating - * close-quote if the parse succeeds. */ + * store a pointer to the character just after + * the quoted string's terminating close-quote + * if the parse succeeds. */ { - if ((numBytes == 0) || (string == NULL)) { + if ((numBytes == 0) || (start == NULL)) { return TCL_ERROR; } if (numBytes < 0) { - numBytes = strlen(string); + numBytes = strlen(start); } if (!append) { - TclParseInit(interp, string, numBytes, parsePtr); + TclParseInit(interp, start, numBytes, parsePtr); } - - if (TCL_OK != ParseTokens(string+1, numBytes-1, TYPE_QUOTE, + + if (TCL_OK != ParseTokens(start+1, numBytes-1, TYPE_QUOTE, TCL_SUBST_ALL, parsePtr)) { goto error; } if (*parsePtr->term != '"') { if (interp != NULL) { Tcl_SetResult(parsePtr->interp, "missing \"", TCL_STATIC); } parsePtr->errorType = TCL_PARSE_MISSING_QUOTE; - parsePtr->term = string; + parsePtr->term = start; parsePtr->incomplete = 1; goto error; } if (termPtr != NULL) { *termPtr = (parsePtr->term + 1); } return TCL_OK; - error: + error: Tcl_FreeParse(parsePtr); return TCL_ERROR; } - + /* *---------------------------------------------------------------------- * * Tcl_SubstObj -- * - * This function performs the substitutions specified on the - * given string as described in the user documentation for the - * "subst" Tcl command. + * This function performs the substitutions specified on the given string + * as described in the user documentation for the "subst" Tcl command. * * Results: - * A Tcl_Obj* containing the substituted string, or NULL to - * indicate that an error occurred. + * A Tcl_Obj* containing the substituted string, or NULL to indicate that + * an error occurred. * * Side effects: - * See the user documentation. + * See the user documentation. * *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_SubstObj(interp, objPtr, flags) - Tcl_Interp *interp; /* Interpreter in which substitution occurs */ - Tcl_Obj *objPtr; /* The value to be substituted */ - int flags; /* What substitutions to do */ + Tcl_Interp *interp; /* Interpreter in which substitution occurs */ + Tcl_Obj *objPtr; /* The value to be substituted. */ + int flags; /* What substitutions to do. */ { int length, tokensLeft, code; Tcl_Parse parse; Tcl_Token *endTokenPtr; Tcl_Obj *result; @@ -1728,32 +1769,31 @@ CONST char *p = Tcl_GetStringFromObj(objPtr, &length); TclParseInit(interp, p, length, &parse); /* - * First parse the string rep of objPtr, as if it were enclosed - * as a "-quoted word in a normal Tcl command. Honor flags that - * selectively inhibit types of substitution. + * First parse the string rep of objPtr, as if it were enclosed as a + * "-quoted word in a normal Tcl command. Honor flags that selectively + * inhibit types of substitution. */ if (TCL_OK != ParseTokens(p, length, /* mask */ 0, flags, &parse)) { - /* - * There was a parse error. Save the error message for - * possible reporting later. + * There was a parse error. Save the error message for possible + * reporting later. */ errMsg = Tcl_GetObjResult(interp); Tcl_IncrRefCount(errMsg); /* - * We need to re-parse to get the portion of the string we can - * [subst] before the parse error. Sadly, all the Tcl_Token's - * created by the first parse attempt are gone, freed according to the - * public spec for the Tcl_Parse* routines. The only clue we have - * is parse.term, which points to either the unmatched opener, or - * to characters that follow a close brace or close quote. + * We need to re-parse to get the portion of the string we can [subst] + * before the parse error. Sadly, all the Tcl_Token's created by the + * first parse attempt are gone, freed according to the public spec + * for the Tcl_Parse* routines. The only clue we have is parse.term, + * which points to either the unmatched opener, or to characters that + * follow a close brace or close quote. * * Call ParseTokens again, working on the string up to parse.term. * Keep repeating until we get a good parse on a prefix. */ @@ -1763,127 +1803,138 @@ parse.end = parse.term; parse.incomplete = 0; parse.errorType = TCL_PARSE_SUCCESS; } while (TCL_OK != ParseTokens(p, parse.end - p, 0, flags, &parse)); - /* The good parse will have to be followed by {, (, or [. */ - switch (*parse.term) { - case '{': - /* - * Parse error was a missing } in a ${varname} variable - * substitution at the toplevel. We will subst everything - * up to that broken variable substitution before reporting - * the parse error. Substituting the leftover '$' will - * have no side-effects, so the current token stream is fine. - */ - break; - case '(': - /* - * Parse error was during the parsing of the index part of - * an array variable substitution at the toplevel. - */ - if (*(parse.term - 1) == '$') { - /* - * Special case where removing the array index left - * us with just a dollar sign (array variable with - * name the empty string as its name), instead of - * with a scalar variable reference. - * - * As in the previous case, existing token stream is OK. - */ - } else { - /* The current parse includes a successful parse of a - * scalar variable substitution where there should have - * been an array variable substitution. We remove that - * mistaken part of the parse before moving on. A scalar - * variable substitution is two tokens. - */ - Tcl_Token *varTokenPtr = - parse.tokenPtr + parse.numTokens - 2; - - if (varTokenPtr->type != TCL_TOKEN_VARIABLE) { - Tcl_Panic("Tcl_SubstObj: programming error"); - } - if (varTokenPtr[1].type != TCL_TOKEN_TEXT) { - Tcl_Panic("Tcl_SubstObj: programming error"); - } - parse.numTokens -= 2; - } - break; - case '[': - /* - * Parse error occurred during parsing of a toplevel - * command substitution. - */ - - parse.end = p + length; - p = parse.term + 1; - length = parse.end - p; - if (length == 0) { - /* - * No commands, just an unmatched [. - * As in previous cases, existing token stream is OK. - */ - } else { - /* - * We want to add the parsing of as many commands as we - * can within that substitution until we reach the - * actual parse error. We'll do additional parsing to - * determine what length to claim for the final - * TCL_TOKEN_COMMAND token. - */ - Tcl_Token *tokenPtr; - Tcl_Parse nested; - CONST char *lastTerm = parse.term; - - while (TCL_OK == - Tcl_ParseCommand(NULL, p, length, 0, &nested)) { - Tcl_FreeParse(&nested); - p = nested.term + (nested.term < nested.end); - length = nested.end - p; - if ((length == 0) && (nested.term == nested.end)) { - /* - * If we run out of string, blame the missing - * close bracket on the last command, and do - * not evaluate it during substitution. - */ - break; - } - lastTerm = nested.term; - } - - if (lastTerm == parse.term) { - /* - * Parse error in first command. No commands - * to subst, add no more tokens. - */ - break; - } - - /* - * Create a command substitution token for whatever - * commands got parsed. - */ - - if (parse.numTokens == parse.tokensAvailable) { - TclExpandTokenArray(&parse); - } - tokenPtr = &parse.tokenPtr[parse.numTokens]; - tokenPtr->start = parse.term; - tokenPtr->numComponents = 0; - tokenPtr->type = TCL_TOKEN_COMMAND; - tokenPtr->size = lastTerm - tokenPtr->start + 1; - parse.numTokens++; - } - break; - - default: - Tcl_Panic("bad parse in Tcl_SubstObj: %c", p[length]); - } - } - - /* Next, substitute the parsed tokens just as in normal Tcl evaluation */ + /* + * The good parse will have to be followed by {, (, or [. + */ + + switch (*parse.term) { + case '{': + /* + * Parse error was a missing } in a ${varname} variable + * substitution at the toplevel. We will subst everything up to + * that broken variable substitution before reporting the parse + * error. Substituting the leftover '$' will have no side-effects, + * so the current token stream is fine. + */ + break; + + case '(': + /* + * Parse error was during the parsing of the index part of an + * array variable substitution at the toplevel. + */ + + if (*(parse.term - 1) == '$') { + /* + * Special case where removing the array index left us with + * just a dollar sign (array variable with name the empty + * string as its name), instead of with a scalar variable + * reference. + * + * As in the previous case, existing token stream is OK. + */ + } else { + /* + * The current parse includes a successful parse of a scalar + * variable substitution where there should have been an array + * variable substitution. We remove that mistaken part of the + * parse before moving on. A scalar variable substitution is + * two tokens. + */ + + Tcl_Token *varTokenPtr = + parse.tokenPtr + parse.numTokens - 2; + + if (varTokenPtr->type != TCL_TOKEN_VARIABLE) { + Tcl_Panic("Tcl_SubstObj: programming error"); + } + if (varTokenPtr[1].type != TCL_TOKEN_TEXT) { + Tcl_Panic("Tcl_SubstObj: programming error"); + } + parse.numTokens -= 2; + } + break; + case '[': + /* + * Parse error occurred during parsing of a toplevel command + * substitution. + */ + + parse.end = p + length; + p = parse.term + 1; + length = parse.end - p; + if (length == 0) { + /* + * No commands, just an unmatched [. As in previous cases, + * existing token stream is OK. + */ + } else { + /* + * We want to add the parsing of as many commands as we can + * within that substitution until we reach the actual parse + * error. We'll do additional parsing to determine what + * length to claim for the final TCL_TOKEN_COMMAND token. + */ + + Tcl_Token *tokenPtr; + Tcl_Parse nested; + CONST char *lastTerm = parse.term; + + while (TCL_OK == + Tcl_ParseCommand(NULL, p, length, 0, &nested)) { + Tcl_FreeParse(&nested); + p = nested.term + (nested.term < nested.end); + length = nested.end - p; + if ((length == 0) && (nested.term == nested.end)) { + /* + * If we run out of string, blame the missing close + * bracket on the last command, and do not evaluate it + * during substitution. + */ + + break; + } + lastTerm = nested.term; + } + + if (lastTerm == parse.term) { + /* + * Parse error in first command. No commands to subst, + * add no more tokens. + */ + break; + } + + /* + * Create a command substitution token for whatever commands + * got parsed. + */ + + if (parse.numTokens == parse.tokensAvailable) { + TclExpandTokenArray(&parse); + } + tokenPtr = &parse.tokenPtr[parse.numTokens]; + tokenPtr->start = parse.term; + tokenPtr->numComponents = 0; + tokenPtr->type = TCL_TOKEN_COMMAND; + tokenPtr->size = lastTerm - tokenPtr->start + 1; + parse.numTokens++; + } + break; + + default: + Tcl_Panic("bad parse in Tcl_SubstObj: %c", p[length]); + } + } + + /* + * Next, substitute the parsed tokens just as in normal Tcl evaluation. + */ + endTokenPtr = parse.tokenPtr + parse.numTokens; tokensLeft = parse.numTokens; code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft, &tokensLeft); if (code == TCL_OK) { @@ -1893,24 +1944,25 @@ Tcl_DecrRefCount(errMsg); return NULL; } return Tcl_GetObjResult(interp); } + result = Tcl_NewObj(); while (1) { switch (code) { - case TCL_ERROR: - Tcl_FreeParse(&parse); - Tcl_DecrRefCount(result); - if (errMsg != NULL) { - Tcl_DecrRefCount(errMsg); - } - return NULL; - case TCL_BREAK: - tokensLeft = 0; /* Halt substitution */ - default: - Tcl_AppendObjToObj(result, Tcl_GetObjResult(interp)); + case TCL_ERROR: + Tcl_FreeParse(&parse); + Tcl_DecrRefCount(result); + if (errMsg != NULL) { + Tcl_DecrRefCount(errMsg); + } + return NULL; + case TCL_BREAK: + tokensLeft = 0; /* Halt substitution */ + default: + Tcl_AppendObjToObj(result, Tcl_GetObjResult(interp)); } if (tokensLeft == 0) { Tcl_FreeParse(&parse); if (errMsg != NULL) { @@ -1927,154 +1979,170 @@ code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft, &tokensLeft); } } - + /* *---------------------------------------------------------------------- * * TclSubstTokens -- * - * Accepts an array of count Tcl_Token's, and creates a result - * value in the interp from concatenating the results of - * performing Tcl substitution on each Tcl_Token. Substitution - * is interrupted if any non-TCL_OK completion code arises. + * Accepts an array of count Tcl_Token's, and creates a result value in + * the interp from concatenating the results of performing Tcl + * substitution on each Tcl_Token. Substitution is interrupted if any + * non-TCL_OK completion code arises. * * Results: - * The return value is a standard Tcl completion code. The - * result in interp is the substituted value, or an error message - * if TCL_ERROR is returned. If tokensLeftPtr is not NULL, then - * it points to an int where the number of tokens remaining to - * be processed is written. + * The return value is a standard Tcl completion code. The result in + * interp is the substituted value, or an error message if TCL_ERROR is + * returned. If tokensLeftPtr is not NULL, then it points to an int where + * the number of tokens remaining to be processed is written. * * Side effects: * Can be anything, depending on the types of substitution done. * *---------------------------------------------------------------------- */ int TclSubstTokens(interp, tokenPtr, count, tokensLeftPtr) - Tcl_Interp *interp; /* Interpreter in which to lookup - * variables, execute nested commands, - * and report errors. */ - Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens - * to evaluate and concatenate. */ - int count; /* Number of tokens to consider at tokenPtr. - * Must be at least 1. */ + Tcl_Interp *interp; /* Interpreter in which to lookup variables, + * execute nested commands, and report + * errors. */ + Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens to + * evaluate and concatenate. */ + int count; /* Number of tokens to consider at tokenPtr. + * Must be at least 1. */ int *tokensLeftPtr; /* If not NULL, points to memory where an * integer representing the number of tokens * left to be substituted will be written */ { Tcl_Obj *result; int code = TCL_OK; /* * Each pass through this loop will substitute one token, and its - * components, if any. The only thing tricky here is that we go to - * some effort to pass Tcl_Obj's through untouched, to avoid string - * copying and Tcl_Obj creation if possible, to aid performance and - * limit shimmering. - * - * Further optimization opportunities might be to check for the - * equivalent of Tcl_SetObjResult(interp, Tcl_GetObjResult(interp)) - * and omit them. + * components, if any. The only thing tricky here is that we go to some + * effort to pass Tcl_Obj's through untouched, to avoid string copying and + * Tcl_Obj creation if possible, to aid performance and limit shimmering. + * + * Further optimization opportunities might be to check for the equivalent + * of Tcl_SetObjResult(interp, Tcl_GetObjResult(interp)) and omit them. */ result = NULL; - for ( ; (count > 0) && (code == TCL_OK); count--, tokenPtr++) { + for (; count>0 && code==TCL_OK ; count--, tokenPtr++) { Tcl_Obj *appendObj = NULL; CONST char *append = NULL; int appendByteLength = 0; char utfCharBytes[TCL_UTF_MAX]; switch (tokenPtr->type) { - case TCL_TOKEN_TEXT: - append = tokenPtr->start; - appendByteLength = tokenPtr->size; - break; - - case TCL_TOKEN_BS: { - appendByteLength = Tcl_UtfBackslash(tokenPtr->start, - (int *) NULL, utfCharBytes); - append = utfCharBytes; - break; - } - - case TCL_TOKEN_COMMAND: + case TCL_TOKEN_TEXT: + append = tokenPtr->start; + appendByteLength = tokenPtr->size; + break; + + case TCL_TOKEN_BS: + appendByteLength = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, + utfCharBytes); + append = utfCharBytes; + break; + + case TCL_TOKEN_COMMAND: { + Interp *iPtr = (Interp *) interp; + + iPtr->numLevels++; + code = TclInterpReady(interp); + if (code == TCL_OK) { code = Tcl_EvalEx(interp, tokenPtr->start+1, tokenPtr->size-2, 0); - appendObj = Tcl_GetObjResult(interp); - break; - - case TCL_TOKEN_VARIABLE: { - Tcl_Obj *arrayIndex = NULL; - Tcl_Obj *varName = NULL; - if (tokenPtr->numComponents > 1) { - /* Subst the index part of an array variable reference */ - code = TclSubstTokens(interp, tokenPtr+2, - tokenPtr->numComponents - 1, NULL); - arrayIndex = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(arrayIndex); - } - - if (code == TCL_OK) { - varName = Tcl_NewStringObj(tokenPtr[1].start, - tokenPtr[1].size); - appendObj = Tcl_ObjGetVar2(interp, varName, arrayIndex, - TCL_LEAVE_ERR_MSG); - Tcl_DecrRefCount(varName); - if (appendObj == NULL) { - code = TCL_ERROR; - } - } - - switch (code) { - case TCL_OK: /* Got value */ - case TCL_ERROR: /* Already have error message */ - case TCL_BREAK: /* Will not substitute anyway */ - case TCL_CONTINUE: /* Will not substitute anyway */ - break; - default: - /* All other return codes, we will subst the - * result from the code-throwing evaluation */ - appendObj = Tcl_GetObjResult(interp); - } - - if (arrayIndex != NULL) { - Tcl_DecrRefCount(arrayIndex); - } - count -= tokenPtr->numComponents; - tokenPtr += tokenPtr->numComponents; - break; - } - - default: - Tcl_Panic("unexpected token type in TclSubstTokens: %d", - tokenPtr->type); + } + iPtr->numLevels--; + appendObj = Tcl_GetObjResult(interp); + break; + } + + case TCL_TOKEN_VARIABLE: { + Tcl_Obj *arrayIndex = NULL; + Tcl_Obj *varName = NULL; + + if (tokenPtr->numComponents > 1) { + /* + * Subst the index part of an array variable reference. + */ + + code = TclSubstTokens(interp, tokenPtr+2, + tokenPtr->numComponents - 1, NULL); + arrayIndex = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(arrayIndex); + } + + if (code == TCL_OK) { + varName = Tcl_NewStringObj(tokenPtr[1].start, + tokenPtr[1].size); + appendObj = Tcl_ObjGetVar2(interp, varName, arrayIndex, + TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(varName); + if (appendObj == NULL) { + code = TCL_ERROR; + } + } + + switch (code) { + case TCL_OK: /* Got value */ + case TCL_ERROR: /* Already have error message */ + case TCL_BREAK: /* Will not substitute anyway */ + case TCL_CONTINUE: /* Will not substitute anyway */ + break; + default: + /* + * All other return codes, we will subst the result from the + * code-throwing evaluation. + */ + + appendObj = Tcl_GetObjResult(interp); + } + + if (arrayIndex != NULL) { + Tcl_DecrRefCount(arrayIndex); + } + count -= tokenPtr->numComponents; + tokenPtr += tokenPtr->numComponents; + break; + } + + default: + Tcl_Panic("unexpected token type in TclSubstTokens: %d", + tokenPtr->type); } if ((code == TCL_BREAK) || (code == TCL_CONTINUE)) { - /* Inhibit substitution */ + /* + * Inhibit substitution. + */ continue; } if (result == NULL) { - /* - * First pass through. If we have a Tcl_Obj, just use it. - * If not, create one from our string. + /* + * First pass through. If we have a Tcl_Obj, just use it. If not, + * create one from our string. */ if (appendObj != NULL) { result = appendObj; } else { - result = Tcl_NewStringObj(append, appendByteLength);; + result = Tcl_NewStringObj(append, appendByteLength); } Tcl_IncrRefCount(result); } else { - /* Subsequent passes. Append to result. */ + /* + * Subsequent passes. Append to result. + */ + if (Tcl_IsShared(result)) { Tcl_DecrRefCount(result); result = Tcl_DuplicateObj(result); Tcl_IncrRefCount(result); } @@ -2084,11 +2152,11 @@ Tcl_AppendToObj(result, append, appendByteLength); } } } - if (code != TCL_ERROR) { /* Keep error message in result! */ + if (code != TCL_ERROR) { /* Keep error message in result! */ if (result != NULL) { Tcl_SetObjResult(interp, result); } else { Tcl_ResetResult(interp); } @@ -2105,29 +2173,29 @@ /* *---------------------------------------------------------------------- * * CommandComplete -- * - * This procedure is shared by TclCommandComplete and - * Tcl_ObjCommandComplete; it does all the real work of seeing - * whether a script is complete + * This function is shared by TclCommandComplete and + * Tcl_ObjCommandComplete; it does all the real work of seeing whether a + * script is complete * * Results: * 1 is returned if the script is complete, 0 if there are open - * delimiters such as " or (. 1 is also returned if there is a - * parse error in the script other than unmatched delimiters. + * delimiters such as " or (. 1 is also returned if there is a parse + * error in the script other than unmatched delimiters. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int CommandComplete(script, numBytes) - CONST char *script; /* Script to check. */ - int numBytes; /* Number of bytes in script. */ + CONST char *script; /* Script to check. */ + int numBytes; /* Number of bytes in script. */ { Tcl_Parse parse; CONST char *p, *end; int result; @@ -2147,46 +2215,46 @@ result = 1; } Tcl_FreeParse(&parse); return result; } - + /* *---------------------------------------------------------------------- * * Tcl_CommandComplete -- * - * Given a partial or complete Tcl script, this procedure - * determines whether the script is complete in the sense - * of having matched braces and quotes and brackets. + * Given a partial or complete Tcl script, this function determines + * whether the script is complete in the sense of having matched braces + * and quotes and brackets. * * Results: - * 1 is returned if the script is complete, 0 otherwise. - * 1 is also returned if there is a parse error in the script - * other than unmatched delimiters. + * 1 is returned if the script is complete, 0 otherwise. 1 is also + * returned if there is a parse error in the script other than unmatched + * delimiters. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_CommandComplete(script) - CONST char *script; /* Script to check. */ + CONST char *script; /* Script to check. */ { return CommandComplete(script, (int) strlen(script)); } - + /* *---------------------------------------------------------------------- * * TclObjCommandComplete -- * - * Given a partial or complete Tcl command in a Tcl object, this - * procedure determines whether the command is complete in the sense of - * having matched braces and quotes and brackets. + * Given a partial or complete Tcl command in a Tcl object, this function + * determines whether the command is complete in the sense of having + * matched braces and quotes and brackets. * * Results: * 1 is returned if the command is complete, 0 otherwise. * * Side effects: @@ -2195,27 +2263,27 @@ *---------------------------------------------------------------------- */ int TclObjCommandComplete(objPtr) - Tcl_Obj *objPtr; /* Points to object holding script - * to check. */ + Tcl_Obj *objPtr; /* Points to object holding script to + * check. */ { CONST char *script; int length; script = Tcl_GetStringFromObj(objPtr, &length); return CommandComplete(script, length); } - + /* *---------------------------------------------------------------------- * * TclIsLocalScalar -- * - * Check to see if a given string is a legal scalar variable - * name with no namespace qualifiers or substitutions. + * Check to see if a given string is a legal scalar variable name with no + * namespace qualifiers or substitutions. * * Results: * Returns 1 if the variable is a local scalar. * * Side effects: @@ -2230,17 +2298,17 @@ int len; { CONST char *p; CONST char *lastChar = src + (len - 1); - for (p = src; p <= lastChar; p++) { + for (p=src ; p<=lastChar ; p++) { if ((CHAR_TYPE(*p) != TYPE_NORMAL) && (CHAR_TYPE(*p) != TYPE_COMMAND_END)) { /* - * TCL_COMMAND_END is returned for the last character - * of the string. By this point we know it isn't - * an array or namespace reference. + * TCL_COMMAND_END is returned for the last character of the + * string. By this point we know it isn't an array or namespace + * reference. */ return 0; } if (*p == '(') { @@ -2251,8 +2319,16 @@ if ((p != lastChar) && *(p+1) == ':') { /* qualified name */ return 0; } } } - + return 1; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclParseExpr.c ================================================================== --- generic/tclParseExpr.c +++ generic/tclParseExpr.c @@ -1,77 +1,59 @@ -/* +/* * tclParseExpr.c -- * - * This file contains procedures that parse Tcl expressions. They - * do so in a general-purpose fashion that can be used for many - * different purposes, including compilation, direct execution, - * code analysis, etc. + * This file contains functions that parse Tcl expressions. They do so in + * a general-purpose fashion that can be used for many different + * purposes, including compilation, direct execution, code analysis, etc. * * Copyright (c) 1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Contributions from Don Porter, NIST, 2002. (not subject to US copyright) * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * 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.23 2004/10/08 15:39:55 dkf Exp $ + * RCS: @(#) $Id: tclParseExpr.c,v 1.23.2.12 2005/08/23 18:28:51 kennykb 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. + * Boolean variable that controls whether expression parse tracing is enabled. */ #ifdef TCL_COMPILE_DEBUG static int traceParseExpr = 0; #endif /* TCL_COMPILE_DEBUG */ /* - * The ParseInfo structure holds state while parsing an expression. - * A pointer to an ParseInfo record is passed among the routines in - * this module. + * The ParseInfo structure holds state while parsing an expression. A pointer + * to an ParseInfo record is passed among the routines in this module. */ typedef struct ParseInfo { Tcl_Parse *parsePtr; /* Points to structure to fill in with * information about the expression. */ - int lexeme; /* Type of last lexeme scanned in expr. - * See below for definitions. Corresponds to - * size characters beginning at start. */ + int lexeme; /* Type of last lexeme scanned in expr. See + * below for definitions. Corresponds to size + * characters beginning at start. */ CONST char *start; /* First character in lexeme. */ int size; /* Number of bytes in lexeme. */ CONST char *next; /* Position of the next character to be * scanned in the expression string. */ - CONST char *prevEnd; /* Points to the character just after the - * last one in the previous lexeme. Used to - * compute size of subexpression tokens. */ + CONST char *prevEnd; /* Points to the character just after the last + * one in the previous lexeme. Used to compute + * size of subexpression tokens. */ CONST char *originalExpr; /* Points to the start of the expression * originally passed to Tcl_ParseExpr. */ CONST char *lastChar; /* Points just after last byte of expr. */ } ParseInfo; /* - * Definitions of the different lexemes that appear in expressions. The - * order of these must match the corresponding entries in the - * operatorStrings array below. + * Definitions of the different lexemes that appear in expressions. The order + * of these must match the corresponding entries in the operatorStrings array + * below. * * Basic lexemes: */ #define LITERAL 0 @@ -139,12 +121,12 @@ #define IN_LIST 37 #define NOT_IN_LIST 38 /* - * Mapping from lexemes to strings; used for debugging messages. These - * entries must match the order and number of the lexeme definitions above. + * Mapping from lexemes to strings; used for debugging messages. These entries + * must match the order and number of the lexeme definitions above. */ static char *lexemeStrings[] = { "LITERAL", "FUNCNAME", "[", "{", "(", ")", "$", "\"", ",", "END", "UNKNOWN", "UNKNOWN_CHAR", @@ -153,39 +135,37 @@ "&", "^", "|", "&&", "||", "?", ":", "!", "~", "eq", "ne", "**", "in", "ni" }; /* - * Declarations for local procedures to this file: + * Declarations for local functions to this file: */ static int GetLexeme _ANSI_ARGS_((ParseInfo *infoPtr)); static void LogSyntaxError _ANSI_ARGS_((ParseInfo *infoPtr, - CONST char *extraInfo)); + CONST char *extraInfo)); static int ParseAddExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseBitAndExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseBitOrExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseBitXorExpr _ANSI_ARGS_((ParseInfo *infoPtr)); 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)); static int ParseShiftExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseExponentialExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseUnaryExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static void PrependSubExprTokens _ANSI_ARGS_((CONST char *op, - int opBytes, CONST char *src, int srcBytes, - int firstIndex, ParseInfo *infoPtr)); + int opBytes, CONST char *src, int srcBytes, + int firstIndex, ParseInfo *infoPtr)); /* - * Macro used to debug the execution of the recursive descent parser used - * to parse expressions. + * Macro used to debug the execution of the recursive descent parser used to + * parse expressions. */ #ifdef TCL_COMPILE_DEBUG #define HERE(production, level) \ if (traceParseExpr) { \ @@ -200,73 +180,73 @@ /* *---------------------------------------------------------------------- * * Tcl_ParseExpr -- * - * Given a string, this procedure parses the first Tcl expression - * in the string and returns information about the structure of - * the expression. This procedure is the top-level interface to the - * the expression parsing module. No more that numBytes bytes will - * be scanned. + * Given a string, this function parses the first Tcl expression in the + * string and returns information about the structure of the expression. + * This function is the top-level interface to the the expression parsing + * module. No more than numBytes bytes will be scanned. + * + * Note that this parser is a LL(1) parser; the operator precedence rules + * are completely hard coded in the recursive structure of the parser + * itself. * * Results: - * The return value is TCL_OK if the command was parsed successfully - * and TCL_ERROR otherwise. If an error occurs and interp isn't NULL - * then an error message is left in its result. On a successful return, - * parsePtr is filled in with information about the expression that - * was parsed. + * The return value is TCL_OK if the command was parsed successfully and + * TCL_ERROR otherwise. If an error occurs and interp isn't NULL then an + * error message is left in its result. On a successful return, parsePtr + * is filled in with information about the expression that was parsed. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the expression, then additional space is - * malloc-ed. If the procedure returns TCL_OK then the caller must - * eventually invoke Tcl_FreeParse to release any additional space - * that was allocated. + * If there is insufficient space in parsePtr to hold all the information + * about the expression, then additional space is malloc-ed. If the + * function returns TCL_OK then the caller must eventually invoke + * Tcl_FreeParse to release any additional space that was allocated. * *---------------------------------------------------------------------- */ int -Tcl_ParseExpr(interp, string, numBytes, parsePtr) +Tcl_ParseExpr(interp, start, numBytes, parsePtr) Tcl_Interp *interp; /* Used for error reporting. */ - CONST char *string; /* The source string to parse. */ + CONST char *start; /* Start of source string to parse. */ int numBytes; /* Number of bytes in string. If < 0, the * string consists of all bytes up to the * first null character. */ Tcl_Parse *parsePtr; /* Structure to fill with information about * the parsed expression; any previous - * information in the structure is - * ignored. */ + * information in the structure is ignored. */ { ParseInfo info; int code; if (numBytes < 0) { - numBytes = (string? strlen(string) : 0); + numBytes = (start? strlen(start) : 0); } #ifdef TCL_COMPILE_DEBUG if (traceParseExpr) { fprintf(stderr, "Tcl_ParseExpr: string=\"%.*s\"\n", - numBytes, string); + numBytes, start); } #endif /* TCL_COMPILE_DEBUG */ - - TclParseInit(interp, string, numBytes, parsePtr); + + TclParseInit(interp, start, numBytes, parsePtr); /* - * Initialize the ParseInfo structure that holds state while parsing - * the expression. + * Initialize the ParseInfo structure that holds state while parsing the + * expression. */ info.parsePtr = parsePtr; info.lexeme = UNKNOWN; info.start = NULL; info.size = 0; - info.next = string; - info.prevEnd = string; - info.originalExpr = string; - info.lastChar = (string + numBytes); /* just after last char of expr */ + info.next = start; + info.prevEnd = start; + info.originalExpr = start; + info.lastChar = (start + numBytes); /* just after last char of expr */ /* * Get the first lexeme then parse the expression. */ @@ -281,12 +261,12 @@ if (info.lexeme != END) { LogSyntaxError(&info, "extra tokens at end of expression"); goto error; } return TCL_OK; - - error: + + error: if (parsePtr->tokenPtr != parsePtr->staticTokens) { ckfree((char *) parsePtr->tokenPtr); } return TCL_ERROR; } @@ -294,84 +274,83 @@ /* *---------------------------------------------------------------------- * * ParseCondExpr -- * - * This procedure parses a Tcl conditional expression: + * This function parses a Tcl conditional expression: * condExpr ::= lorExpr ['?' condExpr ':' condExpr] * * Note that this is the topmost recursive-descent parsing routine used - * by Tcl_ParseExpr to parse expressions. This avoids an extra procedure - * call since such a procedure would only return the result of calling - * ParseCondExpr. Other recursive-descent procedures that need to parse + * by Tcl_ParseExpr to parse expressions. This avoids an extra function + * call since such a function would only return the result of calling + * ParseCondExpr. Other recursive-descent functions that need to parse * complete expressions also call ParseCondExpr. * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseCondExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; Tcl_Token *tokenPtr, *firstTokenPtr, *condTokenPtr; int firstIndex, numToMove, code; CONST char *srcStart; - + HERE("condExpr", 1); srcStart = infoPtr->start; firstIndex = parsePtr->numTokens; - + code = ParseLorExpr(infoPtr); if (code != TCL_OK) { return code; } - + if (infoPtr->lexeme == QUESTY) { /* * Emit two tokens: one TCL_TOKEN_SUB_EXPR token for the entire - * conditional expression, and a TCL_TOKEN_OPERATOR token for - * the "?" operator. Note that these two tokens must be inserted - * before the LOR operand tokens generated above. + * conditional expression, and a TCL_TOKEN_OPERATOR token for the "?" + * operator. Note that these two tokens must be inserted before the + * LOR operand tokens generated above. */ if ((parsePtr->numTokens + 1) >= parsePtr->tokensAvailable) { TclExpandTokenArray(parsePtr); } firstTokenPtr = &parsePtr->tokenPtr[firstIndex]; tokenPtr = (firstTokenPtr + 2); numToMove = (parsePtr->numTokens - firstIndex); memmove((VOID *) tokenPtr, (VOID *) firstTokenPtr, - (size_t) (numToMove * sizeof(Tcl_Token))); + (size_t) (numToMove * sizeof(Tcl_Token))); parsePtr->numTokens += 2; - + tokenPtr = firstTokenPtr; tokenPtr->type = TCL_TOKEN_SUB_EXPR; tokenPtr->start = srcStart; - + tokenPtr++; tokenPtr->type = TCL_TOKEN_OPERATOR; tokenPtr->start = infoPtr->start; tokenPtr->size = 1; tokenPtr->numComponents = 0; - + /* * Skip over the '?'. */ - - code = GetLexeme(infoPtr); + + code = GetLexeme(infoPtr); if (code != TCL_OK) { return code; } /* @@ -414,39 +393,38 @@ /* *---------------------------------------------------------------------- * * ParseLorExpr -- * - * This procedure parses a Tcl logical or expression: + * This function parses a Tcl logical or expression: * lorExpr ::= landExpr {'||' landExpr} * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseLorExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, code; CONST char *srcStart, *operator; - + HERE("lorExpr", 2); srcStart = infoPtr->start; firstIndex = parsePtr->numTokens; - + code = ParseLandExpr(infoPtr); if (code != TCL_OK) { return code; } @@ -464,49 +442,48 @@ /* * Generate tokens for the LOR subexpression and the '||' operator. */ PrependSubExprTokens(operator, 2, srcStart, - (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * * ParseLandExpr -- * - * This procedure parses a Tcl logical and expression: + * This function parses a Tcl logical and expression: * landExpr ::= bitOrExpr {'&&' bitOrExpr} * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseLandExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, code; CONST char *srcStart, *operator; HERE("landExpr", 3); srcStart = infoPtr->start; firstIndex = parsePtr->numTokens; - + code = ParseBitOrExpr(infoPtr); if (code != TCL_OK) { return code; } @@ -524,54 +501,53 @@ /* * Generate tokens for the LAND subexpression and the '&&' operator. */ PrependSubExprTokens(operator, 2, srcStart, - (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * * ParseBitOrExpr -- * - * This procedure parses a Tcl bitwise or expression: + * This function parses a Tcl bitwise or expression: * bitOrExpr ::= bitXorExpr {'|' bitXorExpr} * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseBitOrExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, code; CONST char *srcStart, *operator; HERE("bitOrExpr", 4); srcStart = infoPtr->start; firstIndex = parsePtr->numTokens; - + code = ParseBitXorExpr(infoPtr); if (code != TCL_OK) { return code; } - + while (infoPtr->lexeme == BIT_OR) { operator = infoPtr->start; code = GetLexeme(infoPtr); /* skip over the '|' */ if (code != TCL_OK) { return code; @@ -579,60 +555,59 @@ code = ParseBitXorExpr(infoPtr); if (code != TCL_OK) { return code; } - + /* * Generate tokens for the BITOR subexpression and the '|' operator. */ PrependSubExprTokens(operator, 1, srcStart, - (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * * ParseBitXorExpr -- * - * This procedure parses a Tcl bitwise exclusive or expression: + * This function parses a Tcl bitwise exclusive or expression: * bitXorExpr ::= bitAndExpr {'^' bitAndExpr} * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseBitXorExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, code; CONST char *srcStart, *operator; HERE("bitXorExpr", 5); srcStart = infoPtr->start; firstIndex = parsePtr->numTokens; - + code = ParseBitAndExpr(infoPtr); if (code != TCL_OK) { return code; } - + while (infoPtr->lexeme == BIT_XOR) { operator = infoPtr->start; code = GetLexeme(infoPtr); /* skip over the '^' */ if (code != TCL_OK) { return code; @@ -640,60 +615,59 @@ code = ParseBitAndExpr(infoPtr); if (code != TCL_OK) { return code; } - + /* * Generate tokens for the XOR subexpression and the '^' operator. */ PrependSubExprTokens(operator, 1, srcStart, - (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * * ParseBitAndExpr -- * - * This procedure parses a Tcl bitwise and expression: + * This function parses a Tcl bitwise and expression: * bitAndExpr ::= equalityExpr {'&' equalityExpr} * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseBitAndExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, code; CONST char *srcStart, *operator; HERE("bitAndExpr", 6); srcStart = infoPtr->start; firstIndex = parsePtr->numTokens; - + code = ParseEqualityExpr(infoPtr); if (code != TCL_OK) { return code; } - + while (infoPtr->lexeme == BIT_AND) { operator = infoPtr->start; code = GetLexeme(infoPtr); /* skip over the '&' */ if (code != TCL_OK) { return code; @@ -700,56 +674,55 @@ } code = ParseEqualityExpr(infoPtr); if (code != TCL_OK) { return code; } - + /* * Generate tokens for the BITAND subexpression and '&' operator. */ PrependSubExprTokens(operator, 1, srcStart, - (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * * ParseEqualityExpr -- * - * This procedure parses a Tcl equality (inequality) expression: + * This function parses a Tcl equality (inequality) expression: * equalityExpr ::= relationalExpr * {('==' | '!=' | 'ne' | 'eq') relationalExpr} * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseEqualityExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, lexeme, code; CONST char *srcStart, *operator; HERE("equalityExpr", 7); srcStart = infoPtr->start; firstIndex = parsePtr->numTokens; - + code = ParseRelationalExpr(infoPtr); if (code != TCL_OK) { return code; } @@ -770,11 +743,11 @@ * Generate tokens for the subexpression and '==', '!=', 'eq' or 'ne' * operator. */ PrependSubExprTokens(operator, 2, srcStart, - (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); lexeme = infoPtr->lexeme; } return TCL_OK; } @@ -781,47 +754,46 @@ /* *---------------------------------------------------------------------- * * ParseRelationalExpr -- * - * This procedure parses a Tcl relational expression: + * This function parses a Tcl relational expression: * relationalExpr ::= shiftExpr {('<' | '>' | '<=' | '>=') shiftExpr} * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseRelationalExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, lexeme, operatorSize, code; CONST char *srcStart, *operator; HERE("relationalExpr", 8); srcStart = infoPtr->start; firstIndex = parsePtr->numTokens; - + code = ParseShiftExpr(infoPtr); if (code != TCL_OK) { return code; } lexeme = infoPtr->lexeme; while ((lexeme == LESS) || (lexeme == GREATER) || (lexeme == LEQ) - || (lexeme == GEQ)) { + || (lexeme == GEQ)) { operator = infoPtr->start; if ((lexeme == LEQ) || (lexeme == GEQ)) { operatorSize = 2; } else { operatorSize = 1; @@ -838,11 +810,11 @@ /* * Generate tokens for the subexpression and the operator. */ PrependSubExprTokens(operator, operatorSize, srcStart, - (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); lexeme = infoPtr->lexeme; } return TCL_OK; } @@ -849,48 +821,47 @@ /* *---------------------------------------------------------------------- * * ParseShiftExpr -- * - * This procedure parses a Tcl shift expression: + * This function parses a Tcl shift expression: * shiftExpr ::= addExpr {('<<' | '>>') addExpr} * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseShiftExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, lexeme, code; CONST char *srcStart, *operator; HERE("shiftExpr", 9); srcStart = infoPtr->start; firstIndex = parsePtr->numTokens; - + code = ParseAddExpr(infoPtr); if (code != TCL_OK) { return code; } lexeme = infoPtr->lexeme; while ((lexeme == LEFT_SHIFT) || (lexeme == RIGHT_SHIFT)) { operator = infoPtr->start; - code = GetLexeme(infoPtr); /* skip over << or >> */ + code = GetLexeme(infoPtr); /* skip over << or >> */ if (code != TCL_OK) { return code; } code = ParseAddExpr(infoPtr); if (code != TCL_OK) { @@ -900,11 +871,11 @@ /* * Generate tokens for the subexpression and '<<' or '>>' operator. */ PrependSubExprTokens(operator, 2, srcStart, - (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); lexeme = infoPtr->lexeme; } return TCL_OK; } @@ -911,39 +882,38 @@ /* *---------------------------------------------------------------------- * * ParseAddExpr -- * - * This procedure parses a Tcl addition expression: + * This function parses a Tcl addition expression: * addExpr ::= multiplyExpr {('+' | '-') multiplyExpr} * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseAddExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, lexeme, code; CONST char *srcStart, *operator; HERE("addExpr", 10); srcStart = infoPtr->start; firstIndex = parsePtr->numTokens; - + code = ParseMultiplyExpr(infoPtr); if (code != TCL_OK) { return code; } @@ -962,11 +932,11 @@ /* * Generate tokens for the subexpression and '+' or '-' operator. */ PrependSubExprTokens(operator, 1, srcStart, - (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); lexeme = infoPtr->lexeme; } return TCL_OK; } @@ -973,48 +943,47 @@ /* *---------------------------------------------------------------------- * * ParseMultiplyExpr -- * - * This procedure parses a Tcl multiply expression: + * This function parses a Tcl multiply expression: * multiplyExpr ::= exponentialExpr {('*' | '/' | '%') exponentialExpr} * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseMultiplyExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, lexeme, code; CONST char *srcStart, *operator; HERE("multiplyExpr", 11); srcStart = infoPtr->start; firstIndex = parsePtr->numTokens; - + code = ParseExponentialExpr(infoPtr); if (code != TCL_OK) { return code; } lexeme = infoPtr->lexeme; while ((lexeme == MULT) || (lexeme == DIVIDE) || (lexeme == MOD)) { operator = infoPtr->start; - code = GetLexeme(infoPtr); /* skip over * or / or % */ + code = GetLexeme(infoPtr); /* skip over * or / or % */ if (code != TCL_OK) { return code; } code = ParseExponentialExpr(infoPtr); if (code != TCL_OK) { @@ -1024,11 +993,11 @@ /* * Generate tokens for the subexpression and * or / or % operator. */ PrependSubExprTokens(operator, 1, srcStart, - (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); lexeme = infoPtr->lexeme; } return TCL_OK; } @@ -1035,30 +1004,29 @@ /* *---------------------------------------------------------------------- * * ParseExponentialExpr -- * - * This procedure parses a Tcl exponential expression: + * This function parses a Tcl exponential expression: * exponentialExpr ::= unaryExpr {'**' unaryExpr} * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseExponentialExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, lexeme, code; CONST char *srcStart, *operator; @@ -1091,49 +1059,47 @@ (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); lexeme = infoPtr->lexeme; } return TCL_OK; } - /* *---------------------------------------------------------------------- * * ParseUnaryExpr -- * - * This procedure parses a Tcl unary expression: + * This function parses a Tcl unary expression: * unaryExpr ::= ('+' | '-' | '~' | '!') unaryExpr | primaryExpr * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseUnaryExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, lexeme, code; CONST char *srcStart, *operator; HERE("unaryExpr", 13); srcStart = infoPtr->start; firstIndex = parsePtr->numTokens; - + lexeme = infoPtr->lexeme; if ((lexeme == PLUS) || (lexeme == MINUS) || (lexeme == BIT_NOT) - || (lexeme == NOT)) { + || (lexeme == NOT)) { operator = infoPtr->start; code = GetLexeme(infoPtr); /* skip over the unary operator */ if (code != TCL_OK) { return code; } @@ -1145,11 +1111,11 @@ /* * Generate tokens for the subexpression and the operator. */ PrependSubExprTokens(operator, 1, srcStart, - (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); } else { /* must be a primaryExpr */ code = ParsePrimaryExpr(infoPtr); if (code != TCL_OK) { return code; } @@ -1160,31 +1126,30 @@ /* *---------------------------------------------------------------------- * * ParsePrimaryExpr -- * - * This procedure parses a Tcl primary expression: + * This function parses a Tcl primary expression: * primaryExpr ::= literal | varReference | quotedString | * '[' command ']' | mathFuncCall | '(' condExpr ')' * * Results: - * The return value is TCL_OK on a successful parse and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * The return value is TCL_OK on a successful parse and TCL_ERROR on + * failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParsePrimaryExpr(infoPtr) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; Tcl_Interp *interp = parsePtr->interp; Tcl_Token *tokenPtr, *exprTokenPtr; Tcl_Parse nested; @@ -1230,22 +1195,23 @@ exprTokenPtr->start = infoPtr->start; parsePtr->numTokens++; /* * Process the primary then finish setting the fields of the - * TCL_TOKEN_SUB_EXPR token. Note that we can't use the pointer now - * stored in "exprTokenPtr" in the code below since the token array - * might be reallocated. + * TCL_TOKEN_SUB_EXPR token. Note that we can't use the pointer now stored + * in "exprTokenPtr" in the code below since the token array might be + * reallocated. */ firstIndex = parsePtr->numTokens; switch (lexeme) { case LITERAL: /* * Int or double number. */ - + + tokenizeLiteral: if (parsePtr->numTokens == parsePtr->tokensAvailable) { TclExpandTokenArray(parsePtr); } tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; tokenPtr->type = TCL_TOKEN_TEXT; @@ -1261,33 +1227,33 @@ case DOLLAR: /* * $var variable reference. */ - + dollarPtr = (infoPtr->next - 1); code = Tcl_ParseVarName(interp, dollarPtr, - (infoPtr->lastChar - dollarPtr), parsePtr, 1); + (infoPtr->lastChar - dollarPtr), parsePtr, 1); if (code != TCL_OK) { return code; } infoPtr->next = dollarPtr + parsePtr->tokenPtr[firstIndex].size; exprTokenPtr = &parsePtr->tokenPtr[exprIndex]; exprTokenPtr->size = parsePtr->tokenPtr[firstIndex].size; exprTokenPtr->numComponents = - (parsePtr->tokenPtr[firstIndex].numComponents + 1); + (parsePtr->tokenPtr[firstIndex].numComponents + 1); break; - + case QUOTE: /* * '"' string '"' */ - + stringStart = infoPtr->next; code = Tcl_ParseQuotedString(interp, infoPtr->start, - (infoPtr->lastChar - stringStart), parsePtr, 1, &termPtr); + (infoPtr->lastChar - stringStart), parsePtr, 1, &termPtr); if (code != TCL_OK) { return code; } infoPtr->next = termPtr; @@ -1295,22 +1261,22 @@ exprTokenPtr->size = (termPtr - exprTokenPtr->start); exprTokenPtr->numComponents = parsePtr->numTokens - firstIndex; /* * If parsing the quoted string resulted in more than one token, - * insert a TCL_TOKEN_WORD token before them. This indicates that - * the quoted string represents a concatenation of multiple tokens. + * insert a TCL_TOKEN_WORD token before them. This indicates that the + * quoted string represents a concatenation of multiple tokens. */ if (exprTokenPtr->numComponents > 1) { if (parsePtr->numTokens >= parsePtr->tokensAvailable) { TclExpandTokenArray(parsePtr); } tokenPtr = &parsePtr->tokenPtr[firstIndex]; numToMove = (parsePtr->numTokens - firstIndex); memmove((VOID *) (tokenPtr + 1), (VOID *) tokenPtr, - (size_t) (numToMove * sizeof(Tcl_Token))); + (size_t) (numToMove * sizeof(Tcl_Token))); parsePtr->numTokens++; exprTokenPtr = &parsePtr->tokenPtr[exprIndex]; exprTokenPtr->numComponents++; @@ -1318,11 +1284,11 @@ tokenPtr->start = exprTokenPtr->start; tokenPtr->size = exprTokenPtr->size; tokenPtr->numComponents = (exprTokenPtr->numComponents - 1); } break; - + case OPEN_BRACKET: /* * '[' command {command} ']' */ @@ -1334,14 +1300,14 @@ tokenPtr->start = infoPtr->start; tokenPtr->numComponents = 0; parsePtr->numTokens++; /* - * Call Tcl_ParseCommand repeatedly to parse the nested command(s) - * to find their end, then throw away that parse information. + * Call Tcl_ParseCommand repeatedly to parse the nested command(s) to + * find their end, then throw away that parse information. */ - + src = infoPtr->next; while (1) { if (Tcl_ParseCommand(interp, src, (parsePtr->end - src), 1, &nested) != TCL_OK) { parsePtr->term = nested.term; @@ -1350,12 +1316,12 @@ return TCL_ERROR; } src = (nested.commandStart + nested.commandSize); /* - * This is equivalent to Tcl_FreeParse(&nested), but - * presumably inlined here for sake of runtime optimization + * This is equivalent to Tcl_FreeParse(&nested), but presumably + * inlined here for sake of runtime optimization */ if (nested.tokenPtr != nested.staticTokens) { ckfree((char *) nested.tokenPtr); } @@ -1363,11 +1329,11 @@ /* * Check for the closing ']' that ends the command substitution. * It must have been the last character of the parsed command. */ - if ((nested.term < parsePtr->end) && (*nested.term == ']') + if ((nested.term < parsePtr->end) && (*nested.term == ']') && !nested.incomplete) { break; } if (src == parsePtr->end) { if (parsePtr->interp != NULL) { @@ -1392,12 +1358,11 @@ /* * '{' string '}' */ code = Tcl_ParseBraces(interp, infoPtr->start, - (infoPtr->lastChar - infoPtr->start), parsePtr, 1, - &termPtr); + (infoPtr->lastChar - infoPtr->start), parsePtr, 1, &termPtr); if (code != TCL_OK) { return code; } infoPtr->next = termPtr; @@ -1405,103 +1370,110 @@ exprTokenPtr->size = (termPtr - infoPtr->start); exprTokenPtr->numComponents = parsePtr->numTokens - firstIndex; /* * If parsing the braced string resulted in more than one token, - * insert a TCL_TOKEN_WORD token before them. This indicates that - * the braced string represents a concatenation of multiple tokens. + * insert a TCL_TOKEN_WORD token before them. This indicates that the + * braced string represents a concatenation of multiple tokens. */ if (exprTokenPtr->numComponents > 1) { if (parsePtr->numTokens >= parsePtr->tokensAvailable) { TclExpandTokenArray(parsePtr); } tokenPtr = &parsePtr->tokenPtr[firstIndex]; numToMove = (parsePtr->numTokens - firstIndex); memmove((VOID *) (tokenPtr + 1), (VOID *) tokenPtr, - (size_t) (numToMove * sizeof(Tcl_Token))); + (size_t) (numToMove * sizeof(Tcl_Token))); parsePtr->numTokens++; exprTokenPtr = &parsePtr->tokenPtr[exprIndex]; exprTokenPtr->numComponents++; - + tokenPtr->type = TCL_TOKEN_WORD; tokenPtr->start = exprTokenPtr->start; tokenPtr->size = exprTokenPtr->size; tokenPtr->numComponents = exprTokenPtr->numComponents-1; } break; - - case FUNC_NAME: + + case STREQ: + case STRNEQ: + case IN_LIST: + case NOT_IN_LIST: + case FUNC_NAME: { /* * math_func '(' expr {',' expr} ')' */ - + + ParseInfo savedInfo = *infoPtr; + + code = GetLexeme(infoPtr); /* skip over function name */ + if (code != TCL_OK) { + return code; + } + if (infoPtr->lexeme != OPEN_PAREN) { + + int code; + Tcl_Obj *errMsg, *objPtr = + Tcl_NewStringObj(savedInfo.start, savedInfo.size); + + /* + * Check for boolean literals (true, false, yes, no, on, off). + */ + + Tcl_IncrRefCount(objPtr); + code = Tcl_ConvertToType(NULL, objPtr, &tclBooleanType); + Tcl_DecrRefCount(objPtr); + if (code == TCL_OK) { + *infoPtr = savedInfo; + goto tokenizeLiteral; + } + + /* + * Either there's a math function without a (, or a variable name + * without a '$'. + */ + + errMsg = Tcl_NewStringObj( "syntax error in expression \"", -1 ); + TclAppendLimitedToObj(errMsg, infoPtr->originalExpr, + (int) (infoPtr->lastChar - infoPtr->originalExpr), + 63, NULL); + Tcl_AppendToObj(errMsg, "\": the word \"", -1); + Tcl_AppendToObj(errMsg, savedInfo.start, savedInfo.size); + Tcl_AppendToObj(errMsg, + "\" requires a preceding $ if it's a variable ", -1); + Tcl_AppendToObj(errMsg, + "or function arguments if it's a function", -1); + Tcl_SetObjResult(infoPtr->parsePtr->interp, errMsg); + infoPtr->parsePtr->errorType = TCL_PARSE_SYNTAX; + infoPtr->parsePtr->term = infoPtr->start; + return TCL_ERROR; + + } + if (parsePtr->numTokens == parsePtr->tokensAvailable) { TclExpandTokenArray(parsePtr); } tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; tokenPtr->type = TCL_TOKEN_OPERATOR; - tokenPtr->start = infoPtr->start; - tokenPtr->size = infoPtr->size; + tokenPtr->start = savedInfo.start; + tokenPtr->size = savedInfo.size; tokenPtr->numComponents = 0; parsePtr->numTokens++; - - code = GetLexeme(infoPtr); /* skip over function name */ - if (code != TCL_OK) { - return code; - } - if (infoPtr->lexeme != OPEN_PAREN) { - /* - * Guess what kind of error we have by trying to tell - * whether we have a function or variable name here. - * Alas, this makes the parser more tightly bound with the - * rest of the interpreter, but that is the only way to - * give a sensible message here. Still, it is not too - * serious as this is only done when generating an error. - */ - Interp *iPtr = (Interp *) infoPtr->parsePtr->interp; - Tcl_DString functionName; - Tcl_HashEntry *hPtr; - - /* - * Look up the name as a function name. We need a writable - * copy (DString) so we can terminate it with a NULL for - * the benefit of Tcl_FindHashEntry which operates on - * NULL-terminated string keys. - */ - Tcl_DStringInit(&functionName); - hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, - Tcl_DStringAppend(&functionName, tokenPtr->start, - tokenPtr->size)); - Tcl_DStringFree(&functionName); - - /* - * Assume that we have an attempted variable reference - * unless we've got a function name, as the set of - * potential function names is typically much smaller. - */ - if (hPtr != NULL) { - LogSyntaxError(infoPtr, - "expected parenthesis enclosing function arguments"); - } else { - LogSyntaxError(infoPtr, - "variable references require preceding $"); - } - return TCL_ERROR; - } - code = GetLexeme(infoPtr); /* skip over '(' */ + + code = GetLexeme(infoPtr); /* skip over '(' */ if (code != TCL_OK) { return code; } while (infoPtr->lexeme != CLOSE_PAREN) { code = ParseCondExpr(infoPtr); if (code != TCL_OK) { return code; } - + if (infoPtr->lexeme == COMMA) { code = GetLexeme(infoPtr); /* skip over , */ if (code != TCL_OK) { return code; } @@ -1514,20 +1486,22 @@ exprTokenPtr = &parsePtr->tokenPtr[exprIndex]; exprTokenPtr->size = (infoPtr->next - exprTokenPtr->start); exprTokenPtr->numComponents = parsePtr->numTokens - firstIndex; break; + } case COMMA: LogSyntaxError(infoPtr, "commas can only separate function arguments"); return TCL_ERROR; case END: LogSyntaxError(infoPtr, "premature end of expression"); return TCL_ERROR; case UNKNOWN: - LogSyntaxError(infoPtr, "single equality character not legal in expressions"); + LogSyntaxError(infoPtr, + "single equality character not legal in expressions"); return TCL_ERROR; case UNKNOWN_CHAR: LogSyntaxError(infoPtr, "character not legal in expressions"); return TCL_ERROR; case QUESTY: @@ -1538,23 +1512,24 @@ return TCL_ERROR; case CLOSE_PAREN: LogSyntaxError(infoPtr, "unexpected close parenthesis"); return TCL_ERROR; - default: { - char buf[64]; + default: + { + char buf[64]; - sprintf(buf, "unexpected operator %s", lexemeStrings[lexeme]); - LogSyntaxError(infoPtr, buf); - return TCL_ERROR; + sprintf(buf, "unexpected operator %s", lexemeStrings[lexeme]); + LogSyntaxError(infoPtr, buf); + return TCL_ERROR; } } /* * Advance to the next lexeme before returning. */ - + code = GetLexeme(infoPtr); if (code != TCL_OK) { return code; } parsePtr->term = infoPtr->next; @@ -1564,29 +1539,28 @@ /* *---------------------------------------------------------------------- * * GetLexeme -- * - * Lexical scanner for Tcl expressions: scans a single operator or - * other syntactic element from an expression string. + * Lexical scanner for Tcl expressions: scans a single operator or other + * syntactic element from an expression string. * * Results: * TCL_OK is returned unless an error occurred. In that case a standard * Tcl error code is returned and, if infoPtr->parsePtr->interp is - * non-NULL, the interpreter's result is set to hold an error - * message. TCL_ERROR is returned if an integer overflow, or a - * floating-point overflow or underflow occurred while reading in a - * number. If the lexical analysis is successful, infoPtr->lexeme - * refers to the next symbol in the expression string, and - * infoPtr->next is advanced past the lexeme. Also, if the lexeme is a - * LITERAL or FUNC_NAME, then infoPtr->start is set to the first - * character of the lexeme; otherwise it is set NULL. + * non-NULL, the interpreter's result is set to hold an error message. + * TCL_ERROR is returned if an integer overflow, or a floating-point + * overflow or underflow occurred while reading in a number. If the + * lexical analysis is successful, infoPtr->lexeme refers to the next + * symbol in the expression string, and infoPtr->next is advanced past + * the lexeme. Also, if the lexeme is a LITERAL or FUNC_NAME, then + * infoPtr->start is set to the first character of the lexeme; otherwise + * it is set NULL. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the subexpression, then additional space is - * malloc-ed.. + * If there is insufficient space in parsePtr to hold all the information + * about the subexpression, then additional space is malloc-ed.. * *---------------------------------------------------------------------- */ static int @@ -1596,109 +1570,62 @@ { register CONST char *src; /* Points to current source char. */ char c; int offset, length, numBytes; Tcl_Parse *parsePtr = infoPtr->parsePtr; - Tcl_Interp *interp = parsePtr->interp; Tcl_UniChar ch; /* - * Record where the previous lexeme ended. Since we always read one - * lexeme ahead during parsing, this helps us know the source length of + * Record where the previous lexeme ended. Since we always read one lexeme + * ahead during parsing, this helps us know the source length of * subexpression tokens. */ infoPtr->prevEnd = infoPtr->next; /* - * Scan over leading white space at the start of a lexeme. + * Scan over leading white space at the start of a lexeme. */ src = infoPtr->next; numBytes = parsePtr->end - src; + do { char type; int scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type); - src += scanned; numBytes -= scanned; + + src += scanned; + numBytes -= scanned; } while (numBytes && (*src == '\n') && (src++,numBytes--)); + parsePtr->term = src; if (numBytes == 0) { infoPtr->lexeme = END; infoPtr->next = src; return TCL_OK; } /* - * Try to parse the lexeme first as an integer or floating-point - * number. Don't check for a number if the first character c is - * "+" or "-". If we did, we might treat a binary operator as unary - * by mistake, which would eventually cause a syntax error. + * Try to parse the lexeme first as an integer or floating-point number. + * Don't check for a number if the first character c is "+" or "-". If we + * did, we might treat a binary operator as unary by mistake, which would + * eventually cause a syntax error. */ 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, *termPtr; - double doubleValue; - Tcl_DString toParse; - - errno = 0; - Tcl_DStringInit(&toParse); - startPtr = Tcl_DStringAppend(&toParse, src, length); - doubleValue = strtod(startPtr, &termPtr); - Tcl_DStringFree(&toParse); - if (termPtr != startPtr) { - if (errno != 0) { - if (interp != NULL) { - TclExprFloatError(interp, doubleValue); - } - parsePtr->errorType = TCL_PARSE_BAD_NUMBER; - return TCL_ERROR; - } - - /* - * startPtr was the start of a valid double, copied - * from src. - */ - - infoPtr->lexeme = LITERAL; - infoPtr->start = src; - if ((termPtr - startPtr) > length) { - infoPtr->size = length; - } else { - infoPtr->size = (termPtr - startPtr); - } - infoPtr->next = src + infoPtr->size; + 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; + infoPtr->size = length; + infoPtr->next = (src + length); parsePtr->term = infoPtr->next; return TCL_OK; } } } @@ -1710,296 +1637,256 @@ infoPtr->start = src; infoPtr->size = 1; infoPtr->next = src+1; parsePtr->term = infoPtr->next; - - switch (*src) { - case '[': - infoPtr->lexeme = OPEN_BRACKET; - return TCL_OK; - - case '{': - infoPtr->lexeme = OPEN_BRACE; - return TCL_OK; - - case '(': - infoPtr->lexeme = OPEN_PAREN; - return TCL_OK; - - case ')': - infoPtr->lexeme = CLOSE_PAREN; - return TCL_OK; - - case '$': - infoPtr->lexeme = DOLLAR; - return TCL_OK; - - case '\"': - infoPtr->lexeme = QUOTE; - return TCL_OK; - - case ',': - infoPtr->lexeme = COMMA; - return TCL_OK; - - case '*': - infoPtr->lexeme = MULT; - if ((infoPtr->lastChar - src)>1 && src[1]=='*') { - infoPtr->lexeme = EXPON; - infoPtr->size = 2; - infoPtr->next = src+2; - parsePtr->term = infoPtr->next; - } - return TCL_OK; - - case '/': - infoPtr->lexeme = DIVIDE; - return TCL_OK; - - case '%': - infoPtr->lexeme = MOD; - return TCL_OK; - - case '+': - infoPtr->lexeme = PLUS; - return TCL_OK; - - case '-': - infoPtr->lexeme = MINUS; - return TCL_OK; - - case '?': - infoPtr->lexeme = QUESTY; - return TCL_OK; - - case ':': - infoPtr->lexeme = COLON; - return TCL_OK; - - case '<': - infoPtr->lexeme = LESS; - if ((infoPtr->lastChar - src) > 1) { - switch (src[1]) { - case '<': - infoPtr->lexeme = LEFT_SHIFT; - infoPtr->size = 2; - infoPtr->next = src+2; - break; - case '=': - infoPtr->lexeme = LEQ; - infoPtr->size = 2; - infoPtr->next = src+2; - break; - } - } - parsePtr->term = infoPtr->next; - return TCL_OK; - - case '>': - infoPtr->lexeme = GREATER; - if ((infoPtr->lastChar - src) > 1) { - switch (src[1]) { - case '>': - infoPtr->lexeme = RIGHT_SHIFT; - infoPtr->size = 2; - infoPtr->next = src+2; - break; - case '=': - infoPtr->lexeme = GEQ; - infoPtr->size = 2; - infoPtr->next = src+2; - break; - } - } - parsePtr->term = infoPtr->next; - return TCL_OK; - - case '=': - infoPtr->lexeme = UNKNOWN; - if ((src[1] == '=') && ((infoPtr->lastChar - src) > 1)) { - infoPtr->lexeme = EQUAL; - infoPtr->size = 2; - infoPtr->next = src+2; - } - parsePtr->term = infoPtr->next; - return TCL_OK; - - case '!': - infoPtr->lexeme = NOT; - if ((src[1] == '=') && ((infoPtr->lastChar - src) > 1)) { - infoPtr->lexeme = NEQ; - infoPtr->size = 2; - infoPtr->next = src+2; - } - parsePtr->term = infoPtr->next; - return TCL_OK; - - case '&': - infoPtr->lexeme = BIT_AND; - if ((src[1] == '&') && ((infoPtr->lastChar - src) > 1)) { - infoPtr->lexeme = AND; - infoPtr->size = 2; - infoPtr->next = src+2; - } - parsePtr->term = infoPtr->next; - return TCL_OK; - - case '^': - infoPtr->lexeme = BIT_XOR; - return TCL_OK; - - case '|': - infoPtr->lexeme = BIT_OR; - if ((src[1] == '|') && ((infoPtr->lastChar - src) > 1)) { - infoPtr->lexeme = OR; - infoPtr->size = 2; - infoPtr->next = src+2; - } - parsePtr->term = infoPtr->next; - return TCL_OK; - - case '~': - infoPtr->lexeme = BIT_NOT; - return TCL_OK; - - case 'e': - if ((src[1] == 'q') && ((infoPtr->lastChar - src) > 1) && - (infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) { - infoPtr->lexeme = STREQ; - infoPtr->size = 2; - infoPtr->next = src+2; - parsePtr->term = infoPtr->next; - return TCL_OK; - } else { - goto checkFuncName; - } - - case 'n': - if ((src[1] == 'e') && ((infoPtr->lastChar - src) > 1) && - (infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) { - infoPtr->lexeme = STRNEQ; - infoPtr->size = 2; - infoPtr->next = src+2; - parsePtr->term = infoPtr->next; - return TCL_OK; - } else if ((src[1] == 'i') && ((infoPtr->lastChar - src) > 1) && - (infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) { - infoPtr->lexeme = NOT_IN_LIST; - infoPtr->size = 2; - infoPtr->next = src+2; - parsePtr->term = infoPtr->next; - return TCL_OK; - } else { - goto checkFuncName; - } - - case 'i': - if ((src[1] == 'n') && ((infoPtr->lastChar - src) > 1) && - (infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) { - infoPtr->lexeme = IN_LIST; - infoPtr->size = 2; - infoPtr->next = src+2; - parsePtr->term = infoPtr->next; - return TCL_OK; - } else { - goto checkFuncName; - } - - default: - checkFuncName: - length = (infoPtr->lastChar - src); - if (Tcl_UtfCharComplete(src, length)) { - offset = Tcl_UtfToUniChar(src, &ch); - } else { - char utfBytes[TCL_UTF_MAX]; - memcpy(utfBytes, src, (size_t) length); - utfBytes[length] = '\0'; - offset = Tcl_UtfToUniChar(utfBytes, &ch); - } - c = UCHAR(ch); - if (isalpha(UCHAR(c))) { /* INTL: ISO only. */ - infoPtr->lexeme = FUNC_NAME; - while (isalnum(UCHAR(c)) || (c == '_')) { /* INTL: ISO only. */ - src += offset; length -= offset; - if (Tcl_UtfCharComplete(src, length)) { - offset = Tcl_UtfToUniChar(src, &ch); - } else { - char utfBytes[TCL_UTF_MAX]; - memcpy(utfBytes, src, (size_t) length); - utfBytes[length] = '\0'; - offset = Tcl_UtfToUniChar(utfBytes, &ch); - } - c = UCHAR(ch); - } - infoPtr->size = (src - infoPtr->start); - infoPtr->next = src; - parsePtr->term = infoPtr->next; - /* - * Check for boolean literals (true, false, yes, no, on, off) - */ - switch (infoPtr->start[0]) { - case 'f': - if (infoPtr->size == 5 && - strncmp("false", infoPtr->start, 5) == 0) { - infoPtr->lexeme = LITERAL; - return TCL_OK; - } - break; - case 'n': - if (infoPtr->size == 2 && - strncmp("no", infoPtr->start, 2) == 0) { - infoPtr->lexeme = LITERAL; - return TCL_OK; - } - break; - case 'o': - if (infoPtr->size == 3 && - strncmp("off", infoPtr->start, 3) == 0) { - infoPtr->lexeme = LITERAL; - return TCL_OK; - } else if (infoPtr->size == 2 && - strncmp("on", infoPtr->start, 2) == 0) { - infoPtr->lexeme = LITERAL; - return TCL_OK; - } - break; - case 't': - if (infoPtr->size == 4 && - strncmp("true", infoPtr->start, 4) == 0) { - infoPtr->lexeme = LITERAL; - return TCL_OK; - } - break; - case 'y': - if (infoPtr->size == 3 && - strncmp("yes", infoPtr->start, 3) == 0) { - infoPtr->lexeme = LITERAL; - return TCL_OK; - } - break; - } - return TCL_OK; - } - infoPtr->lexeme = UNKNOWN_CHAR; - return TCL_OK; - } -} - + + switch (*src) { + case '[': + infoPtr->lexeme = OPEN_BRACKET; + return TCL_OK; + + case '{': + infoPtr->lexeme = OPEN_BRACE; + return TCL_OK; + + case '(': + infoPtr->lexeme = OPEN_PAREN; + return TCL_OK; + + case ')': + infoPtr->lexeme = CLOSE_PAREN; + return TCL_OK; + + case '$': + infoPtr->lexeme = DOLLAR; + return TCL_OK; + + case '\"': + infoPtr->lexeme = QUOTE; + return TCL_OK; + + case ',': + infoPtr->lexeme = COMMA; + return TCL_OK; + + case '*': + infoPtr->lexeme = MULT; + if ((infoPtr->lastChar - src)>1 && src[1]=='*') { + infoPtr->lexeme = EXPON; + infoPtr->size = 2; + infoPtr->next = src+2; + parsePtr->term = infoPtr->next; + } + return TCL_OK; + + case '/': + infoPtr->lexeme = DIVIDE; + return TCL_OK; + + case '%': + infoPtr->lexeme = MOD; + return TCL_OK; + + case '+': + infoPtr->lexeme = PLUS; + return TCL_OK; + + case '-': + infoPtr->lexeme = MINUS; + return TCL_OK; + + case '?': + infoPtr->lexeme = QUESTY; + return TCL_OK; + + case ':': + infoPtr->lexeme = COLON; + return TCL_OK; + + case '<': + infoPtr->lexeme = LESS; + if ((infoPtr->lastChar - src) > 1) { + switch (src[1]) { + case '<': + infoPtr->lexeme = LEFT_SHIFT; + infoPtr->size = 2; + infoPtr->next = src+2; + break; + case '=': + infoPtr->lexeme = LEQ; + infoPtr->size = 2; + infoPtr->next = src+2; + break; + } + } + parsePtr->term = infoPtr->next; + return TCL_OK; + + case '>': + infoPtr->lexeme = GREATER; + if ((infoPtr->lastChar - src) > 1) { + switch (src[1]) { + case '>': + infoPtr->lexeme = RIGHT_SHIFT; + infoPtr->size = 2; + infoPtr->next = src+2; + break; + case '=': + infoPtr->lexeme = GEQ; + infoPtr->size = 2; + infoPtr->next = src+2; + break; + } + } + parsePtr->term = infoPtr->next; + return TCL_OK; + + case '=': + infoPtr->lexeme = UNKNOWN; + if ((src[1] == '=') && ((infoPtr->lastChar - src) > 1)) { + infoPtr->lexeme = EQUAL; + infoPtr->size = 2; + infoPtr->next = src+2; + } + parsePtr->term = infoPtr->next; + return TCL_OK; + + case '!': + infoPtr->lexeme = NOT; + if ((src[1] == '=') && ((infoPtr->lastChar - src) > 1)) { + infoPtr->lexeme = NEQ; + infoPtr->size = 2; + infoPtr->next = src+2; + } + parsePtr->term = infoPtr->next; + return TCL_OK; + + case '&': + infoPtr->lexeme = BIT_AND; + if ((src[1] == '&') && ((infoPtr->lastChar - src) > 1)) { + infoPtr->lexeme = AND; + infoPtr->size = 2; + infoPtr->next = src+2; + } + parsePtr->term = infoPtr->next; + return TCL_OK; + + case '^': + infoPtr->lexeme = BIT_XOR; + return TCL_OK; + + case '|': + infoPtr->lexeme = BIT_OR; + if ((src[1] == '|') && ((infoPtr->lastChar - src) > 1)) { + infoPtr->lexeme = OR; + infoPtr->size = 2; + infoPtr->next = src+2; + } + parsePtr->term = infoPtr->next; + return TCL_OK; + + case '~': + infoPtr->lexeme = BIT_NOT; + return TCL_OK; + + case 'e': + if ((src[1] == 'q') && ((infoPtr->lastChar - src) > 1) && + (infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) { + infoPtr->lexeme = STREQ; + infoPtr->size = 2; + infoPtr->next = src+2; + parsePtr->term = infoPtr->next; + return TCL_OK; + } else { + goto checkFuncName; + } + + case 'n': + if ((src[1] == 'e') && ((infoPtr->lastChar - src) > 1) && + (infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) { + infoPtr->lexeme = STRNEQ; + infoPtr->size = 2; + infoPtr->next = src+2; + parsePtr->term = infoPtr->next; + return TCL_OK; + } else if ((src[1] == 'i') && ((infoPtr->lastChar - src) > 1) && + (infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) { + infoPtr->lexeme = NOT_IN_LIST; + infoPtr->size = 2; + infoPtr->next = src+2; + parsePtr->term = infoPtr->next; + return TCL_OK; + } else { + goto checkFuncName; + } + + case 'i': + if ((src[1] == 'n') && ((infoPtr->lastChar - src) > 1) && + (infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) { + infoPtr->lexeme = IN_LIST; + infoPtr->size = 2; + infoPtr->next = src+2; + parsePtr->term = infoPtr->next; + return TCL_OK; + } else { + goto checkFuncName; + } + + default: + checkFuncName: + length = (infoPtr->lastChar - src); + if (Tcl_UtfCharComplete(src, length)) { + offset = Tcl_UtfToUniChar(src, &ch); + } else { + char utfBytes[TCL_UTF_MAX]; + + memcpy(utfBytes, src, (size_t) length); + utfBytes[length] = '\0'; + offset = Tcl_UtfToUniChar(utfBytes, &ch); + } + c = UCHAR(ch); + if (isalpha(UCHAR(c))) { /* INTL: ISO only. */ + infoPtr->lexeme = FUNC_NAME; + while (isalnum(UCHAR(c)) || (c == '_')) { /* INTL: ISO only. */ + src += offset; + length -= offset; + if (Tcl_UtfCharComplete(src, length)) { + offset = Tcl_UtfToUniChar(src, &ch); + } else { + char utfBytes[TCL_UTF_MAX]; + + memcpy(utfBytes, src, (size_t) length); + utfBytes[length] = '\0'; + offset = Tcl_UtfToUniChar(utfBytes, &ch); + } + c = UCHAR(ch); + } + infoPtr->size = (src - infoPtr->start); + infoPtr->next = src; + parsePtr->term = infoPtr->next; + return TCL_OK; + } + infoPtr->lexeme = UNKNOWN_CHAR; + return TCL_OK; + } +} + +#if 0 /* *---------------------------------------------------------------------- * * TclParseInteger -- * - * Scans up to numBytes bytes starting at src, and checks whether - * the leading bytes look like an integer's string representation. + * Scans up to numBytes bytes starting at src, 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. + * 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. * *---------------------------------------------------------------------- @@ -2010,92 +1897,50 @@ register CONST char *string;/* The string to examine. */ register int numBytes; /* Max number of bytes to scan. */ { register CONST char *p = string; - /* Take care of introductory "0x" */ + /* + * 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; + + p += 2; + numBytes -= 2; scanned = TclParseHex(p, numBytes, &ch); if (scanned) { - return scanned + 2; + return scanned+2; } - /* Recognize the 0 as valid integer, but x is left behind */ + /* + * Recognize the 0 as valid integer, but x is left behind. + */ + return 1; } - while (numBytes && isdigit(UCHAR(*p))) { /* INTL: digit */ + while (numBytes && isdigit(UCHAR(*p))) { /* INTL: digit */ numBytes--; p++; } if (numBytes == 0) { - return (p - string); + return (p - string); } if ((*p != '.') && (*p != 'e') && (*p != 'E')) { - return (p - string); + return (p - string); } 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, runing 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 '-': - p++; - break; - default: - goto done; - } - } - done: - return (p - string); -} +#endif /* *---------------------------------------------------------------------- * * PrependSubExprTokens -- * - * This procedure is called after the operands of an subexpression have + * This function is called after the operands of an subexpression have * been parsed. It generates two tokens: a TCL_TOKEN_SUB_EXPR token for * the subexpression, and a TCL_TOKEN_OPERATOR token for its operator. * These two tokens are inserted before the operand tokens. * * Results: @@ -2108,21 +1953,21 @@ *---------------------------------------------------------------------- */ static void PrependSubExprTokens(op, opBytes, src, srcBytes, firstIndex, infoPtr) - CONST char *op; /* Points to first byte of the operator - * in the source script. */ + CONST char *op; /* Points to first byte of the operator in the + * source script. */ int opBytes; /* Number of bytes in the operator. */ CONST char *src; /* Points to first byte of the subexpression * in the source script. */ int srcBytes; /* Number of bytes in subexpression's * source. */ int firstIndex; /* Index of first token already emitted for * operator's first (or only) operand. */ - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; Tcl_Token *tokenPtr, *firstTokenPtr; int numToMove; @@ -2131,19 +1976,19 @@ } firstTokenPtr = &parsePtr->tokenPtr[firstIndex]; tokenPtr = (firstTokenPtr + 2); numToMove = (parsePtr->numTokens - firstIndex); memmove((VOID *) tokenPtr, (VOID *) firstTokenPtr, - (size_t) (numToMove * sizeof(Tcl_Token))); + (size_t) (numToMove * sizeof(Tcl_Token))); parsePtr->numTokens += 2; - + tokenPtr = firstTokenPtr; tokenPtr->type = TCL_TOKEN_SUB_EXPR; tokenPtr->start = src; tokenPtr->size = srcBytes; tokenPtr->numComponents = parsePtr->numTokens - (firstIndex + 1); - + tokenPtr++; tokenPtr->type = TCL_TOKEN_OPERATOR; tokenPtr->start = op; tokenPtr->size = opBytes; tokenPtr->numComponents = 0; @@ -2152,36 +1997,44 @@ /* *---------------------------------------------------------------------- * * LogSyntaxError -- * - * This procedure is invoked after an error occurs when parsing an + * This function is invoked after an error occurs when parsing an * expression. It sets the interpreter result to an error message * describing the error. * * Results: * None. * * Side effects: * Sets the interpreter result to an error message describing the - * expression that was being parsed when the error occurred, and why - * the parser considers that to be a syntax error at all. + * expression that was being parsed when the error occurred, and why the + * parser considers that to be a syntax error at all. * *---------------------------------------------------------------------- */ static void LogSyntaxError(infoPtr, extraInfo) - ParseInfo *infoPtr; /* Holds the parse state for the - * expression being parsed. */ - CONST char *extraInfo; /* String to provide extra information - * about the syntax error. */ + ParseInfo *infoPtr; /* Holds the parse state for the expression + * being parsed. */ + CONST char *extraInfo; /* String to provide extra information about + * the syntax error. */ { Tcl_Obj *result = Tcl_NewStringObj("syntax error in expression \"", -1); - TclAppendLimitedToObj(result, infoPtr->originalExpr, + TclAppendLimitedToObj(result, infoPtr->originalExpr, (int)(infoPtr->lastChar - infoPtr->originalExpr), 63, NULL); Tcl_AppendStringsToObj(result, "\": ", extraInfo, (char *) NULL); Tcl_SetObjResult(infoPtr->parsePtr->interp, result); infoPtr->parsePtr->errorType = TCL_PARSE_SYNTAX; infoPtr->parsePtr->term = infoPtr->start; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclPathObj.c ================================================================== --- generic/tclPathObj.c +++ generic/tclPathObj.c @@ -1,119 +1,115 @@ -/* +/* * tclPathObj.c -- * - * This file contains the implementation of Tcl's "path" object - * type used to represent and manipulate a general (virtual) - * filesystem entity in an efficient manner. + * This file contains the implementation of Tcl's "path" object type used + * to represent and manipulate a general (virtual) filesystem entity in + * an efficient manner. * * Copyright (c) 2003 Vince Darley. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPathObj.c,v 1.38 2004/11/22 12:53:06 vincentdarley Exp $ + * RCS: @(#) $Id: tclPathObj.c,v 1.38.2.5 2005/08/15 18:13:59 dgp Exp $ */ #include "tclInt.h" #include "tclFileSystem.h" /* - * Prototypes for procedures defined later in this file. + * Prototypes for functions defined later in this file. */ static void DupFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *copyPtr)); static void FreeFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *pathPtr)); static void UpdateStringOfFsPath _ANSI_ARGS_((Tcl_Obj *pathPtr)); static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr)); static int FindSplitPos _ANSI_ARGS_((CONST char *path, int separator)); -static int IsSeparatorOrNull _ANSI_ARGS_((int ch)); +static int IsSeparatorOrNull _ANSI_ARGS_((int ch)); static Tcl_Obj* GetExtension _ANSI_ARGS_((Tcl_Obj *pathPtr)); /* - * Define the 'path' object type, which Tcl uses to represent - * file paths internally. + * Define the 'path' object type, which Tcl uses to represent file paths + * internally. */ Tcl_ObjType tclFsPathType = { "path", /* name */ FreeFsPathInternalRep, /* freeIntRepProc */ - DupFsPathInternalRep, /* dupIntRepProc */ + DupFsPathInternalRep, /* dupIntRepProc */ UpdateStringOfFsPath, /* updateStringProc */ SetFsPathFromAny /* setFromAnyProc */ }; -/* +/* * struct FsPath -- - * - * Internal representation of a Tcl_Obj of "path" type. This - * can be used to represent relative or absolute paths, and has - * certain optimisations when used to represent paths which are - * already normalized and absolute. - * - * Note that both 'translatedPathPtr' and 'normPathPtr' can be a - * circular reference to the container Tcl_Obj of this FsPath. - * + * + * Internal representation of a Tcl_Obj of "path" type. This can be used to + * represent relative or absolute paths, and has certain optimisations when + * used to represent paths which are already normalized and absolute. + * + * Note that both 'translatedPathPtr' and 'normPathPtr' can be a circular + * reference to the container Tcl_Obj of this FsPath. + * * There are two cases, with the first being the most common: - * - * (i) flags == 0, => Ordinary path. - * - * translatedPathPtr contains the translated path (which may be - * a circular reference to the object itself). If it is NULL - * then the path is pure normalized (and the normPathPtr will be - * a circular reference). cwdPtr is null for an absolute path, - * and non-null for a relative path (unless the cwd has never been - * set, in which case the cwdPtr may also be null for a relative path). - * + * + * (i) flags == 0, => Ordinary path. + * + * translatedPathPtr contains the translated path (which may be a circular + * reference to the object itself). If it is NULL then the path is pure + * normalized (and the normPathPtr will be a circular reference). cwdPtr is + * null for an absolute path, and non-null for a relative path (unless the cwd + * has never been set, in which case the cwdPtr may also be null for a + * relative path). + * * (ii) flags != 0, => Special path, see TclNewFSPathObj - * - * Now, this is a path like 'file join $dir $tail' where, cwdPtr is - * the $dir and normPathPtr is the $tail. - * + * + * Now, this is a path like 'file join $dir $tail' where, cwdPtr is the $dir + * and normPathPtr is the $tail. + * */ typedef struct FsPath { - Tcl_Obj *translatedPathPtr; /* Name without any ~user sequences. - * If this is NULL, then this is a - * pure normalized, absolute path - * object, in which the parent Tcl_Obj's - * string rep is already both translated - * and normalized. */ - Tcl_Obj *normPathPtr; /* Normalized absolute path, without - * ., .. or ~user sequences. If the - * Tcl_Obj containing - * this FsPath is already normalized, - * this may be a circular reference back - * to the container. If that is NOT the - * case, we have a refCount on the object. */ - Tcl_Obj *cwdPtr; /* If null, path is absolute, else - * this points to the cwd object used - * for this path. We have a refCount - * on the object. */ - int flags; /* Flags to describe interpretation - - * see below. */ - ClientData nativePathPtr; /* Native representation of this path, - * which is filesystem dependent. */ - int filesystemEpoch; /* Used to ensure the path representation - * was generated during the correct - * filesystem epoch. The epoch changes - * when filesystem-mounts are changed. */ + Tcl_Obj *translatedPathPtr; /* Name without any ~user sequences. If this + * is NULL, then this is a pure normalized, + * absolute path object, in which the parent + * Tcl_Obj's string rep is already both + * translated and normalized. */ + Tcl_Obj *normPathPtr; /* Normalized absolute path, without ., .. or + * ~user sequences. If the Tcl_Obj containing + * this FsPath is already normalized, this may + * be a circular reference back to the + * container. If that is NOT the case, we have + * a refCount on the object. */ + Tcl_Obj *cwdPtr; /* If null, path is absolute, else this points + * to the cwd object used for this path. We + * have a refCount on the object. */ + int flags; /* Flags to describe interpretation - see + * below. */ + ClientData nativePathPtr; /* Native representation of this path, which + * is filesystem dependent. */ + int filesystemEpoch; /* Used to ensure the path representation was + * generated during the correct filesystem + * epoch. The epoch changes when + * filesystem-mounts are changed. */ struct FilesystemRecord *fsRecPtr; - /* Pointer to the filesystem record - * entry to use for this path. */ + /* Pointer to the filesystem record entry to + * use for this path. */ } FsPath; /* * Flag values for FsPath->flags. */ #define TCLPATH_APPENDED 1 -/* - * Define some macros to give us convenient access to path-object - * specific fields. +/* + * Define some macros to give us convenient access to path-object specific + * fields. */ #define PATHOBJ(pathPtr) (pathPtr->internalRep.otherValuePtr) #define PATHFLAGS(pathPtr) \ (((FsPath*)(pathPtr->internalRep.otherValuePtr))->flags) @@ -122,94 +118,90 @@ /* *--------------------------------------------------------------------------- * * TclFSNormalizeAbsolutePath -- * - * Description: - * Takes an absolute path specification and computes a 'normalized' - * path from it. - * - * A normalized path is one which has all '../', './' removed. - * Also it is one which is in the 'standard' format for the native - * platform. On Unix, this means the path must be free of - * symbolic links/aliases, and on Windows it means we want the - * long form, with that long form's case-dependence (which gives - * us a unique, case-dependent path). - * - * The behaviour of this function if passed a non-absolute path - * is NOT defined. - * - * pathPtr may have a refCount of zero, or may be a shared - * object. + * Takes an absolute path specification and computes a 'normalized' path + * from it. + * + * A normalized path is one which has all '../', './' removed. Also it + * is one which is in the 'standard' format for the native platform. On + * Unix, this means the path must be free of symbolic links/aliases, and + * on Windows it means we want the long form, with that long form's + * case-dependence (which gives us a unique, case-dependent path). + * + * The behaviour of this function if passed a non-absolute path is NOT + * defined. + * + * pathPtr may have a refCount of zero, or may be a shared object. * * Results: - * The result is returned in a Tcl_Obj with a refCount of 1, - * which is therefore owned by the caller. It must be - * freed (with Tcl_DecrRefCount) by the caller when no longer needed. + * The result is returned in a Tcl_Obj with a refCount of 1, which is + * therefore owned by the caller. It must be freed (with + * Tcl_DecrRefCount) by the caller when no longer needed. * * Side effects: * None (beyond the memory allocation for the result). * * Special note: * This code was originally based on code from Matt Newman and - * Jean-Claude Wippler, but has since been totally rewritten by - * Vince Darley to deal with symbolic links. + * Jean-Claude Wippler, but has since been totally rewritten by Vince + * Darley to deal with symbolic links. * *--------------------------------------------------------------------------- */ Tcl_Obj* TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr) - Tcl_Interp* interp; /* Interpreter to use */ - Tcl_Obj *pathPtr; /* Absolute path to normalize */ - ClientData *clientDataPtr; /* If non-NULL, then may be set to the - * fs-specific clientData for this path. - * This will happen when that extra - * information can be calculated efficiently - * as a side-effect of normalization. */ + Tcl_Interp* interp; /* Interpreter to use */ + Tcl_Obj *pathPtr; /* Absolute path to normalize */ + ClientData *clientDataPtr; /* If non-NULL, then may be set to the + * fs-specific clientData for this path. This + * will happen when that extra information can + * be calculated efficiently as a side-effect + * of normalization. */ { ClientData clientData = NULL; CONST char *dirSep, *oldDirSep; - int first = 1; /* Set to zero once we've passed the first - * directory separator - we can't use '..' to - * remove the volume in a path. */ + int first = 1; /* Set to zero once we've passed the first + * directory separator - we can't use '..' to + * remove the volume in a path. */ Tcl_Obj *retVal = NULL; dirSep = TclGetString(pathPtr); - + if (tclPlatform == TCL_PLATFORM_WINDOWS) { - if (dirSep[0] != 0 && dirSep[1] == ':' && - (dirSep[2] == '/' || dirSep[2] == '\\')) { + if (dirSep[0] != 0 && dirSep[1] == ':' && + (dirSep[2] == '/' || dirSep[2] == '\\')) { /* Do nothing */ - } else if ((dirSep[0] == '/' || dirSep[0] == '\\') - && (dirSep[1] == '/' || dirSep[1] == '\\')) { - /* - * UNC style path, where we must skip over the - * first separator, since the first two segments - * are actually inseparable. + } else if ((dirSep[0] == '/' || dirSep[0] == '\\') + && (dirSep[1] == '/' || dirSep[1] == '\\')) { + /* + * UNC style path, where we must skip over the first separator, + * since the first two segments are actually inseparable. */ + dirSep += 2; dirSep += FindSplitPos(dirSep, '/'); if (*dirSep != 0) { - dirSep++; + dirSep++; } } } - - /* - * Scan forward from one directory separator to the next, - * checking for '..' and '.' sequences which must be handled - * specially. In particular handling of '..' can be complicated - * if the directory before is a link, since we will have to - * expand the link to be able to back up one level. + + /* + * Scan forward from one directory separator to the next, checking for + * '..' and '.' sequences which must be handled specially. In particular + * handling of '..' can be complicated if the directory before is a link, + * since we will have to expand the link to be able to back up one level. */ while (*dirSep != 0) { oldDirSep = dirSep; if (!first) { dirSep++; } - dirSep += FindSplitPos(dirSep, '/'); + dirSep += FindSplitPos(dirSep, '/'); if (dirSep[0] == 0 || dirSep[1] == 0) { if (retVal != NULL) { Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep); } break; @@ -217,13 +209,16 @@ if (dirSep[1] == '.') { if (retVal != NULL) { Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep); oldDirSep = dirSep; } - again: + again: if (IsSeparatorOrNull(dirSep[2])) { - /* Need to skip '.' in the path */ + /* + * Need to skip '.' in the path. + */ + if (retVal == NULL) { CONST char *path = TclGetString(pathPtr); retVal = Tcl_NewStringObj(path, dirSep - path); Tcl_IncrRefCount(retVal); } @@ -236,48 +231,55 @@ } if (dirSep[2] == '.' && IsSeparatorOrNull(dirSep[3])) { Tcl_Obj *link; int curLen; char *linkStr; - /* Have '..' so need to skip previous directory */ + + /* + * Have '..' so need to skip previous directory. + */ + if (retVal == NULL) { CONST char *path = TclGetString(pathPtr); retVal = Tcl_NewStringObj(path, dirSep - path); Tcl_IncrRefCount(retVal); } if (!first || (tclPlatform == TCL_PLATFORM_UNIX)) { link = Tcl_FSLink(retVal, NULL, 0); if (link != NULL) { - /* - * Got a link. Need to check if the link - * is relative or absolute, for those platforms - * where relative links exist. + /* + * Got a link. Need to check if the link is relative + * or absolute, for those platforms where relative + * links exist. */ if (tclPlatform != TCL_PLATFORM_WINDOWS && Tcl_FSGetPathType(link) == TCL_PATH_RELATIVE) { - - /* - * We need to follow this link which is - * relative to retVal's directory. This - * means concatenating the link onto - * the directory of the path so far. + /* + * We need to follow this link which is relative + * to retVal's directory. This means concatenating + * the link onto the directory of the path so far. */ CONST char *path = Tcl_GetStringFromObj(retVal, &curLen); + while (--curLen >= 0) { - if (IsSeparatorOrNull(path[curLen])) { - break; - } + if (IsSeparatorOrNull(path[curLen])) { + break; + } } if (Tcl_IsShared(retVal)) { TclDecrRefCount(retVal); retVal = Tcl_DuplicateObj(retVal); Tcl_IncrRefCount(retVal); } - /* We want the trailing slash */ + + /* + * We want the trailing slash. + */ + Tcl_SetObjLength(retVal, curLen+1); Tcl_AppendObjToObj(retVal, link); TclDecrRefCount(link); linkStr = Tcl_GetStringFromObj(retVal, &curLen); } else { @@ -286,11 +288,15 @@ */ TclDecrRefCount(retVal); retVal = link; linkStr = Tcl_GetStringFromObj(retVal, &curLen); - /* Convert to forward-slashes on windows */ + + /* + * Convert to forward-slashes on windows. + */ + if (tclPlatform == TCL_PLATFORM_WINDOWS) { int i; for (i = 0; i < curLen; i++) { if (linkStr[i] == '\\') { linkStr[i] = '/'; @@ -301,11 +307,11 @@ } else { linkStr = Tcl_GetStringFromObj(retVal, &curLen); } /* - * Either way, we now remove the last path element + * Either way, we now remove the last path element. */ while (--curLen >= 0) { if (IsSeparatorOrNull(linkStr[curLen])) { Tcl_SetObjLength(retVal, curLen); @@ -324,44 +330,46 @@ first = 0; if (retVal != NULL) { Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep); } } - - /* - * If we didn't make any changes, just use the input path + + /* + * If we didn't make any changes, just use the input path. */ if (retVal == NULL) { retVal = pathPtr; Tcl_IncrRefCount(retVal); - + if (Tcl_IsShared(retVal)) { - /* - * Unfortunately, the platform-specific normalization code - * which will be called below has no way of dealing with the - * case where an object is shared. It is expecting to - * modify an object in place. So, we must duplicate this - * here to ensure an object with a single ref-count. - * - * If that changes in the future (e.g. the normalize proc is - * given one object and is able to return a different one), - * then we could remove this code. + /* + * Unfortunately, the platform-specific normalization code which + * will be called below has no way of dealing with the case where + * an object is shared. It is expecting to modify an object in + * place. So, we must duplicate this here to ensure an object + * with a single ref-count. + * + * If that changes in the future (e.g. the normalize proc is given + * one object and is able to return a different one), then we + * could remove this code. */ + TclDecrRefCount(retVal); retVal = Tcl_DuplicateObj(pathPtr); Tcl_IncrRefCount(retVal); } } - /* - * Ensure a windows drive like C:/ has a trailing separator + /* + * Ensure a windows drive like C:/ has a trailing separator */ if (tclPlatform == TCL_PLATFORM_WINDOWS) { int len; CONST char *path = Tcl_GetStringFromObj(retVal, &len); + if (len == 2 && path[0] != 0 && path[1] == ':') { if (Tcl_IsShared(retVal)) { TclDecrRefCount(retVal); retVal = Tcl_DuplicateObj(retVal); Tcl_IncrRefCount(retVal); @@ -368,45 +376,47 @@ } Tcl_AppendToObj(retVal, "/", 1); } } - /* - * Now we have an absolute path, with no '..', '.' sequences, - * but it still may not be in 'unique' form, depending on the - * platform. For instance, Unix is case-sensitive, so the - * path is ok. Windows is case-insensitive, and also has the - * weird 'longname/shortname' thing (e.g. C:/Program Files/ and - * C:/Progra~1/ are equivalent). - * - * Virtual file systems which may be registered may have - * other criteria for normalizing a path. + /* + * Now we have an absolute path, with no '..', '.' sequences, but it still + * may not be in 'unique' form, depending on the platform. For instance, + * Unix is case-sensitive, so the path is ok. Windows is case-insensitive, + * and also has the weird 'longname/shortname' thing (e.g. C:/Program + * Files/ and C:/Progra~1/ are equivalent). + * + * Virtual file systems which may be registered may have other criteria + * for normalizing a path. */ TclFSNormalizeToUniquePath(interp, retVal, 0, &clientData); - /* - * Since we know it is a normalized path, we can - * actually convert this object into an FsPath for - * greater efficiency + /* + * Since we know it is a normalized path, we can actually convert this + * object into an FsPath for greater efficiency */ TclFSMakePathFromNormalized(interp, retVal, clientData); if (clientDataPtr != NULL) { *clientDataPtr = clientData; } - /* This has a refCount of 1 for the caller */ + + /* + * This has a refCount of 1 for the caller, unlike many Tcl_Obj APIs. + */ + return retVal; } /* *---------------------------------------------------------------------- * * Tcl_FSGetPathType -- * - * Determines whether a given path is relative to the current - * directory, relative to the current volume, or absolute. + * Determines whether a given path is relative to the current directory, + * relative to the current volume, or absolute. * * Results: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or * TCL_PATH_VOLUME_RELATIVE. * @@ -426,22 +436,21 @@ /* *---------------------------------------------------------------------- * * TclFSGetPathType -- * - * Determines whether a given path is relative to the current - * directory, relative to the current volume, or absolute. If the - * caller wishes to know which filesystem claimed the path (in the - * case for which the path is absolute), then a reference to a - * filesystem pointer can be passed in (but passing NULL is - * acceptable). + * Determines whether a given path is relative to the current directory, + * relative to the current volume, or absolute. If the caller wishes to + * know which filesystem claimed the path (in the case for which the path + * is absolute), then a reference to a filesystem pointer can be passed + * in (but passing NULL is acceptable). * * Results: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or - * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will - * be set if and only if it is non-NULL and the function's - * return value is TCL_PATH_ABSOLUTE. + * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will be set if and + * only if it is non-NULL and the function's return value is + * TCL_PATH_ABSOLUTE. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -452,22 +461,23 @@ Tcl_Obj *pathPtr; Tcl_Filesystem **filesystemPtrPtr; int *driveNameLengthPtr; { if (Tcl_FSConvertToPathType(NULL, pathPtr) != TCL_OK) { - return TclGetPathType(pathPtr, filesystemPtrPtr, + return TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, NULL); } else { FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathPtr); + if (fsPathPtr->cwdPtr != NULL) { if (PATHFLAGS(pathPtr) == 0) { return TCL_PATH_RELATIVE; } - return TclFSGetPathType(fsPathPtr->cwdPtr, filesystemPtrPtr, + return TclFSGetPathType(fsPathPtr->cwdPtr, filesystemPtrPtr, driveNameLengthPtr); } else { - return TclGetPathType(pathPtr, filesystemPtrPtr, + return TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, NULL); } } } @@ -474,143 +484,147 @@ /* *--------------------------------------------------------------------------- * * TclPathPart * - * This procedure calculates the requested part of the given - * path, which can be: - * + * This function calculates the requested part of the given path, which + * can be: + * * - the directory above ('file dirname') * - the tail ('file tail') * - the extension ('file extension') * - the root ('file root') - * - * The 'portion' parameter dictates which of these to calculate. - * There are a number of special cases both to be more efficient, - * and because the behaviour when given a path with only a single - * element is defined to require the expansion of that single - * element, where possible. - * - * Should look into integrating 'FileBasename' in tclFCmd.c into - * this function. - * + * + * The 'portion' parameter dictates which of these to calculate. There + * are a number of special cases both to be more efficient, and because + * the behaviour when given a path with only a single element is defined + * to require the expansion of that single element, where possible. + * + * Should look into integrating 'FileBasename' in tclFCmd.c into this + * function. + * * Results: - * NULL if an error occurred, otherwise a Tcl_Obj owned by - * the caller (i.e. most likely with refCount 1). + * NULL if an error occurred, otherwise a Tcl_Obj owned by the caller + * (i.e. most likely with refCount 1). * * Side effects: - * None. + * None. * *--------------------------------------------------------------------------- */ Tcl_Obj* TclPathPart(interp, pathPtr, portion) Tcl_Interp *interp; /* Used for error reporting */ - Tcl_Obj *pathPtr; /* Path to take dirname of */ - Tcl_PathPart portion; /* Requested portion of name */ + Tcl_Obj *pathPtr; /* Path to take dirname of */ + Tcl_PathPart portion; /* Requested portion of name */ { if (pathPtr->typePtr == &tclFsPathType) { FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathPtr); - if (TclFSEpochOk(fsPathPtr->filesystemEpoch) + if (TclFSEpochOk(fsPathPtr->filesystemEpoch) && (PATHFLAGS(pathPtr) != 0)) { switch (portion) { - case TCL_PATH_DIRNAME: { - /* - * Check if the joined-on bit has any directory - * delimiters in it. If so, the 'dirname' would - * be a joining of the main part with the dirname - * of the joined-on bit. We could handle that - * special case here, but we don't, and instead - * just use the standardPath code. - */ - - CONST char *rest = TclGetString(fsPathPtr->normPathPtr); - if (strchr(rest, '/') != NULL) { - goto standardPath; - } - if (tclPlatform == TCL_PLATFORM_WINDOWS - && strchr(rest, '\\') != NULL) { - goto standardPath; - } - - /* - * The joined-on path is simple, so we can just - * return here. - */ - - Tcl_IncrRefCount(fsPathPtr->cwdPtr); - return fsPathPtr->cwdPtr; - } - case TCL_PATH_TAIL: { - /* - * Check if the joined-on bit has any directory - * delimiters in it. If so, the 'tail' would - * be only the part following the last delimiter. - * We could handle that special case here, but we - * don't, and instead just use the standardPath code. - */ - - CONST char *rest = TclGetString(fsPathPtr->normPathPtr); - if (strchr(rest, '/') != NULL) { - goto standardPath; - } - if (tclPlatform == TCL_PLATFORM_WINDOWS - && strchr(rest, '\\') != NULL) { - goto standardPath; - } - Tcl_IncrRefCount(fsPathPtr->normPathPtr); - return fsPathPtr->normPathPtr; - } - case TCL_PATH_EXTENSION: { - return GetExtension(fsPathPtr->normPathPtr); - } - case TCL_PATH_ROOT: { - /* Unimplemented */ - CONST char *fileName, *extension; - int length; - fileName = Tcl_GetStringFromObj(fsPathPtr->normPathPtr, - &length); - extension = TclGetExtension(fileName); - if (extension == NULL) { - /* - * There is no extension so the root is the - * same as the path we were given. - */ - Tcl_IncrRefCount(pathPtr); - return pathPtr; - } else { - /* - * Duplicate the object we were given and - * then trim off the extension of the - * tail component of the path. - */ - - FsPath *fsDupPtr; - Tcl_Obj *root = Tcl_DuplicateObj(pathPtr); - - Tcl_IncrRefCount(root); - fsDupPtr = (FsPath*) PATHOBJ(root); - if (Tcl_IsShared(fsDupPtr->normPathPtr)) { - TclDecrRefCount(fsDupPtr->normPathPtr); - fsDupPtr->normPathPtr = - Tcl_NewStringObj(fileName, - (int)(length - strlen(extension))); - Tcl_IncrRefCount(fsDupPtr->normPathPtr); - } else { - Tcl_SetObjLength(fsDupPtr->normPathPtr, - (int)(length - strlen(extension))); - } - return root; - } - } - default: { - /* We should never get here */ - Tcl_Panic("Bad portion to TclPathPart"); - /* For less clever compilers */ - return NULL; - } + case TCL_PATH_DIRNAME: { + /* + * Check if the joined-on bit has any directory delimiters in + * it. If so, the 'dirname' would be a joining of the main + * part with the dirname of the joined-on bit. We could handle + * that special case here, but we don't, and instead just use + * the standardPath code. + */ + + CONST char *rest = TclGetString(fsPathPtr->normPathPtr); + + if (strchr(rest, '/') != NULL) { + goto standardPath; + } + if (tclPlatform == TCL_PLATFORM_WINDOWS + && strchr(rest, '\\') != NULL) { + goto standardPath; + } + + /* + * The joined-on path is simple, so we can just return here. + */ + + Tcl_IncrRefCount(fsPathPtr->cwdPtr); + return fsPathPtr->cwdPtr; + } + case TCL_PATH_TAIL: { + /* + * Check if the joined-on bit has any directory delimiters in + * it. If so, the 'tail' would be only the part following the + * last delimiter. We could handle that special case here, but + * we don't, and instead just use the standardPath code. + */ + + CONST char *rest = TclGetString(fsPathPtr->normPathPtr); + + if (strchr(rest, '/') != NULL) { + goto standardPath; + } + if (tclPlatform == TCL_PLATFORM_WINDOWS + && strchr(rest, '\\') != NULL) { + goto standardPath; + } + Tcl_IncrRefCount(fsPathPtr->normPathPtr); + return fsPathPtr->normPathPtr; + } + case TCL_PATH_EXTENSION: + return GetExtension(fsPathPtr->normPathPtr); + case TCL_PATH_ROOT: { + CONST char *fileName, *extension; + int length; + + fileName = Tcl_GetStringFromObj(fsPathPtr->normPathPtr, + &length); + extension = TclGetExtension(fileName); + if (extension == NULL) { + /* + * There is no extension so the root is the same as the + * path we were given. + */ + + Tcl_IncrRefCount(pathPtr); + return pathPtr; + } else { + /* + * Duplicate the object we were given and then trim off + * the extension of the tail component of the path. + */ + + FsPath *fsDupPtr; + Tcl_Obj *root = Tcl_DuplicateObj(pathPtr); + + Tcl_IncrRefCount(root); + fsDupPtr = (FsPath*) PATHOBJ(root); + if (Tcl_IsShared(fsDupPtr->normPathPtr)) { + TclDecrRefCount(fsDupPtr->normPathPtr); + fsDupPtr->normPathPtr = Tcl_NewStringObj(fileName, + (int)(length - strlen(extension))); + Tcl_IncrRefCount(fsDupPtr->normPathPtr); + } else { + Tcl_SetObjLength(fsDupPtr->normPathPtr, + (int)(length - strlen(extension))); + } + + /* + * Must also trim the string representation if we have it. + */ + + if (root->bytes != NULL && root->length > 0) { + root->length -= strlen(extension); + root->bytes[root->length] = 0; + } + return root; + } + } + default: + /* We should never get here */ + Tcl_Panic("Bad portion to TclPathPart"); + /* For less clever compilers */ + return NULL; } } else if (fsPathPtr->cwdPtr != NULL) { /* Relative path */ goto standardPath; } else { @@ -619,39 +633,38 @@ } } else { int splitElements; Tcl_Obj *splitPtr; Tcl_Obj *resultPtr; - standardPath: - resultPtr = NULL; - if (portion == TCL_PATH_EXTENSION) { + standardPath: + resultPtr = NULL; + if (portion == TCL_PATH_EXTENSION) { return GetExtension(pathPtr); - } else if (portion == TCL_PATH_ROOT) { + } else if (portion == TCL_PATH_ROOT) { int length; CONST char *fileName, *extension; - + fileName = Tcl_GetStringFromObj(pathPtr, &length); extension = TclGetExtension(fileName); if (extension == NULL) { Tcl_IncrRefCount(pathPtr); return pathPtr; } else { - Tcl_Obj *root = Tcl_NewStringObj(fileName, + Tcl_Obj *root = Tcl_NewStringObj(fileName, (int) (length - strlen(extension))); Tcl_IncrRefCount(root); return root; } - } - - /* - * The behaviour we want here is slightly different to - * the standard Tcl_FSSplitPath in the handling of home - * directories; Tcl_FSSplitPath preserves the "~" while - * this code computes the actual full path name, if we - * had just a single component. - */ + } + + /* + * The behaviour we want here is slightly different to the standard + * Tcl_FSSplitPath in the handling of home directories; + * Tcl_FSSplitPath preserves the "~" while this code computes the + * actual full path name, if we had just a single component. + */ splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements); Tcl_IncrRefCount(splitPtr); if (splitElements == 1 && TclGetString(pathPtr)[0] == '~') { Tcl_Obj *norm; @@ -664,12 +677,12 @@ splitPtr = Tcl_FSSplitPath(norm, &splitElements); Tcl_IncrRefCount(splitPtr); } if (portion == TCL_PATH_TAIL) { /* - * Return the last component, unless it is the only component, - * and it is the root of an absolute path. + * Return the last component, unless it is the only component, and + * it is the root of an absolute path. */ if ((splitElements > 0) && ((splitElements > 1) || (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE))) { Tcl_ListObjIndex(NULL, splitPtr, splitElements-1, &resultPtr); @@ -676,18 +689,18 @@ } else { resultPtr = Tcl_NewObj(); } } else { /* - * Return all but the last component. If there is only one + * Return all but the last component. If there is only one * component, return it if the path was non-relative, otherwise * return the current directory. */ if (splitElements > 1) { resultPtr = Tcl_FSJoinPath(splitPtr, splitElements - 1); - } else if (splitElements == 0 || + } else if (splitElements == 0 || (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE)) { resultPtr = Tcl_NewStringObj(".", 1); } else { Tcl_ListObjIndex(NULL, splitPtr, 0, &resultPtr); } @@ -697,20 +710,20 @@ return resultPtr; } } /* - * Simple helper function + * Simple helper function */ static Tcl_Obj* -GetExtension(pathPtr) +GetExtension(pathPtr) Tcl_Obj *pathPtr; { CONST char *tail, *extension; Tcl_Obj *ret; - + tail = TclGetString(pathPtr); extension = TclGetExtension(tail); if (extension == NULL) { ret = Tcl_NewObj(); } else { @@ -723,280 +736,288 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSJoinPath -- * - * This function takes the given Tcl_Obj, which should be a valid - * list, and returns the path object given by considering the - * first 'elements' elements as valid path segments (each path - * segment may be a complete path, a partial path or just a single - * possible directory or file name). If any path segment is - * actually an absolute path, then all prior path segments are - * discarded. - * - * If elements < 0, we use the entire list that was given. - * - * It is possible that the returned object is actually an element - * of the given list, so the caller should be careful to store a - * refCount to it before freeing the list. - * + * This function takes the given Tcl_Obj, which should be a valid list, + * and returns the path object given by considering the first 'elements' + * elements as valid path segments (each path segment may be a complete + * path, a partial path or just a single possible directory or file + * name). If any path segment is actually an absolute path, then all + * prior path segments are discarded. + * + * If elements < 0, we use the entire list that was given. + * + * It is possible that the returned object is actually an element of the + * given list, so the caller should be careful to store a refCount to it + * before freeing the list. + * * Results: - * Returns object with refCount of zero, (or if non-zero, it has - * references elsewhere in Tcl). Either way, the caller must - * increment its refCount before use. Note that in the case where - * the caller has asked to join zero elements of the list, the - * return value will be an empty-string Tcl_Obj. - * - * If the given listObj was invalid, then the calling routine has - * a bug, and this function will just return NULL. + * Returns object with refCount of zero, (or if non-zero, it has + * references elsewhere in Tcl). Either way, the caller must increment + * its refCount before use. Note that in the case where the caller has + * asked to join zero elements of the list, the return value will be an + * empty-string Tcl_Obj. + * + * If the given listObj was invalid, then the calling routine has a bug, + * and this function will just return NULL. * * Side effects: * None. * *--------------------------------------------------------------------------- */ -Tcl_Obj* +Tcl_Obj* Tcl_FSJoinPath(listObj, elements) - Tcl_Obj *listObj; /* Path elements to join, may have refCount 0 */ - int elements; /* Number of elements to use (-1 = all) */ + Tcl_Obj *listObj; /* Path elements to join, may have a zero + * reference count. */ + int elements; /* Number of elements to use (-1 = all) */ { Tcl_Obj *res; int i; Tcl_Filesystem *fsPtr = NULL; - + if (elements < 0) { if (Tcl_ListObjLength(NULL, listObj, &elements) != TCL_OK) { return NULL; } } else { - /* Just make sure it is a valid list */ + /* + * Just make sure it is a valid list. + */ + int listTest; + if (Tcl_ListObjLength(NULL, listObj, &listTest) != TCL_OK) { return NULL; } - /* - * Correct this if it is too large, otherwise we will - * waste our time joining null elements to the path + + /* + * Correct this if it is too large, otherwise we will waste our time + * joining null elements to the path. */ + if (elements > listTest) { elements = listTest; } } - + res = NULL; - + for (i = 0; i < elements; i++) { Tcl_Obj *elt; int driveNameLength; Tcl_PathType type; char *strElt; int strEltLen; int length; char *ptr; Tcl_Obj *driveName = NULL; - + Tcl_ListObjIndex(NULL, listObj, i, &elt); - - /* - * This is a special case where we can be much more - * efficient, where we are joining a single relative path - * onto an object that is already of path type. The - * 'TclNewFSPathObj' call below creates an object which - * can be normalized more efficiently. Currently we only - * use the special case when we have exactly two elements, - * but we could expand that in the future. + + /* + * This is a special case where we can be much more efficient, where + * we are joining a single relative path onto an object that is + * already of path type. The 'TclNewFSPathObj' call below creates an + * object which can be normalized more efficiently. Currently we only + * use the special case when we have exactly two elements, but we + * could expand that in the future. */ if ((i == (elements-2)) && (i == 0) && (elt->typePtr == &tclFsPathType) && !(elt->bytes != NULL && (elt->bytes[0] == '\0'))) { Tcl_Obj *tail; Tcl_PathType type; + Tcl_ListObjIndex(NULL, listObj, i+1, &tail); type = TclGetPathType(tail, NULL, NULL, NULL); if (type == TCL_PATH_RELATIVE) { CONST char *str; int len; str = Tcl_GetStringFromObj(tail, &len); if (len == 0) { - /* - * This happens if we try to handle the root volume - * '/'. There's no need to return a special path - * object, when the base itself is just fine! + /* + * This happens if we try to handle the root volume '/'. + * There's no need to return a special path object, when + * the base itself is just fine! */ + if (res != NULL) { TclDecrRefCount(res); } return elt; } - /* - * If it doesn't begin with '.' and is a unix - * path or it a windows path without backslashes, then we - * can be very efficient here. (In fact even a windows - * path with backslashes can be joined efficiently, but - * the path object would not have forward slashes only, - * and this would therefore contradict our 'file join' - * documentation). + /* + * If it doesn't begin with '.' and is a unix path or it a + * windows path without backslashes, then we can be very + * efficient here. (In fact even a windows path with + * backslashes can be joined efficiently, but the path object + * would not have forward slashes only, and this would + * therefore contradict our 'file join' documentation). */ - if (str[0] != '.' && ((tclPlatform != TCL_PLATFORM_WINDOWS) + if (str[0] != '.' && ((tclPlatform != TCL_PLATFORM_WINDOWS) || (strchr(str, '\\') == NULL))) { - /* - * Finally, on Windows, 'file join' is defined to - * convert all backslashes to forward slashes, - * so the base part cannot have backslashes either. + /* + * Finally, on Windows, 'file join' is defined to convert + * all backslashes to forward slashes, so the base part + * cannot have backslashes either. */ + if ((tclPlatform != TCL_PLATFORM_WINDOWS) - || (strchr(Tcl_GetString(elt), '\\') == NULL)) { + || (strchr(Tcl_GetString(elt), '\\') == NULL)) { if (res != NULL) { TclDecrRefCount(res); } return TclNewFSPathObj(elt, str, len); } } - /* - * Otherwise we don't have an easy join, and - * we must let the more general code below handle - * things - */ - } else { - if (tclPlatform == TCL_PLATFORM_UNIX) { - if (res != NULL) { - TclDecrRefCount(res); - } - return tail; - } else { - CONST char *str; - int len; - str = Tcl_GetStringFromObj(tail, &len); - if (tclPlatform == TCL_PLATFORM_WINDOWS) { - if (strchr(str, '\\') == NULL) { - if (res != NULL) { - TclDecrRefCount(res); - } - return tail; - } + /* + * Otherwise we don't have an easy join, and we must let the + * more general code below handle things + */ + } else if (tclPlatform == TCL_PLATFORM_UNIX) { + if (res != NULL) { + TclDecrRefCount(res); + } + return tail; + } else { + CONST char *str; + int len; + + str = Tcl_GetStringFromObj(tail, &len); + if (tclPlatform == TCL_PLATFORM_WINDOWS) { + if (strchr(str, '\\') == NULL) { + if (res != NULL) { + TclDecrRefCount(res); + } + return tail; } } } } strElt = Tcl_GetStringFromObj(elt, &strEltLen); type = TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName); if (type != TCL_PATH_RELATIVE) { - /* Zero out the current result */ + /* + * Zero out the current result. + */ + if (res != NULL) { TclDecrRefCount(res); } if (driveName != NULL) { /* - * We've been given a separate drive-name object, - * because the prefix in 'elt' is not in a suitable - * format for us (e.g. it may contain irrelevant - * multiple separators, like C://///foo). + * We've been given a separate drive-name object, because the + * prefix in 'elt' is not in a suitable format for us (e.g. it + * may contain irrelevant multiple separators, like + * C://///foo). */ res = Tcl_DuplicateObj(driveName); TclDecrRefCount(driveName); - /* - * Do not set driveName to NULL, because we will check - * its value below (but we won't access the contents, - * since those have been cleaned-up). + /* + * Do not set driveName to NULL, because we will check its + * value below (but we won't access the contents, since those + * have been cleaned-up). */ } else { res = Tcl_NewStringObj(strElt, driveNameLength); } strElt += driveNameLength; } - - /* - * Optimisation block: if this is the last element to be - * examined, and it is absolute or the only element, and the - * drive-prefix was ok (if there is one), it might be that the - * path is already in a suitable form to be returned. Then we - * can short-cut the rest of this procedure. + + /* + * Optimisation block: if this is the last element to be examined, and + * it is absolute or the only element, and the drive-prefix was ok (if + * there is one), it might be that the path is already in a suitable + * form to be returned. Then we can short-cut the rest of this + * function. */ - if ((driveName == NULL) && (i == (elements - 1)) + if ((driveName == NULL) && (i == (elements - 1)) && (type != TCL_PATH_RELATIVE || res == NULL)) { - /* - * It's the last path segment. Perform a quick check if - * the path is already in a suitable form. + /* + * It's the last path segment. Perform a quick check if the path + * is already in a suitable form. */ - + if (tclPlatform == TCL_PLATFORM_WINDOWS) { if (strchr(strElt, '\\') != NULL) { goto noQuickReturn; } } - ptr = strElt; - while (*ptr != '\0') { - if (*ptr == '/' && (ptr[1] == '/' || ptr[1] == '\0')) { - /* - * We have a repeated file separator, which - * means the path is not in normalized form - */ - goto noQuickReturn; - } - ptr++; - } - if (res != NULL) { + ptr = strElt; + while (*ptr != '\0') { + if (*ptr == '/' && (ptr[1] == '/' || ptr[1] == '\0')) { + /* + * We have a repeated file separator, which means the path + * is not in normalized form + */ + goto noQuickReturn; + } + ptr++; + } + if (res != NULL) { TclDecrRefCount(res); } - /* - * This element is just what we want to return already - - * no further manipulation is requred. - */ - return elt; - } - - /* - * The path element was not of a suitable form to be - * returned as is. We need to perform a more complex - * operation here. - */ - - noQuickReturn: - + + /* + * This element is just what we want to return already - no + * further manipulation is requred. + */ + + return elt; + } + + /* + * The path element was not of a suitable form to be returned as is. + * We need to perform a more complex operation here. + */ + + noQuickReturn: + if (res == NULL) { res = Tcl_NewObj(); ptr = Tcl_GetStringFromObj(res, &length); } else { ptr = Tcl_GetStringFromObj(res, &length); } - - /* - * Strip off any './' before a tilde, unless this is the - * beginning of the path. + + /* + * Strip off any './' before a tilde, unless this is the beginning of + * the path. */ if (length > 0 && strEltLen > 0 && (strElt[0] == '.') && (strElt[1] == '/') && (strElt[2] == '~')) { strElt += 2; } - /* - * A NULL value for fsPtr at this stage basically means - * we're trying to join a relative path onto something - * which is also relative (or empty). There's nothing - * particularly wrong with that. + /* + * A NULL value for fsPtr at this stage basically means we're trying + * to join a relative path onto something which is also relative (or + * empty). There's nothing particularly wrong with that. */ if (*strElt == '\0') { continue; } - + if (fsPtr == &tclNativeFilesystem || fsPtr == NULL) { TclpNativeJoinPath(res, strElt); } else { char separator = '/'; int needsSep = 0; - + if (fsPtr->filesystemSeparatorProc != NULL) { Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(res); if (sep != NULL) { separator = TclGetString(sep)[0]; } @@ -1027,53 +1048,51 @@ length = ptr - TclGetString(res); Tcl_SetObjLength(res, length); } } if (res == NULL) { - res = Tcl_NewObj(); + res = Tcl_NewObj(); } return res; } /* *--------------------------------------------------------------------------- * * Tcl_FSConvertToPathType -- * - * This function tries to convert the given Tcl_Obj to a valid - * Tcl path type, taking account of the fact that the cwd may - * have changed even if this object is already supposedly of - * the correct type. - * - * The filename may begin with "~" (to indicate current user's - * home directory) or "~" (to indicate any user's home - * directory). + * This function tries to convert the given Tcl_Obj to a valid Tcl path + * type, taking account of the fact that the cwd may have changed even if + * this object is already supposedly of the correct type. + * + * The filename may begin with "~" (to indicate current user's home + * directory) or "~" (to indicate any user's home directory). * * Results: - * Standard Tcl error code. + * Standard Tcl error code. * * Side effects: * The old representation may be freed, and new memory allocated. * *--------------------------------------------------------------------------- */ -int +int Tcl_FSConvertToPathType(interp, pathPtr) - Tcl_Interp *interp; /* Interpreter in which to store error - * message (if necessary). */ - Tcl_Obj *pathPtr; /* Object to convert to a valid, current - * path type. */ -{ - /* - * While it is bad practice to examine an object's type directly, - * this is actually the best thing to do here. The reason is that - * if we are converting this object to FsPath type for the first - * time, we don't need to worry whether the 'cwd' has changed. - * On the other hand, if this object is already of FsPath type, - * and is a relative path, we do have to worry about the cwd. - * If the cwd has changed, we must recompute the path. + Tcl_Interp *interp; /* Interpreter in which to store error message + * (if necessary). */ + Tcl_Obj *pathPtr; /* Object to convert to a valid, current path + * type. */ +{ + /* + * While it is bad practice to examine an object's type directly, this is + * actually the best thing to do here. The reason is that if we are + * converting this object to FsPath type for the first time, we don't need + * to worry whether the 'cwd' has changed. On the other hand, if this + * object is already of FsPath type, and is a relative path, we do have to + * worry about the cwd. If the cwd has changed, we must recompute the + * path. */ if (pathPtr->typePtr == &tclFsPathType) { FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathPtr); if (!TclFSEpochOk(fsPathPtr->filesystemEpoch)) { @@ -1083,13 +1102,13 @@ FreeFsPathInternalRep(pathPtr); pathPtr->typePtr = NULL; return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType); } return TCL_OK; - /* + /* * We used to have more complex code here: - * + * * if (fsPathPtr->cwdPtr == NULL || PATHFLAGS(pathPtr) != 0) { * return TCL_OK; * } else { * if (TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) { * return TCL_OK; @@ -1100,44 +1119,42 @@ * FreeFsPathInternalRep(pathPtr); * pathPtr->typePtr = NULL; * return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType); * } * } - * + * * But we no longer believe this is necessary. */ } else { return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType); } } -/* +/* * Helper function for normalization. */ static int IsSeparatorOrNull(ch) int ch; { if (ch == 0) { - return 1; + return 1; } switch (tclPlatform) { - case TCL_PLATFORM_UNIX: { - return (ch == '/' ? 1 : 0); - } - case TCL_PLATFORM_WINDOWS: { - return ((ch == '/' || ch == '\\') ? 1 : 0); - } + case TCL_PLATFORM_UNIX: + return (ch == '/' ? 1 : 0); + case TCL_PLATFORM_WINDOWS: + return ((ch == '/' || ch == '\\') ? 1 : 0); } return 0; } -/* - * Helper function for SetFsPathFromAny. Returns position of first - * directory delimiter in the path. If no separator is found, then - * returns the position of the end of the string. +/* + * Helper function for SetFsPathFromAny. Returns position of first directory + * delimiter in the path. If no separator is found, then returns the position + * of the end of the string. */ static int FindSplitPos(path, separator) CONST char *path; @@ -1169,21 +1186,20 @@ /* *--------------------------------------------------------------------------- * * TclNewFSPathObj -- * - * Creates a path object whose string representation is '[file join - * dirPtr addStrRep]', but does so in a way that allows for more - * efficient creation and caching of normalized paths, and more - * efficient 'file dirname', 'file tail', etc. - * + * Creates a path object whose string representation is '[file join + * dirPtr addStrRep]', but does so in a way that allows for more + * efficient creation and caching of normalized paths, and more efficient + * 'file dirname', 'file tail', etc. + * * Assumptions: - * 'dirPtr' must be an absolute path. - * 'len' may not be zero. - * + * 'dirPtr' must be an absolute path. 'len' may not be zero. + * * Results: - * The new Tcl object, with refCount zero. + * The new Tcl object, with refCount zero. * * Side effects: * Memory is allocated. 'dirPtr' gets an additional refCount. * *--------------------------------------------------------------------------- @@ -1193,17 +1209,20 @@ TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep, int len) { FsPath *fsPathPtr; Tcl_Obj *pathPtr; ThreadSpecificData *tsdPtr; - + tsdPtr = TCL_TSD_INIT(&tclFsDataKey); - + pathPtr = Tcl_NewObj(); fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); - - /* Setup the path */ + + /* + * Set up the path. + */ + fsPathPtr->translatedPathPtr = NULL; fsPathPtr->normPathPtr = Tcl_NewStringObj(addStrRep, len); Tcl_IncrRefCount(fsPathPtr->normPathPtr); fsPathPtr->cwdPtr = dirPtr; Tcl_IncrRefCount(dirPtr); @@ -1223,21 +1242,26 @@ /* *--------------------------------------------------------------------------- * * TclFSMakePathRelative -- * - * Only for internal use. - * - * Takes a path and a directory, where we _assume_ both path and - * directory are absolute, normalized and that the path lies - * inside the directory. Returns a Tcl_Obj representing filename - * of the path relative to the directory. - * + * Only for internal use. + * + * Takes a path and a directory, where we _assume_ both path and + * directory are absolute, normalized and that the path lies inside the + * directory. Returns a Tcl_Obj representing filename of the path + * relative to the directory. + * + * In the case where the resulting path would start with a '~', we take + * special care to return an ordinary string. This means to use that + * path (and not have it interpreted as a user name), one must prepend + * './'. This may seem strange, but that is how 'glob' is currently + * defined. + * * Results: - * NULL on error, otherwise a valid object, typically with - * refCount of zero, which it is assumed the caller will - * increment. + * NULL on error, otherwise a valid object, typically with refCount of + * zero, which it is assumed the caller will increment. * * Side effects: * The old representation may be freed, and new memory allocated. * *--------------------------------------------------------------------------- @@ -1250,17 +1274,21 @@ Tcl_Obj *cwdPtr; /* Make it relative to this. */ { int cwdLen, len; CONST char *tempStr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); - + if (pathPtr->typePtr == &tclFsPathType) { FsPath* fsPathPtr = (FsPath*) PATHOBJ(pathPtr); - if (PATHFLAGS(pathPtr) != 0 + if (PATHFLAGS(pathPtr) != 0 && fsPathPtr->cwdPtr == cwdPtr) { pathPtr = fsPathPtr->normPathPtr; - /* Free old representation */ + + /* + * Free old representation. + */ + if (pathPtr->typePtr != NULL) { if (pathPtr->bytes == NULL) { if (pathPtr->typePtr->updateStringProc == NULL) { if (interp != NULL) { Tcl_ResetResult(interp); @@ -1271,14 +1299,30 @@ } pathPtr->typePtr->updateStringProc(pathPtr); } TclFreeIntRep(pathPtr); } + + /* + * Now pathPtr is a string object. + */ + + if (Tcl_GetString(pathPtr)[0] == '~') { + /* + * If the first character of the path is a tilde, we must just + * return the path as is, to agree with the defined behaviour + * of 'glob'. + */ + return pathPtr; + } fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); - /* Circular reference, by design */ + /* + * Circular reference, by design. + */ + fsPathPtr->translatedPathPtr = pathPtr; fsPathPtr->normPathPtr = NULL; fsPathPtr->cwdPtr = cwdPtr; Tcl_IncrRefCount(cwdPtr); fsPathPtr->nativePathPtr = NULL; @@ -1291,42 +1335,40 @@ return pathPtr; } } - /* + /* * We know the cwd is a normalised object which does not end in a - * directory delimiter, unless the cwd is the name of a volume, in - * which case it will end in a delimiter! We handle this - * situation here. A better test than the '!= sep' might be to - * simply check if 'cwd' is a root volume. - * - * Note that if we get this wrong, we will strip off either too - * much or too little below, leading to wrong answers returned by - * glob. + * directory delimiter, unless the cwd is the name of a volume, in which + * case it will end in a delimiter! We handle this situation here. A + * better test than the '!= sep' might be to simply check if 'cwd' is a + * root volume. + * + * Note that if we get this wrong, we will strip off either too much or + * too little below, leading to wrong answers returned by glob. */ tempStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); - /* - * Should we perhaps use 'Tcl_FSPathSeparator'? But then what - * about the Windows special case? Perhaps we should just check - * if cwd is a root volume. + /* + * Should we perhaps use 'Tcl_FSPathSeparator'? But then what about the + * Windows special case? Perhaps we should just check if cwd is a root + * volume. */ switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - if (tempStr[cwdLen-1] != '/') { - cwdLen++; - } - break; - case TCL_PLATFORM_WINDOWS: - if (tempStr[cwdLen-1] != '/' - && tempStr[cwdLen-1] != '\\') { - cwdLen++; - } - break; + case TCL_PLATFORM_UNIX: + if (tempStr[cwdLen-1] != '/') { + cwdLen++; + } + break; + case TCL_PLATFORM_WINDOWS: + if (tempStr[cwdLen-1] != '/' && tempStr[cwdLen-1] != '\\') { + cwdLen++; + } + break; } tempStr = Tcl_GetStringFromObj(pathPtr, &len); return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen); } @@ -1334,15 +1376,15 @@ /* *--------------------------------------------------------------------------- * * TclFSMakePathFromNormalized -- * - * Like SetFsPathFromAny, but assumes the given object is an - * absolute normalized path. Only for internal use. - * + * Like SetFsPathFromAny, but assumes the given object is an absolute + * normalized path. Only for internal use. + * * Results: - * Standard Tcl error code. + * Standard Tcl error code. * * Side effects: * The old representation may be freed, and new memory allocated. * *--------------------------------------------------------------------------- @@ -1359,31 +1401,42 @@ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); if (pathPtr->typePtr == &tclFsPathType) { return TCL_OK; } - - /* Free old representation */ + + /* + * Free old representation + */ + if (pathPtr->typePtr != NULL) { if (pathPtr->bytes == NULL) { if (pathPtr->typePtr->updateStringProc == NULL) { if (interp != NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can't find object", - "string representation", (char *) NULL); + "string representation", (char *) NULL); } return TCL_ERROR; } pathPtr->typePtr->updateStringProc(pathPtr); } TclFreeIntRep(pathPtr); } fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); - /* It's a pure normalized absolute path */ + + /* + * It's a pure normalized absolute path. + */ + fsPathPtr->translatedPathPtr = NULL; - /* Circular reference by design */ + + /* + * Circular reference by design. + */ + fsPathPtr->normPathPtr = pathPtr; fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = nativeRep; fsPathPtr->fsRecPtr = NULL; fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; @@ -1398,24 +1451,23 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSNewNativePath -- * - * This function performs the something like that reverse of the - * usual obj->path->nativerep conversions. If some code retrieves - * a path in native form (from, e.g. readlink or a native dialog), - * and that path is to be used at the Tcl level, then calling - * this function is an efficient way of creating the appropriate - * path object type. - * - * Any memory which is allocated for 'clientData' should be retained - * until clientData is passed to the filesystem's freeInternalRepProc - * when it can be freed. The built in platform-specific filesystems - * use 'ckalloc' to allocate clientData, and ckfree to free it. + * This function performs the something like the reverse of the usual + * obj->path->nativerep conversions. If some code retrieves a path in + * native form (from, e.g. readlink or a native dialog), and that path is + * to be used at the Tcl level, then calling this function is an + * efficient way of creating the appropriate path object type. + * + * Any memory which is allocated for 'clientData' should be retained + * until clientData is passed to the filesystem's freeInternalRepProc + * when it can be freed. The built in platform-specific filesystems use + * 'ckalloc' to allocate clientData, and ckfree to free it. * * Results: - * NULL or a valid path object pointer, with refCount zero. + * NULL or a valid path object pointer, with refCount zero. * * Side effects: * New memory may be allocated. * *--------------------------------------------------------------------------- @@ -1429,41 +1481,46 @@ Tcl_Obj *pathPtr; FsPath *fsPathPtr; FilesystemRecord *fsFromPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); - + pathPtr = TclFSInternalToNormalized(fromFilesystem, clientData, - &fsFromPtr); + &fsFromPtr); if (pathPtr == NULL) { return NULL; } - - /* - * Free old representation; shouldn't normally be any, - * but best to be safe. + + /* + * Free old representation; shouldn't normally be any, but best to be + * safe. */ + if (pathPtr->typePtr != NULL) { if (pathPtr->bytes == NULL) { if (pathPtr->typePtr->updateStringProc == NULL) { return NULL; } pathPtr->typePtr->updateStringProc(pathPtr); } TclFreeIntRep(pathPtr); } - - fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); + + fsPathPtr = (FsPath *) ckalloc(sizeof(FsPath)); fsPathPtr->translatedPathPtr = NULL; - /* Circular reference, by design */ + + /* + * Circular reference, by design. + */ + fsPathPtr->normPathPtr = pathPtr; fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = clientData; fsPathPtr->fsRecPtr = fsFromPtr; fsPathPtr->fsRecPtr->fileRefCount++; - fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; + fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; PATHOBJ(pathPtr) = (VOID *) fsPathPtr; PATHFLAGS(pathPtr) = 0; pathPtr->typePtr = &tclFsPathType; @@ -1473,26 +1530,25 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSGetTranslatedPath -- * - * This function attempts to extract the translated path - * from the given Tcl_Obj. If the translation succeeds (i.e. the - * object is a valid path), then it is returned. Otherwise NULL - * will be returned, and an error message may be left in the - * interpreter (if it is non-NULL) + * This function attempts to extract the translated path from the given + * Tcl_Obj. If the translation succeeds (i.e. the object is a valid + * path), then it is returned. Otherwise NULL will be returned, and an + * error message may be left in the interpreter (if it is non-NULL) * * Results: - * NULL or a valid Tcl_Obj pointer. + * NULL or a valid Tcl_Obj pointer. * * Side effects: * Only those of 'Tcl_FSConvertToPathType' * *--------------------------------------------------------------------------- */ -Tcl_Obj* +Tcl_Obj* Tcl_FSGetTranslatedPath(interp, pathPtr) Tcl_Interp *interp; Tcl_Obj* pathPtr; { Tcl_Obj *retObj = NULL; @@ -1504,20 +1560,23 @@ srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr); if (srcFsPathPtr->translatedPathPtr == NULL) { if (PATHFLAGS(pathPtr) != 0) { retObj = Tcl_FSGetNormalizedPath(interp, pathPtr); } else { - /* - * It is a pure absolute, normalized path object. - * This is something like being a 'pure list'. The - * object's string, translatedPath and normalizedPath - * are all identical. + /* + * It is a pure absolute, normalized path object. This is + * something like being a 'pure list'. The object's string, + * translatedPath and normalizedPath are all identical. */ + retObj = srcFsPathPtr->normPathPtr; } } else { - /* It is an ordinary path object */ + /* + * It is an ordinary path object. + */ + retObj = srcFsPathPtr->translatedPathPtr; } Tcl_IncrRefCount(retObj); return retObj; @@ -1526,18 +1585,17 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSGetTranslatedStringPath -- * - * This function attempts to extract the translated path - * from the given Tcl_Obj. If the translation succeeds (i.e. the - * object is a valid path), then the path is returned. Otherwise NULL - * will be returned, and an error message may be left in the - * interpreter (if it is non-NULL) + * This function attempts to extract the translated path from the given + * Tcl_Obj. If the translation succeeds (i.e. the object is a valid + * path), then the path is returned. Otherwise NULL will be returned, and + * an error message may be left in the interpreter (if it is non-NULL) * * Results: - * NULL or a valid string. + * NULL or a valid string. * * Side effects: * Only those of 'Tcl_FSConvertToPathType' * *--------------------------------------------------------------------------- @@ -1551,10 +1609,11 @@ Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr); if (transPtr != NULL) { int len; CONST char *result, *orig; + orig = Tcl_GetStringFromObj(transPtr, &len); result = (char*) ckalloc((unsigned)(len+1)); memcpy((VOID*) result, (VOID*) orig, (size_t) (len+1)); TclDecrRefCount(transPtr); return result; @@ -1566,25 +1625,25 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSGetNormalizedPath -- * - * This important function attempts to extract from the given Tcl_Obj - * a unique normalised path representation, whose string value can - * be used as a unique identifier for the file. + * This important function attempts to extract from the given Tcl_Obj a + * unique normalised path representation, whose string value can be used + * as a unique identifier for the file. * * Results: - * NULL or a valid path object pointer. + * NULL or a valid path object pointer. * * Side effects: - * New memory may be allocated. The Tcl 'errno' may be modified - * in the process of trying to examine various path possibilities. + * New memory may be allocated. The Tcl 'errno' may be modified in the + * process of trying to examine various path possibilities. * *--------------------------------------------------------------------------- */ -Tcl_Obj* +Tcl_Obj* Tcl_FSGetNormalizedPath(interp, pathPtr) Tcl_Interp *interp; Tcl_Obj* pathPtr; { FsPath *fsPathPtr; @@ -1593,21 +1652,21 @@ return NULL; } fsPathPtr = (FsPath*) PATHOBJ(pathPtr); if (PATHFLAGS(pathPtr) != 0) { - /* - * This is a special path object which is the result of - * something like 'file join' + /* + * This is a special path object which is the result of something like + * 'file join' */ Tcl_Obj *dir, *copy; int cwdLen; int pathType; CONST char *cwdStr; ClientData clientData = NULL; - + pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr); dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr); if (dir == NULL) { return NULL; } @@ -1619,82 +1678,87 @@ Tcl_IncrRefCount(dir); /* * We now own a reference on both 'dir' and 'copy' */ - + cwdStr = Tcl_GetStringFromObj(copy, &cwdLen); - /* - * Should we perhaps use 'Tcl_FSPathSeparator'? - * But then what about the Windows special case? - * Perhaps we should just check if cwd is a root volume. - * We should never get cwdLen == 0 in this code path. + /* + * Should we perhaps use 'Tcl_FSPathSeparator'? But then what about + * the Windows special case? Perhaps we should just check if cwd is a + * root volume. We should never get cwdLen == 0 in this code path. */ switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - if (cwdStr[cwdLen-1] != '/') { - Tcl_AppendToObj(copy, "/", 1); - cwdLen++; - } - break; - case TCL_PLATFORM_WINDOWS: - if (cwdStr[cwdLen-1] != '/' - && cwdStr[cwdLen-1] != '\\') { - Tcl_AppendToObj(copy, "/", 1); - cwdLen++; - } - break; + case TCL_PLATFORM_UNIX: + if (cwdStr[cwdLen-1] != '/') { + Tcl_AppendToObj(copy, "/", 1); + cwdLen++; + } + break; + case TCL_PLATFORM_WINDOWS: + if (cwdStr[cwdLen-1] != '/' && cwdStr[cwdLen-1] != '\\') { + Tcl_AppendToObj(copy, "/", 1); + cwdLen++; + } + break; } Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr); - /* - * Normalize the combined string, but only starting after - * the end of the previously normalized 'dir'. This should - * be much faster! We use 'cwdLen-1' so that we are - * already pointing at the dir-separator that we know about. - * The normalization code will actually start off directly - * after that separator. + /* + * Normalize the combined string, but only starting after the end of + * the previously normalized 'dir'. This should be much faster! We + * use 'cwdLen-1' so that we are already pointing at the dir-separator + * that we know about. The normalization code will actually start off + * directly after that separator. */ - TclFSNormalizeToUniquePath(interp, copy, cwdLen-1, + TclFSNormalizeToUniquePath(interp, copy, cwdLen-1, (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL)); /* * Now we need to construct the new path object */ - + if (pathType == TCL_PATH_RELATIVE) { FsPath* origDirFsPathPtr; Tcl_Obj *origDir = fsPathPtr->cwdPtr; origDirFsPathPtr = (FsPath*) PATHOBJ(origDir); - + fsPathPtr->cwdPtr = origDirFsPathPtr->cwdPtr; Tcl_IncrRefCount(fsPathPtr->cwdPtr); - + TclDecrRefCount(fsPathPtr->normPathPtr); fsPathPtr->normPathPtr = copy; - /* That's our reference to copy used */ + + /* + * That's our reference to copy used. + */ + TclDecrRefCount(dir); TclDecrRefCount(origDir); } else { TclDecrRefCount(fsPathPtr->cwdPtr); fsPathPtr->cwdPtr = NULL; TclDecrRefCount(fsPathPtr->normPathPtr); fsPathPtr->normPathPtr = copy; - /* That's our reference to copy used */ + + /* + * That's our reference to copy used. + */ + TclDecrRefCount(dir); } if (clientData != NULL) { fsPathPtr->nativePathPtr = clientData; } PATHFLAGS(pathPtr) = 0; } /* - * Ensure cwd hasn't changed + * Ensure cwd hasn't changed. */ if (fsPathPtr->cwdPtr != NULL) { if (!TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) { if (pathPtr->bytes == NULL) { @@ -1709,45 +1773,44 @@ } else if (fsPathPtr->normPathPtr == NULL) { int cwdLen; Tcl_Obj *copy; CONST char *cwdStr; ClientData clientData = NULL; - + copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr); Tcl_IncrRefCount(copy); cwdStr = Tcl_GetStringFromObj(copy, &cwdLen); - /* - * Should we perhaps use 'Tcl_FSPathSeparator'? - * But then what about the Windows special case? - * Perhaps we should just check if cwd is a root volume. - * We should never get cwdLen == 0 in this code path. + /* + * Should we perhaps use 'Tcl_FSPathSeparator'? But then what + * about the Windows special case? Perhaps we should just check + * if cwd is a root volume. We should never get cwdLen == 0 in + * this code path. */ switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - if (cwdStr[cwdLen-1] != '/') { - Tcl_AppendToObj(copy, "/", 1); - cwdLen++; - } - break; - case TCL_PLATFORM_WINDOWS: - if (cwdStr[cwdLen-1] != '/' && cwdStr[cwdLen-1] != '\\') { - Tcl_AppendToObj(copy, "/", 1); - cwdLen++; - } - break; + case TCL_PLATFORM_UNIX: + if (cwdStr[cwdLen-1] != '/') { + Tcl_AppendToObj(copy, "/", 1); + cwdLen++; + } + break; + case TCL_PLATFORM_WINDOWS: + if (cwdStr[cwdLen-1] != '/' && cwdStr[cwdLen-1] != '\\') { + Tcl_AppendToObj(copy, "/", 1); + cwdLen++; + } + break; } Tcl_AppendObjToObj(copy, pathPtr); - /* - * Normalize the combined string, but only starting after - * the end of the previously normalized 'dir'. This should - * be much faster! + /* + * Normalize the combined string, but only starting after the end + * of the previously normalized 'dir'. This should be much faster! */ - TclFSNormalizeToUniquePath(interp, copy, cwdLen-1, + TclFSNormalizeToUniquePath(interp, copy, cwdLen-1, (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL)); fsPathPtr->normPathPtr = copy; if (clientData != NULL) { fsPathPtr->nativePathPtr = clientData; } @@ -1755,34 +1818,32 @@ } if (fsPathPtr->normPathPtr == NULL) { ClientData clientData = NULL; Tcl_Obj *useThisCwd = NULL; - /* - * Since normPathPtr is NULL, but this is a valid path - * object, we know that the translatedPathPtr cannot be NULL. + /* + * Since normPathPtr is NULL, but this is a valid path object, we know + * that the translatedPathPtr cannot be NULL. */ Tcl_Obj *absolutePath = fsPathPtr->translatedPathPtr; CONST char *path = TclGetString(absolutePath); - /* + /* * We have to be a little bit careful here to avoid infinite loops - * we're asking Tcl_FSGetPathType to return the path's type, but - * that call can actually result in a lot of other filesystem - * action, which might loop back through here. + * we're asking Tcl_FSGetPathType to return the path's type, but that + * call can actually result in a lot of other filesystem action, which + * might loop back through here. */ if (path[0] != '\0') { - /* - * We don't ask for the type of 'pathPtr' here, because - * that is not correct for our purposes when we have a - * path like '~'. Tcl has a bit of a contradiction in - * that '~' paths are defined as 'absolute', but in - * reality can be just about anything, depending on - * how env(HOME) is set. + * We don't ask for the type of 'pathPtr' here, because that is + * not correct for our purposes when we have a path like '~'. Tcl + * has a bit of a contradiction in that '~' paths are defined as + * 'absolute', but in reality can be just about anything, + * depending on how env(HOME) is set. */ Tcl_PathType type = Tcl_FSGetPathType(absolutePath); if (type == TCL_PATH_RELATIVE) { @@ -1792,62 +1853,66 @@ return NULL; } absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath); Tcl_IncrRefCount(absolutePath); - /* We have a refCount on the cwd */ + + /* + * We have a refCount on the cwd. + */ #ifdef __WIN32__ } else if (type == TCL_PATH_VOLUME_RELATIVE) { - /* Only Windows has volume-relative paths */ - absolutePath = TclWinVolumeRelativeNormalize(interp, path, - &useThisCwd); + /* + * Only Windows has volume-relative paths. + */ + absolutePath = TclWinVolumeRelativeNormalize(interp, + path, &useThisCwd); if (absolutePath == NULL) { return NULL; } #endif /* __WIN32__ */ } } /* - * Already has refCount incremented + * Already has refCount incremented. */ fsPathPtr->normPathPtr = TclFSNormalizeAbsolutePath(interp, - absolutePath, + absolutePath, (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL)); if (0 && (clientData != NULL)) { - fsPathPtr->nativePathPtr = + fsPathPtr->nativePathPtr = (*fsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc)(clientData); } - /* - * Check if path is pure normalized (this can only be the case - * if it is an absolute path). + /* + * Check if path is pure normalized (this can only be the case if it + * is an absolute path). */ if (useThisCwd == NULL) { if (!strcmp(TclGetString(fsPathPtr->normPathPtr), TclGetString(pathPtr))) { - /* - * The path was already normalized. - * Get rid of the duplicate. + /* + * The path was already normalized. Get rid of the duplicate. */ TclDecrRefCount(fsPathPtr->normPathPtr); - /* - * We do *not* increment the refCount for - * this circular reference + /* + * We do *not* increment the refCount for this circular + * reference. */ fsPathPtr->normPathPtr = pathPtr; } } else { - /* - * We just need to free an object we allocated above for - * relative paths (this was returned by Tcl_FSJoinToPath - * above), and then of course store the cwd. + /* + * We just need to free an object we allocated above for relative + * paths (this was returned by Tcl_FSJoinToPath above), and then + * of course store the cwd. */ TclDecrRefCount(absolutePath); fsPathPtr->cwdPtr = useThisCwd; } @@ -1859,87 +1924,83 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSGetInternalRep -- * - * Extract the internal representation of a given path object, - * in the given filesystem. If the path object belongs to a - * different filesystem, we return NULL. - * - * If the internal representation is currently NULL, we attempt - * to generate it, by calling the filesystem's - * 'Tcl_FSCreateInternalRepProc'. + * Extract the internal representation of a given path object, in the + * given filesystem. If the path object belongs to a different + * filesystem, we return NULL. + * + * If the internal representation is currently NULL, we attempt to + * generate it, by calling the filesystem's + * 'Tcl_FSCreateInternalRepProc'. * * Results: - * NULL or a valid internal representation. + * NULL or a valid internal representation. * * Side effects: * An attempt may be made to convert the object. * *--------------------------------------------------------------------------- */ -ClientData +ClientData Tcl_FSGetInternalRep(pathPtr, fsPtr) Tcl_Obj* pathPtr; Tcl_Filesystem *fsPtr; { FsPath* srcFsPathPtr; - + if (Tcl_FSConvertToPathType(NULL, pathPtr) != TCL_OK) { return NULL; } srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr); - - /* + + /* * We will only return the native representation for the caller's - * filesystem. Otherwise we will simply return NULL. This means - * that there must be a unique bi-directional mapping between paths - * and filesystems, and that this mapping will not allow 'remapped' - * files -- files which are in one filesystem but mapped into - * another. Another way of putting this is that 'stacked' - * filesystems are not allowed. We recognise that this is a - * potentially useful feature for the future. - * - * Even something simple like a 'pass through' filesystem which - * logs all activity and passes the calls onto the native system - * would be nice, but not easily achievable with the current - * implementation. + * filesystem. Otherwise we will simply return NULL. This means that + * there must be a unique bi-directional mapping between paths and + * filesystems, and that this mapping will not allow 'remapped' files -- + * files which are in one filesystem but mapped into another. Another way + * of putting this is that 'stacked' filesystems are not allowed. We + * recognise that this is a potentially useful feature for the future. + * + * Even something simple like a 'pass through' filesystem which logs all + * activity and passes the calls onto the native system would be nice, but + * not easily achievable with the current implementation. */ if (srcFsPathPtr->fsRecPtr == NULL) { - /* - * This only usually happens in wrappers like TclpStat which - * create a string object and pass it to TclpObjStat. Code - * which calls the Tcl_FS.. functions should always have a - * filesystem already set. Whether this code path is legal or - * not depends on whether we decide to allow external code to - * call the native filesystem directly. It is at least safer - * to allow this sub-optimal routing. + /* + * This only usually happens in wrappers like TclpStat which create a + * string object and pass it to TclpObjStat. Code which calls the + * Tcl_FS.. functions should always have a filesystem already set. + * Whether this code path is legal or not depends on whether we decide + * to allow external code to call the native filesystem directly. It + * is at least safer to allow this sub-optimal routing. */ Tcl_FSGetFileSystemForPath(pathPtr); - - /* - * If we fail through here, then the path is probably not a - * valid path in the filesystsem, and is most likely to be a - * use of the empty path "" via a direct call to one of the - * objectified interfaces (e.g. from the Tcl testsuite). + + /* + * If we fail through here, then the path is probably not a valid path + * in the filesystsem, and is most likely to be a use of the empty + * path "" via a direct call to one of the objectified interfaces + * (e.g. from the Tcl testsuite). */ srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr); if (srcFsPathPtr->fsRecPtr == NULL) { return NULL; } } - /* - * There is still one possibility we should consider; if the file - * belongs to a different filesystem, perhaps it is actually - * linked through to a file in our own filesystem which we do care - * about. The way we can check for this is we ask what filesystem - * this path belongs to. + /* + * There is still one possibility we should consider; if the file belongs + * to a different filesystem, perhaps it is actually linked through to a + * file in our own filesystem which we do care about. The way we can + * check for this is we ask what filesystem this path belongs to. */ if (fsPtr != srcFsPathPtr->fsRecPtr->fsPtr) { Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathPtr); @@ -1965,25 +2026,24 @@ /* *--------------------------------------------------------------------------- * * TclFSEnsureEpochOk -- * - * This will ensure the pathPtr is up to date and can be - * converted into a "path" type, and that we are able to generate a - * complete normalized path which is used to determine the - * filesystem match. + * This will ensure the pathPtr is up to date and can be converted into a + * "path" type, and that we are able to generate a complete normalized + * path which is used to determine the filesystem match. * * Results: - * Standard Tcl return code. + * Standard Tcl return code. * * Side effects: * An attempt may be made to convert the object. * *--------------------------------------------------------------------------- */ -int +int TclFSEnsureEpochOk(pathPtr, fsPtrPtr) Tcl_Obj* pathPtr; Tcl_Filesystem **fsPtrPtr; { FsPath* srcFsPathPtr; @@ -1992,19 +2052,18 @@ return TCL_OK; } srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr); - /* - * Check if the filesystem has changed in some way since - * this object's internal representation was calculated. + /* + * Check if the filesystem has changed in some way since this object's + * internal representation was calculated. */ if (!TclFSEpochOk(srcFsPathPtr->filesystemEpoch)) { - /* - * We have to discard the stale representation and - * recalculate it + /* + * We have to discard the stale representation and recalculate it. */ if (pathPtr->bytes == NULL) { UpdateStringOfFsPath(pathPtr); } @@ -2015,11 +2074,11 @@ } srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr); } /* - * Check whether the object is already assigned to a fs + * Check whether the object is already assigned to a fs. */ if (srcFsPathPtr->fsRecPtr != NULL) { *fsPtrPtr = srcFsPathPtr->fsRecPtr->fsPtr; } @@ -2040,51 +2099,54 @@ * ??? * *--------------------------------------------------------------------------- */ -void -TclFSSetPathDetails(pathPtr, fsRecPtr, clientData) +void +TclFSSetPathDetails(pathPtr, fsRecPtr, clientData) Tcl_Obj *pathPtr; FilesystemRecord *fsRecPtr; ClientData clientData; { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); FsPath* srcFsPathPtr; - - /* Make sure pathPtr is of the correct type */ + + /* + * Make sure pathPtr is of the correct type. + */ + if (pathPtr->typePtr != &tclFsPathType) { if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) { return; } } - + srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr); srcFsPathPtr->fsRecPtr = fsRecPtr; srcFsPathPtr->nativePathPtr = clientData; - srcFsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; + srcFsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; fsRecPtr->fileRefCount++; } /* *--------------------------------------------------------------------------- * * Tcl_FSEqualPaths -- * - * This function tests whether the two paths given are equal path - * objects. If either or both is NULL, 0 is always returned. + * This function tests whether the two paths given are equal path + * objects. If either or both is NULL, 0 is always returned. * * Results: - * 1 or 0. + * 1 or 0. * * Side effects: * None. * *--------------------------------------------------------------------------- */ -int +int Tcl_FSEqualPaths(firstPtr, secondPtr) Tcl_Obj* firstPtr; Tcl_Obj* secondPtr; { char *firstStr, *secondStr; @@ -2101,13 +2163,13 @@ secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen); if ((firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0)) { return 1; } - /* - * Try the most thorough, correct method of comparing fully - * normalized paths + /* + * Try the most thorough, correct method of comparing fully normalized + * paths. */ tempErrno = Tcl_GetErrno(); firstPtr = Tcl_FSGetNormalizedPath(NULL, firstPtr); secondPtr = Tcl_FSGetNormalizedPath(NULL, secondPtr); @@ -2115,29 +2177,28 @@ if (firstPtr == NULL || secondPtr == NULL) { return 0; } - firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen); + firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen); secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen); return (firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0); } /* *--------------------------------------------------------------------------- * * SetFsPathFromAny -- * - * This function tries to convert the given Tcl_Obj to a valid - * Tcl path type. - * - * The filename may begin with "~" (to indicate current user's - * home directory) or "~" (to indicate any user's home - * directory). + * This function tries to convert the given Tcl_Obj to a valid Tcl path + * type. + * + * The filename may begin with "~" (to indicate current user's home + * directory) or "~" (to indicate any user's home directory). * * Results: - * Standard Tcl error code. + * Standard Tcl error code. * * Side effects: * The old representation may be freed, and new memory allocated. * *--------------------------------------------------------------------------- @@ -2151,29 +2212,27 @@ int len; FsPath *fsPathPtr; Tcl_Obj *transPtr; char *name; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); - + if (pathPtr->typePtr == &tclFsPathType) { return TCL_OK; } - - /* - * First step is to translate the filename. This is similar to - * Tcl_TranslateFilename, but shouldn't convert everything to - * windows backslashes on that platform. The current - * implementation of this piece is a slightly optimised version - * of the various Tilde/Split/Join stuff to avoid multiple - * split/join operations. - * + + /* + * First step is to translate the filename. This is similar to + * Tcl_TranslateFilename, but shouldn't convert everything to windows + * backslashes on that platform. The current implementation of this piece + * is a slightly optimised version of the various Tilde/Split/Join stuff + * to avoid multiple split/join operations. + * * We remove any trailing directory separator. - * - * However, the split/join routines are quite complex, and - * one has to make sure not to break anything on Unix or Win - * (fCmd.test, fileName.test and cmdAH.test exercise - * most of the code). + * + * However, the split/join routines are quite complex, and one has to make + * sure not to break anything on Unix or Win (fCmd.test, fileName.test and + * cmdAH.test exercise most of the code). */ name = Tcl_GetStringFromObj(pathPtr, &len); /* @@ -2183,19 +2242,19 @@ if (name[0] == '~') { char *expandedUser; Tcl_DString temp; int split; char separator='/'; - + split = FindSplitPos(name, separator); if (split != len) { /* We have multiple pieces '~user/foo/bar...' */ name[split] = '\0'; } /* - * Do some tilde substitution + * Do some tilde substitution. */ if (name[1] == '\0') { /* * We have just '~' @@ -2205,11 +2264,11 @@ Tcl_DString dirString; if (split != len) { name[split] = separator; } - + dir = TclGetEnv("HOME", &dirString); if (dir == NULL) { if (interp) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't find HOME environment ", @@ -2224,15 +2283,15 @@ /* * We have a user name '~user' */ Tcl_DStringInit(&temp); - if (TclpGetUserHome(name+1, &temp) == NULL) { + if (TclpGetUserHome(name+1, &temp) == NULL) { if (interp != NULL) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "user \"", (name+1), - "\" doesn't exist", (char *) NULL); + Tcl_AppendResult(interp, "user \"", (name+1), + "\" doesn't exist", (char *) NULL); } Tcl_DStringFree(&temp); if (split != len) { name[split] = separator; } @@ -2240,41 +2299,46 @@ } if (split != len) { name[split] = separator; } } - + expandedUser = Tcl_DStringValue(&temp); transPtr = Tcl_NewStringObj(expandedUser, Tcl_DStringLength(&temp)); if (split != len) { - /* Join up the tilde substitution with the rest */ - if (name[split+1] == separator) { + /* + * Join up the tilde substitution with the rest. + */ + if (name[split+1] == separator) { /* - * Somewhat tricky case like ~//foo/bar. - * Make use of Split/Join machinery to get it right. - * Assumes all paths beginning with ~ are part of the - * native filesystem. + * Somewhat tricky case like ~//foo/bar. Make use of + * Split/Join machinery to get it right. Assumes all paths + * beginning with ~ are part of the native filesystem. */ int objc; Tcl_Obj **objv; Tcl_Obj *parts = TclpNativeSplitPath(pathPtr, NULL); + Tcl_ListObjGetElements(NULL, parts, &objc, &objv); - /* Skip '~'. It's replaced by its expansion */ + + /* + * Skip '~'. It's replaced by its expansion. + */ + objc--; objv++; while (objc--) { TclpNativeJoinPath(transPtr, TclGetString(*objv++)); } TclDecrRefCount(parts); } else { - /* - * Simple case. "rest" is relative path. Just join it. - * The "rest" object will be freed when - * Tcl_FSJoinToPath returns (unless something else - * claims a refCount on it). + /* + * Simple case. "rest" is relative path. Just join it. The + * "rest" object will be freed when Tcl_FSJoinToPath returns + * (unless something else claims a refCount on it). */ Tcl_Obj *joined; Tcl_Obj *rest = Tcl_NewStringObj(name+split+1, -1); @@ -2293,14 +2357,13 @@ { extern int cygwin_conv_to_win32_path(CONST char *, char *); char winbuf[MAX_PATH+1]; /* - * In the Cygwin world, call conv_to_win32_path in order to - * use the mount table to translate the file name into - * something Windows will understand. Take care when - * converting empty strings! + * In the Cygwin world, call conv_to_win32_path in order to use the + * mount table to translate the file name into something Windows will + * understand. Take care when converting empty strings! */ name = Tcl_GetStringFromObj(transPtr, &len); if (len > 0) { cygwin_conv_to_win32_path(name, winbuf); @@ -2308,21 +2371,20 @@ Tcl_SetStringObj(transPtr, winbuf, -1); } } #endif /* __CYGWIN__ && __WIN32__ */ - /* - * Now we have a translated filename in 'transPtr'. This will have - * forward slashes on Windows, and will not contain any ~user - * sequences. + /* + * Now we have a translated filename in 'transPtr'. This will have forward + * slashes on Windows, and will not contain any ~user sequences. */ - - fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); + + fsPathPtr = (FsPath *) ckalloc((unsigned)sizeof(FsPath)); fsPathPtr->translatedPathPtr = transPtr; if (transPtr != pathPtr) { - Tcl_IncrRefCount(fsPathPtr->translatedPathPtr); + Tcl_IncrRefCount(fsPathPtr->translatedPathPtr); } fsPathPtr->normPathPtr = NULL; fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = NULL; fsPathPtr->fsRecPtr = NULL; @@ -2340,11 +2402,11 @@ return TCL_OK; } static void FreeFsPathInternalRep(pathPtr) - Tcl_Obj *pathPtr; /* Path object with internal rep to free. */ + Tcl_Obj *pathPtr; /* Path object with internal rep to free. */ { FsPath* fsPathPtr = (FsPath*) PATHOBJ(pathPtr); if (fsPathPtr->translatedPathPtr != NULL) { if (fsPathPtr->translatedPathPtr != pathPtr) { @@ -2369,12 +2431,15 @@ } } if (fsPathPtr->fsRecPtr != NULL) { fsPathPtr->fsRecPtr->fileRefCount--; if (fsPathPtr->fsRecPtr->fileRefCount <= 0) { - /* It has been unregistered already */ - ckfree((char *)fsPathPtr->fsRecPtr); + /* + * It has been unregistered already. + */ + + ckfree((char *) fsPathPtr->fsRecPtr); } } ckfree((char*) fsPathPtr); } @@ -2395,35 +2460,35 @@ Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr); } } else { copyFsPathPtr->translatedPathPtr = NULL; } - + if (srcFsPathPtr->normPathPtr != NULL) { copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr; if (copyFsPathPtr->normPathPtr != copyPtr) { Tcl_IncrRefCount(copyFsPathPtr->normPathPtr); } } else { copyFsPathPtr->normPathPtr = NULL; } - + if (srcFsPathPtr->cwdPtr != NULL) { copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr; Tcl_IncrRefCount(copyFsPathPtr->cwdPtr); } else { copyFsPathPtr->cwdPtr = NULL; } copyFsPathPtr->flags = srcFsPathPtr->flags; - - if (srcFsPathPtr->fsRecPtr != NULL + + if (srcFsPathPtr->fsRecPtr != NULL && srcFsPathPtr->nativePathPtr != NULL) { Tcl_FSDupInternalRepProc *dupProc = srcFsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc; if (dupProc != NULL) { - copyFsPathPtr->nativePathPtr = + copyFsPathPtr->nativePathPtr = (*dupProc)(srcFsPathPtr->nativePathPtr); } else { copyFsPathPtr->nativePathPtr = NULL; } } else { @@ -2441,14 +2506,14 @@ /* *--------------------------------------------------------------------------- * * UpdateStringOfFsPath -- * - * Gives an object a valid string rep. - * + * Gives an object a valid string rep. + * * Results: - * None. + * None. * * Side effects: * Memory may be allocated. * *--------------------------------------------------------------------------- @@ -2460,51 +2525,50 @@ { FsPath* fsPathPtr = (FsPath*) PATHOBJ(pathPtr); CONST char *cwdStr; int cwdLen; Tcl_Obj *copy; - + if (PATHFLAGS(pathPtr) == 0 || fsPathPtr->cwdPtr == NULL) { Tcl_Panic("Called UpdateStringOfFsPath with invalid object"); } - + copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr); Tcl_IncrRefCount(copy); - + cwdStr = Tcl_GetStringFromObj(copy, &cwdLen); - /* - * Should we perhaps use 'Tcl_FSPathSeparator'? - * But then what about the Windows special case? - * Perhaps we should just check if cwd is a root volume. - * We should never get cwdLen == 0 in this code path. + /* + * Should we perhaps use 'Tcl_FSPathSeparator'? But then what about the + * Windows special case? Perhaps we should just check if cwd is a root + * volume. We should never get cwdLen == 0 in this code path. */ switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - if (cwdStr[cwdLen-1] != '/') { - Tcl_AppendToObj(copy, "/", 1); - cwdLen++; - } - break; - - case TCL_PLATFORM_WINDOWS: - /* - * We need the extra 'cwdLen != 2', and ':' checks because - * a volume relative path doesn't get a '/'. For example - * 'glob C:*cat*.exe' will return 'C:cat32.exe' - */ - - if (cwdStr[cwdLen-1] != '/' - && cwdStr[cwdLen-1] != '\\') { - if (cwdLen != 2 || cwdStr[1] != ':') { - Tcl_AppendToObj(copy, "/", 1); - cwdLen++; - } - } - break; - } + case TCL_PLATFORM_UNIX: + if (cwdStr[cwdLen-1] != '/') { + Tcl_AppendToObj(copy, "/", 1); + cwdLen++; + } + break; + + case TCL_PLATFORM_WINDOWS: + /* + * We need the extra 'cwdLen != 2', and ':' checks because a volume + * relative path doesn't get a '/'. For example 'glob C:*cat*.exe' + * will return 'C:cat32.exe' + */ + + if (cwdStr[cwdLen-1] != '/' && cwdStr[cwdLen-1] != '\\') { + if (cwdLen != 2 || cwdStr[1] != ':') { + Tcl_AppendToObj(copy, "/", 1); + cwdLen++; + } + } + break; + } + Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr); pathPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen); pathPtr->length = cwdLen; copy->bytes = tclEmptyStringRep; copy->length = 0; @@ -2514,64 +2578,75 @@ /* *--------------------------------------------------------------------------- * * TclNativePathInFilesystem -- * - * Any path object is acceptable to the native filesystem, by - * default (we will throw errors when illegal paths are actually - * tried to be used). - * - * However, this behavior means the native filesystem must be - * the last filesystem in the lookup list (otherwise it will - * claim all files belong to it, and other filesystems will - * never get a look in). + * Any path object is acceptable to the native filesystem, by default (we + * will throw errors when illegal paths are actually tried to be used). + * + * However, this behavior means the native filesystem must be the last + * filesystem in the lookup list (otherwise it will claim all files + * belong to it, and other filesystems will never get a look in). * * Results: - * TCL_OK, to indicate 'yes', -1 to indicate no. + * TCL_OK, to indicate 'yes', -1 to indicate no. * * Side effects: * None. * *--------------------------------------------------------------------------- */ -int +int TclNativePathInFilesystem(pathPtr, clientDataPtr) Tcl_Obj *pathPtr; ClientData *clientDataPtr; { - /* - * A special case is required to handle the empty path "". - * This is a valid path (i.e. the user should be able - * to do 'file exists ""' without throwing an error), but - * equally the path doesn't exist. Those are the semantics - * of Tcl (at present anyway), so we have to abide by them - * here. + /* + * A special case is required to handle the empty path "". This is a valid + * path (i.e. the user should be able to do 'file exists ""' without + * throwing an error), but equally the path doesn't exist. Those are the + * semantics of Tcl (at present anyway), so we have to abide by them here. */ if (pathPtr->typePtr == &tclFsPathType) { if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') { - /* We reject the empty path "" */ + /* + * We reject the empty path "". + */ return -1; } - /* Otherwise there is no way this path can be empty */ + /* + * Otherwise there is no way this path can be empty. + */ } else { - /* - * It is somewhat unusual to reach this code path without - * the object being of tclFsPathType. However, we do - * our best to deal with the situation. + /* + * It is somewhat unusual to reach this code path without the object + * being of tclFsPathType. However, we do our best to deal with the + * situation. */ int len; + Tcl_GetStringFromObj(pathPtr, &len); if (len == 0) { - /* We reject the empty path "" */ + /* + * We reject the empty path "". + */ return -1; } } - /* - * Path is of correct type, or is of non-zero length, - * so we accept it. + /* + * Path is of correct type, or is of non-zero length, so we accept it. */ + return TCL_OK; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclPipe.c ================================================================== --- generic/tclPipe.c +++ generic/tclPipe.c @@ -1,63 +1,60 @@ /* * tclPipe.c -- * - * This file contains the generic portion of the command channel - * driver as well as various utility routines used in managing - * subprocesses. + * This file contains the generic portion of the command channel driver + * as well as various utility routines used in managing subprocesses. * * Copyright (c) 1997 by Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPipe.c,v 1.10 2004/10/26 20:24:15 davygrvy Exp $ + * RCS: @(#) $Id: tclPipe.c,v 1.10.2.2 2005/10/08 13:44:37 dgp Exp $ */ #include "tclInt.h" /* - * A linked list of the following structures is used to keep track - * of child processes that have been detached but haven't exited - * yet, so we can make sure that they're properly "reaped" (officially - * waited for) and don't lie around as zombies cluttering the - * system. + * A linked list of the following structures is used to keep track of child + * processes that have been detached but haven't exited yet, so we can make + * sure that they're properly "reaped" (officially waited for) and don't lie + * around as zombies cluttering the system. */ typedef struct Detached { - Tcl_Pid pid; /* Id of process that's been detached - * but isn't known to have exited. */ - struct Detached *nextPtr; /* Next in list of all detached - * processes. */ + Tcl_Pid pid; /* Id of process that's been detached but + * isn't known to have exited. */ + struct Detached *nextPtr; /* Next in list of all detached processes. */ } Detached; -static Detached *detList = NULL; /* List of all detached proceses. */ -TCL_DECLARE_MUTEX(pipeMutex) /* Guard access to detList. */ +static Detached *detList = NULL;/* List of all detached proceses. */ +TCL_DECLARE_MUTEX(pipeMutex) /* Guard access to detList. */ /* - * Declarations for local procedures defined in this file: + * Declarations for local functions defined in this file: */ -static TclFile FileForRedirect _ANSI_ARGS_((Tcl_Interp *interp, - CONST char *spec, int atOk, CONST char *arg, - CONST char *nextArg, int flags, int *skipPtr, - int *closePtr, int *releasePtr)); +static TclFile FileForRedirect _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *spec, int atOk, CONST char *arg, + CONST char *nextArg, int flags, int *skipPtr, + int *closePtr, int *releasePtr)); /* *---------------------------------------------------------------------- * * FileForRedirect -- * - * This procedure does much of the work of parsing redirection - * operators. It handles "@" if specified and allowed, and a file - * name, and opens the file if necessary. + * This function does much of the work of parsing redirection operators. + * It handles "@" if specified and allowed, and a file name, and opens + * the file if necessary. * * Results: - * The return value is the descriptor number for the file. If an - * error occurs then NULL is returned and an error message is left - * in the interp's result. Several arguments are side-effected; see - * the argument list below for details. + * The return value is the descriptor number for the file. If an error + * occurs then NULL is returned and an error message is left in the + * interp's result. Several arguments are side-effected; see the argument + * list below for details. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -65,26 +62,26 @@ static TclFile FileForRedirect(interp, spec, atOK, arg, nextArg, flags, skipPtr, closePtr, releasePtr) Tcl_Interp *interp; /* Intepreter to use for error reporting. */ - CONST char *spec; /* Points to character just after - * redirection character. */ - int atOK; /* Non-zero means that '@' notation can be + CONST char *spec; /* Points to character just after redirection + * character. */ + int atOK; /* Non-zero means that '@' notation can be * used to specify a channel, zero means that * it isn't. */ - CONST char *arg; /* Pointer to entire argument containing - * spec: used for error reporting. */ - CONST char *nextArg; /* Next argument in argc/argv array, if needed - * for file name or channel name. May be + CONST char *arg; /* Pointer to entire argument containing spec: + * used for error reporting. */ + CONST char *nextArg; /* Next argument in argc/argv array, if needed + * for file name or channel name. May be * NULL. */ - int flags; /* Flags to use for opening file or to - * specify mode for channel. */ - int *skipPtr; /* Filled with 1 if redirection target was - * in spec, 2 if it was in nextArg. */ - int *closePtr; /* Filled with one if the caller should - * close the file when done with it, zero + int flags; /* Flags to use for opening file or to specify + * mode for channel. */ + int *skipPtr; /* Filled with 1 if redirection target was in + * spec, 2 if it was in nextArg. */ + int *closePtr; /* Filled with one if the caller should close + * the file when done with it, zero * otherwise. */ int *releasePtr; { int writing = (flags & O_WRONLY); Tcl_Channel chan; @@ -111,15 +108,13 @@ ((writing) ? "writing" : "reading"), (char *) NULL); return NULL; } *releasePtr = 1; if (writing) { - /* - * Be sure to flush output to the file, so that anything - * written by the child appears after stuff we've already - * written. + * Be sure to flush output to the file, so that anything written + * by the child appears after stuff we've already written. */ Tcl_Flush(chan); } } else { @@ -148,11 +143,11 @@ } *closePtr = 1; } return file; - badLastArg: + badLastArg: Tcl_AppendResult(interp, "can't specify \"", arg, "\" as last word in command", (char *) NULL); return NULL; } @@ -159,14 +154,13 @@ /* *---------------------------------------------------------------------- * * Tcl_DetachPids -- * - * This procedure is called to indicate that one or more child - * processes have been placed in background and will never be - * waited for; they should eventually be reaped by - * Tcl_ReapDetachedProcs. + * This function is called to indicate that one or more child processes + * have been placed in background and will never be waited for; they + * should eventually be reaped by Tcl_ReapDetachedProcs. * * Results: * None. * * Side effects: @@ -175,12 +169,12 @@ *---------------------------------------------------------------------- */ void Tcl_DetachPids(numPids, pidPtr) - int numPids; /* Number of pids to detach: gives size - * of array pointed to by pidPtr. */ + int numPids; /* Number of pids to detach: gives size of + * array pointed to by pidPtr. */ Tcl_Pid *pidPtr; /* Array of pids to detach. */ { register Detached *detPtr; int i; @@ -198,21 +192,20 @@ /* *---------------------------------------------------------------------- * * Tcl_ReapDetachedProcs -- * - * This procedure checks to see if any detached processes have - * exited and, if so, it "reaps" them by officially waiting on - * them. It should be called "occasionally" to make sure that - * all detached processes are eventually reaped. + * This function checks to see if any detached processes have exited and, + * if so, it "reaps" them by officially waiting on them. It should be + * called "occasionally" to make sure that all detached processes are + * eventually reaped. * * Results: * None. * * Side effects: - * Processes are waited on, so that they can be reaped by the - * system. + * Processes are waited on, so that they can be reaped by the system. * *---------------------------------------------------------------------- */ void @@ -246,23 +239,23 @@ /* *---------------------------------------------------------------------- * * TclCleanupChildren -- * - * This is a utility procedure used to wait for child processes - * to exit, record information about abnormal exits, and then - * collect any stderr output generated by them. + * This is a utility function used to wait for child processes to exit, + * record information about abnormal exits, and then collect any stderr + * output generated by them. * * Results: - * The return value is a standard Tcl result. If anything at - * weird happened with the child processes, TCL_ERROR is returned - * and a message is left in the interp's result. + * The return value is a standard Tcl result. If anything at weird + * happened with the child processes, TCL_ERROR is returned and a message + * is left in the interp's result. * * Side effects: - * If the last character of the interp's result is a newline, then it - * is removed unless keepNewline is non-zero. File errorId gets - * closed, and pidPtr is freed back to the storage allocator. + * If the last character of the interp's result is a newline, then it is + * removed unless keepNewline is non-zero. File errorId gets closed, and + * pidPtr is freed back to the storage allocator. * *---------------------------------------------------------------------- */ int @@ -269,11 +262,11 @@ TclCleanupChildren(interp, numPids, pidPtr, errorChan) Tcl_Interp *interp; /* Used for error messages. */ int numPids; /* Number of entries in pidPtr array. */ Tcl_Pid *pidPtr; /* Array of process ids of children. */ Tcl_Channel errorChan; /* Channel for file containing stderr output - * from pipeline. NULL means there isn't any + * from pipeline. NULL means there isn't any * stderr output. */ { int result = TCL_OK; int i, abnormalExit, anyErrorInfo; Tcl_Pid pid; @@ -282,26 +275,26 @@ unsigned long resolvedPid; abnormalExit = 0; for (i = 0; i < numPids; i++) { /* - * We need to get the resolved pid before we wait on it as - * the windows implimentation of Tcl_WaitPid deletes the - * information such that any following calls to TclpGetPid - * fail. + * We need to get the resolved pid before we wait on it as the windows + * implimentation of Tcl_WaitPid deletes the information such that any + * following calls to TclpGetPid fail. */ + resolvedPid = TclpGetPid(pidPtr[i]); pid = Tcl_WaitPid(pidPtr[i], (int *) &waitStatus, 0); if (pid == (Tcl_Pid) -1) { result = TCL_ERROR; if (interp != (Tcl_Interp *) NULL) { msg = Tcl_PosixError(interp); if (errno == ECHILD) { /* - * This changeup in message suggested by Mark Diekhans - * to remind people that ECHILD errors can occur on - * some systems if SIGCHLD isn't in its default state. + * This changeup in message suggested by Mark Diekhans to + * remind people that ECHILD errors can occur on some + * systems if SIGCHLD isn't in its default state. */ msg = "child process lost (is SIGCHLD ignored or trapped?)"; } @@ -310,14 +303,14 @@ } continue; } /* - * Create error messages for unusual process exits. An - * extra newline gets appended to each error message, but - * it gets removed below (in the same fashion that an - * extra newline in the command's output is removed). + * Create error messages for unusual process exits. An extra newline + * gets appended to each error message, but it gets removed below (in + * the same fashion that an extra newline in the command's output is + * removed). */ if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) { char msg1[TCL_INTEGER_SPACE], msg2[TCL_INTEGER_SPACE]; @@ -361,18 +354,16 @@ } } } /* - * Read the standard error file. If there's anything there, - * then return an error and add the file's contents to the result - * string. + * Read the standard error file. If there's anything there, then return an + * error and add the file's contents to the result string. */ anyErrorInfo = 0; if (errorChan != NULL) { - /* * Make sure we start at the beginning of the file. */ if (interp != NULL) { @@ -398,12 +389,12 @@ } Tcl_Close(NULL, errorChan); } /* - * If a child exited abnormally but didn't output any error information - * at all, generate an error message here. + * If a child exited abnormally but didn't output any error information at + * all, generate an error message here. */ if ((abnormalExit != 0) && (anyErrorInfo == 0) && (interp != NULL)) { Tcl_AppendResult(interp, "child process exited abnormally", (char *) NULL); @@ -414,29 +405,27 @@ /* *---------------------------------------------------------------------- * * TclCreatePipeline -- * - * Given an argc/argv array, instantiate a pipeline of processes - * as described by the argv. + * Given an argc/argv array, instantiate a pipeline of processes as + * described by the argv. * - * This procedure is unofficially exported for use by BLT. + * This function is unofficially exported for use by BLT. * * Results: - * The return value is a count of the number of new processes - * created, or -1 if an error occurred while creating the pipeline. - * *pidArrayPtr is filled in with the address of a dynamically - * allocated array giving the ids of all of the processes. It - * is up to the caller to free this array when it isn't needed - * anymore. If inPipePtr is non-NULL, *inPipePtr is filled in - * with the file id for the input pipe for the pipeline (if any): - * the caller must eventually close this file. If outPipePtr - * isn't NULL, then *outPipePtr is filled in with the file id - * for the output pipe from the pipeline: the caller must close - * this file. If errFilePtr isn't NULL, then *errFilePtr is filled - * with a file id that may be used to read error output after the - * pipeline completes. + * The return value is a count of the number of new processes created, or + * -1 if an error occurred while creating the pipeline. *pidArrayPtr is + * filled in with the address of a dynamically allocated array giving the + * ids of all of the processes. It is up to the caller to free this array + * when it isn't needed anymore. If inPipePtr is non-NULL, *inPipePtr is + * filled in with the file id for the input pipe for the pipeline (if + * any): the caller must eventually close this file. If outPipePtr isn't + * NULL, then *outPipePtr is filled in with the file id for the output + * pipe from the pipeline: the caller must close this file. If errFilePtr + * isn't NULL, then *errFilePtr is filled with a file id that may be used + * to read error output after the pipeline completes. * * Side effects: * Processes and pipes are created. * *---------------------------------------------------------------------- @@ -446,69 +435,70 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, outPipePtr, errFilePtr) Tcl_Interp *interp; /* Interpreter to use for error reporting. */ int argc; /* Number of entries in argv. */ CONST char **argv; /* Array of strings describing commands in - * pipeline plus I/O redirection with <, - * <<, >, etc. Argv[argc] must be NULL. */ + * pipeline plus I/O redirection with <, <<, + * >, etc. Argv[argc] must be NULL. */ Tcl_Pid **pidArrayPtr; /* Word at *pidArrayPtr gets filled in with - * address of array of pids for processes - * in pipeline (first pid is first process - * in pipeline). */ + * address of array of pids for processes in + * pipeline (first pid is first process in + * pipeline). */ TclFile *inPipePtr; /* If non-NULL, input to the pipeline comes * from a pipe (unless overridden by - * redirection in the command). The file - * id with which to write to this pipe is - * stored at *inPipePtr. NULL means command - * specified its own input source. */ - TclFile *outPipePtr; /* If non-NULL, output to the pipeline goes - * to a pipe, unless overriden by redirection - * in the command. The file id with which to - * read frome this pipe is stored at - * *outPipePtr. NULL means command specified - * its own output sink. */ + * redirection in the command). The file id + * with which to write to this pipe is stored + * at *inPipePtr. NULL means command specified + * its own input source. */ + TclFile *outPipePtr; /* If non-NULL, output to the pipeline goes to + * a pipe, unless overriden by redirection in + * the command. The file id with which to read + * frome this pipe is stored at *outPipePtr. + * NULL means command specified its own output + * sink. */ TclFile *errFilePtr; /* If non-NULL, all stderr output from the * pipeline will go to a temporary file - * created here, and a descriptor to read - * the file will be left at *errFilePtr. - * The file will be removed already, so - * closing this descriptor will be the end - * of the file. If this is NULL, then - * all stderr output goes to our stderr. - * If the pipeline specifies redirection - * then the file will still be created - * but it will never get any data. */ -{ - Tcl_Pid *pidPtr = NULL; /* Points to malloc-ed array holding all - * the pids of child processes. */ - int numPids; /* Actual number of processes that exist - * at *pidPtr right now. */ - int cmdCount; /* Count of number of distinct commands - * found in argc/argv. */ - CONST char *inputLiteral = NULL; /* If non-null, then this points to a - * string containing input data (specified - * via <<) to be piped to the first process - * in the pipeline. */ + * created here, and a descriptor to read the + * file will be left at *errFilePtr. The file + * will be removed already, so closing this + * descriptor will be the end of the file. If + * this is NULL, then all stderr output goes + * to our stderr. If the pipeline specifies + * redirection then the file will still be + * created but it will never get any data. */ +{ + Tcl_Pid *pidPtr = NULL; /* Points to malloc-ed array holding all the + * pids of child processes. */ + int numPids; /* Actual number of processes that exist at + * *pidPtr right now. */ + int cmdCount; /* Count of number of distinct commands found + * in argc/argv. */ + CONST char *inputLiteral = NULL; + /* If non-null, then this points to a string + * containing input data (specified via <<) to + * be piped to the first process in the + * pipeline. */ TclFile inputFile = NULL; /* If != NULL, gives file to use as input for * first process in pipeline (specified via < * or <@). */ - int inputClose = 0; /* If non-zero, then inputFile should be + int inputClose = 0; /* If non-zero, then inputFile should be * closed when cleaning up. */ int inputRelease = 0; TclFile outputFile = NULL; /* Writable file for output from last command - * in pipeline (could be file or pipe). NULL + * in pipeline (could be file or pipe). NULL * means use stdout. */ - int outputClose = 0; /* If non-zero, then outputFile should be + int outputClose = 0; /* If non-zero, then outputFile should be * closed when cleaning up. */ int outputRelease = 0; TclFile errorFile = NULL; /* Writable file for error output from all - * commands in pipeline. NULL means use + * commands in pipeline. NULL means use * stderr. */ - int errorClose = 0; /* If non-zero, then errorFile should be + int errorClose = 0; /* If non-zero, then errorFile should be * closed when cleaning up. */ int errorRelease = 0; CONST char *p; + CONST char *nextArg; int skip, lastBar, lastArg, i, j, atOK, flags, errorToOutput = 0; Tcl_DString execBuffer; TclFile pipeIn; TclFile curInFile, curOutFile, curErrFile; Tcl_Channel channel; @@ -529,20 +519,20 @@ curInFile = NULL; curOutFile = NULL; numPids = 0; /* - * First, scan through all the arguments to figure out the structure - * of the pipeline. Process all of the input and output redirection - * arguments and remove them from the argument list in the pipeline. - * Count the number of distinct processes (it's the number of "|" - * arguments plus one) but don't remove the "|" arguments because - * they'll be used in the second pass to seperate the individual - * child processes. Cannot start the child processes in this pass - * because the redirection symbols may appear anywhere in the - * command line -- e.g., the '<' that specifies the input to the - * entire pipe may appear at the very end of the argument list. + * First, scan through all the arguments to figure out the structure of + * the pipeline. Process all of the input and output redirection arguments + * and remove them from the argument list in the pipeline. Count the + * number of distinct processes (it's the number of "|" arguments plus + * one) but don't remove the "|" arguments because they'll be used in the + * second pass to seperate the individual child processes. Cannot start + * the child processes in this pass because the redirection symbols may + * appear anywhere in the command line - e.g., the '<' that specifies the + * input to the entire pipe may appear at the very end of the argument + * list. */ lastBar = -1; cmdCount = 1; for (i = 0; i < argc; i++) { @@ -554,12 +544,11 @@ if (*p == '&') { p++; } if (*p == '\0') { if ((i == (lastBar + 1)) || (i == (argc - 1))) { - Tcl_SetResult(interp, - "illegal use of | or |& in command", + Tcl_SetResult(interp, "illegal use of | or |& in command", TCL_STATIC); goto error; } } lastBar = i; @@ -578,22 +567,23 @@ if (*p == '<') { inputFile = NULL; inputLiteral = p + 1; skip = 1; if (*inputLiteral == '\0') { - inputLiteral = argv[i + 1]; + inputLiteral = ((i + 1) == argc) ? NULL : argv[i + 1]; if (inputLiteral == NULL) { Tcl_AppendResult(interp, "can't specify \"", argv[i], "\" as last word in command", (char *) NULL); goto error; } skip = 2; } } else { + nextArg = ((i + 1) == argc) ? NULL : argv[i + 1]; inputLiteral = NULL; - inputFile = FileForRedirect(interp, p, 1, argv[i], - argv[i + 1], O_RDONLY, &skip, &inputClose, &inputRelease); + inputFile = FileForRedirect(interp, p, 1, argv[i], nextArg, + O_RDONLY, &skip, &inputClose, &inputRelease); if (inputFile == NULL) { goto error; } } break; @@ -602,11 +592,17 @@ atOK = 1; flags = O_WRONLY | O_CREAT | O_TRUNC; if (*p == '>') { p++; atOK = 0; - flags = O_WRONLY | O_CREAT; + + /* + * Note that the O_APPEND flag only has an effect on POSIX + * platforms. On Windows, we just have to carry on regardless. + */ + + flags = O_WRONLY | O_CREAT | O_APPEND; } if (*p == '&') { if (errorClose != 0) { errorClose = 0; TclpCloseFile(errorFile); @@ -614,12 +610,12 @@ errorToOutput = 1; p++; } /* - * Close the old output file, but only if the error file is - * not also using it. + * Close the old output file, but only if the error file is not + * also using it. */ if (outputClose != 0) { outputClose = 0; if (errorFile == outputFile) { @@ -634,12 +630,13 @@ errorRelease = 1; } else { TclpReleaseFile(outputFile); } } - outputFile = FileForRedirect(interp, p, atOK, argv[i], - argv[i + 1], flags, &skip, &outputClose, &outputRelease); + nextArg = ((i + 1) == argc) ? NULL : argv[i + 1]; + outputFile = FileForRedirect(interp, p, atOK, argv[i], nextArg, + flags, &skip, &outputClose, &outputRelease); if (outputFile == NULL) { goto error; } if (errorToOutput) { if (errorClose != 0) { @@ -675,24 +672,26 @@ TclpReleaseFile(errorFile); } if (atOK && p[0] == '@' && p[1] == '1' && p[2] == '\0') { /* * Special case handling of 2>@1 to redirect stderr to the - * exec/open output pipe as well. This is meant for the end - * of the command string, otherwise use |& between commands. + * exec/open output pipe as well. This is meant for the end of + * the command string, otherwise use |& between commands. */ - if (i != argc - 1) { + + if (i != argc-1) { Tcl_AppendResult(interp, "must specify \"", argv[i], "\" as last word in command", (char *) NULL); goto error; } errorFile = outputFile; errorToOutput = 2; skip = 1; } else { + nextArg = ((i + 1) == argc) ? NULL : argv[i + 1]; errorFile = FileForRedirect(interp, p, atOK, argv[i], - argv[i + 1], flags, &skip, &errorClose, &errorRelease); + nextArg, flags, &skip, &errorClose, &errorRelease); if (errorFile == NULL) { goto error; } } break; @@ -709,13 +708,14 @@ if (inputFile == NULL) { if (inputLiteral != NULL) { /* * The input for the first process is immediate data coming from - * Tcl. Create a temporary file for it and put the data into the + * Tcl. Create a temporary file for it and put the data into the * file. */ + inputFile = TclpCreateTempFile(inputLiteral); if (inputFile == NULL) { Tcl_AppendResult(interp, "couldn't create input file for command: ", Tcl_PosixError(interp), (char *) NULL); @@ -722,12 +722,12 @@ goto error; } inputClose = 1; } else if (inPipePtr != NULL) { /* - * The input for the first process in the pipeline is to - * come from a pipe that can be written from by the caller. + * The input for the first process in the pipeline is to come from + * a pipe that can be written from by the caller. */ if (TclpCreatePipe(&inputFile, inPipePtr) == 0) { Tcl_AppendResult(interp, "couldn't create input pipe for command: ", @@ -751,12 +751,12 @@ } if (outputFile == NULL) { if (outPipePtr != NULL) { /* - * Output from the last process in the pipeline is to go to a - * pipe that can be read by the caller. + * Output from the last process in the pipeline is to go to a pipe + * that can be read by the caller. */ if (TclpCreatePipe(outPipePtr, &outputFile) == 0) { Tcl_AppendResult(interp, "couldn't create output pipe for command: ", @@ -780,20 +780,21 @@ } if (errorFile == NULL) { if (errorToOutput == 2) { /* - * Handle 2>@1 special case at end of cmd line + * Handle 2>@1 special case at end of cmd line. */ + errorFile = outputFile; } else if (errFilePtr != NULL) { /* * Set up the standard error output sink for the pipeline, if - * requested. Use a temporary file which is opened, then deleted. + * requested. Use a temporary file which is opened, then deleted. * Could potentially just use pipe, but if it filled up it could - * cause the pipeline to deadlock: we'd be waiting for processes - * to complete before reading stderr, and processes couldn't + * cause the pipeline to deadlock: we'd be waiting for processes + * to complete before reading stderr, and processes couldn't * complete because stderr was backed up. */ errorFile = TclpCreateTempFile(NULL); if (errorFile == NULL) { @@ -817,12 +818,12 @@ } } } /* - * Scan through the argc array, creating a process for each - * group of arguments between the "|" characters. + * Scan through the argc array, creating a process for each group of + * arguments between the "|" characters. */ Tcl_ReapDetachedProcs(); pidPtr = (Tcl_Pid *) ckalloc((unsigned) (cmdCount * sizeof(Tcl_Pid))); @@ -855,21 +856,21 @@ joinThisError = 1; break; } } } - argv[lastArg] = NULL; /* * If this is the last segment, use the specified outputFile. - * Otherwise create an intermediate pipe. pipeIn will become the + * Otherwise create an intermediate pipe. pipeIn will become the * curInFile for the next segment of the pipe. */ - if (lastArg == argc) { + if (lastArg == argc) { curOutFile = outputFile; } else { + argv[lastArg] = NULL; if (TclpCreatePipe(&pipeIn, &curOutFile) == 0) { Tcl_AppendResult(interp, "couldn't create pipe: ", Tcl_PosixError(interp), (char *) NULL); goto error; } @@ -898,12 +899,12 @@ pidPtr[numPids] = pid; numPids++; /* - * Close off our copies of file descriptors that were set up for - * this child, then set up the input for the next child. + * Close off our copies of file descriptors that were set up for this + * child, then set up the input for the next child. */ if ((curInFile != NULL) && (curInFile != inputFile)) { TclpCloseFile(curInFile); } @@ -917,14 +918,14 @@ } *pidArrayPtr = pidPtr; /* - * All done. Cleanup open files lying around and then return. + * All done. Cleanup open files lying around and then return. */ -cleanup: + cleanup: Tcl_DStringFree(&execBuffer); if (inputClose) { TclpCloseFile(inputFile); } else if (inputRelease) { @@ -941,16 +942,16 @@ TclpReleaseFile(errorFile); } return numPids; /* - * An error occurred. There could have been extra files open, such - * as pipes between children. Clean them all up. Detach any child - * processes that have been created. + * An error occurred. There could have been extra files open, such as + * pipes between children. Clean them all up. Detach any child processes + * that have been created. */ -error: + error: if (pipeIn != NULL) { TclpCloseFile(pipeIn); } if ((curOutFile != NULL) && (curOutFile != outputFile)) { TclpCloseFile(curOutFile); @@ -985,43 +986,41 @@ /* *---------------------------------------------------------------------- * * Tcl_OpenCommandChannel -- * - * Opens an I/O channel to one or more subprocesses specified - * by argc and argv. The flags argument determines the - * disposition of the stdio handles. If the TCL_STDIN flag is - * set then the standard input for the first subprocess will - * be tied to the channel: writing to the channel will provide - * input to the subprocess. If TCL_STDIN is not set, then - * standard input for the first subprocess will be the same as - * this application's standard input. If TCL_STDOUT is set then - * standard output from the last subprocess can be read from the - * channel; otherwise it goes to this application's standard - * output. If TCL_STDERR is set, standard error output for all - * subprocesses is returned to the channel and results in an error - * when the channel is closed; otherwise it goes to this - * application's standard error. If TCL_ENFORCE_MODE is not set, - * then argc and argv can redirect the stdio handles to override - * TCL_STDIN, TCL_STDOUT, and TCL_STDERR; if it is set, then it - * is an error for argc and argv to override stdio channels for - * which TCL_STDIN, TCL_STDOUT, and TCL_STDERR have been set. + * Opens an I/O channel to one or more subprocesses specified by argc and + * argv. The flags argument determines the disposition of the stdio + * handles. If the TCL_STDIN flag is set then the standard input for the + * first subprocess will be tied to the channel: writing to the channel + * will provide input to the subprocess. If TCL_STDIN is not set, then + * standard input for the first subprocess will be the same as this + * application's standard input. If TCL_STDOUT is set then standard + * output from the last subprocess can be read from the channel; + * otherwise it goes to this application's standard output. If TCL_STDERR + * is set, standard error output for all subprocesses is returned to the + * channel and results in an error when the channel is closed; otherwise + * it goes to this application's standard error. If TCL_ENFORCE_MODE is + * not set, then argc and argv can redirect the stdio handles to override + * TCL_STDIN, TCL_STDOUT, and TCL_STDERR; if it is set, then it is an + * error for argc and argv to override stdio channels for which + * TCL_STDIN, TCL_STDOUT, and TCL_STDERR have been set. * * Results: - * A new command channel, or NULL on failure with an error - * message left in interp. + * A new command channel, or NULL on failure with an error message left + * in interp. * * Side effects: * Creates processes, opens pipes. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_OpenCommandChannel(interp, argc, argv, flags) - Tcl_Interp *interp; /* Interpreter for error reporting. Can - * NOT be NULL. */ + Tcl_Interp *interp; /* Interpreter for error reporting. Can NOT be + * NULL. */ int argc; /* How many arguments. */ CONST char **argv; /* Array of arguments for command pipe. */ int flags; /* Or'ed combination of TCL_STDIN, TCL_STDOUT, * TCL_STDERR, and TCL_ENFORCE_MODE. */ { @@ -1043,12 +1042,12 @@ if (numPids < 0) { goto error; } /* - * Verify that the pipes that were created satisfy the - * readable/writable constraints. + * Verify that the pipes that were created satisfy the readable/writable + * constraints. */ if (flags & TCL_ENFORCE_MODE) { if ((flags & TCL_STDOUT) && (outPipe == NULL)) { Tcl_AppendResult(interp, "can't read output from command:", @@ -1070,11 +1069,11 @@ (char *) NULL); goto error; } return channel; -error: + error: if (numPids > 0) { Tcl_DetachPids(numPids, pidPtr); ckfree((char *) pidPtr); } if (inPipe != NULL) { @@ -1086,5 +1085,13 @@ if (errFile != NULL) { TclpCloseFile(errFile); } return NULL; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclPkg.c ================================================================== --- generic/tclPkg.c +++ generic/tclPkg.c @@ -1,84 +1,81 @@ -/* +/* * tclPkg.c -- * - * This file implements package and version control for Tcl via - * the "package" command and a few C APIs. + * This file implements package and version control for Tcl via the + * "package" command and a few C APIs. * * Copyright (c) 1996 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPkg.c,v 1.11 2004/10/06 15:59:25 dgp Exp $ + * RCS: @(#) $Id: tclPkg.c,v 1.11.2.1 2005/08/02 18:16:06 dgp Exp $ */ #include "tclInt.h" /* - * Each invocation of the "package ifneeded" command creates a structure - * of the following type, which is used to load the package into the - * interpreter if it is requested with a "package require" command. + * Each invocation of the "package ifneeded" command creates a structure of + * the following type, which is used to load the package into the interpreter + * if it is requested with a "package require" command. */ typedef struct PkgAvail { char *version; /* Version string; malloc'ed. */ - char *script; /* Script to invoke to provide this version - * of the package. Malloc'ed and protected - * by Tcl_Preserve and Tcl_Release. */ - struct PkgAvail *nextPtr; /* Next in list of available versions of - * the same package. */ + char *script; /* Script to invoke to provide this version of + * the package. Malloc'ed and protected by + * Tcl_Preserve and Tcl_Release. */ + struct PkgAvail *nextPtr; /* Next in list of available versions of the + * same package. */ } PkgAvail; /* - * For each package that is known in any way to an interpreter, there - * is one record of the following type. These records are stored in - * the "packageTable" hash table in the interpreter, keyed by - * package name such as "Tk" (no version number). + * For each package that is known in any way to an interpreter, there is one + * record of the following type. These records are stored in the + * "packageTable" hash table in the interpreter, keyed by package name such as + * "Tk" (no version number). */ typedef struct Package { char *version; /* Version that has been supplied in this * interpreter via "package provide" - * (malloc'ed). NULL means the package doesn't - * exist in this interpreter yet. */ - PkgAvail *availPtr; /* First in list of all available versions - * of this package. */ + * (malloc'ed). NULL means the package + * doesn't exist in this interpreter yet. */ + PkgAvail *availPtr; /* First in list of all available versions of + * this package. */ ClientData clientData; /* Client data. */ } Package; /* * Prototypes for procedures defined in this file: */ static int CheckVersion _ANSI_ARGS_((Tcl_Interp *interp, CONST char *string)); -static int ComparePkgVersions _ANSI_ARGS_((CONST char *v1, - CONST char *v2, - int *satPtr)); +static int ComparePkgVersions _ANSI_ARGS_((CONST char *v1, + CONST char *v2, int *satPtr)); static Package * FindPackage _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name)); /* *---------------------------------------------------------------------- * * Tcl_PkgProvide / Tcl_PkgProvideEx -- * - * This procedure is invoked to declare that a particular version - * of a particular package is now present in an interpreter. There - * must not be any other version of this package already - * provided in the interpreter. + * This procedure is invoked to declare that a particular version of a + * particular package is now present in an interpreter. There must not be + * any other version of this package already provided in the interpreter. * * Results: - * Normally returns TCL_OK; if there is already another version - * of the package loaded then TCL_ERROR is returned and an error - * message is left in the interp's result. + * Normally returns TCL_OK; if there is already another version of the + * package loaded then TCL_ERROR is returned and an error message is left + * in the interp's result. * * Side effects: - * The interpreter remembers that this package is available, - * so that no other version of the package may be provided for - * the interpreter. + * The interpreter remembers that this package is available, so that no + * other version of the package may be provided for the interpreter. * *---------------------------------------------------------------------- */ int @@ -95,12 +92,12 @@ Tcl_PkgProvideEx(interp, name, version, clientData) Tcl_Interp *interp; /* Interpreter in which package is now * available. */ CONST char *name; /* Name of package. */ CONST char *version; /* Version string for package. */ - ClientData clientData; /* clientdata for this package (normally - * used for C callback function table) */ + ClientData clientData; /* clientdata for this package (normally used + * for C callback function table) */ { Package *pkgPtr; pkgPtr = FindPackage(interp, name); if (pkgPtr->version == NULL) { @@ -123,152 +120,144 @@ /* *---------------------------------------------------------------------- * * Tcl_PkgRequire / Tcl_PkgRequireEx -- * - * This procedure is called by code that depends on a particular - * version of a particular package. If the package is not already - * provided in the interpreter, this procedure invokes a Tcl script - * to provide it. If the package is already provided, this - * procedure makes sure that the caller's needs don't conflict with - * the version that is present. + * This procedure is called by code that depends on a particular version + * of a particular package. If the package is not already provided in the + * interpreter, this procedure invokes a Tcl script to provide it. If the + * package is already provided, this procedure makes sure that the + * caller's needs don't conflict with the version that is present. * * Results: - * If successful, returns the version string for the currently - * provided version of the package, which may be different from - * the "version" argument. If the caller's requirements - * cannot be met (e.g. the version requested conflicts with - * a currently provided version, or the required version cannot - * be found, or the script to provide the required version - * generates an error), NULL is returned and an error - * message is left in the interp's result. + * If successful, returns the version string for the currently provided + * version of the package, which may be different from the "version" + * argument. If the caller's requirements cannot be met (e.g. the version + * requested conflicts with a currently provided version, or the required + * version cannot be found, or the script to provide the required version + * generates an error), NULL is returned and an error message is left in + * the interp's result. * * Side effects: - * The script from some previous "package ifneeded" command may - * be invoked to provide the package. + * The script from some previous "package ifneeded" command may be + * invoked to provide the package. * *---------------------------------------------------------------------- */ CONST char * Tcl_PkgRequire(interp, name, version, exact) Tcl_Interp *interp; /* Interpreter in which package is now * available. */ CONST char *name; /* Name of desired package. */ - CONST char *version; /* Version string for desired version; - * NULL means use the latest version - * available. */ + CONST char *version; /* Version string for desired version; NULL + * means use the latest version available. */ int exact; /* Non-zero means that only the particular - * version given is acceptable. Zero means - * use the latest compatible version. */ + * version given is acceptable. Zero means use + * the latest compatible version. */ { return Tcl_PkgRequireEx(interp, name, version, exact, (ClientData *) NULL); } CONST char * Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) Tcl_Interp *interp; /* Interpreter in which package is now * available. */ CONST char *name; /* Name of desired package. */ - CONST char *version; /* Version string for desired version; - * NULL means use the latest version - * available. */ + CONST char *version; /* Version string for desired version; NULL + * means use the latest version available. */ int exact; /* Non-zero means that only the particular - * version given is acceptable. Zero means - * use the latest compatible version. */ + * version given is acceptable. Zero means use + * the latest compatible version. */ ClientData *clientDataPtr; /* Used to return the client data for this - * package. If it is NULL then the client - * data is not returned. This is unchanged - * if this call fails for any reason. */ + * package. If it is NULL then the client data + * is not returned. This is unchanged if this + * call fails for any reason. */ { Package *pkgPtr; PkgAvail *availPtr, *bestPtr; char *script; int code, satisfies, result, pass; Tcl_DString command; /* * If an attempt is being made to load this into a standalone executable - * on a platform where backlinking is not supported then this must be - * a shared version of Tcl (Otherwise the load would have failed). - * Detect this situation by checking that this library has been correctly + * on a platform where backlinking is not supported then this must be a + * shared version of Tcl (Otherwise the load would have failed). Detect + * this situation by checking that this library has been correctly * initialised. If it has not been then return immediately as nothing will * work. */ - + if (tclEmptyStringRep == NULL) { /* * OK, so what's going on here? * - * First, what are we doing? We are performing a check on behalf of - * one particular caller, Tcl_InitStubs(). When a package is - * stub-enabled, it is statically linked to libtclstub.a, which - * contains a copy of Tcl_InitStubs(). When a stub-enabled package - * is loaded, its *_Init() function is supposed to call - * Tcl_InitStubs() before calling any other functions in the Tcl - * library. The first Tcl function called by Tcl_InitStubs() through - * the stub table is Tcl_PkgRequireEx(), so this code right here is - * the first code that is part of the original Tcl library in the - * executable that gets executed on behalf of a newly loaded - * stub-enabled package. + * First, what are we doing? We are performing a check on behalf of + * one particular caller, Tcl_InitStubs(). When a package is stub- + * enabled, it is statically linked to libtclstub.a, which contains a + * copy of Tcl_InitStubs(). When a stub-enabled package is loaded, its + * *_Init() function is supposed to call Tcl_InitStubs() before + * calling any other functions in the Tcl library. The first Tcl + * function called by Tcl_InitStubs() through the stub table is + * Tcl_PkgRequireEx(), so this code right here is the first code that + * is part of the original Tcl library in the executable that gets + * executed on behalf of a newly loaded stub-enabled package. * * One easy error for the developer/builder of a stub-enabled package * to make is to forget to define USE_TCL_STUBS when compiling the - * package. When that happens, the package will contain symbols - * that are references to the Tcl library, rather than function - * pointers referencing the stub table. On platforms that lack - * backlinking, those unresolved references may cause the loading - * of the package to also load a second copy of the Tcl library, - * leading to all kinds of trouble. We would like to catch that - * error and report a useful message back to the user. That's - * what we're doing. - * - * Second, how does this work? If we reach this point, then the - * global variable tclEmptyStringRep has the value NULL. Compare - * that with the definition of tclEmptyStringRep near the top of - * the file generic/tclObj.c. It clearly should not have the value - * NULL; it should point to the char tclEmptyString. If we see it - * having the value NULL, then somehow we are seeing a Tcl library - * that isn't completely initialized, and that's an indicator for the - * error condition described above. (Further explanation is welcome.) - * - * Third, so what do we do about it? This situation indicates - * the package we just loaded wasn't properly compiled to be - * stub-enabled, yet it thinks it is stub-enabled (it called - * Tcl_InitStubs()). We want to report that the package just - * loaded is broken, so we want to place an error message in - * the interpreter result and return NULL to indicate failure - * to Tcl_InitStubs() so that it will also fail. (Further - * explanation why we don't want to Tcl_Panic() is welcome. + * package. When that happens, the package will contain symbols that + * are references to the Tcl library, rather than function pointers + * referencing the stub table. On platforms that lack backlinking, + * those unresolved references may cause the loading of the package to + * also load a second copy of the Tcl library, leading to all kinds of + * trouble. We would like to catch that error and report a useful + * message back to the user. That's what we're doing. + * + * Second, how does this work? If we reach this point, then the global + * variable tclEmptyStringRep has the value NULL. Compare that with + * the definition of tclEmptyStringRep near the top of the file + * generic/tclObj.c. It clearly should not have the value NULL; it + * should point to the char tclEmptyString. If we see it having the + * value NULL, then somehow we are seeing a Tcl library that isn't + * completely initialized, and that's an indicator for the error + * condition described above. (Further explanation is welcome.) + * + * Third, so what do we do about it? This situation indicates the + * package we just loaded wasn't properly compiled to be stub-enabled, + * yet it thinks it is stub-enabled (it called Tcl_InitStubs()). We + * want to report that the package just loaded is broken, so we want + * to place an error message in the interpreter result and return NULL + * to indicate failure to Tcl_InitStubs() so that it will also fail. + * (Further explanation why we don't want to Tcl_Panic() is welcome. * After all, two Tcl libraries can't be a good thing!) * - * Trouble is that's going to be tricky. We're now using a Tcl - * library that's not fully initialized. In particular, it - * doesn't have a proper value for tclEmptyStringRep. The - * Tcl_Obj system heavily depends on the value of tclEmptyStringRep - * and all of Tcl depends (increasingly) on the Tcl_Obj system, we - * need to correct that flaw before making the calls to set the - * interpreter result to the error message. That's the only flaw - * corrected; other problems with initialization of the Tcl library - * are not remedied, so be very careful about adding any other calls - * here without checking how they behave when initialization is - * incomplete. + * Trouble is that's going to be tricky. We're now using a Tcl library + * that's not fully initialized. In particular, it doesn't have a + * proper value for tclEmptyStringRep. The Tcl_Obj system heavily + * depends on the value of tclEmptyStringRep and all of Tcl depends + * (increasingly) on the Tcl_Obj system, we need to correct that flaw + * before making the calls to set the interpreter result to the error + * message. That's the only flaw corrected; other problems with + * initialization of the Tcl library are not remedied, so be very + * careful about adding any other calls here without checking how they + * behave when initialization is incomplete. */ tclEmptyStringRep = &tclEmptyString; - Tcl_AppendResult(interp, "Cannot load package \"", name, - "\" in standalone executable: This package is not ", - "compiled with stub support", NULL); - return NULL; + Tcl_AppendResult(interp, "Cannot load package \"", name, + "\" in standalone executable: This package is not ", + "compiled with stub support", NULL); + return NULL; } /* - * It can take up to three passes to find the package: one pass to - * run the "package unknown" script, one to run the "package ifneeded" - * script for a specific version, and a final pass to lookup the - * package loaded by the "package ifneeded" script. + * It can take up to three passes to find the package: one pass to run the + * "package unknown" script, one to run the "package ifneeded" script for + * a specific version, and a final pass to lookup the package loaded by + * the "package ifneeded" script. */ for (pass = 1; ; pass++) { pkgPtr = FindPackage(interp, name); if (pkgPtr->version != NULL) { @@ -277,11 +266,11 @@ /* * The package isn't yet present. Search the list of available * versions and invoke the script for the best available version. */ - + bestPtr = NULL; for (availPtr = pkgPtr->availPtr; availPtr != NULL; availPtr = availPtr->nextPtr) { if ((bestPtr != NULL) && (ComparePkgVersions(availPtr->version, bestPtr->version, (int *) NULL) <= 0)) { @@ -300,15 +289,15 @@ bestPtr = availPtr; } if (bestPtr != NULL) { /* * We found an ifneeded script for the package. Be careful while - * executing it: this could cause reentrancy, so (a) protect the + * executing it: this could cause reentrancy, so (a) protect the * script itself from deletion and (b) don't assume that bestPtr * will still exist when the script completes. */ - + script = bestPtr->script; Tcl_Preserve((ClientData) script); code = Tcl_GlobalEval(interp, script); Tcl_Release((ClientData) script); if (code != TCL_OK) { @@ -323,12 +312,12 @@ break; } /* * Package not in the database. If there is a "package unknown" - * command, invoke it (but only on the first pass; after that, - * we should not get here in the first place). + * command, invoke it (but only on the first pass; after that, we + * should not get here in the first place). */ if (pass > 1) { break; } @@ -369,11 +358,11 @@ * At this point we know that the package is present. Make sure that the * provided version meets the current requirement. */ if (version == NULL) { - if (clientDataPtr) { + if (clientDataPtr) { *clientDataPtr = pkgPtr->clientData; } return pkgPtr->version; } result = ComparePkgVersions(pkgPtr->version, version, &satisfies); @@ -389,23 +378,22 @@ return NULL; } /* *---------------------------------------------------------------------- - * + *q * Tcl_PkgPresent / Tcl_PkgPresentEx -- * - * Checks to see whether the specified package is present. If it - * is not then no additional action is taken. + * Checks to see whether the specified package is present. If it is not + * then no additional action is taken. * * Results: - * If successful, returns the version string for the currently - * provided version of the package, which may be different from - * the "version" argument. If the caller's requirements - * cannot be met (e.g. the version requested conflicts with - * a currently provided version), NULL is returned and an error - * message is left in interp->result. + * If successful, returns the version string for the currently provided + * version of the package, which may be different from the "version" + * argument. If the caller's requirements cannot be met (e.g. the version + * requested conflicts with a currently provided version), NULL is + * returned and an error message is left in interp->result. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -414,35 +402,33 @@ CONST char * Tcl_PkgPresent(interp, name, version, exact) Tcl_Interp *interp; /* Interpreter in which package is now * available. */ CONST char *name; /* Name of desired package. */ - CONST char *version; /* Version string for desired version; - * NULL means use the latest version - * available. */ + CONST char *version; /* Version string for desired version; NULL + * means use the latest version available. */ int exact; /* Non-zero means that only the particular - * version given is acceptable. Zero means - * use the latest compatible version. */ + * version given is acceptable. Zero means use + * the latest compatible version. */ { return Tcl_PkgPresentEx(interp, name, version, exact, (ClientData *) NULL); } CONST char * Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) Tcl_Interp *interp; /* Interpreter in which package is now * available. */ CONST char *name; /* Name of desired package. */ - CONST char *version; /* Version string for desired version; - * NULL means use the latest version - * available. */ + CONST char *version; /* Version string for desired version; NULL + * means use the latest version available. */ int exact; /* Non-zero means that only the particular - * version given is acceptable. Zero means - * use the latest compatible version. */ + * version given is acceptable. Zero means use + * the latest compatible version. */ ClientData *clientDataPtr; /* Used to return the client data for this - * package. If it is NULL then the client - * data is not returned. This is unchanged - * if this call fails for any reason. */ + * package. If it is NULL then the client data + * is not returned. This is unchanged if this + * call fails for any reason. */ { Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; Package *pkgPtr; int satisfies, result; @@ -449,55 +435,54 @@ hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name); if (hPtr) { pkgPtr = (Package *) Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { - /* - * At this point we know that the package is present. Make sure + * At this point we know that the package is present. Make sure * that the provided version meets the current requirement. */ if (version == NULL) { if (clientDataPtr) { *clientDataPtr = pkgPtr->clientData; } - + return pkgPtr->version; } result = ComparePkgVersions(pkgPtr->version, version, &satisfies); if ((satisfies && !exact) || (result == 0)) { if (clientDataPtr) { *clientDataPtr = pkgPtr->clientData; } - + return pkgPtr->version; } - Tcl_AppendResult(interp, "version conflict for package \"", - name, "\": have ", pkgPtr->version, - ", need ", version, (char *) NULL); + Tcl_AppendResult(interp, "version conflict for package \"", name, + "\": have ", pkgPtr->version, ", need ", version, + (char *) NULL); return NULL; } } if (version != NULL) { Tcl_AppendResult(interp, "package ", name, " ", version, - " is not present", (char *) NULL); + " is not present", (char *) NULL); } else { Tcl_AppendResult(interp, "package ", name, " is not present", - (char *) NULL); + (char *) NULL); } return NULL; } /* *---------------------------------------------------------------------- * * Tcl_PackageObjCmd -- * - * This procedure is invoked to process the "package" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "package" Tcl command. See + * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -507,13 +492,13 @@ */ /* ARGSUSED */ int Tcl_PackageObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { static CONST char *pkgOptions[] = { "forget", "ifneeded", "names", "present", "provide", "require", "unknown", "vcompare", "versions", "vsatisfies", (char *) NULL @@ -532,288 +517,280 @@ Tcl_HashTable *tablePtr; CONST char *version; char *argv2, *argv3, *argv4; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } switch ((enum pkgOptions) optionIndex) { - case PKG_FORGET: { - char *keyString; - for (i = 2; i < objc; i++) { - keyString = Tcl_GetString(objv[i]); - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString); - if (hPtr == NULL) { - continue; - } - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); - Tcl_DeleteHashEntry(hPtr); - if (pkgPtr->version != NULL) { - ckfree(pkgPtr->version); - } - while (pkgPtr->availPtr != NULL) { - availPtr = pkgPtr->availPtr; - pkgPtr->availPtr = availPtr->nextPtr; - ckfree(availPtr->version); - Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); - ckfree((char *) availPtr); - } - ckfree((char *) pkgPtr); - } - break; - } - case PKG_IFNEEDED: { - int length; - if ((objc != 4) && (objc != 5)) { - Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?"); - return TCL_ERROR; - } - argv3 = Tcl_GetString(objv[3]); - if (CheckVersion(interp, argv3) != TCL_OK) { - return TCL_ERROR; - } - argv2 = Tcl_GetString(objv[2]); - if (objc == 4) { - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); - if (hPtr == NULL) { - return TCL_OK; - } - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); - } else { - pkgPtr = FindPackage(interp, argv2); - } - argv3 = Tcl_GetStringFromObj(objv[3], &length); - for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; - prevPtr = availPtr, availPtr = availPtr->nextPtr) { - if (ComparePkgVersions(availPtr->version, argv3, (int *) NULL) - == 0) { - if (objc == 4) { - Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); - return TCL_OK; - } - Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); - break; - } - } - if (objc == 4) { - return TCL_OK; - } - if (availPtr == NULL) { - availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail)); - availPtr->version = ckalloc((unsigned) (length + 1)); - strcpy(availPtr->version, argv3); - if (prevPtr == NULL) { - availPtr->nextPtr = pkgPtr->availPtr; - pkgPtr->availPtr = availPtr; - } else { - availPtr->nextPtr = prevPtr->nextPtr; - prevPtr->nextPtr = availPtr; - } - } - argv4 = Tcl_GetStringFromObj(objv[4], &length); - availPtr->script = ckalloc((unsigned) (length + 1)); - strcpy(availPtr->script, argv4); - break; - } - case PKG_NAMES: { - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; - } - tablePtr = &iPtr->packageTable; - for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); - if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { - Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); - } - } - break; - } - case PKG_PRESENT: { - if (objc < 3) { - presentSyntax: - Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); - return TCL_ERROR; - } - argv2 = Tcl_GetString(objv[2]); - if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { - exact = 1; - } else { - exact = 0; - } - version = NULL; - if (objc == (4 + exact)) { - version = Tcl_GetString(objv[3 + exact]); - if (CheckVersion(interp, version) != TCL_OK) { - return TCL_ERROR; - } - } else if ((objc != 3) || exact) { - goto presentSyntax; - } - if (exact) { - argv3 = Tcl_GetString(objv[3]); - version = Tcl_PkgPresent(interp, argv3, version, exact); - } else { - version = Tcl_PkgPresent(interp, argv2, version, exact); - } - if (version == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) ); - break; - } - case PKG_PROVIDE: { - if ((objc != 3) && (objc != 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "package ?version?"); - return TCL_ERROR; - } - argv2 = Tcl_GetString(objv[2]); - if (objc == 3) { - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); - if (hPtr != NULL) { - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); - if (pkgPtr->version != NULL) { - Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); - } - } - return TCL_OK; - } - argv3 = Tcl_GetString(objv[3]); - if (CheckVersion(interp, argv3) != TCL_OK) { - return TCL_ERROR; - } - return Tcl_PkgProvide(interp, argv2, argv3); - } - case PKG_REQUIRE: { - if (objc < 3) { - requireSyntax: - Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); - return TCL_ERROR; - } - argv2 = Tcl_GetString(objv[2]); - if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { - exact = 1; - } else { - exact = 0; - } - version = NULL; - if (objc == (4 + exact)) { - version = Tcl_GetString(objv[3 + exact]); - if (CheckVersion(interp, version) != TCL_OK) { - return TCL_ERROR; - } - } else if ((objc != 3) || exact) { - goto requireSyntax; - } - if (exact) { - argv3 = Tcl_GetString(objv[3]); - version = Tcl_PkgRequire(interp, argv3, version, exact); - } else { - version = Tcl_PkgRequire(interp, argv2, version, exact); - } - if (version == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) ); - break; - } - case PKG_UNKNOWN: { - int length; - if (objc == 2) { - if (iPtr->packageUnknown != NULL) { - Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE); - } - } else if (objc == 3) { - if (iPtr->packageUnknown != NULL) { - ckfree(iPtr->packageUnknown); - } - argv2 = Tcl_GetStringFromObj(objv[2], &length); - if (argv2[0] == 0) { - iPtr->packageUnknown = NULL; - } else { - iPtr->packageUnknown = (char *) ckalloc((unsigned) - (length + 1)); - strcpy(iPtr->packageUnknown, argv2); - } - } else { - Tcl_WrongNumArgs(interp, 2, objv, "?command?"); - return TCL_ERROR; - } - break; - } - case PKG_VCOMPARE: { - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); - return TCL_ERROR; - } - argv3 = Tcl_GetString(objv[3]); - argv2 = Tcl_GetString(objv[2]); - if ((CheckVersion(interp, argv2) != TCL_OK) - || (CheckVersion(interp, argv3) != TCL_OK)) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewIntObj( - ComparePkgVersions(argv2, argv3, (int *) NULL))); - break; - } - case PKG_VERSIONS: { - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "package"); - return TCL_ERROR; - } - argv2 = Tcl_GetString(objv[2]); - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); - if (hPtr != NULL) { - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); - for (availPtr = pkgPtr->availPtr; availPtr != NULL; - availPtr = availPtr->nextPtr) { - Tcl_AppendElement(interp, availPtr->version); - } - } - break; - } - case PKG_VSATISFIES: { - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); - return TCL_ERROR; - } - argv3 = Tcl_GetString(objv[3]); - argv2 = Tcl_GetString(objv[2]); - if ((CheckVersion(interp, argv2) != TCL_OK) - || (CheckVersion(interp, argv3) != TCL_OK)) { - return TCL_ERROR; - } - ComparePkgVersions(argv2, argv3, &satisfies); - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies)); - break; - } - default: { - Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); - } + case PKG_FORGET: { + char *keyString; + + for (i = 2; i < objc; i++) { + keyString = Tcl_GetString(objv[i]); + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString); + if (hPtr == NULL) { + continue; + } + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + if (pkgPtr->version != NULL) { + ckfree(pkgPtr->version); + } + while (pkgPtr->availPtr != NULL) { + availPtr = pkgPtr->availPtr; + pkgPtr->availPtr = availPtr->nextPtr; + ckfree(availPtr->version); + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + ckfree((char *) availPtr); + } + ckfree((char *) pkgPtr); + } + break; + } + case PKG_IFNEEDED: { + int length; + + if ((objc != 4) && (objc != 5)) { + Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?"); + return TCL_ERROR; + } + argv3 = Tcl_GetString(objv[3]); + if (CheckVersion(interp, argv3) != TCL_OK) { + return TCL_ERROR; + } + argv2 = Tcl_GetString(objv[2]); + if (objc == 4) { + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); + if (hPtr == NULL) { + return TCL_OK; + } + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + } else { + pkgPtr = FindPackage(interp, argv2); + } + argv3 = Tcl_GetStringFromObj(objv[3], &length); + for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; + prevPtr = availPtr, availPtr = availPtr->nextPtr) { + if (ComparePkgVersions(availPtr->version, argv3, (int *) NULL)==0){ + if (objc == 4) { + Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); + return TCL_OK; + } + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + break; + } + } + if (objc == 4) { + return TCL_OK; + } + if (availPtr == NULL) { + availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail)); + availPtr->version = ckalloc((unsigned) (length + 1)); + strcpy(availPtr->version, argv3); + if (prevPtr == NULL) { + availPtr->nextPtr = pkgPtr->availPtr; + pkgPtr->availPtr = availPtr; + } else { + availPtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = availPtr; + } + } + argv4 = Tcl_GetStringFromObj(objv[4], &length); + availPtr->script = ckalloc((unsigned) (length + 1)); + strcpy(availPtr->script, argv4); + break; + } + case PKG_NAMES: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + tablePtr = &iPtr->packageTable; + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { + Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); + } + } + break; + case PKG_PRESENT: + if (objc < 3) { + presentSyntax: + Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); + return TCL_ERROR; + } + argv2 = Tcl_GetString(objv[2]); + if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { + exact = 1; + } else { + exact = 0; + } + version = NULL; + if (objc == (4 + exact)) { + version = Tcl_GetString(objv[3 + exact]); + if (CheckVersion(interp, version) != TCL_OK) { + return TCL_ERROR; + } + } else if ((objc != 3) || exact) { + goto presentSyntax; + } + if (exact) { + argv3 = Tcl_GetString(objv[3]); + version = Tcl_PkgPresent(interp, argv3, version, exact); + } else { + version = Tcl_PkgPresent(interp, argv2, version, exact); + } + if (version == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) ); + break; + case PKG_PROVIDE: + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "package ?version?"); + return TCL_ERROR; + } + argv2 = Tcl_GetString(objv[2]); + if (objc == 3) { + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); + if (hPtr != NULL) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + if (pkgPtr->version != NULL) { + Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); + } + } + return TCL_OK; + } + argv3 = Tcl_GetString(objv[3]); + if (CheckVersion(interp, argv3) != TCL_OK) { + return TCL_ERROR; + } + return Tcl_PkgProvide(interp, argv2, argv3); + case PKG_REQUIRE: + if (objc < 3) { + requireSyntax: + Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); + return TCL_ERROR; + } + argv2 = Tcl_GetString(objv[2]); + if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { + exact = 1; + } else { + exact = 0; + } + version = NULL; + if (objc == (4 + exact)) { + version = Tcl_GetString(objv[3 + exact]); + if (CheckVersion(interp, version) != TCL_OK) { + return TCL_ERROR; + } + } else if ((objc != 3) || exact) { + goto requireSyntax; + } + if (exact) { + argv3 = Tcl_GetString(objv[3]); + version = Tcl_PkgRequire(interp, argv3, version, exact); + } else { + version = Tcl_PkgRequire(interp, argv2, version, exact); + } + if (version == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(version, -1)); + break; + case PKG_UNKNOWN: { + int length; + + if (objc == 2) { + if (iPtr->packageUnknown != NULL) { + Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE); + } + } else if (objc == 3) { + if (iPtr->packageUnknown != NULL) { + ckfree(iPtr->packageUnknown); + } + argv2 = Tcl_GetStringFromObj(objv[2], &length); + if (argv2[0] == 0) { + iPtr->packageUnknown = NULL; + } else { + iPtr->packageUnknown = (char *) ckalloc((unsigned) (length+1)); + strcpy(iPtr->packageUnknown, argv2); + } + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?command?"); + return TCL_ERROR; + } + break; + } + case PKG_VCOMPARE: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); + return TCL_ERROR; + } + argv3 = Tcl_GetString(objv[3]); + argv2 = Tcl_GetString(objv[2]); + if ((CheckVersion(interp, argv2) != TCL_OK) + || (CheckVersion(interp, argv3) != TCL_OK)) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj( + ComparePkgVersions(argv2, argv3, (int *) NULL))); + break; + case PKG_VERSIONS: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "package"); + return TCL_ERROR; + } + argv2 = Tcl_GetString(objv[2]); + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); + if (hPtr != NULL) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + Tcl_AppendElement(interp, availPtr->version); + } + } + break; + case PKG_VSATISFIES: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); + return TCL_ERROR; + } + argv3 = Tcl_GetString(objv[3]); + argv2 = Tcl_GetString(objv[2]); + if ((CheckVersion(interp, argv2) != TCL_OK) + || (CheckVersion(interp, argv3) != TCL_OK)) { + return TCL_ERROR; + } + ComparePkgVersions(argv2, argv3, &satisfies); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies)); + break; + default: + Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); } return TCL_OK; } /* *---------------------------------------------------------------------- * * FindPackage -- * - * This procedure finds the Package record for a particular package - * in a particular interpreter, creating a record if one doesn't - * already exist. + * This procedure finds the Package record for a particular package in a + * particular interpreter, creating a record if one doesn't already + * exist. * * Results: - * The return value is a pointer to the Package record for the - * package. + * The return value is a pointer to the Package record for the package. * * Side effects: * A new Package record may be created. * *---------------------------------------------------------------------- @@ -845,13 +822,12 @@ /* *---------------------------------------------------------------------- * * TclFreePackageInfo -- * - * This procedure is called during interpreter deletion to - * free all of the package-related information for the - * interpreter. + * This procedure is called during interpreter deletion to free all of + * the package-related information for the interpreter. * * Results: * None. * * Side effects: @@ -893,17 +869,17 @@ /* *---------------------------------------------------------------------- * * CheckVersion -- * - * This procedure checks to see whether a version number has - * valid syntax. + * This procedure checks to see whether a version number has valid + * syntax. * * Results: - * If string is a properly formed version number the TCL_OK - * is returned. Otherwise TCL_ERROR is returned and an error - * message is left in the interp's result. + * If string is a properly formed version number the TCL_OK is returned. + * Otherwise TCL_ERROR is returned and an error message is left in the + * interp's result. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -911,16 +887,16 @@ static int CheckVersion(interp, string) Tcl_Interp *interp; /* Used for error reporting. */ CONST char *string; /* Supposedly a version number, which is - * groups of decimal digits separated - * by dots. */ + * groups of decimal digits separated by + * dots. */ { CONST char *p = string; char prevChar; - + if (!isdigit(UCHAR(*p))) { /* INTL: digit */ goto error; } for (prevChar = *p, p++; *p != 0; p++) { if (!isdigit(UCHAR(*p)) && @@ -931,13 +907,13 @@ } if (prevChar != '.') { return TCL_OK; } - error: - Tcl_AppendResult(interp, "expected version number but got \"", - string, "\"", (char *) NULL); + error: + Tcl_AppendResult(interp, "expected version number but got \"", string, + "\"", (char *) NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- @@ -945,15 +921,14 @@ * ComparePkgVersions -- * * This procedure compares two version numbers. * * Results: - * The return value is -1 if v1 is less than v2, 0 if the two - * version numbers are the same, and 1 if v1 is greater than v2. - * If *satPtr is non-NULL, the word it points to is filled in - * with 1 if v2 >= v1 and both numbers have the same major number - * or 0 otherwise. + * The return value is -1 if v1 is less than v2, 0 if the two version + * numbers are the same, and 1 if v1 is greater than v2. If *satPtr is + * non-NULL, the word it points to is filled in with 1 if v2 >= v1 and + * both numbers have the same major number or 0 otherwise. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -960,25 +935,24 @@ */ static int ComparePkgVersions(v1, v2, satPtr) CONST char *v1; - CONST char *v2; /* Versions strings, of form 2.1.3 (any - * number of version numbers). */ - int *satPtr; /* If non-null, the word pointed to is - * filled in with a 0/1 value. 1 means - * v1 "satisfies" v2: v1 is greater than - * or equal to v2 and both version numbers - * have the same major number. */ + CONST char *v2; /* Versions strings, of form 2.1.3 (any number + * of version numbers). */ + int *satPtr; /* If non-null, the word pointed to is filled + * in with a 0/1 value. 1 means v1 "satisfies" + * v2: v1 is greater than or equal to v2 and + * both version numbers have the same major + * number. */ { int thisIsMajor, n1, n2; /* - * Each iteration of the following loop processes one number from - * each string, terminated by a ".". If those numbers don't match - * then the comparison is over; otherwise, we loop back for the - * next number. + * Each iteration of the following loop processes one number from each + * string, terminated by a ".". If those numbers don't match then the + * comparison is over; otherwise, we loop back for the next number. */ thisIsMajor = 1; while (1) { /* @@ -994,12 +968,12 @@ n2 = 10*n2 + (*v2 - '0'); v2++; } /* - * Compare and go on to the next version number if the - * current numbers match. + * Compare and go on to the next version number if the current numbers + * match. */ if (n1 != n2) { break; } @@ -1022,5 +996,13 @@ return 0; } else { return -1; } } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclPkgConfig.c ================================================================== --- generic/tclPkgConfig.c +++ generic/tclPkgConfig.c @@ -1,122 +1,137 @@ -/* +/* * tclPkgConfig.c -- * - * This file contains the configuration information to - * embed into the tcl binary library. - * - * Copyright (c) 2002 Andreas Kupries - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclPkgConfig.c,v 1.2 2003/06/09 22:48:33 andreas_kupries Exp $ + * This file contains the configuration information to embed into the tcl + * binary library. + * + * Copyright (c) 2002 Andreas Kupries + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclPkgConfig.c,v 1.2.4.1 2005/08/02 18:16:06 dgp Exp $ */ -/* Note, the definitions in this module are influenced by the - * following C preprocessor macros: +/* Note, the definitions in this module are influenced by the following C + * preprocessor macros: * * OSCMa = shortcut for "old style configuration macro activates" * NSCMdt = shortcut for "new style configuration macro declares that" * - * - TCL_THREADS OSCMa compilation as threaded core. - * - TCL_MEM_DEBUG OSCMa memory debugging. - * - TCL_COMPILE_DEBUG OSCMa debugging of bytecode compiler. - * - TCL_COMPILE_STATS OSCMa bytecode compiler statistics. + * - TCL_THREADS OSCMa compilation as threaded core. + * - TCL_MEM_DEBUG OSCMa memory debugging. + * - TCL_COMPILE_DEBUG OSCMa debugging of bytecode compiler. + * - TCL_COMPILE_STATS OSCMa bytecode compiler statistics. * * - TCL_CFG_DO64BIT NSCMdt tcl is compiled for a 64bit system. * - TCL_CFG_DEBUG NSCMdt tcl is compiled with symbol info on. - * - TCL_CFG_OPTIMIZED NSCMdt tcl is compiled with cc optimizations on. + * - TCL_CFG_OPTIMIZED NSCMdt tcl is compiled with cc optimizations on * - TCL_CFG_PROFILED NSCMdt tcl is compiled with profiling info. * * - CFG_RUNTIME_* Paths to various stuff at runtime. * - CFG_INSTALL_* Paths to various stuff at installation time. * * - TCL_CFGVAL_ENCODING string containing the encoding used for the - * configuration values. + * configuration values. */ #include "tclInt.h" - - - -/* Use C preprocessor statements to define the various values for the - * embedded configuration information. */ - -#ifdef TCL_THREADS -# define CFG_THREADED "1" -#else -# define CFG_THREADED "0" -#endif -#ifdef TCL_MEM_DEBUG -# define CFG_MEMDEBUG "1" -#else -# define CFG_MEMDEBUG "0" -#endif -#ifdef TCL_COMPILE_DEBUG -# define CFG_COMPILE_DEBUG "1" -#else -# define CFG_COMPILE_DEBUG "0" -#endif -#ifdef TCL_COMPILE_STATS -# define CFG_COMPILE_STATS "1" -#else -# define CFG_COMPILE_STATS "0" -#endif -#ifdef TCL_CFG_DO64BIT -# define CFG_64 "1" -#else -# define CFG_64 "0" -#endif -#ifdef TCL_CFG_DEBUG -# define CFG_DEBUG "1" -#else -# define CFG_DEBUG "0" -#endif -#ifdef TCL_CFG_OPTIMIZED -# define CFG_OPTIMIZED "1" -#else -# define CFG_OPTIMIZED "0" -#endif -#ifdef TCL_CFG_PROFILED -# define CFG_PROFILED "1" -#else -# define CFG_PROFILED "0" -#endif - -static Tcl_Config cfg [] = { - {"debug", CFG_DEBUG}, - {"threaded", CFG_THREADED}, - {"profiled", CFG_PROFILED}, - {"64bit", CFG_64}, - {"optimized", CFG_OPTIMIZED}, - {"mem_debug", CFG_MEMDEBUG}, - {"compile_debug", CFG_COMPILE_DEBUG}, - {"compile_stats", CFG_COMPILE_STATS}, - - /* Runtime paths to various stuff */ - - {"libdir,runtime", CFG_RUNTIME_LIBDIR}, - {"bindir,runtime", CFG_RUNTIME_BINDIR}, - {"scriptdir,runtime", CFG_RUNTIME_SCRDIR}, - {"includedir,runtime", CFG_RUNTIME_INCDIR}, - {"docdir,runtime", CFG_RUNTIME_DOCDIR}, - - /* Installation paths to various stuff */ - - {"libdir,install", CFG_INSTALL_LIBDIR}, - {"bindir,install", CFG_INSTALL_BINDIR}, - {"scriptdir,install", CFG_INSTALL_SCRDIR}, - {"includedir,install", CFG_INSTALL_INCDIR}, - {"docdir,install", CFG_INSTALL_DOCDIR}, - - /* Last entry, closes the array */ - {NULL, NULL} -}; - -void -TclInitEmbeddedConfigurationInformation (interp) - Tcl_Interp* interp; /* Interpreter the configuration - * command is registered in. */ -{ - Tcl_RegisterConfig (interp, "tcl", cfg, TCL_CFGVAL_ENCODING); -} + +/* + * Use C preprocessor statements to define the various values for the embedded + * configuration information. + */ + +#ifdef TCL_THREADS +# define CFG_THREADED "1" +#else +# define CFG_THREADED "0" +#endif + +#ifdef TCL_MEM_DEBUG +# define CFG_MEMDEBUG "1" +#else +# define CFG_MEMDEBUG "0" +#endif + +#ifdef TCL_COMPILE_DEBUG +# define CFG_COMPILE_DEBUG "1" +#else +# define CFG_COMPILE_DEBUG "0" +#endif + +#ifdef TCL_COMPILE_STATS +# define CFG_COMPILE_STATS "1" +#else +# define CFG_COMPILE_STATS "0" +#endif + +#ifdef TCL_CFG_DO64BIT +# define CFG_64 "1" +#else +# define CFG_64 "0" +#endif + +#ifdef TCL_CFG_DEBUG +# define CFG_DEBUG "1" +#else +# define CFG_DEBUG "0" +#endif + +#ifdef TCL_CFG_OPTIMIZED +# define CFG_OPTIMIZED "1" +#else +# define CFG_OPTIMIZED "0" +#endif + +#ifdef TCL_CFG_PROFILED +# define CFG_PROFILED "1" +#else +# define CFG_PROFILED "0" +#endif + +static Tcl_Config cfg[] = { + {"debug", CFG_DEBUG}, + {"threaded", CFG_THREADED}, + {"profiled", CFG_PROFILED}, + {"64bit", CFG_64}, + {"optimized", CFG_OPTIMIZED}, + {"mem_debug", CFG_MEMDEBUG}, + {"compile_debug", CFG_COMPILE_DEBUG}, + {"compile_stats", CFG_COMPILE_STATS}, + + /* Runtime paths to various stuff */ + + {"libdir,runtime", CFG_RUNTIME_LIBDIR}, + {"bindir,runtime", CFG_RUNTIME_BINDIR}, + {"scriptdir,runtime", CFG_RUNTIME_SCRDIR}, + {"includedir,runtime", CFG_RUNTIME_INCDIR}, + {"docdir,runtime", CFG_RUNTIME_DOCDIR}, + + /* Installation paths to various stuff */ + + {"libdir,install", CFG_INSTALL_LIBDIR}, + {"bindir,install", CFG_INSTALL_BINDIR}, + {"scriptdir,install", CFG_INSTALL_SCRDIR}, + {"includedir,install", CFG_INSTALL_INCDIR}, + {"docdir,install", CFG_INSTALL_DOCDIR}, + + /* Last entry, closes the array */ + {NULL, NULL} +}; + +void +TclInitEmbeddedConfigurationInformation(interp) + Tcl_Interp* interp; /* Interpreter the configuration command is + * registered in. */ +{ + Tcl_RegisterConfig(interp, "tcl", cfg, TCL_CFGVAL_ENCODING); +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclPort.h ================================================================== --- generic/tclPort.h +++ generic/tclPort.h @@ -8,20 +8,20 @@ * Copyright (c) 1994-1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPort.h,v 1.13 2004/11/24 21:37:31 davygrvy Exp $ + * RCS: @(#) $Id: tclPort.h,v 1.13.2.2 2005/01/20 19:13:50 kennykb Exp $ */ #ifndef _TCLPORT #define _TCLPORT -#include "tcl.h" #ifdef HAVE_TCL_CONFIG_H #include "tclConfig.h" #endif +#include "tcl.h" #if defined(__WIN32__) # include "../win/tclWinPort.h" #else # include "tclUnixPort.h" Index: generic/tclPosixStr.c ================================================================== --- generic/tclPosixStr.c +++ generic/tclPosixStr.c @@ -1,19 +1,18 @@ /* * tclPosixStr.c -- * - * This file contains procedures that generate strings - * corresponding to various POSIX-related codes, such - * as errno and signals. + * This file contains procedures that generate strings corresponding to + * various POSIX-related codes, such as errno and signals. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1996 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPosixStr.c,v 1.10 2004/04/06 22:25:54 dgp Exp $ + * RCS: @(#) $Id: tclPosixStr.c,v 1.10.2.1 2005/08/02 18:16:06 dgp Exp $ */ #include "tclInt.h" /* @@ -22,13 +21,13 @@ * Tcl_ErrnoId -- * * Return a textual identifier for the current errno value. * * Results: - * This procedure returns a machine-readable textual identifier - * that corresponds to the current errno value (e.g. "EPERM"). - * The identifier is the same as the #define name in errno.h. + * This procedure returns a machine-readable textual identifier that + * corresponds to the current errno value (e.g. "EPERM"). The identifier + * is the same as the #define name in errno.h. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -37,425 +36,425 @@ CONST char * Tcl_ErrnoId() { switch (errno) { #ifdef E2BIG - case E2BIG: return "E2BIG"; + case E2BIG: return "E2BIG"; #endif #ifdef EACCES - case EACCES: return "EACCES"; + case EACCES: return "EACCES"; #endif #ifdef EADDRINUSE - case EADDRINUSE: return "EADDRINUSE"; + case EADDRINUSE: return "EADDRINUSE"; #endif #ifdef EADDRNOTAVAIL - case EADDRNOTAVAIL: return "EADDRNOTAVAIL"; + case EADDRNOTAVAIL: return "EADDRNOTAVAIL"; #endif #ifdef EADV - case EADV: return "EADV"; + case EADV: return "EADV"; #endif #ifdef EAFNOSUPPORT - case EAFNOSUPPORT: return "EAFNOSUPPORT"; + case EAFNOSUPPORT: return "EAFNOSUPPORT"; #endif #ifdef EAGAIN - case EAGAIN: return "EAGAIN"; + case EAGAIN: return "EAGAIN"; #endif #ifdef EALIGN - case EALIGN: return "EALIGN"; + case EALIGN: return "EALIGN"; #endif #if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY )) - case EALREADY: return "EALREADY"; + case EALREADY: return "EALREADY"; #endif #ifdef EBADE - case EBADE: return "EBADE"; + case EBADE: return "EBADE"; #endif #ifdef EBADF - case EBADF: return "EBADF"; + case EBADF: return "EBADF"; #endif #ifdef EBADFD - case EBADFD: return "EBADFD"; + case EBADFD: return "EBADFD"; #endif #ifdef EBADMSG - case EBADMSG: return "EBADMSG"; + case EBADMSG: return "EBADMSG"; #endif #ifdef EBADR - case EBADR: return "EBADR"; + case EBADR: return "EBADR"; #endif #ifdef EBADRPC - case EBADRPC: return "EBADRPC"; + case EBADRPC: return "EBADRPC"; #endif #ifdef EBADRQC - case EBADRQC: return "EBADRQC"; + case EBADRQC: return "EBADRQC"; #endif #ifdef EBADSLT - case EBADSLT: return "EBADSLT"; + case EBADSLT: return "EBADSLT"; #endif #ifdef EBFONT - case EBFONT: return "EBFONT"; + case EBFONT: return "EBFONT"; #endif #ifdef EBUSY - case EBUSY: return "EBUSY"; + case EBUSY: return "EBUSY"; #endif #ifdef ECHILD - case ECHILD: return "ECHILD"; + case ECHILD: return "ECHILD"; #endif #ifdef ECHRNG - case ECHRNG: return "ECHRNG"; + case ECHRNG: return "ECHRNG"; #endif #ifdef ECOMM - case ECOMM: return "ECOMM"; + case ECOMM: return "ECOMM"; #endif #ifdef ECONNABORTED - case ECONNABORTED: return "ECONNABORTED"; + case ECONNABORTED: return "ECONNABORTED"; #endif #ifdef ECONNREFUSED - case ECONNREFUSED: return "ECONNREFUSED"; + case ECONNREFUSED: return "ECONNREFUSED"; #endif #ifdef ECONNRESET - case ECONNRESET: return "ECONNRESET"; + case ECONNRESET: return "ECONNRESET"; #endif #if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK)) - case EDEADLK: return "EDEADLK"; + case EDEADLK: return "EDEADLK"; #endif #if defined(EDEADLOCK) && (!defined(EDEADLK) || (EDEADLOCK != EDEADLK)) - case EDEADLOCK: return "EDEADLOCK"; + case EDEADLOCK: return "EDEADLOCK"; #endif #ifdef EDESTADDRREQ - case EDESTADDRREQ: return "EDESTADDRREQ"; + case EDESTADDRREQ: return "EDESTADDRREQ"; #endif #ifdef EDIRTY - case EDIRTY: return "EDIRTY"; + case EDIRTY: return "EDIRTY"; #endif #ifdef EDOM - case EDOM: return "EDOM"; + case EDOM: return "EDOM"; #endif #ifdef EDOTDOT - case EDOTDOT: return "EDOTDOT"; + case EDOTDOT: return "EDOTDOT"; #endif #ifdef EDQUOT - case EDQUOT: return "EDQUOT"; + case EDQUOT: return "EDQUOT"; #endif #ifdef EDUPPKG - case EDUPPKG: return "EDUPPKG"; + case EDUPPKG: return "EDUPPKG"; #endif #ifdef EEXIST - case EEXIST: return "EEXIST"; + case EEXIST: return "EEXIST"; #endif #ifdef EFAULT - case EFAULT: return "EFAULT"; + case EFAULT: return "EFAULT"; #endif #ifdef EFBIG - case EFBIG: return "EFBIG"; + case EFBIG: return "EFBIG"; #endif #ifdef EHOSTDOWN - case EHOSTDOWN: return "EHOSTDOWN"; + case EHOSTDOWN: return "EHOSTDOWN"; #endif #ifdef EHOSTUNREACH - case EHOSTUNREACH: return "EHOSTUNREACH"; + case EHOSTUNREACH: return "EHOSTUNREACH"; #endif #if defined(EIDRM) && (!defined(EINPROGRESS) || (EIDRM != EINPROGRESS)) - case EIDRM: return "EIDRM"; + case EIDRM: return "EIDRM"; #endif #ifdef EINIT - case EINIT: return "EINIT"; + case EINIT: return "EINIT"; #endif #ifdef EINPROGRESS - case EINPROGRESS: return "EINPROGRESS"; + case EINPROGRESS: return "EINPROGRESS"; #endif #ifdef EINTR - case EINTR: return "EINTR"; + case EINTR: return "EINTR"; #endif #ifdef EINVAL - case EINVAL: return "EINVAL"; + case EINVAL: return "EINVAL"; #endif #ifdef EIO - case EIO: return "EIO"; + case EIO: return "EIO"; #endif #ifdef EISCONN - case EISCONN: return "EISCONN"; + case EISCONN: return "EISCONN"; #endif #ifdef EISDIR - case EISDIR: return "EISDIR"; + case EISDIR: return "EISDIR"; #endif #ifdef EISNAME - case EISNAM: return "EISNAM"; + case EISNAM: return "EISNAM"; #endif #ifdef ELBIN - case ELBIN: return "ELBIN"; + case ELBIN: return "ELBIN"; #endif #ifdef EL2HLT - case EL2HLT: return "EL2HLT"; + case EL2HLT: return "EL2HLT"; #endif #ifdef EL2NSYNC - case EL2NSYNC: return "EL2NSYNC"; + case EL2NSYNC: return "EL2NSYNC"; #endif #ifdef EL3HLT - case EL3HLT: return "EL3HLT"; + case EL3HLT: return "EL3HLT"; #endif #ifdef EL3RST - case EL3RST: return "EL3RST"; + case EL3RST: return "EL3RST"; #endif #ifdef ELIBACC - case ELIBACC: return "ELIBACC"; + case ELIBACC: return "ELIBACC"; #endif #ifdef ELIBBAD - case ELIBBAD: return "ELIBBAD"; + case ELIBBAD: return "ELIBBAD"; #endif #ifdef ELIBEXEC - case ELIBEXEC: return "ELIBEXEC"; + case ELIBEXEC: return "ELIBEXEC"; #endif #ifdef ELIBMAX - case ELIBMAX: return "ELIBMAX"; + case ELIBMAX: return "ELIBMAX"; #endif #ifdef ELIBSCN - case ELIBSCN: return "ELIBSCN"; + case ELIBSCN: return "ELIBSCN"; #endif #ifdef ELNRNG - case ELNRNG: return "ELNRNG"; + case ELNRNG: return "ELNRNG"; #endif #if defined(ELOOP) && (!defined(ENOENT) || (ELOOP != ENOENT)) - case ELOOP: return "ELOOP"; + case ELOOP: return "ELOOP"; #endif #ifdef EMFILE - case EMFILE: return "EMFILE"; + case EMFILE: return "EMFILE"; #endif #ifdef EMLINK - case EMLINK: return "EMLINK"; + case EMLINK: return "EMLINK"; #endif #ifdef EMSGSIZE - case EMSGSIZE: return "EMSGSIZE"; + case EMSGSIZE: return "EMSGSIZE"; #endif #ifdef EMULTIHOP - case EMULTIHOP: return "EMULTIHOP"; + case EMULTIHOP: return "EMULTIHOP"; #endif #ifdef ENAMETOOLONG - case ENAMETOOLONG: return "ENAMETOOLONG"; + case ENAMETOOLONG: return "ENAMETOOLONG"; #endif #ifdef ENAVAIL - case ENAVAIL: return "ENAVAIL"; + case ENAVAIL: return "ENAVAIL"; #endif #ifdef ENET - case ENET: return "ENET"; + case ENET: return "ENET"; #endif #ifdef ENETDOWN - case ENETDOWN: return "ENETDOWN"; + case ENETDOWN: return "ENETDOWN"; #endif #ifdef ENETRESET - case ENETRESET: return "ENETRESET"; + case ENETRESET: return "ENETRESET"; #endif #ifdef ENETUNREACH - case ENETUNREACH: return "ENETUNREACH"; + case ENETUNREACH: return "ENETUNREACH"; #endif #ifdef ENFILE - case ENFILE: return "ENFILE"; + case ENFILE: return "ENFILE"; #endif #ifdef ENOANO - case ENOANO: return "ENOANO"; + case ENOANO: return "ENOANO"; #endif #if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR)) - case ENOBUFS: return "ENOBUFS"; + case ENOBUFS: return "ENOBUFS"; #endif #ifdef ENOCSI - case ENOCSI: return "ENOCSI"; + case ENOCSI: return "ENOCSI"; #endif #if defined(ENODATA) && (!defined(ECONNREFUSED) || (ENODATA != ECONNREFUSED)) - case ENODATA: return "ENODATA"; + case ENODATA: return "ENODATA"; #endif #ifdef ENODEV - case ENODEV: return "ENODEV"; + case ENODEV: return "ENODEV"; #endif #ifdef ENOENT - case ENOENT: return "ENOENT"; + case ENOENT: return "ENOENT"; #endif #ifdef ENOEXEC - case ENOEXEC: return "ENOEXEC"; + case ENOEXEC: return "ENOEXEC"; #endif #ifdef ENOLCK - case ENOLCK: return "ENOLCK"; + case ENOLCK: return "ENOLCK"; #endif #ifdef ENOLINK - case ENOLINK: return "ENOLINK"; + case ENOLINK: return "ENOLINK"; #endif #ifdef ENOMEM - case ENOMEM: return "ENOMEM"; + case ENOMEM: return "ENOMEM"; #endif #ifdef ENOMSG - case ENOMSG: return "ENOMSG"; + case ENOMSG: return "ENOMSG"; #endif #ifdef ENONET - case ENONET: return "ENONET"; + case ENONET: return "ENONET"; #endif #ifdef ENOPKG - case ENOPKG: return "ENOPKG"; + case ENOPKG: return "ENOPKG"; #endif #ifdef ENOPROTOOPT - case ENOPROTOOPT: return "ENOPROTOOPT"; + case ENOPROTOOPT: return "ENOPROTOOPT"; #endif #ifdef ENOSPC - case ENOSPC: return "ENOSPC"; + case ENOSPC: return "ENOSPC"; #endif #if defined(ENOSR) && (!defined(ENAMETOOLONG) || (ENAMETOOLONG != ENOSR)) - case ENOSR: return "ENOSR"; + case ENOSR: return "ENOSR"; #endif #if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR)) - case ENOSTR: return "ENOSTR"; + case ENOSTR: return "ENOSTR"; #endif #ifdef ENOSYM - case ENOSYM: return "ENOSYM"; + case ENOSYM: return "ENOSYM"; #endif #ifdef ENOSYS - case ENOSYS: return "ENOSYS"; + case ENOSYS: return "ENOSYS"; #endif #ifdef ENOTBLK - case ENOTBLK: return "ENOTBLK"; + case ENOTBLK: return "ENOTBLK"; #endif #ifdef ENOTCONN - case ENOTCONN: return "ENOTCONN"; + case ENOTCONN: return "ENOTCONN"; #endif #ifdef ENOTDIR - case ENOTDIR: return "ENOTDIR"; + case ENOTDIR: return "ENOTDIR"; #endif #if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST)) - case ENOTEMPTY: return "ENOTEMPTY"; + case ENOTEMPTY: return "ENOTEMPTY"; #endif #ifdef ENOTNAM - case ENOTNAM: return "ENOTNAM"; + case ENOTNAM: return "ENOTNAM"; #endif #ifdef ENOTSOCK - case ENOTSOCK: return "ENOTSOCK"; + case ENOTSOCK: return "ENOTSOCK"; #endif #ifdef ENOTSUP - case ENOTSUP: return "ENOTSUP"; + case ENOTSUP: return "ENOTSUP"; #endif #ifdef ENOTTY - case ENOTTY: return "ENOTTY"; + case ENOTTY: return "ENOTTY"; #endif #ifdef ENOTUNIQ - case ENOTUNIQ: return "ENOTUNIQ"; + case ENOTUNIQ: return "ENOTUNIQ"; #endif #ifdef ENXIO - case ENXIO: return "ENXIO"; + case ENXIO: return "ENXIO"; #endif #if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP)) - case EOPNOTSUPP: return "EOPNOTSUPP"; + case EOPNOTSUPP: return "EOPNOTSUPP"; #endif #if defined(EOVERFLOW) && ( !defined(EFBIG) || (EOVERFLOW != EFBIG) ) && ( !defined(EINVAL) || (EOVERFLOW != EINVAL) ) - case EOVERFLOW: return "EOVERFLOW"; + case EOVERFLOW: return "EOVERFLOW"; #endif #ifdef EPERM - case EPERM: return "EPERM"; + case EPERM: return "EPERM"; #endif #if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != EPFNOSUPPORT)) - case EPFNOSUPPORT: return "EPFNOSUPPORT"; + case EPFNOSUPPORT: return "EPFNOSUPPORT"; #endif #ifdef EPIPE - case EPIPE: return "EPIPE"; + case EPIPE: return "EPIPE"; #endif #ifdef EPROCLIM - case EPROCLIM: return "EPROCLIM"; + case EPROCLIM: return "EPROCLIM"; #endif #ifdef EPROCUNAVAIL - case EPROCUNAVAIL: return "EPROCUNAVAIL"; + case EPROCUNAVAIL: return "EPROCUNAVAIL"; #endif #ifdef EPROGMISMATCH - case EPROGMISMATCH: return "EPROGMISMATCH"; + case EPROGMISMATCH: return "EPROGMISMATCH"; #endif #ifdef EPROGUNAVAIL - case EPROGUNAVAIL: return "EPROGUNAVAIL"; + case EPROGUNAVAIL: return "EPROGUNAVAIL"; #endif #ifdef EPROTO - case EPROTO: return "EPROTO"; + case EPROTO: return "EPROTO"; #endif #ifdef EPROTONOSUPPORT - case EPROTONOSUPPORT: return "EPROTONOSUPPORT"; + case EPROTONOSUPPORT: return "EPROTONOSUPPORT"; #endif #ifdef EPROTOTYPE - case EPROTOTYPE: return "EPROTOTYPE"; + case EPROTOTYPE: return "EPROTOTYPE"; #endif #ifdef ERANGE - case ERANGE: return "ERANGE"; + case ERANGE: return "ERANGE"; #endif #if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED)) - case EREFUSED: return "EREFUSED"; + case EREFUSED: return "EREFUSED"; #endif #ifdef EREMCHG - case EREMCHG: return "EREMCHG"; + case EREMCHG: return "EREMCHG"; #endif #ifdef EREMDEV - case EREMDEV: return "EREMDEV"; + case EREMDEV: return "EREMDEV"; #endif #ifdef EREMOTE - case EREMOTE: return "EREMOTE"; + case EREMOTE: return "EREMOTE"; #endif #ifdef EREMOTEIO - case EREMOTEIO: return "EREMOTEIO"; + case EREMOTEIO: return "EREMOTEIO"; #endif #ifdef EREMOTERELEASE - case EREMOTERELEASE: return "EREMOTERELEASE"; + case EREMOTERELEASE: return "EREMOTERELEASE"; #endif #ifdef EROFS - case EROFS: return "EROFS"; + case EROFS: return "EROFS"; #endif #ifdef ERPCMISMATCH - case ERPCMISMATCH: return "ERPCMISMATCH"; + case ERPCMISMATCH: return "ERPCMISMATCH"; #endif #ifdef ERREMOTE - case ERREMOTE: return "ERREMOTE"; + case ERREMOTE: return "ERREMOTE"; #endif #ifdef ESHUTDOWN - case ESHUTDOWN: return "ESHUTDOWN"; + case ESHUTDOWN: return "ESHUTDOWN"; #endif #ifdef ESOCKTNOSUPPORT - case ESOCKTNOSUPPORT: return "ESOCKTNOSUPPORT"; + case ESOCKTNOSUPPORT: return "ESOCKTNOSUPPORT"; #endif #ifdef ESPIPE - case ESPIPE: return "ESPIPE"; + case ESPIPE: return "ESPIPE"; #endif #ifdef ESRCH - case ESRCH: return "ESRCH"; + case ESRCH: return "ESRCH"; #endif #ifdef ESRMNT - case ESRMNT: return "ESRMNT"; + case ESRMNT: return "ESRMNT"; #endif #ifdef ESTALE - case ESTALE: return "ESTALE"; + case ESTALE: return "ESTALE"; #endif #ifdef ESUCCESS - case ESUCCESS: return "ESUCCESS"; + case ESUCCESS: return "ESUCCESS"; #endif #if defined(ETIME) && (!defined(ELOOP) || (ETIME != ELOOP)) - case ETIME: return "ETIME"; + case ETIME: return "ETIME"; #endif #if defined(ETIMEDOUT) && (!defined(ENOSTR) || (ETIMEDOUT != ENOSTR)) - case ETIMEDOUT: return "ETIMEDOUT"; + case ETIMEDOUT: return "ETIMEDOUT"; #endif #ifdef ETOOMANYREFS - case ETOOMANYREFS: return "ETOOMANYREFS"; + case ETOOMANYREFS: return "ETOOMANYREFS"; #endif #ifdef ETXTBSY - case ETXTBSY: return "ETXTBSY"; + case ETXTBSY: return "ETXTBSY"; #endif #ifdef EUCLEAN - case EUCLEAN: return "EUCLEAN"; + case EUCLEAN: return "EUCLEAN"; #endif #ifdef EUNATCH - case EUNATCH: return "EUNATCH"; + case EUNATCH: return "EUNATCH"; #endif #ifdef EUSERS - case EUSERS: return "EUSERS"; + case EUSERS: return "EUSERS"; #endif #ifdef EVERSION - case EVERSION: return "EVERSION"; + case EVERSION: return "EVERSION"; #endif #if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN)) - case EWOULDBLOCK: return "EWOULDBLOCK"; + case EWOULDBLOCK: return "EWOULDBLOCK"; #endif #ifdef EXDEV - case EXDEV: return "EXDEV"; + case EXDEV: return "EXDEV"; #endif #ifdef EXFULL - case EXFULL: return "EXFULL"; + case EXFULL: return "EXFULL"; #endif } return "unknown error"; } @@ -462,456 +461,454 @@ /* *---------------------------------------------------------------------- * * Tcl_ErrnoMsg -- * - * Return a human-readable message corresponding to a given - * errno value. + * Return a human-readable message corresponding to a given errno value. * * Results: - * The return value is the standard POSIX error message for - * errno. This procedure is used instead of strerror because - * strerror returns slightly different values on different - * machines (e.g. different capitalizations), which cause - * problems for things such as regression tests. This procedure - * provides messages for most standard errors, then it calls - * strerror for things it doesn't understand. + * The return value is the standard POSIX error message for errno. This + * procedure is used instead of strerror because strerror returns + * slightly different values on different machines (e.g. different + * capitalizations), which cause problems for things such as regression + * tests. This procedure provides messages for most standard errors, then + * it calls strerror for things it doesn't understand. * * Side effects: * None. * *---------------------------------------------------------------------- */ CONST char * Tcl_ErrnoMsg(err) - int err; /* Error number (such as in errno variable). */ + int err; /* Error number (such as in errno variable). */ { switch (err) { #ifdef E2BIG - case E2BIG: return "argument list too long"; + case E2BIG: return "argument list too long"; #endif #ifdef EACCES - case EACCES: return "permission denied"; + case EACCES: return "permission denied"; #endif #ifdef EADDRINUSE - case EADDRINUSE: return "address already in use"; + case EADDRINUSE: return "address already in use"; #endif #ifdef EADDRNOTAVAIL - case EADDRNOTAVAIL: return "can't assign requested address"; + case EADDRNOTAVAIL: return "can't assign requested address"; #endif #ifdef EADV - case EADV: return "advertise error"; + case EADV: return "advertise error"; #endif #ifdef EAFNOSUPPORT - case EAFNOSUPPORT: return "address family not supported by protocol family"; + case EAFNOSUPPORT: return "address family not supported by protocol family"; #endif #ifdef EAGAIN - case EAGAIN: return "resource temporarily unavailable"; + case EAGAIN: return "resource temporarily unavailable"; #endif #ifdef EALIGN - case EALIGN: return "EALIGN"; + case EALIGN: return "EALIGN"; #endif #if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY )) - case EALREADY: return "operation already in progress"; + case EALREADY: return "operation already in progress"; #endif #ifdef EBADE - case EBADE: return "bad exchange descriptor"; + case EBADE: return "bad exchange descriptor"; #endif #ifdef EBADF - case EBADF: return "bad file number"; + case EBADF: return "bad file number"; #endif #ifdef EBADFD - case EBADFD: return "file descriptor in bad state"; + case EBADFD: return "file descriptor in bad state"; #endif #ifdef EBADMSG - case EBADMSG: return "not a data message"; + case EBADMSG: return "not a data message"; #endif #ifdef EBADR - case EBADR: return "bad request descriptor"; + case EBADR: return "bad request descriptor"; #endif #ifdef EBADRPC - case EBADRPC: return "RPC structure is bad"; + case EBADRPC: return "RPC structure is bad"; #endif #ifdef EBADRQC - case EBADRQC: return "bad request code"; + case EBADRQC: return "bad request code"; #endif #ifdef EBADSLT - case EBADSLT: return "invalid slot"; + case EBADSLT: return "invalid slot"; #endif #ifdef EBFONT - case EBFONT: return "bad font file format"; + case EBFONT: return "bad font file format"; #endif #ifdef EBUSY - case EBUSY: return "file busy"; + case EBUSY: return "file busy"; #endif #ifdef ECHILD - case ECHILD: return "no children"; + case ECHILD: return "no children"; #endif #ifdef ECHRNG - case ECHRNG: return "channel number out of range"; + case ECHRNG: return "channel number out of range"; #endif #ifdef ECOMM - case ECOMM: return "communication error on send"; + case ECOMM: return "communication error on send"; #endif #ifdef ECONNABORTED - case ECONNABORTED: return "software caused connection abort"; + case ECONNABORTED: return "software caused connection abort"; #endif #ifdef ECONNREFUSED - case ECONNREFUSED: return "connection refused"; + case ECONNREFUSED: return "connection refused"; #endif #ifdef ECONNRESET - case ECONNRESET: return "connection reset by peer"; + case ECONNRESET: return "connection reset by peer"; #endif #if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK)) - case EDEADLK: return "resource deadlock avoided"; + case EDEADLK: return "resource deadlock avoided"; #endif #if defined(EDEADLOCK) && (!defined(EDEADLK) || (EDEADLOCK != EDEADLK)) - case EDEADLOCK: return "resource deadlock avoided"; + case EDEADLOCK: return "resource deadlock avoided"; #endif #ifdef EDESTADDRREQ - case EDESTADDRREQ: return "destination address required"; + case EDESTADDRREQ: return "destination address required"; #endif #ifdef EDIRTY - case EDIRTY: return "mounting a dirty fs w/o force"; + case EDIRTY: return "mounting a dirty fs w/o force"; #endif #ifdef EDOM - case EDOM: return "math argument out of range"; + case EDOM: return "math argument out of range"; #endif #ifdef EDOTDOT - case EDOTDOT: return "cross mount point"; + case EDOTDOT: return "cross mount point"; #endif #ifdef EDQUOT - case EDQUOT: return "disk quota exceeded"; + case EDQUOT: return "disk quota exceeded"; #endif #ifdef EDUPPKG - case EDUPPKG: return "duplicate package name"; + case EDUPPKG: return "duplicate package name"; #endif #ifdef EEXIST - case EEXIST: return "file already exists"; + case EEXIST: return "file already exists"; #endif #ifdef EFAULT - case EFAULT: return "bad address in system call argument"; + case EFAULT: return "bad address in system call argument"; #endif #ifdef EFBIG - case EFBIG: return "file too large"; + case EFBIG: return "file too large"; #endif #ifdef EHOSTDOWN - case EHOSTDOWN: return "host is down"; + case EHOSTDOWN: return "host is down"; #endif #ifdef EHOSTUNREACH - case EHOSTUNREACH: return "host is unreachable"; + case EHOSTUNREACH: return "host is unreachable"; #endif #if defined(EIDRM) && (!defined(EINPROGRESS) || (EIDRM != EINPROGRESS)) - case EIDRM: return "identifier removed"; + case EIDRM: return "identifier removed"; #endif #ifdef EINIT - case EINIT: return "initialization error"; + case EINIT: return "initialization error"; #endif #ifdef EINPROGRESS - case EINPROGRESS: return "operation now in progress"; + case EINPROGRESS: return "operation now in progress"; #endif #ifdef EINTR - case EINTR: return "interrupted system call"; + case EINTR: return "interrupted system call"; #endif #ifdef EINVAL - case EINVAL: return "invalid argument"; + case EINVAL: return "invalid argument"; #endif #ifdef EIO - case EIO: return "I/O error"; + case EIO: return "I/O error"; #endif #ifdef EISCONN - case EISCONN: return "socket is already connected"; + case EISCONN: return "socket is already connected"; #endif #ifdef EISDIR - case EISDIR: return "illegal operation on a directory"; + case EISDIR: return "illegal operation on a directory"; #endif #ifdef EISNAME - case EISNAM: return "is a name file"; + case EISNAM: return "is a name file"; #endif #ifdef ELBIN - case ELBIN: return "ELBIN"; + case ELBIN: return "ELBIN"; #endif #ifdef EL2HLT - case EL2HLT: return "level 2 halted"; + case EL2HLT: return "level 2 halted"; #endif #ifdef EL2NSYNC - case EL2NSYNC: return "level 2 not synchronized"; + case EL2NSYNC: return "level 2 not synchronized"; #endif #ifdef EL3HLT - case EL3HLT: return "level 3 halted"; + case EL3HLT: return "level 3 halted"; #endif #ifdef EL3RST - case EL3RST: return "level 3 reset"; + case EL3RST: return "level 3 reset"; #endif #ifdef ELIBACC - case ELIBACC: return "can not access a needed shared library"; + case ELIBACC: return "can not access a needed shared library"; #endif #ifdef ELIBBAD - case ELIBBAD: return "accessing a corrupted shared library"; + case ELIBBAD: return "accessing a corrupted shared library"; #endif #ifdef ELIBEXEC - case ELIBEXEC: return "can not exec a shared library directly"; + case ELIBEXEC: return "can not exec a shared library directly"; #endif #ifdef ELIBMAX - case ELIBMAX: return - "attempting to link in more shared libraries than system limit"; + case ELIBMAX: return + "attempting to link in more shared libraries than system limit"; #endif #ifdef ELIBSCN - case ELIBSCN: return ".lib section in a.out corrupted"; + case ELIBSCN: return ".lib section in a.out corrupted"; #endif #ifdef ELNRNG - case ELNRNG: return "link number out of range"; + case ELNRNG: return "link number out of range"; #endif #if defined(ELOOP) && (!defined(ENOENT) || (ELOOP != ENOENT)) - case ELOOP: return "too many levels of symbolic links"; + case ELOOP: return "too many levels of symbolic links"; #endif #ifdef EMFILE - case EMFILE: return "too many open files"; + case EMFILE: return "too many open files"; #endif #ifdef EMLINK - case EMLINK: return "too many links"; + case EMLINK: return "too many links"; #endif #ifdef EMSGSIZE - case EMSGSIZE: return "message too long"; + case EMSGSIZE: return "message too long"; #endif #ifdef EMULTIHOP - case EMULTIHOP: return "multihop attempted"; + case EMULTIHOP: return "multihop attempted"; #endif #ifdef ENAMETOOLONG - case ENAMETOOLONG: return "file name too long"; + case ENAMETOOLONG: return "file name too long"; #endif #ifdef ENAVAIL - case ENAVAIL: return "not available"; + case ENAVAIL: return "not available"; #endif #ifdef ENET - case ENET: return "ENET"; + case ENET: return "ENET"; #endif #ifdef ENETDOWN - case ENETDOWN: return "network is down"; + case ENETDOWN: return "network is down"; #endif #ifdef ENETRESET - case ENETRESET: return "network dropped connection on reset"; + case ENETRESET: return "network dropped connection on reset"; #endif #ifdef ENETUNREACH - case ENETUNREACH: return "network is unreachable"; + case ENETUNREACH: return "network is unreachable"; #endif #ifdef ENFILE - case ENFILE: return "file table overflow"; + case ENFILE: return "file table overflow"; #endif #ifdef ENOANO - case ENOANO: return "anode table overflow"; + case ENOANO: return "anode table overflow"; #endif #if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR)) - case ENOBUFS: return "no buffer space available"; + case ENOBUFS: return "no buffer space available"; #endif #ifdef ENOCSI - case ENOCSI: return "no CSI structure available"; + case ENOCSI: return "no CSI structure available"; #endif #if defined(ENODATA) && (!defined(ECONNREFUSED) || (ENODATA != ECONNREFUSED)) - case ENODATA: return "no data available"; + case ENODATA: return "no data available"; #endif #ifdef ENODEV - case ENODEV: return "no such device"; + case ENODEV: return "no such device"; #endif #ifdef ENOENT - case ENOENT: return "no such file or directory"; + case ENOENT: return "no such file or directory"; #endif #ifdef ENOEXEC - case ENOEXEC: return "exec format error"; + case ENOEXEC: return "exec format error"; #endif #ifdef ENOLCK - case ENOLCK: return "no locks available"; + case ENOLCK: return "no locks available"; #endif #ifdef ENOLINK - case ENOLINK: return "link has be severed"; + case ENOLINK: return "link has be severed"; #endif #ifdef ENOMEM - case ENOMEM: return "not enough memory"; + case ENOMEM: return "not enough memory"; #endif #ifdef ENOMSG - case ENOMSG: return "no message of desired type"; + case ENOMSG: return "no message of desired type"; #endif #ifdef ENONET - case ENONET: return "machine is not on the network"; + case ENONET: return "machine is not on the network"; #endif #ifdef ENOPKG - case ENOPKG: return "package not installed"; + case ENOPKG: return "package not installed"; #endif #ifdef ENOPROTOOPT - case ENOPROTOOPT: return "bad protocol option"; + case ENOPROTOOPT: return "bad protocol option"; #endif #ifdef ENOSPC - case ENOSPC: return "no space left on device"; + case ENOSPC: return "no space left on device"; #endif #if defined(ENOSR) && (!defined(ENAMETOOLONG) || (ENAMETOOLONG != ENOSR)) - case ENOSR: return "out of stream resources"; + case ENOSR: return "out of stream resources"; #endif #if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR)) - case ENOSTR: return "not a stream device"; + case ENOSTR: return "not a stream device"; #endif #ifdef ENOSYM - case ENOSYM: return "unresolved symbol name"; + case ENOSYM: return "unresolved symbol name"; #endif #ifdef ENOSYS - case ENOSYS: return "function not implemented"; + case ENOSYS: return "function not implemented"; #endif #ifdef ENOTBLK - case ENOTBLK: return "block device required"; + case ENOTBLK: return "block device required"; #endif #ifdef ENOTCONN - case ENOTCONN: return "socket is not connected"; + case ENOTCONN: return "socket is not connected"; #endif #ifdef ENOTDIR - case ENOTDIR: return "not a directory"; + case ENOTDIR: return "not a directory"; #endif #if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST)) - case ENOTEMPTY: return "directory not empty"; + case ENOTEMPTY: return "directory not empty"; #endif #ifdef ENOTNAM - case ENOTNAM: return "not a name file"; + case ENOTNAM: return "not a name file"; #endif #ifdef ENOTSOCK - case ENOTSOCK: return "socket operation on non-socket"; + case ENOTSOCK: return "socket operation on non-socket"; #endif #ifdef ENOTSUP - case ENOTSUP: return "operation not supported"; + case ENOTSUP: return "operation not supported"; #endif #ifdef ENOTTY - case ENOTTY: return "inappropriate device for ioctl"; + case ENOTTY: return "inappropriate device for ioctl"; #endif #ifdef ENOTUNIQ - case ENOTUNIQ: return "name not unique on network"; + case ENOTUNIQ: return "name not unique on network"; #endif #ifdef ENXIO - case ENXIO: return "no such device or address"; + case ENXIO: return "no such device or address"; #endif #if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP)) - case EOPNOTSUPP: return "operation not supported on socket"; + case EOPNOTSUPP: return "operation not supported on socket"; #endif #if defined(EOVERFLOW) && ( !defined(EFBIG) || (EOVERFLOW != EFBIG) ) && ( !defined(EINVAL) || (EOVERFLOW != EINVAL) ) - case EOVERFLOW: return "file too big"; + case EOVERFLOW: return "file too big"; #endif #ifdef EPERM - case EPERM: return "not owner"; + case EPERM: return "not owner"; #endif #if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != EPFNOSUPPORT)) - case EPFNOSUPPORT: return "protocol family not supported"; + case EPFNOSUPPORT: return "protocol family not supported"; #endif #ifdef EPIPE - case EPIPE: return "broken pipe"; + case EPIPE: return "broken pipe"; #endif #ifdef EPROCLIM - case EPROCLIM: return "too many processes"; + case EPROCLIM: return "too many processes"; #endif #ifdef EPROCUNAVAIL - case EPROCUNAVAIL: return "bad procedure for program"; + case EPROCUNAVAIL: return "bad procedure for program"; #endif #ifdef EPROGMISMATCH - case EPROGMISMATCH: return "program version wrong"; + case EPROGMISMATCH: return "program version wrong"; #endif #ifdef EPROGUNAVAIL - case EPROGUNAVAIL: return "RPC program not available"; + case EPROGUNAVAIL: return "RPC program not available"; #endif #ifdef EPROTO - case EPROTO: return "protocol error"; + case EPROTO: return "protocol error"; #endif #ifdef EPROTONOSUPPORT - case EPROTONOSUPPORT: return "protocol not suppored"; + case EPROTONOSUPPORT: return "protocol not suppored"; #endif #ifdef EPROTOTYPE - case EPROTOTYPE: return "protocol wrong type for socket"; + case EPROTOTYPE: return "protocol wrong type for socket"; #endif #ifdef ERANGE - case ERANGE: return "math result unrepresentable"; + case ERANGE: return "math result unrepresentable"; #endif #if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED)) - case EREFUSED: return "EREFUSED"; + case EREFUSED: return "EREFUSED"; #endif #ifdef EREMCHG - case EREMCHG: return "remote address changed"; + case EREMCHG: return "remote address changed"; #endif #ifdef EREMDEV - case EREMDEV: return "remote device"; + case EREMDEV: return "remote device"; #endif #ifdef EREMOTE - case EREMOTE: return "pathname hit remote file system"; + case EREMOTE: return "pathname hit remote file system"; #endif #ifdef EREMOTEIO - case EREMOTEIO: return "remote i/o error"; + case EREMOTEIO: return "remote i/o error"; #endif #ifdef EREMOTERELEASE - case EREMOTERELEASE: return "EREMOTERELEASE"; + case EREMOTERELEASE: return "EREMOTERELEASE"; #endif #ifdef EROFS - case EROFS: return "read-only file system"; + case EROFS: return "read-only file system"; #endif #ifdef ERPCMISMATCH - case ERPCMISMATCH: return "RPC version is wrong"; + case ERPCMISMATCH: return "RPC version is wrong"; #endif #ifdef ERREMOTE - case ERREMOTE: return "object is remote"; + case ERREMOTE: return "object is remote"; #endif #ifdef ESHUTDOWN - case ESHUTDOWN: return "can't send afer socket shutdown"; + case ESHUTDOWN: return "can't send afer socket shutdown"; #endif #ifdef ESOCKTNOSUPPORT - case ESOCKTNOSUPPORT: return "socket type not supported"; + case ESOCKTNOSUPPORT: return "socket type not supported"; #endif #ifdef ESPIPE - case ESPIPE: return "invalid seek"; + case ESPIPE: return "invalid seek"; #endif #ifdef ESRCH - case ESRCH: return "no such process"; + case ESRCH: return "no such process"; #endif #ifdef ESRMNT - case ESRMNT: return "srmount error"; + case ESRMNT: return "srmount error"; #endif #ifdef ESTALE - case ESTALE: return "stale remote file handle"; + case ESTALE: return "stale remote file handle"; #endif #ifdef ESUCCESS - case ESUCCESS: return "Error 0"; + case ESUCCESS: return "Error 0"; #endif #if defined(ETIME) && (!defined(ELOOP) || (ETIME != ELOOP)) - case ETIME: return "timer expired"; + case ETIME: return "timer expired"; #endif #if defined(ETIMEDOUT) && (!defined(ENOSTR) || (ETIMEDOUT != ENOSTR)) - case ETIMEDOUT: return "connection timed out"; + case ETIMEDOUT: return "connection timed out"; #endif #ifdef ETOOMANYREFS - case ETOOMANYREFS: return "too many references: can't splice"; + case ETOOMANYREFS: return "too many references: can't splice"; #endif #ifdef ETXTBSY - case ETXTBSY: return "text file or pseudo-device busy"; + case ETXTBSY: return "text file or pseudo-device busy"; #endif #ifdef EUCLEAN - case EUCLEAN: return "structure needs cleaning"; + case EUCLEAN: return "structure needs cleaning"; #endif #ifdef EUNATCH - case EUNATCH: return "protocol driver not attached"; + case EUNATCH: return "protocol driver not attached"; #endif #ifdef EUSERS - case EUSERS: return "too many users"; + case EUSERS: return "too many users"; #endif #ifdef EVERSION - case EVERSION: return "version mismatch"; + case EVERSION: return "version mismatch"; #endif #if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN)) - case EWOULDBLOCK: return "operation would block"; + case EWOULDBLOCK: return "operation would block"; #endif #ifdef EXDEV - case EXDEV: return "cross-domain link"; + case EXDEV: return "cross-domain link"; #endif #ifdef EXFULL - case EXFULL: return "message tables full"; + case EXFULL: return "message tables full"; #endif - default: + default: #ifdef NO_STRERROR - return "unknown POSIX error"; + return "unknown POSIX error"; #else - return strerror(errno); + return strerror(errno); #endif } } /* @@ -920,129 +917,129 @@ * Tcl_SignalId -- * * Return a textual identifier for a signal number. * * Results: - * This procedure returns a machine-readable textual identifier - * that corresponds to sig. The identifier is the same as the - * #define name in signal.h. + * This procedure returns a machine-readable textual identifier that + * corresponds to sig. The identifier is the same as the #define name in + * signal.h. * * Side effects: * None. * *---------------------------------------------------------------------- */ CONST char * Tcl_SignalId(sig) - int sig; /* Number of signal. */ + int sig; /* Number of signal. */ { switch (sig) { #ifdef SIGABRT - case SIGABRT: return "SIGABRT"; + case SIGABRT: return "SIGABRT"; #endif #ifdef SIGALRM - case SIGALRM: return "SIGALRM"; + case SIGALRM: return "SIGALRM"; #endif #ifdef SIGBUS - case SIGBUS: return "SIGBUS"; + case SIGBUS: return "SIGBUS"; #endif #ifdef SIGCHLD - case SIGCHLD: return "SIGCHLD"; + case SIGCHLD: return "SIGCHLD"; #endif #if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD)) - case SIGCLD: return "SIGCLD"; + case SIGCLD: return "SIGCLD"; #endif #ifdef SIGCONT - case SIGCONT: return "SIGCONT"; + case SIGCONT: return "SIGCONT"; #endif #if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU)) - case SIGEMT: return "SIGEMT"; + case SIGEMT: return "SIGEMT"; #endif #ifdef SIGFPE - case SIGFPE: return "SIGFPE"; + case SIGFPE: return "SIGFPE"; #endif #ifdef SIGHUP - case SIGHUP: return "SIGHUP"; + case SIGHUP: return "SIGHUP"; #endif #ifdef SIGILL - case SIGILL: return "SIGILL"; + case SIGILL: return "SIGILL"; #endif #ifdef SIGINT - case SIGINT: return "SIGINT"; + case SIGINT: return "SIGINT"; #endif #ifdef SIGIO - case SIGIO: return "SIGIO"; + case SIGIO: return "SIGIO"; #endif #if defined(SIGIOT) && (!defined(SIGABRT) || (SIGIOT != SIGABRT)) - case SIGIOT: return "SIGIOT"; + case SIGIOT: return "SIGIOT"; #endif #ifdef SIGKILL - case SIGKILL: return "SIGKILL"; + case SIGKILL: return "SIGKILL"; #endif #if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) && (!defined(SIGPROF) || (SIGLOST != SIGPROF)) && (!defined(SIGIO) || (SIGLOST != SIGIO)) - case SIGLOST: return "SIGLOST"; + case SIGLOST: return "SIGLOST"; #endif #ifdef SIGPIPE - case SIGPIPE: return "SIGPIPE"; + case SIGPIPE: return "SIGPIPE"; #endif #if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO)) - case SIGPOLL: return "SIGPOLL"; + case SIGPOLL: return "SIGPOLL"; #endif #ifdef SIGPROF - case SIGPROF: return "SIGPROF"; + case SIGPROF: return "SIGPROF"; #endif #if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) && (!defined(SIGLOST) || (SIGPWR != SIGLOST)) - case SIGPWR: return "SIGPWR"; + case SIGPWR: return "SIGPWR"; #endif #ifdef SIGQUIT - case SIGQUIT: return "SIGQUIT"; + case SIGQUIT: return "SIGQUIT"; #endif #ifdef SIGSEGV - case SIGSEGV: return "SIGSEGV"; + case SIGSEGV: return "SIGSEGV"; #endif #ifdef SIGSTOP - case SIGSTOP: return "SIGSTOP"; + case SIGSTOP: return "SIGSTOP"; #endif #ifdef SIGSYS - case SIGSYS: return "SIGSYS"; + case SIGSYS: return "SIGSYS"; #endif #ifdef SIGTERM - case SIGTERM: return "SIGTERM"; + case SIGTERM: return "SIGTERM"; #endif #ifdef SIGTRAP - case SIGTRAP: return "SIGTRAP"; + case SIGTRAP: return "SIGTRAP"; #endif #ifdef SIGTSTP - case SIGTSTP: return "SIGTSTP"; + case SIGTSTP: return "SIGTSTP"; #endif #ifdef SIGTTIN - case SIGTTIN: return "SIGTTIN"; + case SIGTTIN: return "SIGTTIN"; #endif #ifdef SIGTTOU - case SIGTTOU: return "SIGTTOU"; + case SIGTTOU: return "SIGTTOU"; #endif #if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO)) - case SIGURG: return "SIGURG"; + case SIGURG: return "SIGURG"; #endif #if defined(SIGUSR1) && (!defined(SIGIO) || (SIGUSR1 != SIGIO)) - case SIGUSR1: return "SIGUSR1"; + case SIGUSR1: return "SIGUSR1"; #endif #if defined(SIGUSR2) && (!defined(SIGURG) || (SIGUSR2 != SIGURG)) - case SIGUSR2: return "SIGUSR2"; + case SIGUSR2: return "SIGUSR2"; #endif #ifdef SIGVTALRM - case SIGVTALRM: return "SIGVTALRM"; + case SIGVTALRM: return "SIGVTALRM"; #endif #ifdef SIGWINCH - case SIGWINCH: return "SIGWINCH"; + case SIGWINCH: return "SIGWINCH"; #endif #ifdef SIGXCPU - case SIGXCPU: return "SIGXCPU"; + case SIGXCPU: return "SIGXCPU"; #endif #ifdef SIGXFSZ - case SIGXFSZ: return "SIGXFSZ"; + case SIGXFSZ: return "SIGXFSZ"; #endif } return "unknown signal"; } @@ -1052,128 +1049,135 @@ * Tcl_SignalMsg -- * * Return a human-readable message describing a signal. * * Results: - * This procedure returns a string describing sig that should - * make sense to a human. It may not be easy for a machine - * to parse. + * This procedure returns a string describing sig that should make sense + * to a human. It may not be easy for a machine to parse. * * Side effects: * None. * *---------------------------------------------------------------------- */ CONST char * Tcl_SignalMsg(sig) - int sig; /* Number of signal. */ + int sig; /* Number of signal. */ { switch (sig) { #ifdef SIGABRT - case SIGABRT: return "SIGABRT"; + case SIGABRT: return "SIGABRT"; #endif #ifdef SIGALRM - case SIGALRM: return "alarm clock"; + case SIGALRM: return "alarm clock"; #endif #ifdef SIGBUS - case SIGBUS: return "bus error"; + case SIGBUS: return "bus error"; #endif #ifdef SIGCHLD - case SIGCHLD: return "child status changed"; + case SIGCHLD: return "child status changed"; #endif #if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD)) - case SIGCLD: return "child status changed"; + case SIGCLD: return "child status changed"; #endif #ifdef SIGCONT - case SIGCONT: return "continue after stop"; + case SIGCONT: return "continue after stop"; #endif #if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU)) - case SIGEMT: return "EMT instruction"; + case SIGEMT: return "EMT instruction"; #endif #ifdef SIGFPE - case SIGFPE: return "floating-point exception"; + case SIGFPE: return "floating-point exception"; #endif #ifdef SIGHUP - case SIGHUP: return "hangup"; + case SIGHUP: return "hangup"; #endif #ifdef SIGILL - case SIGILL: return "illegal instruction"; + case SIGILL: return "illegal instruction"; #endif #ifdef SIGINT - case SIGINT: return "interrupt"; + case SIGINT: return "interrupt"; #endif #ifdef SIGIO - case SIGIO: return "input/output possible on file"; + case SIGIO: return "input/output possible on file"; #endif #if defined(SIGIOT) && (!defined(SIGABRT) || (SIGABRT != SIGIOT)) - case SIGIOT: return "IOT instruction"; + case SIGIOT: return "IOT instruction"; #endif #ifdef SIGKILL - case SIGKILL: return "kill signal"; + case SIGKILL: return "kill signal"; #endif #if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) && (!defined(SIGPROF) || (SIGLOST != SIGPROF)) && (!defined(SIGIO) || (SIGLOST != SIGIO)) - case SIGLOST: return "resource lost"; + case SIGLOST: return "resource lost"; #endif #ifdef SIGPIPE - case SIGPIPE: return "write on pipe with no readers"; + case SIGPIPE: return "write on pipe with no readers"; #endif #if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO)) - case SIGPOLL: return "input/output possible on file"; + case SIGPOLL: return "input/output possible on file"; #endif #ifdef SIGPROF - case SIGPROF: return "profiling alarm"; + case SIGPROF: return "profiling alarm"; #endif #if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) && (!defined(SIGLOST) || (SIGPWR != SIGLOST)) - case SIGPWR: return "power-fail restart"; + case SIGPWR: return "power-fail restart"; #endif #ifdef SIGQUIT - case SIGQUIT: return "quit signal"; + case SIGQUIT: return "quit signal"; #endif #ifdef SIGSEGV - case SIGSEGV: return "segmentation violation"; + case SIGSEGV: return "segmentation violation"; #endif #ifdef SIGSTOP - case SIGSTOP: return "stop"; + case SIGSTOP: return "stop"; #endif #ifdef SIGSYS - case SIGSYS: return "bad argument to system call"; + case SIGSYS: return "bad argument to system call"; #endif #ifdef SIGTERM - case SIGTERM: return "software termination signal"; + case SIGTERM: return "software termination signal"; #endif #ifdef SIGTRAP - case SIGTRAP: return "trace trap"; + case SIGTRAP: return "trace trap"; #endif #ifdef SIGTSTP - case SIGTSTP: return "stop signal from tty"; + case SIGTSTP: return "stop signal from tty"; #endif #ifdef SIGTTIN - case SIGTTIN: return "background tty read"; + case SIGTTIN: return "background tty read"; #endif #ifdef SIGTTOU - case SIGTTOU: return "background tty write"; + case SIGTTOU: return "background tty write"; #endif #if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO)) - case SIGURG: return "urgent I/O condition"; + case SIGURG: return "urgent I/O condition"; #endif #if defined(SIGUSR1) && (!defined(SIGIO) || (SIGUSR1 != SIGIO)) - case SIGUSR1: return "user-defined signal 1"; + case SIGUSR1: return "user-defined signal 1"; #endif #if defined(SIGUSR2) && (!defined(SIGURG) || (SIGUSR2 != SIGURG)) - case SIGUSR2: return "user-defined signal 2"; + case SIGUSR2: return "user-defined signal 2"; #endif #ifdef SIGVTALRM - case SIGVTALRM: return "virtual time alarm"; + case SIGVTALRM: return "virtual time alarm"; #endif #ifdef SIGWINCH - case SIGWINCH: return "window changed"; + case SIGWINCH: return "window changed"; #endif #ifdef SIGXCPU - case SIGXCPU: return "exceeded CPU time limit"; + case SIGXCPU: return "exceeded CPU time limit"; #endif #ifdef SIGXFSZ - case SIGXFSZ: return "exceeded file size limit"; + case SIGXFSZ: return "exceeded file size limit"; #endif } return "unknown signal"; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclPreserve.c ================================================================== --- generic/tclPreserve.c +++ generic/tclPreserve.c @@ -1,84 +1,80 @@ -/* +/* * tclPreserve.c -- * - * This file contains a collection of procedures that are used - * to make sure that widget records and other data structures - * aren't reallocated when there are nested procedures that - * depend on their existence. + * This file contains a collection of functions that are used to make + * sure that widget records and other data structures aren't reallocated + * when there are nested functions that depend on their existence. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPreserve.c,v 1.5 2003/12/24 04:18:20 davygrvy Exp $ + * RCS: @(#) $Id: tclPreserve.c,v 1.5.2.2 2005/08/02 18:16:07 dgp Exp $ */ #include "tclInt.h" /* - * The following data structure is used to keep track of all the - * Tcl_Preserve calls that are still in effect. It grows as needed - * to accommodate any number of calls in effect. + * The following data structure is used to keep track of all the Tcl_Preserve + * calls that are still in effect. It grows as needed to accommodate any + * number of calls in effect. */ typedef struct { ClientData clientData; /* Address of preserved block. */ - int refCount; /* Number of Tcl_Preserve calls in effect - * for block. */ + int refCount; /* Number of Tcl_Preserve calls in effect for + * block. */ int mustFree; /* Non-zero means Tcl_EventuallyFree was * called while a Tcl_Preserve call was in - * effect, so the structure must be freed - * when refCount becomes zero. */ - Tcl_FreeProc *freeProc; /* Procedure to call to free. */ + * effect, so the structure must be freed when + * refCount becomes zero. */ + Tcl_FreeProc *freeProc; /* Function to call to free. */ } Reference; +/* + * Global data structures used to hold the list of preserved data references. + * These variables are protected by "preserveMutex". + */ + static Reference *refArray; /* First in array of references. */ -static int spaceAvl = 0; /* Total number of structures available - * at *firstRefPtr. */ -static int inUse = 0; /* Count of structures currently in use - * in refArray. */ -#define INITIAL_SIZE 2 +static int spaceAvl = 0; /* Total number of structures available at + * *firstRefPtr. */ +static int inUse = 0; /* Count of structures currently in use in + * refArray. */ TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */ +#define INITIAL_SIZE 2 /* Initial number of reference slots to make */ + /* - * The following data structure is used to keep track of whether an - * arbitrary block of memory has been deleted. This is used by the - * TclHandle code to avoid the more time-expensive algorithm of - * Tcl_Preserve(). This mechanism is mainly used when we have lots of - * references to a few big, expensive objects that we don't want to live - * any longer than necessary. + * The following data structure is used to keep track of whether an arbitrary + * block of memory has been deleted. This is used by the TclHandle code to + * avoid the more time-expensive algorithm of Tcl_Preserve(). This mechanism + * is mainly used when we have lots of references to a few big, expensive + * objects that we don't want to live any longer than necessary. */ typedef struct HandleStruct { - VOID *ptr; /* Pointer to the memory block being - * tracked. This field will become NULL when - * the memory block is deleted. This field - * must be the first in the structure. */ + VOID *ptr; /* Pointer to the memory block being tracked. + * This field will become NULL when the memory + * block is deleted. This field must be the + * first in the structure. */ #ifdef TCL_MEM_DEBUG - VOID *ptr2; /* Backup copy of the abpve pointer used to + VOID *ptr2; /* Backup copy of the above pointer used to * ensure that the contents of the handle are * not changed by anyone else. */ #endif int refCount; /* Number of TclHandlePreserve() calls in * effect on this handle. */ } HandleStruct; - - -/* - * Static routines in this file: - */ - -static void PreserveExitProc _ANSI_ARGS_((ClientData clientData)); - /* *---------------------------------------------------------------------- * - * PreserveExitProc -- + * TclFinalizePreserve -- * * Called during exit processing to clean up the reference array. * * Results: * None. @@ -88,13 +84,12 @@ * *---------------------------------------------------------------------- */ /* ARGSUSED */ -static void -PreserveExitProc(clientData) - ClientData clientData; /* NULL -Unused. */ +void +TclFinalizePreserve() { Tcl_MutexLock(&preserveMutex); if (spaceAvl != 0) { ckfree((char *) refArray); refArray = (Reference *) NULL; @@ -107,20 +102,20 @@ /* *---------------------------------------------------------------------- * * Tcl_Preserve -- * - * This procedure is used by a procedure to declare its interest - * in a particular block of memory, so that the block will not be - * reallocated until a matching call to Tcl_Release has been made. + * This function is used by a function to declare its interest in a + * particular block of memory, so that the block will not be reallocated + * until a matching call to Tcl_Release has been made. * * Results: * None. * * Side effects: - * Information is retained so that the block of memory will - * not be freed until at least the matching call to Tcl_Release. + * Information is retained so that the block of memory will not be freed + * until at least the matching call to Tcl_Release. * *---------------------------------------------------------------------- */ void @@ -129,32 +124,30 @@ { Reference *refPtr; int i; /* - * See if there is already a reference for this pointer. If so, - * just increment its reference count. + * See if there is already a reference for this pointer. If so, just + * increment its reference count. */ Tcl_MutexLock(&preserveMutex); - for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) { + for (i=0, refPtr=refArray ; iclientData == clientData) { refPtr->refCount++; Tcl_MutexUnlock(&preserveMutex); return; } } /* - * Make a reference array if it doesn't already exist, or make it - * bigger if it is full. + * Make a reference array if it doesn't already exist, or make it bigger + * if it is full. */ if (inUse == spaceAvl) { if (spaceAvl == 0) { - Tcl_CreateExitHandler((Tcl_ExitProc *) PreserveExitProc, - (ClientData) NULL); refArray = (Reference *) ckalloc((unsigned) (INITIAL_SIZE*sizeof(Reference))); spaceAvl = INITIAL_SIZE; } else { Reference *new; @@ -185,72 +178,80 @@ /* *---------------------------------------------------------------------- * * Tcl_Release -- * - * This procedure is called to cancel a previous call to - * Tcl_Preserve, thereby allowing a block of memory to be - * freed (if no one else cares about it). + * This function is called to cancel a previous call to Tcl_Preserve, + * thereby allowing a block of memory to be freed (if no one else cares + * about it). * * Results: * None. * * Side effects: - * If Tcl_EventuallyFree has been called for clientData, and if - * no other call to Tcl_Preserve is still in effect, the block of - * memory is freed. + * If Tcl_EventuallyFree has been called for clientData, and if no other + * call to Tcl_Preserve is still in effect, the block of memory is freed. * *---------------------------------------------------------------------- */ void Tcl_Release(clientData) ClientData clientData; /* Pointer to malloc'ed block of memory. */ { Reference *refPtr; - int mustFree; - Tcl_FreeProc *freeProc; - int i; - - Tcl_MutexLock(&preserveMutex); - for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) { - if (refPtr->clientData != clientData) { - continue; - } - refPtr->refCount--; - if (refPtr->refCount == 0) { - - /* - * Must remove information from the slot before calling freeProc - * to avoid reentrancy problems if the freeProc calls Tcl_Preserve - * on the same clientData. Copy down the last reference in the - * array to overwrite the current slot. - */ - - freeProc = refPtr->freeProc; - mustFree = refPtr->mustFree; - inUse--; - if (i < inUse) { - refArray[i] = refArray[inUse]; - } - if (mustFree) { - if (freeProc == TCL_DYNAMIC) { - ckfree((char *) clientData); - } else { - Tcl_MutexUnlock(&preserveMutex); - (*freeProc)((char *) clientData); - return; - } - } - } - Tcl_MutexUnlock(&preserveMutex); - return; - } - Tcl_MutexUnlock(&preserveMutex); - - /* - * Reference not found. This is a bug in the caller. + int i; + + Tcl_MutexLock(&preserveMutex); + for (i=0, refPtr=refArray ; iclientData != clientData) { + continue; + } + + if (--refPtr->refCount != 0) { + Tcl_MutexUnlock(&preserveMutex); + return; + } + + /* + * Must remove information from the slot before calling freeProc to + * avoid reentrancy problems if the freeProc calls Tcl_Preserve on the + * same clientData. Copy down the last reference in the array to + * overwrite the current slot. + */ + + freeProc = refPtr->freeProc; + mustFree = refPtr->mustFree; + inUse--; + if (i < inUse) { + refArray[i] = refArray[inUse]; + } + + /* + * Now committed to disposing the data. But first, we've patched up + * all the global data structures so we should release the mutex now. + * Only then should we dabble around with potentially-slow memory + * managers... + */ + + Tcl_MutexUnlock(&preserveMutex); + if (mustFree) { + if (freeProc == TCL_DYNAMIC) { + ckfree((char *) clientData); + } else { + (*freeProc)((char *) clientData); + } + } + return; + } + Tcl_MutexUnlock(&preserveMutex); + + /* + * Reference not found. This is a bug in the caller. */ Tcl_Panic("Tcl_Release couldn't find reference for 0x%x", clientData); } @@ -257,14 +258,13 @@ /* *---------------------------------------------------------------------- * * Tcl_EventuallyFree -- * - * Free up a block of memory, unless a call to Tcl_Preserve is in - * effect for that block. In this case, defer the free until all - * calls to Tcl_Preserve have been undone by matching calls to - * Tcl_Release. + * Free up a block of memory, unless a call to Tcl_Preserve is in effect + * for that block. In this case, defer the free until all calls to + * Tcl_Preserve have been undone by matching calls to Tcl_Release. * * Results: * None. * * Side effects: @@ -274,27 +274,28 @@ */ void Tcl_EventuallyFree(clientData, freeProc) ClientData clientData; /* Pointer to malloc'ed block of memory. */ - Tcl_FreeProc *freeProc; /* Procedure to actually do free. */ + Tcl_FreeProc *freeProc; /* Function to actually do free. */ { Reference *refPtr; int i; /* - * See if there is a reference for this pointer. If so, set its - * "mustFree" flag (the flag had better not be set already!). + * See if there is a reference for this pointer. If so, set its "mustFree" + * flag (the flag had better not be set already!). */ Tcl_MutexLock(&preserveMutex); for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) { if (refPtr->clientData != clientData) { continue; } if (refPtr->mustFree) { - Tcl_Panic("Tcl_EventuallyFree called twice for 0x%x\n", clientData); + Tcl_Panic("Tcl_EventuallyFree called twice for 0x%x\n", + clientData); } refPtr->mustFree = 1; refPtr->freeProc = freeProc; Tcl_MutexUnlock(&preserveMutex); return; @@ -315,35 +316,33 @@ /* *--------------------------------------------------------------------------- * * TclHandleCreate -- * - * Allocate a handle that contains enough information to determine - * if an arbitrary malloc'd block has been deleted. This is - * used to avoid the more time-expensive algorithm of Tcl_Preserve(). + * Allocate a handle that contains enough information to determine if an + * arbitrary malloc'd block has been deleted. This is used to avoid the + * more time-expensive algorithm of Tcl_Preserve(). * * Results: * The return value is a TclHandle that refers to the given malloc'd - * block. Doubly dereferencing the returned handle will give - * back the pointer to the block, or will give NULL if the block has - * been deleted. + * block. Doubly dereferencing the returned handle will give back the + * pointer to the block, or will give NULL if the block has been deleted. * * Side effects: - * The caller must keep track of this handle (generally by storing - * it in a field in the malloc'd block) and call TclHandleFree() - * on this handle when the block is deleted. Everything else that - * wishes to keep track of whether the malloc'd block has been deleted - * should use calls to TclHandlePreserve() and TclHandleRelease() - * on the associated handle. + * The caller must keep track of this handle (generally by storing it in + * a field in the malloc'd block) and call TclHandleFree() on this handle + * when the block is deleted. Everything else that wishes to keep track + * of whether the malloc'd block has been deleted should use calls to + * TclHandlePreserve() and TclHandleRelease() on the associated handle. * *--------------------------------------------------------------------------- */ TclHandle TclHandleCreate(ptr) - VOID *ptr; /* Pointer to an arbitrary block of memory - * to be tracked for deletion. Must not be + VOID *ptr; /* Pointer to an arbitrary block of memory to + * be tracked for deletion. Must not be * NULL. */ { HandleStruct *handlePtr; handlePtr = (HandleStruct *) ckalloc(sizeof(HandleStruct)); @@ -358,15 +357,14 @@ /* *--------------------------------------------------------------------------- * * TclHandleFree -- * - * Called when the arbitrary malloc'd block associated with the - * handle is being deleted. Modifies the handle so that doubly - * dereferencing it will give NULL. This informs any user of the - * handle that the block of memory formerly referenced by the - * handle has been freed. + * Called when the arbitrary malloc'd block associated with the handle is + * being deleted. Modifies the handle so that doubly dereferencing it + * will give NULL. This informs any user of the handle that the block of + * memory formerly referenced by the handle has been freed. * * Results: * None. * * Side effects: @@ -375,14 +373,14 @@ *--------------------------------------------------------------------------- */ void TclHandleFree(handle) - TclHandle handle; /* Previously created handle associated - * with a malloc'd block that is being - * deleted. The handle is modified so that - * doubly dereferencing it will give NULL. */ + TclHandle handle; /* Previously created handle associated with a + * malloc'd block that is being deleted. The + * handle is modified so that doubly + * dereferencing it will give NULL. */ { HandleStruct *handlePtr; handlePtr = (HandleStruct *) handle; #ifdef TCL_MEM_DEBUG @@ -403,39 +401,38 @@ /* *--------------------------------------------------------------------------- * * TclHandlePreserve -- * - * Declare an interest in the arbitrary malloc'd block associated - * with the handle. + * Declare an interest in the arbitrary malloc'd block associated with + * the handle. * * Results: * The return value is the handle argument, with its ref count * incremented. * * Side effects: - * For each call to TclHandlePreserve(), there should be a matching - * call to TclHandleRelease() when the caller is no longer interested - * in the malloc'd block associated with the handle. + * For each call to TclHandlePreserve(), there should be a matching call + * to TclHandleRelease() when the caller is no longer interested in the + * malloc'd block associated with the handle. * *--------------------------------------------------------------------------- */ TclHandle TclHandlePreserve(handle) - TclHandle handle; /* Declare an interest in the block of - * memory referenced by this handle. */ + TclHandle handle; /* Declare an interest in the block of memory + * referenced by this handle. */ { HandleStruct *handlePtr; handlePtr = (HandleStruct *) handle; #ifdef TCL_MEM_DEBUG if (handlePtr->refCount == 0x61616161) { Tcl_Panic("using previously disposed TclHandle %x", handlePtr); } - if ((handlePtr->ptr != NULL) - && (handlePtr->ptr != handlePtr->ptr2)) { + if ((handlePtr->ptr != NULL) && (handlePtr->ptr != handlePtr->ptr2)) { Tcl_Panic("someone has changed the block referenced by the handle %x\nfrom %x to %x", handlePtr, handlePtr->ptr2, handlePtr->ptr); } #endif handlePtr->refCount++; @@ -446,43 +443,49 @@ /* *--------------------------------------------------------------------------- * * TclHandleRelease -- * - * This procedure is called to release an interest in the malloc'd - * block associated with the handle. + * This function is called to release an interest in the malloc'd block + * associated with the handle. * * Results: * None. * * Side effects: - * The ref count of the handle is decremented. If the malloc'd block - * has been freed and if no one is using the handle any more, the - * handle will be reclaimed. + * The ref count of the handle is decremented. If the malloc'd block has + * been freed and if no one is using the handle any more, the handle will + * be reclaimed. * *--------------------------------------------------------------------------- */ - + void TclHandleRelease(handle) - TclHandle handle; /* Unregister interest in the block of - * memory referenced by this handle. */ + TclHandle handle; /* Unregister interest in the block of memory + * referenced by this handle. */ { HandleStruct *handlePtr; handlePtr = (HandleStruct *) handle; #ifdef TCL_MEM_DEBUG if (handlePtr->refCount == 0x61616161) { Tcl_Panic("using previously disposed TclHandle %x", handlePtr); } - if ((handlePtr->ptr != NULL) - && (handlePtr->ptr != handlePtr->ptr2)) { + if ((handlePtr->ptr != NULL) && (handlePtr->ptr != handlePtr->ptr2)) { Tcl_Panic("someone has changed the block referenced by the handle %x\nfrom %x to %x", handlePtr, handlePtr->ptr2, handlePtr->ptr); } #endif handlePtr->refCount--; if ((handlePtr->refCount == 0) && (handlePtr->ptr == NULL)) { ckfree((char *) handlePtr); } } - + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclProc.c ================================================================== --- generic/tclProc.c +++ generic/tclProc.c @@ -1,18 +1,18 @@ -/* +/* * tclProc.c -- * - * This file contains routines that implement Tcl procedures, - * including the "proc" and "uplevel" commands. + * This file contains routines that implement Tcl procedures, including + * the "proc" and "uplevel" commands. * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * 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.66 2004/11/25 16:37:15 dkf Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.66.2.8 2005/09/27 18:42:54 dgp Exp $ */ #include "tclInt.h" #include "tclCompile.h" @@ -25,45 +25,49 @@ static int ProcessProcResultCode _ANSI_ARGS_((Tcl_Interp *interp, char *procName, int nameLen, int returnCode)); static int TclCompileNoOp _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +static void InitCompiledLocals _ANSI_ARGS_((Tcl_Interp *interp, + ByteCode *codePtr, CompiledLocal *localPtr, + Var *varPtr, Namespace *nsPtr)); + /* * The ProcBodyObjType type */ Tcl_ObjType tclProcBodyType = { "procbody", /* name for this type */ - ProcBodyFree, /* FreeInternalRep procedure */ - ProcBodyDup, /* DupInternalRep procedure */ - NULL, /* UpdateString procedure; Tcl_GetString - * and Tcl_GetStringFromObj should panic + ProcBodyFree, /* FreeInternalRep function */ + ProcBodyDup, /* DupInternalRep function */ + NULL, /* UpdateString function; Tcl_GetString and + * Tcl_GetStringFromObj should panic * instead. */ - NULL /* SetFromAny procedure; Tcl_ConvertToType + NULL /* SetFromAny function; Tcl_ConvertToType * should panic instead. */ }; /* - * The [upvar]/[uplevel] level reference type. Uses the twoPtrValue - * field, encoding the type of level reference in ptr1 and the actual - * parsed out offset in ptr2. + * The [upvar]/[uplevel] level reference type. Uses the twoPtrValue field, + * encoding the type of level reference in ptr1 and the actual parsed out + * offset in ptr2. * - * Uses the default behaviour throughout, and never disposes of the - * string rep; it's just a cache type. + * Uses the default behaviour throughout, and never disposes of the string + * rep; it's just a cache type. */ -Tcl_ObjType tclLevelReferenceType = { +static Tcl_ObjType levelReferenceType = { "levelReference", NULL, NULL, NULL, NULL }; /* *---------------------------------------------------------------------- * * Tcl_ProcObjCmd -- * - * This object-based procedure is invoked to process the "proc" Tcl + * This object-based function is invoked to process the "proc" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result value. * @@ -93,18 +97,18 @@ Tcl_WrongNumArgs(interp, 1, objv, "name args body"); return TCL_ERROR; } /* - * Determine the namespace where the procedure should reside. Unless - * the command name includes namespace qualifiers, this will be the - * current namespace. + * Determine the namespace where the procedure should reside. Unless the + * command name includes namespace qualifiers, this will be the current + * namespace. */ fullName = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, fullName, (Namespace *) NULL, - 0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName); + TclGetNamespaceForQualName(interp, fullName, (Namespace *) NULL, 0, + &nsPtr, &altNsPtr, &cxtNsPtr, &procName); if (nsPtr == NULL) { Tcl_AppendResult(interp, "can't create procedure \"", fullName, "\": unknown namespace", (char *) NULL); return TCL_ERROR; @@ -123,18 +127,19 @@ } /* * Create the data structure to represent the procedure. */ + if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3], &procPtr) != TCL_OK) { return TCL_ERROR; } /* - * Now create a command for the procedure. This will initially be in - * the current namespace unless the procedure's name included namespace + * Now create a command for the procedure. This will initially be in the + * current namespace unless the procedure's name included namespace * qualifiers. To create the new command in the right namespace, we * generate a fully qualified name for it. */ Tcl_DStringInit(&ds); @@ -146,10 +151,11 @@ cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc); Tcl_DStringFree(&ds); + /* * Now initialize the new procedure's cmdPtr field. This will be used * later when the procedure is called to determine what namespace the * procedure will run in. This will be different than the current * namespace if the proc was renamed into a different namespace. @@ -160,19 +166,20 @@ /* * Optimize for no-op procs: if the body is not precompiled (like a TclPro * procbody), and the argument list is just "args" and the body is empty, * define a compileProc to compile a no-op. * - * Notes: - * - cannot be done for any argument list without having different - * compiled/not-compiled behaviour in the "wrong argument #" case, - * or making this code much more complicated. In any case, it doesn't - * seem to make a lot of sense to verify the number of arguments we - * are about to ignore ... - * - could be enhanced to handle also non-empty bodies that contain - * only comments; however, parsing the body will slow down the - * compilation of all procs whose argument list is just _args_ */ + * Notes: + * - cannot be done for any argument list without having different + * compiled/not-compiled behaviour in the "wrong argument #" case, or + * making this code much more complicated. In any case, it doesn't + * seem to make a lot of sense to verify the number of arguments we + * are about to ignore ... + * - could be enhanced to handle also non-empty bodies that contain only + * comments; however, parsing the body will slow down the compilation + * of all procs whose argument list is just _args_ + */ if (objv[3]->typePtr == &tclProcBodyType) { goto done; } @@ -187,59 +194,59 @@ while(*procArgs != '\0') { if (*procArgs != ' ') { goto done; } procArgs++; - } + } - /* + /* * The argument list is just "args"; check the body */ procBody = TclGetString(objv[3]); while (*procBody != '\0') { if (!isspace(UCHAR(*procBody))) { goto done; } procBody++; - } + } - /* + /* * The body is just spaces: link the compileProc */ ((Command *) cmd)->compileProc = TclCompileNoOp; } - done: + done: return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCreateProc -- * - * Creates the data associated with a Tcl procedure definition. - * This procedure knows how to handle two types of body objects: - * strings and procbody. Strings are the traditional (and common) value - * for bodies, procbody are values created by extensions that have - * loaded a previously compiled script. + * Creates the data associated with a Tcl procedure definition. This + * function knows how to handle two types of body objects: strings and + * procbody. Strings are the traditional (and common) value for bodies, + * procbody are values created by extensions that have loaded a + * previously compiled script. * * Results: - * Returns TCL_OK on success, along with a pointer to a Tcl - * procedure definition in procPtrPtr where the cmdPtr field is not - * initialised. This definition should be freed by calling - * TclProcCleanupProc() when it is no longer needed. Returns TCL_ERROR if - * anything goes wrong. + * Returns TCL_OK on success, along with a pointer to a Tcl procedure + * definition in procPtrPtr where the cmdPtr field is not initialised. + * This definition should be freed by calling TclProcCleanupProc() when + * it is no longer needed. Returns TCL_ERROR if anything goes wrong. * * Side effects: - * If anything goes wrong, this procedure returns an error - * message in the interpreter. + * If anything goes wrong, this function returns an error message in the + * interpreter. * *---------------------------------------------------------------------- */ + int TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) Tcl_Interp *interp; /* interpreter containing proc */ Namespace *nsPtr; /* namespace containing this proc */ CONST char *procName; /* unqualified name of this proc */ @@ -274,21 +281,22 @@ procPtr->iPtr = iPtr; procPtr->refCount++; precompiled = 1; } else { /* - * If the procedure's body object is shared because its string value is - * identical to, e.g., the body of another procedure, we must create a - * private copy for this procedure to use. Such sharing of procedure - * bodies is rare but can cause problems. A procedure body is compiled - * in a context that includes the number of compiler-allocated "slots" - * for local variables. Each formal parameter is given a local variable - * slot (the "procPtr->numCompiledLocals = numArgs" assignment - * below). This means that the same code can not be shared by two - * procedures that have a different number of arguments, even if their - * bodies are identical. Note that we don't use Tcl_DuplicateObj since - * we would not want any bytecode internal representation. + * If the procedure's body object is shared because its string value + * is identical to, e.g., the body of another procedure, we must + * create a private copy for this procedure to use. Such sharing of + * procedure bodies is rare but can cause problems. A procedure body + * is compiled in a context that includes the number of + * compiler-allocated "slots" for local variables. Each formal + * parameter is given a local variable slot (the + * "procPtr->numCompiledLocals = numArgs" assignment below). This + * means that the same code can not be shared by two procedures that + * have a different number of arguments, even if their bodies are + * identical. Note that we don't use Tcl_DuplicateObj since we would + * not want any bytecode internal representation. */ if (Tcl_IsShared(bodyPtr)) { bytes = Tcl_GetStringFromObj(bodyPtr, &length); bodyPtr = Tcl_NewStringObj(bytes, length); @@ -311,15 +319,15 @@ procPtr->firstLocalPtr = NULL; procPtr->lastLocalPtr = NULL; } /* - * Break up the argument list into argument specifiers, then process - * each argument specifier. - * If the body is precompiled, processing is limited to checking that - * the parsed argument is consistent with the one stored in the - * Proc. + * Break up the argument list into argument specifiers, then process each + * argument specifier. If the body is precompiled, processing is limited + * to checking that the parsed argument is consistent with the one stored + * in the Proc. + * * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULLS. */ args = Tcl_GetStringFromObj(argsPtr, &length); result = Tcl_SplitList(interp, args, &numArgs, &argArray); @@ -327,22 +335,24 @@ goto procError; } if (precompiled) { if (numArgs > procPtr->numArgs) { - char buf[40 + TCL_INTEGER_SPACE + TCL_INTEGER_SPACE]; - sprintf(buf, "%d entries, precompiled header expects %d", - numArgs, procPtr->numArgs); - Tcl_AppendResult(interp, "procedure \"", procName, - "\": arg list contains ", buf, NULL); + Tcl_Obj *objPtr = Tcl_NewObj(); + TclObjPrintf(NULL, objPtr, + "procedure \"%s\": arg list contains %d entries, " + "precompiled header expects %d", procName, numArgs, + procPtr->numArgs); + Tcl_SetObjResult(interp, objPtr); goto procError; } localPtr = procPtr->firstLocalPtr; } else { procPtr->numArgs = numArgs; procPtr->numCompiledLocals = numArgs; } + for (i = 0; i < numArgs; i++) { int fieldCount, nameLength, valueLength; CONST char **fieldValues; /* @@ -404,29 +414,29 @@ p++; } if (precompiled) { /* - * Compare the parsed argument with the stored one. - * For the flags, we and out VAR_UNDEFINED to support bridging - * precompiled <= 8.3 code in 8.4 where this is now used as an - * optimization indicator. Yes, this is a hack. -- hobbs + * Compare the parsed argument with the stored one. For the flags, + * we and out VAR_UNDEFINED to support bridging precompiled <= 8.3 + * code in 8.4 where this is now used as an optimization + * indicator. Yes, this is a hack. -- hobbs */ if ((localPtr->nameLength != nameLength) || (strcmp(localPtr->name, fieldValues[0])) || (localPtr->frameIndex != i) || ((localPtr->flags & ~VAR_UNDEFINED) != (VAR_SCALAR | VAR_ARGUMENT)) || (localPtr->defValuePtr == NULL && fieldCount == 2) || (localPtr->defValuePtr != NULL && fieldCount != 2)) { - char buf[40 + TCL_INTEGER_SPACE]; - + Tcl_Obj *objPtr = Tcl_NewObj(); + TclObjPrintf(NULL, objPtr, + "procedure \"%s\": formal parameter %d is " + "inconsistent with precompiled body", procName, i); + Tcl_SetObjResult(interp, objPtr); ckfree((char *) fieldValues); - sprintf(buf, "%d is inconsistent with precompiled body", i); - Tcl_AppendResult(interp, "procedure \"", procName, - "\": formal parameter ", buf, (char *) NULL); goto procError; } /* * compare the default value if any @@ -436,27 +446,36 @@ int tmpLength; char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr, &tmpLength); if ((valueLength != tmpLength) || strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) { - Tcl_AppendResult(interp, "procedure \"", procName, - "\": formal parameter \"", fieldValues[0], - "\" has default value inconsistent with precompiled body", - (char *) NULL); + Tcl_Obj *objPtr = Tcl_NewObj(); + + TclObjPrintf(NULL, objPtr, + "procedure \"%s\": formal parameter \"%s\" has " + "default value inconsistent with precompiled body", + procName, fieldValues[0]); + Tcl_SetObjResult(interp, objPtr); ckfree((char *) fieldValues); goto procError; } + if ((i == numArgs - 1) + && (localPtr->nameLength == 4) + && (localPtr->name[0] == 'a') + && (strcmp(localPtr->name, "args") == 0)) { + localPtr->flags |= VAR_IS_ARGS; + } } localPtr = localPtr->nextPtr; } else { /* * Allocate an entry in the runtime procedure frame's array of - * local variables for the argument. + * local variables for the argument. */ - localPtr = (CompiledLocal *) ckalloc((unsigned) + localPtr = (CompiledLocal *) ckalloc((unsigned) (sizeof(CompiledLocal) - sizeof(localPtr->name) + nameLength + 1)); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { @@ -475,20 +494,26 @@ Tcl_IncrRefCount(localPtr->defValuePtr); } else { localPtr->defValuePtr = NULL; } strcpy(localPtr->name, fieldValues[0]); + if ((i == numArgs - 1) + && (localPtr->nameLength == 4) + && (localPtr->name[0] == 'a') + && (strcmp(localPtr->name, "args") == 0)) { + localPtr->flags |= VAR_IS_ARGS; + } } ckfree((char *) fieldValues); } *procPtrPtr = procPtr; ckfree((char *) argArray); return TCL_OK; -procError: + procError: if (precompiled) { procPtr->refCount--; } else { Tcl_DecrRefCount(bodyPtr); while (procPtr->firstLocalPtr != NULL) { @@ -513,23 +538,23 @@ /* *---------------------------------------------------------------------- * * TclGetFrame -- * - * Given a description of a procedure frame, such as the first - * argument to an "uplevel" or "upvar" command, locate the - * call frame for the appropriate level of procedure. + * Given a description of a procedure frame, such as the first argument + * to an "uplevel" or "upvar" command, locate the call frame for the + * appropriate level of procedure. * * Results: - * The return value is -1 if an error occurred in finding the frame - * (in this case an error message is left in the interp's result). - * 1 is returned if string was either a number or a number preceded - * by "#" and it specified a valid frame. 0 is returned if string - * isn't one of the two things above (in this case, the lookup - * acts as if string were "1"). The variable pointed to by - * framePtrPtr is filled in with the address of the desired frame - * (unless an error occurs, in which case it isn't modified). + * The return value is -1 if an error occurred in finding the frame (in + * this case an error message is left in the interp's result). 1 is + * returned if string was either a number or a number preceded by "#" and + * it specified a valid frame. 0 is returned if string isn't one of the + * two things above (in this case, the lookup acts as if string were + * "1"). The variable pointed to by framePtrPtr is filled in with the + * address of the desired frame (unless an error occurs, in which case it + * isn't modified). * * Side effects: * None. * *---------------------------------------------------------------------- @@ -537,12 +562,12 @@ int TclGetFrame(interp, name, framePtrPtr) Tcl_Interp *interp; /* Interpreter in which to find frame. */ CONST char *name; /* String describing frame. */ - CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL - * if global frame indicated). */ + CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL if + * global frame indicated). */ { register Interp *iPtr = (Interp *) interp; int curLevel, level, result; CallFrame *framePtr; @@ -564,11 +589,13 @@ } else { level = curLevel - 1; result = 0; } - /* Figure out which frame to use, and return it to the caller */ + /* + * Figure out which frame to use, and return it to the caller. + */ if (level == 0) { framePtr = NULL; } else { for (framePtr = iPtr->varFramePtr; framePtr != NULL; @@ -582,11 +609,11 @@ } } *framePtrPtr = framePtr; return result; - levelError: + levelError: Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad level \"", name, "\"", (char *) NULL); return -1; } @@ -593,23 +620,23 @@ /* *---------------------------------------------------------------------- * * TclObjGetFrame -- * - * Given a description of a procedure frame, such as the first - * argument to an "uplevel" or "upvar" command, locate the - * call frame for the appropriate level of procedure. + * Given a description of a procedure frame, such as the first argument + * to an "uplevel" or "upvar" command, locate the call frame for the + * appropriate level of procedure. * * Results: - * The return value is -1 if an error occurred in finding the frame - * (in this case an error message is left in the interp's result). - * 1 is returned if objPtr was either a number or a number preceded - * by "#" and it specified a valid frame. 0 is returned if objPtr - * isn't one of the two things above (in this case, the lookup - * acts as if objPtr were "1"). The variable pointed to by - * framePtrPtr is filled in with the address of the desired frame - * (unless an error occurs, in which case it isn't modified). + * The return value is -1 if an error occurred in finding the frame (in + * this case an error message is left in the interp's result). 1 is + * returned if objPtr was either a number or a number preceded by "#" and + * it specified a valid frame. 0 is returned if objPtr isn't one of the + * two things above (in this case, the lookup acts as if objPtr were + * "1"). The variable pointed to by framePtrPtr is filled in with the + * address of the desired frame (unless an error occurs, in which case it + * isn't modified). * * Side effects: * None. * *---------------------------------------------------------------------- @@ -617,12 +644,12 @@ int TclObjGetFrame(interp, objPtr, framePtrPtr) Tcl_Interp *interp; /* Interpreter in which to find frame. */ Tcl_Obj *objPtr; /* Object describing frame. */ - CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL - * if global frame indicated). */ + CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL if + * global frame indicated). */ { register Interp *iPtr = (Interp *) interp; int curLevel, level, result; CallFrame *framePtr; CONST char *name = TclGetString(objPtr); @@ -631,59 +658,74 @@ * Parse object to figure out which level number to go to. */ result = 1; curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level; - if (objPtr->typePtr == &tclLevelReferenceType) { + if (objPtr->typePtr == &levelReferenceType) { if ((int) objPtr->internalRep.twoPtrValue.ptr1) { level = curLevel - (int) objPtr->internalRep.twoPtrValue.ptr2; } else { level = (int) objPtr->internalRep.twoPtrValue.ptr2; } 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; } level = curLevel - level; } else { if (*name == '#') { if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) { goto levelError; } + /* * Cache for future reference. + * + * TODO: Use the new ptrAndLongRep intrep */ + TclFreeIntRep(objPtr); - objPtr->typePtr = &tclLevelReferenceType; + objPtr->typePtr = &levelReferenceType; objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) 0; objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) level; } else if (isdigit(UCHAR(*name))) { /* INTL: digit */ if (Tcl_GetInt(interp, name, &level) != TCL_OK) { return -1; } + /* * Cache for future reference. + * + * TODO: Use the new ptrAndLongRep intrep */ + TclFreeIntRep(objPtr); - objPtr->typePtr = &tclLevelReferenceType; + objPtr->typePtr = &levelReferenceType; objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) 1; objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) level; level = curLevel - level; } else { /* * Don't cache as the object *isn't* a level reference. */ + level = curLevel - 1; result = 0; } } - /* Figure out which frame to use, and return it to the caller */ + /* + * Figure out which frame to use, and return it to the caller. + */ if (level == 0) { framePtr = NULL; } else { for (framePtr = iPtr->varFramePtr; framePtr != NULL; @@ -697,11 +739,11 @@ } } *framePtrPtr = framePtr; return result; -levelError: + levelError: Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad level \"", name, "\"", (char *) NULL); return -1; } @@ -708,12 +750,12 @@ /* *---------------------------------------------------------------------- * * Tcl_UplevelObjCmd -- * - * This object procedure is invoked to process the "uplevel" Tcl - * command. See the user documentation for details on what it does. + * This object function is invoked to process the "uplevel" Tcl command. + * See the user documentation for details on what it does. * * Results: * A standard Tcl object result value. * * Side effects: @@ -733,11 +775,11 @@ register Interp *iPtr = (Interp *) interp; int result; CallFrame *savedVarFramePtr, *framePtr; if (objc < 2) { - uplevelSyntax: + uplevelSyntax: Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?"); return TCL_ERROR; } /* @@ -768,22 +810,22 @@ if (objc == 1) { result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT); } else { /* * More than one argument: concatenate them together with spaces - * between, then evaluate the result. Tcl_EvalObjEx will delete - * the object when it decrements its refcount after eval'ing it. + * between, then evaluate the result. Tcl_EvalObjEx will delete the + * object when it decrements its refcount after eval'ing it. */ + Tcl_Obj *objPtr; objPtr = Tcl_ConcatObj(objc, objv); result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); } if (result == TCL_ERROR) { - char msg[32 + TCL_INTEGER_SPACE]; - sprintf(msg, "\n (\"uplevel\" body line %d)", interp->errorLine); - Tcl_AddObjErrorInfo(interp, msg, -1); + TclFormatToErrorInfo(interp, "\n (\"uplevel\" body line %d)", + interp->errorLine); } /* * Restore the variable frame, and return. */ @@ -795,22 +837,21 @@ /* *---------------------------------------------------------------------- * * TclFindProc -- * - * Given the name of a procedure, return a pointer to the - * record describing the procedure. The procedure will be - * looked up using the usual rules: first in the current - * namespace and then in the global namespace. + * Given the name of a procedure, return a pointer to the record + * describing the procedure. The procedure will be looked up using the + * usual rules: first in the current namespace and then in the global + * namespace. * * Results: - * NULL is returned if the name doesn't correspond to any - * procedure. Otherwise, the return value is a pointer to - * the procedure's record. If the name is found but refers - * to an imported command that points to a "real" procedure - * defined in another namespace, a pointer to that "real" - * procedure's structure is returned. + * NULL is returned if the name doesn't correspond to any procedure. + * Otherwise, the return value is a pointer to the procedure's record. If + * the name is found but refers to an imported command that points to a + * "real" procedure defined in another namespace, a pointer to that + * "real" procedure's structure is returned. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -848,13 +889,13 @@ * TclIsProc -- * * Tells whether a command is a Tcl procedure or not. * * Results: - * If the given command is actually a Tcl procedure, the - * return value is the address of the record describing - * the procedure. Otherwise the return value is 0. + * If the given command is actually a Tcl procedure, the return value is + * the address of the record describing the procedure. Otherwise the + * return value is 0. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -877,13 +918,184 @@ } /* *---------------------------------------------------------------------- * + * InitCompiledLocals -- + * + * This routine is invoked in order to initialize the compiled locals + * table for a new call frame. + * + * Results: + * None. + * + * Side effects: + * May invoke various name resolvers in order to determine which + * variables are being referenced at runtime. + * + *---------------------------------------------------------------------- + */ + +static void +InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr) + Tcl_Interp *interp; /* Current interpreter. */ + ByteCode *codePtr; + CompiledLocal *localPtr; + Var *varPtr; + Namespace *nsPtr; /* Pointer to current namespace. */ +{ + Interp *iPtr = (Interp*) interp; + int haveResolvers = (nsPtr->compiledVarResProc || iPtr->resolverPtr); + CompiledLocal *firstLocalPtr; + + if (codePtr->flags & TCL_BYTECODE_RESOLVE_VARS) { + /* + * This is the first run after a recompile, or else the resolver epoch + * has changed: update the resolver cache. + */ + + firstLocalPtr = localPtr; + for (; localPtr != NULL; localPtr = localPtr->nextPtr) { + + if (localPtr->resolveInfo) { + if (localPtr->resolveInfo->deleteProc) { + localPtr->resolveInfo->deleteProc(localPtr->resolveInfo); + } else { + ckfree((char*)localPtr->resolveInfo); + } + localPtr->resolveInfo = NULL; + } + localPtr->flags &= ~VAR_RESOLVED; + + if (haveResolvers && + !(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY))) { + ResolverScheme *resPtr = iPtr->resolverPtr; + Tcl_ResolvedVarInfo *vinfo; + int result; + + if (nsPtr->compiledVarResProc) { + result = (*nsPtr->compiledVarResProc)(nsPtr->interp, + localPtr->name, localPtr->nameLength, + (Tcl_Namespace *) nsPtr, &vinfo); + } else { + result = TCL_CONTINUE; + } + + while ((result == TCL_CONTINUE) && resPtr) { + if (resPtr->compiledVarResProc) { + result = (*resPtr->compiledVarResProc)(nsPtr->interp, + localPtr->name, localPtr->nameLength, + (Tcl_Namespace *) nsPtr, &vinfo); + } + resPtr = resPtr->nextPtr; + } + if (result == TCL_OK) { + localPtr->resolveInfo = vinfo; + localPtr->flags |= VAR_RESOLVED; + } + } + } + localPtr = firstLocalPtr; + codePtr->flags &= ~TCL_BYTECODE_RESOLVE_VARS; + } + + /* + * Initialize the array of local variables stored in the call frame. Some + * variables may have special resolution rules. In that case, we call + * their "resolver" procs to get our hands on the variable, and we make + * the compiled local a link to the real variable. + */ + + if (haveResolvers) { + Tcl_ResolvedVarInfo *resVarInfo; + for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) { + varPtr->value.objPtr = NULL; + varPtr->name = localPtr->name; /* will be just '\0' if temp var */ + varPtr->nsPtr = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = localPtr->flags; + + /* + * Now invoke the resolvers to determine the exact variables that + * should be used. + */ + + resVarInfo = localPtr->resolveInfo; + if (resVarInfo && resVarInfo->fetchProc) { + Var *resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp, + resVarInfo); + if (resolvedVarPtr) { + resolvedVarPtr->refCount++; + varPtr->value.linkPtr = resolvedVarPtr; + varPtr->flags = VAR_LINK; + } + } + } + } else { + for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) { + varPtr->value.objPtr = NULL; + varPtr->name = localPtr->name; /* will be just '\0' if temp var */ + varPtr->nsPtr = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = localPtr->flags; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TclInitCompiledLocals -- + * + * This routine is invoked in order to initialize the compiled locals + * table for a new call frame. + * + * DEPRECATED: functionality has been inlined elsewhere; this function + * remains to insure binary compatibility with Itcl. + * + * Results: + * None. + * + * Side effects: + * May invoke various name resolvers in order to determine which + * variables are being referenced at runtime. + * + *---------------------------------------------------------------------- + */ + +void +TclInitCompiledLocals(interp, framePtr, nsPtr) + Tcl_Interp *interp; /* Current interpreter. */ + CallFrame *framePtr; /* Call frame to initialize. */ + Namespace *nsPtr; /* Pointer to current namespace. */ +{ + Var *varPtr = framePtr->compiledLocals; + Tcl_Obj *bodyPtr; + ByteCode *codePtr; + CompiledLocal *localPtr = framePtr->procPtr->firstLocalPtr; + + bodyPtr = framePtr->procPtr->bodyPtr; + if (bodyPtr->typePtr != &tclByteCodeType) { + Tcl_Panic("body object for proc attached to frame is not a byte code type"); + } + codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; + + InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr); +} + +/* + *---------------------------------------------------------------------- + * * TclObjInterpProc -- * - * When a Tcl procedure gets invoked during bytecode evaluation, this + * When a Tcl procedure gets invoked during bytecode evaluation, this * object-based routine gets invoked to interpret the procedure. * * Results: * A standard Tcl object result value. * @@ -903,156 +1115,177 @@ * procedure. */ Tcl_Obj *CONST objv[]; /* Argument value objects. */ { register Proc *procPtr = (Proc *) clientData; Namespace *nsPtr = procPtr->cmdPtr->nsPtr; - CallFrame frame; - register CallFrame *framePtr = &frame; + CallFrame *framePtr, **framePtrPtr; register Var *varPtr; register CompiledLocal *localPtr; char *procName; - int nameLen, localCt, numArgs, argCt, i, result; - - /* - * This procedure generates an array "compiledLocals" that holds the - * storage for local variables. It starts out with stack-allocated space - * but uses dynamically-allocated storage if needed. - */ - -#define NUM_LOCALS 20 - Var localStorage[NUM_LOCALS]; - Var *compiledLocals = localStorage; + int nameLen, localCt, numArgs, argCt, i, imax, result; + Var *compiledLocals; /* * Get the procedure's name. */ procName = Tcl_GetStringFromObj(objv[0], &nameLen); /* - * If necessary, compile the procedure's body. The compiler will - * allocate frame slots for the procedure's non-argument local - * variables. Note that compiling the body might increase - * procPtr->numCompiledLocals if new local variables are found - * while compiling. + * If necessary, compile the procedure's body. The compiler will allocate + * frame slots for the procedure's non-argument local variables. Note that + * compiling the body might increase procPtr->numCompiledLocals if new + * local variables are found while compiling. */ result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, "body of proc", procName); if (result != TCL_OK) { return result; } - /* - * Create the "compiledLocals" array. Make sure it is large enough to - * hold all the procedure's compiled local variables, including its - * formal parameters. - */ - - localCt = procPtr->numCompiledLocals; - if (localCt > NUM_LOCALS) { - compiledLocals = (Var *) ckalloc((unsigned) localCt * sizeof(Var)); - } /* * Set up and push a new call frame for the new procedure invocation. - * This call frame will execute in the proc's namespace, which might - * be different than the current namespace. The proc's namespace is - * that of its command, which can change if the command is renamed - * from one namespace to another. + * This call frame will execute in the proc's namespace, which might be + * different than the current namespace. The proc's namespace is that of + * its command, which can change if the command is renamed from one + * namespace to another. */ - result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, - (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 1); + framePtrPtr = &framePtr; + result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, + (Tcl_Namespace *) nsPtr, FRAME_IS_PROC); if (result != TCL_OK) { return result; } + framePtr->objc = objc; framePtr->objv = objv; /* ref counts for args are incremented below */ - - /* - * Initialize and resolve compiled variable references. - */ - framePtr->procPtr = procPtr; + + /* + * Create the "compiledLocals" array. Make sure it is large enough to hold + * all the procedure's compiled local variables, including its formal + * parameters. + */ + + localCt = procPtr->numCompiledLocals; + compiledLocals = (Var *) TclStackAlloc(interp, localCt*sizeof(Var)); framePtr->numCompiledLocals = localCt; framePtr->compiledLocals = compiledLocals; - TclInitCompiledLocals(interp, framePtr, nsPtr); - /* - * Match and assign the call's actual parameters to the procedure's - * formal arguments. The formal arguments are described by the first - * numArgs entries in both the Proc structure's local variable list and - * the call frame's local variable array. + * Match and assign the call's actual parameters to the procedure's formal + * arguments. The formal arguments are described by the first numArgs + * entries in both the Proc structure's local variable list and the call + * frame's local variable array. */ numArgs = procPtr->numArgs; + argCt = objc-1; /* set it to the number of args to the proc */ varPtr = framePtr->compiledLocals; localPtr = procPtr->firstLocalPtr; - argCt = objc; - for (i = 1, argCt -= 1; i <= numArgs; i++, argCt--) { - if (!TclIsVarArgument(localPtr)) { - Tcl_Panic("TclObjInterpProc: local variable %s is not argument but should be", - localPtr->name); - return TCL_ERROR; - } - if (TclIsVarTemporary(localPtr)) { - Tcl_Panic("TclObjInterpProc: local variable %d is temporary but should be an argument", i); - return TCL_ERROR; - } - + if (numArgs == 0) { + if (argCt) { + goto incorrectArgs; + } else { + goto runProc; + } + } + imax = ((argCt < numArgs - 1)? argCt : (numArgs - 1)); + for (i = 1; i <= imax; i++) { + /* + * "Normal" arguments; last formal is special, depends on it being + * 'args'. + */ + + Tcl_Obj *objPtr = objv[i]; + + varPtr->value.objPtr = objPtr; + Tcl_IncrRefCount(objPtr); /* local var is a reference */ + varPtr->name = localPtr->name; + varPtr->nsPtr = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = localPtr->flags; + varPtr++; + localPtr = localPtr->nextPtr; + } + for (; i < numArgs; i++) { /* - * Handle the special case of the last formal being "args". When - * it occurs, assign it a list consisting of all the remaining - * actual arguments. + * This loop is entered if argCt < (numArgs-1). Set default values; + * last formal is special. */ - if ((i == numArgs) && ((localPtr->name[0] == 'a') - && (strcmp(localPtr->name, "args") == 0))) { - Tcl_Obj *listPtr = Tcl_NewListObj(argCt, &(objv[i])); - varPtr->value.objPtr = listPtr; - Tcl_IncrRefCount(listPtr); /* local var is a reference */ - TclClearVarUndefined(varPtr); - argCt = 0; - break; /* done processing args */ - } else if (argCt > 0) { - Tcl_Obj *objPtr = objv[i]; - varPtr->value.objPtr = objPtr; - TclClearVarUndefined(varPtr); - Tcl_IncrRefCount(objPtr); /* since the local variable now has - * another reference to object. */ - } else if (localPtr->defValuePtr != NULL) { + if (localPtr->defValuePtr != NULL) { Tcl_Obj *objPtr = localPtr->defValuePtr; + varPtr->value.objPtr = objPtr; - TclClearVarUndefined(varPtr); - Tcl_IncrRefCount(objPtr); /* since the local variable now has - * another reference to object. */ + Tcl_IncrRefCount(objPtr); /* local var is a reference */ + varPtr->name = localPtr->name; + varPtr->nsPtr = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = localPtr->flags; + varPtr++; + localPtr = localPtr->nextPtr; } else { goto incorrectArgs; } - varPtr++; - localPtr = localPtr->nextPtr; } - if (argCt > 0) { + + /* + * When we get here, the last formal argument remains to be defined: + * localPtr and varPtr point to the last argument to be initialized. + */ + + if (localPtr->flags & VAR_IS_ARGS) { + Tcl_Obj *listPtr = Tcl_NewListObj(objc-numArgs, &(objv[numArgs])); + varPtr->value.objPtr = listPtr; + Tcl_IncrRefCount(listPtr); /* local var is a reference */ + } else if (argCt == numArgs) { + Tcl_Obj *objPtr = objv[numArgs]; + varPtr->value.objPtr = objPtr; + Tcl_IncrRefCount(objPtr); /* local var is a reference */ + } else if ((argCt < numArgs) && (localPtr->defValuePtr != NULL)) { + Tcl_Obj *objPtr = localPtr->defValuePtr; + varPtr->value.objPtr = objPtr; + Tcl_IncrRefCount(objPtr); /* local var is a reference */ + } else { Tcl_Obj **desiredObjs, *argObj; + ByteCode *codePtr; + + /* + * Do initialise all compiled locals, to avoid problems at + * DeleteLocalVars. + */ incorrectArgs: + codePtr = (ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr; + InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr); + /* * Build up desired argument list for Tcl_WrongNumArgs */ desiredObjs = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * (unsigned)(numArgs+1)); + #ifdef AVOID_HACKS_FOR_ITCL desiredObjs[0] = objv[0]; #else desiredObjs[0] = Tcl_NewListObj(1, objv); #endif /* AVOID_HACKS_FOR_ITCL */ + localPtr = procPtr->firstLocalPtr; for (i=1 ; i<=numArgs ; i++) { TclNewObj(argObj); if (localPtr->defValuePtr != NULL) { Tcl_AppendStringsToObj(argObj, @@ -1080,10 +1313,33 @@ } #endif /* AVOID_HACKS_FOR_ITCL */ ckfree((char *) desiredObjs); goto procDone; } + + varPtr->name = localPtr->name; + varPtr->nsPtr = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = localPtr->flags; + + localPtr = localPtr->nextPtr; + varPtr++; + + /* + * Initialise and resolve the remaining compiledLocals. + */ + + runProc: + if (localPtr) { + ByteCode *codePtr = (ByteCode *) + procPtr->bodyPtr->internalRep.otherValuePtr; + + InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr); + } /* * Invoke the commands in the procedure's body. */ @@ -1109,73 +1365,79 @@ if (result != TCL_OK) { result = ProcessProcResultCode(interp, procName, nameLen, result); } /* - * Pop and free the call frame for this procedure invocation, then - * free the compiledLocals array if malloc'ed storage was used. + * Pop and free the call frame for this procedure invocation, then free + * the compiledLocals array if malloc'ed storage was used. + */ + + procDone: + /* + * Free the stack-allocated compiled locals and CallFrame. It is important + * to pop the call frame without freeing it first: the compiledLocals + * cannot be freed before the frame is popped, as the local variables must + * be deleted. But the compiledLocals must be freed first, as they were + * allocated later on the stack. */ - procDone: - Tcl_PopCallFrame(interp); - if (compiledLocals != localStorage) { - ckfree((char *) compiledLocals); - } + Tcl_PopCallFrame(interp); /* pop but do not free */ + TclStackFree(interp); /* free compiledLocals */ + TclStackFree(interp); /* free CallFrame */ return result; #undef NUM_LOCALS } /* *---------------------------------------------------------------------- * * TclProcCompileProc -- * - * Called just before a procedure is executed to compile the - * body to byte codes. If the type of the body is not - * "byte code" or if the compile conditions have changed - * (namespace context, epoch counters, etc.) then the body - * is recompiled. Otherwise, this procedure does nothing. + * Called just before a procedure is executed to compile the body to byte + * codes. If the type of the body is not "byte code" or if the compile + * conditions have changed (namespace context, epoch counters, etc.) then + * the body is recompiled. Otherwise, this function does nothing. * * Results: * None. * * Side effects: - * May change the internal representation of the body object - * to compiled code. + * May change the internal representation of the body object to compiled + * code. * *---------------------------------------------------------------------- */ int TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) Tcl_Interp *interp; /* Interpreter containing procedure. */ Proc *procPtr; /* Data associated with procedure. */ Tcl_Obj *bodyPtr; /* Body of proc. (Usually procPtr->bodyPtr, - * but could be any code fragment compiled - * in the context of this procedure.) */ + * but could be any code fragment compiled in + * the context of this procedure.) */ Namespace *nsPtr; /* Namespace containing procedure. */ CONST char *description; /* string describing this body of code. */ CONST char *procName; /* Name of this procedure. */ { Interp *iPtr = (Interp*)interp; int result; - Tcl_CallFrame frame; + Tcl_CallFrame *framePtr; Proc *saveProcPtr; ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; /* - * If necessary, compile the procedure's body. The compiler will - * allocate frame slots for the procedure's non-argument local - * variables. If the ByteCode already exists, make sure it hasn't been - * invalidated by someone redefining a core command (this might make the - * compiled code wrong). Also, if the code was compiled in/for a - * different interpreter, we recompile it. Note that compiling the body - * might increase procPtr->numCompiledLocals if new local variables are - * found while compiling. - * - * Precompiled procedure bodies, however, are immutable and therefore - * they are not recompiled, even if things have changed. + * If necessary, compile the procedure's body. The compiler will allocate + * frame slots for the procedure's non-argument local variables. If the + * ByteCode already exists, make sure it hasn't been invalidated by + * someone redefining a core command (this might make the compiled code + * wrong). Also, if the code was compiled in/for a different interpreter, + * we recompile it. Note that compiling the body might increase + * procPtr->numCompiledLocals if new local variables are found while + * compiling. + * + * Precompiled procedure bodies, however, are immutable and therefore they + * are not recompiled, even if things have changed. */ if (bodyPtr->typePtr == &tclByteCodeType) { if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) @@ -1196,164 +1458,142 @@ } if (bodyPtr->typePtr != &tclByteCodeType) { #ifdef TCL_COMPILE_DEBUG if (tclTraceCompile >= 1) { /* - * Display a line summarizing the top level command we - * are about to compile. + * Display a line summarizing the top level command we are about + * to compile. */ + Tcl_Obj *message = Tcl_NewStringObj("Compiling ", -1); + Tcl_IncrRefCount(message); Tcl_AppendStringsToObj(message, description, " \"", NULL); TclAppendLimitedToObj(message, procName, -1, 50, NULL); fprintf(stdout, "%s\"\n", TclGetString(message)); Tcl_DecrRefCount(message); } #endif /* - * Plug the current procPtr into the interpreter and coerce - * the code body to byte codes. The interpreter needs to - * know which proc it's compiling so that it can access its - * list of compiled locals. - * - * TRICKY NOTE: Be careful to push a call frame with the - * proper namespace context, so that the byte codes are - * compiled in the appropriate class context. + * Plug the current procPtr into the interpreter and coerce the code + * body to byte codes. The interpreter needs to know which proc it's + * compiling so that it can access its list of compiled locals. + * + * TRICKY NOTE: Be careful to push a call frame with the proper + * namespace context, so that the byte codes are compiled in the + * appropriate class context. */ saveProcPtr = iPtr->compiledProcPtr; iPtr->compiledProcPtr = procPtr; - result = Tcl_PushCallFrame(interp, &frame, - (Tcl_Namespace*)nsPtr, /* isProcCallFrame */ 0); + result = TclPushStackFrame(interp, &framePtr, + (Tcl_Namespace *) nsPtr, /* isProcCallFrame */ 0); if (result == TCL_OK) { result = tclByteCodeType.setFromAnyProc(interp, bodyPtr); - Tcl_PopCallFrame(interp); + TclPopStackFrame(interp); } iPtr->compiledProcPtr = saveProcPtr; if (result != TCL_OK) { if (result == TCL_ERROR) { - Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine); - Tcl_Obj *message = - Tcl_NewStringObj("\n (compiling ", -1); - Tcl_IncrRefCount(message); - Tcl_AppendStringsToObj(message, description, " \"", NULL); - TclAppendLimitedToObj(message, procName, -1, 50, NULL); - Tcl_AppendToObj(message, "\", line ", -1); - Tcl_AppendObjToObj(message, errorLine); - Tcl_DecrRefCount(errorLine); - Tcl_AppendToObj(message, ")", -1); - TclAppendObjToErrorInfo(interp, message); - Tcl_DecrRefCount(message); + int length = strlen(procName); + int limit = 50; + int overflow = (length > limit); + + TclFormatToErrorInfo(interp, + "\n (compiling %s \"%.*s%s\", line %d)", + description, (overflow ? limit : length), procName, + (overflow ? "..." : ""), interp->errorLine); } return result; } } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) { - register CompiledLocal *localPtr; - /* - * The resolver epoch has changed, but we only need to invalidate - * the resolver cache. + * The resolver epoch has changed, but we only need to invalidate the + * resolver cache. */ - for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; - localPtr = localPtr->nextPtr) { - localPtr->flags &= ~(VAR_RESOLVED); - if (localPtr->resolveInfo) { - if (localPtr->resolveInfo->deleteProc) { - localPtr->resolveInfo->deleteProc(localPtr->resolveInfo); - } else { - ckfree((char*)localPtr->resolveInfo); - } - localPtr->resolveInfo = NULL; - } - } + codePtr->flags |= TCL_BYTECODE_RESOLVE_VARS; } return TCL_OK; } /* *---------------------------------------------------------------------- * * ProcessProcResultCode -- * - * Procedure called by TclObjInterpProc to process a return code other + * Function called by TclObjInterpProc to process a return code other * than TCL_OK returned by a Tcl procedure. * * Results: - * Depending on the argument return code, the result returned is - * another return code and the interpreter's result is set to a value - * to supplement that return code. + * Depending on the argument return code, the result returned is another + * return code and the interpreter's result is set to a value to + * supplement that return code. * * Side effects: - * If the result returned is TCL_ERROR, traceback information about - * the procedure just executed is appended to the interpreter's - * errorInfo field. + * If the result returned is TCL_ERROR, traceback information about the + * procedure just executed is appended to the interpreter's errorInfo + * field. * *---------------------------------------------------------------------- */ static int ProcessProcResultCode(interp, procName, nameLen, returnCode) - Tcl_Interp *interp; /* The interpreter in which the procedure - * was called and returned returnCode. */ + Tcl_Interp *interp; /* The interpreter in which the procedure was + * called and returned returnCode. */ char *procName; /* Name of the procedure. Used for error * messages and trace information. */ int nameLen; /* Number of bytes in procedure's name. */ int returnCode; /* The unexpected result code. */ { Interp *iPtr = (Interp *) interp; - Tcl_Obj *message, *errorLine; + int overflow, limit = 60; if (returnCode == TCL_OK) { return TCL_OK; } if ((returnCode > TCL_CONTINUE) || (returnCode < TCL_OK)) { return returnCode; } if (returnCode == TCL_RETURN) { return TclUpdateReturnInfo(iPtr); - } + } if (returnCode != TCL_ERROR) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "invoked \"", ((returnCode == TCL_BREAK) ? "break" : "continue"), "\" outside of a loop", NULL); } - errorLine = Tcl_NewIntObj(interp->errorLine); - message = Tcl_NewStringObj("\n (procedure \"", -1); - Tcl_IncrRefCount(message); - TclAppendLimitedToObj(message, procName, nameLen, 60, NULL); - Tcl_AppendToObj(message, "\" line ", -1); - Tcl_AppendObjToObj(message, errorLine); - Tcl_DecrRefCount(errorLine); - Tcl_AppendToObj(message, ")", -1); - TclAppendObjToErrorInfo(interp, message); - Tcl_DecrRefCount(message); + overflow = (nameLen > limit); + TclFormatToErrorInfo(interp, "\n (procedure \"%.*s%s\" line %d)", + (overflow ? limit : nameLen), procName, + (overflow ? "..." : ""), interp->errorLine); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * TclProcDeleteProc -- * - * This procedure is invoked just before a command procedure is - * removed from an interpreter. Its job is to release all the - * resources allocated to the procedure. + * This function is invoked just before a command procedure is removed + * from an interpreter. Its job is to release all the resources allocated + * to the procedure. * * Results: * None. * * Side effects: - * Memory gets freed, unless the procedure is actively being - * executed. In this case the cleanup is delayed until the - * last call to the current procedure completes. + * Memory gets freed, unless the procedure is actively being executed. + * In this case the cleanup is delayed until the last call to the current + * procedure completes. * *---------------------------------------------------------------------- */ void @@ -1371,13 +1611,12 @@ /* *---------------------------------------------------------------------- * * TclProcCleanupProc -- * - * This procedure does all the real work of freeing up a Proc - * structure. It's called only when the structure's reference - * count becomes zero. + * This function does all the real work of freeing up a Proc structure. + * It's called only when the structure's reference count becomes zero. * * Results: * None. * * Side effects: @@ -1423,54 +1662,57 @@ /* *---------------------------------------------------------------------- * * TclUpdateReturnInfo -- * - * This procedure is called when procedures return, and at other - * points where the TCL_RETURN code is used. It examines the - * returnLevel and returnCode to determine the real return status. + * This function is called when procedures return, and at other points + * where the TCL_RETURN code is used. It examines the returnLevel and + * returnCode to determine the real return status. * * Results: - * The return value is the true completion code to use for - * the procedure or script, instead of TCL_RETURN. + * The return value is the true completion code to use for the procedure + * or script, instead of TCL_RETURN. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclUpdateReturnInfo(iPtr) - Interp *iPtr; /* Interpreter for which TCL_RETURN - * exception is being processed. */ + Interp *iPtr; /* Interpreter for which TCL_RETURN exception + * is being processed. */ { int code = TCL_RETURN; iPtr->returnLevel--; if (iPtr->returnLevel < 0) { Tcl_Panic("TclUpdateReturnInfo: negative return level"); } if (iPtr->returnLevel == 0) { - /* Now we've reached the level to return the requested -code */ - return iPtr->returnCode; + /* + * Now we've reached the level to return the requested -code. + */ + + code = iPtr->returnCode; } return code; } /* *---------------------------------------------------------------------- * * TclGetObjInterpProc -- * - * Returns a pointer to the TclObjInterpProc procedure; this is - * different from the value obtained from the TclObjInterpProc - * reference on systems like Windows where import and export - * versions of a procedure exported by a DLL exist. + * Returns a pointer to the TclObjInterpProc function; this is different + * from the value obtained from the TclObjInterpProc reference on systems + * like Windows where import and export versions of a function exported + * by a DLL exist. * * Results: - * Returns the internal address of the TclObjInterpProc procedure. + * Returns the internal address of the TclObjInterpProc function. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -1486,20 +1728,19 @@ *---------------------------------------------------------------------- * * TclNewProcBodyObj -- * * Creates a new object, of type "procbody", whose internal - * representation is the given Proc struct. The newly created - * object's reference count is 0. + * representation is the given Proc struct. The newly created object's + * reference count is 0. * * Results: * Returns a pointer to a newly allocated Tcl_Obj, 0 on error. * * Side effects: - * The reference count in the ByteCode attached to the Proc is - * bumped up by one, since the internal rep stores a pointer to - * it. + * The reference count in the ByteCode attached to the Proc is bumped up + * by one, since the internal rep stores a pointer to it. * *---------------------------------------------------------------------- */ Tcl_Obj * @@ -1528,13 +1769,12 @@ /* *---------------------------------------------------------------------- * * ProcBodyDup -- * - * Tcl_ObjType's Dup function for the proc body object. - * Bumps the reference count on the Proc stored in the internal - * representation. + * Tcl_ObjType's Dup function for the proc body object. Bumps the + * reference count on the Proc stored in the internal representation. * * Results: * None. * * Side effects: @@ -1558,20 +1798,20 @@ /* *---------------------------------------------------------------------- * * ProcBodyFree -- * - * Tcl_ObjType's Free function for the proc body object. The - * reference count on its Proc struct is decreased by 1; if the - * count reaches 0, the proc is freed. + * Tcl_ObjType's Free function for the proc body object. The reference + * count on its Proc struct is decreased by 1; if the count reaches 0, + * the proc is freed. * * Results: * None. * * Side effects: - * If the reference count on the Proc struct reaches 0, the - * struct is freed. + * If the reference count on the Proc struct reaches 0, the struct is + * freed. * *---------------------------------------------------------------------- */ static void @@ -1588,11 +1828,11 @@ /* *---------------------------------------------------------------------- * * TclCompileNoOp -- * - * Procedure called to compile no-op's + * Function called to compile no-op's * * Results: * The return value is TCL_OK, indicating successful compilation. * * Side effects: @@ -1602,12 +1842,12 @@ */ static int TclCompileNoOp(interp, parsePtr, envPtr) Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Parse *parsePtr; /* Points to a parse structure for the - * command created by Tcl_ParseCommand. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ CompileEnv *envPtr; /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; int i; int savedStackDepth = envPtr->currStackDepth; @@ -1615,15 +1855,23 @@ tokenPtr = parsePtr->tokenPtr; for(i = 1; i < parsePtr->numWords; i++) { tokenPtr = tokenPtr + tokenPtr->numComponents + 1; envPtr->currStackDepth = savedStackDepth; - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); TclEmitOpcode(INST_POP, envPtr); - } + } } envPtr->currStackDepth = savedStackDepth; - TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); return TCL_OK; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclRegexp.c ================================================================== --- generic/tclRegexp.c +++ generic/tclRegexp.c @@ -1,52 +1,52 @@ -/* +/* * tclRegexp.c -- * - * This file contains the public interfaces to the Tcl regular - * expression mechanism. + * This file contains the public interfaces to the Tcl regular expression + * mechanism. * * Copyright (c) 1998 by Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclRegexp.c,v 1.17 2004/09/29 22:23:25 dkf Exp $ + * RCS: @(#) $Id: tclRegexp.c,v 1.17.2.2 2005/08/02 18:16:07 dgp Exp $ */ #include "tclInt.h" #include "tclRegexp.h" /* *---------------------------------------------------------------------- - * The routines in this file use Henry Spencer's regular expression - * package contained in the following additional source files: + * The routines in this file use Henry Spencer's regular expression package + * contained in the following additional source files: * * regc_color.c regc_cvec.c regc_lex.c * regc_nfa.c regcomp.c regcustom.h * rege_dfa.c regerror.c regerrs.h * regex.h regexec.c regfree.c * regfronts.c regguts.h * * Copyright (c) 1998 Henry Spencer. All rights reserved. - * + * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics - * Corporation, none of whom are responsible for the results. The author - * thanks all of them. - * + * Corporation, none of whom are responsible for the results. The author + * thanks all of them. + * * Redistribution and use in source and binary forms -- with or without * modification -- are permitted for any purpose, provided that * redistributions in source form retain this entire copyright notice and * indicate the origin and nature of any modifications. - * - * I'd appreciate being given credit for this package in the documentation - * of software which uses it, but that is not a requirement. - * + * + * I'd appreciate being given credit for this package in the documentation of + * software which uses it, but that is not a requirement. + * * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL + * AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL * HENRY SPENCER BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR @@ -66,19 +66,18 @@ #define NUM_REGEXPS 30 typedef struct ThreadSpecificData { int initialized; /* Set to 1 when the module is initialized. */ - char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled - * regular expression patterns. NULL - * means that this slot isn't used. - * Malloc-ed. */ + char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled regular + * expression patterns. NULL means that this + * slot isn't used. Malloc-ed. */ int patLengths[NUM_REGEXPS];/* Number of non-null characters in - * corresponding entry in patterns. - * -1 means entry isn't used. */ + * corresponding entry in patterns. -1 means + * entry isn't used. */ struct TclRegexp *regexps[NUM_REGEXPS]; - /* Compiled forms of above strings. Also + /* Compiled forms of above strings. Also * malloc-ed, or NULL if not in use yet. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; @@ -98,121 +97,118 @@ int numChars, int nmatches, int flags)); static int SetRegexpFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); /* - * The regular expression Tcl object type. This serves as a cache - * of the compiled form of the regular expression. + * The regular expression Tcl object type. This serves as a cache of the + * compiled form of the regular expression. */ Tcl_ObjType tclRegexpType = { "regexp", /* name */ FreeRegexpInternalRep, /* freeIntRepProc */ DupRegexpInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ SetRegexpFromAny /* setFromAnyProc */ }; - /* *---------------------------------------------------------------------- * * Tcl_RegExpCompile -- * - * Compile a regular expression into a form suitable for fast - * matching. This procedure is DEPRECATED in favor of the - * object version of the command. + * Compile a regular expression into a form suitable for fast matching. + * This function is DEPRECATED in favor of the object version of the + * command. * * Results: - * The return value is a pointer to the compiled form of string, - * suitable for passing to Tcl_RegExpExec. This compiled form - * is only valid up until the next call to this procedure, so - * don't keep these around for a long time! If an error occurred - * while compiling the pattern, then NULL is returned and an error - * message is left in the interp's result. + * The return value is a pointer to the compiled form of string, suitable + * for passing to Tcl_RegExpExec. This compiled form is only valid up + * until the next call to this function, so don't keep these around for a + * long time! If an error occurred while compiling the pattern, then NULL + * is returned and an error message is left in the interp's result. * * Side effects: * Updates the cache of compiled regexps. * *---------------------------------------------------------------------- */ Tcl_RegExp -Tcl_RegExpCompile(interp, string) - Tcl_Interp *interp; /* For use in error reporting and - * to access the interp regexp cache. */ - CONST char *string; /* String for which to produce - * compiled regular expression. */ +Tcl_RegExpCompile(interp, pattern) + Tcl_Interp *interp; /* For use in error reporting and to access + * the interp regexp cache. */ + CONST char *pattern; /* String for which to produce compiled + * regular expression. */ { - return (Tcl_RegExp) CompileRegexp(interp, string, (int) strlen(string), + return (Tcl_RegExp) CompileRegexp(interp, pattern, (int) strlen(pattern), REG_ADVANCED); } /* *---------------------------------------------------------------------- * * Tcl_RegExpExec -- * - * Execute the regular expression matcher using a compiled form - * of a regular expression and save information about any match - * that is found. + * Execute the regular expression matcher using a compiled form of a + * regular expression and save information about any match that is found. * * Results: - * If an error occurs during the matching operation then -1 - * is returned and the interp's result contains an error message. - * Otherwise the return value is 1 if a matching range is - * found and 0 if there is no matching range. + * If an error occurs during the matching operation then -1 is returned + * and the interp's result contains an error message. Otherwise the + * return value is 1 if a matching range is found and 0 if there is no + * matching range. * * Side effects: * None. * *---------------------------------------------------------------------- */ int -Tcl_RegExpExec(interp, re, string, start) +Tcl_RegExpExec(interp, re, text, start) Tcl_Interp *interp; /* Interpreter to use for error reporting. */ - Tcl_RegExp re; /* Compiled regular expression; must have - * been returned by previous call to + Tcl_RegExp re; /* Compiled regular expression; must have been + * returned by previous call to * Tcl_GetRegExpFromObj. */ - CONST char *string; /* String against which to match re. */ - CONST char *start; /* If string is part of a larger string, - * this identifies beginning of larger - * string, so that "^" won't match. */ + CONST char *text; /* Text against which to match re. */ + CONST char *start; /* If text is part of a larger string, this + * identifies beginning of larger string, so + * that "^" won't match. */ { int flags, result, numChars; TclRegexp *regexp = (TclRegexp *)re; Tcl_DString ds; CONST Tcl_UniChar *ustr; /* - * If the starting point is offset from the beginning of the buffer, - * then we need to tell the regexp engine not to match "^". + * If the starting point is offset from the beginning of the buffer, then + * we need to tell the regexp engine not to match "^". */ - if (string > start) { + if (text > start) { flags = REG_NOTBOL; } else { flags = 0; } /* * Remember the string for use by Tcl_RegExpRange(). */ - regexp->string = string; + regexp->string = text; regexp->objPtr = NULL; /* * Convert the string to Unicode and perform the match. */ Tcl_DStringInit(&ds); - ustr = Tcl_UtfToUniCharDString(string, -1, &ds); + ustr = Tcl_UtfToUniCharDString(text, -1, &ds); numChars = Tcl_DStringLength(&ds) / sizeof(Tcl_UniChar); - result = RegExpExecUniChar(interp, re, ustr, numChars, - -1 /* nmatches */, flags); + result = RegExpExecUniChar(interp, re, ustr, numChars, -1 /* nmatches */, + flags); Tcl_DStringFree(&ds); return result; } @@ -224,11 +220,11 @@ * Returns pointers describing the range of a regular expression match, * or one of the subranges within the match. * * Results: * The variables at *startPtr and *endPtr are modified to hold the - * addresses of the endpoints of the range given by index. If the + * addresses of the endpoints of the range given by index. If the * specified range doesn't exist then NULLs are returned. * * Side effects: * None. * @@ -235,19 +231,19 @@ *--------------------------------------------------------------------------- */ void Tcl_RegExpRange(re, index, startPtr, endPtr) - Tcl_RegExp re; /* Compiled regular expression that has - * been passed to Tcl_RegExpExec. */ - int index; /* 0 means give the range of the entire - * match, > 0 means give the range of - * a matching subrange. */ + Tcl_RegExp re; /* Compiled regular expression that has been + * passed to Tcl_RegExpExec. */ + int index; /* 0 means give the range of the entire match, + * > 0 means give the range of a matching + * subrange. */ CONST char **startPtr; /* Store address of first character in - * (sub-) range here. */ + * (sub-)range here. */ CONST char **endPtr; /* Store address of character just after last - * in (sub-) range here. */ + * in (sub-)range here. */ { TclRegexp *regexpPtr = (TclRegexp *) re; CONST char *string; if ((size_t) index > regexpPtr->re.re_nsub) { @@ -269,18 +265,17 @@ *--------------------------------------------------------------------------- * * RegExpExecUniChar -- * * Execute the regular expression matcher using a compiled form of a - * regular expression and save information about any match that is - * found. + * regular expression and save information about any match that is found. * * Results: - * If an error occurs during the matching operation then -1 is - * returned and an error message is left in interp's result. - * Otherwise the return value is 1 if a matching range was found or - * 0 if there was no matching range. + * If an error occurs during the matching operation then -1 is returned + * and an error message is left in interp's result. Otherwise the return + * value is 1 if a matching range was found or 0 if there was no matching + * range. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -287,18 +282,18 @@ */ static int RegExpExecUniChar(interp, re, wString, numChars, nmatches, flags) Tcl_Interp *interp; /* Interpreter to use for error reporting. */ - Tcl_RegExp re; /* Compiled regular expression; returned by - * a previous call to Tcl_GetRegExpFromObj */ + Tcl_RegExp re; /* Compiled regular expression; returned by a + * previous call to Tcl_GetRegExpFromObj */ CONST Tcl_UniChar *wString; /* String against which to match re. */ - int numChars; /* Length of Tcl_UniChar string (must - * be >= 0). */ + int numChars; /* Length of Tcl_UniChar string (must be + * >=0). */ int nmatches; /* How many subexpression matches (counting - * the whole match as subexpression 0) are - * of interest. -1 means "don't know". */ + * the whole match as subexpression 0) are of + * interest. -1 means "don't know". */ int flags; /* Regular expression flags. */ { int status; TclRegexp *regexpPtr = (TclRegexp *) re; size_t last = regexpPtr->re.re_nsub + 1; @@ -337,31 +332,31 @@ * or one of the subranges within the match, or the hypothetical range * represented by the rm_extend field of the rm_detail_t. * * Results: * The variables at *startPtr and *endPtr are modified to hold the - * offsets of the endpoints of the range given by index. If the - * specified range doesn't exist then -1s are supplied. + * offsets of the endpoints of the range given by index. If the specified + * range doesn't exist then -1s are supplied. * * Side effects: * None. * *--------------------------------------------------------------------------- */ void TclRegExpRangeUniChar(re, index, startPtr, endPtr) - Tcl_RegExp re; /* Compiled regular expression that has - * been passed to Tcl_RegExpExec. */ - int index; /* 0 means give the range of the entire - * match, > 0 means give the range of - * a matching subrange, -1 means the - * range of the rm_extend field. */ + Tcl_RegExp re; /* Compiled regular expression that has been + * passed to Tcl_RegExpExec. */ + int index; /* 0 means give the range of the entire match, + * > 0 means give the range of a matching + * subrange, -1 means the range of the + * rm_extend field. */ int *startPtr; /* Store address of first character in - * (sub-) range here. */ + * (sub-)range here. */ int *endPtr; /* Store address of character just after last - * in (sub-) range here. */ + * in (sub-)range here. */ { TclRegexp *regexpPtr = (TclRegexp *) re; if ((regexpPtr->flags®_EXPECT) && index == -1) { *startPtr = regexpPtr->details.rm_extend.rm_so; @@ -381,35 +376,33 @@ * Tcl_RegExpMatch -- * * See if a string matches a regular expression. * * Results: - * If an error occurs during the matching operation then -1 - * is returned and the interp's result contains an error message. - * Otherwise the return value is 1 if "string" matches "pattern" - * and 0 otherwise. + * If an error occurs during the matching operation then -1 is returned + * and the interp's result contains an error message. Otherwise the + * return value is 1 if "text" matches "pattern" and 0 otherwise. * * Side effects: * None. * *---------------------------------------------------------------------- */ int -Tcl_RegExpMatch(interp, string, pattern) +Tcl_RegExpMatch(interp, text, pattern) Tcl_Interp *interp; /* Used for error reporting. May be NULL. */ - CONST char *string; /* String. */ - CONST char *pattern; /* Regular expression to match against - * string. */ + CONST char *text; /* Text to search for pattern matches. */ + CONST char *pattern; /* Regular expression to match against text. */ { Tcl_RegExp re; re = Tcl_RegExpCompile(interp, pattern); if (re == NULL) { return -1; } - return Tcl_RegExpExec(interp, re, string, string); + return Tcl_RegExpExec(interp, re, text, text); } /* *---------------------------------------------------------------------- * @@ -416,33 +409,32 @@ * Tcl_RegExpExecObj -- * * Execute a precompiled regexp against the given object. * * Results: - * If an error occurs during the matching operation then -1 - * is returned and the interp's result contains an error message. - * Otherwise the return value is 1 if "string" matches "pattern" - * and 0 otherwise. + * If an error occurs during the matching operation then -1 is returned + * and the interp's result contains an error message. Otherwise the + * return value is 1 if "string" matches "pattern" and 0 otherwise. * * Side effects: * Converts the object to a Unicode object. * *---------------------------------------------------------------------- */ int -Tcl_RegExpExecObj(interp, re, objPtr, offset, nmatches, flags) +Tcl_RegExpExecObj(interp, re, textObj, offset, nmatches, flags) Tcl_Interp *interp; /* Interpreter to use for error reporting. */ - Tcl_RegExp re; /* Compiled regular expression; must have - * been returned by previous call to + Tcl_RegExp re; /* Compiled regular expression; must have been + * returned by previous call to * Tcl_GetRegExpFromObj. */ - Tcl_Obj *objPtr; /* String against which to match re. */ + Tcl_Obj *textObj; /* Text against which to match re. */ int offset; /* Character index that marks where matching * should begin. */ int nmatches; /* How many subexpression matches (counting - * the whole match as subexpression 0) are - * of interest. -1 means all of them. */ + * the whole match as subexpression 0) are of + * interest. -1 means all of them. */ int flags; /* Regular expression execution flags. */ { TclRegexp *regexpPtr = (TclRegexp *) re; Tcl_UniChar *udata; int length; @@ -450,20 +442,20 @@ /* * Save the target object so we can extract strings from it later. */ regexpPtr->string = NULL; - regexpPtr->objPtr = objPtr; + regexpPtr->objPtr = textObj; - udata = Tcl_GetUnicodeFromObj(objPtr, &length); + udata = Tcl_GetUnicodeFromObj(textObj, &length); if (offset > length) { offset = length; } udata += offset; length -= offset; - + return RegExpExecUniChar(interp, re, udata, length, nmatches, flags); } /* *---------------------------------------------------------------------- @@ -471,25 +463,24 @@ * Tcl_RegExpMatchObj -- * * See if an object matches a regular expression. * * Results: - * If an error occurs during the matching operation then -1 - * is returned and the interp's result contains an error message. - * Otherwise the return value is 1 if "string" matches "pattern" - * and 0 otherwise. + * If an error occurs during the matching operation then -1 is returned + * and the interp's result contains an error message. Otherwise the + * return value is 1 if "text" matches "pattern" and 0 otherwise. * * Side effects: * Changes the internal rep of the pattern and string objects. * *---------------------------------------------------------------------- */ int -Tcl_RegExpMatchObj(interp, stringObj, patternObj) +Tcl_RegExpMatchObj(interp, textObj, patternObj) Tcl_Interp *interp; /* Used for error reporting. May be NULL. */ - Tcl_Obj *stringObj; /* Object containing the String to search. */ + Tcl_Obj *textObj; /* Object containing the String to search. */ Tcl_Obj *patternObj; /* Regular expression to match against * string. */ { Tcl_RegExp re; @@ -496,11 +487,11 @@ re = Tcl_GetRegExpFromObj(interp, patternObj, TCL_REG_ADVANCED | TCL_REG_NOSUB); if (re == NULL) { return -1; } - return Tcl_RegExpExecObj(interp, re, stringObj, 0 /* offset */, + return Tcl_RegExpExecObj(interp, re, textObj, 0 /* offset */, 0 /* nmatches */, 0 /* flags */); } /* *---------------------------------------------------------------------- @@ -519,11 +510,11 @@ */ void Tcl_RegExpGetInfo(regexp, infoPtr) Tcl_RegExp regexp; /* Pattern from which to get subexpressions. */ - Tcl_RegExpInfo *infoPtr; /* Match information is stored here. */ + Tcl_RegExpInfo *infoPtr; /* Match information is stored here. */ { TclRegexp *regexpPtr = (TclRegexp *) regexp; infoPtr->nsubs = regexpPtr->re.re_nsub; infoPtr->matches = (Tcl_RegExpIndices *) regexpPtr->matches; @@ -533,18 +524,18 @@ /* *---------------------------------------------------------------------- * * Tcl_GetRegExpFromObj -- * - * Compile a regular expression into a form suitable for fast - * matching. This procedure caches the result in a Tcl_Obj. + * Compile a regular expression into a form suitable for fast matching. + * This function caches the result in a Tcl_Obj. * * Results: - * The return value is a pointer to the compiled form of string, - * suitable for passing to Tcl_RegExpExec. If an error occurred - * while compiling the pattern, then NULL is returned and an error - * message is left in the interp's result. + * The return value is a pointer to the compiled form of string, suitable + * for passing to Tcl_RegExpExec. If an error occurred while compiling + * the pattern, then NULL is returned and an error message is left in the + * interp's result. * * Side effects: * Updates the native rep of the Tcl_Obj. * *---------------------------------------------------------------------- @@ -553,23 +544,24 @@ Tcl_RegExp Tcl_GetRegExpFromObj(interp, objPtr, flags) Tcl_Interp *interp; /* For use in error reporting, and to access * the interp regexp cache. */ Tcl_Obj *objPtr; /* Object whose string rep contains regular - * expression pattern. Internal rep will be + * expression pattern. Internal rep will be * changed to compiled form of this regular * expression. */ int flags; /* Regular expression compilation flags. */ { int length; TclRegexp *regexpPtr; char *pattern; /* - * This is OK because we only actually interpret this value - * properly as a TclRegexp* when the type is tclRegexpType. + * This is OK because we only actually interpret this value properly as a + * TclRegexp* when the type is tclRegexpType. */ + regexpPtr = (TclRegexp *) objPtr->internalRep.otherValuePtr; if ((objPtr->typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) { pattern = Tcl_GetStringFromObj(objPtr, &length); @@ -578,11 +570,11 @@ return NULL; } /* * Add a reference to the regexp so it will persist even if it is - * pushed out of the current thread's regexp cache. This reference + * pushed out of the current thread's regexp cache. This reference * will be removed when the object's internal rep is freed. */ regexpPtr->refCount++; @@ -603,14 +595,14 @@ * TclRegAbout -- * * Return information about a compiled regular expression. * * Results: - * The return value is -1 for failure, 0 for success, although at - * the moment there's nothing that could fail. On success, a list - * is left in the interp's result: first element is the subexpression - * count, second is a list of re_info bit names. + * The return value is -1 for failure, 0 for success, although at the + * moment there's nothing that could fail. On success, a list is left in + * the interp's result: first element is the subexpression count, second + * is a list of re_info bit names. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -650,13 +642,14 @@ sprintf(buf, "%u", (unsigned)(regexpPtr->re.re_nsub)); Tcl_AppendElement(interp, buf); /* - * Must count bits before generating list, because we must know - * whether {} are needed before we start appending names. + * Must count bits before generating list, because we must know whether {} + * are needed before we start appending names. */ + n = 0; for (inf = infonames; inf->bit != 0; inf++) { if (regexpPtr->re.re_info&inf->bit) { n++; } @@ -710,11 +703,10 @@ sprintf(cbuf, "%d", status); (VOID) TclReError(REG_ITOA, (regex_t *)NULL, cbuf, sizeof(cbuf)); Tcl_SetErrorCode(interp, "REGEXP", cbuf, buf, NULL); } - /* *---------------------------------------------------------------------- * * FreeRegexpInternalRep -- @@ -749,12 +741,12 @@ /* *---------------------------------------------------------------------- * * DupRegexpInternalRep -- * - * We copy the reference to the compiled regexp and bump its - * reference count. + * We copy the reference to the compiled regexp and bump its reference + * count. * * Results: * None. * * Side effects: @@ -767,10 +759,11 @@ DupRegexpInternalRep(srcPtr, copyPtr) Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ Tcl_Obj *copyPtr; /* Object with internal rep to set. */ { TclRegexp *regexpPtr = (TclRegexp *) srcPtr->internalRep.otherValuePtr; + regexpPtr->refCount++; copyPtr->internalRep.otherValuePtr = srcPtr->internalRep.otherValuePtr; copyPtr->typePtr = &tclRegexpType; } @@ -808,23 +801,23 @@ /* *--------------------------------------------------------------------------- * * CompileRegexp -- * - * Attempt to compile the given regexp pattern. If the compiled - * regular expression can be found in the per-thread cache, it - * will be used instead of compiling a new copy. + * Attempt to compile the given regexp pattern. If the compiled regular + * expression can be found in the per-thread cache, it will be used + * instead of compiling a new copy. * * Results: - * The return value is a pointer to a newly allocated TclRegexp - * that represents the compiled pattern, or NULL if the pattern - * could not be compiled. If NULL is returned, an error message is - * left in the interp's result. + * The return value is a pointer to a newly allocated TclRegexp that + * represents the compiled pattern, or NULL if the pattern could not be + * compiled. If NULL is returned, an error message is left in the + * interp's result. * * Side effects: - * The thread-local regexp cache is updated and a new TclRegexp may - * be allocated. + * The thread-local regexp cache is updated and a new TclRegexp may be + * allocated. * *---------------------------------------------------------------------- */ static TclRegexp * @@ -838,35 +831,35 @@ CONST Tcl_UniChar *uniString; int numChars; Tcl_DString stringBuf; int status, i; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - + if (!tsdPtr->initialized) { tsdPtr->initialized = 1; Tcl_CreateThreadExitHandler(FinalizeRegexp, NULL); } /* * This routine maintains a second-level regular expression cache in - * addition to the per-object regexp cache. The per-thread cache is needed + * addition to the per-object regexp cache. The per-thread cache is needed * to handle the case where for various reasons the object is lost between * invocations of the regexp command, but the literal pattern is the same. */ /* - * Check the per-thread compiled regexp cache. We can only reuse - * a regexp if it has the same pattern and the same flags. + * Check the per-thread compiled regexp cache. We can only reuse a regexp + * if it has the same pattern and the same flags. */ for (i = 0; (i < NUM_REGEXPS) && (tsdPtr->patterns[i] != NULL); i++) { if ((length == tsdPtr->patLengths[i]) && (tsdPtr->regexps[i]->flags == flags) && (strcmp(string, tsdPtr->patterns[i]) == 0)) { /* - * Move the matched pattern to the first slot in the - * cache and shift the other patterns down one position. + * Move the matched pattern to the first slot in the cache and + * shift the other patterns down one position. */ if (i != 0) { int j; char *cachedString; @@ -887,11 +880,11 @@ } /* * This is a new expression, so compile it and add it to the cache. */ - + regexpPtr = (TclRegexp *) ckalloc(sizeof(TclRegexp)); regexpPtr->objPtr = NULL; regexpPtr->string = NULL; regexpPtr->details.rm_extend.rm_so = -1; regexpPtr->details.rm_extend.rm_eo = -1; @@ -925,12 +918,12 @@ } return NULL; } /* - * Allocate enough space for all of the subexpressions, plus one - * extra for the entire pattern. + * Allocate enough space for all of the subexpressions, plus one extra for + * the entire pattern. */ regexpPtr->matches = (regmatch_t *) ckalloc( sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1)); @@ -1023,5 +1016,13 @@ FreeRegexp(regexpPtr); } ckfree(tsdPtr->patterns[i]); } } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclResolve.c ================================================================== --- generic/tclResolve.c +++ generic/tclResolve.c @@ -1,115 +1,112 @@ /* * tclResolve.c -- * - * Contains hooks for customized command/variable name resolution - * schemes. These hooks allow extensions like [incr Tcl] to add - * their own name resolution rules to the Tcl language. Rules can - * be applied to a particular namespace, to the interpreter as a - * whole, or both. + * Contains hooks for customized command/variable name resolution + * schemes. These hooks allow extensions like [incr Tcl] to add their own + * name resolution rules to the Tcl language. Rules can be applied to a + * particular namespace, to the interpreter as a whole, or both. * * Copyright (c) 1998 Lucent Technologies, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclResolve.c,v 1.4 2002/01/25 22:01:32 dgp Exp $ + * RCS: @(#) $Id: tclResolve.c,v 1.4.6.2 2005/08/02 18:16:07 dgp Exp $ */ #include "tclInt.h" /* - * Declarations for procedures local to this file: + * Declarations for functions local to this file: */ static void BumpCmdRefEpochs _ANSI_ARGS_((Namespace *nsPtr)); - /* *---------------------------------------------------------------------- * * Tcl_AddInterpResolvers -- * - * Adds a set of command/variable resolution procedures to an - * interpreter. These procedures are consulted when commands - * are resolved in Tcl_FindCommand, and when variables are - * resolved in TclLookupVar and LookupCompiledLocal. Each - * namespace may also have its own set of resolution procedures - * which take precedence over those for the interpreter. - * - * When a name is resolved, it is handled as follows. First, - * the name is passed to the resolution procedures for the - * namespace. If not resolved, the name is passed to each of - * the resolution procedures added to the interpreter. Finally, - * if still not resolved, the name is handled using the default - * Tcl rules for name resolution. + * Adds a set of command/variable resolution functions to an interpreter. + * These functions are consulted when commands are resolved in + * Tcl_FindCommand, and when variables are resolved in TclLookupVar and + * LookupCompiledLocal. Each namespace may also have its own set of + * resolution functions which take precedence over those for the + * interpreter. + * + * When a name is resolved, it is handled as follows. First, the name is + * passed to the resolution functions for the namespace. If not resolved, + * the name is passed to each of the resolution functions added to the + * interpreter. Finally, if still not resolved, the name is handled using + * the default Tcl rules for name resolution. * * Results: - * Returns pointers to the current name resolution procedures - * in the cmdProcPtr, varProcPtr and compiledVarProcPtr - * arguments. + * Returns pointers to the current name resolution functions in the + * cmdProcPtr, varProcPtr and compiledVarProcPtr arguments. * * Side effects: - * If a compiledVarProc is specified, this procedure bumps the - * compileEpoch for the interpreter, forcing all code to be - * recompiled. If a cmdProc is specified, this procedure bumps - * the cmdRefEpoch in all namespaces, forcing commands to be - * resolved again using the new rules. + * If a compiledVarProc is specified, this function bumps the + * compileEpoch for the interpreter, forcing all code to be recompiled. + * If a cmdProc is specified, this function bumps the cmdRefEpoch in all + * namespaces, forcing commands to be resolved again using the new rules. * *---------------------------------------------------------------------- */ void Tcl_AddInterpResolvers(interp, name, cmdProc, varProc, compiledVarProc) - Tcl_Interp *interp; /* Interpreter whose name resolution * rules are being modified. */ CONST char *name; /* Name of this resolution scheme. */ - Tcl_ResolveCmdProc *cmdProc; /* New procedure for command - * resolution */ - Tcl_ResolveVarProc *varProc; /* Procedure for variable resolution - * at runtime */ + Tcl_ResolveCmdProc *cmdProc; /* New function for command + * resolution. */ + Tcl_ResolveVarProc *varProc; /* Function for variable resolution at + * runtime. */ Tcl_ResolveCompiledVarProc *compiledVarProc; - /* Procedure for variable resolution - * at compile time. */ + /* Function for variable resolution at + * compile time. */ { - Interp *iPtr = (Interp*)interp; + Interp *iPtr = (Interp *) interp; ResolverScheme *resPtr; /* - * Since we're adding a new name resolution scheme, we must force - * all code to be recompiled to use the new scheme. If there - * are new compiled variable resolution rules, bump the compiler - * epoch to invalidate compiled code. If there are new command - * resolution rules, bump the cmdRefEpoch in all namespaces. - */ - if (compiledVarProc) { - iPtr->compileEpoch++; - } - if (cmdProc) { - BumpCmdRefEpochs(iPtr->globalNsPtr); - } - - /* - * Look for an existing scheme with the given name. If found, - * then replace its rules. - */ - for (resPtr = iPtr->resolverPtr; resPtr != NULL; resPtr = resPtr->nextPtr) { - if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) { - resPtr->cmdResProc = cmdProc; - resPtr->varResProc = varProc; - resPtr->compiledVarResProc = compiledVarProc; - return; - } - } - - /* - * Otherwise, this is a new scheme. Add it to the FRONT - * of the linked list, so that it overrides existing schemes. - */ - resPtr = (ResolverScheme *) ckalloc(sizeof(ResolverScheme)); - resPtr->name = (char*)ckalloc((unsigned)(strlen(name)+1)); + * Since we're adding a new name resolution scheme, we must force all code + * to be recompiled to use the new scheme. If there are new compiled + * variable resolution rules, bump the compiler epoch to invalidate + * compiled code. If there are new command resolution rules, bump the + * cmdRefEpoch in all namespaces. + */ + + if (compiledVarProc) { + iPtr->compileEpoch++; + } + if (cmdProc) { + BumpCmdRefEpochs(iPtr->globalNsPtr); + } + + /* + * Look for an existing scheme with the given name. If found, then replace + * its rules. + */ + + for (resPtr=iPtr->resolverPtr ; resPtr!=NULL ; resPtr=resPtr->nextPtr) { + if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) { + resPtr->cmdResProc = cmdProc; + resPtr->varResProc = varProc; + resPtr->compiledVarResProc = compiledVarProc; + return; + } + } + + /* + * Otherwise, this is a new scheme. Add it to the FRONT of the linked + * list, so that it overrides existing schemes. + */ + + resPtr = (ResolverScheme *) ckalloc(sizeof(ResolverScheme)); + resPtr->name = (char *) ckalloc((unsigned)(strlen(name) + 1)); strcpy(resPtr->name, name); resPtr->cmdResProc = cmdProc; resPtr->varResProc = varProc; resPtr->compiledVarResProc = compiledVarProc; resPtr->nextPtr = iPtr->resolverPtr; @@ -119,49 +116,48 @@ /* *---------------------------------------------------------------------- * * Tcl_GetInterpResolvers -- * - * Looks for a set of command/variable resolution procedures with - * the given name in an interpreter. These procedures are - * registered by calling Tcl_AddInterpResolvers. + * Looks for a set of command/variable resolution functions with the + * given name in an interpreter. These functions are registered by + * calling Tcl_AddInterpResolvers. * * Results: - * If the name is recognized, this procedure returns non-zero, - * along with pointers to the name resolution procedures in - * the Tcl_ResolverInfo structure. If the name is not recognized, - * this procedure returns zero. + * If the name is recognized, this function returns non-zero, along with + * pointers to the name resolution functions in the Tcl_ResolverInfo + * structure. If the name is not recognized, this function returns zero. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_GetInterpResolvers(interp, name, resInfoPtr) - Tcl_Interp *interp; /* Interpreter whose name resolution * rules are being queried. */ - CONST char *name; /* Look for a scheme with this name. */ - Tcl_ResolverInfo *resInfoPtr; /* Returns pointers to the procedures, + CONST char *name; /* Look for a scheme with this name. */ + Tcl_ResolverInfo *resInfoPtr; /* Returns pointers to the functions, * if found */ { - Interp *iPtr = (Interp*)interp; + Interp *iPtr = (Interp *) interp; ResolverScheme *resPtr; /* - * Look for an existing scheme with the given name. If found, - * then return pointers to its procedures. + * Look for an existing scheme with the given name. If found, then return + * pointers to its functions. */ - for (resPtr = iPtr->resolverPtr; resPtr != NULL; resPtr = resPtr->nextPtr) { - if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) { + + for (resPtr=iPtr->resolverPtr ; resPtr!=NULL ; resPtr=resPtr->nextPtr) { + if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) { resInfoPtr->cmdResProc = resPtr->cmdResProc; resInfoPtr->varResProc = resPtr->varResProc; resInfoPtr->compiledVarResProc = resPtr->compiledVarResProc; - return 1; - } + return 1; + } } return 0; } @@ -168,92 +164,93 @@ /* *---------------------------------------------------------------------- * * Tcl_RemoveInterpResolvers -- * - * Removes a set of command/variable resolution procedures - * previously added by Tcl_AddInterpResolvers. The next time - * a command/variable name is resolved, these procedures - * won't be consulted. + * Removes a set of command/variable resolution functions previously + * added by Tcl_AddInterpResolvers. The next time a command/variable name + * is resolved, these functions won't be consulted. * * Results: - * Returns non-zero if the name was recognized and the - * resolution scheme was deleted. Returns zero otherwise. + * Returns non-zero if the name was recognized and the resolution scheme + * was deleted. Returns zero otherwise. * * Side effects: - * If a scheme with a compiledVarProc was deleted, this procedure - * bumps the compileEpoch for the interpreter, forcing all code - * to be recompiled. If a scheme with a cmdProc was deleted, - * this procedure bumps the cmdRefEpoch in all namespaces, - * forcing commands to be resolved again using the new rules. + * If a scheme with a compiledVarProc was deleted, this function bumps + * the compileEpoch for the interpreter, forcing all code to be + * recompiled. If a scheme with a cmdProc was deleted, this function + * bumps the cmdRefEpoch in all namespaces, forcing commands to be + * resolved again using the new rules. * *---------------------------------------------------------------------- */ int Tcl_RemoveInterpResolvers(interp, name) - - Tcl_Interp *interp; /* Interpreter whose name resolution - * rules are being modified. */ - CONST char *name; /* Name of the scheme to be removed. */ -{ - Interp *iPtr = (Interp*)interp; - ResolverScheme **prevPtrPtr, *resPtr; - - /* - * Look for an existing scheme with the given name. - */ - prevPtrPtr = &iPtr->resolverPtr; - for (resPtr = iPtr->resolverPtr; resPtr != NULL; resPtr = resPtr->nextPtr) { - if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) { - break; - } - prevPtrPtr = &resPtr->nextPtr; - } - - /* - * If we found the scheme, delete it. - */ - if (resPtr) { - /* - * If we're deleting a scheme with compiled variable resolution - * rules, bump the compiler epoch to invalidate compiled code. - * If we're deleting a scheme with command resolution rules, - * bump the cmdRefEpoch in all namespaces. - */ - if (resPtr->compiledVarResProc) { - iPtr->compileEpoch++; - } - if (resPtr->cmdResProc) { - BumpCmdRefEpochs(iPtr->globalNsPtr); - } - - *prevPtrPtr = resPtr->nextPtr; - ckfree(resPtr->name); - ckfree((char *) resPtr); - - return 1; + Tcl_Interp *interp; /* Interpreter whose name resolution + * rules are being modified. */ + CONST char *name; /* Name of the scheme to be removed. */ +{ + Interp *iPtr = (Interp *) interp; + ResolverScheme **prevPtrPtr, *resPtr; + + /* + * Look for an existing scheme with the given name. + */ + + prevPtrPtr = &iPtr->resolverPtr; + for (resPtr=iPtr->resolverPtr ; resPtr!=NULL ; resPtr=resPtr->nextPtr) { + if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) { + break; + } + prevPtrPtr = &resPtr->nextPtr; + } + + /* + * If we found the scheme, delete it. + */ + + if (resPtr) { + /* + * If we're deleting a scheme with compiled variable resolution rules, + * bump the compiler epoch to invalidate compiled code. If we're + * deleting a scheme with command resolution rules, bump the + * cmdRefEpoch in all namespaces. + */ + + if (resPtr->compiledVarResProc) { + iPtr->compileEpoch++; + } + if (resPtr->cmdResProc) { + BumpCmdRefEpochs(iPtr->globalNsPtr); + } + + *prevPtrPtr = resPtr->nextPtr; + ckfree(resPtr->name); + ckfree((char *) resPtr); + + return 1; } return 0; } /* *---------------------------------------------------------------------- * * BumpCmdRefEpochs -- * - * This procedure is used to bump the cmdRefEpoch counters in - * the specified namespace and all of its child namespaces. - * It is used whenever name resolution schemes are added/removed - * from an interpreter, to invalidate all command references. + * This function is used to bump the cmdRefEpoch counters in the + * specified namespace and all of its child namespaces. It is used + * whenever name resolution schemes are added/removed from an + * interpreter, to invalidate all command references. * * Results: * None. * * Side effects: - * Bumps the cmdRefEpoch in the specified namespace and its - * children, recursively. + * Bumps the cmdRefEpoch in the specified namespace and its children, + * recursively. * *---------------------------------------------------------------------- */ static void @@ -260,159 +257,157 @@ BumpCmdRefEpochs(nsPtr) Namespace *nsPtr; /* Namespace being modified. */ { Tcl_HashEntry *entry; Tcl_HashSearch search; - Namespace *childNsPtr; nsPtr->cmdRefEpoch++; for (entry = Tcl_FirstHashEntry(&nsPtr->childTable, &search); - entry != NULL; - entry = Tcl_NextHashEntry(&search)) { - - childNsPtr = (Namespace *) Tcl_GetHashValue(entry); - BumpCmdRefEpochs(childNsPtr); - } -} - + entry != NULL; entry = Tcl_NextHashEntry(&search)) { + Namespace *childNsPtr = (Namespace *) Tcl_GetHashValue(entry); + BumpCmdRefEpochs(childNsPtr); + } + TclInvalidateNsPath(nsPtr); +} /* *---------------------------------------------------------------------- * * Tcl_SetNamespaceResolvers -- * - * Sets the command/variable resolution procedures for a namespace, - * thereby changing the way that command/variable names are - * interpreted. This allows extension writers to support different - * name resolution schemes, such as those for object-oriented - * packages. - * - * Command resolution is handled by a procedure of the following - * type: - * - * typedef int (Tcl_ResolveCmdProc) _ANSI_ARGS_(( - * Tcl_Interp* interp, CONST char* name, Tcl_Namespace *context, - * int flags, Tcl_Command *rPtr)); - * - * Whenever a command is executed or Tcl_FindCommand is invoked - * within the namespace, this procedure is called to resolve the - * command name. If this procedure is able to resolve the name, - * it should return the status code TCL_OK, along with the - * corresponding Tcl_Command in the rPtr argument. Otherwise, - * the procedure can return TCL_CONTINUE, and the command will - * be treated under the usual name resolution rules. Or, it can - * return TCL_ERROR, and the command will be considered invalid. - * - * Variable resolution is handled by two procedures. The first - * is called whenever a variable needs to be resolved at compile - * time: - * - * typedef int (Tcl_ResolveCompiledVarProc) _ANSI_ARGS_(( - * Tcl_Interp* interp, CONST char* name, Tcl_Namespace *context, - * Tcl_ResolvedVarInfo *rPtr)); - * - * If this procedure is able to resolve the name, it should return - * the status code TCL_OK, along with variable resolution info in - * the rPtr argument; this info will be used to set up compiled - * locals in the call frame at runtime. The procedure may also - * return TCL_CONTINUE, and the variable will be treated under - * the usual name resolution rules. Or, it can return TCL_ERROR, - * and the variable will be considered invalid. - * - * Another procedure is used whenever a variable needs to be - * resolved at runtime but it is not recognized as a compiled local. - * (For example, the variable may be requested via - * Tcl_FindNamespaceVar.) This procedure has the following type: - * - * typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_(( - * Tcl_Interp* interp, CONST char* name, Tcl_Namespace *context, - * int flags, Tcl_Var *rPtr)); - * - * This procedure is quite similar to the compile-time version. - * It returns the same status codes, but if variable resolution - * succeeds, this procedure returns a Tcl_Var directly via the - * rPtr argument. + * Sets the command/variable resolution functions for a namespace, + * thereby changing the way that command/variable names are interpreted. + * This allows extension writers to support different name resolution + * schemes, such as those for object-oriented packages. + * + * Command resolution is handled by a function of the following type: + * + * typedef int (*Tcl_ResolveCmdProc)(Tcl_Interp *interp, + * CONST char *name, Tcl_Namespace *context, + * int flags, Tcl_Command *rPtr); + * + * Whenever a command is executed or Tcl_FindCommand is invoked within + * the namespace, this function is called to resolve the command name. + * If this function is able to resolve the name, it should return the + * status code TCL_OK, along with the corresponding Tcl_Command in the + * rPtr argument. Otherwise, the function can return TCL_CONTINUE, and + * the command will be treated under the usual name resolution rules. + * Or, it can return TCL_ERROR, and the command will be considered + * invalid. + * + * Variable resolution is handled by two functions. The first is called + * whenever a variable needs to be resolved at compile time: + * + * typedef int (*Tcl_ResolveCompiledVarProc)(Tcl_Interp *interp, + * CONST char *name, Tcl_Namespace *context, + * Tcl_ResolvedVarInfo *rPtr); + * + * If this function is able to resolve the name, it should return the + * status code TCL_OK, along with variable resolution info in the rPtr + * argument; this info will be used to set up compiled locals in the call + * frame at runtime. The function may also return TCL_CONTINUE, and the + * variable will be treated under the usual name resolution rules. Or, it + * can return TCL_ERROR, and the variable will be considered invalid. + * + * Another function is used whenever a variable needs to be resolved at + * runtime but it is not recognized as a compiled local. (For example, + * the variable may be requested via Tcl_FindNamespaceVar.) This function + * has the following type: + * + * typedef int (*Tcl_ResolveVarProc)(Tcl_Interp *interp, + * CONST char *name, Tcl_Namespace *context, + * int flags, Tcl_Var *rPtr); + * + * This function is quite similar to the compile-time version. It returns + * the same status codes, but if variable resolution succeeds, this + * function returns a Tcl_Var directly via the rPtr argument. * * Results: * Nothing. * * Side effects: - * Bumps the command epoch counter for the namespace, invalidating - * all command references in that namespace. Also bumps the - * resolver epoch counter for the namespace, forcing all code - * in the namespace to be recompiled. + * Bumps the command epoch counter for the namespace, invalidating all + * command references in that namespace. Also bumps the resolver epoch + * counter for the namespace, forcing all code in the namespace to be + * recompiled. * *---------------------------------------------------------------------- */ void Tcl_SetNamespaceResolvers(namespacePtr, cmdProc, varProc, compiledVarProc) Tcl_Namespace *namespacePtr; /* Namespace whose resolution rules * are being modified. */ - Tcl_ResolveCmdProc *cmdProc; /* Procedure for command resolution */ - Tcl_ResolveVarProc *varProc; /* Procedure for variable resolution - * at runtime */ + Tcl_ResolveCmdProc *cmdProc; /* Function for command resolution */ + Tcl_ResolveVarProc *varProc; /* Function for variable resolution at + * run-time */ Tcl_ResolveCompiledVarProc *compiledVarProc; - /* Procedure for variable resolution - * at compile time. */ + /* Function for variable resolution at + * compile time. */ { - Namespace *nsPtr = (Namespace*)namespacePtr; + Namespace *nsPtr = (Namespace *) namespacePtr; /* - * Plug in the new command resolver, and bump the epoch counters - * so that all code will have to be recompiled and all commands - * will have to be resolved again using the new policy. + * Plug in the new command resolver, and bump the epoch counters so that + * all code will have to be recompiled and all commands will have to be + * resolved again using the new policy. */ + nsPtr->cmdResProc = cmdProc; nsPtr->varResProc = varProc; nsPtr->compiledVarResProc = compiledVarProc; nsPtr->cmdRefEpoch++; nsPtr->resolverEpoch++; + TclInvalidateNsPath(nsPtr); } /* *---------------------------------------------------------------------- * * Tcl_GetNamespaceResolvers -- * - * Returns the current command/variable resolution procedures - * for a namespace. By default, these procedures are NULL. - * New procedures can be installed by calling - * Tcl_SetNamespaceResolvers, to provide new name resolution - * rules. + * Returns the current command/variable resolution functions for a + * namespace. By default, these functions are NULL. New functions can be + * installed by calling Tcl_SetNamespaceResolvers, to provide new name + * resolution rules. * * Results: - * Returns non-zero if any name resolution procedures have been - * assigned to this namespace; also returns pointers to the - * procedures in the Tcl_ResolverInfo structure. Returns zero - * otherwise. + * Returns non-zero if any name resolution functions have been assigned + * to this namespace; also returns pointers to the functions in the + * Tcl_ResolverInfo structure. Returns zero otherwise. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_GetNamespaceResolvers(namespacePtr, resInfoPtr) - Tcl_Namespace *namespacePtr; /* Namespace whose resolution rules * are being modified. */ - Tcl_ResolverInfo *resInfoPtr; /* Returns: pointers for all - * name resolution procedures - * assigned to this namespace. */ + Tcl_ResolverInfo *resInfoPtr; /* Returns: pointers for all name + * resolution functions assigned to + * this namespace. */ { - Namespace *nsPtr = (Namespace*)namespacePtr; + Namespace *nsPtr = (Namespace *) namespacePtr; resInfoPtr->cmdResProc = nsPtr->cmdResProc; resInfoPtr->varResProc = nsPtr->varResProc; resInfoPtr->compiledVarResProc = nsPtr->compiledVarResProc; - if (nsPtr->cmdResProc != NULL || - nsPtr->varResProc != NULL || - nsPtr->compiledVarResProc != NULL) { + if (nsPtr->cmdResProc != NULL || nsPtr->varResProc != NULL || + nsPtr->compiledVarResProc != NULL) { return 1; } return 0; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclResult.c ================================================================== --- generic/tclResult.c +++ generic/tclResult.c @@ -1,66 +1,67 @@ -/* +/* * tclResult.c -- * * This file contains code to manage the interpreter result. * * Copyright (c) 1997 by Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclResult.c,v 1.23 2004/11/23 00:12:57 dkf Exp $ + * RCS: @(#) $Id: tclResult.c,v 1.23.2.5 2005/09/15 20:58:40 dgp Exp $ */ #include "tclInt.h" -/* Indices of the standard return options dictionary keys */ +/* + * Indices of the standard return options dictionary keys. + */ + enum returnKeys { KEY_CODE, KEY_ERRORCODE, KEY_ERRORINFO, KEY_ERRORLINE, KEY_LEVEL, KEY_OPTIONS, KEY_LAST }; /* - * Function prototypes for local procedures in this file: + * Function prototypes for local functions in this file: */ -static Tcl_Obj ** GetKeys(); +static Tcl_Obj ** GetKeys _ANSI_ARGS_((void)); static void ReleaseKeys _ANSI_ARGS_((ClientData clientData)); -static void ResetObjResult _ANSI_ARGS_((Interp *iPtr)); +static void ResetObjResult _ANSI_ARGS_((Interp *iPtr)); static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr, int newSpace)); /* - * This structure is used to take a snapshot of the interpreter - * state in Tcl_SaveInterpState. You can snapshot the state, - * execute a command, and then back up to the result or the - * error that was previously in progress. + * This structure is used to take a snapshot of the interpreter state in + * Tcl_SaveInterpState. You can snapshot the state, execute a command, and + * then back up to the result or the error that was previously in progress. */ + typedef struct InterpState { int status; /* return code status */ - int flags; /* Each remaining field saves */ - int returnLevel; /* the corresponding field of */ - int returnCode; /* the Interp struct. These */ - Tcl_Obj *errorInfo; /* fields take together are the */ - Tcl_Obj *errorCode; /* "state" of the interp. */ + int flags; /* Each remaining field saves the */ + int returnLevel; /* corresponding field of the Interp */ + int returnCode; /* struct. These fields taken together are */ + Tcl_Obj *errorInfo; /* the "state" of the interp. */ + Tcl_Obj *errorCode; Tcl_Obj *returnOpts; Tcl_Obj *objResult; } InterpState; - /* *---------------------------------------------------------------------- * * Tcl_SaveInterpState -- * - * Fills a token with a snapshot of the current state of the - * interpreter. The snapshot can be restored at any point by - * TclRestoreInterpState. + * Fills a token with a snapshot of the current state of the interpreter. + * The snapshot can be restored at any point by TclRestoreInterpState. * - * The token returned must be eventally passed to one of the - * routines TclRestoreInterpState or TclDiscardInterpState, - * or there will be a memory leak. + * The token returned must be eventally passed to one of the routines + * TclRestoreInterpState or TclDiscardInterpState, or there will be a + * memory leak. * * Results: * Returns a token representing the interp state. * * Side effects: @@ -69,12 +70,12 @@ *---------------------------------------------------------------------- */ Tcl_InterpState Tcl_SaveInterpState(interp, status) - Tcl_Interp* interp; /* Interpreter's state to be saved */ - int status; /* status code for current operation */ + Tcl_Interp* interp; /* Interpreter's state to be saved */ + int status; /* status code for current operation */ { Interp *iPtr = (Interp *)interp; InterpState *statePtr = (InterpState *)ckalloc(sizeof(InterpState)); statePtr->status = status; @@ -101,13 +102,13 @@ /* *---------------------------------------------------------------------- * * Tcl_RestoreInterpState -- * - * Accepts an interp and a token previously returned by - * Tcl_SaveInterpState. Restore the state of the interp - * to what it was at the time of the Tcl_SaveInterpState call. + * Accepts an interp and a token previously returned by + * Tcl_SaveInterpState. Restore the state of the interp to what it was at + * the time of the Tcl_SaveInterpState call. * * Results: * Returns the status value originally passed in to Tcl_SaveInterpState. * * Side effects: @@ -159,12 +160,12 @@ /* *---------------------------------------------------------------------- * * Tcl_DiscardInterpState -- * - * Accepts a token previously returned by Tcl_SaveInterpState. - * Frees the memory it uses. + * Accepts a token previously returned by Tcl_SaveInterpState. Frees the + * memory it uses. * * Results: * None. * * Side effects: @@ -178,17 +179,17 @@ Tcl_InterpState state; /* saved interpreter state */ { InterpState *statePtr = (InterpState *)state; if (statePtr->errorInfo) { - Tcl_DecrRefCount(statePtr->errorInfo); + Tcl_DecrRefCount(statePtr->errorInfo); } if (statePtr->errorCode) { - Tcl_DecrRefCount(statePtr->errorCode); + Tcl_DecrRefCount(statePtr->errorCode); } if (statePtr->returnOpts) { - Tcl_DecrRefCount(statePtr->returnOpts); + Tcl_DecrRefCount(statePtr->returnOpts); } Tcl_DecrRefCount(statePtr->objResult); ckfree((char*) statePtr); } @@ -195,19 +196,17 @@ /* *---------------------------------------------------------------------- * * Tcl_SaveResult -- * - * Takes a snapshot of the current result state of the interpreter. - * The snapshot can be restored at any point by - * Tcl_RestoreResult. Note that this routine does not - * preserve the errorCode, errorInfo, or flags fields so it - * should not be used if an error is in progress. - * - * Once a snapshot is saved, it must be restored by calling - * Tcl_RestoreResult, or discarded by calling - * Tcl_DiscardResult. + * Takes a snapshot of the current result state of the interpreter. The + * snapshot can be restored at any point by Tcl_RestoreResult. Note that + * this routine does not preserve the errorCode, errorInfo, or flags + * fields so it should not be used if an error is in progress. + * + * Once a snapshot is saved, it must be restored by calling + * Tcl_RestoreResult, or discarded by calling Tcl_DiscardResult. * * Results: * None. * * Side effects: @@ -222,21 +221,21 @@ Tcl_SavedResult *statePtr; /* Pointer to state structure. */ { Interp *iPtr = (Interp *) interp; /* - * Move the result object into the save state. Note that we don't need - * to change its refcount because we're moving it, not adding a new - * reference. Put an empty object into the interpreter. + * Move the result object into the save state. Note that we don't need to + * change its refcount because we're moving it, not adding a new + * reference. Put an empty object into the interpreter. */ statePtr->objResultPtr = iPtr->objResultPtr; - iPtr->objResultPtr = Tcl_NewObj(); - Tcl_IncrRefCount(iPtr->objResultPtr); + iPtr->objResultPtr = Tcl_NewObj(); + Tcl_IncrRefCount(iPtr->objResultPtr); /* - * Save the string result. + * Save the string result. */ statePtr->freeProc = iPtr->freeProc; if (iPtr->result == iPtr->resultSpace) { /* @@ -275,19 +274,19 @@ /* *---------------------------------------------------------------------- * * Tcl_RestoreResult -- * - * Restores the state of the interpreter to a snapshot taken - * by Tcl_SaveResult. After this call, the token for - * the interpreter state is no longer valid. + * Restores the state of the interpreter to a snapshot taken by + * Tcl_SaveResult. After this call, the token for the interpreter state + * is no longer valid. * * Results: - * None. + * None. * * Side effects: - * Restores the interpreter result. + * Restores the interpreter result. * *---------------------------------------------------------------------- */ void @@ -343,20 +342,19 @@ /* *---------------------------------------------------------------------- * * Tcl_DiscardResult -- * - * Frees the memory associated with an interpreter snapshot - * taken by Tcl_SaveResult. If the snapshot is not - * restored, this procedure must be called to discard it, - * or the memory will be lost. + * Frees the memory associated with an interpreter snapshot taken by + * Tcl_SaveResult. If the snapshot is not restored, this function must be + * called to discard it, or the memory will be lost. * * Results: - * None. + * None. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ void @@ -379,60 +377,60 @@ /* *---------------------------------------------------------------------- * * Tcl_SetResult -- * - * Arrange for "string" to be the Tcl return value. + * Arrange for "result" to be the Tcl return value. * * Results: * None. * * Side effects: - * interp->result is left pointing either to "string" (if "copy" is 0) - * or to a copy of string. Also, the object result is reset. + * interp->result is left pointing either to "result" or to a copy of it. + * Also, the object result is reset. * *---------------------------------------------------------------------- */ void -Tcl_SetResult(interp, stringPtr, freeProc) +Tcl_SetResult(interp, result, freeProc) Tcl_Interp *interp; /* Interpreter with which to associate the * return value. */ - register char *stringPtr; /* Value to be returned. If NULL, the - * result is set to an empty string. */ + register char *result; /* Value to be returned. If NULL, the result + * is set to an empty string. */ Tcl_FreeProc *freeProc; /* Gives information about the string: - * TCL_STATIC, TCL_VOLATILE, or the address - * of a Tcl_FreeProc such as free. */ + * TCL_STATIC, TCL_VOLATILE, or the address of + * a Tcl_FreeProc such as free. */ { Interp *iPtr = (Interp *) interp; int length; register Tcl_FreeProc *oldFreeProc = iPtr->freeProc; char *oldResult = iPtr->result; - if (stringPtr == NULL) { + if (result == NULL) { iPtr->resultSpace[0] = 0; iPtr->result = iPtr->resultSpace; iPtr->freeProc = 0; } else if (freeProc == TCL_VOLATILE) { - length = strlen(stringPtr); + length = strlen(result); if (length > TCL_RESULT_SIZE) { iPtr->result = (char *) ckalloc((unsigned) length+1); iPtr->freeProc = TCL_DYNAMIC; } else { iPtr->result = iPtr->resultSpace; iPtr->freeProc = 0; } - strcpy(iPtr->result, stringPtr); + strcpy(iPtr->result, result); } else { - iPtr->result = stringPtr; + iPtr->result = result; iPtr->freeProc = freeProc; } /* - * If the old result was dynamically-allocated, free it up. Do it - * here, rather than at the beginning, in case the new result value - * was part of the old result value. + * If the old result was dynamically-allocated, free it up. Do it here, + * rather than at the beginning, in case the new result value was part of + * the old result value. */ if (oldFreeProc != 0) { if (oldFreeProc == TCL_DYNAMIC) { ckfree(oldResult); @@ -465,20 +463,20 @@ *---------------------------------------------------------------------- */ CONST char * Tcl_GetStringResult(interp) - register Tcl_Interp *interp; /* Interpreter whose result to return. */ + register Tcl_Interp *interp;/* Interpreter whose result to return. */ { /* - * If the string result is empty, move the object result to the - * string result, then reset the object result. + * If the string result is empty, move the object result to the string + * result, then reset the object result. */ - + if (*(interp->result) == 0) { Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), - TCL_VOLATILE); + TCL_VOLATILE); } return interp->result; } /* @@ -490,38 +488,36 @@ * * Results: * None. * * Side effects: - * interp->objResultPtr is left pointing to the object referenced - * by objPtr. The object's reference count is incremented since - * there is now a new reference to it. The reference count for any - * old objResultPtr value is decremented. Also, the string result - * is reset. + * interp->objResultPtr is left pointing to the object referenced by + * objPtr. The object's reference count is incremented since there is now + * a new reference to it. The reference count for any old objResultPtr + * value is decremented. Also, the string result is reset. * *---------------------------------------------------------------------- */ void Tcl_SetObjResult(interp, objPtr) Tcl_Interp *interp; /* Interpreter with which to associate the * return object value. */ - register Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the - * obj result is made an empty string - * object. */ + register Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the obj + * result is made an empty string object. */ { register Interp *iPtr = (Interp *) interp; register Tcl_Obj *oldObjResult = iPtr->objResultPtr; iPtr->objResultPtr = objPtr; Tcl_IncrRefCount(objPtr); /* since interp result is a reference */ /* - * We wait until the end to release the old object result, in case - * we are setting the result to itself. + * We wait until the end to release the old object result, in case we are + * setting the result to itself. */ - + TclDecrRefCount(oldObjResult); /* * Reset the string result since we just set the result object. */ @@ -542,21 +538,21 @@ *---------------------------------------------------------------------- * * Tcl_GetObjResult -- * * Returns an interpreter's result value as a Tcl object. The object's - * reference count is not modified; the caller must do that if it - * needs to hold on to a long-term reference to it. + * reference count is not modified; the caller must do that if it needs + * to hold on to a long-term reference to it. * * Results: * The interpreter's result as an object. * * Side effects: - * If the interpreter has a non-empty string result, the result object - * is either empty or stale because some procedure set interp->result - * directly. If so, the string result is moved to the result object - * then the string result is reset. + * If the interpreter has a non-empty string result, the result object is + * either empty or stale because some function set interp->result + * directly. If so, the string result is moved to the result object then + * the string result is reset. * *---------------------------------------------------------------------- */ Tcl_Obj * @@ -566,21 +562,21 @@ register Interp *iPtr = (Interp *) interp; Tcl_Obj *objResultPtr; int length; /* - * If the string result is non-empty, move the string result to the - * object result, then reset the string result. + * If the string result is non-empty, move the string result to the object + * result, then reset the string result. */ - + if (*(iPtr->result) != 0) { ResetObjResult(iPtr); - + objResultPtr = iPtr->objResultPtr; length = strlen(iPtr->result); TclInitStringRep(objResultPtr, iPtr->result, length); - + if (iPtr->freeProc != NULL) { if (iPtr->freeProc == TCL_DYNAMIC) { ckfree(iPtr->result); } else { (*iPtr->freeProc)(iPtr->result); @@ -596,24 +592,21 @@ /* *---------------------------------------------------------------------- * * Tcl_AppendResultVA -- * - * Append a variable number of strings onto the interpreter's - * result. + * Append a variable number of strings onto the interpreter's result. * * Results: * None. * * Side effects: - * The result of the interpreter given by the first argument is - * extended by the strings in the va_list (up to a terminating - * NULL argument). + * The result of the interpreter given by the first argument is extended + * by the strings in the va_list (up to a terminating NULL argument). * - * If the string result is non-empty, the object result forced to - * be a duplicate of it first. There will be a string result - * afterwards. + * If the string result is non-empty, the object result forced to be a + * duplicate of it first. There will be a string result afterwards. * *---------------------------------------------------------------------- */ void @@ -627,23 +620,23 @@ if (Tcl_IsShared(objPtr)) { objPtr = Tcl_DuplicateObj(objPtr); } Tcl_AppendStringsToObjVA(objPtr, argList); Tcl_SetObjResult(interp, objPtr); + /* - * Strictly we should call Tcl_GetStringResult(interp) here to - * make sure that interp->result is correct according to the old - * contract, but that makes the performance of much code (e.g. in - * Tk) absolutely awful. So we leave it out; code that really - * wants interp->result can just insert the calls to - * Tcl_GetStringResult() itself. [Patch 1041072 discussion] + * Strictly we should call Tcl_GetStringResult(interp) here to make sure + * that interp->result is correct according to the old contract, but that + * makes the performance of much code (e.g. in Tk) absolutely awful. So we + * leave it out; code that really wants interp->result can just insert the + * calls to Tcl_GetStringResult() itself. [Patch 1041072 discussion] */ #ifdef USE_DIRECT_INTERP_RESULT_ACCESS /* - * Ensure that the interp->result is legal so old Tcl 7.* code - * still works. There's still embarrasingly much of it about... + * Ensure that the interp->result is legal so old Tcl 7.* code still + * works. There's still embarrasingly much of it about... */ (void) Tcl_GetStringResult(interp); #endif /* USE_DIRECT_INTERP_RESULT_ACCESS */ } @@ -651,35 +644,32 @@ /* *---------------------------------------------------------------------- * * Tcl_AppendResult -- * - * Append a variable number of strings onto the interpreter's - * result. + * Append a variable number of strings onto the interpreter's result. * * Results: * None. * * Side effects: - * The result of the interpreter given by the first argument is - * extended by the strings given by the second and following - * arguments (up to a terminating NULL argument). + * The result of the interpreter given by the first argument is extended + * by the strings given by the second and following arguments (up to a + * terminating NULL argument). * - * If the string result is non-empty, the object result forced to - * be a duplicate of it first. There will be a string result - * afterwards. + * If the string result is non-empty, the object result forced to be a + * duplicate of it first. There will be a string result afterwards. * *---------------------------------------------------------------------- */ void -Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1) +Tcl_AppendResult(Tcl_Interp *interp, ...) { - Tcl_Interp *interp; va_list argList; - interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); + va_start(argList, interp); Tcl_AppendResultVA(interp, argList); va_end(argList); } /* @@ -692,81 +682,83 @@ * * Results: * None. * * Side effects: - * The result in the interpreter given by the first argument is - * extended with a list element converted from string. A separator - * space is added before the converted list element unless the current - * result is empty, contains the single character "{", or ends in " {". + * The result in the interpreter given by the first argument is extended + * with a list element converted from string. A separator space is added + * before the converted list element unless the current result is empty, + * contains the single character "{", or ends in " {". * * If the string result is empty, the object result is moved to the * string result, then the object result is reset. * *---------------------------------------------------------------------- */ void -Tcl_AppendElement(interp, stringPtr) +Tcl_AppendElement(interp, element) Tcl_Interp *interp; /* Interpreter whose result is to be * extended. */ - CONST char *stringPtr; /* String to convert to list element and - * add to result. */ + CONST char *element; /* String to convert to list element and add + * to result. */ { Interp *iPtr = (Interp *) interp; char *dst; int size; int flags; /* - * If the string result is empty, move the object result to the - * string result, then reset the object result. + * If the string result is empty, move the object result to the string + * result, then reset the object result. */ (void) Tcl_GetStringResult(interp); /* - * See how much space is needed, and grow the append buffer if - * needed to accommodate the list element. + * See how much space is needed, and grow the append buffer if needed to + * accommodate the list element. */ - size = Tcl_ScanElement(stringPtr, &flags) + 1; + size = Tcl_ScanElement(element, &flags) + 1; if ((iPtr->result != iPtr->appendResult) || (iPtr->appendResult[iPtr->appendUsed] != 0) || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) { - SetupAppendBuffer(iPtr, size+iPtr->appendUsed); + SetupAppendBuffer(iPtr, size+iPtr->appendUsed); } /* - * Convert the string into a list element and copy it to the - * buffer that's forming, with a space separator if needed. + * Convert the string into a list element and copy it to the buffer that's + * forming, with a space separator if needed. */ dst = iPtr->appendResult + iPtr->appendUsed; if (TclNeedSpace(iPtr->appendResult, dst)) { iPtr->appendUsed++; *dst = ' '; dst++; + /* - * If we need a space to separate this element from preceding - * stuff, then this element will not lead a list, and need not - * have it's leading '#' quoted. + * If we need a space to separate this element from preceding stuff, + * then this element will not lead a list, and need not have it's + * leading '#' quoted. */ + flags |= TCL_DONT_QUOTE_HASH; } - iPtr->appendUsed += Tcl_ConvertElement(stringPtr, dst, flags); + iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags); } /* *---------------------------------------------------------------------- * * SetupAppendBuffer -- * - * This procedure makes sure that there is an append buffer properly - * initialized, if necessary, from the interpreter's result, and - * that it has at least enough room to accommodate newSpace new - * bytes of information. + * This function makes sure that there is an append buffer properly + * initialized, if necessary, from the interpreter's result, and that it + * has at least enough room to accommodate newSpace new bytes of + * information. * * Results: * None. * * Side effects: @@ -776,12 +768,12 @@ */ static void SetupAppendBuffer(iPtr, newSpace) Interp *iPtr; /* Interpreter whose result is being set up. */ - int newSpace; /* Make sure that at least this many bytes - * of new information may be added. */ + int newSpace; /* Make sure that at least this many bytes of + * new information may be added. */ { int totalSpace; /* * Make the append buffer larger, if that's necessary, then copy the @@ -789,13 +781,13 @@ * Tcl result. */ if (iPtr->result != iPtr->appendResult) { /* - * If an oversized buffer was used recently, then free it up - * so we go back to a smaller buffer. This avoids tying up - * memory forever after a large operation. + * If an oversized buffer was used recently, then free it up so we go + * back to a smaller buffer. This avoids tying up memory forever after + * a large operation. */ if (iPtr->appendAvl > 500) { ckfree(iPtr->appendResult); iPtr->appendResult = NULL; @@ -803,17 +795,17 @@ } iPtr->appendUsed = strlen(iPtr->result); } else if (iPtr->result[iPtr->appendUsed] != 0) { /* * Most likely someone has modified a result created by - * Tcl_AppendResult et al. so that it has a different size. - * Just recompute the size. + * Tcl_AppendResult et al. so that it has a different size. Just + * recompute the size. */ iPtr->appendUsed = strlen(iPtr->result); } - + totalSpace = newSpace + iPtr->appendUsed; if (totalSpace >= iPtr->appendAvl) { char *new; if (totalSpace < 100) { @@ -829,69 +821,68 @@ iPtr->appendResult = new; iPtr->appendAvl = totalSpace; } else if (iPtr->result != iPtr->appendResult) { strcpy(iPtr->appendResult, iPtr->result); } - + Tcl_FreeResult((Tcl_Interp *) iPtr); iPtr->result = iPtr->appendResult; } /* *---------------------------------------------------------------------- * * Tcl_FreeResult -- * - * This procedure frees up the memory associated with an interpreter's + * This function frees up the memory associated with an interpreter's * string result. It also resets the interpreter's result object. - * Tcl_FreeResult is most commonly used when a procedure is about to + * Tcl_FreeResult is most commonly used when a function is about to * replace one result value with another. * * Results: * None. * * Side effects: * Frees the memory associated with interp's string result and sets - * interp->freeProc to zero, but does not change interp->result or - * clear error state. Resets interp's result object to an unshared - * empty object. + * interp->freeProc to zero, but does not change interp->result or clear + * error state. Resets interp's result object to an unshared empty + * object. * *---------------------------------------------------------------------- */ void Tcl_FreeResult(interp) register Tcl_Interp *interp; /* Interpreter for which to free result. */ { register Interp *iPtr = (Interp *) interp; - + if (iPtr->freeProc != NULL) { if (iPtr->freeProc == TCL_DYNAMIC) { ckfree(iPtr->result); } else { (*iPtr->freeProc)(iPtr->result); } iPtr->freeProc = 0; } - + ResetObjResult(iPtr); } /* *---------------------------------------------------------------------- * * Tcl_ResetResult -- * - * This procedure resets both the interpreter's string and object - * results. + * This function resets both the interpreter's string and object results. * * Results: * None. * * Side effects: - * It resets the result object to an unshared empty object. It - * then restores the interpreter's string result area to its default + * It resets the result object to an unshared empty object. It then + * restores the interpreter's string result area to its default * initialized state, freeing up any memory that may have been * allocated. It also clears any error information for the interpreter. * *---------------------------------------------------------------------- */ @@ -925,10 +916,12 @@ Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo, TCL_GLOBAL_ONLY); Tcl_DecrRefCount(iPtr->errorInfo); iPtr->errorInfo = NULL; } + iPtr->returnLevel = 1; + iPtr->returnCode = TCL_OK; if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); iPtr->returnOpts = NULL; } iPtr->flags &= ~ERR_ALREADY_LOGGED; @@ -937,19 +930,19 @@ /* *---------------------------------------------------------------------- * * ResetObjResult -- * - * Procedure used to reset an interpreter's Tcl result object. + * Function used to reset an interpreter's Tcl result object. * * Results: * None. * * Side effects: * Resets the interpreter's result object to an unshared empty string - * object with ref count one. It does not clear any error information - * in the interpreter. + * object with ref count one. It does not clear any error information in + * the interpreter. * *---------------------------------------------------------------------- */ static void @@ -964,11 +957,11 @@ TclNewObj(objResultPtr); Tcl_IncrRefCount(objResultPtr); iPtr->objResultPtr = objResultPtr; } else { if ((objResultPtr->bytes != NULL) - && (objResultPtr->bytes != tclEmptyStringRep)) { + && (objResultPtr->bytes != tclEmptyStringRep)) { ckfree((char *) objResultPtr->bytes); } objResultPtr->bytes = tclEmptyStringRep; objResultPtr->length = 0; TclFreeIntRep(objResultPtr); @@ -979,34 +972,34 @@ /* *---------------------------------------------------------------------- * * Tcl_SetErrorCodeVA -- * - * This procedure is called to record machine-readable information - * about an error that is about to be returned. + * This function is called to record machine-readable information about + * an error that is about to be returned. * * Results: * None. * * Side effects: * The errorCode field of the interp is modified to hold all of the - * arguments to this procedure, in a list form with each argument - * becoming one element of the list. + * arguments to this function, in a list form with each argument becoming + * one element of the list. * *---------------------------------------------------------------------- */ void -Tcl_SetErrorCodeVA (interp, argList) +Tcl_SetErrorCodeVA(interp, argList) Tcl_Interp *interp; /* Interpreter in which to set errorCode */ va_list argList; /* Variable argument list. */ { Tcl_Obj *errorObj = Tcl_NewObj(); /* - * Scan through the arguments one at a time, appending them to - * the errorCode field as list elements. + * Scan through the arguments one at a time, appending them to the + * errorCode field as list elements. */ while (1) { char *elem = va_arg(argList, char *); if (elem == NULL) { @@ -1020,48 +1013,47 @@ /* *---------------------------------------------------------------------- * * Tcl_SetErrorCode -- * - * This procedure is called to record machine-readable information - * about an error that is about to be returned. + * This function is called to record machine-readable information about + * an error that is about to be returned. * * Results: * None. * * Side effects: * The errorCode field of the interp is modified to hold all of the - * arguments to this procedure, in a list form with each argument - * becoming one element of the list. + * arguments to this function, in a list form with each argument becoming + * one element of the list. * *---------------------------------------------------------------------- */ - /* VARARGS2 */ + void -Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1) +Tcl_SetErrorCode(Tcl_Interp *interp, ...) { - Tcl_Interp *interp; va_list argList; /* - * Scan through the arguments one at a time, appending them to - * the errorCode field as list elements. + * Scan through the arguments one at a time, appending them to the + * errorCode field as list elements. */ - interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); + va_start(argList, interp); Tcl_SetErrorCodeVA(interp, argList); va_end(argList); } /* *---------------------------------------------------------------------- * * Tcl_SetObjErrorCode -- * - * This procedure is called to record machine-readable information - * about an error that is about to be returned. The caller should - * build a list object up and pass it to this routine. + * This function is called to record machine-readable information about + * an error that is about to be returned. The caller should build a list + * object up and pass it to this routine. * * Results: * None. * * Side effects: @@ -1074,11 +1066,11 @@ Tcl_SetObjErrorCode(interp, errorObjPtr) Tcl_Interp *interp; Tcl_Obj *errorObjPtr; { Interp *iPtr = (Interp *) interp; - + if (iPtr->errorCode) { Tcl_DecrRefCount(iPtr->errorCode); } iPtr->errorCode = errorObjPtr; Tcl_IncrRefCount(iPtr->errorCode); @@ -1087,22 +1079,22 @@ /* *---------------------------------------------------------------------- * * GetKeys -- * - * Returns a Tcl_Obj * array of the standard keys used in the - * return options dictionary. + * Returns a Tcl_Obj * array of the standard keys used in the return + * options dictionary. * - * Broadly sharing one copy of these key values helps with both - * memory efficiency and dictionary lookup times. + * Broadly sharing one copy of these key values helps with both memory + * efficiency and dictionary lookup times. * * Results: * A Tcl_Obj * array. * * Side effects: - * First time called in a thread, creates the keys (allocating - * memory) and arranges for their cleanup at thread exit. + * First time called in a thread, creates the keys (allocating memory) + * and arranges for their cleanup at thread exit. * *---------------------------------------------------------------------- */ static Tcl_Obj ** @@ -1109,23 +1101,33 @@ GetKeys() { static Tcl_ThreadDataKey returnKeysKey; Tcl_Obj **keys = Tcl_GetThreadData(&returnKeysKey, (int) (KEY_LAST * sizeof(Tcl_Obj *))); + if (keys[0] == NULL) { - /* First call in this thread, create the keys... */ + /* + * First call in this thread, create the keys... + */ + int i; - keys[KEY_CODE] = Tcl_NewStringObj("-code", -1); - keys[KEY_ERRORCODE] = Tcl_NewStringObj("-errorcode", -1); - keys[KEY_ERRORINFO] = Tcl_NewStringObj("-errorinfo", -1); - keys[KEY_ERRORLINE] = Tcl_NewStringObj("-errorline", -1); - keys[KEY_LEVEL] = Tcl_NewStringObj("-level", -1); - keys[KEY_OPTIONS] = Tcl_NewStringObj("-options", -1); + + keys[KEY_CODE] = Tcl_NewStringObj("-code", -1); + keys[KEY_ERRORCODE] = Tcl_NewStringObj("-errorcode", -1); + keys[KEY_ERRORINFO] = Tcl_NewStringObj("-errorinfo", -1); + keys[KEY_ERRORLINE] = Tcl_NewStringObj("-errorline", -1); + keys[KEY_LEVEL] = Tcl_NewStringObj("-level", -1); + keys[KEY_OPTIONS] = Tcl_NewStringObj("-options", -1); + for (i = KEY_CODE; i < KEY_LAST; i++) { Tcl_IncrRefCount(keys[i]); } - /* ... and arrange for their clenaup. */ + + /* + * ... and arrange for their clenaup. + */ + Tcl_CreateThreadExitHandler(ReleaseKeys, (ClientData) keys); } return keys; } @@ -1132,12 +1134,12 @@ /* *---------------------------------------------------------------------- * * ReleaseKeys -- * - * Called as a thread exit handler to cleanup return options - * dictionary keys. + * Called as a thread exit handler to cleanup return options dictionary + * keys. * * Results: * None. * * Side effects: @@ -1144,16 +1146,17 @@ * Frees memory. * *---------------------------------------------------------------------- */ -void +static void ReleaseKeys(clientData) ClientData clientData; { Tcl_Obj **keys = (Tcl_Obj **)clientData; int i; + for (i = KEY_CODE; i < KEY_LAST; i++) { Tcl_DecrRefCount(keys[i]); } } @@ -1160,15 +1163,15 @@ /* *---------------------------------------------------------------------- * * TclProcessReturn -- * - * Does the work of the [return] command based on the code, - * level, and returnOpts arguments. Note that the code argument - * must agree with the -code entry in returnOpts and the level - * argument must agree with the -level entry in returnOpts, as - * is the case for values returned from TclMergeReturnOptions. + * Does the work of the [return] command based on the code, level, and + * returnOpts arguments. Note that the code argument must agree with the + * -code entry in returnOpts and the level argument must agree with the + * -level entry in returnOpts, as is the case for values returned from + * TclMergeReturnOptions. * * Results: * Returns the return code the [return] command should return. * * Side effects: @@ -1186,11 +1189,14 @@ { Interp *iPtr = (Interp *) interp; Tcl_Obj *valuePtr; Tcl_Obj **keys = GetKeys(); - /* Store the merged return options */ + /* + * Store the merged return options. + */ + if (iPtr->returnOpts != returnOpts) { if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); } iPtr->returnOpts = returnOpts; @@ -1203,10 +1209,11 @@ iPtr->errorInfo = NULL; } Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], &valuePtr); if (valuePtr != NULL) { int infoLen; + (void) Tcl_GetStringFromObj(valuePtr, &infoLen); if (infoLen) { iPtr->errorInfo = valuePtr; Tcl_IncrRefCount(iPtr->errorInfo); iPtr->flags |= ERR_ALREADY_LOGGED; @@ -1238,13 +1245,13 @@ * TclMergeReturnOptions -- * * Parses, checks, and stores the options to the [return] command. * * Results: - * Returns TCL_ERROR is any of the option values are invalid. - * Otherwise, returns TCL_OK, and writes the returnOpts, code, - * and level values to the pointers provided. + * Returns TCL_ERROR is any of the option values are invalid. Otherwise, + * returns TCL_OK, and writes the returnOpts, code, and level values to + * the pointers provided. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -1253,14 +1260,13 @@ int TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr) Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ - Tcl_Obj **optionsPtrPtr; /* If not NULL, points to space for a - * (Tcl_Obj *) where the pointer to the - * merged return options dictionary should - * be written */ + Tcl_Obj **optionsPtrPtr; /* If not NULL, points to space for a (Tcl_Obj + * *) where the pointer to the merged return + * options dictionary should be written */ int *codePtr; /* If not NULL, points to space where the * -code value should be written */ int *levelPtr; /* If not NULL, points to space where the * -level value should be written */ { @@ -1281,17 +1287,20 @@ Tcl_DictSearch search; int done = 0; Tcl_Obj *keyPtr; Tcl_Obj *dict = objv[1]; - nestedOptions: - if (TCL_ERROR == Tcl_DictObjFirst(NULL, dict, - &search, &keyPtr, &valuePtr, &done)) { - /* Value is not a legal dictionary */ + nestedOptions: + if (TCL_ERROR == Tcl_DictObjFirst(NULL, dict, &search, + &keyPtr, &valuePtr, &done)) { + /* + * Value is not a legal dictionary. + */ + Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad ", - compare, " value: expected dictionary but got \"", + Tcl_AppendResult(interp, "bad ", compare, + " value: expected dictionary but got \"", TclGetString(objv[1]), "\"", (char *) NULL); goto error; } while (!done) { @@ -1309,13 +1318,16 @@ } else { Tcl_DictObjPut(NULL, returnOpts, objv[0], objv[1]); } } - /* Check for bogus -code value */ + /* + * Check for bogus -code value. + */ + Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr); - if ((valuePtr != NULL) + if ((valuePtr != NULL) && (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &code))) { static CONST char *returnCodes[] = { "ok", "error", "return", "break", "continue", NULL }; @@ -1330,29 +1342,35 @@ goto error; } Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_CODE]); } - /* Check for bogus -level value */ + /* + * Check for bogus -level value. + */ + Tcl_DictObjGet(NULL, returnOpts, keys[KEY_LEVEL], &valuePtr); if (valuePtr != NULL) { - if ((TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &level)) + if ((TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &level)) || (level < 0)) { - /* Value is not a legal level */ + /* + * Value is not a legal level. + */ + Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad -level value: ", - "expected non-negative integer but got \"", - TclGetString(valuePtr), "\"", (char *) NULL); + "expected non-negative integer but got \"", + TclGetString(valuePtr), "\"", (char *) NULL); goto error; } Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_LEVEL]); } - /* - * Convert [return -code return -level X] to - * [return -code ok -level X+1] + /* + * Convert [return -code return -level X] to [return -code ok -level X+1] */ + if (code == TCL_RETURN) { level++; code = TCL_OK; } @@ -1360,19 +1378,23 @@ *codePtr = code; } if (levelPtr != NULL) { *levelPtr = level; } + if (optionsPtrPtr == NULL) { - /* Not passing back the options (?!), so clean them up */ + /* + * Not passing back the options (?!), so clean them up. + */ + Tcl_DecrRefCount(returnOpts); } else { *optionsPtrPtr = returnOpts; } return TCL_OK; -error: + error: Tcl_DecrRefCount(returnOpts); return TCL_ERROR; } /* @@ -1418,14 +1440,15 @@ Tcl_NewIntObj(0)); } if (result == TCL_ERROR) { /* - * When result was an error, fill in any missing values - * for -errorinfo, -errorcode, and -errorline + * When result was an error, fill in any missing values for + * -errorinfo, -errorcode, and -errorline */ - Tcl_AddObjErrorInfo(interp, "", -1); + + Tcl_AddObjErrorInfo(interp, "", -1); Tcl_DictObjPut(NULL, options, keys[KEY_ERRORINFO], iPtr->errorInfo); Tcl_DictObjPut(NULL, options, keys[KEY_ERRORCODE], iPtr->errorCode); Tcl_DictObjPut(NULL, options, keys[KEY_ERRORLINE], Tcl_NewIntObj(iPtr->errorLine)); } @@ -1435,18 +1458,18 @@ /* *------------------------------------------------------------------------- * * Tcl_SetReturnOptions -- * - * Accepts an interp and a dictionary of return options, and sets - * the return options of the interp to match the dictionary. + * Accepts an interp and a dictionary of return options, and sets the + * return options of the interp to match the dictionary. * * Results: - * A standard status code. Usually TCL_OK, but TCL_ERROR if an - * invalid option value was found in the dictionary. If a -level - * value of 0 is in the dictionary, then the -code value in the - * dictionary will be returned (TCL_OK default). + * A standard status code. Usually TCL_OK, but TCL_ERROR if an invalid + * option value was found in the dictionary. If a -level value of 0 is in + * the dictionary, then the -code value in the dictionary will be + * returned (TCL_OK default). * * Side effects: * Sets the state of the interp. * *------------------------------------------------------------------------- @@ -1480,46 +1503,45 @@ /* *------------------------------------------------------------------------- * * TclTransferResult -- * - * Copy the result (and error information) from one interp to - * another. Used when one interp has caused another interp to - * evaluate a script and then wants to transfer the results back - * to itself. - * - * This routine copies the string reps of the result and error - * information. It does not simply increment the refcounts of the - * result and error information objects themselves. - * It is not legal to exchange objects between interps, because an - * object may be kept alive by one interp, but have an internal rep - * that is only valid while some other interp is alive. + * Copy the result (and error information) from one interp to another. + * Used when one interp has caused another interp to evaluate a script + * and then wants to transfer the results back to itself. + * + * This routine copies the string reps of the result and error + * information. It does not simply increment the refcounts of the result + * and error information objects themselves. It is not legal to exchange + * objects between interps, because an object may be kept alive by one + * interp, but have an internal rep that is only valid while some other + * interp is alive. * * Results: * The target interp's result is set to a copy of the source interp's - * result. The source's errorInfo field may be transferred to the + * result. The source's errorInfo field may be transferred to the * target's errorInfo field, and the source's errorCode field may be * transferred to the target's errorCode field. * * Side effects: * None. * *------------------------------------------------------------------------- */ - + void TclTransferResult(sourceInterp, result, targetInterp) Tcl_Interp *sourceInterp; /* Interp whose result and error information - * should be moved to the target interp. - * After moving result, this interp's result + * should be moved to the target interp. + * After moving result, this interp's result * is reset. */ - int result; /* TCL_OK if just the result should be copied, - * TCL_ERROR if both the result and error + int result; /* TCL_OK if just the result should be copied, + * TCL_ERROR if both the result and error * information should be copied. */ - Tcl_Interp *targetInterp; /* Interp where result and error information - * should be stored. If source and target - * are the same, nothing is done. */ + Tcl_Interp *targetInterp; /* Interp where result and error information + * should be stored. If source and target are + * the same, nothing is done. */ { Interp *iPtr = (Interp *) targetInterp; if (sourceInterp == targetInterp) { return; @@ -1529,5 +1551,13 @@ Tcl_GetReturnOptions(sourceInterp, result)); iPtr->flags &= ~(ERR_ALREADY_LOGGED); Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp)); Tcl_ResetResult(sourceInterp); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclScan.c ================================================================== --- generic/tclScan.c +++ generic/tclScan.c @@ -1,41 +1,44 @@ -/* +/* * tclScan.c -- * * This file contains the implementation of the "scan" command. * * Copyright (c) 1998 by Scriptics Corporation. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclScan.c,v 1.16 2004/10/06 15:59:25 dgp Exp $ + * RCS: @(#) $Id: tclScan.c,v 1.16.2.6 2005/09/28 00:23:46 dgp Exp $ */ #include "tclInt.h" /* * Flag values used by Tcl_ScanObjCmd. */ -#define SCAN_NOSKIP 0x1 /* Don't skip blanks. */ -#define SCAN_SUPPRESS 0x2 /* Suppress assignment. */ -#define SCAN_UNSIGNED 0x4 /* Read an unsigned value. */ -#define SCAN_WIDTH 0x8 /* A width value was supplied. */ - -#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. */ - -#define SCAN_LONGER 0x400 /* Asked for a wide value. */ +#define SCAN_NOSKIP 0x1 /* Don't skip blanks. */ +#define SCAN_SUPPRESS 0x2 /* Suppress assignment. */ +#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 character set. + * The following structure contains the information associated with a + * character set. */ typedef struct CharSet { int exclude; /* 1 if this is an exclusion set. */ int nchars; @@ -60,13 +63,13 @@ /* *---------------------------------------------------------------------- * * BuildCharSet -- * - * This function examines a character set format specification - * and builds a CharSet containing the individual characters and - * character ranges specified. + * This function examines a character set format specification and builds + * a CharSet containing the individual characters and character ranges + * specified. * * Results: * Returns the next format position. * * Side effects: @@ -83,11 +86,11 @@ Tcl_UniChar ch, start; int offset, nranges; char *end; memset(cset, 0, sizeof(CharSet)); - + offset = Tcl_UtfToUniChar(format, &ch); if (ch == '^') { cset->exclude = 1; format += offset; offset = Tcl_UtfToUniChar(format, &ch); @@ -129,12 +132,12 @@ format += Tcl_UtfToUniChar(format, &ch); } while (ch != ']') { if (*format == '-') { /* - * This may be the first character of a range, so don't add - * it yet. + * This may be the first character of a range, so don't add it + * yet. */ start = ch; } else if (ch == '-') { /* @@ -157,11 +160,11 @@ cset->ranges[cset->nranges].start = start; cset->ranges[cset->nranges].end = ch; } else { cset->ranges[cset->nranges].start = ch; cset->ranges[cset->nranges].end = start; - } + } cset->nranges++; } } else { cset->chars[cset->nchars++] = ch; } @@ -187,12 +190,12 @@ */ static int CharInSet(cset, c) CharSet *cset; - int c; /* Character to test, passed as int because - * of non-ANSI prototypes. */ + int c; /* Character to test, passed as int because of + * non-ANSI prototypes. */ { Tcl_UniChar ch = (Tcl_UniChar) c; int i, match = 0; for (i = 0; i < cset->nchars; i++) { if (cset->chars[i] == ch) { @@ -207,11 +210,11 @@ match = 1; break; } } } - return (cset->exclude ? !match : match); + return (cset->exclude ? !match : match); } /* *---------------------------------------------------------------------- * @@ -241,12 +244,12 @@ /* *---------------------------------------------------------------------- * * ValidateFormat -- * - * Parse the format string and verify that it is properly formed - * and that there are exactly enough variables on the command line. + * Parse the format string and verify that it is properly formed and that + * there are exactly enough variables on the command line. * * Results: * A standard Tcl result. * * Side effects: @@ -257,12 +260,12 @@ static int ValidateFormat(interp, format, numVars, totalSubs) Tcl_Interp *interp; /* Current interpreter. */ char *format; /* The format string. */ - int numVars; /* The number of variables passed to the - * scan command. */ + int numVars; /* The number of variables passed to the scan + * command. */ int *totalSubs; /* The number of variables that will be * required. */ { #define STATIC_LIST_SIZE 16 int gotXpg, gotSequential, value, i, flags; @@ -272,13 +275,13 @@ int *nassign = staticAssign; int objIndex, xpgSize, nspace = STATIC_LIST_SIZE; char buf[TCL_UTF_MAX+1]; /* - * Initialize an array that records the number of times a variable - * is assigned to by the format string. We use this to detect if - * a variable is multiply assigned or left unassigned. + * Initialize an array that records the number of times a variable is + * assigned to by the format string. We use this to detect if a variable + * is multiply assigned or left unassigned. */ if (numVars > nspace) { nassign = (int*)ckalloc(sizeof(int) * numVars); nspace = numVars; @@ -307,13 +310,13 @@ goto xpgCheckDone; } if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ /* - * Check for an XPG3-style %n$ specification. Note: there - * must not be a mixture of XPG3 specs and non-XPG3 specs - * in the same format string. + * Check for an XPG3-style %n$ specification. Note: there must + * not be a mixture of XPG3 specs and non-XPG3 specs in the same + * format string. */ value = strtoul(format-1, &end, 10); /* INTL: "C" locale. */ if (*end != '$') { goto notXpg; @@ -329,29 +332,29 @@ goto badIndex; } else if (numVars == 0) { /* * In the case where no vars are specified, the user can * specify %9999$ legally, so we have to consider special - * rules for growing the assign array. 'value' is - * guaranteed to be > 0. + * rules for growing the assign array. 'value' is guaranteed + * to be > 0. */ xpgSize = (xpgSize > value) ? xpgSize : value; } goto xpgCheckDone; } - notXpg: + notXpg: gotSequential = 1; if (gotXpg) { - mixedXPG: + mixedXPG: Tcl_SetResult(interp, "cannot mix \"%\" and \"%n$\" conversion specifiers", TCL_STATIC); goto error; } - xpgCheckDone: + xpgCheckDone: /* * Parse any width specifier. */ if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ @@ -364,10 +367,16 @@ * Handle any size specifier. */ 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': format += Tcl_UtfToUniChar(format, &ch); } @@ -379,77 +388,83 @@ /* * Handle the various field types. */ switch (ch) { - case 'c': - if (flags & SCAN_WIDTH) { - Tcl_SetResult(interp, - "field width may not be specified in %c conversion", - TCL_STATIC); - goto error; - } - /* - * Fall through! - */ - case 'n': - case 's': - if (flags & SCAN_LONGER) { - invalidLonger: - buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; - Tcl_AppendResult(interp, - "'l' modifier may not be specified in %", buf, - " conversion", NULL); - goto error; - } - /* - * Fall through! - */ - case 'd': - case 'e': - case 'f': - case 'g': - case 'i': - case 'o': - case 'u': - case 'x': - break; - /* - * Bracket terms need special checking - */ - case '[': - if (flags & SCAN_LONGER) { - goto invalidLonger; - } - if (*format == '\0') { - goto badSet; - } - format += Tcl_UtfToUniChar(format, &ch); - if (ch == '^') { - if (*format == '\0') { - goto badSet; - } - format += Tcl_UtfToUniChar(format, &ch); - } - if (ch == ']') { - if (*format == '\0') { - goto badSet; - } - format += Tcl_UtfToUniChar(format, &ch); - } - while (ch != ']') { - if (*format == '\0') { - goto badSet; - } - format += Tcl_UtfToUniChar(format, &ch); - } - break; - badSet: - Tcl_SetResult(interp, "unmatched [ in format string", - TCL_STATIC); - goto error; - default: + case 'c': + if (flags & SCAN_WIDTH) { + Tcl_SetResult(interp, + "field width may not be specified in %c conversion", + TCL_STATIC); + goto error; + } + /* + * Fall through! + */ + case 'n': + case 's': + if (flags & (SCAN_LONGER|SCAN_BIG)) { + invalidFieldSize: + buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; + Tcl_AppendResult(interp, + "field size modifier may not be specified in %", buf, + " conversion", NULL); + goto error; + } + /* + * Fall through! + */ + case 'd': + case 'e': + case 'f': + case 'g': + case 'i': + case 'o': + 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|SCAN_BIG)) { + goto invalidFieldSize; + } + if (*format == '\0') { + goto badSet; + } + format += Tcl_UtfToUniChar(format, &ch); + if (ch == '^') { + if (*format == '\0') { + goto badSet; + } + format += Tcl_UtfToUniChar(format, &ch); + } + if (ch == ']') { + if (*format == '\0') { + goto badSet; + } + format += Tcl_UtfToUniChar(format, &ch); + } + while (ch != ']') { + if (*format == '\0') { + goto badSet; + } + format += Tcl_UtfToUniChar(format, &ch); + } + break; + badSet: + Tcl_SetResult(interp, "unmatched [ in format string", + TCL_STATIC); + goto error; + default: { char buf[TCL_UTF_MAX+1]; buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; Tcl_AppendResult(interp, "bad scan conversion character \"", @@ -458,14 +473,15 @@ } } if (!(flags & SCAN_SUPPRESS)) { if (objIndex >= nspace) { /* - * Expand the nassign buffer. If we are using XPG specifiers, - * make sure that we grow to a large enough size. xpgSize is + * Expand the nassign buffer. If we are using XPG specifiers, + * make sure that we grow to a large enough size. xpgSize is * guaranteed to be at least one larger than objIndex. */ + value = nspace; if (xpgSize) { nspace = xpgSize; } else { nspace += STATIC_LIST_SIZE; @@ -502,38 +518,43 @@ if (totalSubs) { *totalSubs = numVars; } for (i = 0; i < numVars; i++) { if (nassign[i] > 1) { - Tcl_SetResult(interp, "variable is assigned by multiple \"%n$\" conversion specifiers", TCL_STATIC); + Tcl_SetResult(interp, + "variable is assigned by multiple \"%n$\" conversion specifiers", + TCL_STATIC); goto error; } else if (!xpgSize && (nassign[i] == 0)) { /* - * If the space is empty, and xpgSize is 0 (means XPG wasn't - * used, and/or numVars != 0), then too many vars were given + * If the space is empty, and xpgSize is 0 (means XPG wasn't used, + * and/or numVars != 0), then too many vars were given */ - Tcl_SetResult(interp, "variable is not assigned by any conversion specifiers", TCL_STATIC); + + Tcl_SetResult(interp, + "variable is not assigned by any conversion specifiers", + TCL_STATIC); goto error; } } if (nassign != staticAssign) { ckfree((char *)nassign); } return TCL_OK; - badIndex: + badIndex: if (gotXpg) { Tcl_SetResult(interp, "\"%n$\" argument index out of range", TCL_STATIC); } else { - Tcl_SetResult(interp, + Tcl_SetResult(interp, "different numbers of variable names and field specifiers", TCL_STATIC); } - error: + error: if (nassign != staticAssign) { ckfree((char *)nassign); } return TCL_ERROR; #undef STATIC_LIST_SIZE @@ -542,12 +563,12 @@ /* *---------------------------------------------------------------------- * * Tcl_ScanObjCmd -- * - * This procedure is invoked to process the "scan" Tcl command. - * See the user documentation for details on what it does. + * This function is invoked to process the "scan" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -566,29 +587,31 @@ { char *format; 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. */ + 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, + Tcl_WrongNumArgs(interp, 1, objv, "string format ?varName varName ...?"); return TCL_ERROR; } format = Tcl_GetStringFromObj(objv[2], NULL); @@ -595,11 +618,11 @@ numVars = objc-3; /* * Check for errors in the format string. */ - + if (ValidateFormat(interp, format, numVars, &totalVars) == TCL_ERROR) { return TCL_ERROR; } /* @@ -615,18 +638,19 @@ string = Tcl_GetStringFromObj(objv[1], NULL); baseString = string; /* - * Iterate over the format string filling in the result objects until - * we reach the end of input, the end of the format string, or there - * is a mismatch. + * Iterate over the format string filling in the result objects until we + * reach the end of input, the end of the format string, or there is a + * mismatch. */ objIndex = 0; nconversions = 0; while (*format != '\0') { + int parseFlag = 0; format += Tcl_UtfToUniChar(format, &ch); flags = 0; /* @@ -642,13 +666,13 @@ string += offset; offset = Tcl_UtfToUniChar(string, &sch); } continue; } - + if (ch != '%') { - literal: + literal: if (*string == '\0') { underflow = 1; goto done; } string += Tcl_UtfToUniChar(string, &sch); @@ -662,32 +686,33 @@ if (ch == '%') { goto literal; } /* - * Check for assignment suppression ('*') or an XPG3-style - * assignment ('%n$'). + * Check for assignment suppression ('*') or an XPG3-style assignment + * ('%n$'). */ if (ch == '*') { 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; + } else if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ + 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; } } /* * Parse any width specifier. */ - if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ - width = strtoul(format-1, &format, 10); /* INTL: "C" locale. */ + if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ + width = strtoul(format-1, &format, 10); /* INTL: "C" locale. */ format += Tcl_UtfToUniChar(format, &ch); } else { width = 0; } @@ -695,10 +720,16 @@ * Handle any size specifier. */ switch (ch) { case 'l': + if (*format == 'l') { + flags |= SCAN_BIG; + format += 1; + format += Tcl_UtfToUniChar(format, &ch); + break; + } case 'L': flags |= SCAN_LONGER; /* * Fall through so we skip to the next character. */ @@ -709,94 +740,108 @@ /* * Handle the various field types. */ switch (ch) { - case 'n': - if (!(flags & SCAN_SUPPRESS)) { - objPtr = Tcl_NewIntObj(string - baseString); - Tcl_IncrRefCount(objPtr); - objs[objIndex++] = objPtr; - } - nconversions++; - continue; - - case 'd': - op = 'i'; - 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 - break; - case 'i': - op = 'i'; - 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 - break; - case 'o': - op = 'i'; - 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 - break; - case 'x': - op = 'i'; - 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 - break; - case 'u': - op = 'i'; - base = 10; - flags |= SCAN_UNSIGNED; - fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul; -#ifndef TCL_WIDE_INT_IS_LONG - lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull; -#endif - break; - - case 'f': - case 'e': - case 'g': - op = 'f'; - break; - - case 's': - op = 's'; - break; - - case 'c': - op = 'c'; - flags |= SCAN_NOSKIP; - break; - case '[': - op = '['; - flags |= SCAN_NOSKIP; - break; + case 'n': + if (!(flags & SCAN_SUPPRESS)) { + objPtr = Tcl_NewIntObj(string - baseString); + Tcl_IncrRefCount(objPtr); + objs[objIndex++] = objPtr; + } + nconversions++; + continue; + + 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'; + 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': + case 'e': + case 'g': + op = 'f'; + break; + + case 's': + op = 's'; + break; + + case 'c': + op = 'c'; + flags |= SCAN_NOSKIP; + break; + case '[': + op = '['; + flags |= SCAN_NOSKIP; + break; } /* - * At this point, we will need additional characters from the - * string to proceed. + * At this point, we will need additional characters from the string + * to proceed. */ if (*string == '\0') { underflow = 1; goto done; } - + /* - * Skip any leading whitespace at the beginning of a field unless - * the format suppresses this behavior. + * Skip any leading whitespace at the beginning of a field unless the + * format suppresses this behavior. */ if (!(flags & SCAN_NOSKIP)) { while (*string != '\0') { offset = Tcl_UtfToUniChar(string, &sch); @@ -812,384 +857,366 @@ } /* * Perform the requested scanning operation. */ - - switch (op) { - case 's': - /* - * Scan a string up to width characters or whitespace. - */ - - if (width == 0) { - width = (size_t) ~0; - } - end = string; - while (*end != '\0') { - offset = Tcl_UtfToUniChar(end, &sch); - if (Tcl_UniCharIsSpace(sch)) { - break; - } - end += offset; - if (--width == 0) { - break; - } - } - if (!(flags & SCAN_SUPPRESS)) { - objPtr = Tcl_NewStringObj(string, end-string); - Tcl_IncrRefCount(objPtr); - objs[objIndex++] = objPtr; - } - string = end; - break; - - case '[': { - CharSet cset; - - if (width == 0) { - width = (size_t) ~0; - } - end = string; - - format = BuildCharSet(&cset, format); - while (*end != '\0') { - offset = Tcl_UtfToUniChar(end, &sch); - if (!CharInSet(&cset, (int)sch)) { - break; - } - end += offset; - if (--width == 0) { - break; - } - } - ReleaseCharSet(&cset); - - if (string == end) { - /* - * Nothing matched the range, stop processing - */ - goto done; - } - if (!(flags & SCAN_SUPPRESS)) { - objPtr = Tcl_NewStringObj(string, end-string); - Tcl_IncrRefCount(objPtr); - objs[objIndex++] = objPtr; - } - string = end; - - break; - } - case 'c': - /* - * Scan a single Unicode character. - */ - - string += Tcl_UtfToUniChar(string, &sch); - if (!(flags & SCAN_SUPPRESS)) { - objPtr = Tcl_NewIntObj((int)sch); - Tcl_IncrRefCount(objPtr); - objs[objIndex++] = objPtr; - } - break; - - case 'i': - /* - * Scan an unsigned or signed integer. - */ - - if ((width == 0) || (width > sizeof(buf) - 1)) { - width = sizeof(buf) - 1; - } - flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_NOZERO; - for (end = buf; width > 0; width--) { - switch (*string) { - /* - * The 0 digit has special meaning at the beginning of - * a number. If we are unsure of the base, it - * indicates that we are in base 8 or base 16 (if it is - * followed by an 'x'). - * - * 8.1 - 8.3.4 incorrectly handled 0x... base-16 - * cases for %x by not reading the 0x as the - * auto-prelude for base-16. [Bug #495213] - */ - case '0': - if (base == 0) { - base = 8; - flags |= SCAN_XOK; - } - if (base == 16) { - flags |= SCAN_XOK; - } - if (flags & SCAN_NOZERO) { - flags &= ~(SCAN_SIGNOK | SCAN_NODIGITS - | SCAN_NOZERO); - } else { - flags &= ~(SCAN_SIGNOK | SCAN_XOK - | SCAN_NODIGITS); - } - goto addToInt; - - case '1': case '2': case '3': case '4': - case '5': case '6': case '7': - if (base == 0) { - base = 10; - } - flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); - goto addToInt; - - case '8': case '9': - if (base == 0) { - base = 10; - } - if (base <= 8) { - break; - } - flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); - goto addToInt; - - case 'A': case 'B': case 'C': - case 'D': case 'E': case 'F': - case 'a': case 'b': case 'c': - case 'd': case 'e': case 'f': - if (base <= 10) { - break; - } - flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); - goto addToInt; - - case '+': case '-': - if (flags & SCAN_SIGNOK) { - flags &= ~SCAN_SIGNOK; - goto addToInt; - } - break; - - case 'x': case 'X': - if ((flags & SCAN_XOK) && (end == buf+1)) { - base = 16; - flags &= ~SCAN_XOK; - goto addToInt; - } - break; - } - - /* - * We got an illegal character so we are done accumulating. - */ - - break; - - addToInt: - /* - * Add the character to the temporary buffer. - */ - - *end++ = *string++; - if (*string == '\0') { - break; - } - } - - /* - * Check to see if we need to back up because we only got a - * sign or a trailing x after a 0. - */ - - if (flags & SCAN_NODIGITS) { - if (*string == '\0') { - underflow = 1; - } - goto done; - } else if (end[-1] == 'x' || end[-1] == 'X') { - end--; - string--; - } - - - /* - * Scan the value from the temporary buffer. If we are - * returning a large unsigned value, we have to convert it back - * to a string since Tcl only supports signed values. - */ - - if (!(flags & SCAN_SUPPRESS)) { - *end = '\0'; -#ifndef TCL_WIDE_INT_IS_LONG - if (flags & SCAN_LONGER) { - wideValue = (Tcl_WideInt) (*lfn)(buf, NULL, base); - if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) { - /* INTL: ISO digit */ - sprintf(buf, "%" TCL_LL_MODIFIER "u", - (Tcl_WideUInt)wideValue); - objPtr = Tcl_NewStringObj(buf, -1); - } else { - objPtr = Tcl_NewWideIntObj(wideValue); - } - } else { -#endif /* !TCL_WIDE_INT_IS_LONG */ - value = (long) (*fn)(buf, NULL, base); - if ((flags & SCAN_UNSIGNED) && (value < 0)) { - sprintf(buf, "%lu", value); /* INTL: ISO digit */ - objPtr = Tcl_NewStringObj(buf, -1); - } else if ((flags & SCAN_LONGER) - || (unsigned long) value > UINT_MAX) { - objPtr = Tcl_NewLongObj(value); - } else { - objPtr = Tcl_NewIntObj(value); - } -#ifndef TCL_WIDE_INT_IS_LONG - } -#endif - Tcl_IncrRefCount(objPtr); - objs[objIndex++] = objPtr; - } - - break; - - case 'f': - /* - * Scan a floating point number - */ - - if ((width == 0) || (width > sizeof(buf) - 1)) { - width = sizeof(buf) - 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; - } - 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; - } - } - - /* - * 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; - } - goto done; - } - - /* - * We got a bad exponent ('e' and maybe a sign). - */ - - end--; - string--; - if (*end != 'e' && *end != 'E') { - end--; - string--; - } - } - - /* - * Scan the value from the temporary buffer. - */ - - if (!(flags & SCAN_SUPPRESS)) { - double dvalue; - *end = '\0'; - dvalue = strtod(buf, NULL); - objPtr = Tcl_NewDoubleObj(dvalue); - Tcl_IncrRefCount(objPtr); - objs[objIndex++] = objPtr; - } - break; + + switch (op) { + case 's': + /* + * Scan a string up to width characters or whitespace. + */ + + if (width == 0) { + width = (size_t) ~0; + } + end = string; + while (*end != '\0') { + offset = Tcl_UtfToUniChar(end, &sch); + if (Tcl_UniCharIsSpace(sch)) { + break; + } + end += offset; + if (--width == 0) { + break; + } + } + if (!(flags & SCAN_SUPPRESS)) { + objPtr = Tcl_NewStringObj(string, end-string); + Tcl_IncrRefCount(objPtr); + objs[objIndex++] = objPtr; + } + string = end; + break; + + case '[': { + CharSet cset; + + if (width == 0) { + width = (size_t) ~0; + } + end = string; + + format = BuildCharSet(&cset, format); + while (*end != '\0') { + offset = Tcl_UtfToUniChar(end, &sch); + if (!CharInSet(&cset, (int)sch)) { + break; + } + end += offset; + if (--width == 0) { + break; + } + } + ReleaseCharSet(&cset); + + if (string == end) { + /* + * Nothing matched the range, stop processing. + */ + goto done; + } + if (!(flags & SCAN_SUPPRESS)) { + objPtr = Tcl_NewStringObj(string, end-string); + Tcl_IncrRefCount(objPtr); + objs[objIndex++] = objPtr; + } + string = end; + + break; + } + case 'c': + /* + * Scan a single Unicode character. + */ + + string += Tcl_UtfToUniChar(string, &sch); + if (!(flags & SCAN_SUPPRESS)) { + objPtr = Tcl_NewIntObj((int)sch); + Tcl_IncrRefCount(objPtr); + objs[objIndex++] = objPtr; + } + break; + + case 'i': + /* + * Scan an unsigned or signed integer. + */ + +#if 0 + if ((width == 0) || (width > sizeof(buf) - 1)) { + width = sizeof(buf) - 1; + } + flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_NOZERO; + for (end = buf; width > 0; width--) { + switch (*string) { + /* + * The 0 digit has special meaning at the beginning of a + * number. If we are unsure of the base, it indicates that + * we are in base 8 or base 16 (if it is followed by an + * 'x'). + * + * 8.1 - 8.3.4 incorrectly handled 0x... base-16 cases for + * %x by not reading the 0x as the auto-prelude for + * base-16. [Bug #495213] + */ + case '0': + if (base == 0) { + base = 8; + flags |= SCAN_XOK; + } + if (base == 16) { + flags |= SCAN_XOK; + } + if (flags & SCAN_NOZERO) { + flags &= ~(SCAN_SIGNOK | SCAN_NODIGITS | SCAN_NOZERO); + } else { + flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); + } + goto addToInt; + + case '1': case '2': case '3': case '4': + case '5': case '6': case '7': + if (base == 0) { + base = 10; + } + flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); + goto addToInt; + + case '8': case '9': + if (base == 0) { + base = 10; + } + if (base <= 8) { + break; + } + flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); + goto addToInt; + + case 'A': case 'B': case 'C': + case 'D': case 'E': case 'F': + case 'a': case 'b': case 'c': + case 'd': case 'e': case 'f': + if (base <= 10) { + break; + } + flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); + goto addToInt; + + case '+': case '-': + if (flags & SCAN_SIGNOK) { + flags &= ~SCAN_SIGNOK; + goto addToInt; + } + break; + + case 'x': case 'X': + if ((flags & SCAN_XOK) && (end == buf+1)) { + base = 16; + flags &= ~SCAN_XOK; + goto addToInt; + } + break; + } + + /* + * We got an illegal character so we are done accumulating. + */ + + break; + + addToInt: + /* + * Add the character to the temporary buffer. + */ + + *end++ = *string++; + if (*string == '\0') { + break; + } + } + + /* + * Check to see if we need to back up because we only got a sign + * or a trailing x after a 0. + */ + + if (flags & SCAN_NODIGITS) { + if (*string == '\0') { + underflow = 1; + } + goto done; + } else if (end[-1] == 'x' || end[-1] == 'X') { + end--; + string--; + } + + /* + * Scan the value from the temporary buffer. If we are returning a + * large unsigned value, we have to convert it back to a string + * since Tcl only supports signed values. + */ + + if (!(flags & SCAN_SUPPRESS)) { + *end = '\0'; +#ifndef TCL_WIDE_INT_IS_LONG + if (flags & SCAN_LONGER) { + wideValue = (Tcl_WideInt) (*lfn)(buf, NULL, base); + if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) { + /* INTL: ISO digit */ + sprintf(buf, "%" TCL_LL_MODIFIER "u", + (Tcl_WideUInt)wideValue); + objPtr = Tcl_NewStringObj(buf, -1); + } else { + objPtr = Tcl_NewWideIntObj(wideValue); + } + } else { +#endif /* !TCL_WIDE_INT_IS_LONG */ + value = (long) (*fn)(buf, NULL, base); + if ((flags & SCAN_UNSIGNED) && (value < 0)) { + sprintf(buf, "%lu", value); /* INTL: ISO digit */ + objPtr = Tcl_NewStringObj(buf, -1); + } else if ((flags & SCAN_LONGER) + || (unsigned long) value > UINT_MAX) { + objPtr = Tcl_NewLongObj(value); + } else { + objPtr = Tcl_NewIntObj(value); + } +#ifndef TCL_WIDE_INT_IS_LONG + } +#endif + Tcl_IncrRefCount(objPtr); + objs[objIndex++] = objPtr; + } + + break; +#else + objPtr = Tcl_NewLongObj(0); + Tcl_IncrRefCount(objPtr); + if (width == 0) { + width = -1; + } + 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 */ + } + } + 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); + } + } 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; + } + } + 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 a floating point number + */ + + 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; + 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; + } } nconversions++; } - done: + done: result = 0; code = TCL_OK; if (numVars) { /* - * In this case, variables were specified (classic scan) + * In this case, variables were specified (classic scan). */ - for (i = 0; i < totalVars; i++) { - if (objs[i] != NULL) { - result++; - if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, - objs[i], 0) == NULL) { - Tcl_AppendResult(interp, "couldn't set variable \"", - Tcl_GetString(objv[i+3]), "\"", (char *) NULL); - code = TCL_ERROR; - } - Tcl_DecrRefCount(objs[i]); - } + + for (i = 0; i < totalVars; i++) { + if (objs[i] == NULL) { + continue; + } + result++; + if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], 0) == NULL) { + Tcl_AppendResult(interp, "couldn't set variable \"", + TclGetString(objv[i+3]), "\"", (char *) NULL); + code = TCL_ERROR; + } + Tcl_DecrRefCount(objs[i]); } } else { /* * Here no vars were specified, we want a list returned (inline scan) */ + objPtr = Tcl_NewObj(); for (i = 0; i < totalVars; i++) { if (objs[i] != NULL) { Tcl_ListObjAppendElement(NULL, objPtr, objs[i]); Tcl_DecrRefCount(objs[i]); } else { /* - * More %-specifiers than matching chars, so we - * just spit out empty strings for these + * More %-specifiers than matching chars, so we just spit out + * empty strings for these. */ + Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewObj()); } } } if (objs != NULL) { @@ -1211,5 +1238,13 @@ } Tcl_SetObjResult(interp, objPtr); } return code; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ ADDED generic/tclStrToD.c Index: generic/tclStrToD.c ================================================================== --- /dev/null +++ generic/tclStrToD.c @@ -0,0 +1,2626 @@ +/* + *---------------------------------------------------------------------- + * + * tclDouble.c -- + * + * 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.1.2.39 2005/09/26 20:16:53 kennykb Exp $ + * + *---------------------------------------------------------------------- + */ + +#include +#include +#include +#include +#include +#include +#include +#include + +/* + * 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.) + */ + +#define TIP_114_FORMATS +#undef KILL_OCTAL + +#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, 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__ __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 + +/* + * HP's PA_RISC architecture uses 7ff4000000000000 to represent a quiet NaN. + * Everyone else uses 7ff8000000000000. (Why, HP, why?) + */ + +#ifdef __hppa +# define NAN_START 0x7ff4 +# define NAN_MASK (((Tcl_WideUInt) 1) << 50) +#else +# define NAN_START 0x7ff8 +# define NAN_MASK (((Tcl_WideUInt) 1) << 51) +#endif + +/* 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'. */ + +/* Inexact higher powers of ten */ + +static CONST double pow_10_2_n [] = { + 1.0, + 100.0, + 10000.0, + 1.0e+8, + 1.0e+16, + 1.0e+32, + 1.0e+64, + 1.0e+128, + 1.0e+256 +}; + + /* Logarithm of the floating point radix. */ + +static int log2FLT_RADIX; + +/* Number of bits in a double's significand */ + +static int mantBits; + +/* Table of powers of 5**(2**n), up to 5**256 */ + +static mp_int pow5[9]; + +/* The smallest representable double */ + +static double tiny; + +/* The maximum number of digits to the left of the decimal point of a + * double. */ + +static int maxDigits; + +/* The maximum number of digits to the right of the decimal point in a + * double. */ + +static int minDigits; + +/* Number of mp_digit's needed to hold the significand of a double */ + +static int mantDIGIT; + +/* Static functions defined in this file */ + +static 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 )); + + +/* + *---------------------------------------------------------------------- + * + * TclParseNumber -- + * + * Place a "numeric" internal representation on a Tcl object. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * 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. + * + *---------------------------------------------------------------------- + */ + +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 */ +{ + + 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 + + /* + * Initialize string to start of the object's string rep if + * the caller didn't pass anything else. + */ + + if ( string == NULL ) { + string = Tcl_GetStringFromObj( objPtr, NULL ); + } + + p = string; + len = length; + acceptPoint = p; + acceptLen = len; + while ( 1 ) { + char c = len ? *p : '\0'; + switch (state) { + + 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 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; + + 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 */ + + 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 */ + + 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') { + ++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 { + 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); + } + } + if (!significandOverflow) { + significandWide + = (significandWide << shift) + d; + } else { + mp_mul_2d(&significandBig, shift, + &significandBig); + mp_add_d(&significandBig, (mp_digit) d, + &significandBig); + } + } + 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; + } + 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 + + 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; + + /* + * 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 { + numSigDigs = 1; + } + numTrailZeros = 0; + state = FRACTION; + break; + } + goto endgame; + + 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 */ + + 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; + + 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; + } + state = EXPONENT; + break; + } + goto endgame; + + /* + * Parse out INFINITY by simply spelling it out. + * INF is accepted as an abbreviation; other prefices are + * not. + */ + 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; + + /* + * 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; + + /* + * 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: + + /* Back up to the last accepting state in the lexer */ + + if (acceptState == INITIAL) { + status = TCL_ERROR; + } + p = acceptPoint; + len = acceptLen; + + /* Skip past trailing whitespace */ + + if (endPtrPtr != NULL) { + *endPtrPtr = p; + } + + while (len > 0 && isspace(UCHAR(*p))) { + ++p; + --len; + } + + /* Determine whether a partial string is acceptable. */ + + if (endPtrPtr == NULL && len != 0 && *p != '\0') { + status = TCL_ERROR; + } + + /* Generate and store the appropriate internal rep */ + + 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); + } + } + 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; + + } + } + + /* 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 ); + } + } + + /* Free memory */ + + if (octalSignificandOverflow) { + mp_clear(&octalSignificandBig); + } + 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. + * + *---------------------------------------------------------------------- + */ + +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 { + + /* + * 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 */ + + /* + * With gcc on x86, the floating point rounding mode is double-extended. + * This causes the result of double-precision calculations to be rounded + * twice: once to the precision of double-extended and then again to the + * precision of double. Double-rounding introduces gratuitous errors of + * 1 ulp, so we need to change rounding mode to 53-bits. + */ + +#if defined(__GNUC__) && defined(__i386) + fpu_control_t roundTo53Bits = 0x027f; + fpu_control_t oldRoundingMode; + _FPU_GETCW( oldRoundingMode ); + _FPU_SETCW( roundTo53Bits ); +#endif + + /* Test for the easy cases */ + + if ( numSigDigs <= DBL_DIG ) { + if ( exponent >= 0 ) { + if ( exponent <= mmaxpow ) { + + /* + * The significand is an exact integer, and so is + * 10**exponent. The product will be correct to within + * 1/2 ulp without special handling. + */ + + retval = (double)(Tcl_WideInt)significand * pow10[ exponent ]; + goto returnValue; + + } 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; + } + } + } + + /* + * 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 ( 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 */ + + /* + * With gcc on x86, the floating point rounding mode is double-extended. + * This causes the result of double-precision calculations to be rounded + * twice: once to the precision of double-extended and then again to the + * precision of double. Double-rounding introduces gratuitous errors of + * 1 ulp, so we need to change rounding mode to 53-bits. + */ + +#if defined(__GNUC__) && defined(__i386) + fpu_control_t roundTo53Bits = 0x027f; + fpu_control_t oldRoundingMode; + _FPU_GETCW( oldRoundingMode ); + _FPU_SETCW( roundTo53Bits ); +#endif + + /* Quick checks for over/underflow */ + + if ( numSigDigs + exponent - 1 > maxDigits ) { + retval = HUGE_VAL; + goto returnValue; + } + if ( numSigDigs + exponent - 1 < minDigits ) { + retval = 0; + goto returnValue; + } + + /* + * 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. + */ + + 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; + } + + /* + * Refine the result twice. (The second refinement should be + * necessary only if the best approximation is a power of 2 + * minus 1/2 ulp). + */ + + retval = RefineApproximation( retval, significand, exponent ); + retval = RefineApproximation( retval, significand, exponent ); + + /* Come here to return the computed value */ + + returnValue: + 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; +} + +/* + *---------------------------------------------------------------------- + * + * MakeNaN -- + * + * Makes a "Not a Number" given a set of bits to put in the + * tag bits + * + * 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. + * + *---------------------------------------------------------------------- + */ + +static double +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 msb; /* Most significant bit position of an + * intermediate result */ + int nDigits; /* Number of mp_digit's in an intermediate + * result */ + mp_int twoMv; /* Approx binary value expressed as an + * exact integer scaled by the multiplier 2M */ + mp_int twoMd; /* Exact decimal value expressed as an + * exact integer scaled by the multiplier 2M */ + int scale; /* Scale factor for M */ + int multiplier; /* Power of two to scale M */ + double num, den; /* Numerator and denominator of the + * correction term */ + double quot; /* Correction term */ + double minincr; /* Lower bound on the absolute value + * of the correction term. */ + int i; + + /* + * The first approximation is always low. If we find that + * it's HUGE_VAL, we're done. + */ + + if ( approxResult == HUGE_VAL ) { + return approxResult; + } + + /* + * Find a common denominator for the decimal and binary fractions. + * The common denominator will be 2**M2 + 5**M5. + */ + + significand = frexp( approxResult, &binExponent ); + i = mantBits - binExponent; + if ( i < 0 ) { + M2 = 0; + } else { + M2 = i; + } + if ( exponent > 0 ) { + M5 = 0; + } else { + M5 = -exponent; + if ( (M5-1) > M2 ) { + M2 = M5-1; + } + } + + /* + * The floating point number is significand*2**binExponent. + * 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 */ + nDigits = msb / DIGIT_BIT + 1; + mp_init_size( &twoMv, nDigits ); + i = ( msb % DIGIT_BIT + 1 ); + twoMv.used = nDigits; + significand *= SafeLdExp( 1.0, i ); + while ( -- nDigits >= 0 ) { + twoMv.dp[nDigits] = (mp_digit) significand; + significand -= (mp_digit) significand; + significand = SafeLdExp( significand, DIGIT_BIT ); + } + for ( i = 0; i <= 8; ++i ) { + if ( M5 & ( 1 << i ) ) { + mp_mul( &twoMv, pow5+i, &twoMv ); + } + } + + /* + * Collect the decimal significand as a high precision integer. + * The least significant bit corresponds to bit M2+exponent+1 + * so it will need to be shifted left by that many bits after + * being multiplied by 5**(M5+exponent). + */ + + mp_init_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 ); + + /* + * The result, 2Mv-2Md, needs to be divided by 2M to yield a correction + * term. Because 2M may well overflow a double, we need to scale the + * denominator by a factor of 2**binExponent-mantBits + */ + + scale = binExponent - mantBits - 1; + + mp_set( &twoMv, 1 ); + for ( i = 0; i <= 8; ++i ) { + if ( M5 & ( 1 << i ) ) { + mp_mul( &twoMv, pow5+i, &twoMv ); + } + } + multiplier = M2 + scale + 1; + if ( multiplier > 0 ) { + mp_mul_2d( &twoMv, multiplier, &twoMv ); + } else if ( multiplier < 0 ) { + mp_div_2d( &twoMv, -multiplier, &twoMv, NULL ); + } + + /* + * If the result is less than unity, the error is less than 1/2 unit + * in the last place, so there's no correction to make. + */ + + if ( mp_cmp_mag( &twoMd, &twoMv ) == MP_LT ) { + return approxResult; + } + + /* + * Convert the numerator and denominator of the corrector term + * accurately to floating point numbers. + */ + + num = TclBignumToDouble( &twoMd ); + den = TclBignumToDouble( &twoMv ); + + quot = SafeLdExp( num/den, scale ); + minincr = SafeLdExp( 1.0, binExponent - mantBits ); + + if ( quot < 0. && quot > -minincr ) { + quot = -minincr; + } else if ( quot > 0. && quot < minincr ) { + quot = minincr; + } + + mp_clear( &twoMd ); + mp_clear( &twoMv ); + + + return approxResult + quot; +} + +/* + *---------------------------------------------------------------------- + * + * TclDoubleDigits -- + * + * Converts a double to a string of digits. + * + * Results: + * Returns the position of the character in the string after which the + * decimal point should appear. Since the string contains only + * significant digits, the position may be less than zero or greater than + * the length of the string. + * + * Side effects: + * Stores the digits in the given buffer and sets 'signum' according to + * the sign of the number. + * + *---------------------------------------------------------------------- + */ + +int +TclDoubleDigits( char * 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. */ +{ + 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. */ + mp_int mminus; /* Scaled epsilon: (r - 2*mminus) == v(-) + * where v(-) is the floating point + * predecessor of v. */ + mp_int temp; + int rfac2 = 0; /* Powers of 2 and 5 by which large */ + int rfac5 = 0; /* integers should be scaled. */ + int sfac2 = 0; + int sfac5 = 0; + int mplusfac2 = 0; + int mminusfac2 = 0; + char c; + int i, k, n; + + /* Split the number into absolute value and signum. */ + + v = AbsoluteValue(v, signum); + + /* + * Handle zero specially. + */ + + if ( v == 0.0 ) { + *string++ = '0'; + *string++ = '\0'; + return 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. + */ + + smallestSig = GetIntegerTimesPower(v, &r, &e); + + lowOK = highOK = (mp_iseven(&r)); + + /* + * We are going to want to develop integers r, s, mplus, and mminus such + * that v = r / s, v(+)-v / 2 = mplus / s; v-v(-) / 2 = mminus / s and + * then scale either s or r, mplus, mminus by an appropriate power of ten. + * + * We actually do this by keeping track of the powers of 2 and 5 by which + * f is multiplied to yield v and by which 1 is multiplied to yield s, + * mplus, and mminus. + */ + + if (e >= 0) { + int bits = e * log2FLT_RADIX; + + if (!smallestSig) { + /* + * Normal case, m+ and m- are both FLT_RADIX**e + */ + + rfac2 = bits + 1; + sfac2 = 1; + mplusfac2 = bits; + mminusfac2 = bits; + } else { + /* + * If f is equal to the smallest significand, then we need another + * factor of FLT_RADIX in s to cope with stepping to the next + * smaller exponent when going to e's predecessor. + */ + + rfac2 = bits + log2FLT_RADIX + 1; + sfac2 = 1 + log2FLT_RADIX; + mplusfac2 = bits + log2FLT_RADIX; + mminusfac2 = bits; + } + } else { + /* + * v has digits after the binary point + */ + + if (e <= DBL_MIN_EXP-DBL_MANT_DIG || !smallestSig) { + /* + * Either f isn't the smallest significand or e is the smallest + * exponent. mplus and mminus will both be 1. + */ + + rfac2 = 1; + sfac2 = 1 - e * log2FLT_RADIX; + mplusfac2 = 0; + mminusfac2 = 0; + } else { + /* + * f is the smallest significand, but e is not the smallest + * exponent. We need to scale by FLT_RADIX again to cope with the + * fact that v's predecessor has a smaller exponent. + */ + + rfac2 = 1 + log2FLT_RADIX; + sfac2 = 1 + log2FLT_RADIX * (1 - e); + mplusfac2 = FLT_RADIX; + mminusfac2 = 0; + } + } + + /* + * Estimate the highest power of ten that will be needed to hold the + * result. + */ + + k = (int) ceil(log(v) / log(10.)); + if (k >= 0) { + sfac2 += k; + sfac5 = k; + } else { + rfac2 -= k; + mplusfac2 -= k; + mminusfac2 -= k; + rfac5 = -k; + } + + /* + * Scale r, s, mplus, mminus by the appropriate powers of 2 and 5. + */ + + mp_init_set(&mplus, 1); + for (i=0 ; i<=8 ; ++i) { + if (rfac5 & (1 << i)) { + mp_mul(&mplus, pow5+i, &mplus); + } + } + mp_mul(&r, &mplus, &r); + mp_mul_2d(&r, rfac2, &r); + mp_init_copy(&mminus, &mplus); + mp_mul_2d(&mplus, mplusfac2, &mplus); + mp_mul_2d(&mminus, mminusfac2, &mminus); + mp_init_set(&s, 1); + for (i=0 ; i<=8 ; ++i) { + if (sfac5 & (1 << i)) { + mp_mul(&s, pow5+i, &s); + } + } + mp_mul_2d(&s, sfac2, &s); + + /* + * It is possible for k to be off by one because we used an inexact + * logarithm. + */ + + mp_init(&temp); + mp_add(&r, &mplus, &temp); + i = mp_cmp_mag(&temp, &s); + if (i>0 || (highOK && i==0)) { + mp_mul_d(&s, 10, &s); + ++k; + } else { + mp_mul_d(&temp, 10, &temp); + i = mp_cmp_mag(&temp, &s); + if (i<0 || (highOK && i==0)) { + mp_mul_d(&r, 10, &r); + mp_mul_d(&mplus, 10, &mplus); + mp_mul_d(&mminus, 10, &mminus); + --k; + } + } + + /* + * At this point, k contains the power of ten by which we're scaling the + * result. r/s is at least 1/10 and strictly less than ten, and v = r/s * + * 10**k. mplus and mminus give the rounding limits. + */ + + for (;;) { + int tc1, tc2; + + mp_mul_d(&r, 10, &r); + mp_div(&r, &s, &temp, &r); /* temp = 10r / s; r = 10r mod s */ + i = temp.dp[0]; + mp_mul_d(&mplus, 10, &mplus); + mp_mul_d(&mminus, 10, &mminus); + tc1 = mp_cmp_mag(&r, &mminus); + if (lowOK) { + tc1 = (tc1 <= 0); + } else { + tc1 = (tc1 < 0); + } + mp_add(&r, &mplus, &temp); + tc2 = mp_cmp_mag(&temp, &s); + if (highOK) { + tc2 = (tc2 >= 0); + } else { + tc2= (tc2 > 0); + } + if ( ! tc1 ) { + if ( !tc2 ) { + *string++ = '0' + i; + } else { + c = (char) (i + '1'); + break; + } + } else { + if (!tc2) { + c = (char) (i + '0'); + } else { + mp_mul_2d(&r, 1, &r); + n = mp_cmp_mag(&r, &s); + if (n < 0) { + c = (char) (i + '0'); + } else { + c = (char) (i + '1'); + } + } + break; + } + }; + *string++ = c; + *string++ = '\0'; + + /* + * Free memory, and return. + */ + + mp_clear_multi(&r, &s, &mplus, &mminus, &temp, NULL); + return k; +} + +/* + *---------------------------------------------------------------------- + * + * 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 + * 'double' + * + * Results: + * None. + * + * Side effects: + * The log base 2 of the floating point radix, the number of bits in a + * double mantissa, and a table of the powers of five and ten are + * computed and stored. + * + *---------------------------------------------------------------------- + */ + +void +TclInitDoubleConversion(void) +{ + int i; + int x; + Tcl_WideUInt u; + double d; + + /* + * 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; + + /* + * 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; + } + for (i=0 ; i<=mmaxpow ; ++i) { + pow10[i] = d; + d *= 10.0; + } + + /* 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 ); + } + + /* + * 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.)); +} + +/* + *---------------------------------------------------------------------- + * + * TclFinalizeDoubleConversion -- + * + * Cleans up this file on exit. + * + * Results: + * None + * + * Side effects: + * Memory allocated by TclInitDoubleConversion is freed. + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeDoubleConversion() +{ + int 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; +} + +/* + *---------------------------------------------------------------------- + * + * TclBignumToDouble -- + * + * Convert an arbitrary-precision integer to a native floating point + * number. + * + * Results: + * Returns the converted number. Sets errno to ERANGE if the number is + * too large to convert. + * + *---------------------------------------------------------------------- + */ + +double +TclBignumToDouble(mp_int *a) /* Integer to convert. */ +{ + mp_int b; + int bits; + int shift; + int i; + double r; + + /* + * Determine how many bits we need, and extract that many from the input. + * Round to nearest unit in the last place. + */ + + bits = mp_count_bits(a); + if (bits > DBL_MAX_EXP*log2FLT_RADIX) { + errno = ERANGE; + if (a->sign == MP_ZPOS) { + return HUGE_VAL; + } else { + return -HUGE_VAL; + } + } + shift = mantBits + 1 - bits; + mp_init(&b); + if (shift > 0) { + mp_mul_2d(a, shift, &b); + } else if (shift < 0) { + mp_div_2d(a, -shift, &b, NULL); + } else { + mp_copy(a, &b); + } + mp_add_d(&b, 1, &b); + mp_div_2d(&b, 1, &b, NULL); + + /* + * Accumulate the result, one mp_digit at a time. + */ + + r = 0.0; + for (i=b.used-1 ; i>=0 ; --i) { + r = ldexp(r, DIGIT_BIT) + b.dp[i]; + } + mp_clear(&b); + + /* + * Scale the result to the correct number of bits. + */ + + r = ldexp(r, bits - mantBits); + + /* + * Return the result with the appropriate sign. + */ + + if (a->sign == MP_ZPOS) { + return r; + } else { + return -r; + } +} + +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<= 0 means that there is a - * valid Unicode rep, or that the number - * of UTF bytes == the number of chars. */ - size_t allocated; /* The amount of space actually allocated - * for the UTF string (minus 1 byte for - * the termination char). */ - size_t uallocated; /* The amount of space actually allocated - * for the Unicode string (minus 2 bytes for - * the termination char). */ - int hasUnicode; /* Boolean determining whether the string - * has a Unicode representation. */ - Tcl_UniChar unicode[2]; /* The array of Unicode chars. The actual - * size of this field depends on the - * 'uallocated' field above. */ + int numChars; /* The number of chars in the string. -1 means + * this value has not been calculated. >= 0 + * means that there is a valid Unicode rep, or + * that the number of UTF bytes == the number + * of chars. */ + size_t allocated; /* The amount of space actually allocated for + * the UTF string (minus 1 byte for the + * termination char). */ + size_t uallocated; /* The amount of space actually allocated for + * the Unicode string (minus 2 bytes for the + * termination char). */ + int hasUnicode; /* Boolean determining whether the string has + * a Unicode representation. */ + Tcl_UniChar unicode[2]; /* The array of Unicode chars. The actual size + * of this field depends on the 'uallocated' + * field above. */ } String; #define STRING_UALLOC(numChars) \ - (numChars * sizeof(Tcl_UniChar)) + (numChars * sizeof(Tcl_UniChar)) #define STRING_SIZE(ualloc) \ - ((unsigned) (sizeof(String) - sizeof(Tcl_UniChar) + ualloc)) + ((unsigned) (sizeof(String) - sizeof(Tcl_UniChar) + ualloc)) #define GET_STRING(objPtr) \ - ((String *) (objPtr)->internalRep.otherValuePtr) + ((String *) (objPtr)->internalRep.otherValuePtr) #define SET_STRING(objPtr, stringPtr) \ - (objPtr)->internalRep.otherValuePtr = (VOID *) (stringPtr) + ((objPtr)->internalRep.otherValuePtr = (VOID *) (stringPtr)) /* * TCL STRING GROWTH ALGORITHM * * When growing strings (during an append, for example), the following growth @@ -119,147 +128,139 @@ * algorithm is used: * * Attempt to allocate 2 * (originalLength + appendLength) * On failure: * attempt to allocate originalLength + 2*appendLength + - * TCL_GROWTH_MIN_ALLOC + * TCL_GROWTH_MIN_ALLOC * * This algorithm allows very good performance, as it rapidly increases the * memory allocated for a given string, which minimizes the number of - * reallocations that must be performed. However, using only the doubling - * algorithm can lead to a significant waste of memory. In particular, it - * may fail even when there is sufficient memory available to complete the - * append request (but there is not 2 * totalLength memory available). So when - * the doubling fails (because there is not enough memory available), the + * reallocations that must be performed. However, using only the doubling + * algorithm can lead to a significant waste of memory. In particular, it may + * fail even when there is sufficient memory available to complete the append + * request (but there is not 2*totalLength memory available). So when the + * doubling fails (because there is not enough memory available), the * algorithm requests a smaller amount of memory, which is still enough to - * cover the request, but which hopefully will be less than the total available - * memory. - * - * The addition of TCL_GROWTH_MIN_ALLOC allows for efficient handling - * of very small appends. Without this extra slush factor, a sequence - * of several small appends would cause several memory allocations. - * As long as TCL_GROWTH_MIN_ALLOC is a reasonable size, we can - * avoid that behavior. + * cover the request, but which hopefully will be less than the total + * available memory. + * + * The addition of TCL_GROWTH_MIN_ALLOC allows for efficient handling of very + * small appends. Without this extra slush factor, a sequence of several small + * appends would cause several memory allocations. As long as + * TCL_GROWTH_MIN_ALLOC is a reasonable size, we can avoid that behavior. * * The growth algorithm can be tuned by adjusting the following parameters: * * TCL_GROWTH_MIN_ALLOC Additional space, in bytes, to allocate when - * the double allocation has failed. - * Default is 1024 (1 kilobyte). + * the double allocation has failed. Default is + * 1024 (1 kilobyte). */ + #ifndef TCL_GROWTH_MIN_ALLOC #define TCL_GROWTH_MIN_ALLOC 1024 #endif - /* *---------------------------------------------------------------------- * * Tcl_NewStringObj -- * - * This procedure is normally called when not debugging: i.e., when + * This function is normally called when not debugging: i.e., when * TCL_MEM_DEBUG is not defined. It creates a new string object and * initializes it from the byte pointer and length arguments. * - * When TCL_MEM_DEBUG is defined, this procedure just returns the - * result of calling the debugging version Tcl_DbNewStringObj. + * When TCL_MEM_DEBUG is defined, this function just returns the result + * of calling the debugging version Tcl_DbNewStringObj. * * Results: * A newly created string object is returned that has ref count zero. * * Side effects: - * The new object's internal string representation will be set to a - * copy of the length bytes starting at "bytes". If "length" is - * negative, use bytes up to the first NULL byte; i.e., assume "bytes" - * points to a C-style NULL-terminated string. The object's type is set - * to NULL. An extra NULL is added to the end of the new object's byte - * array. + * The new object's internal string representation will be set to a copy + * of the length bytes starting at "bytes". If "length" is negative, use + * bytes up to the first NULL byte; i.e., assume "bytes" points to a + * C-style NULL-terminated string. The object's type is set to NULL. An + * extra NULL is added to the end of the new object's byte array. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG #undef Tcl_NewStringObj - Tcl_Obj * Tcl_NewStringObj(bytes, length) CONST char *bytes; /* Points to the first of the length bytes * used to initialize the new object. */ int length; /* The number of bytes to copy from "bytes" - * when initializing the new object. If - * negative, use bytes up to the first - * NULL byte. */ + * when initializing the new object. If + * negative, use bytes up to the first NULL + * byte. */ { return Tcl_DbNewStringObj(bytes, length, "unknown", 0); } - #else /* if not TCL_MEM_DEBUG */ - Tcl_Obj * Tcl_NewStringObj(bytes, length) CONST char *bytes; /* Points to the first of the length bytes * used to initialize the new object. */ int length; /* The number of bytes to copy from "bytes" - * when initializing the new object. If - * negative, use bytes up to the first - * NULL byte. */ + * when initializing the new object. If + * negative, use bytes up to the first NULL + * byte. */ { register Tcl_Obj *objPtr; if (length < 0) { length = (bytes? strlen(bytes) : 0); } - TclNewObj(objPtr); - TclInitStringRep(objPtr, bytes, length); + TclNewStringObj(objPtr, bytes, length); return objPtr; } #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_DbNewStringObj -- * - * This procedure is normally called when debugging: i.e., when + * This function is normally called when debugging: i.e., when * TCL_MEM_DEBUG is defined. It creates new string objects. It is the - * same as the Tcl_NewStringObj procedure above except that it calls + * same as the Tcl_NewStringObj function above except that it calls * Tcl_DbCkalloc directly with the file name and line number from its * caller. This simplifies debugging since then the [memory active] - * command will report the correct file name and line number when + * command will report the correct file name and line number when * reporting objects that haven't been freed. * - * When TCL_MEM_DEBUG is not defined, this procedure just returns the + * When TCL_MEM_DEBUG is not defined, this function just returns the * result of calling Tcl_NewStringObj. * * Results: * A newly created string object is returned that has ref count zero. * * Side effects: - * The new object's internal string representation will be set to a - * copy of the length bytes starting at "bytes". If "length" is - * negative, use bytes up to the first NULL byte; i.e., assume "bytes" - * points to a C-style NULL-terminated string. The object's type is set - * to NULL. An extra NULL is added to the end of the new object's byte - * array. + * The new object's internal string representation will be set to a copy + * of the length bytes starting at "bytes". If "length" is negative, use + * bytes up to the first NULL byte; i.e., assume "bytes" points to a + * C-style NULL-terminated string. The object's type is set to NULL. An + * extra NULL is added to the end of the new object's byte array. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG - Tcl_Obj * Tcl_DbNewStringObj(bytes, length, file, line) CONST char *bytes; /* Points to the first of the length bytes * used to initialize the new object. */ int length; /* The number of bytes to copy from "bytes" - * when initializing the new object. If - * negative, use bytes up to the first - * NULL byte. */ + * when initializing the new object. If + * negative, use bytes up to the first NULL + * byte. */ CONST char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + * function; used for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { register Tcl_Obj *objPtr; if (length < 0) { length = (bytes? strlen(bytes) : 0); @@ -266,25 +267,23 @@ } TclDbNewObj(objPtr, file, line); TclInitStringRep(objPtr, bytes, length); return objPtr; } - #else /* if not TCL_MEM_DEBUG */ - Tcl_Obj * Tcl_DbNewStringObj(bytes, length, file, line) CONST char *bytes; /* Points to the first of the length bytes * used to initialize the new object. */ register int length; /* The number of bytes to copy from "bytes" - * when initializing the new object. If - * negative, use bytes up to the first - * NULL byte. */ + * when initializing the new object. If + * negative, use bytes up to the first NULL + * byte. */ CONST char *file; /* The name of the source file calling this - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + * function; used for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { return Tcl_NewStringObj(bytes, length); } #endif /* TCL_MEM_DEBUG */ @@ -291,29 +290,28 @@ /* *--------------------------------------------------------------------------- * * Tcl_NewUnicodeObj -- * - * This procedure is creates a new String object and initializes - * it from the given Unicode String. If the Utf String is the same size - * as the Unicode string, don't duplicate the data. + * This function is creates a new String object and initializes it from + * the given Unicode String. If the Utf String is the same size as the + * Unicode string, don't duplicate the data. * * Results: - * The newly created object is returned. This object will have no - * initial string representation. The returned object has a ref count - * of 0. + * The newly created object is returned. This object will have no initial + * string representation. The returned object has a ref count of 0. * * Side effects: * Memory allocated for new object and copy of Unicode argument. * *--------------------------------------------------------------------------- */ Tcl_Obj * Tcl_NewUnicodeObj(unicode, numChars) - CONST Tcl_UniChar *unicode; /* The unicode string used to initialize - * the new object. */ + CONST Tcl_UniChar *unicode; /* The unicode string used to initialize the + * new object. */ int numChars; /* Number of characters in the unicode * string. */ { Tcl_Obj *objPtr; String *stringPtr; @@ -320,11 +318,13 @@ size_t uallocated; if (numChars < 0) { numChars = 0; if (unicode) { - while (unicode[numChars] != 0) { numChars++; } + while (unicode[numChars] != 0) { + numChars++; + } } } uallocated = STRING_UALLOC(numChars); /* @@ -355,73 +355,76 @@ * * Results: * Pointer to unicode string representing the unicode object. * * Side effects: - * Frees old internal rep. Allocates memory for new "String" - * internal rep. + * Frees old internal rep. Allocates memory for new "String" internal + * rep. * *---------------------------------------------------------------------- */ int Tcl_GetCharLength(objPtr) - Tcl_Obj *objPtr; /* The String object to get the num chars of. */ + Tcl_Obj *objPtr; /* The String object to get the num chars + * of. */ { String *stringPtr; - + SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); /* - * If numChars is unknown, then calculate the number of characaters - * while populating the Unicode string. + * If numChars is unknown, then calculate the number of characaters while + * populating the Unicode string. */ - + if (stringPtr->numChars == -1) { register int i = objPtr->length; register unsigned char *str = (unsigned char *) objPtr->bytes; /* * This is a speed sensitive function, so run specially over the - * 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); - */ + * 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)) { i--; str++; } + while (i && (*str < 0xC0)) { + i--; + str++; + } stringPtr->numChars = objPtr->length - i; if (i) { stringPtr->numChars += Tcl_NumUtfChars(objPtr->bytes + (objPtr->length - i), i); } - if (stringPtr->numChars == objPtr->length) { - + if (stringPtr->numChars == objPtr->length) { /* - * Since we've just calculated the number of chars, and all - * UTF chars are 1-byte long, we don't need to store the - * unicode string. + * Since we've just calculated the number of chars, and all UTF + * chars are 1-byte long, we don't need to store the unicode + * string. */ stringPtr->hasUnicode = 0; - } else { - /* - * Since we've just calucalated the number of chars, and not - * all UTF chars are 1-byte long, go ahead and populate the - * unicode string. + * Since we've just calucalated the number of chars, and not all + * UTF chars are 1-byte long, go ahead and populate the unicode + * string. */ FillUnicodeRep(objPtr); /* * We need to fetch the pointer again because we have just * reallocated the structure to make room for the Unicode data. */ - + stringPtr = GET_STRING(objPtr); } } return stringPtr->numChars; } @@ -429,12 +432,12 @@ /* *---------------------------------------------------------------------- * * Tcl_GetUniChar -- * - * Get the index'th Unicode character from the String object. The - * index is assumed to be in the appropriate range. + * Get the index'th Unicode character from the String object. The index + * is assumed to be in the appropriate range. * * Results: * Returns the index'th Unicode character in the Object. * * Side effects: @@ -443,42 +446,40 @@ *---------------------------------------------------------------------- */ Tcl_UniChar Tcl_GetUniChar(objPtr, index) - Tcl_Obj *objPtr; /* The object to get the Unicode charater from. */ - int index; /* Get the index'th Unicode character. */ + Tcl_Obj *objPtr; /* The object to get the Unicode charater + * from. */ + int index; /* Get the index'th Unicode character. */ { Tcl_UniChar unichar; String *stringPtr; - + SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); if (stringPtr->numChars == -1) { - /* - * We haven't yet calculated the length, so we don't have the - * Unicode str. We need to know the number of chars before we - * can do indexing. + * We haven't yet calculated the length, so we don't have the Unicode + * str. We need to know the number of chars before we can do indexing. */ Tcl_GetCharLength(objPtr); /* * We need to fetch the pointer again because we may have just * reallocated the structure. */ - + stringPtr = GET_STRING(objPtr); } if (stringPtr->hasUnicode == 0) { - /* - * All of the characters in the Utf string are 1 byte chars, - * so we don't store the unicode char. We get the Utf string - * and convert the index'th byte to a Unicode character. + * All of the characters in the Utf string are 1 byte chars, so we + * don't store the unicode char. We get the Utf string and convert the + * index'th byte to a Unicode character. */ unichar = (Tcl_UniChar) objPtr->bytes[index]; } else { unichar = stringPtr->unicode[index]; @@ -489,14 +490,14 @@ /* *---------------------------------------------------------------------- * * Tcl_GetUnicode -- * - * Get the Unicode form of the String object. If - * the object is not already a String object, it will be converted - * to one. If the String object does not have a Unicode rep, then - * one is create from the UTF string format. + * Get the Unicode form of the String object. If the object is not + * already a String object, it will be converted to one. If the String + * object does not have a Unicode rep, then one is create from the UTF + * string format. * * Results: * Returns a pointer to the object's internal Unicode string. * * Side effects: @@ -505,34 +506,34 @@ *---------------------------------------------------------------------- */ Tcl_UniChar * Tcl_GetUnicode(objPtr) - Tcl_Obj *objPtr; /* The object to find the unicode string for. */ + Tcl_Obj *objPtr; /* The object to find the unicode string + * for. */ { String *stringPtr; - + SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); - + if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) { - /* - * We haven't yet calculated the length, or all of the characters - * in the Utf string are 1 byte chars (so we didn't store the - * unicode str). Since this function must return a unicode string, - * and one has not yet been stored, force the Unicode to be - * calculated and stored now. + * We haven't yet calculated the length, or all of the characters in + * the Utf string are 1 byte chars (so we didn't store the unicode + * str). Since this function must return a unicode string, and one has + * not yet been stored, force the Unicode to be calculated and stored + * now. */ FillUnicodeRep(objPtr); /* - * We need to fetch the pointer again because we have just - * reallocated the structure to make room for the Unicode data. + * We need to fetch the pointer again because we have just reallocated + * the structure to make room for the Unicode data. */ - + stringPtr = GET_STRING(objPtr); } return stringPtr->unicode; } @@ -539,14 +540,14 @@ /* *---------------------------------------------------------------------- * * Tcl_GetUnicodeFromObj -- * - * Get the Unicode form of the String object with length. If - * the object is not already a String object, it will be converted - * to one. If the String object does not have a Unicode rep, then - * one is create from the UTF string format. + * Get the Unicode form of the String object with length. If the object + * is not already a String object, it will be converted to one. If the + * String object does not have a Unicode rep, then one is create from the + * UTF string format. * * Results: * Returns a pointer to the object's internal Unicode string. * * Side effects: @@ -555,37 +556,37 @@ *---------------------------------------------------------------------- */ Tcl_UniChar * Tcl_GetUnicodeFromObj(objPtr, lengthPtr) - Tcl_Obj *objPtr; /* The object to find the unicode string for. */ - int *lengthPtr; /* If non-NULL, the location where the - * string rep's unichar length should be - * stored. If NULL, no length is stored. */ + Tcl_Obj *objPtr; /* The object to find the unicode string + * for. */ + int *lengthPtr; /* If non-NULL, the location where the string + * rep's unichar length should be stored. If + * NULL, no length is stored. */ { String *stringPtr; - + SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); - + if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) { - /* - * We haven't yet calculated the length, or all of the characters - * in the Utf string are 1 byte chars (so we didn't store the - * unicode str). Since this function must return a unicode string, - * and one has not yet been stored, force the Unicode to be - * calculated and stored now. + * We haven't yet calculated the length, or all of the characters in + * the Utf string are 1 byte chars (so we didn't store the unicode + * str). Since this function must return a unicode string, and one has + * not yet been stored, force the Unicode to be calculated and stored + * now. */ FillUnicodeRep(objPtr); /* - * We need to fetch the pointer again because we have just - * reallocated the structure to make room for the Unicode data. + * We need to fetch the pointer again because we have just reallocated + * the structure to make room for the Unicode data. */ - + stringPtr = GET_STRING(objPtr); } if (lengthPtr != NULL) { *lengthPtr = stringPtr->numChars; @@ -596,14 +597,14 @@ /* *---------------------------------------------------------------------- * * Tcl_GetRange -- * - * Create a Tcl Object that contains the chars between first and last - * of the object indicated by "objPtr". If the object is not already - * a String object, convert it to one. The first and last indices - * are assumed to be in the appropriate range. + * Create a Tcl Object that contains the chars between first and last of + * the object indicated by "objPtr". If the object is not already a + * String object, convert it to one. The first and last indices are + * assumed to be in the appropriate range. * * Results: * Returns a new Tcl Object of the String type. * * Side effects: @@ -618,48 +619,46 @@ int first; /* First index of the range. */ int last; /* Last index of the range. */ { Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ String *stringPtr; - + SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); if (stringPtr->numChars == -1) { - /* - * We haven't yet calculated the length, so we don't have the - * Unicode str. We need to know the number of chars before we - * can do indexing. + * We haven't yet calculated the length, so we don't have the Unicode + * str. We need to know the number of chars before we can do indexing. */ Tcl_GetCharLength(objPtr); /* * We need to fetch the pointer again because we may have just * reallocated the structure. */ - + stringPtr = GET_STRING(objPtr); } if (stringPtr->numChars == objPtr->length) { char *str = Tcl_GetString(objPtr); /* - * All of the characters in the Utf string are 1 byte chars, - * so we don't store the unicode char. Create a new string - * object containing the specified range of chars. + * All of the characters in the Utf string are 1 byte chars, so we + * don't store the unicode char. Create a new string object containing + * the specified range of chars. */ - + newObjPtr = Tcl_NewStringObj(&str[first], last-first+1); /* - * Since we know the new string only has 1-byte chars, we - * can set it's numChars field. + * Since we know the new string only has 1-byte chars, we can set it's + * numChars field. */ - + SetStringFromAny(NULL, newObjPtr); stringPtr = GET_STRING(newObjPtr); stringPtr->numChars = last-first+1; } else { newObjPtr = Tcl_NewUnicodeObj(stringPtr->unicode + first, @@ -672,20 +671,20 @@ *---------------------------------------------------------------------- * * Tcl_SetStringObj -- * * Modify an object to hold a string that is a copy of the bytes - * indicated by the byte pointer and length arguments. + * indicated by the byte pointer and length arguments. * * Results: * None. * * Side effects: - * The object's string representation will be set to a copy of - * the "length" bytes starting at "bytes". If "length" is negative, use - * bytes up to the first NULL byte; i.e., assume "bytes" points to a - * C-style NULL-terminated string. The object's old string and internal + * The object's string representation will be set to a copy of the + * "length" bytes starting at "bytes". If "length" is negative, use bytes + * up to the first NULL byte; i.e., assume "bytes" points to a C-style + * NULL-terminated string. The object's old string and internal * representations are freed and the object's type is set NULL. * *---------------------------------------------------------------------- */ @@ -693,17 +692,16 @@ Tcl_SetStringObj(objPtr, bytes, length) register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ CONST char *bytes; /* Points to the first of the length bytes * used to initialize the object. */ register int length; /* The number of bytes to copy from "bytes" - * when initializing the object. If - * negative, use bytes up to the first - * NULL byte.*/ + * when initializing the object. If negative, + * use bytes up to the first NULL byte.*/ { /* - * Free any old string rep, then set the string rep to a copy of - * the length bytes starting at "bytes". + * Free any old string rep, then set the string rep to a copy of the + * length bytes starting at "bytes". */ if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetStringObj called with shared object"); } @@ -725,33 +723,32 @@ /* *---------------------------------------------------------------------- * * Tcl_SetObjLength -- * - * This procedure changes the length of the string representation - * of an object. + * This function changes the length of the string representation of an + * object. * * Results: * None. * * Side effects: - * If the size of objPtr's string representation is greater than - * length, then it is reduced to length and a new terminating null - * byte is stored in the strength. If the length of the string - * representation is greater than length, the storage space is - * reallocated to the given length; a null byte is stored at the - * end, but other bytes past the end of the original string - * representation are undefined. The object's internal + * If the size of objPtr's string representation is greater than length, + * then it is reduced to length and a new terminating null byte is stored + * in the strength. If the length of the string representation is greater + * than length, the storage space is reallocated to the given length; a + * null byte is stored at the end, but other bytes past the end of the + * original string representation are undefined. The object's internal * representation is changed to "expendable string". * *---------------------------------------------------------------------- */ void Tcl_SetObjLength(objPtr, length) - register Tcl_Obj *objPtr; /* Pointer to object. This object must - * not currently be shared. */ + register Tcl_Obj *objPtr; /* Pointer to object. This object must not + * currently be shared. */ register int length; /* Number of bytes desired for string * representation of object, not including * terminating null byte. */ { String *stringPtr; @@ -758,23 +755,26 @@ if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetObjLength called with shared object"); } SetStringFromAny(NULL, objPtr); - + stringPtr = GET_STRING(objPtr); - - /* Check that we're not extending a pure unicode string */ - - if (length > (int) stringPtr->allocated && + + /* + * Check that we're not extending a pure unicode string. + */ + + if (length > (int) stringPtr->allocated && (objPtr->bytes != NULL || stringPtr->hasUnicode == 0)) { char *new; /* - * Not enough space in current string. Reallocate the string - * space and free the old string. + * Not enough space in current string. Reallocate the string space and + * free the old string. */ + if (objPtr->bytes != tclEmptyStringRep && objPtr->bytes != NULL) { new = (char *) ckrealloc((char *)objPtr->bytes, (unsigned)(length+1)); } else { new = (char *) ckalloc((unsigned) (length+1)); @@ -784,69 +784,87 @@ Tcl_InvalidateStringRep(objPtr); } } objPtr->bytes = new; stringPtr->allocated = length; - /* Invalidate the unicode data. */ + + /* + * Invalidate the unicode data. + */ + stringPtr->hasUnicode = 0; } - + if (objPtr->bytes != NULL) { - objPtr->length = length; - if (objPtr->bytes != tclEmptyStringRep) { - /* Ensure the string is NULL-terminated */ - objPtr->bytes[length] = 0; - } - /* Invalidate the unicode data. */ - stringPtr->numChars = -1; - stringPtr->hasUnicode = 0; + objPtr->length = length; + if (objPtr->bytes != tclEmptyStringRep) { + /* + * Ensure the string is NULL-terminated. + */ + + objPtr->bytes[length] = 0; + } + + /* + * Invalidate the unicode data. + */ + + stringPtr->numChars = -1; + stringPtr->hasUnicode = 0; } else { - /* Changing length of pure unicode string */ - size_t uallocated = STRING_UALLOC(length); - if (uallocated > stringPtr->uallocated) { - stringPtr = (String *) ckrealloc((char*) stringPtr, - STRING_SIZE(uallocated)); - SET_STRING(objPtr, stringPtr); - stringPtr->uallocated = uallocated; - } - stringPtr->numChars = length; - stringPtr->hasUnicode = (length > 0); - /* Ensure the string is NULL-terminated */ - stringPtr->unicode[length] = 0; - stringPtr->allocated = 0; - objPtr->length = 0; + /* + * Changing length of pure unicode string. + */ + + size_t uallocated = STRING_UALLOC(length); + + if (uallocated > stringPtr->uallocated) { + stringPtr = (String *) ckrealloc((char*) stringPtr, + STRING_SIZE(uallocated)); + SET_STRING(objPtr, stringPtr); + stringPtr->uallocated = uallocated; + } + stringPtr->numChars = length; + stringPtr->hasUnicode = (length > 0); + + /* + * Ensure the string is NULL-terminated. + */ + + stringPtr->unicode[length] = 0; + stringPtr->allocated = 0; + objPtr->length = 0; } } /* *---------------------------------------------------------------------- * * Tcl_AttemptSetObjLength -- * - * This procedure changes the length of the string representation - * of an object. It uses the attempt* (non-panic'ing) memory allocators. + * This function changes the length of the string representation of an + * object. It uses the attempt* (non-panic'ing) memory allocators. * * Results: * 1 if the requested memory was allocated, 0 otherwise. * * Side effects: - * If the size of objPtr's string representation is greater than - * length, then it is reduced to length and a new terminating null - * byte is stored in the strength. If the length of the string - * representation is greater than length, the storage space is - * reallocated to the given length; a null byte is stored at the - * end, but other bytes past the end of the original string - * representation are undefined. The object's internal + * If the size of objPtr's string representation is greater than length, + * then it is reduced to length and a new terminating null byte is stored + * in the strength. If the length of the string representation is greater + * than length, the storage space is reallocated to the given length; a + * null byte is stored at the end, but other bytes past the end of the + * original string representation are undefined. The object's internal * representation is changed to "expendable string". * *---------------------------------------------------------------------- */ int Tcl_AttemptSetObjLength(objPtr, length) - register Tcl_Obj *objPtr; /* Pointer to object. This object must - * not currently be shared. */ + register Tcl_Obj *objPtr; /* Pointer to object. This object must not + * currently be shared. */ register int length; /* Number of bytes desired for string * representation of object, not including * terminating null byte. */ { String *stringPtr; @@ -853,23 +871,26 @@ if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_AttemptSetObjLength called with shared object"); } SetStringFromAny(NULL, objPtr); - + stringPtr = GET_STRING(objPtr); - /* Check that we're not extending a pure unicode string */ + /* + * Check that we're not extending a pure unicode string. + */ - if (length > (int) stringPtr->allocated && + if (length > (int) stringPtr->allocated && (objPtr->bytes != NULL || stringPtr->hasUnicode == 0)) { char *new; /* - * Not enough space in current string. Reallocate the string - * space and free the old string. + * Not enough space in current string. Reallocate the string space and + * free the old string. */ + if (objPtr->bytes != tclEmptyStringRep && objPtr->bytes != NULL) { new = (char *) attemptckrealloc((char *)objPtr->bytes, (unsigned)(length+1)); if (new == NULL) { return 0; @@ -878,45 +899,64 @@ new = (char *) attemptckalloc((unsigned) (length+1)); if (new == NULL) { return 0; } if (objPtr->bytes != NULL && objPtr->length != 0) { - memcpy((VOID *) new, (VOID *) objPtr->bytes, - (size_t) objPtr->length); - Tcl_InvalidateStringRep(objPtr); + memcpy((VOID *) new, (VOID *) objPtr->bytes, + (size_t) objPtr->length); + Tcl_InvalidateStringRep(objPtr); } } objPtr->bytes = new; stringPtr->allocated = length; - /* Invalidate the unicode data. */ + + /* + * Invalidate the unicode data. + */ + stringPtr->hasUnicode = 0; } - + if (objPtr->bytes != NULL) { objPtr->length = length; if (objPtr->bytes != tclEmptyStringRep) { - /* Ensure the string is NULL-terminated */ + /* + * Ensure the string is NULL-terminated. + */ + objPtr->bytes[length] = 0; } - /* Invalidate the unicode data. */ + + /* + * Invalidate the unicode data. + */ + stringPtr->numChars = -1; stringPtr->hasUnicode = 0; } else { - /* Changing length of pure unicode string */ + /* + * Changing length of pure unicode string. + */ + size_t uallocated = STRING_UALLOC(length); + if (uallocated > stringPtr->uallocated) { stringPtr = (String *) attemptckrealloc((char*) stringPtr, STRING_SIZE(uallocated)); if (stringPtr == NULL) { - return 0; + return 0; } SET_STRING(objPtr, stringPtr); stringPtr->uallocated = uallocated; } stringPtr->numChars = length; stringPtr->hasUnicode = (length > 0); - /* Ensure the string is NULL-terminated */ + + /* + * Ensure the string is NULL-terminated. + */ + stringPtr->unicode[length] = 0; stringPtr->allocated = 0; objPtr->length = 0; } return 1; @@ -939,22 +979,24 @@ */ void Tcl_SetUnicodeObj(objPtr, unicode, numChars) Tcl_Obj *objPtr; /* The object to set the string of. */ - CONST Tcl_UniChar *unicode; /* The unicode string used to initialize - * the object. */ + CONST Tcl_UniChar *unicode; /* The unicode string used to initialize the + * object. */ int numChars; /* Number of characters in the unicode * string. */ { String *stringPtr; size_t uallocated; if (numChars < 0) { numChars = 0; if (unicode) { - while (unicode[numChars] != 0) { numChars++; } + while (unicode[numChars] != 0) { + numChars++; + } } } uallocated = STRING_UALLOC(numChars); /* @@ -965,18 +1007,19 @@ objPtr->typePtr = &tclStringType; /* * Allocate enough space for the String structure + Unicode string. */ - + stringPtr = (String *) ckalloc(STRING_SIZE(uallocated)); stringPtr->numChars = numChars; stringPtr->uallocated = uallocated; stringPtr->hasUnicode = (numChars > 0); stringPtr->allocated = 0; memcpy((VOID *) stringPtr->unicode, (VOID *) unicode, uallocated); stringPtr->unicode[numChars] = 0; + SET_STRING(objPtr, stringPtr); Tcl_InvalidateStringRep(objPtr); return; } @@ -983,19 +1026,19 @@ /* *---------------------------------------------------------------------- * * TclAppendLimitedToObj -- * - * This procedure appends a limited number of bytes from a sequence - * of bytes to an object, marking any limitation with an ellipsis. + * This function appends a limited number of bytes from a sequence of + * bytes to an object, marking any limitation with an ellipsis. * * Results: * None. * * Side effects: - * The bytes at *bytes are appended to the string representation - * of objPtr. + * The bytes at *bytes are appended to the string representation of + * objPtr. * *---------------------------------------------------------------------- */ void @@ -1002,17 +1045,17 @@ TclAppendLimitedToObj(objPtr, bytes, length, limit, ellipsis) register Tcl_Obj *objPtr; /* Points to the object to append to. */ CONST char *bytes; /* Points to the bytes to append to the * object. */ register int length; /* The number of bytes available to be - * appended from "bytes". If < 0, then - * all bytes up to a NULL byte are available. */ - register int limit; /* The maximum number of bytes to append - * to the object. */ - CONST char *ellipsis; /* Ellipsis marker string, appended to - * the object to indicate not all available - * bytes at "bytes" were appended. */ + * appended from "bytes". If < 0, then all + * bytes up to a NULL byte are available. */ + register int limit; /* The maximum number of bytes to append to + * the object. */ + CONST char *ellipsis; /* Ellipsis marker string, appended to the + * object to indicate not all available bytes + * at "bytes" were appended. */ { String *stringPtr; int toCopy = 0; if (Tcl_IsShared(objPtr)) { @@ -1036,13 +1079,13 @@ } toCopy = Tcl_UtfPrev(bytes+limit+1-strlen(ellipsis), bytes) - bytes; } /* - * If objPtr has a valid Unicode rep, then append the Unicode - * conversion of "bytes" to the objPtr's Unicode rep, otherwise - * append "bytes" to objPtr's string rep. + * If objPtr has a valid Unicode rep, then append the Unicode conversion + * of "bytes" to the objPtr's Unicode rep, otherwise append "bytes" to + * objPtr's string rep. */ stringPtr = GET_STRING(objPtr); if (stringPtr->hasUnicode != 0) { AppendUtfToUnicodeRep(objPtr, bytes, toCopy); @@ -1058,49 +1101,48 @@ if (stringPtr->hasUnicode != 0) { AppendUtfToUnicodeRep(objPtr, ellipsis, -1); } else { AppendUtfToUtfRep(objPtr, ellipsis, -1); } - } /* *---------------------------------------------------------------------- * * Tcl_AppendToObj -- * - * This procedure appends a sequence of bytes to an object. + * This function appends a sequence of bytes to an object. * * Results: * None. * * Side effects: - * The bytes at *bytes are appended to the string representation - * of objPtr. + * The bytes at *bytes are appended to the string representation of + * objPtr. * *---------------------------------------------------------------------- */ void Tcl_AppendToObj(objPtr, bytes, length) register Tcl_Obj *objPtr; /* Points to the object to append to. */ CONST char *bytes; /* Points to the bytes to append to the * object. */ - register int length; /* The number of bytes to append from - * "bytes". If < 0, then append all bytes - * up to NULL byte. */ + register int length; /* The number of bytes to append from "bytes". + * If < 0, then append all bytes up to NULL + * byte. */ { TclAppendLimitedToObj(objPtr, bytes, length, INT_MAX, NULL); } /* *---------------------------------------------------------------------- * * Tcl_AppendUnicodeToObj -- * - * This procedure appends a Unicode string to an object in the - * most efficient manner possible. Length must be >= 0. + * This function appends a Unicode string to an object in the most + * efficient manner possible. Length must be >= 0. * * Results: * None. * * Side effects: @@ -1111,11 +1153,11 @@ void Tcl_AppendUnicodeToObj(objPtr, unicode, length) register Tcl_Obj *objPtr; /* Points to the object to append to. */ CONST Tcl_UniChar *unicode; /* The unicode string to append to the - * object. */ + * object. */ int length; /* Number of chars in "unicode". */ { String *stringPtr; if (Tcl_IsShared(objPtr)) { @@ -1128,13 +1170,13 @@ SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); /* - * If objPtr has a valid Unicode rep, then append the "unicode" - * to the objPtr's Unicode rep, otherwise the UTF conversion of - * "unicode" to objPtr's string rep. + * If objPtr has a valid Unicode rep, then append the "unicode" to the + * objPtr's Unicode rep, otherwise the UTF conversion of "unicode" to + * objPtr's string rep. */ if (stringPtr->hasUnicode != 0) { AppendUnicodeToUnicodeRep(objPtr, unicode, length); } else { @@ -1145,18 +1187,18 @@ /* *---------------------------------------------------------------------- * * Tcl_AppendObjToObj -- * - * This procedure appends the string rep of one object to another. + * This function appends the string rep of one object to another. * "objPtr" cannot be a shared object. * * Results: * None. * * Side effects: - * The string rep of appendObjPtr is appended to the string + * The string rep of appendObjPtr is appended to the string * representation of objPtr. * *---------------------------------------------------------------------- */ @@ -1170,29 +1212,26 @@ char *bytes; SetStringFromAny(NULL, objPtr); /* - * If objPtr has a valid Unicode rep, then get a Unicode string - * from appendObjPtr and append it. + * If objPtr has a valid Unicode rep, then get a Unicode string from + * appendObjPtr and append it. */ stringPtr = GET_STRING(objPtr); if (stringPtr->hasUnicode != 0) { - /* * If appendObjPtr is not of the "String" type, don't convert it. */ if (appendObjPtr->typePtr == &tclStringType) { stringPtr = GET_STRING(appendObjPtr); - if ((stringPtr->numChars == -1) - || (stringPtr->hasUnicode == 0)) { - + if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) { /* - * If appendObjPtr is a string obj with no valid Unicode - * rep, then fill its unicode rep. + * If appendObjPtr is a string obj with no valid Unicode rep, + * then fill its unicode rep. */ FillUnicodeRep(appendObjPtr); stringPtr = GET_STRING(appendObjPtr); } @@ -1204,13 +1243,13 @@ } return; } /* - * Append to objPtr's UTF string rep. If we know the number of - * characters in both objects before appending, then set the combined - * number of characters in the final (appended-to) object. + * Append to objPtr's UTF string rep. If we know the number of characters + * in both objects before appending, then set the combined number of + * characters in the final (appended-to) object. */ bytes = Tcl_GetStringFromObj(appendObjPtr, &length); allOneByteChars = 0; @@ -1234,12 +1273,12 @@ /* *---------------------------------------------------------------------- * * AppendUnicodeToUnicodeRep -- * - * This procedure appends the contents of "unicode" to the Unicode - * rep of "objPtr". objPtr must already have a valid Unicode rep. + * This function appends the contents of "unicode" to the Unicode rep of + * "objPtr". objPtr must already have a valid Unicode rep. * * Results: * None. * * Side effects: @@ -1248,21 +1287,23 @@ *---------------------------------------------------------------------- */ static void AppendUnicodeToUnicodeRep(objPtr, unicode, appendNumChars) - Tcl_Obj *objPtr; /* Points to the object to append to. */ - CONST Tcl_UniChar *unicode; /* String to append. */ - int appendNumChars; /* Number of chars of "unicode" to append. */ + Tcl_Obj *objPtr; /* Points to the object to append to. */ + CONST Tcl_UniChar *unicode; /* String to append. */ + int appendNumChars; /* Number of chars of "unicode" to append. */ { String *stringPtr, *tmpString; size_t numChars; if (appendNumChars < 0) { appendNumChars = 0; if (unicode) { - while (unicode[appendNumChars] != 0) { appendNumChars++; } + while (unicode[appendNumChars] != 0) { + appendNumChars++; + } } } if (appendNumChars == 0) { return; } @@ -1269,27 +1310,27 @@ SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); /* - * If not enough space has been allocated for the unicode rep, - * reallocate the internal rep object with additional space. First - * try to double the required allocation; if that fails, try a more - * modest increase. See the "TCL STRING GROWTH ALGORITHM" comment at - * the top of this file for an explanation of this growth algorithm. + * If not enough space has been allocated for the unicode rep, reallocate + * the internal rep object with additional space. First try to double the + * required allocation; if that fails, try a more modest increase. See the + * "TCL STRING GROWTH ALGORITHM" comment at the top of this file for an + * explanation of this growth algorithm. */ numChars = stringPtr->numChars + appendNumChars; if (STRING_UALLOC(numChars) >= stringPtr->uallocated) { - stringPtr->uallocated = STRING_UALLOC(2 * numChars); + stringPtr->uallocated = STRING_UALLOC(2 * numChars); tmpString = (String *) attemptckrealloc((char *)stringPtr, STRING_SIZE(stringPtr->uallocated)); if (tmpString == NULL) { stringPtr->uallocated = - STRING_UALLOC(numChars + appendNumChars) - + TCL_GROWTH_MIN_ALLOC; + STRING_UALLOC(numChars + appendNumChars) + + TCL_GROWTH_MIN_ALLOC; tmpString = (String *) ckrealloc((char *)stringPtr, STRING_SIZE(stringPtr->uallocated)); } stringPtr = tmpString; SET_STRING(objPtr, stringPtr); @@ -1311,12 +1352,12 @@ /* *---------------------------------------------------------------------- * * AppendUnicodeToUtfRep -- * - * This procedure converts the contents of "unicode" to UTF and - * appends the UTF to the string rep of "objPtr". + * This function converts the contents of "unicode" to UTF and appends + * the UTF to the string rep of "objPtr". * * Results: * None. * * Side effects: @@ -1325,21 +1366,23 @@ *---------------------------------------------------------------------- */ static void AppendUnicodeToUtfRep(objPtr, unicode, numChars) - Tcl_Obj *objPtr; /* Points to the object to append to. */ - CONST Tcl_UniChar *unicode; /* String to convert to UTF. */ - int numChars; /* Number of chars of "unicode" to convert. */ + Tcl_Obj *objPtr; /* Points to the object to append to. */ + CONST Tcl_UniChar *unicode; /* String to convert to UTF. */ + int numChars; /* Number of chars of "unicode" to convert. */ { Tcl_DString dsPtr; CONST char *bytes; - + if (numChars < 0) { numChars = 0; if (unicode) { - while (unicode[numChars] != 0) { numChars++; } + while (unicode[numChars] != 0) { + numChars++; + } } } if (numChars == 0) { return; } @@ -1353,13 +1396,13 @@ /* *---------------------------------------------------------------------- * * AppendUtfToUnicodeRep -- * - * This procedure converts the contents of "bytes" to Unicode and - * appends the Unicode to the Unicode rep of "objPtr". objPtr must - * already have a valid Unicode rep. + * This function converts the contents of "bytes" to Unicode and appends + * the Unicode to the Unicode rep of "objPtr". objPtr must already have a + * valid Unicode rep. * * Results: * None. * * Side effects: @@ -1368,13 +1411,13 @@ *---------------------------------------------------------------------- */ static void AppendUtfToUnicodeRep(objPtr, bytes, numBytes) - Tcl_Obj *objPtr; /* Points to the object to append to. */ - CONST char *bytes; /* String to convert to Unicode. */ - int numBytes; /* Number of bytes of "bytes" to convert. */ + Tcl_Obj *objPtr; /* Points to the object to append to. */ + CONST char *bytes; /* String to convert to Unicode. */ + int numBytes; /* Number of bytes of "bytes" to convert. */ { Tcl_DString dsPtr; int numChars; Tcl_UniChar *unicode; @@ -1382,11 +1425,11 @@ numBytes = (bytes ? strlen(bytes) : 0); } if (numBytes == 0) { return; } - + Tcl_DStringInit(&dsPtr); numChars = Tcl_NumUtfChars(bytes, numBytes); unicode = (Tcl_UniChar *)Tcl_UtfToUniCharDString(bytes, numBytes, &dsPtr); AppendUnicodeToUnicodeRep(objPtr, unicode, numChars); Tcl_DStringFree(&dsPtr); @@ -1395,12 +1438,12 @@ /* *---------------------------------------------------------------------- * * AppendUtfToUtfRep -- * - * This procedure appends "numBytes" bytes of "bytes" to the UTF string - * rep of "objPtr". objPtr must already have a valid String rep. + * This function appends "numBytes" bytes of "bytes" to the UTF string + * rep of "objPtr". objPtr must already have a valid String rep. * * Results: * None. * * Side effects: @@ -1409,13 +1452,13 @@ *---------------------------------------------------------------------- */ static void AppendUtfToUtfRep(objPtr, bytes, numBytes) - Tcl_Obj *objPtr; /* Points to the object to append to. */ - CONST char *bytes; /* String to append. */ - int numBytes; /* Number of bytes of "bytes" to append. */ + Tcl_Obj *objPtr; /* Points to the object to append to. */ + CONST char *bytes; /* String to append. */ + int numBytes; /* Number of bytes of "bytes" to append. */ { String *stringPtr; int newLength, oldLength; if (numBytes < 0) { @@ -1433,16 +1476,15 @@ oldLength = objPtr->length; newLength = numBytes + oldLength; stringPtr = GET_STRING(objPtr); if (newLength > (int) stringPtr->allocated) { - /* - * There isn't currently enough space in the string representation - * so allocate additional space. First, try to double the length - * required. If that fails, try a more modest allocation. See the - * "TCL STRING GROWTH ALGORITHM" comment at the top of this file for an + * There isn't currently enough space in the string representation so + * allocate additional space. First, try to double the length + * required. If that fails, try a more modest allocation. See the "TCL + * STRING GROWTH ALGORITHM" comment at the top of this file for an * explanation of this growth algorithm. */ if (Tcl_AttemptSetObjLength(objPtr, 2 * newLength) == 0) { Tcl_SetObjLength(objPtr, @@ -1451,14 +1493,14 @@ } /* * Invalidate the unicode data. */ - + stringPtr->numChars = -1; stringPtr->hasUnicode = 0; - + memcpy((VOID *) (objPtr->bytes + oldLength), (VOID *) bytes, (size_t) numBytes); objPtr->bytes[newLength] = 0; objPtr->length = newLength; } @@ -1466,19 +1508,19 @@ /* *---------------------------------------------------------------------- * * Tcl_AppendStringsToObjVA -- * - * This procedure appends one or more null-terminated strings - * to an object. + * This function appends one or more null-terminated strings to an + * object. * * Results: * None. * * Side effects: - * The contents of all the string arguments are appended to the - * string representation of objPtr. + * The contents of all the string arguments are appended to the string + * representation of objPtr. * *---------------------------------------------------------------------- */ void @@ -1500,14 +1542,14 @@ } SetStringFromAny(NULL, objPtr); /* - * Figure out how much space is needed for all the strings, and - * expand the string representation if it isn't big enough. If no - * bytes would be appended, just return. Note that on some platforms - * (notably OS/390) the argList is an array so we need to use memcpy. + * Figure out how much space is needed for all the strings, and expand the + * string representation if it isn't big enough. If no bytes would be + * appended, just return. Note that on some platforms (notably OS/390) the + * argList is an array so we need to use memcpy. */ nargs = 0; newLength = 0; oldLength = objPtr->length; @@ -1514,67 +1556,67 @@ while (1) { string = va_arg(argList, char *); if (string == NULL) { break; } - if (nargs >= nargs_space) { - /* - * Expand the args buffer - */ - nargs_space += STATIC_LIST_SIZE; - if (args == static_list) { - args = (void *)ckalloc(nargs_space * sizeof(char *)); - for (i = 0; i < nargs; ++i) { - args[i] = static_list[i]; - } - } else { - args = (void *)ckrealloc((void *)args, + if (nargs >= nargs_space) { + /* + * Expand the args buffer. + */ + + nargs_space += STATIC_LIST_SIZE; + if (args == static_list) { + args = (void *) ckalloc(nargs_space * sizeof(char *)); + for (i = 0; i < nargs; ++i) { + args[i] = static_list[i]; + } + } else { + args = (void *) ckrealloc((void *) args, nargs_space * sizeof(char *)); - } - } + } + } newLength += strlen(string); args[nargs++] = string; } if (newLength == 0) { goto done; } stringPtr = GET_STRING(objPtr); if (oldLength + newLength > (int) stringPtr->allocated) { - /* - * There isn't currently enough space in the string - * representation, so allocate additional space. If the current - * string representation isn't empty (i.e. it looks like we're - * doing a series of appends) then try to allocate extra space to - * accomodate future growth: first try to double the required memory; - * if that fails, try a more modest allocation. See the "TCL STRING - * GROWTH ALGORITHM" comment at the top of this file for an explanation - * of this growth algorithm. Otherwise, if the current string - * representation is empty, exactly enough memory is allocated. + * There isn't currently enough space in the string representation, so + * allocate additional space. If the current string representation + * isn't empty (i.e. it looks like we're doing a series of appends) + * then try to allocate extra space to accomodate future growth: first + * try to double the required memory; if that fails, try a more modest + * allocation. See the "TCL STRING GROWTH ALGORITHM" comment at the + * top of this file for an explanation of this growth algorithm. + * Otherwise, if the current string representation is empty, exactly + * enough memory is allocated. */ if (oldLength == 0) { Tcl_SetObjLength(objPtr, newLength); } else { attemptLength = 2 * (oldLength + newLength); if (Tcl_AttemptSetObjLength(objPtr, attemptLength) == 0) { attemptLength = oldLength + (2 * newLength) + - TCL_GROWTH_MIN_ALLOC; + TCL_GROWTH_MIN_ALLOC; Tcl_SetObjLength(objPtr, attemptLength); } } } /* - * Make a second pass through the arguments, appending all the - * strings to the object. + * Make a second pass through the arguments, appending all the strings to + * the object. */ dst = objPtr->bytes + oldLength; for (i = 0; i < nargs; ++i) { - string = args[i]; + string = args[i]; if (string == NULL) { break; } while (*string != 0) { *dst = *string; @@ -1582,69 +1624,883 @@ string++; } } /* - * Add a null byte to terminate the string. However, be careful: - * it's possible that the object is totally empty (if it was empty - * originally and there was nothing to append). In this case dst is - * NULL; just leave everything alone. + * Add a null byte to terminate the string. However, be careful: it's + * possible that the object is totally empty (if it was empty originally + * and there was nothing to append). In this case dst is NULL; just leave + * everything alone. */ if (dst != NULL) { *dst = 0; } objPtr->length = oldLength + newLength; - done: + done: /* - * If we had to allocate a buffer from the heap, - * free it now. + * If we had to allocate a buffer from the heap, free it now. */ - + if (args != static_list) { - ckfree((void *)args); + ckfree((void *)args); } #undef STATIC_LIST_SIZE } /* *---------------------------------------------------------------------- * * Tcl_AppendStringsToObj -- * - * This procedure appends one or more null-terminated strings - * to an object. + * This function appends one or more null-terminated strings to an + * object. * * Results: * None. * * Side effects: - * The contents of all the string arguments are appended to the - * string representation of objPtr. + * The contents of all the string arguments are appended to the string + * representation of objPtr. * *---------------------------------------------------------------------- */ void -Tcl_AppendStringsToObj TCL_VARARGS_DEF(Tcl_Obj *,arg1) +Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...) { - register Tcl_Obj *objPtr; va_list argList; - objPtr = TCL_VARARGS_START(Tcl_Obj *,arg1,argList); + va_start(argList, objPtr); Tcl_AppendStringsToObjVA(objPtr, argList); va_end(argList); } + +/* + *---------------------------------------------------------------------- + * + * TclAppendFormattedObjs -- + * + * This function appends a list of Tcl_Obj's to a Tcl_Obj according + * to the formatting instructions embedded in the format string. The + * formatting instructions are inspired by sprintf(). Returns TCL_OK + * when successful. If there's an error in the arguments, TCL_ERROR is + * returned, and an error message is written to the interp, if non-NULL. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclAppendFormattedObjs(interp, appendObj, format, objc, objv) + Tcl_Interp *interp; + Tcl_Obj *appendObj; + CONST char *format; + int objc; + Tcl_Obj *CONST objv[]; +{ + CONST char *span = format; + int numBytes = 0; + int objIndex = 0; + int gotXpg = 0, gotSequential = 0; + int originalLength; + CONST char *msg; + CONST char *mixedXPG = "cannot mix \"%\" and \"%n$\" conversion specifiers"; + CONST char *badIndex[2] = { + "not enough arguments for all format specifiers", + "\"%n$\" argument index out of range" + }; + + if (Tcl_IsShared(appendObj)) { + Tcl_Panic("TclAppendFormattedObjs called with shared object"); + } + Tcl_GetStringFromObj(appendObj, &originalLength); + + /* format string is NUL-terminated */ + while (*format != '\0') { + char *end; + int gotMinus, gotHash, gotZero, gotSpace, gotPlus, sawFlag; + int width, gotPrecision, precision, useShort, useWide, useBig; + int newXpg, numChars, allocSegment = 0; + Tcl_Obj *segment; + Tcl_UniChar ch; + int step = Tcl_UtfToUniChar(format, &ch); + + format += step; + if (ch != '%') { + numBytes += step; + continue; + } + if (numBytes) { + Tcl_AppendToObj(appendObj, span, numBytes); + numBytes = 0; + } + + /* Saw a % : process the format specifier */ + /* 0. %% : Escape format handling */ + + step = Tcl_UtfToUniChar(format, &ch); + if (ch == '%') { + span = format; + numBytes = step; + format += step; + continue; + } + + /* 1. XPG3 position specifier */ + + newXpg = 0; + if (isdigit(UCHAR(ch))) { + int position = strtoul(format, &end, 10); + if (*end == '$') { + newXpg = 1; + objIndex = position - 1; + format = end + 1; + step = Tcl_UtfToUniChar(format, &ch); + } + } + if (newXpg) { + if (gotSequential) { + msg = mixedXPG; + goto errorMsg; + } + gotXpg = 1; + } else { + if (gotXpg) { + msg = mixedXPG; + goto errorMsg; + } + gotSequential = 1; + } + if ((objIndex < 0) || (objIndex >= objc)) { + msg = badIndex[gotXpg]; + goto errorMsg; + } + + /* 2. Set of flags */ + + gotMinus = gotHash = gotZero = gotSpace = gotPlus = 0; + sawFlag = 1; + do { + switch (ch) { + case '-': + gotMinus = 1; + break; + case '#': + gotHash = 1; + break; + case '0': + gotZero = 1; + break; + case ' ': + gotSpace = 1; + break; + case '+': + gotPlus = 1; + break; + default: + sawFlag = 0; + } + if (sawFlag) { + format += step; + step = Tcl_UtfToUniChar(format, &ch); + } + } while (sawFlag); + + /* 3. Minimum field width */ + + width = 0; + if (isdigit(UCHAR(ch))) { + width = strtoul(format, &end, 10); + format = end; + step = Tcl_UtfToUniChar(format, &ch); + } else if (ch == '*') { + if (objIndex >= objc - 1) { + msg = badIndex[gotXpg]; + goto errorMsg; + } + if (Tcl_GetIntFromObj(interp, objv[objIndex], &width) != TCL_OK) { + goto error; + } + if (width < 0) { + width = -width; + gotMinus = 1; + } + objIndex++; + format += step; + step = Tcl_UtfToUniChar(format, &ch); + } + + /* 4. Precision */ + + gotPrecision = precision = 0; + if (ch == '.') { + gotPrecision = 1; + format += step; + step = Tcl_UtfToUniChar(format, &ch); + } + if (isdigit(UCHAR(ch))) { + precision = strtoul(format, &end, 10); + format = end; + step = Tcl_UtfToUniChar(format, &ch); + } else if (ch == '*') { + if (objIndex >= objc - 1) { + msg = badIndex[gotXpg]; + goto errorMsg; + } + if (Tcl_GetIntFromObj(interp, objv[objIndex], &precision) + != TCL_OK) { + goto error; + } + /* TODO: Check this truncation logic */ + if (precision < 0) { + precision = 0; + } + objIndex++; + format += step; + step = Tcl_UtfToUniChar(format, &ch); + } + + /* 5. Length modifier */ + + 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; + span = format; + + /* 6. Conversion character */ + segment = objv[objIndex]; + if (ch == 'i') { + ch = 'd'; + } + switch (ch) { + case '\0': + msg = "format string ended in middle of field specifier"; + goto errorMsg; + case 's': { + numChars = Tcl_GetCharLength(segment); + if (gotPrecision && (precision < numChars)) { + segment = Tcl_GetRange(segment, 0, precision - 1); + Tcl_IncrRefCount(segment); + allocSegment = 1; + } + break; + } + case 'c': { + char buf[TCL_UTF_MAX]; + int code, length; + if (Tcl_GetIntFromObj(interp, segment, &code) != TCL_OK) { + goto error; + } + length = Tcl_UniCharToUtf(code, buf); + segment = Tcl_NewStringObj(buf, length); + Tcl_IncrRefCount(segment); + allocSegment = 1; + break; + } + + case 'u': + if (useBig) { + msg = "unsigned bignum format is invalid"; + goto errorMsg; + } + case 'd': + case 'o': + case 'x': + case 'X': { + short int s; + long l; + Tcl_WideInt w; + mp_int big; + int isNegative = 0; + + if (useBig) { + if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) { + goto error; + } + 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 { + if (useShort) { + s = (short int) l; + isNegative = (s < (short int)0); + } else { + isNegative = (l < (long)0); + } + } + + segment = Tcl_NewObj(); + allocSegment = 1; + Tcl_IncrRefCount(segment); + + if (isNegative || gotPlus) { + if (useBig || (ch == 'd')) { + if (isNegative) { + Tcl_AppendToObj(segment, "-", 1); + } else { + Tcl_AppendToObj(segment, "+", 1); + } + } + } + + if (gotHash) { + switch (ch) { + case 'o': + Tcl_AppendToObj(segment, "0", 1); + precision--; + break; + case 'x': + case 'X': + Tcl_AppendToObj(segment, "0x", 2); + break; + } + } + + switch (ch) { + case 'd': { + int length; + Tcl_Obj *pure; + CONST char *bytes; + + if (useShort) { + pure = Tcl_NewIntObj((int)(s)); + } else if (useWide) { + pure = Tcl_NewWideIntObj(w); + } else if (useBig) { + pure = Tcl_NewBignumObj(&big); + } else { + pure = Tcl_NewLongObj(l); + } + Tcl_IncrRefCount(pure); + bytes = Tcl_GetStringFromObj(pure, &length); + /* Already did the sign above */ + if (*bytes == '-') { + length--; bytes++; + } + /* Canonical decimal string reps for integers are composed + * entirely of one-byte encoded characters, so "length" is + * the number of chars */ + if (gotPrecision) { + while (length < precision) { + Tcl_AppendToObj(segment, "0", 1); + length++; + } + gotZero = 0; + } + if (gotZero) { + length += Tcl_GetCharLength(segment); + while (length < width) { + Tcl_AppendToObj(segment, "0", 1); + length++; + } + } + Tcl_AppendToObj(segment, bytes, -1); + Tcl_DecrRefCount(pure); + break; + } + + case 'u': + case 'o': + case 'x': + case 'X': { + Tcl_WideUInt bits = (Tcl_WideUInt)0; + int length, numBits = 4, numDigits = 0, base = 16; + int index = 0, shift = 0; + Tcl_Obj *pure; + char *bytes; + + if (ch == 'u') { + base = 10; + } + if (ch == 'o') { + base = 8; + numBits = 3; + } + if (useShort) { + unsigned short int us = (unsigned short int) s; + bits = (Tcl_WideUInt) us; + while (us) { + numDigits++; + us /= base; + } + } else if (useWide) { + Tcl_WideUInt uw = (Tcl_WideUInt) w; + bits = uw; + while (uw) { + 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; + while (ul) { + numDigits++; + ul /= base; + } + } + /* Need to be sure zero becomes "0", not "" */ + if ((numDigits == 0) && !((ch == 'o') && gotHash)) { + numDigits = 1; + } + pure = Tcl_NewObj(); + Tcl_SetObjLength(pure, numDigits); + bytes = Tcl_GetString(pure); + length = numDigits; + while (numDigits--) { + int digitOffset; + if (useBig) { + if (shift 9) { + bytes[numDigits] = 'a' + digitOffset - 10; + } else { + bytes[numDigits] = '0' + digitOffset; + } + bits /= base; + } + if (gotPrecision) { + while (length < precision) { + Tcl_AppendToObj(segment, "0", 1); + length++; + } + gotZero = 0; + } + if (gotZero) { + length += Tcl_GetCharLength(segment); + while (length < width) { + Tcl_AppendToObj(segment, "0", 1); + length++; + } + } + Tcl_AppendObjToObj(segment, pure); + Tcl_DecrRefCount(pure); + break; + } + + } + break; + } + + case 'e': + case 'E': + case 'f': + case 'g': + case 'G': { +#define MAX_FLOAT_SIZE 320 + char spec[2*TCL_INTEGER_SPACE + 9], *p = spec; + double d; + int length = MAX_FLOAT_SIZE; + char *bytes; + + if (Tcl_GetDoubleFromObj(interp, segment, &d) != TCL_OK) { + goto error; + } + *p++ = '%'; + if (gotMinus) { + *p++ = '-'; + } + if (gotHash) { + *p++ = '#'; + } + if (gotZero) { + *p++ = '0'; + } + if (gotSpace) { + *p++ = ' '; + } + if (gotPlus) { + *p++ = '+'; + } + if (width) { + p += sprintf(p, "%d", width); + } + if (gotPrecision) { + *p++ = '.'; + p += sprintf(p, "%d", precision); + length += precision; + } + /* Don't pass length modifiers ! */ + *p++ = (char) ch; + *p = '\0'; + + segment = Tcl_NewObj(); + allocSegment = 1; + Tcl_SetObjLength(segment, length); + bytes = Tcl_GetString(segment); + Tcl_SetObjLength(segment, sprintf(bytes, spec, d)); + break; + } + default: { + char buf[40]; + sprintf(buf, "bad field specifier \"%c\"", ch); + msg = buf; + goto errorMsg; + } + } + + switch (ch) { + case 'E': + case 'G': + case 'X': { + Tcl_SetObjLength(segment, Tcl_UtfToUpper(Tcl_GetString(segment))); + } + } + + numChars = Tcl_GetCharLength(segment); + if (!gotMinus) { + while (numChars < width) { + Tcl_AppendToObj(appendObj, (gotZero ? "0" : " "), 1); + numChars++; + } + } + Tcl_AppendObjToObj(appendObj, segment); + if (allocSegment) { + Tcl_DecrRefCount(segment); + } + while (numChars < width) { + Tcl_AppendToObj(appendObj, (gotZero ? "0" : " "), 1); + numChars++; + } + + objIndex += gotSequential; + } + if (numBytes) { + Tcl_AppendToObj(appendObj, span, numBytes); + numBytes = 0; + } + + return TCL_OK; + + errorMsg: + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1)); + } + error: + Tcl_SetObjLength(appendObj, originalLength); + return TCL_ERROR; +} + +/* + *--------------------------------------------------------------------------- + * + * FormatObjVA -- + * + * Populate the Unicode internal rep with the Unicode form of its string + * rep. The object must alread have a "String" internal rep. + * + * Results: + * None. + * + * Side effects: + * Reallocates the String internal rep. + * + *--------------------------------------------------------------------------- + */ + +static int +FormatObjVA(Tcl_Interp *interp, + Tcl_Obj *objPtr, + CONST char *format, + va_list argList) +{ + int code, objc; + Tcl_Obj **objv, *element, *list = Tcl_NewObj(); + + Tcl_IncrRefCount(list); + element = va_arg(argList, Tcl_Obj *); + while (element != NULL) { + Tcl_ListObjAppendElement(NULL, list, element); + element = va_arg(argList, Tcl_Obj *); + } + Tcl_ListObjGetElements(NULL, list, &objc, &objv); + code = TclAppendFormattedObjs(interp, objPtr, format, objc, objv); + Tcl_DecrRefCount(list); + return code; +} + +/* + *--------------------------------------------------------------------------- + * + * TclFormatObj -- + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +int +TclFormatObj(Tcl_Interp *interp, Tcl_Obj *objPtr, CONST char *format, ...) +{ + va_list argList; + int result; + + va_start(argList, format); + result = FormatObjVA(interp, objPtr, format, argList); + va_end(argList); + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * ObjPrintfVA -- + * + * Results: + * + * Side effects: + * + *--------------------------------------------------------------------------- + */ + +static int +ObjPrintfVA( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + CONST char *format, + va_list argList) +{ + int code, objc; + Tcl_Obj **objv, *list = Tcl_NewObj(); + CONST char *p; + char *end; + + p = format; + Tcl_IncrRefCount(list); + while (*p != '\0') { + int size = 0, seekingConversion = 1, gotPrecision = 0; + int lastNum = -1, numBytes = -1; + + if (*p++ != '%') { + continue; + } + if (*p == '%') { + p++; + continue; + } + do { + switch (*p) { + + case '\0': + seekingConversion = 0; + break; + case 's': { + char *bytes = va_arg(argList, char *); + seekingConversion = 0; + if (gotPrecision) { + char *end = bytes + lastNum; + char *q = bytes; + while ((q < end) && (*q != '\0')) { + q++; + } + numBytes = (int)(q - bytes); + } + Tcl_ListObjAppendElement(NULL, list, + Tcl_NewStringObj(bytes , numBytes)); + /* We took no more than numBytes bytes from the (char *). + * In turn, [format] will take no more than numBytes + * characters from the Tcl_Obj. Since numBytes characters + * must be no less than numBytes bytes, the character limit + * will have no effect and we can just pass it through. + */ + break; + } + case 'c': + case 'i': + case 'u': + case 'd': + case 'o': + case 'x': + case 'X': + seekingConversion = 0; + switch (size) { + case -1: + case 0: + Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj( + (long int)va_arg(argList, int))); + break; + case 1: + Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj( + va_arg(argList, long int))); + break; + } + break; + case 'e': + case 'E': + case 'f': + case 'g': + case 'G': + Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj( + va_arg(argList, double))); + seekingConversion = 0; + break; + case '*': + lastNum = (int)va_arg(argList, int); + Tcl_ListObjAppendElement(NULL, list, Tcl_NewIntObj(lastNum)); + p++; + break; + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + lastNum = (int) strtoul(p, &end, 10); + p = end; + break; + case '.': + gotPrecision = 1; + p++; + break; + /* TODO: support for wide (and bignum?) arguments */ + case 'l': + size = 1; + p++; + break; + case 'h': + size = -1; + default: + p++; + } + } while (seekingConversion); + } + Tcl_ListObjGetElements(NULL, list, &objc, &objv); + code = TclAppendFormattedObjs(interp, objPtr, format, objc, objv); + Tcl_DecrRefCount(list); + return code; +} + +/* + *--------------------------------------------------------------------------- + * + * TclObjPrintf -- + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +int +TclObjPrintf(Tcl_Interp *interp, Tcl_Obj *objPtr, CONST char *format, ...) +{ + va_list argList; + int result; + + va_start(argList, format); + result = ObjPrintfVA(interp, objPtr, format, argList); + va_end(argList); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclFormatToErrorInfo -- + * + * Results: + * + * Side effects: + * + *---------------------------------------------------------------------- + */ + +int +TclFormatToErrorInfo(Tcl_Interp *interp, CONST char *format, ...) +{ + int code; + va_list argList; + Tcl_Obj *objPtr = Tcl_NewObj(); + + va_start(argList, format); + code = ObjPrintfVA(interp, objPtr, format, argList); + va_end(argList); + if (code != TCL_OK) { + return code; + } + TclAppendObjToErrorInfo(interp, objPtr); + Tcl_DecrRefCount(objPtr); + return TCL_OK; +} /* *--------------------------------------------------------------------------- * * FillUnicodeRep -- * * Populate the Unicode internal rep with the Unicode form of its string - * rep. The object must alread have a "String" internal rep. + * rep. The object must alread have a "String" internal rep. * * Results: * None. * * Side effects: @@ -1653,38 +2509,36 @@ *--------------------------------------------------------------------------- */ static void FillUnicodeRep(objPtr) - Tcl_Obj *objPtr; /* The object in which to fill the unicode rep. */ + Tcl_Obj *objPtr; /* The object in which to fill the unicode + * rep. */ { String *stringPtr; size_t uallocated; char *src, *srcEnd; Tcl_UniChar *dst; src = objPtr->bytes; - + stringPtr = GET_STRING(objPtr); if (stringPtr->numChars == -1) { stringPtr->numChars = Tcl_NumUtfChars(src, objPtr->length); } stringPtr->hasUnicode = (stringPtr->numChars > 0); uallocated = STRING_UALLOC(stringPtr->numChars); if (uallocated > stringPtr->uallocated) { - /* * If not enough space has been allocated for the unicode rep, * reallocate the internal rep object. - */ - - /* - * There isn't currently enough space in the Unicode - * representation so allocate additional space. If the current - * Unicode representation isn't empty (i.e. it looks like we've - * done some appends) then overallocate the space so - * that we won't have to do as much reallocation in the future. + * + * There isn't currently enough space in the Unicode representation so + * allocate additional space. If the current Unicode representation + * isn't empty (i.e. it looks like we've done some appends) then + * overallocate the space so that we won't have to do as much + * reallocation in the future. */ if (stringPtr->uallocated > 0) { uallocated *= 2; } @@ -1694,27 +2548,27 @@ } /* * Convert src to Unicode and store the coverted data in "unicode". */ - + srcEnd = src + objPtr->length; for (dst = stringPtr->unicode; src < srcEnd; dst++) { src += TclUtfToUniChar(src, dst); } *dst = 0; - + SET_STRING(objPtr, stringPtr); } /* *---------------------------------------------------------------------- * * DupStringInternalRep -- * - * Initialize the internal representation of a new Tcl_Obj to a - * copy of the internal representation of an existing string object. + * Initialize the internal representation of a new Tcl_Obj to a copy of + * the internal representation of an existing string object. * * Results: * None. * * Side effects: @@ -1724,31 +2578,31 @@ *---------------------------------------------------------------------- */ static void DupStringInternalRep(srcPtr, copyPtr) - register Tcl_Obj *srcPtr; /* Object with internal rep to copy. Must - * have an internal rep of type "String". */ - register Tcl_Obj *copyPtr; /* Object with internal rep to set. Must - * not currently have an internal rep.*/ + register Tcl_Obj *srcPtr; /* Object with internal rep to copy. Must have + * an internal rep of type "String". */ + register Tcl_Obj *copyPtr; /* Object with internal rep to set. Must not + * currently have an internal rep.*/ { String *srcStringPtr = GET_STRING(srcPtr); String *copyStringPtr = NULL; /* - * If the src obj is a string of 1-byte Utf chars, then copy the - * string rep of the source object and create an "empty" Unicode - * internal rep for the new object. Otherwise, copy Unicode - * internal rep, and invalidate the string rep of the new object. + * If the src obj is a string of 1-byte Utf chars, then copy the string + * rep of the source object and create an "empty" Unicode internal rep for + * the new object. Otherwise, copy Unicode internal rep, and invalidate + * the string rep of the new object. */ - + if (srcStringPtr->hasUnicode == 0) { - copyStringPtr = (String *) ckalloc(STRING_SIZE(STRING_UALLOC(0))); + copyStringPtr = (String *) ckalloc(STRING_SIZE(STRING_UALLOC(0))); copyStringPtr->uallocated = STRING_UALLOC(0); } else { copyStringPtr = (String *) ckalloc( - STRING_SIZE(srcStringPtr->uallocated)); + STRING_SIZE(srcStringPtr->uallocated)); copyStringPtr->uallocated = srcStringPtr->uallocated; memcpy((VOID *) copyStringPtr->unicode, (VOID *) srcStringPtr->unicode, (size_t) srcStringPtr->numChars * sizeof(Tcl_UniChar)); @@ -1757,13 +2611,13 @@ copyStringPtr->numChars = srcStringPtr->numChars; copyStringPtr->hasUnicode = srcStringPtr->hasUnicode; copyStringPtr->allocated = srcStringPtr->allocated; /* - * Tricky point: the string value was copied by generic object - * management code, so it doesn't contain any extra bytes that - * might exist in the source object. + * Tricky point: the string value was copied by generic object management + * code, so it doesn't contain any extra bytes that might exist in the + * source object. */ copyStringPtr->allocated = copyPtr->length; SET_STRING(copyPtr, copyStringPtr); @@ -1779,12 +2633,12 @@ * * Results: * This operation always succeeds and returns TCL_OK. * * Side effects: - * Any old internal reputation for objPtr is freed and the - * internal representation is set to "String". + * Any old internal reputation for objPtr is freed and the internal + * representation is set to "String". * *---------------------------------------------------------------------- */ static int @@ -1791,13 +2645,13 @@ SetStringFromAny(interp, objPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr; /* The object to convert. */ { /* - * The Unicode object is optimized for the case where each UTF char - * in a string is only one byte. In this case, we store the value of - * numChars, but we don't copy the bytes to the unicodeObj->unicode. + * The Unicode object is optimized for the case where each UTF char in a + * string is only one byte. In this case, we store the value of numChars, + * but we don't copy the bytes to the unicodeObj->unicode. */ if (objPtr->typePtr != &tclStringType) { String *stringPtr; @@ -1817,12 +2671,12 @@ stringPtr->numChars = -1; stringPtr->uallocated = STRING_UALLOC(0); stringPtr->hasUnicode = 0; if (objPtr->bytes != NULL) { - stringPtr->allocated = objPtr->length; - objPtr->bytes[objPtr->length] = 0; + stringPtr->allocated = objPtr->length; + objPtr->bytes[objPtr->length] = 0; } else { objPtr->length = 0; } SET_STRING(objPtr, stringPtr); } @@ -1839,12 +2693,12 @@ * * Results: * None. * * Side effects: - * The object's string may be set by converting its Unicode - * represention to UTF format. + * The object's string may be set by converting its Unicode represention + * to UTF format. * *---------------------------------------------------------------------- */ static void @@ -1857,16 +2711,14 @@ char *dst; String *stringPtr; stringPtr = GET_STRING(objPtr); if ((objPtr->bytes == NULL) || (stringPtr->allocated == 0)) { - if (stringPtr->numChars <= 0) { - /* - * If there is no Unicode rep, or the string has 0 chars, - * then set the string rep to an empty string. + * If there is no Unicode rep, or the string has 0 chars, then set + * the string rep to an empty string. */ objPtr->bytes = tclEmptyStringRep; objPtr->length = 0; return; @@ -1873,19 +2725,19 @@ } unicode = stringPtr->unicode; /* - * Translate the Unicode string to UTF. "size" will hold the - * amount of space the UTF string needs. + * Translate the Unicode string to UTF. "size" will hold the amount of + * space the UTF string needs. */ size = 0; for (i = 0; i < stringPtr->numChars; i++) { size += Tcl_UniCharToUtf((int) unicode[i], dummy); } - + dst = (char *) ckalloc((unsigned) (size + 1)); objPtr->bytes = dst; objPtr->length = size; stringPtr->allocated = size; @@ -1900,18 +2752,18 @@ /* *---------------------------------------------------------------------- * * FreeStringInternalRep -- * - * Deallocate the storage associated with a String data object's - * internal representation. + * Deallocate the storage associated with a String data object's internal + * representation. * * Results: * None. * * Side effects: - * Frees memory. + * Frees memory. * *---------------------------------------------------------------------- */ static void @@ -1918,5 +2770,13 @@ FreeStringInternalRep(objPtr) Tcl_Obj *objPtr; /* Object with internal rep to free. */ { ckfree((char *) GET_STRING(objPtr)); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclStubInit.c ================================================================== --- generic/tclStubInit.c +++ generic/tclStubInit.c @@ -6,11 +6,11 @@ * Copyright (c) 1998-1999 by Scriptics Corporation. * * 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.109 2004/12/01 23:18:53 dgp Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.109.2.17 2005/09/20 14:11:52 dgp Exp $ */ #include "tclInt.h" /* @@ -101,11 +101,11 @@ NULL, /* 19 */ NULL, /* 20 */ NULL, /* 21 */ TclFindElement, /* 22 */ TclFindProc, /* 23 */ - TclFormatInt, /* 24 */ + NULL, /* 24 */ TclFreePackageInfo, /* 25 */ NULL, /* 26 */ NULL, /* 27 */ TclpGetDefaultStdChannel, /* 28 */ NULL, /* 29 */ @@ -126,11 +126,11 @@ TclGuessPackageName, /* 44 */ TclHideUnsafeCommands, /* 45 */ TclInExit, /* 46 */ NULL, /* 47 */ NULL, /* 48 */ - TclIncrVar2, /* 49 */ + NULL, /* 49 */ TclInitCompiledLocals, /* 50 */ TclInterpInit, /* 51 */ NULL, /* 52 */ TclInvokeObjectCommand, /* 53 */ TclInvokeStringCommand, /* 54 */ @@ -222,11 +222,11 @@ NULL, /* 135 */ NULL, /* 136 */ NULL, /* 137 */ TclGetEnv, /* 138 */ NULL, /* 139 */ - TclLooksLikeInt, /* 140 */ + NULL, /* 140 */ TclpGetCwd, /* 141 */ TclSetByteCodeFromAny, /* 142 */ TclAddLiteralObj, /* 143 */ TclHideLiteral, /* 144 */ TclGetAuxDataType, /* 145 */ @@ -256,36 +256,36 @@ TclpUtfNcmp2, /* 169 */ TclCheckInterpTraces, /* 170 */ TclCheckExecutionTraces, /* 171 */ TclInThreadExit, /* 172 */ TclUniCharMatch, /* 173 */ - TclIncrWideVar2, /* 174 */ + NULL, /* 174 */ TclCallVarTraces, /* 175 */ TclCleanupVar, /* 176 */ TclVarErrMsg, /* 177 */ Tcl_SetStartupScript, /* 178 */ Tcl_GetStartupScript, /* 179 */ - TclNewListObjDirect, /* 180 */ - TclDbNewListObjDirect, /* 181 */ + NULL, /* 180 */ + NULL, /* 181 */ TclpLocaltime, /* 182 */ TclpGmtime, /* 183 */ - TclThreadStorageLockInit, /* 184 */ - TclThreadStorageLock, /* 185 */ - TclThreadStorageUnlock, /* 186 */ - TclThreadStoragePrint, /* 187 */ - TclThreadStorageGetHashTable, /* 188 */ - TclThreadStorageInit, /* 189 */ - TclThreadStorageDataKeyInit, /* 190 */ - TclThreadStorageDataKeyGet, /* 191 */ - TclThreadStorageDataKeySet, /* 192 */ - TclFinalizeThreadStorageThread, /* 193 */ - TclFinalizeThreadStorage, /* 194 */ - TclFinalizeThreadStorageData, /* 195 */ - TclFinalizeThreadStorageDataKey, /* 196 */ + NULL, /* 184 */ + NULL, /* 185 */ + NULL, /* 186 */ + NULL, /* 187 */ + NULL, /* 188 */ + NULL, /* 189 */ + NULL, /* 190 */ + NULL, /* 191 */ + NULL, /* 192 */ + NULL, /* 193 */ + NULL, /* 194 */ + NULL, /* 195 */ + NULL, /* 196 */ TclCompEvalObj, /* 197 */ TclObjGetFrame, /* 198 */ - TclMatchIsTrivial, /* 199 */ + NULL, /* 199 */ TclpObjRemoveDirectory, /* 200 */ TclpObjCopyDirectory, /* 201 */ TclpObjCreateDirectory, /* 202 */ TclpObjDeleteFile, /* 203 */ TclpObjCopyFile, /* 204 */ @@ -297,10 +297,21 @@ TclSetEncodingSearchPath, /* 210 */ TclpGetEncodingNameFromEnvironment, /* 211 */ TclpFindExecutable, /* 212 */ TclGetObjNameOfExecutable, /* 213 */ TclSetObjNameOfExecutable, /* 214 */ + TclStackAlloc, /* 215 */ + TclStackFree, /* 216 */ + TclPushStackFrame, /* 217 */ + TclPopStackFrame, /* 218 */ + TclBN_mp_div_d, /* 219 */ + TclBN_mp_mul_d, /* 220 */ + TclBN_mp_clear, /* 221 */ + TclBN_mp_init, /* 222 */ + TclBN_mp_read_radix, /* 223 */ + TclGetPlatform, /* 224 */ + TclTraceDictPath, /* 225 */ }; TclIntPlatStubs tclIntPlatStubs = { TCL_STUB_MAGIC, NULL, @@ -345,11 +356,11 @@ TclWinAddProcess, /* 20 */ NULL, /* 21 */ TclpCreateTempFile, /* 22 */ TclpGetTZName, /* 23 */ TclWinNoBackslash, /* 24 */ - TclWinGetPlatform, /* 25 */ + NULL, /* 25 */ TclWinSetInterfaces, /* 26 */ TclWinFlushDirtyChannels, /* 27 */ TclWinResetInterfaces, /* 28 */ TclWinCPUID, /* 29 */ #endif /* __WIN32__ */ @@ -950,8 +961,34 @@ Tcl_SaveInterpState, /* 535 */ Tcl_RestoreInterpState, /* 536 */ Tcl_DiscardInterpState, /* 537 */ Tcl_SetReturnOptions, /* 538 */ Tcl_GetReturnOptions, /* 539 */ + Tcl_IsEnsemble, /* 540 */ + Tcl_CreateEnsemble, /* 541 */ + Tcl_FindEnsemble, /* 542 */ + Tcl_SetEnsembleSubcommandList, /* 543 */ + Tcl_SetEnsembleMappingDict, /* 544 */ + Tcl_SetEnsembleUnknownHandler, /* 545 */ + Tcl_SetEnsembleFlags, /* 546 */ + Tcl_GetEnsembleSubcommandList, /* 547 */ + Tcl_GetEnsembleMappingDict, /* 548 */ + Tcl_GetEnsembleUnknownHandler, /* 549 */ + Tcl_GetEnsembleFlags, /* 550 */ + Tcl_GetEnsembleNamespace, /* 551 */ + Tcl_SetTimeProc, /* 552 */ + Tcl_QueryTimeProc, /* 553 */ + Tcl_ChannelThreadActionProc, /* 554 */ + Tcl_NewBignumObj, /* 555 */ + Tcl_DbNewBignumObj, /* 556 */ + Tcl_SetBignumObj, /* 557 */ + Tcl_GetBignumFromObj, /* 558 */ + 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. */ Index: generic/tclTest.c ================================================================== --- generic/tclTest.c +++ generic/tclTest.c @@ -12,11 +12,11 @@ * Copyright (c) 2003 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: tclTest.c,v 1.86 2004/11/30 19:34:50 dgp Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.86.2.7 2005/09/09 18:48:40 dgp Exp $ */ #define TCL_TEST #include "tclInt.h" @@ -118,10 +118,24 @@ Tcl_Event header; /* Header common to all events */ Tcl_Interp* interp; /* Interpreter that will handle the event */ Tcl_Obj* command; /* Command to evaluate when the event occurs */ Tcl_Obj* tag; /* Tag for this event used to delete it */ } TestEvent; + + +/* + * Simple detach/attach facility for testchannel cut|splice. + * Allow testing of channel transfer in core testsuite. + */ + +typedef struct TestChannel { + Tcl_Channel chan; /* Detached channel */ + struct TestChannel* nextPtr; /* Next in pool of detached channels */ +} TestChannel; + +static TestChannel* firstDetached; + /* * Forward declarations for procedures defined later in this file: */ @@ -242,10 +256,18 @@ ClientData clientData)); 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[])); static int TestexprstringCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); @@ -306,10 +328,13 @@ static int TestparsevarnameObjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TestregexpObjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int TestreturnObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static void TestregexpXflags _ANSI_ARGS_((char *string, int length, int *cflagsPtr, int *eflagsPtr)); static int TestsaveresultCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, @@ -621,10 +646,16 @@ (ClientData) 0, (Tcl_CmdDeleteProc*) NULL ); Tcl_CreateCommand(interp, "testexithandler", TestexithandlerCmd, (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, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0, @@ -661,10 +692,12 @@ Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); @@ -2275,20 +2308,154 @@ CONST char **argv; /* Argument strings. */ { long exprResult; char buf[4 + TCL_INTEGER_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_ExprLong(interp, argv[1], &exprResult); + if (result != TCL_OK) { + return result; + } + sprintf(buf, ": %ld", exprResult); + Tcl_AppendResult(interp, buf, NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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_ExprLong(interp, "4+1", &exprResult); + 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 -- @@ -2450,15 +2617,11 @@ CONST char **argv; /* Argument strings. */ { static CONST char *platformStrings[] = { "unix", "mac", "windows" }; TclPlatformType *platform; -#ifdef __WIN32__ - platform = TclWinGetPlatform(); -#else - platform = &tclPlatform; -#endif + platform = TclGetPlatform(); if (argc != 1) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], (char *) NULL); return TCL_ERROR; @@ -2538,33 +2701,54 @@ static int intVar = 43; static int boolVar = 4; static double realVar = 1.23; static Tcl_WideInt wideVar = Tcl_LongAsWide(79); static char *stringVar = NULL; + static char charVar = '@'; + static unsigned char ucharVar = 130; + static short shortVar = 3000; + static unsigned short ushortVar = 60000; + static unsigned int uintVar = 0xbeeffeed; + static long longVar = 123456789L; + static unsigned long ulongVar = 3456789012UL; + static float floatVar = 4.5; + static Tcl_WideUInt uwideVar = (Tcl_WideUInt) Tcl_LongAsWide(123); static int created = 0; char buffer[2*TCL_DOUBLE_SPACE]; int writable, flag; Tcl_Obj *tmp; if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " option ?arg arg arg arg arg?\"", (char *) NULL); + " option ?arg arg arg arg arg arg arg arg arg arg arg arg", + " arg arg?\"", (char *) NULL); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { - if (argc != 7) { + if (argc != 16) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], - " intRO realRO boolRO stringRO wideRO\"", (char *) NULL); + " intRO realRO boolRO stringRO wideRO charRO ucharRO shortRO", + " ushortRO uintRO longRO ulongRO floatRO uwideRO\"", + (char *) NULL); return TCL_ERROR; } if (created) { Tcl_UnlinkVar(interp, "int"); Tcl_UnlinkVar(interp, "real"); Tcl_UnlinkVar(interp, "bool"); Tcl_UnlinkVar(interp, "string"); Tcl_UnlinkVar(interp, "wide"); + Tcl_UnlinkVar(interp, "char"); + Tcl_UnlinkVar(interp, "uchar"); + Tcl_UnlinkVar(interp, "short"); + Tcl_UnlinkVar(interp, "ushort"); + Tcl_UnlinkVar(interp, "uint"); + Tcl_UnlinkVar(interp, "long"); + Tcl_UnlinkVar(interp, "ulong"); + Tcl_UnlinkVar(interp, "float"); + Tcl_UnlinkVar(interp, "uwide"); } created = 1; if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) { return TCL_ERROR; } @@ -2603,16 +2787,98 @@ flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "wide", (char *) &wideVar, TCL_LINK_WIDE_INT | flag) != TCL_OK) { return TCL_ERROR; } + if (Tcl_GetBoolean(interp, argv[7], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "char", (char *) &charVar, + TCL_LINK_CHAR | flag) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBoolean(interp, argv[8], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "uchar", (char *) &ucharVar, + TCL_LINK_UCHAR | flag) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBoolean(interp, argv[9], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "short", (char *) &shortVar, + TCL_LINK_SHORT | flag) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBoolean(interp, argv[10], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "ushort", (char *) &ushortVar, + TCL_LINK_USHORT | flag) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBoolean(interp, argv[11], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "uint", (char *) &uintVar, + TCL_LINK_UINT | flag) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBoolean(interp, argv[12], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "long", (char *) &longVar, + TCL_LINK_LONG | flag) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBoolean(interp, argv[13], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "ulong", (char *) &ulongVar, + TCL_LINK_ULONG | flag) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBoolean(interp, argv[14], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "float", (char *) &floatVar, + TCL_LINK_FLOAT | flag) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBoolean(interp, argv[15], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "uwide", (char *) &uwideVar, + TCL_LINK_WIDE_UINT | flag) != TCL_OK) { + return TCL_ERROR; + } + } else if (strcmp(argv[1], "delete") == 0) { Tcl_UnlinkVar(interp, "int"); Tcl_UnlinkVar(interp, "real"); Tcl_UnlinkVar(interp, "bool"); Tcl_UnlinkVar(interp, "string"); Tcl_UnlinkVar(interp, "wide"); + Tcl_UnlinkVar(interp, "char"); + Tcl_UnlinkVar(interp, "uchar"); + Tcl_UnlinkVar(interp, "short"); + Tcl_UnlinkVar(interp, "ushort"); + Tcl_UnlinkVar(interp, "uint"); + Tcl_UnlinkVar(interp, "long"); + Tcl_UnlinkVar(interp, "ulong"); + Tcl_UnlinkVar(interp, "float"); + Tcl_UnlinkVar(interp, "uwide"); created = 0; } else if (strcmp(argv[1], "get") == 0) { TclFormatInt(buffer, intVar); Tcl_AppendElement(interp, buffer); Tcl_PrintDouble((Tcl_Interp *) NULL, realVar, buffer); @@ -2624,15 +2890,40 @@ * Wide ints only have an object-based interface. */ tmp = Tcl_NewWideIntObj(wideVar); Tcl_AppendElement(interp, Tcl_GetString(tmp)); Tcl_DecrRefCount(tmp); + TclFormatInt(buffer, (int) charVar); + Tcl_AppendElement(interp, buffer); + TclFormatInt(buffer, (int) ucharVar); + Tcl_AppendElement(interp, buffer); + TclFormatInt(buffer, (int) shortVar); + Tcl_AppendElement(interp, buffer); + TclFormatInt(buffer, (int) ushortVar); + Tcl_AppendElement(interp, buffer); + TclFormatInt(buffer, (int) uintVar); + Tcl_AppendElement(interp, buffer); + tmp = Tcl_NewLongObj(longVar); + Tcl_AppendElement(interp, Tcl_GetString(tmp)); + Tcl_DecrRefCount(tmp); + tmp = Tcl_NewLongObj((long)ulongVar); + Tcl_AppendElement(interp, Tcl_GetString(tmp)); + Tcl_DecrRefCount(tmp); + Tcl_PrintDouble((Tcl_Interp *) NULL, (double)floatVar, buffer); + Tcl_AppendElement(interp, buffer); + tmp = Tcl_NewWideIntObj((Tcl_WideInt)uwideVar); + Tcl_AppendElement(interp, Tcl_GetString(tmp)); + Tcl_DecrRefCount(tmp); } else if (strcmp(argv[1], "set") == 0) { - if (argc != 7) { + int v; + + if (argc != 16) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], - " intValue realValue boolValue stringValue wideValue\"", + " intValue realValue boolValue stringValue wideValue", + " charValue ucharValue shortValue ushortValue uintValue", + " longValue ulongValue floatValue uwideValue\"", (char *) NULL); return TCL_ERROR; } if (argv[2][0] != 0) { if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) { @@ -2666,15 +2957,78 @@ Tcl_DecrRefCount(tmp); return TCL_ERROR; } Tcl_DecrRefCount(tmp); } + if (argv[7][0]) { + if (Tcl_GetInt(interp, argv[7], &v) != TCL_OK) { + return TCL_ERROR; + } + charVar = (char) v; + } + if (argv[8][0]) { + if (Tcl_GetInt(interp, argv[8], &v) != TCL_OK) { + return TCL_ERROR; + } + ucharVar = (unsigned char) v; + } + if (argv[9][0]) { + if (Tcl_GetInt(interp, argv[9], &v) != TCL_OK) { + return TCL_ERROR; + } + shortVar = (short) v; + } + if (argv[10][0]) { + if (Tcl_GetInt(interp, argv[10], &v) != TCL_OK) { + return TCL_ERROR; + } + ushortVar = (unsigned short) v; + } + if (argv[11][0]) { + if (Tcl_GetInt(interp, argv[11], &v) != TCL_OK) { + return TCL_ERROR; + } + uintVar = (unsigned int) v; + } + if (argv[12][0]) { + if (Tcl_GetInt(interp, argv[12], &v) != TCL_OK) { + return TCL_ERROR; + } + longVar = (long) v; + } + if (argv[13][0]) { + if (Tcl_GetInt(interp, argv[13], &v) != TCL_OK) { + return TCL_ERROR; + } + ulongVar = (unsigned long) v; + } + if (argv[14][0]) { + double d; + if (Tcl_GetDouble(interp, argv[14], &d) != TCL_OK) { + return TCL_ERROR; + } + floatVar = (float) d; + } + if (argv[15][0]) { + Tcl_WideInt w; + tmp = Tcl_NewStringObj(argv[15], -1); + if (Tcl_GetWideIntFromObj(interp, tmp, &w) != TCL_OK) { + Tcl_DecrRefCount(tmp); + return TCL_ERROR; + } + Tcl_DecrRefCount(tmp); + uwideVar = (Tcl_WideUInt) w; + } } else if (strcmp(argv[1], "update") == 0) { - if (argc != 7) { + int v; + + if (argc != 16) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], - "intValue realValue boolValue stringValue wideValue\"", + " intValue realValue boolValue stringValue wideValue", + " charValue ucharValue shortValue ushortValue uintValue", + " longValue ulongValue floatValue uwideValue\"", (char *) NULL); return TCL_ERROR; } if (argv[2][0] != 0) { if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) { @@ -2713,10 +3067,78 @@ return TCL_ERROR; } Tcl_DecrRefCount(tmp); Tcl_UpdateLinkedVar(interp, "wide"); } + if (argv[7][0]) { + if (Tcl_GetInt(interp, argv[7], &v) != TCL_OK) { + return TCL_ERROR; + } + charVar = (char) v; + Tcl_UpdateLinkedVar(interp, "char"); + } + if (argv[8][0]) { + if (Tcl_GetInt(interp, argv[8], &v) != TCL_OK) { + return TCL_ERROR; + } + ucharVar = (unsigned char) v; + Tcl_UpdateLinkedVar(interp, "uchar"); + } + if (argv[9][0]) { + if (Tcl_GetInt(interp, argv[9], &v) != TCL_OK) { + return TCL_ERROR; + } + shortVar = (short) v; + Tcl_UpdateLinkedVar(interp, "short"); + } + if (argv[10][0]) { + if (Tcl_GetInt(interp, argv[10], &v) != TCL_OK) { + return TCL_ERROR; + } + ushortVar = (unsigned short) v; + Tcl_UpdateLinkedVar(interp, "ushort"); + } + if (argv[11][0]) { + if (Tcl_GetInt(interp, argv[11], &v) != TCL_OK) { + return TCL_ERROR; + } + uintVar = (unsigned int) v; + Tcl_UpdateLinkedVar(interp, "uint"); + } + if (argv[12][0]) { + if (Tcl_GetInt(interp, argv[12], &v) != TCL_OK) { + return TCL_ERROR; + } + longVar = (long) v; + Tcl_UpdateLinkedVar(interp, "long"); + } + if (argv[13][0]) { + if (Tcl_GetInt(interp, argv[13], &v) != TCL_OK) { + return TCL_ERROR; + } + ulongVar = (unsigned long) v; + Tcl_UpdateLinkedVar(interp, "ulong"); + } + if (argv[14][0]) { + double d; + if (Tcl_GetDouble(interp, argv[14], &d) != TCL_OK) { + return TCL_ERROR; + } + floatVar = (float) d; + Tcl_UpdateLinkedVar(interp, "float"); + } + if (argv[15][0]) { + Tcl_WideInt w; + tmp = Tcl_NewStringObj(argv[15], -1); + if (Tcl_GetWideIntFromObj(interp, tmp, &w) != TCL_OK) { + Tcl_DecrRefCount(tmp); + return TCL_ERROR; + } + Tcl_DecrRefCount(tmp); + uwideVar = (Tcl_WideUInt) w; + Tcl_UpdateLinkedVar(interp, "uwide"); + } } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": should be create, delete, get, set, or update", (char *) NULL); return TCL_ERROR; @@ -3612,10 +4034,41 @@ } /* *---------------------------------------------------------------------- * + * TestreturnObjCmd -- + * + * This procedure implements the "testreturn" command. It is + * used to verify that a + * return TCL_RETURN; + * has same behavior as + * return Tcl_SetReturnOptions(interp, Tcl_NewObj()); + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestreturnObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + return TCL_RETURN; +} + +/* + *---------------------------------------------------------------------- + * * TestsetassocdataCmd -- * * This procedure implements the "testsetassocdata" command. It is used * to test Tcl_SetAssocData. * @@ -3690,15 +4143,11 @@ CONST char **argv; /* Argument strings. */ { size_t length; TclPlatformType *platform; -#ifdef __WIN32__ - platform = TclWinGetPlatform(); -#else - platform = &tclPlatform; -#endif + platform = TclGetPlatform(); if (argc != 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], " platform\"", (char *) NULL); return TCL_ERROR; @@ -4189,11 +4638,11 @@ Tcl_Obj *CONST objv[]; /* The argument objects. */ { char *name, *arg; int flags = 0; Tcl_Namespace *namespacePtr; - Tcl_CallFrame frame; + Tcl_CallFrame *framePtr; Tcl_Var variable; int result; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "name scope"); @@ -4220,11 +4669,11 @@ namespacePtr = Tcl_FindNamespace(interp, "::test_ns_var", (Tcl_Namespace *) NULL, TCL_LEAVE_ERR_MSG); if (namespacePtr == NULL) { return TCL_ERROR; } - result = Tcl_PushCallFrame(interp, &frame, namespacePtr, + result = TclPushStackFrame(interp, &framePtr, namespacePtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { return result; } } @@ -4231,11 +4680,11 @@ variable = Tcl_FindNamespaceVar(interp, name, (Tcl_Namespace *) NULL, (flags | TCL_LEAVE_ERR_MSG)); if (flags == TCL_NAMESPACE_ONLY) { - Tcl_PopCallFrame(interp); + TclPopStackFrame(interp); } if (variable == (Tcl_Var) NULL) { return TCL_ERROR; } Tcl_GetVariableFullName(interp, variable, Tcl_GetObjResult(interp)); @@ -5317,31 +5766,103 @@ len = strlen(cmdName); chanPtr = (Channel *) NULL; if (argc > 2) { - chan = Tcl_GetChannel(interp, argv[2], &mode); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } + if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) { + /* For splice access the pool of detached channels. + * Locate channel, remove from the list. + */ + + TestChannel** nextPtrPtr; + TestChannel* curPtr; + + chan = (Tcl_Channel) NULL; + for (nextPtrPtr = &firstDetached, curPtr = firstDetached; + curPtr != NULL; + nextPtrPtr = &(curPtr->nextPtr), curPtr = curPtr->nextPtr) { + + if (strcmp (argv[2], Tcl_GetChannelName (curPtr->chan)) == 0) { + *nextPtrPtr = curPtr->nextPtr; + curPtr->nextPtr = NULL; + chan = curPtr->chan; + ckfree ((char*) curPtr); + break; + } + } + } else { + chan = Tcl_GetChannel(interp, argv[2], &mode); + } + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } chanPtr = (Channel *) chan; statePtr = chanPtr->state; chanPtr = statePtr->topChanPtr; chan = (Tcl_Channel) chanPtr; } else { /* lint */ statePtr = NULL; chan = NULL; } + + if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerror", len) == 0)) { + + Tcl_Obj* msg = Tcl_NewStringObj (argv [3],-1); + + Tcl_IncrRefCount (msg); + Tcl_SetChannelError (chan, msg); + Tcl_DecrRefCount (msg); + + Tcl_GetChannelError (chan, &msg); + Tcl_SetObjResult (interp, msg); + Tcl_DecrRefCount (msg); + return TCL_OK; + } + if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerrorinterp", len) == 0)) { + + Tcl_Obj* msg = Tcl_NewStringObj (argv [3],-1); + + Tcl_IncrRefCount (msg); + Tcl_SetChannelErrorInterp (interp, msg); + Tcl_DecrRefCount (msg); + + Tcl_GetChannelErrorInterp (interp, &msg); + Tcl_SetObjResult (interp, msg); + Tcl_DecrRefCount (msg); + return TCL_OK; + } + + /* + * "cut" is actually more a simplified detach facility as provided + * by the Thread package. Without the safeguards of a regular + * command (no checking that the command is truly cut'able, no + * mutexes for thread-safety). Its complementary command is + * "splice", see below. + */ if ((cmdName[0] == 'c') && (strncmp(cmdName, "cut", len) == 0)) { + TestChannel* det; + if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " cut channelName\"", (char *) NULL); return TCL_ERROR; } + + Tcl_RegisterChannel((Tcl_Interp *) NULL, chan); /* prevent closing */ + Tcl_UnregisterChannel(interp, chan); + Tcl_CutChannel(chan); + + /* Remember the channel in the pool of detached channels */ + + det = (TestChannel*) ckalloc (sizeof(TestChannel)); + det->chan = chan; + det->nextPtr = firstDetached; + firstDetached = det; + return TCL_OK; } if ((cmdName[0] == 'c') && (strncmp(cmdName, "clearchannelhandlers", len) == 0)) { @@ -5591,17 +6112,29 @@ TclFormatInt(buf, statePtr->refCount); Tcl_AppendResult(interp, buf, (char *) NULL); return TCL_OK; } + /* + * "splice" is actually more a simplified attach facility as + * provided by the Thread package. Without the safeguards of a + * regular command (no checking that the command is truly + * cut'able, no mutexes for thread-safety). Its complementary + * command is "cut", see above. + */ + if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "channel name required", (char *) NULL); return TCL_ERROR; } Tcl_SpliceChannel(chan); + + Tcl_RegisterChannel(interp, chan); + Tcl_UnregisterChannel((Tcl_Interp *)NULL, chan); + return TCL_OK; } if ((cmdName[0] == 't') && (strncmp(cmdName, "type", len) == 0)) { if (argc != 3) { @@ -6637,5 +7170,13 @@ TclFormatInt(buf, total); Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_OK; } } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclTestObj.c ================================================================== --- generic/tclTestObj.c +++ generic/tclTestObj.c @@ -6,18 +6,20 @@ * types. These commands are not normally included in Tcl * applications; they're only used for testing. * * Copyright (c) 1995-1998 Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation. + * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTestObj.c,v 1.12 2002/12/04 13:09:24 vincentdarley Exp $ + * RCS: @(#) $Id: tclTestObj.c,v 1.12.6.5 2005/08/22 16:11:37 dgp Exp $ */ #include "tclInt.h" +#include "tommath.h" /* * An array of Tcl_Obj pointers used in the commands that operate on or get * the values of Tcl object-valued variables. varPtr[i] is the i-th * variable's Tcl_Obj *. @@ -35,16 +37,21 @@ static int GetVariableIndex _ANSI_ARGS_((Tcl_Interp *interp, char *string, int *indexPtr)); static void SetVarToObj _ANSI_ARGS_((int varIndex, Tcl_Obj *objPtr)); int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +static int TestbignumobjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); static int TestbooleanobjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +#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[])); static int TestindexobjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, @@ -93,14 +100,18 @@ for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { varPtr[i] = NULL; } + Tcl_CreateObjCommand( interp, "testbignumobj", TestbignumobjCmd, + (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, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testindexobj", TestindexobjCmd, @@ -109,10 +120,165 @@ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "teststringobj", TeststringobjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * TestbignumobjCmd -- + * + * This procedure implmenets the "testbignumobj" command. It is used + * to exercise the bignum Tcl object type implementation. + * + * Results: + * Returns a standard Tcl object result. + * + * Side effects: + * Creates and frees bignum objects; converts objects to have bignum + * type. + * + *---------------------------------------------------------------------- + */ + +static int +TestbignumobjCmd( clientData, interp, objc, objv ) + ClientData clientData; /* unused */ + Tcl_Interp* interp; /* Tcl interpreter */ + int objc; /* Argument count */ + Tcl_Obj* CONST objv[]; /* Argument vector */ +{ + const char * subcmds[] = { + "set", "get", "mult10", "div10", + NULL + }; + enum options { + BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10 + }; + + int index, varIndex; + char* string; + mp_int bignumValue, newValue; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg?..."); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + string = Tcl_GetString(objv[2]); + if (GetVariableIndex(interp, string, &varIndex) != TCL_OK) { + return TCL_ERROR; + } + + switch (index) { + case BIGNUM_SET: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "var value"); + return TCL_ERROR; + } + string = Tcl_GetString(objv[3]); + if (mp_init(&bignumValue) != MP_OKAY) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("error in mp_init", -1)); + return TCL_ERROR; + } + if (mp_read_radix(&bignumValue, string, 10) != MP_OKAY) { + mp_clear(&bignumValue); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("error in mp_read_radix", -1)); + return TCL_ERROR; + } + + /* + * If the object currently bound to the variable with index + * varIndex has ref count 1 (i.e. the object is unshared) we can + * modify that object directly. Otherwise, if RC>1 (i.e. the + * object is shared), we must create a new object to modify/set and + * decrement the old formerly-shared object's ref count. This is + * "copy on write". + */ + + if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { + Tcl_SetBignumObj(varPtr[varIndex], &bignumValue); + } else { + SetVarToObj(varIndex, Tcl_NewBignumObj(&bignumValue)); + } + break; + + case BIGNUM_GET: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + break; + + case BIGNUM_MULT10: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + if (Tcl_GetBignumFromObj(interp, varPtr[varIndex], + &bignumValue) != TCL_OK) { + return TCL_ERROR; + } + if (mp_init(&newValue) != MP_OKAY + || (mp_mul_d(&bignumValue, 10, &newValue) != MP_OKAY)) { + mp_clear(&bignumValue); + mp_clear(&newValue); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("error in mp_mul_d", -1)); + return TCL_ERROR; + } + mp_clear(&bignumValue); + if (!Tcl_IsShared(varPtr[varIndex])) { + Tcl_SetBignumObj(varPtr[varIndex], &newValue); + } else { + SetVarToObj(varIndex, Tcl_NewBignumObj(&newValue)); + } + break; + + case BIGNUM_DIV10: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + if (Tcl_GetBignumFromObj(interp, varPtr[varIndex], + &bignumValue) != TCL_OK) { + return TCL_ERROR; + } + if (mp_init(&newValue) != MP_OKAY + || (mp_div_d(&bignumValue, 10, &newValue, NULL) != MP_OKAY)) { + mp_clear(&bignumValue); + mp_clear(&newValue); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("error in mp_div_d", -1)); + return TCL_ERROR; + } + mp_clear(&bignumValue); + if (!Tcl_IsShared(varPtr[varIndex])) { + Tcl_SetBignumObj(varPtr[varIndex], &newValue); + } else { + SetVarToObj(varIndex, Tcl_NewBignumObj(&newValue)); + } + } + + Tcl_SetObjResult(interp, varPtr[varIndex]); + return TCL_OK; +} /* *---------------------------------------------------------------------- * * TestbooleanobjCmd -- @@ -206,10 +372,11 @@ return TCL_ERROR; } return TCL_OK; } +#if 0 /* *---------------------------------------------------------------------- * * TestconvertobjCmd -- * @@ -259,10 +426,11 @@ "\": must be double", (char *) NULL); return TCL_ERROR; } return TCL_OK; } +#endif /* *---------------------------------------------------------------------- * * TestdoubleobjCmd -- Index: generic/tclThread.c ================================================================== --- generic/tclThread.c +++ generic/tclThread.c @@ -1,26 +1,25 @@ /* * tclThread.c -- * - * This file implements Platform independent thread operations. - * Most of the real work is done in the platform dependent files. + * This file implements Platform independent thread operations. Most of + * the real work is done in the platform dependent files. * * Copyright (c) 1998 by Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclThread.c,v 1.8 2004/06/24 01:29:02 mistachkin Exp $ + * RCS: @(#) $Id: tclThread.c,v 1.8.2.4 2005/08/15 18:13:59 dgp Exp $ */ #include "tclInt.h" /* - * There are three classes of synchronization objects: - * mutexes, thread data keys, and condition variables. - * The following are used to record the memory used for these - * objects so they can be finalized. + * There are three classes of synchronization objects: mutexes, thread data + * keys, and condition variables. The following are used to record the memory + * used for these objects so they can be finalized. * * These statics are guarded by the mutex in the caller of * TclRememberThreadData, e.g., TclpThreadDataKeyInit */ @@ -33,23 +32,24 @@ static SyncObjRecord keyRecord = {0, 0, NULL}; static SyncObjRecord mutexRecord = {0, 0, NULL}; static SyncObjRecord condRecord = {0, 0, NULL}; /* - * Prototypes of functions used only in this file + * Prototypes of functions used only in this file. */ static void RememberSyncObject _ANSI_ARGS_((char *objPtr, SyncObjRecord *recPtr)); static void ForgetSyncObject _ANSI_ARGS_((char *objPtr, SyncObjRecord *recPtr)); /* * Several functions are #defined to nothing in tcl.h if TCL_THREADS is not - * specified. Here we undo that so the procedures are defined in the - * stubs table. + * specified. Here we undo that so the functions are defined in the stubs + * table. */ + #ifndef TCL_THREADS #undef Tcl_MutexLock #undef Tcl_MutexUnlock #undef Tcl_MutexFinalize #undef Tcl_ConditionNotify @@ -61,19 +61,19 @@ /* *---------------------------------------------------------------------- * * Tcl_GetThreadData -- * - * This procedure allocates and initializes a chunk of thread - * local storage. + * This function allocates and initializes a chunk of thread local + * storage. * * Results: * A thread-specific pointer to the data structure. * * Side effects: - * Will allocate memory the first time this thread calls for - * this chunk of storage. + * Will allocate memory the first time this thread calls for this chunk + * of storage. * *---------------------------------------------------------------------- */ VOID * @@ -81,137 +81,70 @@ Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk */ int size; /* Size of storage block */ { VOID *result; #ifdef TCL_THREADS - - /* - * See if this is the first thread to init this key. - */ - - if (*keyPtr == NULL) { -#ifdef USE_THREAD_STORAGE - TclThreadStorageDataKeyInit(keyPtr); -#else - TclpThreadDataKeyInit(keyPtr); -#endif - } - /* * Initialize the key for this thread. */ -#ifdef USE_THREAD_STORAGE - result = TclThreadStorageDataKeyGet(keyPtr); -#else result = TclpThreadDataKeyGet(keyPtr); -#endif if (result == NULL) { result = (VOID *)ckalloc((size_t)size); memset(result, 0, (size_t)size); -#ifdef USE_THREAD_STORAGE - TclThreadStorageDataKeySet(keyPtr, result); -#else TclpThreadDataKeySet(keyPtr, result); -#endif } -#else +#else /* TCL_THREADS */ if (*keyPtr == NULL) { result = (VOID *)ckalloc((size_t)size); memset((char *)result, 0, (size_t)size); *keyPtr = (Tcl_ThreadDataKey)result; - TclRememberDataKey(keyPtr); + RememberSyncObject((char *)keyPtr, &keyRecord); } result = *(VOID **)keyPtr; -#endif +#endif /* TCL_THREADS */ return result; } /* *---------------------------------------------------------------------- * * TclThreadDataKeyGet -- * - * This procedure returns a pointer to a block of thread local storage. + * This function returns a pointer to a block of thread local storage. * * Results: - * A thread-specific pointer to the data structure, or NULL - * if the memory has not been assigned to this key for this thread. + * A thread-specific pointer to the data structure, or NULL if the memory + * has not been assigned to this key for this thread. * * Side effects: * None. * *---------------------------------------------------------------------- */ VOID * TclThreadDataKeyGet(keyPtr) - Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, - * really (pthread_key_t **) */ + Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, really + * (pthread_key_t **) */ { #ifdef TCL_THREADS -#ifdef USE_THREAD_STORAGE - return (VOID *)TclThreadStorageDataKeyGet(keyPtr); -#else return (VOID *)TclpThreadDataKeyGet(keyPtr); -#endif -#else +#else /* TCL_THREADS */ char *result = *(char **)keyPtr; return (VOID *)result; #endif /* TCL_THREADS */ } /* *---------------------------------------------------------------------- * - * TclThreadDataKeySet -- - * - * This procedure sets a thread local storage pointer. - * - * Results: - * None. - * - * Side effects: - * The assigned value will be returned by TclpThreadDataKeyGet. - * - *---------------------------------------------------------------------- - */ - -void -TclThreadDataKeySet(keyPtr, data) - Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, - * really (pthread_key_t **) */ - VOID *data; /* Thread local storage */ -{ -#ifdef TCL_THREADS - if (*keyPtr == NULL) { -#ifdef USE_THREAD_STORAGE - TclThreadStorageDataKeyInit(keyPtr); -#else - TclpThreadDataKeyInit(keyPtr); -#endif - } -#ifdef USE_THREAD_STORAGE - TclThreadStorageDataKeySet(keyPtr, data); -#else - TclpThreadDataKeySet(keyPtr, data); -#endif -#else - *keyPtr = (Tcl_ThreadDataKey)data; -#endif /* TCL_THREADS */ -} - - - -/* - *---------------------------------------------------------------------- - * * RememberSyncObject * - * Keep a list of (mutexes/condition variable/data key) - * used during finalization. + * Keep a list of (mutexes/condition variable/data key) used during + * finalization. * * Results: * None. * * Side effects: @@ -227,22 +160,22 @@ { char **newList; int i, j; /* - * Save the pointer to the allocated object so it can be finalized. - * Grow the list of pointers if necessary, copying only non-NULL - * pointers to the new list. + * Save the pointer to the allocated object so it can be finalized. Grow + * the list of pointers if necessary, copying only non-NULL pointers to + * the new list. */ if (recPtr->num >= recPtr->max) { recPtr->max += 8; newList = (char **)ckalloc(recPtr->max * sizeof(char *)); for (i=0,j=0 ; inum ; i++) { - if (recPtr->list[i] != NULL) { + if (recPtr->list[i] != NULL) { newList[j++] = recPtr->list[i]; - } + } } if (recPtr->list != NULL) { ckfree((char *)recPtr->list); } recPtr->list = newList; @@ -255,11 +188,11 @@ /* *---------------------------------------------------------------------- * * ForgetSyncObject * - * Remove a single object from the list. + * Remove a single object from the list. * * Results: * None. * * Side effects: @@ -286,11 +219,11 @@ /* *---------------------------------------------------------------------- * * TclRememberMutex * - * Keep a list of mutexes used during finalization. + * Keep a list of mutexes used during finalization. * * Results: * None. * * Side effects: @@ -307,14 +240,14 @@ } /* *---------------------------------------------------------------------- * - * Tcl_MutexFinalize + * Tcl_MutexFinalize -- * - * Finalize a single mutex and remove it from the - * list of remembered objects. + * Finalize a single mutex and remove it from the list of remembered + * objects. * * Results: * None. * * Side effects: @@ -334,36 +267,13 @@ } /* *---------------------------------------------------------------------- * - * TclRememberDataKey - * - * Keep a list of thread data keys used during finalization. - * - * Results: - * None. - * - * Side effects: - * Add to the key list. - * - *---------------------------------------------------------------------- - */ - -void -TclRememberDataKey(keyPtr) - Tcl_ThreadDataKey *keyPtr; -{ - RememberSyncObject((char *)keyPtr, &keyRecord); -} - -/* - *---------------------------------------------------------------------- - * * TclRememberCondition * - * Keep a list of condition variables used during finalization. + * Keep a list of condition variables used during finalization. * * Results: * None. * * Side effects: @@ -380,14 +290,14 @@ } /* *---------------------------------------------------------------------- * - * Tcl_ConditionFinalize + * Tcl_ConditionFinalize -- * - * Finalize a single condition variable and remove it from the - * list of remembered objects. + * Finalize a single condition variable and remove it from the list of + * remembered objects. * * Results: * None. * * Side effects: @@ -409,12 +319,12 @@ /* *---------------------------------------------------------------------- * * TclFinalizeThreadData -- * - * This procedure cleans up the thread-local storage. This is - * called once for each thread. + * This function cleans up the thread-local storage. This is called once + * for each thread. * * Results: * None. * * Side effects: @@ -424,39 +334,20 @@ */ void TclFinalizeThreadData() { - int i; - Tcl_ThreadDataKey *keyPtr; - - TclpMasterLock(); - for (i=0 ; isourceBucket; if (bucket == NBUCKETS) { cachePtr->totalAssigned -= blockPtr->reqSize; free(blockPtr); return; } + cachePtr->buckets[bucket].totalAssigned -= blockPtr->reqSize; blockPtr->nextBlock = cachePtr->buckets[bucket].firstPtr; cachePtr->buckets[bucket].firstPtr = blockPtr; ++cachePtr->buckets[bucket].numFree; ++cachePtr->buckets[bucket].numInserts; + if (cachePtr != sharedPtr && cachePtr->buckets[bucket].numFree > bucketInfo[bucket].maxBlocks) { PutBlocks(cachePtr, bucket, bucketInfo[bucket].numMove); } } @@ -435,14 +432,13 @@ if (cachePtr == NULL) { cachePtr = GetCache(); } /* - * If the block is not a system block and fits in place, - * simply return the existing pointer. Otherwise, if the block - * is a system block and the new size would also require a system - * block, call realloc() directly. + * If the block is not a system block and fits in place, simply return the + * existing pointer. Otherwise, if the block is a system block and the new + * size would also require a system block, call realloc() directly. */ blockPtr = Ptr2Block(ptr); size = reqSize + sizeof(Block); #if RCHECK @@ -494,34 +490,34 @@ * * Results: * Pointer to uninitialized Tcl_Obj. * * Side effects: - * May move Tcl_Obj's from shared cached or allocate new Tcl_Obj's - * if list is empty. + * May move Tcl_Obj's from shared cached or allocate new Tcl_Obj's if + * list is empty. * *---------------------------------------------------------------------- */ Tcl_Obj * TclThreadAllocObj(void) { register Cache *cachePtr = TclpGetAllocCache(); - register int numMove; register Tcl_Obj *objPtr; - Tcl_Obj *newObjsPtr; if (cachePtr == NULL) { cachePtr = GetCache(); } /* - * Get this thread's obj list structure and move - * or allocate new objs if necessary. + * Get this thread's obj list structure and move or allocate new objs if + * necessary. */ if (cachePtr->numObjects == 0) { + register int numMove; + Tcl_MutexLock(objLockPtr); numMove = sharedPtr->numObjects; if (numMove > 0) { if (numMove > NOBJALLOC) { numMove = NOBJALLOC; @@ -528,10 +524,12 @@ } MoveObjs(sharedPtr, cachePtr, numMove); } Tcl_MutexUnlock(objLockPtr); if (cachePtr->numObjects == 0) { + Tcl_Obj *newObjsPtr; + cachePtr->numObjects = numMove = NOBJALLOC; newObjsPtr = malloc(sizeof(Tcl_Obj) * numMove); if (newObjsPtr == NULL) { Tcl_Panic("alloc: could not allocate %d new objects", numMove); } @@ -562,12 +560,11 @@ * * Results: * None. * * Side effects: - * May move free Tcl_Obj's to shared list upon hitting high - * water mark. + * May move free Tcl_Obj's to shared list upon hitting high water mark. * *---------------------------------------------------------------------- */ void @@ -587,12 +584,12 @@ objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr; cachePtr->firstObjPtr = objPtr; ++cachePtr->numObjects; /* - * If the number of free objects has exceeded the high - * water mark, move some blocks to the shared list. + * If the number of free objects has exceeded the high water mark, move + * some blocks to the shared list. */ if (cachePtr->numObjects > NOBJHIGH) { Tcl_MutexLock(objLockPtr); MoveObjs(cachePtr, sharedPtr, NOBJALLOC); @@ -677,23 +674,22 @@ toPtr->numObjects += numMove; fromPtr->numObjects -= numMove; /* - * Find the last object to be moved; set the next one - * (the first one not to be moved) as the first object - * in the 'from' cache. + * Find the last object to be moved; set the next one (the first one not + * to be moved) as the first object in the 'from' cache. */ while (--numMove) { objPtr = objPtr->internalRep.otherValuePtr; } fromPtr->firstObjPtr = objPtr->internalRep.otherValuePtr; /* - * Move all objects as a block - they are already linked to - * each other, we just have to update the first and last. + * Move all objects as a block - they are already linked to each other, we + * just have to update the first and last. */ objPtr->internalRep.otherValuePtr = toPtr->firstObjPtr; toPtr->firstObjPtr = fromFirstObjPtr; } @@ -762,12 +758,12 @@ * * Results: * None. * * Side effects: - * Lock activity and contention are monitored globally and on - * a per-cache basis. + * Lock activity and contention are monitored globally and on a per-cache + * basis. * *---------------------------------------------------------------------- */ static void @@ -819,12 +815,12 @@ { register Block *lastPtr, *firstPtr; register int n = numMove; /* - * Before acquiring the lock, walk the block list to find - * the last block to be moved. + * Before acquiring the lock, walk the block list to find the last block + * to be moved. */ firstPtr = lastPtr = cachePtr->buckets[bucket].firstPtr; while (--n > 0) { lastPtr = lastPtr->nextBlock; @@ -831,12 +827,12 @@ } cachePtr->buckets[bucket].firstPtr = lastPtr->nextBlock; cachePtr->buckets[bucket].numFree -= numMove; /* - * Aquire the lock and place the list of blocks at the front - * of the shared cache bucket. + * Aquire the lock and place the list of blocks at the front of the shared + * cache bucket. */ LockBucket(cachePtr, bucket); lastPtr->nextBlock = sharedPtr->buckets[bucket].firstPtr; sharedPtr->buckets[bucket].firstPtr = firstPtr; @@ -865,26 +861,25 @@ Cache *cachePtr; int bucket; { register Block *blockPtr; register int n; - register size_t size; /* - * First, atttempt to move blocks from the shared cache. Note - * the potentially dirty read of numFree before acquiring the lock - * which is a slight performance enhancement. The value is - * verified after the lock is actually acquired. + * First, atttempt to move blocks from the shared cache. Note the + * potentially dirty read of numFree before acquiring the lock which is a + * slight performance enhancement. The value is verified after the lock is + * actually acquired. */ if (cachePtr != sharedPtr && sharedPtr->buckets[bucket].numFree > 0) { LockBucket(cachePtr, bucket); if (sharedPtr->buckets[bucket].numFree > 0) { /* - * Either move the entire list or walk the list to find - * the last block to move. + * Either move the entire list or walk the list to find the last + * block to move. */ n = bucketInfo[bucket].numMove; if (n >= sharedPtr->buckets[bucket].numFree) { cachePtr->buckets[bucket].firstPtr = @@ -907,14 +902,15 @@ } UnlockBucket(cachePtr, bucket); } if (cachePtr->buckets[bucket].numFree == 0) { + register size_t size; /* - * If no blocks could be moved from shared, first look for a - * larger block in this cache to split up. + * If no blocks could be moved from shared, first look for a larger + * block in this cache to split up. */ blockPtr = NULL; n = NBUCKETS; size = 0; /* lint */ @@ -960,12 +956,12 @@ /* *---------------------------------------------------------------------- * * TclFinalizeThreadAlloc -- * - * This procedure is used to destroy all private resources used in - * this file. + * This procedure is used to destroy all private resources used in this + * file. * * Results: * None. * * Side effects: @@ -977,30 +973,31 @@ void TclFinalizeThreadAlloc() { int i; for (i = 0; i < NBUCKETS; ++i) { - TclpFreeAllocMutex(bucketInfo[i].lockPtr); + TclpFreeAllocMutex(bucketInfo[i].lockPtr); bucketInfo[i].lockPtr = NULL; } TclpFreeAllocMutex(objLockPtr); objLockPtr = NULL; TclpFreeAllocMutex(listLockPtr); listLockPtr = NULL; + + TclpFreeAllocCache(NULL); } #else - /* *---------------------------------------------------------------------- * * TclFinalizeThreadAlloc -- * - * This procedure is used to destroy all private resources used in - * this file. + * This procedure is used to destroy all private resources used in this + * file. * * Results: * None. * * Side effects: @@ -1012,7 +1009,14 @@ void TclFinalizeThreadAlloc() { Tcl_Panic("TclFinalizeThreadAlloc called when threaded memory allocator not in use."); } - #endif /* TCL_THREADS */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclThreadJoin.c ================================================================== --- generic/tclThreadJoin.c +++ generic/tclThreadJoin.c @@ -1,210 +1,211 @@ -/* +/* * tclThreadJoin.c -- * - * This file implements a platform independent emulation layer for - * the handling of joinable threads. The Windows platform - * uses this code to provide the functionality of joining threads. - * This code is currently not necessary on Unix. + * This file implements a platform independent emulation layer for the + * handling of joinable threads. The Windows platform uses this code to + * provide the functionality of joining threads. This code is currently + * not necessary on Unix. * * Copyright (c) 2000 by Scriptics Corporation * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclThreadJoin.c,v 1.5 2004/03/17 18:14:14 das Exp $ + * RCS: @(#) $Id: tclThreadJoin.c,v 1.5.2.1 2005/08/02 18:16:10 dgp Exp $ */ #include "tclInt.h" -#if defined(WIN32) +#ifdef WIN32 -/* The information about each joinable thread is remembered in a - * structure as defined below. +/* + * The information about each joinable thread is remembered in a structure as + * defined below. */ typedef struct JoinableThread { - Tcl_ThreadId id; /* The id of the joinable thread */ - int result; /* A place for the result after the - * demise of the thread */ - int done; /* Boolean flag. Initialized to 0 - * and set to 1 after the exit of - * the thread. This allows a thread - * requesting a join to detect when - * waiting is not necessary. */ - int waitedUpon; /* Boolean flag. Initialized to 0 - * and set to 1 by the thread waiting - * for this one via Tcl_JoinThread. - * Used to lock any other thread - * trying to wait on this one. - */ - Tcl_Mutex threadMutex; /* The mutex used to serialize access - * to this structure. */ - Tcl_Condition cond; /* This is the condition a thread has - * to wait upon to get notified of the - * end of the described thread. It is - * signaled indirectly by - * Tcl_ExitThread. */ - struct JoinableThread* nextThreadPtr; /* Reference to the next thread in the - * list of joinable threads */ + Tcl_ThreadId id; /* The id of the joinable thread. */ + int result; /* A place for the result after the demise of + * the thread. */ + int done; /* Boolean flag. Initialized to 0 and set to 1 + * after the exit of the thread. This allows a + * thread requesting a join to detect when + * waiting is not necessary. */ + int waitedUpon; /* Boolean flag. Initialized to 0 and set to 1 + * by the thread waiting for this one via + * Tcl_JoinThread. Used to lock any other + * thread trying to wait on this one. */ + Tcl_Mutex threadMutex; /* The mutex used to serialize access to this + * structure. */ + Tcl_Condition cond; /* This is the condition a thread has to wait + * upon to get notified of the end of the + * described thread. It is signaled indirectly + * by Tcl_ExitThread. */ + struct JoinableThread *nextThreadPtr; + /* Reference to the next thread in the list of + * joinable threads. */ } JoinableThread; -/* The following variable is used to maintain the global list of all - * joinable threads. Usage by a thread is allowed only if the - * thread acquired the 'joinMutex'. +/* + * The following variable is used to maintain the global list of all joinable + * threads. Usage by a thread is allowed only if the thread acquired the + * 'joinMutex'. */ TCL_DECLARE_MUTEX(joinMutex) static JoinableThread* firstThreadPtr; - - /* *---------------------------------------------------------------------- * * TclJoinThread -- * - * This procedure waits for the exit of the thread with the specified - * id and returns its result. + * This procedure waits for the exit of the thread with the specified id + * and returns its result. * * Results: * A standard tcl result signaling the overall success/failure of the * operation and an integer result delivered by the thread which was * waited upon. * * Side effects: * Deallocates the memory allocated by TclRememberJoinableThread. - * Removes the data associated to the thread waited upon from the - * list of joinable threads. + * Removes the data associated to the thread waited upon from the list of + * joinable threads. * *---------------------------------------------------------------------- */ int TclJoinThread(id, result) - Tcl_ThreadId id; /* The id of the thread to wait upon. */ - int* result; /* Reference to a location for the result - * of the thread we are waiting upon. */ + Tcl_ThreadId id; /* The id of the thread to wait upon. */ + int *result; /* Reference to a location for the result of + * the thread we are waiting upon. */ { - /* Steps done here: + JoinableThread *threadPtr; + + /* + * Steps done here: * i. Acquire the joinMutex and search for the thread. * ii. Error out if it could not be found. * iii. If found, switch from exclusive access to the list to exclusive - * access to the thread structure. + * access to the thread structure. * iv. Error out if some other is already waiting. * v. Skip the waiting part of the thread is already done. * vi. Wait for the thread to exit, mark it as waited upon too. - * vii. Get the result form the structure, + * vii. Get the result form the structure, * viii. switch to exclusive access of the list, * ix. remove the structure from the list, * x. then switch back to exclusive access to the structure * xi. and delete it. */ - JoinableThread* threadPtr; - - Tcl_MutexLock (&joinMutex); - - for (threadPtr = firstThreadPtr; - (threadPtr != (JoinableThread*) NULL) && (threadPtr->id != id); - threadPtr = threadPtr->nextThreadPtr) - /* empty body */ - ; - - if (threadPtr == (JoinableThread*) NULL) { - /* Thread not found. Either not joinable, or already waited - * upon and exited. Whatever, an error is in order. - */ - - Tcl_MutexUnlock (&joinMutex); - return TCL_ERROR; - } - - /* [1] If we don't lock the structure before giving up exclusive access - * to the list some other thread just completing its wait on the same - * thread can delete the structure from under us, leaving us with a - * dangling pointer. - */ - - Tcl_MutexLock (&threadPtr->threadMutex); - Tcl_MutexUnlock (&joinMutex); - - /* [2] Now that we have the structure mutex any other thread that just - * tries to delete structure will wait at location [3] until we are - * done with the structure. And in that case we are done with it - * rather quickly as 'waitedUpon' will be set and we will have to - * error out. + Tcl_MutexLock(&joinMutex); + + threadPtr = firstThreadPtr; + while (threadPtr!=NULL && threadPtr->id!=id) { + threadPtr = threadPtr->nextThreadPtr; + } + + if (threadPtr == NULL) { + /* + * Thread not found. Either not joinable, or already waited upon and + * exited. Whatever, an error is in order. + */ + + Tcl_MutexUnlock(&joinMutex); + return TCL_ERROR; + } + + /* + * [1] If we don't lock the structure before giving up exclusive access to + * the list some other thread just completing its wait on the same thread + * can delete the structure from under us, leaving us with a dangling + * pointer. + */ + + Tcl_MutexLock(&threadPtr->threadMutex); + Tcl_MutexUnlock(&joinMutex); + + /* + * [2] Now that we have the structure mutex any other thread that just + * tries to delete structure will wait at location [3] until we are done + * with the structure. And in that case we are done with it rather quickly + * as 'waitedUpon' will be set and we will have to error out. */ if (threadPtr->waitedUpon) { - Tcl_MutexUnlock (&threadPtr->threadMutex); + Tcl_MutexUnlock(&threadPtr->threadMutex); return TCL_ERROR; } - /* We are waiting now, let other threads recognize this + /* + * We are waiting now, let other threads recognize this. */ threadPtr->waitedUpon = 1; while (!threadPtr->done) { - Tcl_ConditionWait (&threadPtr->cond, &threadPtr->threadMutex, NULL); + Tcl_ConditionWait(&threadPtr->cond, &threadPtr->threadMutex, NULL); } - /* We have to release the structure before trying to access the list - * again or we can run into deadlock with a thread at [1] (see above) - * because of us holding the structure and the other holding the list. - * There is no problem with dangling pointers here as 'waitedUpon == 1' - * is still valid and any other thread will error out and not come to - * this place. IOW, the fact that we are here also means that no other - * thread came here before us and is able to delete the structure. + /* + * We have to release the structure before trying to access the list again + * or we can run into deadlock with a thread at [1] (see above) because of + * us holding the structure and the other holding the list. There is no + * problem with dangling pointers here as 'waitedUpon == 1' is still valid + * and any other thread will error out and not come to this place. IOW, + * the fact that we are here also means that no other thread came here + * before us and is able to delete the structure. */ - Tcl_MutexUnlock (&threadPtr->threadMutex); - Tcl_MutexLock (&joinMutex); + Tcl_MutexUnlock(&threadPtr->threadMutex); + Tcl_MutexLock(&joinMutex); - /* We have to search the list again as its structure may (may, almost + /* + * We have to search the list again as its structure may (may, almost * certainly) have changed while we were waiting. Especially now is the - * time to compute the predecessor in the list. Any earlier result can - * be dangling by now. + * time to compute the predecessor in the list. Any earlier result can be + * dangling by now. */ if (firstThreadPtr == threadPtr) { - firstThreadPtr = threadPtr->nextThreadPtr; + firstThreadPtr = threadPtr->nextThreadPtr; } else { - JoinableThread* prevThreadPtr; - - for (prevThreadPtr = firstThreadPtr; - prevThreadPtr->nextThreadPtr != threadPtr; - prevThreadPtr = prevThreadPtr->nextThreadPtr) - /* empty body */ - ; - + JoinableThread *prevThreadPtr = firstThreadPtr; + + while (prevThreadPtr->nextThreadPtr != threadPtr) { + prevThreadPtr = prevThreadPtr->nextThreadPtr; + } prevThreadPtr->nextThreadPtr = threadPtr->nextThreadPtr; } - Tcl_MutexUnlock (&joinMutex); + Tcl_MutexUnlock(&joinMutex); - /* [3] Now that the structure is not part of the list anymore no other + /* + * [3] Now that the structure is not part of the list anymore no other * thread can acquire its mutex from now on. But it is possible that - * another thread is still holding the mutex though, see location [2]. - * So we have to acquire the mutex one more time to wait for that thread - * to finish. We can (and have to) release the mutex immediately. + * another thread is still holding the mutex though, see location [2]. So + * we have to acquire the mutex one more time to wait for that thread to + * finish. We can (and have to) release the mutex immediately. */ - Tcl_MutexLock (&threadPtr->threadMutex); - Tcl_MutexUnlock (&threadPtr->threadMutex); + Tcl_MutexLock(&threadPtr->threadMutex); + Tcl_MutexUnlock(&threadPtr->threadMutex); - /* Copy the result to us, finalize the synchronisation objects, then - * free the structure and return. + /* + * Copy the result to us, finalize the synchronisation objects, then free + * the structure and return. */ *result = threadPtr->result; - Tcl_ConditionFinalize (&threadPtr->cond); - Tcl_MutexFinalize (&threadPtr->threadMutex); - ckfree ((VOID*) threadPtr); + Tcl_ConditionFinalize(&threadPtr->cond); + Tcl_MutexFinalize(&threadPtr->threadMutex); + ckfree((char *) threadPtr); return TCL_OK; } /* @@ -211,53 +212,51 @@ *---------------------------------------------------------------------- * * TclRememberJoinableThread -- * * This procedure remebers a thread as joinable. Only a call to - * TclJoinThread will remove the structre created (and initialized) - * here. IOW, not waiting upon a joinable thread will cause memory - * leaks. + * TclJoinThread will remove the structre created (and initialized) here. + * IOW, not waiting upon a joinable thread will cause memory leaks. * * Results: * None. * * Side effects: - * Allocates memory, adds it to the global list of all joinable - * threads. + * Allocates memory, adds it to the global list of all joinable threads. * *---------------------------------------------------------------------- */ VOID TclRememberJoinableThread(id) Tcl_ThreadId id; /* The thread to remember as joinable */ { - JoinableThread* threadPtr; + JoinableThread *threadPtr; - threadPtr = (JoinableThread*) ckalloc (sizeof (JoinableThread)); - threadPtr->id = id; - threadPtr->done = 0; - threadPtr->waitedUpon = 0; + threadPtr = (JoinableThread *) ckalloc(sizeof(JoinableThread)); + threadPtr->id = id; + threadPtr->done = 0; + threadPtr->waitedUpon = 0; threadPtr->threadMutex = (Tcl_Mutex) NULL; - threadPtr->cond = (Tcl_Condition) NULL; + threadPtr->cond = (Tcl_Condition) NULL; - Tcl_MutexLock (&joinMutex); + Tcl_MutexLock(&joinMutex); threadPtr->nextThreadPtr = firstThreadPtr; - firstThreadPtr = threadPtr; + firstThreadPtr = threadPtr; - Tcl_MutexUnlock (&joinMutex); + Tcl_MutexUnlock(&joinMutex); } /* *---------------------------------------------------------------------- * * TclSignalExitThread -- * - * This procedure signals that the specified thread is done with - * its work. If the thread is joinable this signal is propagated - * to the thread waiting upon it. + * This procedure signals that the specified thread is done with its + * work. If the thread is joinable this signal is propagated to the + * thread waiting upon it. * * Results: * None. * * Side effects: @@ -266,46 +265,54 @@ *---------------------------------------------------------------------- */ VOID TclSignalExitThread(id,result) - Tcl_ThreadId id; /* Id of the thread signaling its exit */ - int result; /* The result from the thread */ -{ - JoinableThread* threadPtr; - - Tcl_MutexLock (&joinMutex); - - for (threadPtr = firstThreadPtr; - (threadPtr != (JoinableThread*) NULL) && (threadPtr->id != id); - threadPtr = threadPtr->nextThreadPtr) - /* empty body */ - ; - - if (threadPtr == (JoinableThread*) NULL) { - /* Thread not found. Not joinable. No problem, nothing to do. + Tcl_ThreadId id; /* Id of the thread signaling its exit. */ + int result; /* The result from the thread. */ +{ + JoinableThread *threadPtr; + + Tcl_MutexLock(&joinMutex); + + threadPtr = firstThreadPtr; + while ((threadPtr != NULL) && (threadPtr->id != id)) { + threadPtr = threadPtr->nextThreadPtr; + } + + if (threadPtr == NULL) { + /* + * Thread not found. Not joinable. No problem, nothing to do. */ - Tcl_MutexUnlock (&joinMutex); + Tcl_MutexUnlock(&joinMutex); return; } - /* Switch over the exclusive access from the list to the structure, - * then store the result, set the flag and notify the waiting thread, - * provided that it exists. The order of lock/unlock ensures that a - * thread entering 'TclJoinThread' will not interfere with us. + /* + * Switch over the exclusive access from the list to the structure, then + * store the result, set the flag and notify the waiting thread, provided + * that it exists. The order of lock/unlock ensures that a thread entering + * 'TclJoinThread' will not interfere with us. */ - Tcl_MutexLock (&threadPtr->threadMutex); - Tcl_MutexUnlock (&joinMutex); + Tcl_MutexLock(&threadPtr->threadMutex); + Tcl_MutexUnlock(&joinMutex); - threadPtr->done = 1; + threadPtr->done = 1; threadPtr->result = result; if (threadPtr->waitedUpon) { - Tcl_ConditionNotify (&threadPtr->cond); + Tcl_ConditionNotify(&threadPtr->cond); } - Tcl_MutexUnlock (&threadPtr->threadMutex); + Tcl_MutexUnlock(&threadPtr->threadMutex); } - #endif /* WIN32 */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclThreadStorage.c ================================================================== --- generic/tclThreadStorage.c +++ generic/tclThreadStorage.c @@ -3,59 +3,60 @@ * * This file implements platform independent thread storage operations. * * Copyright (c) 2003-2004 by Joe Mistachkin * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclThreadStorage.c,v 1.4 2004/06/24 09:05:46 dkf Exp $ + * RCS: @(#) $Id: tclThreadStorage.c,v 1.4.4.2 2005/08/15 18:13:59 dgp Exp $ */ #include "tclInt.h" -#if defined(TCL_THREADS) && defined(USE_THREAD_STORAGE) +#if defined(TCL_THREADS) /* - * This is the thread storage cache array and it's accompanying mutex. - * The elements are pairs of thread Id and an associated hash table - * pointer; the hash table being pointed to contains the thread storage - * for it's associated thread. The purpose of this cache is to minimize - * the number of hash table lookups in the master thread storage hash - * table. + * This is the thread storage cache array and it's accompanying mutex. The + * elements are pairs of thread Id and an associated hash table pointer; the + * hash table being pointed to contains the thread storage for it's associated + * thread. The purpose of this cache is to minimize the number of hash table + * lookups in the master thread storage hash table. */ static Tcl_Mutex threadStorageLock; /* - * This is the struct used for a thread storage cache slot. It contains - * the owning thread Id and the associated hash table pointer. + * This is the struct used for a thread storage cache slot. It contains the + * owning thread Id and the associated hash table pointer. */ typedef struct ThreadStorage { - Tcl_ThreadId id; /* the owning thread id */ - Tcl_HashTable *hashTablePtr; /* the hash table for the thread */ + Tcl_ThreadId id; /* the owning thread id */ + Tcl_HashTable *hashTablePtr;/* the hash table for the thread */ } ThreadStorage; /* - * These are the prototypes for the custom hash table allocation - * functions used by the thread storage subsystem. + * These are the prototypes for the custom hash table allocation functions + * used by the thread storage subsystem. */ -static Tcl_HashEntry * AllocThreadStorageEntry _ANSI_ARGS_(( - Tcl_HashTable *tablePtr, void *keyPtr)); -static void FreeThreadStorageEntry _ANSI_ARGS_(( - Tcl_HashEntry *hPtr)); +static Tcl_HashEntry * AllocThreadStorageEntry(Tcl_HashTable *tablePtr, + void *keyPtr); +static void FreeThreadStorageEntry(Tcl_HashEntry *hPtr); +static Tcl_HashTable * ThreadStorageGetHashTable(Tcl_ThreadId id); /* * This is the hash key type for thread storage. We MUST use this in * combination with the new hash key type flag TCL_HASH_KEY_SYSTEM_HASH * because these hash tables MAY be used by the threaded memory allocator. */ + Tcl_HashKeyType tclThreadStorageHashKeyType = { TCL_HASH_KEY_TYPE_VERSION, /* version */ - TCL_HASH_KEY_SYSTEM_HASH, /* flags */ + TCL_HASH_KEY_SYSTEM_HASH | TCL_HASH_KEY_RANDOMIZE_HASH, + /* flags */ NULL, /* hashKeyProc */ NULL, /* compareKeysProc */ AllocThreadStorageEntry, /* allocEntryProc */ FreeThreadStorageEntry /* freeEntryProc */ }; @@ -71,142 +72,53 @@ */ #define STORAGE_INVALID_KEY 0 /* - * This is the first valid key for use by external callers. - * All the values below this are RESERVED for future use. + * This is the first valid key for use by external callers. All the values + * below this are RESERVED for future use. */ -#define STORAGE_FIRST_KEY 101 +#define STORAGE_FIRST_KEY 1 /* - * This is the default number of thread storage cache slots. - * This define may need to be fine tuned for maximum performance. + * This is the default number of thread storage cache slots. This define may + * need to be fine tuned for maximum performance. */ #define STORAGE_CACHE_SLOTS 97 /* - * This is the master thread storage hash table. It is keyed on - * thread Id and contains values that are hash tables for each thread. - * The thread specific hash tables contain the actual thread storage. + * This is the master thread storage hash table. It is keyed on thread Id and + * contains values that are hash tables for each thread. The thread specific + * hash tables contain the actual thread storage. */ -static Tcl_HashTable *threadStorageHashTablePtr = NULL; +static Tcl_HashTable threadStorageHashTable; /* - * This is the next thread data key value to use. We increment this - * everytime we "allocate" one. It is initially set to 1 in - * TclThreadStorageInit. + * This is the next thread data key value to use. We increment this everytime + * we "allocate" one. It is initially set to 1 in TclInitThreadStorage. */ static int nextThreadStorageKey = STORAGE_INVALID_KEY; /* - * Have we initialized the thread storage mutex yet? - */ - -static int initThreadStorage = 0; - -/* - * This is the master thread storage cache. Per kennykb's idea, this - * prevents unnecessary lookups for threads that use a lot of thread - * storage. + * This is the master thread storage cache. Per Kevin Kenny's idea, this + * prevents unnecessary lookups for threads that use a lot of thread storage. */ static volatile ThreadStorage threadStorageCache[STORAGE_CACHE_SLOTS]; /* *---------------------------------------------------------------------- * - * TclThreadStorageLockInit - * - * This procedure is used to initialize the lock that serializes - * creation of thread storage. - * - * Results: - * None. - * - * Side effects: - * The master lock is acquired and possibly initialized for the - * first time. - * - *---------------------------------------------------------------------- - */ - -void -TclThreadStorageLockInit() -{ - if (!initThreadStorage) { - /* - * Mutexes in Tcl are self initializing, and we are taking - * advantage of that fact since this file cannot contain - * platform specific calls. - */ - initThreadStorage = 1; - } -} - -/* - *---------------------------------------------------------------------- - * - * TclThreadStorageLock - * - * This procedure is used to grab a lock that serializes creation - * of thread storage. - * - * This lock must be different than the initLock because the - * initLock is held during creation of syncronization objects. - * - * Results: - * None. - * - * Side effects: - * Acquire the thread storage mutex. - * - *---------------------------------------------------------------------- - */ - -void -TclThreadStorageLock() -{ - TclThreadStorageLockInit(); - Tcl_MutexLock(&threadStorageLock); -} - -/* - *---------------------------------------------------------------------- - * - * TclThreadStorageUnlock - * - * This procedure is used to release a lock that serializes creation - * of thread storage. - * - * Results: - * None. - * - * Side effects: - * Release the thread storage mutex. - * - *---------------------------------------------------------------------- - */ - -void -TclThreadStorageUnlock() -{ - Tcl_MutexUnlock(&threadStorageLock); -} - -/* - *---------------------------------------------------------------------- - * * AllocThreadStorageEntry -- * - * Allocate space for a Tcl_HashEntry using TclpSysAlloc (not - * ckalloc). We do this because the threaded memory allocator MAY - * use the thread storage hash tables. + * Allocate space for a Tcl_HashEntry using TclpSysAlloc (not ckalloc). + * We do this because the threaded memory allocator MAY use the thread + * storage hash tables. * * Results: * The return value is a pointer to the created entry. * * Side effects: @@ -231,13 +143,13 @@ /* *---------------------------------------------------------------------- * * FreeThreadStorageEntry -- * - * Frees space for a Tcl_HashEntry using TclpSysFree (not ckfree). - * We do this because the threaded memory allocator MAY use the - * thread storage hash tables. + * Frees space for a Tcl_HashEntry using TclpSysFree (not ckfree). We do + * this because the threaded memory allocator MAY use the thread storage + * hash tables. * * Results: * None. * * Side effects: @@ -254,525 +166,328 @@ } /* *---------------------------------------------------------------------- * - * TclThreadStoragePrint -- - * - * This procedure prints out the contents of the master thread - * storage hash table, the thread storage cache, and the next key - * value to the specified file. - * - * This assumes that thread storage lock is held. - * - * Results: - * None. - * - * Side effects: - * The thread storage lock is acquired and released. - * - *---------------------------------------------------------------------- - */ - -void -TclThreadStoragePrint(outFile, flags) - FILE *outFile; /* The file to print the information to. */ - int flags; /* Reserved for future use. */ -{ - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - int header, index; - - if (threadStorageHashTablePtr != NULL) { - hPtr = Tcl_FirstHashEntry(threadStorageHashTablePtr, &search); - - if (hPtr != NULL) { - fprintf(outFile, "master thread storage hash table:\n"); - for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - fprintf(outFile, - "master entry ptr %p, thread %p, thread table ptr %p\n", - hPtr, Tcl_GetHashKey(threadStorageHashTablePtr, hPtr), - Tcl_GetHashValue(hPtr)); - } - } else { - fprintf(outFile, - "master thread storage hash table has no entries\n"); - } - } else { - fprintf(outFile, - "master thread storage hash table not initialized\n"); - } - - header = 0; /* we have not output the header yet. */ - for (index = 0; index < STORAGE_CACHE_SLOTS; index++) { - if (threadStorageCache[index].id != STORAGE_INVALID_THREAD) { - if (!header) { - fprintf(outFile, "thread storage cache (%d total slots):\n", - STORAGE_CACHE_SLOTS); - header = 1; - } - - fprintf(outFile, "slot %d, thread %p, thread table ptr %p\n", - index, threadStorageCache[index].id, - threadStorageCache[index].hashTablePtr); -#ifdef VERBOSE_THREAD_STORAGE_DEBUGGING - /* - * Currently not enabled by default due to Tcl_HashStats - * use of ckalloc and ckfree. Please note that this can - * produce a LOT of output. - */ - if (threadStorageCache[index].hashTablePtr != NULL) { - CONST char *stats = - Tcl_HashStats(threadStorageCache[index].hashTablePtr); - if (stats != NULL) { - fprintf(outFile, "%s\n", stats); - ckfree((void *)stats); - } else { - fprintf(outFile, - "could not get table statistics for slot %d\n", - index); - } - } -#endif - } else { - /* fprintf(outFile, "cache slot %d not used\n", index); */ - } - } - - if (!header) { - fprintf(outFile, "thread storage cache is empty (%d total slots)\n", - STORAGE_CACHE_SLOTS); - header = 1; - } - - /* - * Show the next data key value. - */ - - fprintf(outFile, "next data key value is: %d\n", nextThreadStorageKey); -} - -/* - *---------------------------------------------------------------------- - * - * TclThreadStorageGetHashTable -- + * ThreadStorageGetHashTable -- * * This procedure returns a hash table pointer to be used for thread * storage for the specified thread. * * This assumes that thread storage lock is held. * * Results: - * A hash table pointer for the specified thread, or NULL - * if the hash table has not been created yet. + * A hash table pointer for the specified thread, or NULL if the hash + * table has not been created yet. * * Side effects: - * May change an entry in the master thread storage cache to point - * to the specified thread and it's associated hash table. + * May change an entry in the master thread storage cache to point to the + * specified thread and it's associated hash table. * *---------------------------------------------------------------------- */ -Tcl_HashTable * -TclThreadStorageGetHashTable(id) +static Tcl_HashTable * +ThreadStorageGetHashTable(id) Tcl_ThreadId id; /* Id of thread to get hash table for */ { int index = (unsigned int)id % STORAGE_CACHE_SLOTS; Tcl_HashEntry *hPtr; int new; /* - * It's important that we pick up the hash table pointer BEFORE - * comparing thread Id in case another thread is in the critical - * region changing things out from under you. + * It's important that we pick up the hash table pointer BEFORE comparing + * thread Id in case another thread is in the critical region changing + * things out from under you. */ Tcl_HashTable *hashTablePtr = threadStorageCache[index].hashTablePtr; if (threadStorageCache[index].id != id) { - TclThreadStorageLock(); - - /* - * Make sure the master hash table is initialized. - */ - - TclThreadStorageInit(STORAGE_INVALID_THREAD, NULL); - - if (threadStorageHashTablePtr != NULL) { - /* - * It's not in the cache, so we look it up... - */ - - hPtr = Tcl_FindHashEntry(threadStorageHashTablePtr, (char *)id); - - if (hPtr != NULL) { - /* - * We found it, extract the hash table pointer. - */ - hashTablePtr = Tcl_GetHashValue(hPtr); - } else { - /* - * The thread specific hash table is not found. - */ - hashTablePtr = NULL; - } - - if (hashTablePtr == NULL) { - hashTablePtr = (Tcl_HashTable *) - TclpSysAlloc(sizeof(Tcl_HashTable), 0); - - if (hashTablePtr == NULL) { - Tcl_Panic("could not allocate thread specific hash " - "table, TclpSysAlloc failed from " - "TclThreadStorageGetHashTable!"); - } - Tcl_InitCustomHashTable(hashTablePtr, TCL_CUSTOM_TYPE_KEYS, - &tclThreadStorageHashKeyType); - - /* - * Add new thread storage hash table to the master - * hash table. - */ - - hPtr = Tcl_CreateHashEntry(threadStorageHashTablePtr, - (char *)id, &new); - - if (hPtr == NULL) { - Tcl_Panic("Tcl_CreateHashEntry failed from " - "TclThreadStorageInit!"); - } - Tcl_SetHashValue(hPtr, hashTablePtr); - } - - /* - * Now, we put it in the cache since it is highly likely - * it will be needed again shortly. - */ - - threadStorageCache[index].id = id; - threadStorageCache[index].hashTablePtr = hashTablePtr; - } else { - /* - * We cannot look it up, the master hash table has not - * been initialized. - */ - hashTablePtr = NULL; - } - TclThreadStorageUnlock(); + Tcl_MutexLock(&threadStorageLock); + + /* + * It's not in the cache, so we look it up... + */ + + hPtr = Tcl_FindHashEntry(&threadStorageHashTable, (char *)id); + + if (hPtr != NULL) { + /* + * We found it, extract the hash table pointer. + */ + + hashTablePtr = Tcl_GetHashValue(hPtr); + } else { + /* + * The thread specific hash table is not found. + */ + + hashTablePtr = NULL; + } + + if (hashTablePtr == NULL) { + hashTablePtr = (Tcl_HashTable *) + TclpSysAlloc(sizeof(Tcl_HashTable), 0); + + if (hashTablePtr == NULL) { + Tcl_Panic("could not allocate thread specific hash " + "table, TclpSysAlloc failed from " + "ThreadStorageGetHashTable!"); + } + Tcl_InitCustomHashTable(hashTablePtr, TCL_CUSTOM_TYPE_KEYS, + &tclThreadStorageHashKeyType); + + /* + * Add new thread storage hash table to the master hash table. + */ + + hPtr = Tcl_CreateHashEntry(&threadStorageHashTable, + (char *)id, &new); + + if (hPtr == NULL) { + Tcl_Panic("Tcl_CreateHashEntry failed from " + "ThreadStorageGetHashTable!"); + } + Tcl_SetHashValue(hPtr, hashTablePtr); + } + + /* + * Now, we put it in the cache since it is highly likely it will + * be needed again shortly. + */ + + threadStorageCache[index].id = id; + threadStorageCache[index].hashTablePtr = hashTablePtr; + + Tcl_MutexUnlock(&threadStorageLock); } return hashTablePtr; } /* *---------------------------------------------------------------------- * - * TclThreadStorageInit -- - * - * This procedure initializes a thread specific hash table for the - * current thread. It may also initialize the master hash table which - * stores all the thread specific hash tables. - * - * This assumes that thread storage lock is held. - * - * Results: - * A hash table pointer for the specified thread, or NULL if we are - * be called to initialize the master hash table only. - * - * Side effects: - * The thread specific hash table may be initialized and added to the - * master hash table. - * - *---------------------------------------------------------------------- - */ - -Tcl_HashTable * -TclThreadStorageInit(id, reserved) - Tcl_ThreadId id; /* Id of thread to get hash table for */ - void *reserved; /* reserved for future use */ -{ -#if 0 /* #ifdef TCL_THREAD_STORAGE_DEBUG */ - TclThreadStoragePrint(stderr, 0); -#endif - - if (threadStorageHashTablePtr == NULL) { - /* - * Looks like we haven't created the outer hash table yet we - * can just do that now. - */ - - threadStorageHashTablePtr = (Tcl_HashTable *) - TclpSysAlloc(sizeof(Tcl_HashTable), 0); - if (threadStorageHashTablePtr == NULL) { - Tcl_Panic("could not allocate master thread storage hash table, " - "TclpSysAlloc failed from TclThreadStorageInit!"); - } - Tcl_InitCustomHashTable(threadStorageHashTablePtr, - TCL_CUSTOM_TYPE_KEYS, &tclThreadStorageHashKeyType); - - /* - * We also initialize the cache. - */ - - memset((ThreadStorage *)&threadStorageCache, 0, - sizeof(ThreadStorage) * STORAGE_CACHE_SLOTS); - - /* - * Now, we set the first value to be used for a thread data key. - */ - - nextThreadStorageKey = STORAGE_FIRST_KEY; - } - - return NULL; -} - -/* - *---------------------------------------------------------------------- - * - * TclThreadStorageDataKeyInit -- - * - * This procedure initializes a thread specific data block key. - * Each thread has table of pointers to thread specific data. - * all threads agree on which table entry is used by each module. - * this is remembered in a "data key", that is just an index into - * this table. To allow self initialization, the interface - * passes a pointer to this key and the first thread to use - * the key fills in the pointer to the key. The key should be - * a process-wide static. - * - * Results: - * None. - * - * Side effects: - * Will allocate memory the first time this process calls for - * this key. In this case it modifies its argument - * to hold the pointer to information about the key. - * - *---------------------------------------------------------------------- - */ - -void -TclThreadStorageDataKeyInit(keyPtr) - Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, - * really (int **) */ -{ - int *indexPtr; - int newKey; - - if (*keyPtr == NULL) { - indexPtr = (int *)TclpSysAlloc(sizeof(int), 0); - if (indexPtr == NULL) { - Tcl_Panic("TclpSysAlloc failed from TclThreadStorageDataKeyInit!"); - } - - /* - * We must call this now to make sure that - * nextThreadStorageKey has a well defined value. - */ - - TclThreadStorageLock(); - - /* - * Make sure the master hash table is initialized. - */ - - TclThreadStorageInit(STORAGE_INVALID_THREAD, NULL); - - /* - * These data key values are sequentially assigned and we must - * use the storage lock to prevent serious problems here. - * Also note that the caller should NOT make any assumptions - * about the provided values. In particular, we may need to - * reserve some values in the future. - */ - - newKey = nextThreadStorageKey++; - TclThreadStorageUnlock(); - - *indexPtr = newKey; - *keyPtr = (Tcl_ThreadDataKey)indexPtr; - TclRememberDataKey(keyPtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclThreadStorageDataKeyGet -- - * - * This procedure returns a pointer to a block of thread local storage. - * - * Results: - * A thread-specific pointer to the data structure, or NULL - * if the memory has not been assigned to this key for this thread. + * TclInitThreadStorage -- + * + * Initializes the thread storage allocator. + * + * Results: + * None. + * + * Side effects: + * This procedure initializes the master hash table that maps + * thread ID onto the individual index tables that map thread data + * key to thread data. It also creates a cache that enables + * fast lookup of the thread data block array for a recently + * executing thread without using spinlocks. + * + * This procedure is called from an extremely early point in Tcl's + * initialization. In particular, it may not use ckalloc/ckfree + * because they may depend on thread-local storage (it uses TclpSysAlloc + * and TclpSysFree instead). It may not depend on synchronization + * primitives - but no threads other than the master thread have yet + * been launched. + * + *---------------------------------------------------------------------- + */ + +void +TclInitThreadStorage() +{ + + Tcl_InitCustomHashTable(&threadStorageHashTable, + TCL_CUSTOM_TYPE_KEYS, &tclThreadStorageHashKeyType); + + /* + * We also initialize the cache. + */ + + memset((ThreadStorage *)&threadStorageCache, 0, + sizeof(ThreadStorage) * STORAGE_CACHE_SLOTS); + + /* + * Now, we set the first value to be used for a thread data key. + */ + + nextThreadStorageKey = STORAGE_FIRST_KEY; +} + +/* + *---------------------------------------------------------------------- + * + * TclpThreadDataKeyGet -- + * + * This procedure returns a pointer to a block of thread local storage. + * + * Results: + * A thread-specific pointer to the data structure, or NULL if the memory + * has not been assigned to this key for this thread. * * Side effects: * None. * *---------------------------------------------------------------------- */ void * -TclThreadStorageDataKeyGet(keyPtr) - Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, - * really (int **) */ -{ - int *indexPtr = *(int **)keyPtr; - - if (indexPtr == NULL) { - return NULL; - } else { - Tcl_HashTable *hashTablePtr = - TclThreadStorageGetHashTable(Tcl_GetCurrentThread()); - Tcl_HashEntry *hPtr; - - if (hashTablePtr == NULL) { - Tcl_Panic("TclThreadStorageGetHashTable failed from " - "TclThreadStorageDataKeyGet!"); - } - - hPtr = Tcl_FindHashEntry(hashTablePtr, (char *)*indexPtr); - - if (hPtr == NULL) { - return NULL; - } - return (void *)Tcl_GetHashValue(hPtr); - } +TclpThreadDataKeyGet(keyPtr) + Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, really + * (int**) */ +{ + Tcl_HashTable *hashTablePtr = + ThreadStorageGetHashTable(Tcl_GetCurrentThread()); + Tcl_HashEntry *hPtr = + Tcl_FindHashEntry(hashTablePtr, (char *) keyPtr); + if (hPtr == NULL) { + return NULL; + } + return (void *) Tcl_GetHashValue(hPtr); } /* *---------------------------------------------------------------------- * - * TclThreadStorageDataKeySet -- + * TclpThreadDataKeySet -- * * This procedure sets the pointer to a block of thread local storage. * * Results: * None. * * Side effects: - * Sets up the thread so future calls to TclThreadStorageDataKeyGet - * with this key will return the data pointer. + * Sets up the thread so future calls to TclpThreadDataKeyGet with + * this key will return the data pointer. * *---------------------------------------------------------------------- */ void -TclThreadStorageDataKeySet(keyPtr, data) - Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, - * really (pthread_key_t **) */ +TclpThreadDataKeySet(keyPtr, data) + Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, really + * (pthread_key_t **) */ void *data; /* Thread local storage */ { - int *indexPtr = *(int **)keyPtr; Tcl_HashTable *hashTablePtr; Tcl_HashEntry *hPtr; - hashTablePtr = TclThreadStorageGetHashTable(Tcl_GetCurrentThread()); - if (hashTablePtr == NULL) { - Tcl_Panic("TclThreadStorageGetHashTable failed from " - "TclThreadStorageDataKeySet!"); - } - - hPtr = Tcl_FindHashEntry(hashTablePtr, (char *)*indexPtr); + hashTablePtr = ThreadStorageGetHashTable(Tcl_GetCurrentThread()); + hPtr = Tcl_FindHashEntry(hashTablePtr, (char *)keyPtr); /* * Does the item need to be created? */ + if (hPtr == NULL) { int new; - hPtr = Tcl_CreateHashEntry(hashTablePtr, (char *)*indexPtr, &new); - if (hPtr == NULL) { - Tcl_Panic("could not create hash entry value from " - "TclThreadStorageDataKeySet"); - } + hPtr = Tcl_CreateHashEntry(hashTablePtr, (char *)keyPtr, &new); } Tcl_SetHashValue(hPtr, data); } /* *---------------------------------------------------------------------- * - * TclFinalizeThreadStorageThread -- + * TclpFinalizeThreadDataThread -- * * This procedure cleans up the thread storage hash table for the - * specified thread. + * current thread. * * Results: * None. * * Side effects: - * None. + * Frees all associated thread storage, all hash table entries for + * the thread's thread storage, and the hash table itself. * *---------------------------------------------------------------------- */ void -TclFinalizeThreadStorageThread(id) - Tcl_ThreadId id; /* Id of the thread to finalize */ -{ - int index = (unsigned int)id % STORAGE_CACHE_SLOTS; - Tcl_HashTable *hashTablePtr; /* Hash table for current thread */ - Tcl_HashEntry *hPtr; /* Hash entry for current thread in master - * table */ - - TclThreadStorageLock(); - - if (threadStorageHashTablePtr != NULL) { - hPtr = Tcl_FindHashEntry(threadStorageHashTablePtr, (char *)id); - - if (hPtr != NULL) { - /* - * We found it, extract the hash table pointer. - */ - - hashTablePtr = Tcl_GetHashValue(hPtr); - - if (hashTablePtr != NULL) { - /* - * Delete thread specific hash table and free the - * struct. - */ - - Tcl_DeleteHashTable(hashTablePtr); - TclpSysFree((char *)hashTablePtr); - } - - /* - * Delete thread specific entry from master hash table. - */ - - Tcl_DeleteHashEntry(hPtr); - } - } - - /* - * Make sure cache entry for this thread is NULL. - */ - - if (threadStorageCache[index].id == id) { - /* - * We do not step on another thread's cache entry. This is - * especially important if we are creating and exiting a lot - * of threads. - */ - - threadStorageCache[index].id = STORAGE_INVALID_THREAD; - threadStorageCache[index].hashTablePtr = NULL; - } - - TclThreadStorageUnlock(); +TclpFinalizeThreadDataThread() +{ + Tcl_ThreadId id = Tcl_GetCurrentThread(); + /* Id of the thread to finalize. */ + int index = (unsigned int)id % STORAGE_CACHE_SLOTS; + Tcl_HashEntry *hPtr; /* Hash entry for current thread in master + * table. */ + Tcl_HashTable* hashTablePtr; + /* Pointer to the hash table holding + * TSD blocks for the current thread*/ + Tcl_HashSearch search; /* Search object to walk the TSD blocks + * in the designated thread */ + Tcl_HashEntry *hPtr2; /* Hash entry for a TSD block in the + * designated thread. */ + + Tcl_MutexLock(&threadStorageLock); + hPtr = Tcl_FindHashEntry(&threadStorageHashTable, (char*)id); + if (hPtr == NULL) { + hashTablePtr = NULL; + } else { + /* + * We found it, extract the hash table pointer. + */ + + hashTablePtr = Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + + /* + * Make sure cache entry for this thread is NULL. + */ + + if (threadStorageCache[index].id == id) { + /* + * We do not step on another thread's cache entry. This is + * especially important if we are creating and exiting a lot + * of threads. + */ + threadStorageCache[index].id = STORAGE_INVALID_THREAD; + threadStorageCache[index].hashTablePtr = NULL; + } + } + Tcl_MutexUnlock(&threadStorageLock); + + /* + * The thread's hash table has been extracted and removed from the master + * hash table. Now clean up the thread. + */ + + if (hashTablePtr != NULL) { + + /* Free all TSD */ + + for (hPtr2 = Tcl_FirstHashEntry(hashTablePtr, &search); + hPtr2 != NULL; + hPtr2 = Tcl_NextHashEntry(&search)) { + void* blockPtr = Tcl_GetHashValue(hPtr2); + if (blockPtr != NULL) { + /* + * The block itself was allocated in Tcl_GetThreadData + * using ckalloc; use ckfree to dispose of it. + */ + ckfree(blockPtr); + } + } + + /* + * Delete thread specific hash table and free the struct. + */ + + Tcl_DeleteHashTable(hashTablePtr); + TclpSysFree((char *)hashTablePtr); + } } /* *---------------------------------------------------------------------- * * TclFinalizeThreadStorage -- * - * This procedure cleans up the master thread storage hash table, - * all thread specific hash tables, and the thread storage cache. + * This procedure cleans up the master thread storage hash table, all + * thread specific hash tables, and the thread storage cache. * * Results: * None. * * Side effects: @@ -783,330 +498,87 @@ */ void TclFinalizeThreadStorage() { - TclThreadStorageLock(); - - if (threadStorageHashTablePtr != NULL) { - Tcl_HashSearch search; /* We need to hit every thread with - * this search. */ - Tcl_HashEntry *hPtr; /* Hash entry for current thread in - * master table. */ - - /* - * We are going to delete the hash table for every thread now. - * This hash table should be empty at this point, except for - * one entry for the current thread. - */ - - for (hPtr = Tcl_FirstHashEntry(threadStorageHashTablePtr, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - Tcl_HashTable *hashTablePtr = Tcl_GetHashValue(hPtr); - - if (hashTablePtr != NULL) { - /* - * Delete thread specific hash table for the thread in - * question and free the struct. - */ - - Tcl_DeleteHashTable(hashTablePtr); - TclpSysFree((char *)hashTablePtr); - } - - /* - * Delete thread specific entry from master hash table. - */ - - Tcl_SetHashValue(hPtr, NULL); - } - - Tcl_DeleteHashTable(threadStorageHashTablePtr); - TclpSysFree((char *)threadStorageHashTablePtr); - - /* - * Reset this so that next time around we know it's not valid. - */ - - threadStorageHashTablePtr = NULL; - } - + Tcl_HashSearch search; /* We need to hit every thread with + * this search. */ + Tcl_HashEntry *hPtr; /* Hash entry for current thread in + * master table. */ + Tcl_MutexLock(&threadStorageLock); + + /* + * We are going to delete the hash table for every thread now. This + * hash table should be empty at this point, except for one entry for + * the current thread. + */ + + for (hPtr = Tcl_FirstHashEntry(&threadStorageHashTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + Tcl_HashTable *hashTablePtr = Tcl_GetHashValue(hPtr); + + if (hashTablePtr != NULL) { + /* + * Delete thread specific hash table for the thread in + * question and free the struct. + */ + + Tcl_DeleteHashTable(hashTablePtr); + TclpSysFree((char *)hashTablePtr); + } + + /* + * Delete thread specific entry from master hash table. + */ + + Tcl_SetHashValue(hPtr, NULL); + } + + Tcl_DeleteHashTable(&threadStorageHashTable); + /* * Clear out the thread storage cache as well. */ memset((ThreadStorage *)&threadStorageCache, 0, sizeof(ThreadStorage) * STORAGE_CACHE_SLOTS); /* - * Reset this to zero, it will be set to STORAGE_FIRST_KEY if the - * thread storage subsystem gets reinitialized + * Reset this to zero, it will be set to STORAGE_FIRST_KEY if the thread + * storage subsystem gets reinitialized */ nextThreadStorageKey = STORAGE_INVALID_KEY; - TclThreadStorageUnlock(); -} - -/* - *---------------------------------------------------------------------- - * - * TclFinalizeThreadStorageData -- - * - * This procedure cleans up the thread-local storage. This is - * called once for each thread. - * - * Results: - * None. - * - * Side effects: - * Frees up the memory. - * - *---------------------------------------------------------------------- - */ - -void -TclFinalizeThreadStorageData(keyPtr) - Tcl_ThreadDataKey *keyPtr; -{ - if (*keyPtr != NULL) { - Tcl_ThreadId id = Tcl_GetCurrentThread(); - Tcl_HashTable *hashTablePtr; /* Hash table for current thread */ - Tcl_HashEntry *hPtr; /* Hash entry for data key in current - * thread. */ - int *indexPtr = *(int **)keyPtr; - - hashTablePtr = TclThreadStorageGetHashTable(id); - if (hashTablePtr == NULL) { - Tcl_Panic("TclThreadStorageGetHashTable failed from " - "TclFinalizeThreadStorageData!"); - } - - hPtr = Tcl_FindHashEntry(hashTablePtr, (char *)*indexPtr); - if (hPtr != NULL) { - void *result = Tcl_GetHashValue(hPtr); - - if (result != NULL) { - /* - * This must be ckfree because tclThread.c allocates - * these using ckalloc. - */ - ckfree((char *)result); - } - - Tcl_SetHashValue(hPtr, NULL); - } - } -} - -/* - *---------------------------------------------------------------------- - * - * TclFinalizeThreadStorageDataKey -- - * - * This procedure is invoked to clean up one key. This is a - * process-wide storage identifier. The thread finalization code - * cleans up the thread local storage itself. - * - * This assumes the master lock is held. - * - * Results: - * None. - * - * Side effects: - * The key is deallocated. - * - *---------------------------------------------------------------------- - */ - -void -TclFinalizeThreadStorageDataKey(keyPtr) - Tcl_ThreadDataKey *keyPtr; -{ - int *indexPtr; - Tcl_HashTable *hashTablePtr;/* Hash table for current thread */ - Tcl_HashSearch search; /* Need to hit every thread with this search */ - Tcl_HashEntry *hPtr; /* Hash entry for current thread in master - * table. */ - Tcl_HashEntry *hDataPtr; /* Hash entry for data key in current thread */ - - if (*keyPtr != NULL) { - indexPtr = *(int **)keyPtr; - - TclThreadStorageLock(); - - if (threadStorageHashTablePtr != NULL) { - /* - * We are going to delete the specified data key entry - * from every thread. - */ - - for (hPtr = Tcl_FirstHashEntry(threadStorageHashTablePtr, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - - /* - * Get the hash table corresponding to the thread in question. - */ - hashTablePtr = Tcl_GetHashValue(hPtr); - - if (hashTablePtr != NULL) { - /* - * Now find the entry for the specified data key. - */ - hDataPtr = Tcl_FindHashEntry(hashTablePtr, - (char *)*indexPtr); - - if (hDataPtr != NULL) { - /* - * Delete the data key for this thread. - */ - Tcl_DeleteHashEntry(hDataPtr); - } - } - } - } - - TclThreadStorageUnlock(); - - TclpSysFree((char *)indexPtr); - *keyPtr = NULL; - } -} - -#else /* !defined(TCL_THREADS) || !defined(USE_THREAD_STORAGE) */ - -static void ThreadStoragePanic _ANSI_ARGS_((CONST char *message)); - -/* - *---------------------------------------------------------------------- - * - * ThreadStoragePanic -- - * - * Panic if Tcl was compiled without TCL_THREADS or without - * USE_THREAD_STORAGE and a thread storage function has been - * called. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ -static void ThreadStoragePanic(message) - CONST char *message; /* currently ignored */ -{ -#ifdef TCL_THREADS -# ifdef USE_THREAD_STORAGE - /* - * Do nothing, everything is OK. However, this should never happen - * because this function only gets called by the dummy thread - * storage functions (used when one or both of these DEFINES are - * not present). - */ -# else - Tcl_Panic("Tcl was not compiled with thread storage enabled."); -# endif /* USE_THREAD_STORAGE */ -#else - Tcl_Panic("Tcl was not compiled with threads enabled."); -#endif /* TCL_THREADS */ -} - -/* - * Stub functions that just call ThreadStoragePanic. - */ - -void -TclThreadStorageLockInit() -{ - ThreadStoragePanic(NULL); -} - -void -TclThreadStorageLock() -{ - ThreadStoragePanic(NULL); -} - -void -TclThreadStorageUnlock() -{ - ThreadStoragePanic(NULL); -} - -void -TclThreadStoragePrint(outFile, flags) - FILE *outFile; - int flags; -{ - ThreadStoragePanic(NULL); -} - -Tcl_HashTable * -TclThreadStorageGetHashTable(id) - Tcl_ThreadId id; -{ - ThreadStoragePanic(NULL); - return NULL; -} - -Tcl_HashTable * -TclThreadStorageInit(id, reserved) - Tcl_ThreadId id; - void *reserved; -{ - ThreadStoragePanic(NULL); - return NULL; -} - -void -TclThreadStorageDataKeyInit(keyPtr) - Tcl_ThreadDataKey *keyPtr; -{ - ThreadStoragePanic(NULL); -} - -void * -TclThreadStorageDataKeyGet(keyPtr) - Tcl_ThreadDataKey *keyPtr; -{ - ThreadStoragePanic(NULL); - return NULL; -} - -void -TclThreadStorageDataKeySet(keyPtr, data) - Tcl_ThreadDataKey *keyPtr; - void *data; -{ - ThreadStoragePanic(NULL); -} - -void -TclFinalizeThreadStorageThread(id) - Tcl_ThreadId id; -{ - ThreadStoragePanic(NULL); + Tcl_MutexUnlock(&threadStorageLock); +} + +#else /* !defined(TCL_THREADS) */ + +/* + * Stub functions for non-threaded builds + */ + +void +TclInitThreadStorage() +{ +} + +void +TclpFinalizeThreadDataThread() +{ } void TclFinalizeThreadStorage() { - ThreadStoragePanic(NULL); -} - -void -TclFinalizeThreadStorageData(keyPtr) - Tcl_ThreadDataKey *keyPtr; -{ - ThreadStoragePanic(NULL); -} - -void -TclFinalizeThreadStorageDataKey(keyPtr) - Tcl_ThreadDataKey *keyPtr; -{ - ThreadStoragePanic(NULL); } #endif /* defined(TCL_THREADS) && defined(USE_THREAD_STORAGE) */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclThreadTest.c ================================================================== --- generic/tclThreadTest.c +++ generic/tclThreadTest.c @@ -9,14 +9,16 @@ * Copyright (c) 1998 by Sun Microsystems, Inc. * * 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.17 2004/10/20 05:28:39 dgp Exp $ + * RCS: @(#) $Id: tclThreadTest.c,v 1.17.2.4 2005/09/26 20:16:53 kennykb Exp $ */ #include "tclInt.h" + +extern int Tcltest_Init( Tcl_Interp* ); #ifdef TCL_THREADS /* * Each thread has an single instance of the following structure. There * is one instance of this structure per thread even if that thread contains @@ -134,10 +136,16 @@ static void ThreadFreeProc _ANSI_ARGS_((ClientData clientData)); static int ThreadDeleteEvent _ANSI_ARGS_((Tcl_Event *eventPtr, ClientData clientData)); static void ThreadExitProc _ANSI_ARGS_((ClientData clientData)); + +/* Forward declaration of function import from "tclTest.c". + */ + +int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); + /* *---------------------------------------------------------------------- * * TclThread_Init -- @@ -158,13 +166,10 @@ Tcl_Interp *interp; /* The current Tcl interpreter */ { Tcl_CreateObjCommand(interp,"testthread", Tcl_ThreadObjCmd, (ClientData)NULL ,NULL); - if (Tcl_PkgProvide(interp, "Thread", "1.0" ) != TCL_OK) { - return TCL_ERROR; - } return TCL_OK; } /* @@ -480,10 +485,16 @@ tsdPtr->interp = Tcl_CreateInterp(); result = Tcl_Init(tsdPtr->interp); result = TclThread_Init(tsdPtr->interp); + /* This is part of the test facility. + * Initialize _ALL_ test commands for + * use by the new thread. + */ + result = Tcltest_Init(tsdPtr->interp); + /* * Update the list of threads. */ Tcl_MutexLock(&threadMutex); Index: generic/tclTimer.c ================================================================== --- generic/tclTimer.c +++ generic/tclTimer.c @@ -1,125 +1,143 @@ -/* +/* * tclTimer.c -- * * This file provides timer event management facilities for Tcl, * including the "after" command. * * Copyright (c) 1997 by Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTimer.c,v 1.12 2004/10/06 15:59:25 dgp Exp $ + * RCS: @(#) $Id: tclTimer.c,v 1.12.2.6 2005/10/08 13:44:37 dgp Exp $ */ #include "tclInt.h" /* * For each timer callback that's pending there is one record of the following - * type. The normal handlers (created by Tcl_CreateTimerHandler) are chained + * type. The normal handlers (created by Tcl_CreateTimerHandler) are chained * together in a list sorted by time (earliest event first). */ typedef struct TimerHandler { - Tcl_Time time; /* When timer is to fire. */ - Tcl_TimerProc *proc; /* Procedure to call. */ - ClientData clientData; /* Argument to pass to proc. */ - Tcl_TimerToken token; /* Identifies handler so it can be - * deleted. */ - struct TimerHandler *nextPtr; /* Next event in queue, or NULL for - * end of queue. */ + Tcl_Time time; /* When timer is to fire. */ + Tcl_TimerProc *proc; /* Function to call. */ + ClientData clientData; /* Argument to pass to proc. */ + Tcl_TimerToken token; /* Identifies handler so it can be deleted. */ + struct TimerHandler *nextPtr; + /* Next event in queue, or NULL for end of + * queue. */ } TimerHandler; /* - * The data structure below is used by the "after" command to remember - * the command to be executed later. All of the pending "after" commands - * for an interpreter are linked together in a list. + * The data structure below is used by the "after" command to remember the + * command to be executed later. All of the pending "after" commands for an + * interpreter are linked together in a list. */ typedef struct AfterInfo { struct AfterAssocData *assocPtr; - /* Pointer to the "tclAfter" assocData for - * the interp in which command will be + /* Pointer to the "tclAfter" assocData for the + * interp in which command will be * executed. */ Tcl_Obj *commandPtr; /* Command to execute. */ - int id; /* Integer identifier for command; used to + int id; /* Integer identifier for command; used to * cancel it. */ - Tcl_TimerToken token; /* Used to cancel the "after" command. NULL - * means that the command is run as an - * idle handler rather than as a timer - * handler. NULL means this is an "after - * idle" handler rather than a - * timer handler. */ + Tcl_TimerToken token; /* Used to cancel the "after" command. NULL + * means that the command is run as an idle + * handler rather than as a timer handler. + * NULL means this is an "after idle" handler + * rather than a timer handler. */ struct AfterInfo *nextPtr; /* Next in list of all "after" commands for * this interpreter. */ } AfterInfo; /* - * One of the following structures is associated with each interpreter - * for which an "after" command has ever been invoked. A pointer to - * this structure is stored in the AssocData for the "tclAfter" key. + * One of the following structures is associated with each interpreter for + * which an "after" command has ever been invoked. A pointer to this structure + * is stored in the AssocData for the "tclAfter" key. */ typedef struct AfterAssocData { Tcl_Interp *interp; /* The interpreter for which this data is * registered. */ - AfterInfo *firstAfterPtr; /* First in list of all "after" commands - * still pending for this interpreter, or - * NULL if none. */ + AfterInfo *firstAfterPtr; /* First in list of all "after" commands still + * pending for this interpreter, or NULL if + * none. */ } AfterAssocData; /* - * There is one of the following structures for each of the - * handlers declared in a call to Tcl_DoWhenIdle. All of the - * currently-active handlers are linked together into a list. + * There is one of the following structures for each of the handlers declared + * in a call to Tcl_DoWhenIdle. All of the currently-active handlers are + * linked together into a list. */ typedef struct IdleHandler { - Tcl_IdleProc (*proc); /* Procedure to call. */ + Tcl_IdleProc (*proc); /* Function to call. */ ClientData clientData; /* Value to pass to proc. */ int generation; /* Used to distinguish older handlers from * recently-created ones. */ struct IdleHandler *nextPtr;/* Next in list of active handlers. */ } IdleHandler; /* - * The timer and idle queues are per-thread because they are associated - * with the notifier, which is also per-thread. - * - * All static variables used in this file are collected into a single - * instance of the following structure. For multi-threaded implementations, - * there is one instance of this structure for each thread. - * - * Notice that different structures with the same name appear in other - * files. The structure defined below is used in this file only. + * The timer and idle queues are per-thread because they are associated with + * the notifier, which is also per-thread. + * + * All static variables used in this file are collected into a single instance + * of the following structure. For multi-threaded implementations, there is + * one instance of this structure for each thread. + * + * Notice that different structures with the same name appear in other files. + * The structure defined below is used in this file only. */ typedef struct ThreadSpecificData { TimerHandler *firstTimerHandlerPtr; /* First event in queue. */ - int lastTimerId; /* Timer identifier of most recently - * created timer. */ + int lastTimerId; /* Timer identifier of most recently created + * timer. */ int timerPending; /* 1 if a timer event is in the queue. */ IdleHandler *idleList; /* First in list of all idle handlers. */ IdleHandler *lastIdlePtr; /* Last in list (or NULL for empty list). */ - int idleGeneration; /* Used to fill in the "generation" fields - * of IdleHandler structures. Increments - * each time Tcl_DoOneEvent starts calling - * idle handlers, so that all old handlers - * can be called without calling any of the - * new ones created by old ones. */ + int idleGeneration; /* Used to fill in the "generation" fields of + * IdleHandler structures. Increments each + * time Tcl_DoOneEvent starts calling idle + * handlers, so that all old handlers can be + * called without calling any of the new ones + * created by old ones. */ int afterId; /* For unique identifiers of after events. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* - * Prototypes for procedures referenced only in this file: + * Helper macros for working with times. TCL_TIME_BEFORE encodes how to write + * the ordering relation on (normalized) times, and TCL_TIME_DIFF_MS computes + * the number of milliseconds difference between two times. Both macros use + * both of their arguments multiple times, so make sure they are cheap and + * side-effect free. The "prototypes" for these macros are: + * + * static int TCL_TIME_BEFORE(Tcl_Time t1, Tcl_Time t2); + * static long TCL_TIME_DIFF_MS(Tcl_Time t1, Tcl_Time t2); + */ + +#define TCL_TIME_BEFORE(t1, t2) \ + (((t1).sec<(t2).sec) || ((t1).sec==(t2).sec && (t1).usec<(t2).usec)) + +#define TCL_TIME_DIFF_MS(t1, t2) \ + (1000*((long)(t1).sec - (long)(t2).sec) + \ + ((long)(t1).usec - (long)(t2).usec)/1000) + +/* + * Prototypes for functions referenced only in this file: */ static void AfterCleanupProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp)); +static int AfterDelay _ANSI_ARGS_((Tcl_Interp *interp, int ms)); static void AfterProc _ANSI_ARGS_((ClientData clientData)); static void FreeAfterPtr _ANSI_ARGS_((AfterInfo *afterPtr)); static AfterInfo * GetAfterEvent _ANSI_ARGS_((AfterAssocData *assocPtr, Tcl_Obj *commandPtr)); static ThreadSpecificData *InitTimer _ANSI_ARGS_((void)); @@ -148,12 +166,12 @@ */ static ThreadSpecificData * InitTimer() { - ThreadSpecificData *tsdPtr = - (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) + TclThreadDataKeyGet(&dataKey); if (tsdPtr == NULL) { tsdPtr = TCL_TSD_INIT(&dataKey); Tcl_CreateEventSource(TimerSetupProc, TimerCheckProc, NULL); Tcl_CreateThreadExitHandler(TimerExitProc, NULL); @@ -164,12 +182,12 @@ /* *---------------------------------------------------------------------- * * TimerExitProc -- * - * This function is call at exit or unload time to remove the - * timer and idle event sources. + * This function is call at exit or unload time to remove the timer and + * idle event sources. * * Results: * None. * * Side effects: @@ -180,16 +198,17 @@ static void TimerExitProc(clientData) ClientData clientData; /* Not used. */ { - ThreadSpecificData *tsdPtr = - (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) + TclThreadDataKeyGet(&dataKey); Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL); if (tsdPtr != NULL) { register TimerHandler *timerHandlerPtr; + timerHandlerPtr = tsdPtr->firstTimerHandlerPtr; while (timerHandlerPtr != NULL) { tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr; ckfree((char *) timerHandlerPtr); timerHandlerPtr = tsdPtr->firstTimerHandlerPtr; @@ -200,55 +219,82 @@ /* *-------------------------------------------------------------- * * Tcl_CreateTimerHandler -- * - * Arrange for a given procedure to be invoked at a particular - * time in the future. + * Arrange for a given function to be invoked at a particular time in the + * future. * * Results: - * The return value is a token for the timer event, which - * may be used to delete the event before it fires. + * The return value is a token for the timer event, which may be used to + * delete the event before it fires. * * Side effects: - * When milliseconds have elapsed, proc will be invoked - * exactly once. + * When milliseconds have elapsed, proc will be invoked exactly once. * *-------------------------------------------------------------- */ Tcl_TimerToken Tcl_CreateTimerHandler(milliseconds, proc, clientData) - int milliseconds; /* How many milliseconds to wait - * before invoking proc. */ - Tcl_TimerProc *proc; /* Procedure to invoke. */ + int milliseconds; /* How many milliseconds to wait before + * invoking proc. */ + Tcl_TimerProc *proc; /* Function to invoke. */ ClientData clientData; /* Arbitrary data to pass to proc. */ { - register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr; Tcl_Time time; - ThreadSpecificData *tsdPtr; - - tsdPtr = InitTimer(); - - timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler)); /* * Compute when the event should fire. */ Tcl_GetTime(&time); - timerHandlerPtr->time.sec = time.sec + milliseconds/1000; - timerHandlerPtr->time.usec = time.usec + (milliseconds%1000)*1000; - if (timerHandlerPtr->time.usec >= 1000000) { - timerHandlerPtr->time.usec -= 1000000; - timerHandlerPtr->time.sec += 1; + time.sec += milliseconds/1000; + time.usec += (milliseconds%1000)*1000; + if (time.usec >= 1000000) { + time.usec -= 1000000; + time.sec += 1; } + return TclCreateAbsoluteTimerHandler(&time, proc, clientData); +} + +/* + *-------------------------------------------------------------- + * + * TclCreateAbsoluteTimerHandler -- + * + * Arrange for a given function to be invoked at a particular time in the + * future. + * + * Results: + * The return value is a token for the timer event, which may be used to + * delete the event before it fires. + * + * Side effects: + * When the time in timePtr has been reached, proc will be invoked + * exactly once. + * + *-------------------------------------------------------------- + */ + +Tcl_TimerToken +TclCreateAbsoluteTimerHandler(timePtr, proc, clientData) + Tcl_Time *timePtr; + Tcl_TimerProc *proc; + ClientData clientData; +{ + register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr; + ThreadSpecificData *tsdPtr; + + tsdPtr = InitTimer(); + timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler)); /* - * Fill in other fields for the event. + * Fill in fields for the event. */ + memcpy((void *)&timerHandlerPtr->time, (void *)timePtr, sizeof(Tcl_Time)); timerHandlerPtr->proc = proc; timerHandlerPtr->clientData = clientData; tsdPtr->lastTimerId++; timerHandlerPtr->token = (Tcl_TimerToken) tsdPtr->lastTimerId; @@ -257,13 +303,11 @@ * (ordered by event firing time). */ for (tPtr2 = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL; prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) { - if ((tPtr2->time.sec > timerHandlerPtr->time.sec) - || ((tPtr2->time.sec == timerHandlerPtr->time.sec) - && (tPtr2->time.usec > timerHandlerPtr->time.usec))) { + if (TCL_TIME_BEFORE(timerHandlerPtr->time, tPtr2->time)) { break; } } timerHandlerPtr->nextPtr = tPtr2; if (prevPtr == NULL) { @@ -286,14 +330,13 @@ * * Results: * None. * * Side effects: - * Destroy the timer callback identified by TimerToken, - * so that its associated procedure will not be called. - * If the callback has already fired, or if the given - * token doesn't exist, then nothing happens. + * Destroy the timer callback identified by TimerToken, so that its + * associated function will not be called. If the callback has already + * fired, or if the given token doesn't exist, then nothing happens. * *-------------------------------------------------------------- */ void @@ -300,13 +343,16 @@ Tcl_DeleteTimerHandler(token) Tcl_TimerToken token; /* Result previously returned by * Tcl_DeleteTimerHandler. */ { register TimerHandler *timerHandlerPtr, *prevPtr; - ThreadSpecificData *tsdPtr; + ThreadSpecificData *tsdPtr = InitTimer(); - tsdPtr = InitTimer(); + if (token == NULL) { + return; + } + for (timerHandlerPtr = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; timerHandlerPtr != NULL; prevPtr = timerHandlerPtr, timerHandlerPtr = timerHandlerPtr->nextPtr) { if (timerHandlerPtr->token != token) { continue; @@ -324,13 +370,13 @@ /* *---------------------------------------------------------------------- * * TimerSetupProc -- * - * This function is called by Tcl_DoOneEvent to setup the timer - * event source for before blocking. This routine checks both the - * idle and after timer lists. + * This function is called by Tcl_DoOneEvent to setup the timer event + * source for before blocking. This routine checks both the idle and + * after timer lists. * * Results: * None. * * Side effects: @@ -374,22 +420,22 @@ blockTime.usec = 0; } } else { return; } - + Tcl_SetMaxBlockTime(&blockTime); } /* *---------------------------------------------------------------------- * * TimerCheckProc -- * - * This function is called by Tcl_DoOneEvent to check the timer - * event source for events. This routine checks both the - * idle and after timer lists. + * This function is called by Tcl_DoOneEvent to check the timer event + * source for events. This routine checks both the idle and after timer + * lists. * * Results: * None. * * Side effects: @@ -442,73 +488,70 @@ /* *---------------------------------------------------------------------- * * TimerHandlerEventProc -- * - * This procedure is called by Tcl_ServiceEvent when a timer event - * reaches the front of the event queue. This procedure handles - * the event by invoking the callbacks for all timers that are - * ready. + * This function is called by Tcl_ServiceEvent when a timer event reaches + * the front of the event queue. This function handles the event by + * invoking the callbacks for all timers that are ready. * * Results: - * Returns 1 if the event was handled, meaning it should be removed - * from the queue. Returns 0 if the event was not handled, meaning - * it should stay on the queue. The only time the event isn't - * handled is if the TCL_TIMER_EVENTS flag bit isn't set. + * Returns 1 if the event was handled, meaning it should be removed from + * the queue. Returns 0 if the event was not handled, meaning it should + * stay on the queue. The only time the event isn't handled is if the + * TCL_TIMER_EVENTS flag bit isn't set. * * Side effects: - * Whatever the timer handler callback procedures do. + * Whatever the timer handler callback functions do. * *---------------------------------------------------------------------- */ static int TimerHandlerEventProc(evPtr, flags) Tcl_Event *evPtr; /* Event to service. */ - int flags; /* Flags that indicate what events to - * handle, such as TCL_FILE_EVENTS. */ + int flags; /* Flags that indicate what events to handle, + * such as TCL_FILE_EVENTS. */ { TimerHandler *timerHandlerPtr, **nextPtrPtr; Tcl_Time time; int currentTimerId; ThreadSpecificData *tsdPtr = InitTimer(); /* - * Do nothing if timers aren't enabled. This leaves the event on the - * queue, so we will get to it as soon as ServiceEvents() is called - * with timers enabled. + * Do nothing if timers aren't enabled. This leaves the event on the + * queue, so we will get to it as soon as ServiceEvents() is called with + * timers enabled. */ if (!(flags & TCL_TIMER_EVENTS)) { return 0; } /* - * The code below is trickier than it may look, for the following - * reasons: - * - * 1. New handlers can get added to the list while the current - * one is being processed. If new ones get added, we don't - * want to process them during this pass through the list to avoid - * starving other event sources. This is implemented using the - * token number in the handler: new handlers will have a - * newer token than any of the ones currently on the list. - * 2. The handler can call Tcl_DoOneEvent, so we have to remove - * the handler from the list before calling it. Otherwise an - * infinite loop could result. - * 3. Tcl_DeleteTimerHandler can be called to remove an element from - * the list while a handler is executing, so the list could - * change structure during the call. - * 4. Because we only fetch the current time before entering the loop, - * the only way a new timer will even be considered runnable is if - * its expiration time is within the same millisecond as the - * current time. This is fairly likely on Windows, since it has - * a course granularity clock. Since timers are placed - * on the queue in time order with the most recently created - * handler appearing after earlier ones with the same expiration - * time, we don't have to worry about newer generation timers - * appearing before later ones. + * The code below is trickier than it may look, for the following reasons: + * + * 1. New handlers can get added to the list while the current one is + * being processed. If new ones get added, we don't want to process + * them during this pass through the list to avoid starving other event + * sources. This is implemented using the token number in the handler: + * new handlers will have a newer token than any of the ones currently + * on the list. + * 2. The handler can call Tcl_DoOneEvent, so we have to remove the + * handler from the list before calling it. Otherwise an infinite loop + * could result. + * 3. Tcl_DeleteTimerHandler can be called to remove an element from the + * list while a handler is executing, so the list could change + * structure during the call. + * 4. Because we only fetch the current time before entering the loop, the + * only way a new timer will even be considered runnable is if its + * expiration time is within the same millisecond as the current time. + * This is fairly likely on Windows, since it has a course granularity + * clock. Since timers are placed on the queue in time order with the + * most recently created handler appearing after earlier ones with the + * same expiration time, we don't have to worry about newer generation + * timers appearing before later ones. */ tsdPtr->timerPending = 0; currentTimerId = tsdPtr->lastTimerId; Tcl_GetTime(&time); @@ -516,14 +559,12 @@ nextPtrPtr = &tsdPtr->firstTimerHandlerPtr; timerHandlerPtr = tsdPtr->firstTimerHandlerPtr; if (timerHandlerPtr == NULL) { break; } - - if ((timerHandlerPtr->time.sec > time.sec) - || ((timerHandlerPtr->time.sec == time.sec) - && (timerHandlerPtr->time.usec > time.usec))) { + + if (TCL_TIME_BEFORE(time, timerHandlerPtr->time)) { break; } /* * Bail out if the next timer is of a newer generation. @@ -532,12 +573,12 @@ if ((currentTimerId - (int)timerHandlerPtr->token) < 0) { break; } /* - * Remove the handler from the queue before invoking it, - * to avoid potential reentrancy problems. + * Remove the handler from the queue before invoking it, to avoid + * potential reentrancy problems. */ (*nextPtrPtr) = timerHandlerPtr->nextPtr; (*timerHandlerPtr->proc)(timerHandlerPtr->clientData); ckfree((char *) timerHandlerPtr); @@ -549,27 +590,27 @@ /* *-------------------------------------------------------------- * * Tcl_DoWhenIdle -- * - * Arrange for proc to be invoked the next time the system is - * idle (i.e., just before the next time that Tcl_DoOneEvent - * would have to wait for something to happen). + * Arrange for proc to be invoked the next time the system is idle (i.e., + * just before the next time that Tcl_DoOneEvent would have to wait for + * something to happen). * * Results: * None. * * Side effects: - * Proc will eventually be called, with clientData as argument. - * See the manual entry for details. + * Proc will eventually be called, with clientData as argument. See the + * manual entry for details. * *-------------------------------------------------------------- */ void Tcl_DoWhenIdle(proc, clientData) - Tcl_IdleProc *proc; /* Procedure to invoke. */ + Tcl_IdleProc *proc; /* Function to invoke. */ ClientData clientData; /* Arbitrary value to pass to proc. */ { register IdleHandler *idlePtr; Tcl_Time blockTime; ThreadSpecificData *tsdPtr = InitTimer(); @@ -594,26 +635,26 @@ /* *---------------------------------------------------------------------- * * Tcl_CancelIdleCall -- * - * If there are any when-idle calls requested to a given procedure - * with given clientData, cancel all of them. + * If there are any when-idle calls requested to a given function with + * given clientData, cancel all of them. * * Results: * None. * * Side effects: - * If the proc/clientData combination were on the when-idle list, - * they are removed so that they will never be called. + * If the proc/clientData combination were on the when-idle list, they + * are removed so that they will never be called. * *---------------------------------------------------------------------- */ void Tcl_CancelIdleCall(proc, clientData) - Tcl_IdleProc *proc; /* Procedure that was previously registered. */ + Tcl_IdleProc *proc; /* Function that was previously registered. */ ClientData clientData; /* Arbitrary value to pass to proc. */ { register IdleHandler *idlePtr, *prevPtr; IdleHandler *nextPtr; ThreadSpecificData *tsdPtr = InitTimer(); @@ -641,18 +682,17 @@ /* *---------------------------------------------------------------------- * * TclServiceIdle -- * - * This procedure is invoked by the notifier when it becomes - * idle. It will invoke all idle handlers that are present at - * the time the call is invoked, but not those added during idle - * processing. + * This function is invoked by the notifier when it becomes idle. It will + * invoke all idle handlers that are present at the time the call is + * invoked, but not those added during idle processing. * * Results: - * The return value is 1 if TclServiceIdle found something to - * do, otherwise return value is 0. + * The return value is 1 if TclServiceIdle found something to do, + * otherwise return value is 0. * * Side effects: * Invokes all pending idle handlers. * *---------------------------------------------------------------------- @@ -672,26 +712,24 @@ oldGeneration = tsdPtr->idleGeneration; tsdPtr->idleGeneration++; /* - * The code below is trickier than it may look, for the following - * reasons: - * - * 1. New handlers can get added to the list while the current - * one is being processed. If new ones get added, we don't - * want to process them during this pass through the list (want - * to check for other work to do first). This is implemented - * using the generation number in the handler: new handlers - * will have a different generation than any of the ones currently - * on the list. - * 2. The handler can call Tcl_DoOneEvent, so we have to remove - * the handler from the list before calling it. Otherwise an - * infinite loop could result. - * 3. Tcl_CancelIdleCall can be called to remove an element from - * the list while a handler is executing, so the list could - * change structure during the call. + * The code below is trickier than it may look, for the following reasons: + * + * 1. New handlers can get added to the list while the current one is + * being processed. If new ones get added, we don't want to process + * them during this pass through the list (want to check for other work + * to do first). This is implemented using the generation number in the + * handler: new handlers will have a different generation than any of + * the ones currently on the list. + * 2. The handler can call Tcl_DoOneEvent, so we have to remove the + * handler from the list before calling it. Otherwise an infinite loop + * could result. + * 3. Tcl_CancelIdleCall can be called to remove an element from the list + * while a handler is executing, so the list could change structure + * during the call. */ for (idlePtr = tsdPtr->idleList; ((idlePtr != NULL) && ((oldGeneration - idlePtr->generation) >= 0)); @@ -714,12 +752,12 @@ /* *---------------------------------------------------------------------- * * Tcl_AfterObjCmd -- * - * This procedure is invoked to process the "after" Tcl command. - * See the user documentation for details on what it does. + * This function is invoked to process the "after" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -744,26 +782,25 @@ int index; char buf[16 + TCL_INTEGER_SPACE]; static CONST char *afterSubCmds[] = { "cancel", "idle", "info", (char *) NULL }; + Tcl_Obj *objPtr; enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO}; ThreadSpecificData *tsdPtr = InitTimer(); if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; } /* - * Create the "after" information associated for this interpreter, - * if it doesn't already exist. Associate it with the command too, - * so that it will be passed in as the ClientData argument in the - * future. + * Create the "after" information associated for this interpreter, if it + * doesn't already exist. */ - assocPtr = Tcl_GetAssocData( interp, "tclAfter", NULL ); + assocPtr = Tcl_GetAssocData(interp, "tclAfter", NULL); if (assocPtr == NULL) { assocPtr = (AfterAssocData *) ckalloc(sizeof(AfterAssocData)); assocPtr->interp = interp; assocPtr->firstAfterPtr = NULL; Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, @@ -781,170 +818,233 @@ argString = Tcl_GetStringFromObj(objv[1], &length); if (isdigit(UCHAR(argString[0]))) { /* INTL: digit */ if (Tcl_GetIntFromObj(interp, objv[1], &ms) != TCL_OK) { return TCL_ERROR; } -processInteger: + processInteger: if (ms < 0) { ms = 0; } if (objc == 2) { - Tcl_Sleep(ms); - return TCL_OK; + return AfterDelay(interp, ms); } afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); afterPtr->assocPtr = assocPtr; if (objc == 3) { afterPtr->commandPtr = objv[2]; } else { afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2); } Tcl_IncrRefCount(afterPtr->commandPtr); + /* - * The variable below is used to generate unique identifiers for - * after commands. This id can wrap around, which can potentially - * cause problems. However, there are not likely to be problems - * in practice, because after commands can only be requested to - * about a month in the future, and wrap-around is unlikely to - * occur in less than about 1-10 years. Thus it's unlikely that - * any old ids will still be around when wrap-around occurs. + * The variable below is used to generate unique identifiers for after + * commands. This id can wrap around, which can potentially cause + * problems. However, there are not likely to be problems in practice, + * because after commands can only be requested to about a month in + * the future, and wrap-around is unlikely to occur in less than about + * 1-10 years. Thus it's unlikely that any old ids will still be + * around when wrap-around occurs. */ + afterPtr->id = tsdPtr->afterId; tsdPtr->afterId += 1; afterPtr->token = Tcl_CreateTimerHandler(ms, AfterProc, (ClientData) afterPtr); afterPtr->nextPtr = assocPtr->firstAfterPtr; assocPtr->firstAfterPtr = afterPtr; - sprintf(buf, "after#%d", afterPtr->id); - Tcl_AppendResult(interp, buf, (char *) NULL); + objPtr = Tcl_NewObj(); + TclObjPrintf(NULL, objPtr, "after#%d", afterPtr->id); + Tcl_SetObjResult(interp, objPtr); return TCL_OK; } /* - * If it's not a number it must be a subcommand. + * If it's not a number it must be a subcommand. Note that we're using a + * custom error message here, so we do not pass an interpreter to T_GIFO. */ - if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "argument", - 0, &index) != TCL_OK) { + if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "argument", 0, + &index) != TCL_OK) { Tcl_AppendResult(interp, "bad argument \"", argString, "\": must be cancel, idle, info, or a number", (char *) NULL); return TCL_ERROR; } switch ((enum afterSubCmds) index) { - case AFTER_CANCEL: { - Tcl_Obj *commandPtr; - char *command, *tempCommand; - int tempLength; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "id|command"); - return TCL_ERROR; - } - if (objc == 3) { - commandPtr = objv[2]; - } else { - commandPtr = Tcl_ConcatObj(objc-2, objv+2);; - } - command = Tcl_GetStringFromObj(commandPtr, &length); - for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; - afterPtr = afterPtr->nextPtr) { - tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr, - &tempLength); - if ((length == tempLength) - && (memcmp((void*) command, (void*) tempCommand, - (unsigned) length) == 0)) { - break; - } - } - if (afterPtr == NULL) { - afterPtr = GetAfterEvent(assocPtr, commandPtr); - } - if (objc != 3) { - Tcl_DecrRefCount(commandPtr); - } - if (afterPtr != NULL) { - if (afterPtr->token != NULL) { - Tcl_DeleteTimerHandler(afterPtr->token); - } else { - Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr); - } - FreeAfterPtr(afterPtr); - } - break; - } - case AFTER_IDLE: - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "script script ..."); - return TCL_ERROR; - } - afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); - afterPtr->assocPtr = assocPtr; - if (objc == 3) { - afterPtr->commandPtr = objv[2]; - } else { - afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2); - } - Tcl_IncrRefCount(afterPtr->commandPtr); - afterPtr->id = tsdPtr->afterId; - tsdPtr->afterId += 1; - afterPtr->token = NULL; - afterPtr->nextPtr = assocPtr->firstAfterPtr; - assocPtr->firstAfterPtr = afterPtr; - Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr); - sprintf(buf, "after#%d", afterPtr->id); - Tcl_AppendResult(interp, buf, (char *) NULL); - break; - case AFTER_INFO: { - Tcl_Obj *resultListPtr; - - if (objc == 2) { - for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; - afterPtr = afterPtr->nextPtr) { - if (assocPtr->interp == interp) { - sprintf(buf, "after#%d", afterPtr->id); - Tcl_AppendElement(interp, buf); - } - } - return TCL_OK; - } - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?id?"); - return TCL_ERROR; - } - afterPtr = GetAfterEvent(assocPtr, objv[2]); - if (afterPtr == NULL) { - Tcl_AppendResult(interp, "event \"", Tcl_GetString(objv[2]), - "\" doesn't exist", (char *) NULL); - return TCL_ERROR; - } - resultListPtr = Tcl_NewObj(); - Tcl_ListObjAppendElement(interp, resultListPtr, afterPtr->commandPtr); - Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj( - (afterPtr->token == NULL) ? "idle" : "timer", -1)); - Tcl_SetObjResult(interp, resultListPtr); - break; - } - default: { - Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds"); - } + case AFTER_CANCEL: { + Tcl_Obj *commandPtr; + char *command, *tempCommand; + int tempLength; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "id|command"); + return TCL_ERROR; + } + if (objc == 3) { + commandPtr = objv[2]; + } else { + commandPtr = Tcl_ConcatObj(objc-2, objv+2);; + } + command = Tcl_GetStringFromObj(commandPtr, &length); + for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; + afterPtr = afterPtr->nextPtr) { + tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr, + &tempLength); + if ((length == tempLength) + && (memcmp((void*) command, (void*) tempCommand, + (unsigned) length) == 0)) { + break; + } + } + if (afterPtr == NULL) { + afterPtr = GetAfterEvent(assocPtr, commandPtr); + } + if (objc != 3) { + Tcl_DecrRefCount(commandPtr); + } + if (afterPtr != NULL) { + if (afterPtr->token != NULL) { + Tcl_DeleteTimerHandler(afterPtr->token); + } else { + Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr); + } + FreeAfterPtr(afterPtr); + } + break; + } + case AFTER_IDLE: + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "script script ..."); + return TCL_ERROR; + } + afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); + afterPtr->assocPtr = assocPtr; + if (objc == 3) { + afterPtr->commandPtr = objv[2]; + } else { + afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2); + } + Tcl_IncrRefCount(afterPtr->commandPtr); + afterPtr->id = tsdPtr->afterId; + tsdPtr->afterId += 1; + afterPtr->token = NULL; + afterPtr->nextPtr = assocPtr->firstAfterPtr; + assocPtr->firstAfterPtr = afterPtr; + Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr); + objPtr = Tcl_NewObj(); + TclObjPrintf(NULL, objPtr, "after#%d", afterPtr->id); + Tcl_SetObjResult(interp, objPtr); + break; + case AFTER_INFO: { + Tcl_Obj *resultListPtr; + + if (objc == 2) { + for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; + afterPtr = afterPtr->nextPtr) { + if (assocPtr->interp == interp) { + sprintf(buf, "after#%d", afterPtr->id); + Tcl_AppendElement(interp, buf); + } + } + return TCL_OK; + } + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?id?"); + return TCL_ERROR; + } + afterPtr = GetAfterEvent(assocPtr, objv[2]); + if (afterPtr == NULL) { + Tcl_AppendResult(interp, "event \"", Tcl_GetString(objv[2]), + "\" doesn't exist", (char *) NULL); + return TCL_ERROR; + } + resultListPtr = Tcl_NewObj(); + Tcl_ListObjAppendElement(interp, resultListPtr, afterPtr->commandPtr); + Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj( + (afterPtr->token == NULL) ? "idle" : "timer", -1)); + Tcl_SetObjResult(interp, resultListPtr); + break; + } + default: + Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds"); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * AfterDelay -- + * + * Implements the blocking delay behaviour of [after $time]. Tricky + * because it has to take into account any time limit that has been set. + * + * Results: + * Standard Tcl result code (with error set if an error occurred due to a + * time limit being exceeded). + * + * Side effects: + * May adjust the time limit granularity marker. + * + *---------------------------------------------------------------------- + */ + +static int +AfterDelay(interp, ms) + Tcl_Interp *interp; + int ms; +{ + Interp *iPtr = (Interp *) interp; + + if (iPtr->limit.timeEvent != NULL) { + Tcl_Time endTime, now; + + Tcl_GetTime(&endTime); + endTime.sec += ms/1000; + endTime.usec += (ms%1000)*1000; + if (endTime.usec >= 1000000) { + endTime.sec++; + endTime.usec -= 1000000; + } + + do { + Tcl_GetTime(&now); + if (TCL_TIME_BEFORE(iPtr->limit.time, now)) { + iPtr->limit.granularityTicker = 0; + if (Tcl_LimitCheck(interp) != TCL_OK) { + return TCL_ERROR; + } + } + if (TCL_TIME_BEFORE(endTime, iPtr->limit.time)) { + Tcl_Sleep(TCL_TIME_DIFF_MS(endTime, now)); + break; + } else { + Tcl_Sleep(TCL_TIME_DIFF_MS(iPtr->limit.time, now)); + if (Tcl_LimitCheck(interp) != TCL_OK) { + return TCL_ERROR; + } + } + } while (TCL_TIME_BEFORE(now, endTime)); + } else { + Tcl_Sleep(ms); } return TCL_OK; } /* *---------------------------------------------------------------------- * * GetAfterEvent -- * - * This procedure parses an "after" id such as "after#4" and - * returns a pointer to the AfterInfo structure. + * This function parses an "after" id such as "after#4" and returns a + * pointer to the AfterInfo structure. * * Results: - * The return value is either a pointer to an AfterInfo structure, - * if one is found that corresponds to "cmdString" and is for interp, - * or NULL if no corresponding after event can be found. + * The return value is either a pointer to an AfterInfo structure, if one + * is found that corresponds to "cmdString" and is for interp, or NULL if + * no corresponding after event can be found. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -954,12 +1054,12 @@ GetAfterEvent(assocPtr, commandPtr) AfterAssocData *assocPtr; /* Points to "after"-related information for * this interpreter. */ Tcl_Obj *commandPtr; { - char *cmdString; /* Textual identifier for after event, such - * as "after#6". */ + char *cmdString; /* Textual identifier for after event, such as + * "after#6". */ AfterInfo *afterPtr; int id; char *end; cmdString = Tcl_GetString(commandPtr); @@ -983,21 +1083,20 @@ /* *---------------------------------------------------------------------- * * AfterProc -- * - * Timer callback to execute commands registered with the - * "after" command. + * Timer callback to execute commands registered with the "after" + * command. * * Results: * None. * * Side effects: - * Executes whatever command was specified. If the command - * returns an error, then the command "bgerror" is invoked - * to process the error; if bgerror fails then information - * about the error is output on stderr. + * Executes whatever command was specified. If the command returns an + * error, then the command "bgerror" is invoked to process the error; if + * bgerror fails then information about the error is output on stderr. * *---------------------------------------------------------------------- */ static void @@ -1011,13 +1110,13 @@ Tcl_Interp *interp; char *script; int numBytes; /* - * First remove the callback from our list of callbacks; otherwise - * someone could delete the callback while it's being executed, which - * could cause a core dump. + * First remove the callback from our list of callbacks; otherwise someone + * could delete the callback while it's being executed, which could cause + * a core dump. */ if (assocPtr->firstAfterPtr == afterPtr) { assocPtr->firstAfterPtr = afterPtr->nextPtr; } else { @@ -1039,11 +1138,11 @@ if (result != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (\"after\" script)"); Tcl_BackgroundError(interp); } Tcl_Release((ClientData) interp); - + /* * Free the memory for the callback. */ Tcl_DecrRefCount(afterPtr->commandPtr); @@ -1053,14 +1152,13 @@ /* *---------------------------------------------------------------------- * * FreeAfterPtr -- * - * This procedure removes an "after" command from the list of - * those that are pending and frees its resources. This procedure - * does *not* cancel the timer handler; if that's needed, the - * caller must do it. + * This function removes an "after" command from the list of those that + * are pending and frees its resources. This function does *not* cancel + * the timer handler; if that's needed, the caller must do it. * * Results: * None. * * Side effects: @@ -1092,11 +1190,11 @@ /* *---------------------------------------------------------------------- * * AfterCleanupProc -- * - * This procedure is invoked whenever an interpreter is deleted + * This function is invoked whenever an interpreter is deleted * to cleanup the AssocData for "tclAfter". * * Results: * None. * @@ -1127,5 +1225,13 @@ Tcl_DecrRefCount(afterPtr->commandPtr); ckfree((char *) afterPtr); } ckfree((char *) assocPtr); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ ADDED generic/tclTomMath.h Index: generic/tclTomMath.h ================================================================== --- /dev/null +++ generic/tclTomMath.h @@ -0,0 +1,130 @@ +/* + * tclTomMath.h -- + * + * Interface information that comes in at the head of + * to adapt the API to Tcl's linkage conventions. + * + * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclTomMath.h,v 1.1.2.7 2005/09/26 20:16:53 kennykb Exp $ + */ + +#ifndef TCLTOMMATH_H +#define TCLTOMMATH_H 1 + +#include +#include + + +/* Define TOMMATH_DLLIMPORT and TOMMATH_DLLEXPORT to suit the compiler */ + +#ifdef STATIC_BUILD +# define TOMMATH_DLLIMPORT +# define TOMMATH_DLLEXPORT +#else +# if (defined(__WIN32__) && (defined(_MSC_VER) || (__BORLANDC__ >= 0x0550) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec)))) +# define TOMMATH_DLLIMPORT __declspec(dllimport) +# define TOMMATH_DLLEXPORT __declspec(dllexport) +# else +# define TOMMATH_DLLIMPORT +# define TOMMATH_DLLEXPORT +# endif +#endif + +/* Define TOMMATH_STORAGE_CLASS according to the build options. */ + +#undef TOMMATH_STORAGE_CLASS +#ifdef BUILD_tcl +# define TOMMATH_STORAGE_CLASS TOMMATH_DLLEXPORT +#else +# ifdef USE_TCL_STUBS +# define TOMMATH_STORAGE_CLASS +# else +# define TOMMATH_STORAGE_CLASS TOMMATH_DLLIMPORT +# endif +#endif + +/* Define custom memory allocation for libtommath */ + +#define XMALLOC(x) TclBNAlloc(x) +#define XFREE(x) TclBNFree(x) +#define XREALLOC(x,n) TclBNRealloc(x,n) +#define XCALLOC(n,x) TclBNCalloc(n,x) +void* TclBNAlloc( size_t ); +void* TclBNRealloc( void*, size_t ); +void TclBNFree( void* ); +void* TclBNCalloc( size_t, size_t ); + +/* Rename all global symboles in libtommath to avoid linkage conflicts */ + +#define KARATSUBA_MUL_CUTOFF TclBNKaratsubaMulCutoff +#define KARATSUBA_SQR_CUTOFF TclBNKaratsubaSqrCutoff +#define TOOM_MUL_CUTOFF TclBNToomMulCutoff +#define TOOM_SQR_CUTOFF TclBNToomSqrCutoff + +#define mp_s_rmap TclBNMpSRmap + +#define bn_reverse TclBN_reverse +#define fast_s_mp_mul_digs TclBN_fast_s_mp_mul_digs +#define 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 +#define mp_div TclBN_mp_div +#define mp_div_d TclBN_mp_div_d +#define mp_div_2 TclBN_mp_div_2 +#define mp_div_2d TclBN_mp_div_2d +#define mp_div_3 TclBN_mp_div_3 +#define mp_exch TclBN_mp_exch +#define mp_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 +#define mp_init_multi TclBN_mp_init_multi +#define mp_init_set TclBN_mp_init_set +#define mp_init_size TclBN_mp_init_size +#define mp_karatsuba_mul TclBN_mp_karatsuba_mul +#define mp_karatsuba_sqr TclBN_mp_karatsuba_sqr +#define mp_lshd TclBN_mp_lshd +#define mp_mod TclBN_mp_mod +#define mp_mod_2d TclBN_mp_mod_2d +#define mp_mul TclBN_mp_mul +#define mp_mul_2 TclBN_mp_mul_2 +#define mp_mul_2d TclBN_mp_mul_2d +#define mp_mul_d TclBN_mp_mul_d +#define mp_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 +#define s_mp_sqr TclBN_s_mp_sqr +#define s_mp_sub TclBN_s_mp_sub + +#endif ADDED generic/tclTomMathInterface.c Index: generic/tclTomMathInterface.c ================================================================== --- /dev/null +++ generic/tclTomMathInterface.c @@ -0,0 +1,223 @@ +/* + *---------------------------------------------------------------------- + * + * tclTomMathInterface.c -- + * + * This file contains procedures that are used as a 'glue' + * layer between Tcl and libtommath. + * + * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclTomMathInterface.c,v 1.1.2.4 2005/09/16 19:29:02 dgp Exp $ + */ + +#include "tclInt.h" +#include "tommath.h" +#include + +/* + *---------------------------------------------------------------------- + * + * TclBNAlloc -- + * + * Allocate memory for libtommath. + * + * Results: + * Returns a pointer to the allocated block. + * + * This procedure is a wrapper around Tcl_Alloc, needed because of + * a mismatched type signature between Tcl_Alloc and malloc. + * + *---------------------------------------------------------------------- + */ + +extern void * +TclBNAlloc( size_t x ) +{ + return (void*) Tcl_Alloc( (unsigned int) x ); +} + +/* + *---------------------------------------------------------------------- + * + * TclBNAlloc -- + * + * Change the size of an allocated block of memory in libtommath + * + * Results: + * Returns a pointer to the allocated block. + * + * This procedure is a wrapper around Tcl_Realloc, needed because of + * a mismatched type signature between Tcl_Realloc and realloc. + * + *---------------------------------------------------------------------- + */ + +extern void * +TclBNRealloc( void* p, size_t s ) +{ + return (void*) Tcl_Realloc( (char*) p, (unsigned int) s ); +} + +/* + *---------------------------------------------------------------------- + * + * TclBNFree -- + * + * Free allocated memory in libtommath. + * + * Results: + * None. + * + * Side effects: + * Memory is freed. + * + * This function is simply a wrapper around Tcl_Free, needed in + * libtommath because of a type mismatch between free and Tcl_Free. + * + *---------------------------------------------------------------------- + */ + +extern void +TclBNFree( void* p ) +{ + Tcl_Free( (char*) p); +} + +/* + *---------------------------------------------------------------------- + * + * TclBNInitBignumFromLong -- + * + * Allocate and initialize a 'bignum' from a native 'long'. + * + * Results: + * None. + * + * Side effects: + * The 'bignum' is constructed. + * + *---------------------------------------------------------------------- + */ + +extern void +TclBNInitBignumFromLong( mp_int* a, long initVal ) +{ + + int status; + unsigned long v; + mp_digit* p; + + /* + * Allocate enough memory to hold the largest possible long + */ + + status = mp_init_size( a, ( ( CHAR_BIT * sizeof( long ) + DIGIT_BIT - 1 ) + / DIGIT_BIT ) ); + if ( status != MP_OKAY ) { + Tcl_Panic( "initialization failure in TclBNInitBignumFromLong" ); + } + + /* Convert arg to sign and magnitude */ + + if ( initVal < 0 ) { + a->sign = MP_NEG; + v = -initVal; + } else { + a->sign = MP_ZPOS; + v = initVal; + } + + /* Store the magnitude in the bignum. */ + + p = a->dp; + while ( v ) { + *p++ = (mp_digit) ( v & MP_MASK ); + v >>= MP_DIGIT_BIT; + } + a->used = p - a->dp; + +} + +/* + *---------------------------------------------------------------------- + * + * 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; + +} Index: generic/tclTrace.c ================================================================== --- generic/tclTrace.c +++ generic/tclTrace.c @@ -1,110 +1,111 @@ -/* +/* * tclTrace.c -- * * This file contains code to handle most trace management. * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 Scriptics Corporation. * Copyright (c) 2002 ActiveState Corporation. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTrace.c,v 1.21 2004/11/15 21:47:23 dgp Exp $ + * RCS: @(#) $Id: tclTrace.c,v 1.21.2.3 2005/08/02 18:16:10 dgp Exp $ */ #include "tclInt.h" /* * Structure used to hold information about variable traces: */ typedef struct { - int flags; /* Operations for which Tcl command is - * to be invoked. */ + int flags; /* Operations for which Tcl command is to be + * invoked. */ size_t length; /* Number of non-NULL chars. in command. */ - char command[4]; /* Space for Tcl command to invoke. Actual - * size will be as large as necessary to - * hold command. This field must be the - * last in the structure, so that it can - * be larger than 4 bytes. */ + char command[4]; /* Space for Tcl command to invoke. Actual + * size will be as large as necessary to hold + * command. This field must be the last in the + * structure, so that it can be larger than 4 + * bytes. */ } TraceVarInfo; /* * Structure used to hold information about command traces: */ typedef struct { - int flags; /* Operations for which Tcl command is - * to be invoked. */ + int flags; /* Operations for which Tcl command is to be + * invoked. */ size_t length; /* Number of non-NULL chars. in command. */ - Tcl_Trace stepTrace; /* Used for execution traces, when tracing - * inside the given command */ - int startLevel; /* Used for bookkeeping with step execution - * traces, store the level at which the step - * trace was invoked */ - char *startCmd; /* Used for bookkeeping with step execution - * traces, store the command name which invoked - * step trace */ - int curFlags; /* Trace flags for the current command */ - int curCode; /* Return code for the current command */ - int refCount; /* Used to ensure this structure is - * not deleted too early. Keeps track - * of how many pieces of code have - * a pointer to this structure. */ - char command[4]; /* Space for Tcl command to invoke. Actual - * size will be as large as necessary to - * hold command. This field must be the - * last in the structure, so that it can - * be larger than 4 bytes. */ + Tcl_Trace stepTrace; /* Used for execution traces, when tracing + * inside the given command */ + int startLevel; /* Used for bookkeeping with step execution + * traces, store the level at which the step + * trace was invoked */ + char *startCmd; /* Used for bookkeeping with step execution + * traces, store the command name which + * invoked step trace */ + int curFlags; /* Trace flags for the current command */ + int curCode; /* Return code for the current command */ + int refCount; /* Used to ensure this structure is not + * deleted too early. Keeps track of how many + * pieces of code have a pointer to this + * structure. */ + char command[4]; /* Space for Tcl command to invoke. Actual + * size will be as large as necessary to hold + * command. This field must be the last in the + * structure, so that it can be larger than 4 + * bytes. */ } TraceCommandInfo; -/* - * Used by command execution traces. Note that we assume in the code - * that the first two defines are exactly 4 times the - * 'TCL_TRACE_ENTER_EXEC' and 'TCL_TRACE_LEAVE_EXEC' constants. - * +/* + * Used by command execution traces. Note that we assume in the code that + * TCL_TRACE_ENTER_DURING_EXEC == 4 * TCL_TRACE_ENTER_EXEC and that + * TCL_TRACE_LEAVE_DURING_EXEC == 4 * TCL_TRACE_LEAVE_EXEC. + * * TCL_TRACE_ENTER_DURING_EXEC - Trace each command inside the command - * currently being traced, before execution. + * currently being traced, before execution. * TCL_TRACE_LEAVE_DURING_EXEC - Trace each command inside the command - * currently being traced, after execution. - * TCL_TRACE_ANY_EXEC - OR'd combination of all EXEC flags. - * TCL_TRACE_EXEC_IN_PROGRESS - The callback procedure on this trace - * is currently executing. Therefore we - * don't let further traces execute. - * TCL_TRACE_EXEC_DIRECT - This execution trace is triggered directly - * by the command being traced, not because - * of an internal trace. - * The flags 'TCL_TRACE_DESTROYED' and 'TCL_INTERP_DESTROYED' may also - * be used in command execution traces. + * currently being traced, after execution. + * TCL_TRACE_ANY_EXEC - OR'd combination of all EXEC flags. + * TCL_TRACE_EXEC_IN_PROGRESS - The callback function on this trace is + * currently executing. Therefore we don't let + * further traces execute. + * TCL_TRACE_EXEC_DIRECT - This execution trace is triggered directly + * by the command being traced, not because of + * an internal trace. + * The flags 'TCL_TRACE_DESTROYED' and 'TCL_INTERP_DESTROYED' may also be used + * in command execution traces. */ + #define TCL_TRACE_ENTER_DURING_EXEC 4 #define TCL_TRACE_LEAVE_DURING_EXEC 8 -#define TCL_TRACE_ANY_EXEC 15 -#define TCL_TRACE_EXEC_IN_PROGRESS 0x10 -#define TCL_TRACE_EXEC_DIRECT 0x20 +#define TCL_TRACE_ANY_EXEC 15 +#define TCL_TRACE_EXEC_IN_PROGRESS 0x10 +#define TCL_TRACE_EXEC_DIRECT 0x20 /* - * Forward declarations for procedures defined in this file: + * Forward declarations for functions defined in this file: */ typedef int (Tcl_TraceTypeObjCmd) _ANSI_ARGS_((Tcl_Interp *interp, int optionIndex, int objc, Tcl_Obj *CONST objv[])); Tcl_TraceTypeObjCmd TclTraceVariableObjCmd; Tcl_TraceTypeObjCmd TclTraceCommandObjCmd; Tcl_TraceTypeObjCmd TclTraceExecutionObjCmd; -/* - * Each subcommand has a number of 'types' to which it can apply. - * Currently 'execution', 'command' and 'variable' are the only - * types supported. These three arrays MUST be kept in sync! - * In the future we may provide an API to add to the list of - * supported trace types. +/* + * Each subcommand has a number of 'types' to which it can apply. Currently + * 'execution', 'command' and 'variable' are the only types supported. These + * three arrays MUST be kept in sync! In the future we may provide an API to + * add to the list of supported trace types. */ + static CONST char *traceTypeOptions[] = { "execution", "command", "variable", (char*) NULL }; static Tcl_TraceTypeObjCmd* traceSubCmds[] = { TclTraceExecutionObjCmd, @@ -111,31 +112,30 @@ TclTraceCommandObjCmd, TclTraceVariableObjCmd, }; /* - * Declarations for local procedures to this file: + * Declarations for local functions to this file: */ -static int CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp, - Trace *tracePtr, Command *cmdPtr, - CONST char *command, int numChars, - int objc, Tcl_Obj *CONST objv[])); + +static int CallTraceFunction _ANSI_ARGS_((Tcl_Interp *interp, + Trace *tracePtr, Command *cmdPtr, + CONST char *command, int numChars, + int objc, Tcl_Obj *CONST objv[])); static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, CONST char *name1, - CONST char *name2, int flags)); + Tcl_Interp *interp, CONST char *name1, + CONST char *name2, int flags)); static void TraceCommandProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, CONST char *oldName, - CONST char *newName, int flags)); + CONST char *newName, int flags)); static Tcl_CmdObjTraceProc TraceExecutionProc; -static int StringTraceProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp* interp, - int level, - CONST char* command, - Tcl_Command commandInfo, - int objc, - Tcl_Obj *CONST objv[])); -static void StringTraceDeleteProc _ANSI_ARGS_((ClientData clientData)); +static int StringTraceProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp* interp, int level, + CONST char* command, Tcl_Command commandInfo, + int objc, Tcl_Obj *CONST objv[])); +static void StringTraceDeleteProc _ANSI_ARGS_(( + ClientData clientData)); static void DisposeTraceResult _ANSI_ARGS_((int flags, char *result)); /* * The following structure holds the client data for string-based @@ -142,25 +142,23 @@ * trace procs */ typedef struct StringTraceData { ClientData clientData; /* Client data from Tcl_CreateTrace */ - Tcl_CmdTraceProc* proc; /* Trace procedure from Tcl_CreateTrace */ + Tcl_CmdTraceProc* proc; /* Trace function from Tcl_CreateTrace */ } StringTraceData; /* *---------------------------------------------------------------------- * * Tcl_TraceObjCmd -- * - * This procedure is invoked to process the "trace" Tcl command. - * See the user documentation for details on what it does. - * - * Standard syntax as of Tcl 8.4 is - * - * trace {add|info|remove} {command|variable} name ops cmd + * This function is invoked to process the "trace" Tcl command. See the + * user documentation for details on what it does. * + * Standard syntax as of Tcl 8.4 is: + * trace {add|info|remove} {command|variable} name ops cmd * * Results: * A standard Tcl result. * * Side effects: @@ -178,19 +176,19 @@ { int optionIndex; char *name, *flagOps, *p; /* Main sub commands to 'trace' */ static CONST char *traceOptions[] = { - "add", "info", "remove", + "add", "info", "remove", #ifndef TCL_REMOVE_OBSOLETE_TRACES - "variable", "vdelete", "vinfo", + "variable", "vdelete", "vinfo", #endif (char *) NULL }; /* 'OLD' options are pre-Tcl-8.4 style */ enum traceOptions { - TRACE_ADD, TRACE_INFO, TRACE_REMOVE, + TRACE_ADD, TRACE_INFO, TRACE_REMOVE, #ifndef TCL_REMOVE_OBSOLETE_TRACES TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO #endif }; @@ -202,178 +200,181 @@ if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions, "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } switch ((enum traceOptions) optionIndex) { - case TRACE_ADD: - case TRACE_REMOVE: { - /* - * All sub commands of trace add/remove must take at least - * one more argument. Beyond that we let the subcommand itself - * control the argument structure. - */ - int typeIndex; - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "type ?arg arg ...?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions, - "option", 0, &typeIndex) != TCL_OK) { - return TCL_ERROR; - } - return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv); - } - case TRACE_INFO: { - /* - * All sub commands of trace info must take exactly two - * more arguments which name the type of thing being - * traced and the name of the thing being traced. - */ - int typeIndex; - if (objc < 3) { - /* - * Delegate other complaints to the type-specific code - * which can give a better error message. - */ - Tcl_WrongNumArgs(interp, 2, objv, "type name"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions, - "option", 0, &typeIndex) != TCL_OK) { - return TCL_ERROR; - } - return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv); - break; - } - -#ifndef TCL_REMOVE_OBSOLETE_TRACES - case TRACE_OLD_VARIABLE: - case TRACE_OLD_VDELETE: { - Tcl_Obj *copyObjv[6]; - Tcl_Obj *opsList; - int code, numFlags; - - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); - return TCL_ERROR; - } - - opsList = Tcl_NewObj(); - Tcl_IncrRefCount(opsList); - flagOps = Tcl_GetStringFromObj(objv[3], &numFlags); - if (numFlags == 0) { - Tcl_DecrRefCount(opsList); - goto badVarOps; - } - for (p = flagOps; *p != 0; p++) { - if (*p == 'r') { - Tcl_ListObjAppendElement(NULL, opsList, - Tcl_NewStringObj("read", -1)); - } else if (*p == 'w') { - Tcl_ListObjAppendElement(NULL, opsList, - Tcl_NewStringObj("write", -1)); - } else if (*p == 'u') { - Tcl_ListObjAppendElement(NULL, opsList, - Tcl_NewStringObj("unset", -1)); - } else if (*p == 'a') { - Tcl_ListObjAppendElement(NULL, opsList, - Tcl_NewStringObj("array", -1)); - } else { - Tcl_DecrRefCount(opsList); - goto badVarOps; - } - } - copyObjv[0] = NULL; - memcpy(copyObjv+1, objv, objc*sizeof(Tcl_Obj *)); - copyObjv[4] = opsList; - if (optionIndex == TRACE_OLD_VARIABLE) { - code = (traceSubCmds[2])(interp,TRACE_ADD,objc+1,copyObjv); - } else { - code = (traceSubCmds[2])(interp,TRACE_REMOVE,objc+1,copyObjv); - } - Tcl_DecrRefCount(opsList); - return code; - } - case TRACE_OLD_VINFO: { - ClientData clientData; - char ops[5]; - Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "name"); - return TCL_ERROR; - } - resultListPtr = Tcl_NewObj(); - clientData = 0; - name = Tcl_GetString(objv[2]); - while ((clientData = Tcl_VarTraceInfo(interp, name, 0, - TraceVarProc, clientData)) != 0) { - - TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; - - pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - p = ops; - if (tvarPtr->flags & TCL_TRACE_READS) { - *p = 'r'; - p++; - } - if (tvarPtr->flags & TCL_TRACE_WRITES) { - *p = 'w'; - p++; - } - if (tvarPtr->flags & TCL_TRACE_UNSETS) { - *p = 'u'; - p++; - } - if (tvarPtr->flags & TCL_TRACE_ARRAY) { - *p = 'a'; - p++; - } - *p = '\0'; - - /* - * Build a pair (2-item list) with the ops string as - * the first obj element and the tvarPtr->command string - * as the second obj element. Append the pair (as an - * element) to the end of the result object list. - */ - - elemObjPtr = Tcl_NewStringObj(ops, -1); - Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); - elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); - Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); - Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr); - } - Tcl_SetObjResult(interp, resultListPtr); - break; - } + case TRACE_ADD: + case TRACE_REMOVE: { + /* + * All sub commands of trace add/remove must take at least one more + * argument. Beyond that we let the subcommand itself control the + * argument structure. + */ + + int typeIndex; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "type ?arg arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions, "option", + 0, &typeIndex) != TCL_OK) { + return TCL_ERROR; + } + return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv); + } + case TRACE_INFO: { + /* + * All sub commands of trace info must take exactly two more arguments + * which name the type of thing being traced and the name of the thing + * being traced. + */ + + int typeIndex; + if (objc < 3) { + /* + * Delegate other complaints to the type-specific code which can + * give a better error message. + */ + + Tcl_WrongNumArgs(interp, 2, objv, "type name"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions, "option", + 0, &typeIndex) != TCL_OK) { + return TCL_ERROR; + } + return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv); + break; + } + +#ifndef TCL_REMOVE_OBSOLETE_TRACES + case TRACE_OLD_VARIABLE: + case TRACE_OLD_VDELETE: { + Tcl_Obj *copyObjv[6]; + Tcl_Obj *opsList; + int code, numFlags; + + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); + return TCL_ERROR; + } + + opsList = Tcl_NewObj(); + Tcl_IncrRefCount(opsList); + flagOps = Tcl_GetStringFromObj(objv[3], &numFlags); + if (numFlags == 0) { + Tcl_DecrRefCount(opsList); + goto badVarOps; + } + for (p = flagOps; *p != 0; p++) { + if (*p == 'r') { + Tcl_ListObjAppendElement(NULL, opsList, + Tcl_NewStringObj("read", -1)); + } else if (*p == 'w') { + Tcl_ListObjAppendElement(NULL, opsList, + Tcl_NewStringObj("write", -1)); + } else if (*p == 'u') { + Tcl_ListObjAppendElement(NULL, opsList, + Tcl_NewStringObj("unset", -1)); + } else if (*p == 'a') { + Tcl_ListObjAppendElement(NULL, opsList, + Tcl_NewStringObj("array", -1)); + } else { + Tcl_DecrRefCount(opsList); + goto badVarOps; + } + } + copyObjv[0] = NULL; + memcpy(copyObjv+1, objv, objc*sizeof(Tcl_Obj *)); + copyObjv[4] = opsList; + if (optionIndex == TRACE_OLD_VARIABLE) { + code = (traceSubCmds[2])(interp,TRACE_ADD,objc+1,copyObjv); + } else { + code = (traceSubCmds[2])(interp,TRACE_REMOVE,objc+1,copyObjv); + } + Tcl_DecrRefCount(opsList); + return code; + } + case TRACE_OLD_VINFO: { + ClientData clientData; + char ops[5]; + Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name"); + return TCL_ERROR; + } + resultListPtr = Tcl_NewObj(); + clientData = 0; + name = Tcl_GetString(objv[2]); + while ((clientData = Tcl_VarTraceInfo(interp, name, 0, + TraceVarProc, clientData)) != 0) { + + TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; + + pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + p = ops; + if (tvarPtr->flags & TCL_TRACE_READS) { + *p = 'r'; + p++; + } + if (tvarPtr->flags & TCL_TRACE_WRITES) { + *p = 'w'; + p++; + } + if (tvarPtr->flags & TCL_TRACE_UNSETS) { + *p = 'u'; + p++; + } + if (tvarPtr->flags & TCL_TRACE_ARRAY) { + *p = 'a'; + p++; + } + *p = '\0'; + + /* + * Build a pair (2-item list) with the ops string as the first obj + * element and the tvarPtr->command string as the second obj + * element. Append the pair (as an element) to the end of the + * result object list. + */ + + elemObjPtr = Tcl_NewStringObj(ops, -1); + Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); + elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); + Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); + Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr); + } + Tcl_SetObjResult(interp, resultListPtr); + break; + } #endif /* TCL_REMOVE_OBSOLETE_TRACES */ } return TCL_OK; - badVarOps: + badVarOps: Tcl_AppendResult(interp, "bad operations \"", flagOps, "\": should be one or more of rwua", (char *) NULL); return TCL_ERROR; } - /* *---------------------------------------------------------------------- * * TclTraceExecutionObjCmd -- * - * Helper function for Tcl_TraceObjCmd; implements the - * [trace {add|remove|info} execution ...] subcommands. - * See the user documentation for details on what these do. + * Helper function for Tcl_TraceObjCmd; implements the [trace + * {add|remove|info} execution ...] subcommands. See the user + * documentation for details on what these do. * * Results: * Standard Tcl result. * * Side effects: - * Depends on the operation (add, remove, or info) being performed; - * may add or remove command traces on a command. + * Depends on the operation (add, remove, or info) being performed; may + * add or remove command traces on a command. * *---------------------------------------------------------------------- */ int @@ -384,237 +385,243 @@ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int commandLength, index; char *name, *command; size_t length; - enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; - static CONST char *opStrings[] = { "enter", "leave", - "enterstep", "leavestep", (char *) NULL }; - enum operations { TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE, - TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP }; - - switch ((enum traceOptions) optionIndex) { - case TRACE_ADD: - case TRACE_REMOVE: { - int flags = 0; - int i, listLen, result; - Tcl_Obj **elemPtrs; - if (objc != 6) { - Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); - return TCL_ERROR; - } - /* - * Make sure the ops argument is a list object; get its length and - * a pointer to its array of element pointers. - */ - - result = Tcl_ListObjGetElements(interp, objv[4], &listLen, - &elemPtrs); - if (result != TCL_OK) { - return result; - } - if (listLen == 0) { - Tcl_SetResult(interp, "bad operation list \"\": must be " - "one or more of enter, leave, enterstep, or leavestep", - TCL_STATIC); - return TCL_ERROR; - } - for (i = 0; i < listLen; i++) { - if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, - "operation", TCL_EXACT, &index) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum operations) index) { - case TRACE_EXEC_ENTER: - flags |= TCL_TRACE_ENTER_EXEC; - break; - case TRACE_EXEC_LEAVE: - flags |= TCL_TRACE_LEAVE_EXEC; - break; - case TRACE_EXEC_ENTER_STEP: - flags |= TCL_TRACE_ENTER_DURING_EXEC; - break; - case TRACE_EXEC_LEAVE_STEP: - flags |= TCL_TRACE_LEAVE_DURING_EXEC; - break; - } - } - command = Tcl_GetStringFromObj(objv[5], &commandLength); - length = (size_t) commandLength; - if ((enum traceOptions) optionIndex == TRACE_ADD) { - TraceCommandInfo *tcmdPtr; - tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned) - (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command) - + length + 1)); - tcmdPtr->flags = flags; - tcmdPtr->stepTrace = NULL; - tcmdPtr->startLevel = 0; - tcmdPtr->startCmd = NULL; - tcmdPtr->length = length; - tcmdPtr->refCount = 1; - flags |= TCL_TRACE_DELETE; - if (flags & (TCL_TRACE_ENTER_DURING_EXEC | - TCL_TRACE_LEAVE_DURING_EXEC)) { - flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); - } - strcpy(tcmdPtr->command, command); - name = Tcl_GetString(objv[3]); - if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, - (ClientData) tcmdPtr) != TCL_OK) { - ckfree((char *) tcmdPtr); - return TCL_ERROR; - } - } else { - /* - * Search through all of our traces on this command to - * see if there's one with the given command. If so, then - * delete the first one that matches. - */ - - TraceCommandInfo *tcmdPtr; - ClientData clientData = NULL; - name = Tcl_GetString(objv[3]); - - /* First ensure the name given is valid */ - if (Tcl_FindCommand(interp, name, NULL, - TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; - } - - while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, - TraceCommandProc, clientData)) != NULL) { - tcmdPtr = (TraceCommandInfo *) clientData; - /* - * In checking the 'flags' field we must remove any - * extraneous flags which may have been temporarily - * added by various pieces of the trace mechanism. - */ - if ((tcmdPtr->length == length) - && ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC | - TCL_TRACE_RENAME | - TCL_TRACE_DELETE)) == flags) - && (strncmp(command, tcmdPtr->command, - (size_t) length) == 0)) { - flags |= TCL_TRACE_DELETE; - if (flags & (TCL_TRACE_ENTER_DURING_EXEC | - TCL_TRACE_LEAVE_DURING_EXEC)) { - flags |= (TCL_TRACE_ENTER_EXEC | - TCL_TRACE_LEAVE_EXEC); - } - Tcl_UntraceCommand(interp, name, - flags, TraceCommandProc, clientData); - if (tcmdPtr->stepTrace != NULL) { - /* - * We need to remove the interpreter-wide trace - * which we created to allow 'step' traces. - */ - Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); - tcmdPtr->stepTrace = NULL; - if (tcmdPtr->startCmd != NULL) { - ckfree((char *)tcmdPtr->startCmd); - } - } - if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { - /* Postpone deletion */ - tcmdPtr->flags = 0; - } - if ((--tcmdPtr->refCount) <= 0) { - ckfree((char*)tcmdPtr); - } - break; - } - } - } - break; - } - case TRACE_INFO: { - ClientData clientData; - Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; - if (objc != 4) { - Tcl_WrongNumArgs(interp, 3, objv, "name"); - return TCL_ERROR; - } - - clientData = NULL; - name = Tcl_GetString(objv[3]); - - /* First ensure the name given is valid */ - if (Tcl_FindCommand(interp, name, NULL, - TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; - } - - resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, - TraceCommandProc, clientData)) != NULL) { - int numOps = 0; - - TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; - - /* - * Build a list with the ops list as the first obj - * element and the tcmdPtr->command string as the - * second obj element. Append this list (as an - * element) to the end of the result object list. - */ - - elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - Tcl_IncrRefCount(elemObjPtr); - if (tcmdPtr->flags & TCL_TRACE_ENTER_EXEC) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("enter",5)); - } - if (tcmdPtr->flags & TCL_TRACE_LEAVE_EXEC) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("leave",5)); - } - if (tcmdPtr->flags & TCL_TRACE_ENTER_DURING_EXEC) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("enterstep",9)); - } - if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("leavestep",9)); - } - Tcl_ListObjLength(NULL, elemObjPtr, &numOps); - if (0 == numOps) { - Tcl_DecrRefCount(elemObjPtr); - continue; - } - eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); - Tcl_DecrRefCount(elemObjPtr); - elemObjPtr = NULL; - - Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, - Tcl_NewStringObj(tcmdPtr->command, -1)); - Tcl_ListObjAppendElement(interp, resultListPtr, - eachTraceObjPtr); - } - Tcl_SetObjResult(interp, resultListPtr); - break; - } - } - return TCL_OK; -} - + enum traceOptions { + TRACE_ADD, TRACE_INFO, TRACE_REMOVE + }; + static CONST char *opStrings[] = { + "enter", "leave", "enterstep", "leavestep", (char *) NULL + }; + enum operations { + TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE, + TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP + }; + + switch ((enum traceOptions) optionIndex) { + case TRACE_ADD: + case TRACE_REMOVE: { + int flags = 0; + int i, listLen, result; + Tcl_Obj **elemPtrs; + + if (objc != 6) { + Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); + return TCL_ERROR; + } + + /* + * Make sure the ops argument is a list object; get its length and a + * pointer to its array of element pointers. + */ + + result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); + if (result != TCL_OK) { + return result; + } + if (listLen == 0) { + Tcl_SetResult(interp, "bad operation list \"\": must be " + "one or more of enter, leave, enterstep, or leavestep", + TCL_STATIC); + return TCL_ERROR; + } + for (i = 0; i < listLen; i++) { + if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, + "operation", TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum operations) index) { + case TRACE_EXEC_ENTER: + flags |= TCL_TRACE_ENTER_EXEC; + break; + case TRACE_EXEC_LEAVE: + flags |= TCL_TRACE_LEAVE_EXEC; + break; + case TRACE_EXEC_ENTER_STEP: + flags |= TCL_TRACE_ENTER_DURING_EXEC; + break; + case TRACE_EXEC_LEAVE_STEP: + flags |= TCL_TRACE_LEAVE_DURING_EXEC; + break; + } + } + command = Tcl_GetStringFromObj(objv[5], &commandLength); + length = (size_t) commandLength; + if ((enum traceOptions) optionIndex == TRACE_ADD) { + TraceCommandInfo *tcmdPtr; + + tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned) + (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command) + + length + 1)); + tcmdPtr->flags = flags; + tcmdPtr->stepTrace = NULL; + tcmdPtr->startLevel = 0; + tcmdPtr->startCmd = NULL; + tcmdPtr->length = length; + tcmdPtr->refCount = 1; + flags |= TCL_TRACE_DELETE; + if (flags & (TCL_TRACE_ENTER_DURING_EXEC | + TCL_TRACE_LEAVE_DURING_EXEC)) { + flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); + } + strcpy(tcmdPtr->command, command); + name = Tcl_GetString(objv[3]); + if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, + (ClientData) tcmdPtr) != TCL_OK) { + ckfree((char *) tcmdPtr); + return TCL_ERROR; + } + } else { + /* + * Search through all of our traces on this command to see if + * there's one with the given command. If so, then delete the + * first one that matches. + */ + + TraceCommandInfo *tcmdPtr; + ClientData clientData = NULL; + name = Tcl_GetString(objv[3]); + + /* First ensure the name given is valid */ + if (Tcl_FindCommand(interp, name, NULL, + TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + + while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, + TraceCommandProc, clientData)) != NULL) { + tcmdPtr = (TraceCommandInfo *) clientData; + + /* + * In checking the 'flags' field we must remove any extraneous + * flags which may have been temporarily added by various + * pieces of the trace mechanism. + */ + + if ((tcmdPtr->length == length) + && ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC | + TCL_TRACE_RENAME | TCL_TRACE_DELETE)) == flags) + && (strncmp(command, tcmdPtr->command, + (size_t) length) == 0)) { + flags |= TCL_TRACE_DELETE; + if (flags & (TCL_TRACE_ENTER_DURING_EXEC | + TCL_TRACE_LEAVE_DURING_EXEC)) { + flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); + } + Tcl_UntraceCommand(interp, name, flags, + TraceCommandProc, clientData); + if (tcmdPtr->stepTrace != NULL) { + /* + * We need to remove the interpreter-wide trace which + * we created to allow 'step' traces. + */ + + Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); + tcmdPtr->stepTrace = NULL; + if (tcmdPtr->startCmd != NULL) { + ckfree((char *)tcmdPtr->startCmd); + } + } + if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { + /* Postpone deletion */ + tcmdPtr->flags = 0; + } + if ((--tcmdPtr->refCount) <= 0) { + ckfree((char*)tcmdPtr); + } + break; + } + } + } + break; + } + case TRACE_INFO: { + ClientData clientData; + Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 3, objv, "name"); + return TCL_ERROR; + } + + clientData = NULL; + name = Tcl_GetString(objv[3]); + + /* First ensure the name given is valid */ + if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + + resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, + TraceCommandProc, clientData)) != NULL) { + int numOps = 0; + + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; + + /* + * Build a list with the ops list as the first obj element and the + * tcmdPtr->command string as the second obj element. Append this + * list (as an element) to the end of the result object list. + */ + + elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + Tcl_IncrRefCount(elemObjPtr); + if (tcmdPtr->flags & TCL_TRACE_ENTER_EXEC) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("enter",5)); + } + if (tcmdPtr->flags & TCL_TRACE_LEAVE_EXEC) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("leave",5)); + } + if (tcmdPtr->flags & TCL_TRACE_ENTER_DURING_EXEC) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("enterstep",9)); + } + if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("leavestep",9)); + } + Tcl_ListObjLength(NULL, elemObjPtr, &numOps); + if (0 == numOps) { + Tcl_DecrRefCount(elemObjPtr); + continue; + } + eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); + Tcl_DecrRefCount(elemObjPtr); + elemObjPtr = NULL; + + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, + Tcl_NewStringObj(tcmdPtr->command, -1)); + Tcl_ListObjAppendElement(interp, resultListPtr, + eachTraceObjPtr); + } + Tcl_SetObjResult(interp, resultListPtr); + break; + } + } + return TCL_OK; +} /* *---------------------------------------------------------------------- * * TclTraceCommandObjCmd -- * - * Helper function for Tcl_TraceObjCmd; implements the - * [trace {add|info|remove} command ...] subcommands. - * See the user documentation for details on what these do. + * Helper function for Tcl_TraceObjCmd; implements the [trace + * {add|info|remove} command ...] subcommands. See the user documentation + * for details on what these do. * * Results: * Standard Tcl result. * * Side effects: - * Depends on the operation (add, remove, or info) being performed; - * may add or remove command traces on a command. + * Depends on the operation (add, remove, or info) being performed; may + * add or remove command traces on a command. * *---------------------------------------------------------------------- */ int @@ -628,186 +635,186 @@ char *name, *command; size_t length; enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; static CONST char *opStrings[] = { "delete", "rename", (char *) NULL }; enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME }; - - switch ((enum traceOptions) optionIndex) { - case TRACE_ADD: - case TRACE_REMOVE: { - int flags = 0; - int i, listLen, result; - Tcl_Obj **elemPtrs; - if (objc != 6) { - Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); - return TCL_ERROR; - } - /* - * Make sure the ops argument is a list object; get its length and - * a pointer to its array of element pointers. - */ - - result = Tcl_ListObjGetElements(interp, objv[4], &listLen, - &elemPtrs); - if (result != TCL_OK) { - return result; - } - if (listLen == 0) { - Tcl_SetResult(interp, "bad operation list \"\": must be " - "one or more of delete or rename", TCL_STATIC); - return TCL_ERROR; - } - for (i = 0; i < listLen; i++) { - if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, - "operation", TCL_EXACT, &index) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum operations) index) { - case TRACE_CMD_RENAME: - flags |= TCL_TRACE_RENAME; - break; - case TRACE_CMD_DELETE: - flags |= TCL_TRACE_DELETE; - break; - } - } - command = Tcl_GetStringFromObj(objv[5], &commandLength); - length = (size_t) commandLength; - if ((enum traceOptions) optionIndex == TRACE_ADD) { - TraceCommandInfo *tcmdPtr; - tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned) - (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command) - + length + 1)); - tcmdPtr->flags = flags; - tcmdPtr->stepTrace = NULL; - tcmdPtr->startLevel = 0; - tcmdPtr->startCmd = NULL; - tcmdPtr->length = length; - tcmdPtr->refCount = 1; - flags |= TCL_TRACE_DELETE; - strcpy(tcmdPtr->command, command); - name = Tcl_GetString(objv[3]); - if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, - (ClientData) tcmdPtr) != TCL_OK) { - ckfree((char *) tcmdPtr); - return TCL_ERROR; - } - } else { - /* - * Search through all of our traces on this command to - * see if there's one with the given command. If so, then - * delete the first one that matches. - */ - - TraceCommandInfo *tcmdPtr; - ClientData clientData = NULL; - name = Tcl_GetString(objv[3]); - - /* First ensure the name given is valid */ - if (Tcl_FindCommand(interp, name, NULL, - TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; - } - - while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, - TraceCommandProc, clientData)) != NULL) { - tcmdPtr = (TraceCommandInfo *) clientData; - if ((tcmdPtr->length == length) - && (tcmdPtr->flags == flags) - && (strncmp(command, tcmdPtr->command, - (size_t) length) == 0)) { - Tcl_UntraceCommand(interp, name, - flags | TCL_TRACE_DELETE, - TraceCommandProc, clientData); - tcmdPtr->flags |= TCL_TRACE_DESTROYED; - if ((--tcmdPtr->refCount) <= 0) { - ckfree((char *) tcmdPtr); - } - break; - } - } - } - break; - } - case TRACE_INFO: { - ClientData clientData; - Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; - if (objc != 4) { - Tcl_WrongNumArgs(interp, 3, objv, "name"); - return TCL_ERROR; - } - - clientData = NULL; - name = Tcl_GetString(objv[3]); - - /* First ensure the name given is valid */ - if (Tcl_FindCommand(interp, name, NULL, - TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; - } - - resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, - TraceCommandProc, clientData)) != NULL) { - int numOps = 0; - - TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; - - /* - * Build a list with the ops list as - * the first obj element and the tcmdPtr->command string - * as the second obj element. Append this list (as an - * element) to the end of the result object list. - */ - - elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - Tcl_IncrRefCount(elemObjPtr); - if (tcmdPtr->flags & TCL_TRACE_RENAME) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("rename",6)); - } - if (tcmdPtr->flags & TCL_TRACE_DELETE) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("delete",6)); - } - Tcl_ListObjLength(NULL, elemObjPtr, &numOps); - if (0 == numOps) { - Tcl_DecrRefCount(elemObjPtr); - continue; - } - eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); - Tcl_DecrRefCount(elemObjPtr); - - elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1); - Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); - Tcl_ListObjAppendElement(interp, resultListPtr, - eachTraceObjPtr); - } - Tcl_SetObjResult(interp, resultListPtr); - break; - } - } - return TCL_OK; -} - + + switch ((enum traceOptions) optionIndex) { + case TRACE_ADD: + case TRACE_REMOVE: { + int flags = 0; + int i, listLen, result; + Tcl_Obj **elemPtrs; + + if (objc != 6) { + Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); + return TCL_ERROR; + } + + /* + * Make sure the ops argument is a list object; get its length and a + * pointer to its array of element pointers. + */ + + result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); + if (result != TCL_OK) { + return result; + } + if (listLen == 0) { + Tcl_SetResult(interp, "bad operation list \"\": must be " + "one or more of delete or rename", TCL_STATIC); + return TCL_ERROR; + } + + for (i = 0; i < listLen; i++) { + if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, + "operation", TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum operations) index) { + case TRACE_CMD_RENAME: + flags |= TCL_TRACE_RENAME; + break; + case TRACE_CMD_DELETE: + flags |= TCL_TRACE_DELETE; + break; + } + } + + command = Tcl_GetStringFromObj(objv[5], &commandLength); + length = (size_t) commandLength; + if ((enum traceOptions) optionIndex == TRACE_ADD) { + TraceCommandInfo *tcmdPtr; + + tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned) + (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command) + + length + 1)); + tcmdPtr->flags = flags; + tcmdPtr->stepTrace = NULL; + tcmdPtr->startLevel = 0; + tcmdPtr->startCmd = NULL; + tcmdPtr->length = length; + tcmdPtr->refCount = 1; + flags |= TCL_TRACE_DELETE; + strcpy(tcmdPtr->command, command); + name = Tcl_GetString(objv[3]); + if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, + (ClientData) tcmdPtr) != TCL_OK) { + ckfree((char *) tcmdPtr); + return TCL_ERROR; + } + } else { + /* + * Search through all of our traces on this command to see if + * there's one with the given command. If so, then delete the + * first one that matches. + */ + + TraceCommandInfo *tcmdPtr; + ClientData clientData = NULL; + name = Tcl_GetString(objv[3]); + + /* First ensure the name given is valid */ + if (Tcl_FindCommand(interp, name, NULL, + TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + + while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, + TraceCommandProc, clientData)) != NULL) { + tcmdPtr = (TraceCommandInfo *) clientData; + if ((tcmdPtr->length == length) + && (tcmdPtr->flags == flags) + && (strncmp(command, tcmdPtr->command, + (size_t) length) == 0)) { + Tcl_UntraceCommand(interp, name, flags | TCL_TRACE_DELETE, + TraceCommandProc, clientData); + tcmdPtr->flags |= TCL_TRACE_DESTROYED; + if ((--tcmdPtr->refCount) <= 0) { + ckfree((char *) tcmdPtr); + } + break; + } + } + } + break; + } + case TRACE_INFO: { + ClientData clientData; + Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 3, objv, "name"); + return TCL_ERROR; + } + + clientData = NULL; + name = Tcl_GetString(objv[3]); + + /* First ensure the name given is valid */ + if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + + resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, + TraceCommandProc, clientData)) != NULL) { + int numOps = 0; + + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; + + /* + * Build a list with the ops list as the first obj element and the + * tcmdPtr->command string as the second obj element. Append this + * list (as an element) to the end of the result object list. + */ + + elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + Tcl_IncrRefCount(elemObjPtr); + if (tcmdPtr->flags & TCL_TRACE_RENAME) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("rename",6)); + } + if (tcmdPtr->flags & TCL_TRACE_DELETE) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("delete",6)); + } + Tcl_ListObjLength(NULL, elemObjPtr, &numOps); + if (0 == numOps) { + Tcl_DecrRefCount(elemObjPtr); + continue; + } + eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); + Tcl_DecrRefCount(elemObjPtr); + + elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1); + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); + Tcl_ListObjAppendElement(interp, resultListPtr, eachTraceObjPtr); + } + Tcl_SetObjResult(interp, resultListPtr); + break; + } + } + return TCL_OK; +} /* *---------------------------------------------------------------------- * * TclTraceVariableObjCmd -- * - * Helper function for Tcl_TraceObjCmd; implements the - * [trace {add|info|remove} variable ...] subcommands. - * See the user documentation for details on what these do. + * Helper function for Tcl_TraceObjCmd; implements the [trace + * {add|info|remove} variable ...] subcommands. See the user + * documentation for details on what these do. * * Results: * Standard Tcl result. * * Side effects: - * Depends on the operation (add, remove, or info) being performed; - * may add or remove variable traces on a variable. + * Depends on the operation (add, remove, or info) being performed; may + * add or remove variable traces on a variable. * *---------------------------------------------------------------------- */ int @@ -819,184 +826,183 @@ { int commandLength, index; char *name, *command; size_t length; enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; - static CONST char *opStrings[] = { "array", "read", "unset", "write", - (char *) NULL }; - enum operations { TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET, - TRACE_VAR_WRITE }; - - switch ((enum traceOptions) optionIndex) { - case TRACE_ADD: - case TRACE_REMOVE: { - int flags = 0; - int i, listLen, result; - Tcl_Obj **elemPtrs; - if (objc != 6) { - Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); - return TCL_ERROR; - } - /* - * Make sure the ops argument is a list object; get its length and - * a pointer to its array of element pointers. - */ - - result = Tcl_ListObjGetElements(interp, objv[4], &listLen, - &elemPtrs); - if (result != TCL_OK) { - return result; - } - if (listLen == 0) { - Tcl_SetResult(interp, "bad operation list \"\": must be " - "one or more of array, read, unset, or write", - TCL_STATIC); - return TCL_ERROR; - } - for (i = 0; i < listLen ; i++) { - if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, - "operation", TCL_EXACT, &index) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum operations) index) { - case TRACE_VAR_ARRAY: - flags |= TCL_TRACE_ARRAY; - break; - case TRACE_VAR_READ: - flags |= TCL_TRACE_READS; - break; - case TRACE_VAR_UNSET: - flags |= TCL_TRACE_UNSETS; - break; - case TRACE_VAR_WRITE: - flags |= TCL_TRACE_WRITES; - break; - } - } - command = Tcl_GetStringFromObj(objv[5], &commandLength); - length = (size_t) commandLength; - if ((enum traceOptions) optionIndex == TRACE_ADD) { - TraceVarInfo *tvarPtr; - tvarPtr = (TraceVarInfo *) ckalloc((unsigned) - (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) - + length + 1)); - tvarPtr->flags = flags; - if (objv[0] == NULL) { - tvarPtr->flags |= TCL_TRACE_OLD_STYLE; - } - tvarPtr->length = length; - flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT; - strcpy(tvarPtr->command, command); - name = Tcl_GetString(objv[3]); - if (Tcl_TraceVar(interp, name, flags, TraceVarProc, - (ClientData) tvarPtr) != TCL_OK) { - ckfree((char *) tvarPtr); - return TCL_ERROR; - } - } else { - /* - * Search through all of our traces on this variable to - * see if there's one with the given command. If so, then - * delete the first one that matches. - */ - - TraceVarInfo *tvarPtr; - ClientData clientData = 0; - name = Tcl_GetString(objv[3]); - while ((clientData = Tcl_VarTraceInfo(interp, name, 0, - TraceVarProc, clientData)) != 0) { - tvarPtr = (TraceVarInfo *) clientData; - if ((tvarPtr->length == length) - && ((tvarPtr->flags & ~TCL_TRACE_OLD_STYLE)==flags) - && (strncmp(command, tvarPtr->command, - (size_t) length) == 0)) { - Tcl_UntraceVar2(interp, name, NULL, - flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, - TraceVarProc, clientData); - Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC); - break; - } - } - } - break; - } - case TRACE_INFO: { - ClientData clientData; - Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; - if (objc != 4) { - Tcl_WrongNumArgs(interp, 3, objv, "name"); - return TCL_ERROR; - } - - resultListPtr = Tcl_NewObj(); - clientData = 0; - name = Tcl_GetString(objv[3]); - while ((clientData = Tcl_VarTraceInfo(interp, name, 0, - TraceVarProc, clientData)) != 0) { - - TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; - - /* - * Build a list with the ops list as - * the first obj element and the tcmdPtr->command string - * as the second obj element. Append this list (as an - * element) to the end of the result object list. - */ - - elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - if (tvarPtr->flags & TCL_TRACE_ARRAY) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("array", 5)); - } - if (tvarPtr->flags & TCL_TRACE_READS) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("read", 4)); - } - if (tvarPtr->flags & TCL_TRACE_WRITES) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("write", 5)); - } - if (tvarPtr->flags & TCL_TRACE_UNSETS) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("unset", 5)); - } - eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); - - elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); - Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); - Tcl_ListObjAppendElement(interp, resultListPtr, - eachTraceObjPtr); - } - Tcl_SetObjResult(interp, resultListPtr); - break; - } - } - return TCL_OK; -} - + static CONST char *opStrings[] = { + "array", "read", "unset", "write", (char *) NULL + }; + enum operations { + TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET, TRACE_VAR_WRITE + }; + + switch ((enum traceOptions) optionIndex) { + case TRACE_ADD: + case TRACE_REMOVE: { + int flags = 0; + int i, listLen, result; + Tcl_Obj **elemPtrs; + + if (objc != 6) { + Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); + return TCL_ERROR; + } + + /* + * Make sure the ops argument is a list object; get its length and a + * pointer to its array of element pointers. + */ + + result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); + if (result != TCL_OK) { + return result; + } + if (listLen == 0) { + Tcl_SetResult(interp, "bad operation list \"\": must be " + "one or more of array, read, unset, or write", TCL_STATIC); + return TCL_ERROR; + } + for (i = 0; i < listLen ; i++) { + if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, + "operation", TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum operations) index) { + case TRACE_VAR_ARRAY: + flags |= TCL_TRACE_ARRAY; + break; + case TRACE_VAR_READ: + flags |= TCL_TRACE_READS; + break; + case TRACE_VAR_UNSET: + flags |= TCL_TRACE_UNSETS; + break; + case TRACE_VAR_WRITE: + flags |= TCL_TRACE_WRITES; + break; + } + } + command = Tcl_GetStringFromObj(objv[5], &commandLength); + length = (size_t) commandLength; + if ((enum traceOptions) optionIndex == TRACE_ADD) { + TraceVarInfo *tvarPtr; + tvarPtr = (TraceVarInfo *) ckalloc((unsigned) + (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + + length + 1)); + tvarPtr->flags = flags; + if (objv[0] == NULL) { + tvarPtr->flags |= TCL_TRACE_OLD_STYLE; + } + tvarPtr->length = length; + flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT; + strcpy(tvarPtr->command, command); + name = Tcl_GetString(objv[3]); + if (Tcl_TraceVar(interp, name, flags, TraceVarProc, + (ClientData) tvarPtr) != TCL_OK) { + ckfree((char *) tvarPtr); + return TCL_ERROR; + } + } else { + /* + * Search through all of our traces on this variable to see if + * there's one with the given command. If so, then delete the + * first one that matches. + */ + + TraceVarInfo *tvarPtr; + ClientData clientData = 0; + name = Tcl_GetString(objv[3]); + while ((clientData = Tcl_VarTraceInfo(interp, name, 0, + TraceVarProc, clientData)) != 0) { + tvarPtr = (TraceVarInfo *) clientData; + if ((tvarPtr->length == length) + && ((tvarPtr->flags & ~TCL_TRACE_OLD_STYLE)==flags) + && (strncmp(command, tvarPtr->command, + (size_t) length) == 0)) { + Tcl_UntraceVar2(interp, name, NULL, + flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, + TraceVarProc, clientData); + Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC); + break; + } + } + } + break; + } + case TRACE_INFO: { + ClientData clientData; + Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 3, objv, "name"); + return TCL_ERROR; + } + + resultListPtr = Tcl_NewObj(); + clientData = 0; + name = Tcl_GetString(objv[3]); + while ((clientData = Tcl_VarTraceInfo(interp, name, 0, TraceVarProc, + clientData)) != 0) { + + TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; + + /* + * Build a list with the ops list as the first obj element and the + * tcmdPtr->command string as the second obj element. Append this + * list (as an element) to the end of the result object list. + */ + + elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + if (tvarPtr->flags & TCL_TRACE_ARRAY) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("array", 5)); + } + if (tvarPtr->flags & TCL_TRACE_READS) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("read", 4)); + } + if (tvarPtr->flags & TCL_TRACE_WRITES) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("write", 5)); + } + if (tvarPtr->flags & TCL_TRACE_UNSETS) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("unset", 5)); + } + eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); + + elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); + Tcl_ListObjAppendElement(interp, resultListPtr, + eachTraceObjPtr); + } + Tcl_SetObjResult(interp, resultListPtr); + break; + } + } + return TCL_OK; +} /* *---------------------------------------------------------------------- * * Tcl_CommandTraceInfo -- * - * Return the clientData value associated with a trace on a - * command. This procedure can also be used to step through - * all of the traces on a particular command that have the - * same trace procedure. + * Return the clientData value associated with a trace on a command. + * This function can also be used to step through all of the traces on a + * particular command that have the same trace function. * * Results: - * The return value is the clientData value associated with - * a trace on the given command. Information will only be - * returned for a trace with proc as trace procedure. If - * the clientData argument is NULL then the first such trace is - * returned; otherwise, the next relevant one after the one - * given by clientData will be returned. If the command - * doesn't exist then an error message is left in the interpreter - * and NULL is returned. Also, if there are no (more) traces for - * the given command, NULL is returned. + * The return value is the clientData value associated with a trace on + * the given command. Information will only be returned for a trace with + * proc as trace function. If the clientData argument is NULL then the + * first such trace is returned; otherwise, the next relevant one after + * the one given by clientData will be returned. If the command doesn't + * exist then an error message is left in the interpreter and NULL is + * returned. Also, if there are no (more) traces for the given command, + * NULL is returned. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -1006,22 +1012,21 @@ Tcl_CommandTraceInfo(interp, cmdName, flags, proc, prevClientData) Tcl_Interp *interp; /* Interpreter containing command. */ CONST char *cmdName; /* Name of command. */ int flags; /* OR-ed combo or TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY (can be 0). */ - Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */ - ClientData prevClientData; /* If non-NULL, gives last value returned - * by this procedure, so this call will - * return the next trace after that one. - * If NULL, this call will return the - * first trace. */ + Tcl_CommandTraceProc *proc; /* Function assocated with trace. */ + ClientData prevClientData; /* If non-NULL, gives last value returned by + * this function, so this call will return the + * next trace after that one. If NULL, this + * call will return the first trace. */ { Command *cmdPtr; register CommandTrace *tracePtr; - cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, - NULL, TCL_LEAVE_ERR_MSG); + cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL, + TCL_LEAVE_ERR_MSG); if (cmdPtr == NULL) { return NULL; } /* @@ -1028,19 +1033,19 @@ * Find the relevant trace, if any, and return its clientData. */ tracePtr = cmdPtr->tracePtr; if (prevClientData != NULL) { - for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { + for (; tracePtr!=NULL ; tracePtr=tracePtr->nextPtr) { if ((tracePtr->clientData == prevClientData) && (tracePtr->traceProc == proc)) { tracePtr = tracePtr->nextPtr; break; } } } - for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { + for (; tracePtr!=NULL ; tracePtr=tracePtr->nextPtr) { if (tracePtr->traceProc == proc) { return tracePtr->clientData; } } return NULL; @@ -1049,45 +1054,44 @@ /* *---------------------------------------------------------------------- * * Tcl_TraceCommand -- * - * Arrange for rename/deletes to a command to cause a - * procedure to be invoked, which can monitor the operations. - * - * Also optionally arrange for execution of that command - * to cause a procedure to be invoked. + * Arrange for rename/deletes to a command to cause a function to be + * invoked, which can monitor the operations. + * + * Also optionally arrange for execution of that command to cause a + * function to be invoked. * * Results: * A standard Tcl return value. * * Side effects: - * A trace is set up on the command given by cmdName, such that - * future changes to the command will be intermediated by - * proc. See the manual entry for complete details on the calling - * sequence for proc. + * A trace is set up on the command given by cmdName, such that future + * changes to the command will be intermediated by proc. See the manual + * entry for complete details on the calling sequence for proc. * *---------------------------------------------------------------------- */ int Tcl_TraceCommand(interp, cmdName, flags, proc, clientData) - Tcl_Interp *interp; /* Interpreter in which command is - * to be traced. */ + Tcl_Interp *interp; /* Interpreter in which command is to be + * traced. */ CONST char *cmdName; /* Name of command. */ - int flags; /* OR-ed collection of bits, including any - * of TCL_TRACE_RENAME, TCL_TRACE_DELETE, - * and any of the TRACE_*_EXEC flags */ - Tcl_CommandTraceProc *proc; /* Procedure to call when specified ops are + int flags; /* OR-ed collection of bits, including any of + * TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any + * of the TRACE_*_EXEC flags */ + Tcl_CommandTraceProc *proc; /* Function to call when specified ops are * invoked upon cmdName. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { Command *cmdPtr; register CommandTrace *tracePtr; - cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, - NULL, TCL_LEAVE_ERR_MSG); + cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL, + TCL_LEAVE_ERR_MSG); if (cmdPtr == NULL) { return TCL_ERROR; } /* @@ -1095,17 +1099,17 @@ */ tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace)); tracePtr->traceProc = proc; tracePtr->clientData = clientData; - tracePtr->flags = flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE - | TCL_TRACE_ANY_EXEC); + tracePtr->flags = flags & + (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC); tracePtr->nextPtr = cmdPtr->tracePtr; tracePtr->refCount = 1; cmdPtr->tracePtr = tracePtr; if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { - cmdPtr->flags |= CMD_HAS_EXEC_TRACES; + cmdPtr->flags |= CMD_HAS_EXEC_TRACES; } return TCL_OK; } /* @@ -1117,104 +1121,109 @@ * * Results: * None. * * Side effects: - * If there exists a trace for the command given by cmdName - * with the given flags, proc, and clientData, then that trace - * is removed. + * If there exists a trace for the command given by cmdName with the + * given flags, proc, and clientData, then that trace is removed. * *---------------------------------------------------------------------- */ void Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData) Tcl_Interp *interp; /* Interpreter containing command. */ CONST char *cmdName; /* Name of command. */ - int flags; /* OR-ed collection of bits, including any - * of TCL_TRACE_RENAME, TCL_TRACE_DELETE, - * and any of the TRACE_*_EXEC flags */ - Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */ + int flags; /* OR-ed collection of bits, including any of + * TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any + * of the TRACE_*_EXEC flags */ + Tcl_CommandTraceProc *proc; /* Function assocated with trace. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { register CommandTrace *tracePtr; CommandTrace *prevPtr; Command *cmdPtr; Interp *iPtr = (Interp *) interp; ActiveCommandTrace *activePtr; int hasExecTraces = 0; - - cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, - NULL, TCL_LEAVE_ERR_MSG); + + cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, NULL, + TCL_LEAVE_ERR_MSG); if (cmdPtr == NULL) { return; } flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC); for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; ; - prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { + prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { if (tracePtr == NULL) { return; } - if ((tracePtr->traceProc == proc) - && ((tracePtr->flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE | - TCL_TRACE_ANY_EXEC)) == flags) + if ((tracePtr->traceProc == proc) + && ((tracePtr->flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE | + TCL_TRACE_ANY_EXEC)) == flags) && (tracePtr->clientData == clientData)) { if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { hasExecTraces = 1; } break; } } - + /* - * The code below makes it possible to delete traces while traces - * are active: it makes sure that the deleted trace won't be - * processed by CallCommandTraces. + * The code below makes it possible to delete traces while traces are + * active: it makes sure that the deleted trace won't be processed by + * CallCommandTraces. */ for (activePtr = iPtr->activeCmdTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { + activePtr = activePtr->nextPtr) { if (activePtr->nextTracePtr == tracePtr) { - activePtr->nextTracePtr = tracePtr->nextPtr; + if (activePtr->reverseScan) { + activePtr->nextTracePtr = prevPtr; + } else { + activePtr->nextTracePtr = tracePtr->nextPtr; + } } } if (prevPtr == NULL) { cmdPtr->tracePtr = tracePtr->nextPtr; } else { prevPtr->nextPtr = tracePtr->nextPtr; } tracePtr->flags = 0; - + if ((--tracePtr->refCount) <= 0) { ckfree((char*)tracePtr); } - + if (hasExecTraces) { for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; tracePtr != NULL ; - prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { + prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { - return; + return; } } - /* - * None of the remaining traces on this command are execution - * traces. We therefore remove this flag: + + /* + * None of the remaining traces on this command are execution traces. + * We therefore remove this flag: */ + cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES; } } /* *---------------------------------------------------------------------- * * TraceCommandProc -- * - * This procedure is called to handle command changes that have - * been traced using the "trace" command, when using the - * 'rename' or 'delete' options. + * This function is called to handle command changes that have been + * traced using the "trace" command, when using the 'rename' or 'delete' + * options. * * Results: * None. * * Side effects: @@ -1227,27 +1236,27 @@ static void TraceCommandProc(clientData, interp, oldName, newName, flags) ClientData clientData; /* Information about the command trace. */ Tcl_Interp *interp; /* Interpreter containing command. */ CONST char *oldName; /* Name of command being changed. */ - CONST char *newName; /* New name of command. Empty string - * or NULL means command is being deleted - * (renamed to ""). */ + CONST char *newName; /* New name of command. Empty string or NULL + * means command is being deleted (renamed to + * ""). */ int flags; /* OR-ed bits giving operation and other * information. */ { TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; int code; Tcl_DString cmd; - + tcmdPtr->refCount++; - + if ((tcmdPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED) && !Tcl_LimitExceeded(interp)) { /* - * Generate a command to execute by appending list elements - * for the old and new command name and the operation. + * Generate a command to execute by appending list elements for the + * old and new command name and the operation. */ Tcl_DStringInit(&cmd); Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length); Tcl_DStringAppendElement(&cmd, oldName); @@ -1257,113 +1266,127 @@ } else if (flags & TCL_TRACE_DELETE) { Tcl_DStringAppend(&cmd, " delete", 7); } /* - * Execute the command. - * We discard any object result the command returns. + * Execute the command. We discard any object result the command + * returns. * - * Add the TCL_TRACE_DESTROYED flag to tcmdPtr to indicate to - * other areas that this will be destroyed by us, otherwise a - * double-free might occur depending on what the eval does. + * Add the TCL_TRACE_DESTROYED flag to tcmdPtr to indicate to other + * areas that this will be destroyed by us, otherwise a double-free + * might occur depending on what the eval does. */ if (flags & TCL_TRACE_DESTROYED) { tcmdPtr->flags |= TCL_TRACE_DESTROYED; } code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), Tcl_DStringLength(&cmd), 0); - if (code != TCL_OK) { + if (code != TCL_OK) { /* We ignore errors in these traced commands */ /*** QUESTION: Use Tcl_BackgroundError(interp); instead? ***/ } Tcl_DStringFree(&cmd); } + /* * We delete when the trace was destroyed or if this is a delete trace, * because command deletes are unconditional, so the trace must go away. */ + if (flags & (TCL_TRACE_DESTROYED | TCL_TRACE_DELETE)) { int untraceFlags = tcmdPtr->flags; + Tcl_InterpState state; if (tcmdPtr->stepTrace != NULL) { Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; - if (tcmdPtr->startCmd != NULL) { - ckfree((char *)tcmdPtr->startCmd); + if (tcmdPtr->startCmd != NULL) { + ckfree((char *)tcmdPtr->startCmd); } } if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { - /* Postpone deletion, until exec trace returns */ + /* + * Postpone deletion, until exec trace returns. + */ + tcmdPtr->flags = 0; } + /* - * We need to construct the same flags for Tcl_UntraceCommand - * as were passed to Tcl_TraceCommand. Reproduce the processing - * of [trace add execution/command]. Be careful to keep this - * code in sync with that. + * We need to construct the same flags for Tcl_UntraceCommand as were + * passed to Tcl_TraceCommand. Reproduce the processing of [trace add + * execution/command]. Be careful to keep this code in sync with that. */ + if (untraceFlags & TCL_TRACE_ANY_EXEC) { untraceFlags |= TCL_TRACE_DELETE; - if (untraceFlags & (TCL_TRACE_ENTER_DURING_EXEC + if (untraceFlags & (TCL_TRACE_ENTER_DURING_EXEC | TCL_TRACE_LEAVE_DURING_EXEC)) { untraceFlags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); } } else if (untraceFlags & TCL_TRACE_RENAME) { untraceFlags |= TCL_TRACE_DELETE; } + /* * Remove the trace since TCL_TRACE_DESTROYED tells us to, or the - * command we're tracing has just gone away. Then decrement the + * command we're tracing has just gone away. Then decrement the * clientData refCount that was set up by trace creation. + * + * Note that we save the (return) state of the interpreter to prevent + * bizarre error messages. */ + + state = Tcl_SaveInterpState(interp, TCL_OK); Tcl_UntraceCommand(interp, oldName, untraceFlags, TraceCommandProc, clientData); + (void) Tcl_RestoreInterpState(interp, state); tcmdPtr->refCount--; } if ((--tcmdPtr->refCount) <= 0) { - ckfree((char*)tcmdPtr); + ckfree((char*)tcmdPtr); } return; } /* *---------------------------------------------------------------------- * * TclCheckExecutionTraces -- * - * Checks on all current command execution traces, and invokes - * procedures which have been registered. This procedure can be - * used by other code which performs execution to unify the - * tracing system, so that execution traces will function for that - * other code. - * - * For instance extensions like [incr Tcl] which use their - * own execution technique can make use of Tcl's tracing. - * - * This procedure is called by 'TclEvalObjvInternal' + * Checks on all current command execution traces, and invokes functions + * which have been registered. This function can be used by other code + * which performs execution to unify the tracing system, so that + * execution traces will function for that other code. + * + * For instance extensions like [incr Tcl] which use their own execution + * technique can make use of Tcl's tracing. + * + * This function is called by 'TclEvalObjvInternal' * * Results: - * The return value is a standard Tcl completion code such as - * TCL_OK or TCL_ERROR, etc. + * The return value is a standard Tcl completion code such as TCL_OK or + * TCL_ERROR, etc. * * Side effects: - * Those side effects made by any trace procedures called. + * Those side effects made by any trace functions called. * *---------------------------------------------------------------------- */ -int -TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, - traceFlags, objc, objv) + +int +TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, traceFlags, + objc, objv) Tcl_Interp *interp; /* The current interpreter. */ - CONST char *command; /* Pointer to beginning of the current - * command string. */ - int numChars; /* The number of characters in 'command' - * which are part of the command string. */ + CONST char *command; /* Pointer to beginning of the current command + * string. */ + int numChars; /* The number of characters in 'command' which + * are part of the command string. */ Command *cmdPtr; /* Points to command's Command struct. */ - int code; /* The current result code. */ - int traceFlags; /* Current tracing situation. */ + int code; /* The current result code. */ + int traceFlags; /* Current tracing situation. */ int objc; /* Number of arguments for the command. */ Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; CommandTrace *tracePtr, *lastTracePtr; @@ -1370,51 +1393,58 @@ ActiveCommandTrace active; int curLevel; int traceCode = TCL_OK; TraceCommandInfo* tcmdPtr; Tcl_InterpState state = NULL; - + if (command == NULL || cmdPtr->tracePtr == NULL) { return traceCode; } - + curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level); - + active.nextPtr = iPtr->activeCmdTracePtr; iPtr->activeCmdTracePtr = &active; active.cmdPtr = cmdPtr; lastTracePtr = NULL; - for (tracePtr = cmdPtr->tracePtr; - (traceCode == TCL_OK) && (tracePtr != NULL); - tracePtr = active.nextTracePtr) { - if (traceFlags & TCL_TRACE_LEAVE_EXEC) { - /* execute the trace command in order of creation for "leave" */ + for (tracePtr = cmdPtr->tracePtr; + (traceCode == TCL_OK) && (tracePtr != NULL); + tracePtr = active.nextTracePtr) { + if (traceFlags & TCL_TRACE_LEAVE_EXEC) { + /* + * Execute the trace command in order of creation for "leave". + */ + + active.reverseScan = 1; active.nextTracePtr = NULL; - tracePtr = cmdPtr->tracePtr; - while (tracePtr->nextPtr != lastTracePtr) { - active.nextTracePtr = tracePtr; - tracePtr = tracePtr->nextPtr; - } - } else { + tracePtr = cmdPtr->tracePtr; + while (tracePtr->nextPtr != lastTracePtr) { + active.nextTracePtr = tracePtr; + tracePtr = tracePtr->nextPtr; + } + } else { + active.reverseScan = 0; active.nextTracePtr = tracePtr->nextPtr; - } + } tcmdPtr = (TraceCommandInfo*)tracePtr->clientData; if (tcmdPtr->flags != 0) { - tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT; - tcmdPtr->curCode = code; + tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT; + tcmdPtr->curCode = code; tcmdPtr->refCount++; if (state == NULL) { state = Tcl_SaveInterpState(interp, code); } - traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp, - curLevel, command, (Tcl_Command)cmdPtr, objc, objv); + traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp, + curLevel, command, (Tcl_Command)cmdPtr, objc, objv); if ((--tcmdPtr->refCount) <= 0) { - ckfree((char*)tcmdPtr); + ckfree((char*)tcmdPtr); } } - lastTracePtr = tracePtr; + if (active.nextTracePtr) { + lastTracePtr = active.nextTracePtr->nextPtr; + } } iPtr->activeCmdTracePtr = active.nextPtr; if (state) { (void) Tcl_RestoreInterpState(interp, state); } @@ -1424,127 +1454,142 @@ /* *---------------------------------------------------------------------- * * TclCheckInterpTraces -- * - * Checks on all current traces, and invokes procedures which - * have been registered. This procedure can be used by other - * code which performs execution to unify the tracing system. - * For instance extensions like [incr Tcl] which use their - * own execution technique can make use of Tcl's tracing. - * - * This procedure is called by 'TclEvalObjvInternal' + * Checks on all current traces, and invokes functions which have been + * registered. This function can be used by other code which performs + * execution to unify the tracing system. For instance extensions like + * [incr Tcl] which use their own execution technique can make use of + * Tcl's tracing. + * + * This function is called by 'TclEvalObjvInternal' * * Results: - * The return value is a standard Tcl completion code such as - * TCL_OK or TCL_ERROR, etc. + * The return value is a standard Tcl completion code such as TCL_OK or + * TCL_ERROR, etc. * * Side effects: - * Those side effects made by any trace procedures called. + * Those side effects made by any trace functions called. * *---------------------------------------------------------------------- */ -int -TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, - traceFlags, objc, objv) + +int +TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, traceFlags, + objc, objv) Tcl_Interp *interp; /* The current interpreter. */ - CONST char *command; /* Pointer to beginning of the current - * command string. */ - int numChars; /* The number of characters in 'command' - * which are part of the command string. */ + CONST char *command; /* Pointer to beginning of the current command + * string. */ + int numChars; /* The number of characters in 'command' which + * are part of the command string. */ Command *cmdPtr; /* Points to command's Command struct. */ - int code; /* The current result code. */ - int traceFlags; /* Current tracing situation. */ + int code; /* The current result code. */ + int traceFlags; /* Current tracing situation. */ int objc; /* Number of arguments for the command. */ Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; Trace *tracePtr, *lastTracePtr; ActiveInterpTrace active; int curLevel; int traceCode = TCL_OK; - TraceCommandInfo* tcmdPtr; Tcl_InterpState state = NULL; - - if (command == NULL || iPtr->tracePtr == NULL || - (iPtr->flags & INTERP_TRACE_IN_PROGRESS)) { + + if (command == NULL || iPtr->tracePtr == NULL + || (iPtr->flags & INTERP_TRACE_IN_PROGRESS)) { return(traceCode); } - + curLevel = iPtr->numLevels; - + active.nextPtr = iPtr->activeInterpTracePtr; iPtr->activeInterpTracePtr = &active; lastTracePtr = NULL; - for ( tracePtr = iPtr->tracePtr; - (traceCode == TCL_OK) && (tracePtr != NULL); - tracePtr = active.nextTracePtr) { - if (traceFlags & TCL_TRACE_ENTER_EXEC) { - /* - * Execute the trace command in reverse order of creation - * for "enterstep" operation. The order is changed for - * "enterstep" instead of for "leavestep" as was done in - * TclCheckExecutionTraces because for step traces, - * Tcl_CreateObjTrace creates one more linked list of traces - * which results in one more reversal of trace invocation. - */ + for (tracePtr = iPtr->tracePtr; + (traceCode == TCL_OK) && (tracePtr != NULL); + tracePtr = active.nextTracePtr) { + if (traceFlags & TCL_TRACE_ENTER_EXEC) { + /* + * Execute the trace command in reverse order of creation for + * "enterstep" operation. The order is changed for "enterstep" + * instead of for "leavestep" as was done in + * TclCheckExecutionTraces because for step traces, + * Tcl_CreateObjTrace creates one more linked list of traces which + * results in one more reversal of trace invocation. + */ + + active.reverseScan = 1; active.nextTracePtr = NULL; - tracePtr = iPtr->tracePtr; - while (tracePtr->nextPtr != lastTracePtr) { - active.nextTracePtr = tracePtr; - tracePtr = tracePtr->nextPtr; - } - } else { + tracePtr = iPtr->tracePtr; + while (tracePtr->nextPtr != lastTracePtr) { + active.nextTracePtr = tracePtr; + tracePtr = tracePtr->nextPtr; + } + } else { + active.reverseScan = 0; active.nextTracePtr = tracePtr->nextPtr; - } + } + if (tracePtr->level > 0 && curLevel > tracePtr->level) { continue; } + if (!(tracePtr->flags & TCL_TRACE_EXEC_IN_PROGRESS)) { - /* - * The proc invoked might delete the traced command which - * which might try to free tracePtr. We want to use tracePtr - * until the end of this if section, so we use - * Tcl_Preserve() and Tcl_Release() to be sure it is not - * freed while we still need it. + /* + * The proc invoked might delete the traced command which which + * might try to free tracePtr. We want to use tracePtr until the + * end of this if section, so we use Tcl_Preserve() and + * Tcl_Release() to be sure it is not freed while we still need + * it. */ + Tcl_Preserve((ClientData) tracePtr); tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; if (state == NULL) { state = Tcl_SaveInterpState(interp, code); } - - if (tracePtr->flags & (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC)) { - /* New style trace */ - if ((tracePtr->flags != TCL_TRACE_EXEC_IN_PROGRESS) && - ((tracePtr->flags & traceFlags) != 0)) { - tcmdPtr = (TraceCommandInfo*)tracePtr->clientData; - tcmdPtr->curFlags = traceFlags; - tcmdPtr->curCode = code; - traceCode = (tracePtr->proc)((ClientData)tcmdPtr, - (Tcl_Interp*)interp, - curLevel, command, - (Tcl_Command)cmdPtr, - objc, objv); + + if (tracePtr->flags & + (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC)) { + /* + * New style trace. + */ + + if (tracePtr->flags & traceFlags) { + if (tracePtr->proc == TraceExecutionProc) { + TraceCommandInfo* tcmdPtr = + (TraceCommandInfo *) tracePtr->clientData; + tcmdPtr->curFlags = traceFlags; + tcmdPtr->curCode = code; + } + traceCode = (tracePtr->proc)(tracePtr->clientData, + interp, curLevel, command, (Tcl_Command) cmdPtr, + objc, objv); } } else { - /* Old-style trace */ - + /* + * Old-style trace. + */ + if (traceFlags & TCL_TRACE_ENTER_EXEC) { - /* - * Old-style interpreter-wide traces only trigger - * before the command is executed. + /* + * Old-style interpreter-wide traces only trigger before + * the command is executed. */ - traceCode = CallTraceProcedure(interp, tracePtr, cmdPtr, - command, numChars, objc, objv); + + traceCode = CallTraceFunction(interp, tracePtr, cmdPtr, + command, numChars, objc, objv); } } tracePtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; Tcl_Release((ClientData) tracePtr); } - lastTracePtr = tracePtr; + if (active.nextTracePtr) { + lastTracePtr = active.nextTracePtr->nextPtr; + } } iPtr->activeInterpTracePtr = active.nextPtr; if (state) { if (traceCode == TCL_OK) { (void) Tcl_RestoreInterpState(interp, state); @@ -1556,57 +1601,56 @@ } /* *---------------------------------------------------------------------- * - * CallTraceProcedure -- + * CallTraceFunction -- * - * Invokes a trace procedure registered with an interpreter. These - * procedures trace command execution. Currently this trace procedure - * is called with the address of the string-based Tcl_CmdProc for the + * Invokes a trace function registered with an interpreter. These + * functions trace command execution. Currently this trace function is + * called with the address of the string-based Tcl_CmdProc for the * command, not the Tcl_ObjCmdProc. * * Results: * None. * * Side effects: - * Those side effects made by the trace procedure. + * Those side effects made by the trace function. * *---------------------------------------------------------------------- */ static int -CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv) +CallTraceFunction(interp, tracePtr, cmdPtr, command, numChars, objc, objv) Tcl_Interp *interp; /* The current interpreter. */ - register Trace *tracePtr; /* Describes the trace procedure to call. */ + register Trace *tracePtr; /* Describes the trace function to call. */ Command *cmdPtr; /* Points to command's Command struct. */ CONST char *command; /* Points to the first character of the * command's source before substitutions. */ - int numChars; /* The number of characters in the - * command's source. */ + int numChars; /* The number of characters in the command's + * source. */ register int objc; /* Number of arguments for the command. */ Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; char *commandCopy; int traceCode; - /* + /* * Copy the command characters into a new string. */ commandCopy = (char *) ckalloc((unsigned) (numChars + 1)); memcpy((VOID *) commandCopy, (VOID *) command, (size_t) numChars); commandCopy[numChars] = '\0'; - + /* - * Call the trace procedure then free allocated storage. + * Call the trace function then free allocated storage. */ - - traceCode = (tracePtr->proc)( tracePtr->clientData, (Tcl_Interp*) iPtr, - iPtr->numLevels, commandCopy, - (Tcl_Command) cmdPtr, objc, objv ); + + traceCode = (tracePtr->proc)(tracePtr->clientData, (Tcl_Interp*) iPtr, + iPtr->numLevels, commandCopy, (Tcl_Command) cmdPtr, objc, objv); ckfree((char *) commandCopy); return(traceCode); } @@ -1613,22 +1657,23 @@ /* *---------------------------------------------------------------------- * * CommandObjTraceDeleted -- * - * Ensure the trace is correctly deleted by decrementing its - * refCount and only deleting if no other references exist. + * Ensure the trace is correctly deleted by decrementing its refCount and + * only deleting if no other references exist. * * Results: - * None. + * None. * * Side effects: * May release memory. * *---------------------------------------------------------------------- */ -static void + +static void CommandObjTraceDeleted(ClientData clientData) { TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData; if ((--tcmdPtr->refCount) <= 0) { ckfree((char*)tcmdPtr); } @@ -1637,181 +1682,199 @@ /* *---------------------------------------------------------------------- * * TraceExecutionProc -- * - * This procedure is invoked whenever code relevant to a - * 'trace execution' command is executed. It is called in one - * of two ways in Tcl's core: - * - * (i) by the TclCheckExecutionTraces, when an execution trace - * has been triggered. - * (ii) by TclCheckInterpTraces, when a prior execution trace has - * created a trace of the internals of a procedure, passing in - * this procedure as the one to be called. + * This function is invoked whenever code relevant to a 'trace execution' + * command is executed. It is called in one of two ways in Tcl's core: + * + * (i) by the TclCheckExecutionTraces, when an execution trace has been + * triggered. + * (ii) by TclCheckInterpTraces, when a prior execution trace has created + * a trace of the internals of a procedure, passing in this function as + * the one to be called. * * Results: - * The return value is a standard Tcl completion code such as - * TCL_OK or TCL_ERROR, etc. + * The return value is a standard Tcl completion code such as TCL_OK or + * TCL_ERROR, etc. * * Side effects: - * May invoke an arbitrary Tcl procedure, and may create or - * delete an interpreter-wide trace. + * May invoke an arbitrary Tcl procedure, and may create or delete an + * interpreter-wide trace. * *---------------------------------------------------------------------- */ + static int -TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, - int level, CONST char* command, Tcl_Command cmdInfo, - int objc, struct Tcl_Obj *CONST objv[]) { +TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, int level, + CONST char* command, Tcl_Command cmdInfo, int objc, + struct Tcl_Obj *CONST objv[]) { int call = 0; Interp *iPtr = (Interp *) interp; TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData; int flags = tcmdPtr->curFlags; int code = tcmdPtr->curCode; int traceCode = TCL_OK; - + if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { - /* - * Inside any kind of execution trace callback, we do - * not allow any further execution trace callbacks to - * be called for the same trace. + /* + * Inside any kind of execution trace callback, we do not allow any + * further execution trace callbacks to be called for the same trace. */ + return traceCode; } - + if (!(flags & TCL_INTERP_DESTROYED) && !Tcl_LimitExceeded(interp)) { /* - * Check whether the current call is going to eval arbitrary - * Tcl code with a generated trace, or whether we are only - * going to setup interpreter-wide traces to implement the - * 'step' traces. This latter situation can happen if - * we create a command trace without either before or after - * operations, but with either of the step operations. + * Check whether the current call is going to eval arbitrary Tcl code + * with a generated trace, or whether we are only going to setup + * interpreter-wide traces to implement the 'step' traces. This latter + * situation can happen if we create a command trace without either + * before or after operations, but with either of the step operations. */ + if (flags & TCL_TRACE_EXEC_DIRECT) { - call = flags & tcmdPtr->flags & (TCL_TRACE_ENTER_EXEC | - TCL_TRACE_LEAVE_EXEC); + call = flags & tcmdPtr->flags & + (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); } else { call = 1; } + /* - * First, if we have returned back to the level at which we - * created an interpreter trace for enterstep and/or leavestep - * execution traces, we remove it here. + * First, if we have returned back to the level at which we created an + * interpreter trace for enterstep and/or leavestep execution traces, + * we remove it here. */ - if (flags & TCL_TRACE_LEAVE_EXEC) { - if ((tcmdPtr->stepTrace != NULL) && (level == tcmdPtr->startLevel) - && (strcmp(command, tcmdPtr->startCmd) == 0)) { - Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); - tcmdPtr->stepTrace = NULL; - if (tcmdPtr->startCmd != NULL) { - ckfree((char *)tcmdPtr->startCmd); - } + + if ((flags & TCL_TRACE_LEAVE_EXEC) && (tcmdPtr->stepTrace != NULL) + && (level == tcmdPtr->startLevel) + && (strcmp(command, tcmdPtr->startCmd) == 0)) { + Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); + tcmdPtr->stepTrace = NULL; + if (tcmdPtr->startCmd != NULL) { + ckfree((char *)tcmdPtr->startCmd); } } - + /* * Second, create the tcl callback, if required. */ + if (call) { Tcl_DString cmd; Tcl_DString sub; int i; Tcl_DStringInit(&cmd); Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length); - /* Append command with arguments */ + + /* + * Append command with arguments. + */ + Tcl_DStringInit(&sub); for (i = 0; i < objc; i++) { - char* str; - int len; - str = Tcl_GetStringFromObj(objv[i],&len); - Tcl_DStringAppendElement(&sub, str); + Tcl_DStringAppendElement(&sub, Tcl_GetString(objv[i])); } Tcl_DStringAppendElement(&cmd, Tcl_DStringValue(&sub)); Tcl_DStringFree(&sub); if (flags & TCL_TRACE_ENTER_EXEC) { - /* Append trace operation */ + /* + * Append trace operation. + */ + if (flags & TCL_TRACE_EXEC_DIRECT) { Tcl_DStringAppendElement(&cmd, "enter"); } else { Tcl_DStringAppendElement(&cmd, "enterstep"); } } else if (flags & TCL_TRACE_LEAVE_EXEC) { Tcl_Obj* resultCode; char* resultCodeStr; - /* Append result code */ + /* + * Append result code. + */ + resultCode = Tcl_NewIntObj(code); resultCodeStr = Tcl_GetString(resultCode); Tcl_DStringAppendElement(&cmd, resultCodeStr); Tcl_DecrRefCount(resultCode); - - /* Append result string */ + + /* + * Append result string. + */ + Tcl_DStringAppendElement(&cmd, Tcl_GetStringResult(interp)); - /* Append trace operation */ + + /* + * Append trace operation. + */ + if (flags & TCL_TRACE_EXEC_DIRECT) { Tcl_DStringAppendElement(&cmd, "leave"); } else { Tcl_DStringAppendElement(&cmd, "leavestep"); } } else { Tcl_Panic("TraceExecutionProc: bad flag combination"); } - + /* - * Execute the command. - * We discard any object result the command returns. + * Execute the command. We discard any object result the command + * returns. */ tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; iPtr->flags |= INTERP_TRACE_IN_PROGRESS; tcmdPtr->refCount++; - /* - * This line can have quite arbitrary side-effects, - * including deleting the trace, the command being - * traced, or even the interpreter. + + /* + * This line can have quite arbitrary side-effects, including + * deleting the trace, the command being traced, or even the + * interpreter. */ + traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; iPtr->flags &= ~INTERP_TRACE_IN_PROGRESS; if (tcmdPtr->flags == 0) { flags |= TCL_TRACE_DESTROYED; } Tcl_DStringFree(&cmd); } - + /* - * Third, if there are any step execution traces for this proc, - * we register an interpreter trace to invoke enterstep and/or - * leavestep traces. - * We also need to save the current stack level and the proc - * string in startLevel and startCmd so that we can delete this - * interpreter trace when it reaches the end of this proc. + * Third, if there are any step execution traces for this proc, we + * register an interpreter trace to invoke enterstep and/or leavestep + * traces. We also need to save the current stack level and the proc + * string in startLevel and startCmd so that we can delete this + * interpreter trace when it reaches the end of this proc. */ + if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL) - && (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC | - TCL_TRACE_LEAVE_DURING_EXEC))) { - tcmdPtr->startLevel = level; - tcmdPtr->startCmd = + && (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC | + TCL_TRACE_LEAVE_DURING_EXEC))) { + tcmdPtr->startLevel = level; + tcmdPtr->startCmd = (char *) ckalloc((unsigned) (strlen(command) + 1)); - strcpy(tcmdPtr->startCmd, command); - tcmdPtr->refCount++; - tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0, - (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2, - TraceExecutionProc, (ClientData)tcmdPtr, + strcpy(tcmdPtr->startCmd, command); + tcmdPtr->refCount++; + tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0, + (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2, + TraceExecutionProc, (ClientData)tcmdPtr, CommandObjTraceDeleted); } } if (flags & TCL_TRACE_DESTROYED) { if (tcmdPtr->stepTrace != NULL) { Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; - if (tcmdPtr->startCmd != NULL) { - ckfree((char *)tcmdPtr->startCmd); + if (tcmdPtr->startCmd != NULL) { + ckfree((char *)tcmdPtr->startCmd); } } } if (call) { if ((--tcmdPtr->refCount) <= 0) { @@ -1824,16 +1887,16 @@ /* *---------------------------------------------------------------------- * * TraceVarProc -- * - * This procedure is called to handle variable accesses that have - * been traced using the "trace" command. + * This function is called to handle variable accesses that have been + * traced using the "trace" command. * * Results: - * Normally returns NULL. If the trace command returns an error, - * then this procedure returns an error string. + * Normally returns NULL. If the trace command returns an error, then + * this function returns an error string. * * Side effects: * Depends on the command associated with the trace. * *---------------------------------------------------------------------- @@ -1843,37 +1906,36 @@ static char * TraceVarProc(clientData, interp, name1, name2, flags) ClientData clientData; /* Information about the variable trace. */ Tcl_Interp *interp; /* Interpreter containing variable. */ CONST char *name1; /* Name of variable or array. */ - CONST char *name2; /* Name of element within array; NULL means + CONST char *name2; /* Name of element within array; NULL means * scalar variable is being referenced. */ int flags; /* OR-ed bits giving operation and other * information. */ { TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; char *result; int code; Tcl_DString cmd; - /* - * We might call Tcl_Eval() below, and that might evaluate - * [trace vdelete] which might try to free tvarPtr. We want - * to use tvarPtr until the end of this function, so we use - * Tcl_Preserve() and Tcl_Release() to be sure it is not - * freed while we still need it. + /* + * We might call Tcl_Eval() below, and that might evaluate [trace vdelete] + * which might try to free tvarPtr. We want to use tvarPtr until the end + * of this function, so we use Tcl_Preserve() and Tcl_Release() to be sure + * it is not freed while we still need it. */ Tcl_Preserve((ClientData) tvarPtr); result = NULL; if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED) && !Tcl_LimitExceeded(interp)) { if (tvarPtr->length != (size_t) 0) { /* - * Generate a command to execute by appending list elements - * for the two variable names and the operation. + * Generate a command to execute by appending list elements for + * the two variable names and the operation. */ Tcl_DStringInit(&cmd); Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length); Tcl_DStringAppendElement(&cmd, name1); @@ -1901,14 +1963,14 @@ Tcl_DStringAppend(&cmd, " unset", 6); } #ifndef TCL_REMOVE_OBSOLETE_TRACES } #endif - + /* - * Execute the command. - * We discard any object result the command returns. + * Execute the command. We discard any object result the command + * returns. * * Add the TCL_TRACE_DESTROYED flag to tvarPtr to indicate to * other areas that this will be destroyed by us, otherwise a * double-free might occur depending on what the eval does. */ @@ -1916,11 +1978,11 @@ if (flags & TCL_TRACE_DESTROYED) { tvarPtr->flags |= TCL_TRACE_DESTROYED; } code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), Tcl_DStringLength(&cmd), 0); - if (code != TCL_OK) { /* copy error msg to result */ + if (code != TCL_OK) { /* copy error msg to result */ Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp); Tcl_IncrRefCount(errMsgObj); result = (char *) errMsgObj; } Tcl_DStringFree(&cmd); @@ -1942,128 +2004,126 @@ /* *---------------------------------------------------------------------- * * Tcl_CreateObjTrace -- * - * Arrange for a procedure to be called to trace command execution. + * Arrange for a function to be called to trace command execution. * * Results: - * The return value is a token for the trace, which may be passed - * to Tcl_DeleteTrace to eliminate the trace. + * The return value is a token for the trace, which may be passed to + * Tcl_DeleteTrace to eliminate the trace. * * Side effects: - * From now on, proc will be called just before a command procedure - * is called to execute a Tcl command. Calls to proc will have the - * following form: - * - * void proc( ClientData clientData, - * Tcl_Interp* interp, - * int level, - * CONST char* command, - * Tcl_Command commandInfo, - * int objc, - * Tcl_Obj *CONST objv[] ); - * - * The 'clientData' and 'interp' arguments to 'proc' will be the - * same as the arguments to Tcl_CreateObjTrace. The 'level' - * argument gives the nesting depth of command interpretation within - * the interpreter. The 'command' argument is the ASCII text of - * the command being evaluated -- before any substitutions are - * performed. The 'commandInfo' argument gives a handle to the - * command procedure that will be evaluated. The 'objc' and 'objv' - * parameters give the parameter vector that will be passed to the - * command procedure. proc does not return a value. - * - * It is permissible for 'proc' to call Tcl_SetCommandTokenInfo - * to change the command procedure or client data for the command - * being evaluated, and these changes will take effect with the - * current evaluation. - * - * The 'level' argument specifies the maximum nesting level of calls - * to be traced. If the execution depth of the interpreter exceeds - * 'level', the trace callback is not executed. - * - * The 'flags' argument is either zero or the value, - * TCL_ALLOW_INLINE_COMPILATION. If the TCL_ALLOW_INLINE_COMPILATION - * flag is not present, the bytecode compiler will not generate inline - * code for Tcl's built-in commands. This behavior will have a significant - * impact on performance, but will ensure that all command evaluations are - * traced. If the TCL_ALLOW_INLINE_COMPILATION flag is present, the - * bytecode compiler will have its normal behavior of compiling in-line - * code for some of Tcl's built-in commands. In this case, the tracing - * will be imprecise -- in-line code will not be traced -- but run-time - * performance will be improved. The latter behavior is desired for - * many applications such as profiling of run time. - * - * When the trace is deleted, the 'delProc' procedure will be invoked, - * passing it the original client data. + * From now on, proc will be called just before a command function is + * called to execute a Tcl command. Calls to proc will have the following + * form: + * + * void proc(ClientData clientData, + * Tcl_Interp* interp, + * int level, + * CONST char* command, + * Tcl_Command commandInfo, + * int objc, + * Tcl_Obj *CONST objv[]); + * + * The 'clientData' and 'interp' arguments to 'proc' will be the same as + * the arguments to Tcl_CreateObjTrace. The 'level' argument gives the + * nesting depth of command interpretation within the interpreter. The + * 'command' argument is the ASCII text of the command being evaluated - + * before any substitutions are performed. The 'commandInfo' argument + * gives a handle to the command procedure that will be evaluated. The + * 'objc' and 'objv' parameters give the parameter vector that will be + * passed to the command procedure. Proc does not return a value. + * + * It is permissible for 'proc' to call Tcl_SetCommandTokenInfo to change + * the command procedure or client data for the command being evaluated, + * and these changes will take effect with the current evaluation. + * + * The 'level' argument specifies the maximum nesting level of calls to + * be traced. If the execution depth of the interpreter exceeds 'level', + * the trace callback is not executed. + * + * The 'flags' argument is either zero or the value, + * TCL_ALLOW_INLINE_COMPILATION. If the TCL_ALLOW_INLINE_COMPILATION flag + * is not present, the bytecode compiler will not generate inline code + * for Tcl's built-in commands. This behavior will have a significant + * impact on performance, but will ensure that all command evaluations + * are traced. If the TCL_ALLOW_INLINE_COMPILATION flag is present, the + * bytecode compiler will have its normal behavior of compiling in-line + * code for some of Tcl's built-in commands. In this case, the tracing + * will be imprecise - in-line code will not be traced - but run-time + * performance will be improved. The latter behavior is desired for many + * applications such as profiling of run time. + * + * When the trace is deleted, the 'delProc' function will be invoked, + * passing it the original client data. * *---------------------------------------------------------------------- */ Tcl_Trace -Tcl_CreateObjTrace( interp, level, flags, proc, clientData, delProc ) +Tcl_CreateObjTrace(interp, level, flags, proc, clientData, delProc) Tcl_Interp* interp; /* Tcl interpreter */ int level; /* Maximum nesting level */ int flags; /* Flags, see above */ Tcl_CmdObjTraceProc* proc; /* Trace callback */ ClientData clientData; /* Client data for the callback */ Tcl_CmdObjTraceDeleteProc* delProc; - /* Procedure to call when trace is deleted */ + /* Function to call when trace is deleted */ { register Trace *tracePtr; register Interp *iPtr = (Interp *) interp; - /* Test if this trace allows inline compilation of commands */ + /* + * Test if this trace allows inline compilation of commands. + */ if (!(flags & TCL_ALLOW_INLINE_COMPILATION)) { if (iPtr->tracesForbiddingInline == 0) { - /* - * When the first trace forbidding inline compilation is - * created, invalidate existing compiled code for this - * interpreter and arrange (by setting the - * DONT_COMPILE_CMDS_INLINE flag) that when compiling new - * code, no commands will be compiled inline (i.e., into - * an inline sequence of instructions). We do this because - * commands that were compiled inline will never result in + * When the first trace forbidding inline compilation is created, + * invalidate existing compiled code for this interpreter and + * arrange (by setting the DONT_COMPILE_CMDS_INLINE flag) that + * when compiling new code, no commands will be compiled inline + * (i.e., into an inline sequence of instructions). We do this + * because commands that were compiled inline will never result in * a command trace being called. */ iPtr->compileEpoch++; iPtr->flags |= DONT_COMPILE_CMDS_INLINE; } iPtr->tracesForbiddingInline++; } - + tracePtr = (Trace *) ckalloc(sizeof(Trace)); - tracePtr->level = level; - tracePtr->proc = proc; - tracePtr->clientData = clientData; - tracePtr->delProc = delProc; - tracePtr->nextPtr = iPtr->tracePtr; - tracePtr->flags = flags; - iPtr->tracePtr = tracePtr; + tracePtr->level = level; + tracePtr->proc = proc; + tracePtr->clientData = clientData; + tracePtr->delProc = delProc; + tracePtr->nextPtr = iPtr->tracePtr; + tracePtr->flags = flags; + iPtr->tracePtr = tracePtr; return (Tcl_Trace) tracePtr; } /* *---------------------------------------------------------------------- * * Tcl_CreateTrace -- * - * Arrange for a procedure to be called to trace command execution. + * Arrange for a function to be called to trace command execution. * * Results: - * The return value is a token for the trace, which may be passed - * to Tcl_DeleteTrace to eliminate the trace. + * The return value is a token for the trace, which may be passed to + * Tcl_DeleteTrace to eliminate the trace. * * Side effects: - * From now on, proc will be called just before a command procedure - * is called to execute a Tcl command. Calls to proc will have the - * following form: + * From now on, proc will be called just before a command procedure is + * called to execute a Tcl command. Calls to proc will have the following + * form: * * void * proc(clientData, interp, level, command, cmdProc, cmdClientData, * argc, argv) * ClientData clientData; @@ -2075,59 +2135,57 @@ * int argc; * char **argv; * { * } * - * The clientData and interp arguments to proc will be the same - * as the corresponding arguments to this procedure. Level gives - * the nesting level of command interpretation for this interpreter - * (0 corresponds to top level). Command gives the ASCII text of - * the raw command, cmdProc and cmdClientData give the procedure that - * will be called to process the command and the ClientData value it - * will receive, and argc and argv give the arguments to the - * command, after any argument parsing and substitution. Proc - * does not return a value. + * The clientData and interp arguments to proc will be the same as the + * corresponding arguments to this function. Level gives the nesting + * level of command interpretation for this interpreter (0 corresponds to + * top level). Command gives the ASCII text of the raw command, cmdProc + * and cmdClientData give the function that will be called to process the + * command and the ClientData value it will receive, and argc and argv + * give the arguments to the command, after any argument parsing and + * substitution. Proc does not return a value. * *---------------------------------------------------------------------- */ Tcl_Trace Tcl_CreateTrace(interp, level, proc, clientData) Tcl_Interp *interp; /* Interpreter in which to create trace. */ int level; /* Only call proc for commands at nesting * level<=argument level (1=>top level). */ - Tcl_CmdTraceProc *proc; /* Procedure to call before executing each + Tcl_CmdTraceProc *proc; /* Function to call before executing each * command. */ ClientData clientData; /* Arbitrary value word to pass to proc. */ { StringTraceData* data; - data = (StringTraceData*) ckalloc( sizeof( *data )); + data = (StringTraceData *) ckalloc(sizeof(*data)); data->clientData = clientData; data->proc = proc; - return Tcl_CreateObjTrace( interp, level, 0, StringTraceProc, - (ClientData) data, StringTraceDeleteProc ); + return Tcl_CreateObjTrace(interp, level, 0, StringTraceProc, + (ClientData) data, StringTraceDeleteProc); } /* *---------------------------------------------------------------------- * * StringTraceProc -- * - * Invoke a string-based trace procedure from an object-based - * callback. + * Invoke a string-based trace function from an object-based callback. * * Results: * None. * * Side effects: - * Whatever the string-based trace procedure does. + * Whatever the string-based trace function does. * *---------------------------------------------------------------------- */ static int -StringTraceProc( clientData, interp, level, command, commandInfo, objc, objv ) +StringTraceProc(clientData, interp, level, command, commandInfo, objc, objv) ClientData clientData; Tcl_Interp* interp; int level; CONST char* command; Tcl_Command commandInfo; @@ -2134,37 +2192,34 @@ int objc; Tcl_Obj *CONST *objv; { StringTraceData* data = (StringTraceData*) clientData; Command* cmdPtr = (Command*) commandInfo; - CONST char** argv; /* Args to pass to string trace proc */ - int i; /* - * This is a bit messy because we have to emulate the old trace - * interface, which uses strings for everything. + * This is a bit messy because we have to emulate the old trace interface, + * which uses strings for everything. */ - - argv = (CONST char **) ckalloc((unsigned) ( (objc + 1) - * sizeof(CONST char *) )); + + argv = (CONST char **) + ckalloc((unsigned) ((objc + 1) * sizeof(CONST char *))); for (i = 0; i < objc; i++) { argv[i] = Tcl_GetString(objv[i]); } argv[objc] = 0; /* - * Invoke the command procedure. Note that we cast away const-ness - * on two parameters for compatibility with legacy code; the code - * MUST NOT modify either command or argv. + * Invoke the command function. Note that we cast away const-ness on two + * parameters for compatibility with legacy code; the code MUST NOT modify + * either command or argv. */ - - ( data->proc )( data->clientData, interp, level, - (char*) command, cmdPtr->proc, cmdPtr->clientData, - objc, argv ); - ckfree( (char*) argv ); + + (data->proc)(data->clientData, interp, level, (char *) command, + cmdPtr->proc, cmdPtr->clientData, objc, argv); + ckfree((char *) argv); return TCL_OK; } /* @@ -2182,14 +2237,14 @@ * *---------------------------------------------------------------------- */ static void -StringTraceDeleteProc( clientData ) +StringTraceDeleteProc(clientData) ClientData clientData; { - ckfree( (char*) clientData ); + ckfree((char *) clientData); } /* *---------------------------------------------------------------------- * @@ -2199,12 +2254,12 @@ * * Results: * None. * * Side effects: - * From now on there will be no more calls to the procedure given - * in trace. + * From now on there will be no more calls to the function given in + * trace. * *---------------------------------------------------------------------- */ void @@ -2212,31 +2267,51 @@ Tcl_Interp *interp; /* Interpreter that contains trace. */ Tcl_Trace trace; /* Token for trace (returned previously by * Tcl_CreateTrace). */ { Interp *iPtr = (Interp *) interp; - Trace *tracePtr = (Trace *) trace; + Trace *prevPtr, *tracePtr = (Trace *) trace; register Trace **tracePtr2 = &(iPtr->tracePtr); + ActiveInterpTrace *activePtr; /* - * Locate the trace entry in the interpreter's trace list, - * and remove it from the list. + * Locate the trace entry in the interpreter's trace list, and remove it + * from the list. */ + prevPtr = NULL; while ((*tracePtr2) != NULL && (*tracePtr2) != tracePtr) { + prevPtr = *tracePtr2; tracePtr2 = &((*tracePtr2)->nextPtr); } if (*tracePtr2 == NULL) { return; } (*tracePtr2) = (*tracePtr2)->nextPtr; + + /* + * The code below makes it possible to delete traces while traces are + * active: it makes sure that the deleted trace won't be processed by + * TclCheckInterpTraces. + */ + + for (activePtr = iPtr->activeInterpTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->nextTracePtr == tracePtr) { + if (activePtr->reverseScan) { + activePtr->nextTracePtr = prevPtr; + } else { + activePtr->nextTracePtr = tracePtr->nextPtr; + } + } + } /* * If the trace forbids bytecode compilation, change the interpreter's - * state. If bytecode compilation is now permitted, flag the fact and - * advance the compilation epoch so that procs will be recompiled to - * take advantage of it. + * state. If bytecode compilation is now permitted, flag the fact and + * advance the compilation epoch so that procs will be recompiled to take + * advantage of it. */ if (!(tracePtr->flags & TCL_ALLOW_INLINE_COMPILATION)) { iPtr->tracesForbiddingInline--; if (iPtr->tracesForbiddingInline == 0) { @@ -2251,23 +2326,25 @@ if (tracePtr->delProc != NULL) { (tracePtr->delProc)(tracePtr->clientData); } - /* Delete the trace object */ + /* + * Delete the trace object. + */ Tcl_EventuallyFree((char*)tracePtr, TCL_DYNAMIC); } /* *---------------------------------------------------------------------- * * TclTraceVarExists -- * - * This is called from info exists. We need to trigger read - * and/or array traces because they may end up creating a - * variable that doesn't currently exist. + * This is called from info exists. We need to trigger read and/or array + * traces because they may end up creating a variable that doesn't + * currently exist. * * Results: * A pointer to the Var structure, or NULL. * * Side effects: @@ -2283,21 +2360,20 @@ { Var *varPtr; Var *arrayPtr; /* - * The choice of "create" flag values is delicate here, and - * matches the semantics of GetVar. Things are still not perfect, - * however, because if you do "info exists x" you get a varPtr - * and therefore trigger traces. However, if you do - * "info exists x(i)", then you only get a varPtr if x is already - * known to be an array. Otherwise you get NULL, and no trace - * is triggered. This matches Tcl 7.6 semantics. + * The choice of "create" flag values is delicate here, and matches the + * semantics of GetVar. Things are still not perfect, however, because if + * you do "info exists x" you get a varPtr and therefore trigger traces. + * However, if you do "info exists x(i)", then you only get a varPtr if x + * is already known to be an array. Otherwise you get NULL, and no trace + * is triggered. This matches Tcl 7.6 semantics. */ - varPtr = TclLookupVar(interp, varName, (char *) NULL, - 0, "access", /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr); + varPtr = TclLookupVar(interp, varName, (char *) NULL, 0, "access", + /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return NULL; } @@ -2306,12 +2382,12 @@ TclCallVarTraces((Interp *)interp, arrayPtr, varPtr, varName, NULL, TCL_TRACE_READS, /* leaveErrMsg */ 0); } /* - * If the variable doesn't exist anymore and no-one's using - * it, then free up the relevant structures and hash table entries. + * If the variable doesn't exist anymore and no-one's using it, then free + * up the relevant structures and hash table entries. */ if (TclIsVarUndefined(varPtr)) { TclCleanupVar(varPtr, arrayPtr); return NULL; @@ -2323,47 +2399,45 @@ /* *---------------------------------------------------------------------- * * TclCallVarTraces -- * - * This procedure is invoked to find and invoke relevant - * trace procedures associated with a particular operation on - * a variable. This procedure invokes traces both on the - * variable and on its containing array (where relevant). + * This function is invoked to find and invoke relevant trace functions + * associated with a particular operation on a variable. This function + * invokes traces both on the variable and on its containing array (where + * relevant). * * Results: - * Returns TCL_OK to indicate normal operation. Returns TCL_ERROR - * if invocation of a trace procedure indicated an error. When - * TCL_ERROR is returned and leaveErrMsg is true, then the - * errorInfo field of iPtr has information about the error - * placed in it. + * Returns TCL_OK to indicate normal operation. Returns TCL_ERROR if + * invocation of a trace function indicated an error. When TCL_ERROR is + * returned and leaveErrMsg is true, then the errorInfo field of iPtr has + * information about the error placed in it. * * Side effects: - * Almost anything can happen, depending on trace; this procedure - * itself doesn't have any side effects. + * Almost anything can happen, depending on trace; this function itself + * doesn't have any side effects. * *---------------------------------------------------------------------- */ int TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg) Interp *iPtr; /* Interpreter containing variable. */ - register Var *arrayPtr; /* Pointer to array variable that contains - * the variable, or NULL if the variable - * isn't an element of an array. */ - Var *varPtr; /* Variable whose traces are to be - * invoked. */ + register Var *arrayPtr; /* Pointer to array variable that contains the + * variable, or NULL if the variable isn't an + * element of an array. */ + Var *varPtr; /* Variable whose traces are to be invoked. */ CONST char *part1; CONST char *part2; /* Variable's two-part name. */ - int flags; /* Flags passed to trace procedures: - * indicates what's happening to variable, - * plus other stuff like TCL_GLOBAL_ONLY, + int flags; /* Flags passed to trace functions: indicates + * what's happening to variable, plus other + * stuff like TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY, and * TCL_INTERP_DESTROYED. */ - int leaveErrMsg; /* If true, and one of the traces indicates an - * error, then leave an error message and stack - * trace information in *iPTr. */ + int leaveErrMsg; /* If true, and one of the traces indicates an + * error, then leave an error message and + * stack trace information in *iPTr. */ { register VarTrace *tracePtr; ActiveVarTrace active; char *result; CONST char *openParen, *p; @@ -2372,12 +2446,12 @@ int code = TCL_OK; int disposeFlags = 0; Tcl_InterpState state = NULL; /* - * If there are already similar trace procedures active for the - * variable, don't call them again. + * If there are already similar trace functions active for the variable, + * don't call them again. */ if (TclIsVarTraceActive(varPtr)) { return code; } @@ -2386,16 +2460,15 @@ if (arrayPtr != NULL) { arrayPtr->refCount++; } /* - * If the variable name hasn't been parsed into array name and - * element, do it here. If there really is an array element, - * make a copy of the original name so that NULLs can be - * inserted into it to separate the names (can't modify the name - * string in place, because the string might get used by the - * callbacks we invoke). + * If the variable name hasn't been parsed into array name and element, do + * it here. If there really is an array element, make a copy of the + * original name so that NULLs can be inserted into it to separate the + * names (can't modify the name string in place, because the string might + * get used by the callbacks we invoke). */ copiedName = 0; if (part2 == NULL) { for (p = part1; *p ; p++) { @@ -2406,10 +2479,11 @@ } while (*p != '\0'); p--; if (*p == ')') { int offset = (openParen - part1); char *newPart1; + Tcl_DStringInit(&nameCopy); Tcl_DStringAppend(&nameCopy, part1, (p-part1)); newPart1 = Tcl_DStringValue(&nameCopy); newPart1[offset] = 0; part1 = newPart1; @@ -2430,11 +2504,11 @@ iPtr->activeVarTracePtr = &active; Tcl_Preserve((ClientData) iPtr); if (arrayPtr != NULL && !TclIsVarTraceActive(arrayPtr)) { active.varPtr = arrayPtr; for (tracePtr = arrayPtr->tracePtr; tracePtr != NULL; - tracePtr = active.nextTracePtr) { + tracePtr = active.nextTracePtr) { active.nextTracePtr = tracePtr->nextPtr; if (!(tracePtr->flags & flags)) { continue; } Tcl_Preserve((ClientData) tracePtr); @@ -2443,14 +2517,17 @@ } result = (*tracePtr->traceProc)(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { if (flags & TCL_TRACE_UNSETS) { - /* Ignore errors in unset traces */ + /* + * Ignore errors in unset traces. + */ + DisposeTraceResult(tracePtr->flags, result); } else { - disposeFlags = tracePtr->flags; + disposeFlags = tracePtr->flags; code = TCL_ERROR; } } Tcl_Release((ClientData) tracePtr); if (code == TCL_ERROR) { @@ -2466,11 +2543,11 @@ if (flags & TCL_TRACE_UNSETS) { flags |= TCL_TRACE_DESTROYED; } active.varPtr = varPtr; for (tracePtr = varPtr->tracePtr; tracePtr != NULL; - tracePtr = active.nextTracePtr) { + tracePtr = active.nextTracePtr) { active.nextTracePtr = tracePtr->nextPtr; if (!(tracePtr->flags & flags)) { continue; } Tcl_Preserve((ClientData) tracePtr); @@ -2479,11 +2556,14 @@ } result = (*tracePtr->traceProc)(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { if (flags & TCL_TRACE_UNSETS) { - /* Ignore errors in unset traces */ + /* + * Ignore errors in unset traces. + */ + DisposeTraceResult(tracePtr->flags, result); } else { disposeFlags = tracePtr->flags; code = TCL_ERROR; } @@ -2493,15 +2573,15 @@ goto done; } } /* - * Restore the variable's flags, remove the record of our active - * traces, and then return. + * Restore the variable's flags, remove the record of our active traces, + * and then return. */ - done: + done: if (code == TCL_ERROR) { if (leaveErrMsg) { CONST char *type = ""; Tcl_Obj *options = Tcl_GetReturnOptions((Tcl_Interp *)iPtr, code); Tcl_Obj *errorInfoKey = Tcl_NewStringObj("-errorinfo", -1); @@ -2516,22 +2596,22 @@ errorInfo = Tcl_DuplicateObj(errorInfo); Tcl_IncrRefCount(errorInfo); } Tcl_AppendToObj(errorInfo, "\n (", -1); switch (flags&(TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_ARRAY)) { - case TCL_TRACE_READS: - type = "read"; - Tcl_AppendToObj(errorInfo, type, -1); - break; - case TCL_TRACE_WRITES: - type = "set"; - Tcl_AppendToObj(errorInfo, "write", -1); - break; - case TCL_TRACE_ARRAY: - type = "trace array"; - Tcl_AppendToObj(errorInfo, "array", -1); - break; + case TCL_TRACE_READS: + type = "read"; + Tcl_AppendToObj(errorInfo, type, -1); + break; + case TCL_TRACE_WRITES: + type = "set"; + Tcl_AppendToObj(errorInfo, "write", -1); + break; + case TCL_TRACE_ARRAY: + type = "trace array"; + Tcl_AppendToObj(errorInfo, "array", -1); + break; } if (disposeFlags & TCL_TRACE_RESULT_OBJECT) { TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, type, Tcl_GetString((Tcl_Obj *) result)); } else { @@ -2579,13 +2659,13 @@ /* *---------------------------------------------------------------------- * * DisposeTraceResult-- * - * This procedure is called to dispose of the result returned from - * a trace procedure. The disposal method appropriate to the type - * of result is determined by flags. + * This function is called to dispose of the result returned from a trace + * function. The disposal method appropriate to the type of result is + * determined by flags. * * Results: * None. * * Side effects: @@ -2595,13 +2675,13 @@ */ static void DisposeTraceResult(flags, result) int flags; /* Indicates type of result to determine - * proper disposal method */ - char *result; /* The result returned from a trace - * procedure to be disposed */ + * proper disposal method. */ + char *result; /* The result returned from a trace function + * to be disposed. */ { if (flags & TCL_TRACE_RESULT_DYNAMIC) { ckfree(result); } else if (flags & TCL_TRACE_RESULT_OBJECT) { Tcl_DecrRefCount((Tcl_Obj *) result); @@ -2617,28 +2697,26 @@ * * Results: * None. * * Side effects: - * If there exists a trace for the variable given by varName - * with the given flags, proc, and clientData, then that trace - * is removed. + * If there exists a trace for the variable given by varName with the + * given flags, proc, and clientData, then that trace is removed. * *---------------------------------------------------------------------- */ void Tcl_UntraceVar(interp, varName, flags, proc, clientData) Tcl_Interp *interp; /* Interpreter containing variable. */ - CONST char *varName; /* Name of variable; may end with "(index)" - * to signify an array reference. */ - int flags; /* OR-ed collection of bits describing - * current trace, including any of - * TCL_TRACE_READS, TCL_TRACE_WRITES, - * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY - * and TCL_NAMESPACE_ONLY. */ - Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ + CONST char *varName; /* Name of variable; may end with "(index)" to + * signify an array reference. */ + int flags; /* OR-ed collection of bits describing current + * trace, including any of TCL_TRACE_READS, + * TCL_TRACE_WRITES, TCL_TRACE_UNSETS, + * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY. */ + Tcl_VarTraceProc *proc; /* Function assocated with trace. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { Tcl_UntraceVar2(interp, varName, (char *) NULL, flags, proc, clientData); } @@ -2651,43 +2729,42 @@ * * Results: * None. * * Side effects: - * If there exists a trace for the variable given by part1 - * and part2 with the given flags, proc, and clientData, then - * that trace is removed. + * If there exists a trace for the variable given by part1 and part2 with + * the given flags, proc, and clientData, then that trace is removed. * *---------------------------------------------------------------------- */ void Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) Tcl_Interp *interp; /* Interpreter containing variable. */ CONST char *part1; /* Name of variable or array. */ - CONST char *part2; /* Name of element within array; NULL means + CONST char *part2; /* Name of element within array; NULL means * trace applies to scalar variable or array * as-a-whole. */ - int flags; /* OR-ed collection of bits describing - * current trace, including any of - * TCL_TRACE_READS, TCL_TRACE_WRITES, - * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, - * and TCL_NAMESPACE_ONLY. */ - Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ + int flags; /* OR-ed collection of bits describing current + * trace, including any of TCL_TRACE_READS, + * TCL_TRACE_WRITES, TCL_TRACE_UNSETS, + * TCL_GLOBAL_ONLY, and TCL_NAMESPACE_ONLY. */ + Tcl_VarTraceProc *proc; /* Function assocated with trace. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { register VarTrace *tracePtr; VarTrace *prevPtr; Var *varPtr, *arrayPtr; Interp *iPtr = (Interp *) interp; ActiveVarTrace *activePtr; int flagMask; - + /* * Set up a mask to mask out the parts of the flags that we are not * interested in now. */ + flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY; varPtr = TclLookupVar(interp, part1, part2, flags & flagMask, /*msg*/ (char *) NULL, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); if (varPtr == NULL) { @@ -2696,18 +2773,19 @@ /* * Set up a mask to mask out the parts of the flags that we are not * interested in now. */ + flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | - TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; + TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; #ifndef TCL_REMOVE_OBSOLETE_TRACES flagMask |= TCL_TRACE_OLD_STYLE; #endif flags &= flagMask; - for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ; - prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { + for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ; + prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { if (tracePtr == NULL) { return; } if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags) && (tracePtr->clientData == clientData)) { @@ -2714,17 +2792,17 @@ break; } } /* - * The code below makes it possible to delete traces while traces - * are active: it makes sure that the deleted trace won't be - * processed by TclCallVarTraces. + * The code below makes it possible to delete traces while traces are + * active: it makes sure that the deleted trace won't be processed by + * TclCallVarTraces. */ for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { + activePtr = activePtr->nextPtr) { if (activePtr->nextTracePtr == tracePtr) { activePtr->nextTracePtr = tracePtr->nextPtr; } } if (prevPtr == NULL) { @@ -2733,12 +2811,12 @@ prevPtr->nextPtr = tracePtr->nextPtr; } Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); /* - * If this is the last trace on the variable, and the variable is - * unset and unused, then free up the variable. + * If this is the last trace on the variable, and the variable is unset + * and unused, then free up the variable. */ if (TclIsVarUndefined(varPtr)) { TclCleanupVar(varPtr, (Var *) NULL); } @@ -2747,24 +2825,21 @@ /* *---------------------------------------------------------------------- * * Tcl_VarTraceInfo -- * - * Return the clientData value associated with a trace on a - * variable. This procedure can also be used to step through - * all of the traces on a particular variable that have the - * same trace procedure. + * Return the clientData value associated with a trace on a variable. + * This function can also be used to step through all of the traces on a + * particular variable that have the same trace function. * * Results: - * The return value is the clientData value associated with - * a trace on the given variable. Information will only be - * returned for a trace with proc as trace procedure. If - * the clientData argument is NULL then the first such trace is - * returned; otherwise, the next relevant one after the one - * given by clientData will be returned. If the variable - * doesn't exist, or if there are no (more) traces for it, - * then NULL is returned. + * The return value is the clientData value associated with a trace on + * the given variable. Information will only be returned for a trace with + * proc as trace function. If the clientData argument is NULL then the + * first such trace is returned; otherwise, the next relevant one after + * the one given by clientData will be returned. If the variable doesn't + * exist, or if there are no (more) traces for it, then NULL is returned. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -2771,20 +2846,19 @@ */ ClientData Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) Tcl_Interp *interp; /* Interpreter containing variable. */ - CONST char *varName; /* Name of variable; may end with "(index)" - * to signify an array reference. */ + CONST char *varName; /* Name of variable; may end with "(index)" to + * signify an array reference. */ int flags; /* OR-ed combo or TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY (can be 0). */ - Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ - ClientData prevClientData; /* If non-NULL, gives last value returned - * by this procedure, so this call will - * return the next trace after that one. - * If NULL, this call will return the - * first trace. */ + Tcl_VarTraceProc *proc; /* Function assocated with trace. */ + ClientData prevClientData; /* If non-NULL, gives last value returned by + * this function, so this call will return the + * next trace after that one. If NULL, this + * call will return the first trace. */ { return Tcl_VarTraceInfo2(interp, varName, (char *) NULL, flags, proc, prevClientData); } @@ -2791,12 +2865,12 @@ /* *---------------------------------------------------------------------- * * Tcl_VarTraceInfo2 -- * - * Same as Tcl_VarTraceInfo, except takes name in two pieces - * instead of one. + * Same as Tcl_VarTraceInfo, except takes name in two pieces instead of + * one. * * Results: * Same as Tcl_VarTraceInfo. * * Side effects: @@ -2807,21 +2881,20 @@ ClientData Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData) Tcl_Interp *interp; /* Interpreter containing variable. */ CONST char *part1; /* Name of variable or array. */ - CONST char *part2; /* Name of element within array; NULL means + CONST char *part2; /* Name of element within array; NULL means * trace applies to scalar variable or array * as-a-whole. */ int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY. */ - Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ - ClientData prevClientData; /* If non-NULL, gives last value returned - * by this procedure, so this call will - * return the next trace after that one. - * If NULL, this call will return the - * first trace. */ + Tcl_VarTraceProc *proc; /* Function assocated with trace. */ + ClientData prevClientData; /* If non-NULL, gives last value returned by + * this function, so this call will return the + * next trace after that one. If NULL, this + * call will return the first trace. */ { register VarTrace *tracePtr; Var *varPtr, *arrayPtr; varPtr = TclLookupVar(interp, part1, part2, @@ -2844,11 +2917,11 @@ tracePtr = tracePtr->nextPtr; break; } } } - for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { + for (; tracePtr!=NULL ; tracePtr=tracePtr->nextPtr) { if (tracePtr->traceProc == proc) { return tracePtr->clientData; } } return NULL; @@ -2857,120 +2930,129 @@ /* *---------------------------------------------------------------------- * * Tcl_TraceVar -- * - * Arrange for reads and/or writes to a variable to cause a - * procedure to be invoked, which can monitor the operations - * and/or change their actions. + * Arrange for reads and/or writes to a variable to cause a function to + * be invoked, which can monitor the operations and/or change their + * actions. * * Results: * A standard Tcl return value. * * Side effects: - * A trace is set up on the variable given by varName, such that - * future references to the variable will be intermediated by - * proc. See the manual entry for complete details on the calling - * sequence for proc. + * A trace is set up on the variable given by varName, such that future + * references to the variable will be intermediated by proc. See the + * manual entry for complete details on the calling sequence for proc. * *---------------------------------------------------------------------- */ int Tcl_TraceVar(interp, varName, flags, proc, clientData) - Tcl_Interp *interp; /* Interpreter in which variable is - * to be traced. */ - CONST char *varName; /* Name of variable; may end with "(index)" - * to signify an array reference. */ - int flags; /* OR-ed collection of bits, including any - * of TCL_TRACE_READS, TCL_TRACE_WRITES, + Tcl_Interp *interp; /* Interpreter in which variable is to be + * traced. */ + CONST char *varName; /* Name of variable; may end with "(index)" to + * signify an array reference. */ + int flags; /* OR-ed collection of bits, including any of + * TCL_TRACE_READS, TCL_TRACE_WRITES, * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and * TCL_NAMESPACE_ONLY. */ - Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are + Tcl_VarTraceProc *proc; /* Function to call when specified ops are * invoked upon varName. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { - return Tcl_TraceVar2(interp, varName, (char *) NULL, + return Tcl_TraceVar2(interp, varName, (char *) NULL, flags, proc, clientData); } /* *---------------------------------------------------------------------- * * Tcl_TraceVar2 -- * - * Arrange for reads and/or writes to a variable to cause a - * procedure to be invoked, which can monitor the operations - * and/or change their actions. + * Arrange for reads and/or writes to a variable to cause a function to + * be invoked, which can monitor the operations and/or change their + * actions. * * Results: * A standard Tcl return value. * * Side effects: - * A trace is set up on the variable given by part1 and part2, such - * that future references to the variable will be intermediated by - * proc. See the manual entry for complete details on the calling - * sequence for proc. + * A trace is set up on the variable given by part1 and part2, such that + * future references to the variable will be intermediated by proc. See + * the manual entry for complete details on the calling sequence for + * proc. * *---------------------------------------------------------------------- */ int Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) - Tcl_Interp *interp; /* Interpreter in which variable is - * to be traced. */ + Tcl_Interp *interp; /* Interpreter in which variable is to be + * traced. */ CONST char *part1; /* Name of scalar variable or array. */ - CONST char *part2; /* Name of element within array; NULL means + CONST char *part2; /* Name of element within array; NULL means * trace applies to scalar variable or array * as-a-whole. */ - int flags; /* OR-ed collection of bits, including any - * of TCL_TRACE_READS, TCL_TRACE_WRITES, - * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, - * and TCL_NAMESPACE_ONLY. */ - Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are + int flags; /* OR-ed collection of bits, including any of + * TCL_TRACE_READS, TCL_TRACE_WRITES, + * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and + * TCL_NAMESPACE_ONLY. */ + Tcl_VarTraceProc *proc; /* Function to call when specified ops are * invoked upon varName. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { Var *varPtr, *arrayPtr; register VarTrace *tracePtr; int flagMask; - - /* + + /* * We strip 'flags' down to just the parts which are relevant to - * TclLookupVar, to avoid conflicts between trace flags and - * internal namespace flags such as 'TCL_FIND_ONLY_NS'. This can - * now occur since we have trace flags with values 0x1000 and higher. + * TclLookupVar, to avoid conflicts between trace flags and internal + * namespace flags such as 'TCL_FIND_ONLY_NS'. This can now occur since we + * have trace flags with values 0x1000 and higher. */ + flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY; varPtr = TclLookupVar(interp, part1, part2, (flags & flagMask) | TCL_LEAVE_ERR_MSG, "trace", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return TCL_ERROR; } /* - * Check for a nonsense flag combination. Note that this is a - * Tcl_Panic() because there should be no code path that ever sets - * both flags. + * Check for a nonsense flag combination. Note that this is a Tcl_Panic() + * because there should be no code path that ever sets both flags. */ + if ((flags&TCL_TRACE_RESULT_DYNAMIC) && (flags&TCL_TRACE_RESULT_OBJECT)) { Tcl_Panic("bad result flag combination"); } /* * Set up trace information. */ - flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | - TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; + flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | + TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; #ifndef TCL_REMOVE_OBSOLETE_TRACES flagMask |= TCL_TRACE_OLD_STYLE; #endif tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace)); - tracePtr->traceProc = proc; - tracePtr->clientData = clientData; - tracePtr->flags = flags & flagMask; - tracePtr->nextPtr = varPtr->tracePtr; - varPtr->tracePtr = tracePtr; + tracePtr->traceProc = proc; + tracePtr->clientData = clientData; + tracePtr->flags = flags & flagMask; + tracePtr->nextPtr = varPtr->tracePtr; + + varPtr->tracePtr = tracePtr; return TCL_OK; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclUtf.c ================================================================== --- generic/tclUtf.c +++ generic/tclUtf.c @@ -3,14 +3,14 @@ * * Routines for manipulating UTF-8 strings. * * Copyright (c) 1997-1998 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUtf.c,v 1.32 2003/10/08 14:24:41 dkf Exp $ + * RCS: @(#) $Id: tclUtf.c,v 1.32.2.3 2005/09/09 18:48:40 dgp Exp $ */ #include "tclInt.h" /* @@ -18,39 +18,39 @@ */ #include "tclUniData.c" /* - * The following macros are used for fast character category tests. The - * x_BITS values are shifted right by the category value to determine whether - * the given category is included in the set. + * The following macros are used for fast character category tests. The x_BITS + * values are shifted right by the category value to determine whether the + * given category is included in the set. */ #define ALPHA_BITS ((1 << UPPERCASE_LETTER) | (1 << LOWERCASE_LETTER) \ - | (1 << TITLECASE_LETTER) | (1 << MODIFIER_LETTER) | (1 << OTHER_LETTER)) + | (1 << TITLECASE_LETTER) | (1 << MODIFIER_LETTER) | (1< 0) && (ch < UNICODE_SELF)) { - str[0] = (char) ch; + buf[0] = (char) ch; return 1; } - if (ch <= 0x7FF) { - str[1] = (char) ((ch | 0x80) & 0xBF); - str[0] = (char) ((ch >> 6) | 0xC0); - return 2; - } - if (ch <= 0xFFFF) { + if (ch >= 0) { + if (ch <= 0x7FF) { + buf[1] = (char) ((ch | 0x80) & 0xBF); + buf[0] = (char) ((ch >> 6) | 0xC0); + return 2; + } + if (ch <= 0xFFFF) { three: - str[2] = (char) ((ch | 0x80) & 0xBF); - str[1] = (char) (((ch >> 6) | 0x80) & 0xBF); - str[0] = (char) ((ch >> 12) | 0xE0); - return 3; - } + buf[2] = (char) ((ch | 0x80) & 0xBF); + buf[1] = (char) (((ch >> 6) | 0x80) & 0xBF); + buf[0] = (char) ((ch >> 12) | 0xE0); + return 3; + } #if TCL_UTF_MAX > 3 - if (ch <= 0x1FFFFF) { - str[3] = (char) ((ch | 0x80) & 0xBF); - str[2] = (char) (((ch >> 6) | 0x80) & 0xBF); - str[1] = (char) (((ch >> 12) | 0x80) & 0xBF); - str[0] = (char) ((ch >> 18) | 0xF0); - return 4; - } - if (ch <= 0x3FFFFFF) { - str[4] = (char) ((ch | 0x80) & 0xBF); - str[3] = (char) (((ch >> 6) | 0x80) & 0xBF); - str[2] = (char) (((ch >> 12) | 0x80) & 0xBF); - str[1] = (char) (((ch >> 18) | 0x80) & 0xBF); - str[0] = (char) ((ch >> 24) | 0xF8); - return 5; - } - if (ch <= 0x7FFFFFFF) { - str[5] = (char) ((ch | 0x80) & 0xBF); - str[4] = (char) (((ch >> 6) | 0x80) & 0xBF); - str[3] = (char) (((ch >> 12) | 0x80) & 0xBF); - str[2] = (char) (((ch >> 18) | 0x80) & 0xBF); - str[1] = (char) (((ch >> 24) | 0x80) & 0xBF); - str[0] = (char) ((ch >> 30) | 0xFC); - return 6; - } + if (ch <= 0x1FFFFF) { + buf[3] = (char) ((ch | 0x80) & 0xBF); + buf[2] = (char) (((ch >> 6) | 0x80) & 0xBF); + buf[1] = (char) (((ch >> 12) | 0x80) & 0xBF); + buf[0] = (char) ((ch >> 18) | 0xF0); + return 4; + } + if (ch <= 0x3FFFFFF) { + buf[4] = (char) ((ch | 0x80) & 0xBF); + buf[3] = (char) (((ch >> 6) | 0x80) & 0xBF); + buf[2] = (char) (((ch >> 12) | 0x80) & 0xBF); + buf[1] = (char) (((ch >> 18) | 0x80) & 0xBF); + buf[0] = (char) ((ch >> 24) | 0xF8); + return 5; + } + if (ch <= 0x7FFFFFFF) { + buf[5] = (char) ((ch | 0x80) & 0xBF); + buf[4] = (char) (((ch >> 6) | 0x80) & 0xBF); + buf[3] = (char) (((ch >> 12) | 0x80) & 0xBF); + buf[2] = (char) (((ch >> 18) | 0x80) & 0xBF); + buf[1] = (char) (((ch >> 24) | 0x80) & 0xBF); + buf[0] = (char) ((ch >> 30) | 0xFC); + return 6; + } #endif + } ch = 0xFFFD; goto three; } @@ -220,27 +221,26 @@ * * Convert the given Unicode string to UTF-8. * * Results: * The return value is a pointer to the UTF-8 representation of the - * Unicode string. Storage for the return value is appended to the - * end of dsPtr. + * Unicode string. Storage for the return value is appended to the end of + * dsPtr. * * Side effects: * None. * *--------------------------------------------------------------------------- */ char * -Tcl_UniCharToUtfDString(wString, numChars, dsPtr) - CONST Tcl_UniChar *wString; /* Unicode string to convert to UTF-8. */ - int numChars; /* Length of Unicode string in Tcl_UniChars +Tcl_UniCharToUtfDString(uniStr, uniLength, dsPtr) + CONST Tcl_UniChar *uniStr; /* Unicode string to convert to UTF-8. */ + int uniLength; /* Length of Unicode string in Tcl_UniChars * (must be >= 0). */ - Tcl_DString *dsPtr; /* UTF-8 representation of string is - * appended to this previously initialized - * DString. */ + Tcl_DString *dsPtr; /* UTF-8 representation of string is appended + * to this previously initialized DString. */ { CONST Tcl_UniChar *w, *wEnd; char *p, *string; int oldLength; @@ -248,16 +248,16 @@ * UTF-8 string length in bytes will be <= Unicode string length * * TCL_UTF_MAX. */ oldLength = Tcl_DStringLength(dsPtr); - Tcl_DStringSetLength(dsPtr, (oldLength + numChars + 1) * TCL_UTF_MAX); + Tcl_DStringSetLength(dsPtr, (oldLength + uniLength + 1) * TCL_UTF_MAX); string = Tcl_DStringValue(dsPtr) + oldLength; p = string; - wEnd = wString + numChars; - for (w = wString; w < wEnd; ) { + wEnd = uniStr + uniLength; + for (w = uniStr; w < wEnd; ) { p += Tcl_UniCharToUtf(*w, p); w++; } Tcl_DStringSetLength(dsPtr, oldLength + (p - string)); @@ -267,20 +267,20 @@ /* *--------------------------------------------------------------------------- * * Tcl_UtfToUniChar -- * - * Extract the Tcl_UniChar represented by the UTF-8 string. Bad - * UTF-8 sequences are converted to valid Tcl_UniChars and processing - * continues. Equivalent to Plan 9 chartorune(). - * - * The caller must ensure that the source buffer is long enough that - * this routine does not run off the end and dereference non-existent - * memory looking for trail bytes. If the source buffer is known to - * be '\0' terminated, this cannot happen. Otherwise, the caller - * should call Tcl_UtfCharComplete() before calling this routine to - * ensure that enough bytes remain in the string. + * Extract the Tcl_UniChar represented by the UTF-8 string. Bad UTF-8 + * sequences are converted to valid Tcl_UniChars and processing + * continues. Equivalent to Plan 9 chartorune(). + * + * The caller must ensure that the source buffer is long enough that this + * routine does not run off the end and dereference non-existent memory + * looking for trail bytes. If the source buffer is known to be '\0' + * terminated, this cannot happen. Otherwise, the caller should call + * Tcl_UtfCharComplete() before calling this routine to ensure that + * enough bytes remain in the string. * * Results: * *chPtr is filled with the Tcl_UniChar, and the return value is the * number of bytes from the UTF-8 string that were consumed. * @@ -289,22 +289,22 @@ * *--------------------------------------------------------------------------- */ int -Tcl_UtfToUniChar(str, chPtr) - register CONST char *str; /* The UTF-8 string. */ - register Tcl_UniChar *chPtr; /* Filled with the Tcl_UniChar represented - * by the UTF-8 string. */ +Tcl_UtfToUniChar(src, chPtr) + register CONST char *src; /* The UTF-8 string. */ + register Tcl_UniChar *chPtr; /* Filled with the Tcl_UniChar represented by + * the UTF-8 string. */ { register int byte; /* * Unroll 1 to 3 byte UTF-8 sequences, use loop to handle longer ones. */ - byte = *((unsigned char *) str); + byte = *((unsigned char *) src); if (byte < 0xC0) { /* * Handles properly formed UTF-8 characters between 0x01 and 0x7F. * Also treats \0 and naked trail bytes 0x80 to 0xBF as valid * characters representing themselves. @@ -311,35 +311,37 @@ */ *chPtr = (Tcl_UniChar) byte; return 1; } else if (byte < 0xE0) { - if ((str[1] & 0xC0) == 0x80) { + if ((src[1] & 0xC0) == 0x80) { /* * Two-byte-character lead-byte followed by a trail-byte. */ - *chPtr = (Tcl_UniChar) (((byte & 0x1F) << 6) | (str[1] & 0x3F)); + *chPtr = (Tcl_UniChar) (((byte & 0x1F) << 6) | (src[1] & 0x3F)); return 2; } + /* * A two-byte-character lead-byte not followed by trail-byte * represents itself. */ *chPtr = (Tcl_UniChar) byte; return 1; } else if (byte < 0xF0) { - if (((str[1] & 0xC0) == 0x80) && ((str[2] & 0xC0) == 0x80)) { + if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80)) { /* * Three-byte-character lead byte followed by two trail bytes. */ *chPtr = (Tcl_UniChar) (((byte & 0x0F) << 12) - | ((str[1] & 0x3F) << 6) | (str[2] & 0x3F)); + | ((src[1] & 0x3F) << 6) | (src[2] & 0x3F)); return 3; } + /* * A three-byte-character lead-byte not followed by two trail-bytes * represents itself. */ @@ -353,17 +355,17 @@ total = totalBytes[byte]; trail = total - 1; if (trail > 0) { ch = byte & (0x3F >> trail); do { - str++; - if ((*str & 0xC0) != 0x80) { + src++; + if ((*src & 0xC0) != 0x80) { *chPtr = byte; return 1; } ch <<= 6; - ch |= (*str & 0x3F); + ch |= (*src & 0x3F); trail--; } while (trail > 0); *chPtr = ch; return total; } @@ -381,50 +383,49 @@ * * Convert the UTF-8 string to Unicode. * * Results: * The return value is a pointer to the Unicode representation of the - * UTF-8 string. Storage for the return value is appended to the - * end of dsPtr. The Unicode string is terminated with a Unicode - * NULL character. + * UTF-8 string. Storage for the return value is appended to the end of + * dsPtr. The Unicode string is terminated with a Unicode NULL character. * * Side effects: * None. * *--------------------------------------------------------------------------- */ Tcl_UniChar * -Tcl_UtfToUniCharDString(string, length, dsPtr) - CONST char *string; /* UTF-8 string to convert to Unicode. */ - int length; /* Length of UTF-8 string in bytes, or -1 - * for strlen(). */ +Tcl_UtfToUniCharDString(src, length, dsPtr) + CONST char *src; /* UTF-8 string to convert to Unicode. */ + int length; /* Length of UTF-8 string in bytes, or -1 for + * strlen(). */ Tcl_DString *dsPtr; /* Unicode representation of string is * appended to this previously initialized * DString. */ { Tcl_UniChar *w, *wString; CONST char *p, *end; int oldLength; if (length < 0) { - length = strlen(string); + length = strlen(src); } /* - * Unicode string length in Tcl_UniChars will be <= UTF-8 string length - * in bytes. + * Unicode string length in Tcl_UniChars will be <= UTF-8 string length in + * bytes. */ oldLength = Tcl_DStringLength(dsPtr); Tcl_DStringSetLength(dsPtr, (int) ((oldLength + length + 1) * sizeof(Tcl_UniChar))); wString = (Tcl_UniChar *) (Tcl_DStringValue(dsPtr) + oldLength); w = wString; - end = string + length; - for (p = string; p < end; ) { + end = src + length; + for (p = src; p < end; ) { p += TclUtfToUniChar(p, w); w++; } *w = '\0'; Tcl_DStringSetLength(dsPtr, @@ -436,13 +437,13 @@ /* *--------------------------------------------------------------------------- * * Tcl_UtfCharComplete -- * - * Determine if the UTF-8 string of the given length is long enough - * to be decoded by Tcl_UtfToUniChar(). This does not ensure that the - * UTF-8 string is properly formed. Equivalent to Plan 9 fullrune(). + * Determine if the UTF-8 string of the given length is long enough to be + * decoded by Tcl_UtfToUniChar(). This does not ensure that the UTF-8 + * string is properly formed. Equivalent to Plan 9 fullrune(). * * Results: * The return value is 0 if the string is not long enough, non-zero * otherwise. * @@ -451,29 +452,29 @@ * *--------------------------------------------------------------------------- */ int -Tcl_UtfCharComplete(str, len) - CONST char *str; /* String to check if first few bytes - * contain a complete UTF-8 character. */ - int len; /* Length of above string in bytes. */ +Tcl_UtfCharComplete(src, length) + CONST char *src; /* String to check if first few bytes contain + * a complete UTF-8 character. */ + int length; /* Length of above string in bytes. */ { int ch; - ch = *((unsigned char *) str); - return len >= totalBytes[ch]; + ch = *((unsigned char *) src); + return length >= totalBytes[ch]; } /* *--------------------------------------------------------------------------- * * Tcl_NumUtfChars -- * - * Returns the number of characters (not bytes) in the UTF-8 string, - * not including the terminating NULL byte. This is equivalent to - * Plan 9 utflen() and utfnlen(). + * Returns the number of characters (not bytes) in the UTF-8 string, not + * including the terminating NULL byte. This is equivalent to Plan 9 + * utflen() and utfnlen(). * * Results: * As above. * * Side effects: @@ -481,43 +482,43 @@ * *--------------------------------------------------------------------------- */ int -Tcl_NumUtfChars(str, len) - register CONST char *str; /* The UTF-8 string to measure. */ - int len; /* The length of the string in bytes, or -1 +Tcl_NumUtfChars(src, length) + register CONST char *src; /* The UTF-8 string to measure. */ + int length; /* The length of the string in bytes, or -1 * for strlen(string). */ { Tcl_UniChar ch; register Tcl_UniChar *chPtr = &ch; register int i; /* * The separate implementations are faster. * - * Since this is a time-sensitive function, we also do the check for - * the single-byte char case specially. + * Since this is a time-sensitive function, we also do the check for the + * single-byte char case specially. */ i = 0; - if (len < 0) { - while (*str != '\0') { - str += TclUtfToUniChar(str, chPtr); + if (length < 0) { + while (*src != '\0') { + src += TclUtfToUniChar(src, chPtr); i++; } } else { register int n; - while (len > 0) { - if (UCHAR(*str) < 0xC0) { - len--; - str++; + while (length > 0) { + if (UCHAR(*src) < 0xC0) { + length--; + src++; } else { - n = Tcl_UtfToUniChar(str, chPtr); - len -= n; - str += n; + n = Tcl_UtfToUniChar(src, chPtr); + length -= n; + src += n; } i++; } } return i; @@ -526,153 +527,149 @@ /* *--------------------------------------------------------------------------- * * Tcl_UtfFindFirst -- * - * Returns a pointer to the first occurance of the given Tcl_UniChar - * in the NULL-terminated UTF-8 string. The NULL terminator is - * considered part of the UTF-8 string. Equivalent to Plan 9 - * utfrune(). + * Returns a pointer to the first occurance of the given Tcl_UniChar in + * the NULL-terminated UTF-8 string. The NULL terminator is considered + * part of the UTF-8 string. Equivalent to Plan 9 utfrune(). * * Results: - * As above. If the Tcl_UniChar does not exist in the given string, - * the return value is NULL. + * As above. If the Tcl_UniChar does not exist in the given string, the + * return value is NULL. * * Side effects: * None. * *--------------------------------------------------------------------------- */ CONST char * -Tcl_UtfFindFirst(string, ch) - CONST char *string; /* The UTF-8 string to be searched. */ +Tcl_UtfFindFirst(src, ch) + CONST char *src; /* The UTF-8 string to be searched. */ int ch; /* The Tcl_UniChar to search for. */ { int len; Tcl_UniChar find; while (1) { - len = TclUtfToUniChar(string, &find); + len = TclUtfToUniChar(src, &find); if (find == ch) { - return string; + return src; } - if (*string == '\0') { + if (*src == '\0') { return NULL; } - string += len; + src += len; } } /* *--------------------------------------------------------------------------- * * Tcl_UtfFindLast -- * - * Returns a pointer to the last occurance of the given Tcl_UniChar - * in the NULL-terminated UTF-8 string. The NULL terminator is - * considered part of the UTF-8 string. Equivalent to Plan 9 - * utfrrune(). + * Returns a pointer to the last occurance of the given Tcl_UniChar in + * the NULL-terminated UTF-8 string. The NULL terminator is considered + * part of the UTF-8 string. Equivalent to Plan 9 utfrrune(). * * Results: - * As above. If the Tcl_UniChar does not exist in the given string, - * the return value is NULL. + * As above. If the Tcl_UniChar does not exist in the given string, the + * return value is NULL. * * Side effects: * None. * *--------------------------------------------------------------------------- */ CONST char * -Tcl_UtfFindLast(string, ch) - CONST char *string; /* The UTF-8 string to be searched. */ +Tcl_UtfFindLast(src, ch) + CONST char *src; /* The UTF-8 string to be searched. */ int ch; /* The Tcl_UniChar to search for. */ { int len; Tcl_UniChar find; CONST char *last; last = NULL; while (1) { - len = TclUtfToUniChar(string, &find); + len = TclUtfToUniChar(src, &find); if (find == ch) { - last = string; + last = src; } - if (*string == '\0') { + if (*src == '\0') { break; } - string += len; + src += len; } return last; } /* *--------------------------------------------------------------------------- * * Tcl_UtfNext -- * - * Given a pointer to some current location in a UTF-8 string, - * move forward one character. The caller must ensure that they - * are not asking for the next character after the last character - * in the string. + * Given a pointer to some current location in a UTF-8 string, move + * forward one character. The caller must ensure that they are not asking + * for the next character after the last character in the string. * * Results: - * The return value is the pointer to the next character in - * the UTF-8 string. + * The return value is the pointer to the next character in the UTF-8 + * string. * * Side effects: * None. * *--------------------------------------------------------------------------- */ CONST char * -Tcl_UtfNext(str) - CONST char *str; /* The current location in the string. */ +Tcl_UtfNext(src) + CONST char *src; /* The current location in the string. */ { Tcl_UniChar ch; - return str + TclUtfToUniChar(str, &ch); + return src + TclUtfToUniChar(src, &ch); } /* *--------------------------------------------------------------------------- * * Tcl_UtfPrev -- * - * Given a pointer to some current location in a UTF-8 string, - * move backwards one character. This works correctly when the - * pointer is in the middle of a UTF-8 character. + * Given a pointer to some current location in a UTF-8 string, move + * backwards one character. This works correctly when the pointer is in + * the middle of a UTF-8 character. * * Results: - * The return value is a pointer to the previous character in the - * UTF-8 string. If the current location was already at the - * beginning of the string, the return value will also be a - * pointer to the beginning of the string. + * The return value is a pointer to the previous character in the UTF-8 + * string. If the current location was already at the beginning of the + * string, the return value will also be a pointer to the beginning of + * the string. * * Side effects: * None. * *--------------------------------------------------------------------------- */ CONST char * -Tcl_UtfPrev(str, start) - CONST char *str; /* The current location in the string. */ - CONST char *start; /* Pointer to the beginning of the - * string, to avoid going backwards too - * far. */ +Tcl_UtfPrev(src, start) + CONST char *src; /* The current location in the string. */ + CONST char *start; /* Pointer to the beginning of the string, to + * avoid going backwards too far. */ { CONST char *look; int i, byte; - str--; - look = str; + src--; + look = src; for (i = 0; i < TCL_UTF_MAX; i++) { if (look < start) { - if (str < start) { - str = start; + if (src < start) { + src = start; } break; } byte = *((unsigned char *) look); if (byte < 0x80) { @@ -681,20 +678,20 @@ if (byte >= 0xC0) { return look; } look--; } - return str; + return src; } /* *--------------------------------------------------------------------------- * * Tcl_UniCharAtIndex -- * - * Returns the Unicode character represented at the specified - * character (not byte) position in the UTF-8 string. + * Returns the Unicode character represented at the specified character + * (not byte) position in the UTF-8 string. * * Results: * As above. * * Side effects: @@ -720,12 +717,12 @@ /* *--------------------------------------------------------------------------- * * Tcl_UtfAtIndex -- * - * Returns a pointer to the specified character (not byte) position - * in the UTF-8 string. + * Returns a pointer to the specified character (not byte) position in + * the UTF-8 string. * * Results: * As above. * * Side effects: @@ -755,34 +752,33 @@ * * Figure out how to handle a backslash sequence. * * Results: * Stores the bytes represented by the backslash sequence in dst and - * returns the number of bytes written to dst. At most TCL_UTF_MAX - * bytes are written to dst; dst must have been large enough to accept - * those bytes. If readPtr isn't NULL then it is filled in with a - * count of the number of bytes in the backslash sequence. + * returns the number of bytes written to dst. At most TCL_UTF_MAX bytes + * are written to dst; dst must have been large enough to accept those + * bytes. If readPtr isn't NULL then it is filled in with a count of the + * number of bytes in the backslash sequence. * * Side effects: - * The maximum number of bytes it takes to represent a Unicode - * character in UTF-8 is guaranteed to be less than the number of - * bytes used to express the backslash sequence that represents - * that Unicode character. If the target buffer into which the - * caller is going to store the bytes that represent the Unicode - * character is at least as large as the source buffer from which - * the backslashed sequence was extracted, no buffer overruns should - * occur. + * The maximum number of bytes it takes to represent a Unicode character + * in UTF-8 is guaranteed to be less than the number of bytes used to + * express the backslash sequence that represents that Unicode character. + * If the target buffer into which the caller is going to store the bytes + * that represent the Unicode character is at least as large as the + * source buffer from which the backslashed sequence was extracted, no + * buffer overruns should occur. * *--------------------------------------------------------------------------- */ int Tcl_UtfBackslash(src, readPtr, dst) - CONST char *src; /* Points to the backslash character of - * a backslash sequence. */ - int *readPtr; /* Fill in with number of characters read - * from src, unless NULL. */ + CONST char *src; /* Points to the backslash character of a + * backslash sequence. */ + int *readPtr; /* Fill in with number of characters read from + * src, unless NULL. */ char *dst; /* Filled with the bytes represented by the * backslash sequence. */ { #define LINE_LENGTH 128 int numRead; @@ -802,16 +798,16 @@ /* *---------------------------------------------------------------------- * * Tcl_UtfToUpper -- * - * Convert lowercase characters to uppercase characters in a UTF - * string in place. The conversion may shrink the UTF string. + * Convert lowercase characters to uppercase characters in a UTF string + * in place. The conversion may shrink the UTF string. * * Results: - * Returns the number of bytes in the resulting string - * excluding the trailing null. + * Returns the number of bytes in the resulting string excluding the + * trailing null. * * Side effects: * Writes a terminating null after the last converted character. * *---------------------------------------------------------------------- @@ -829,17 +825,17 @@ * Iterate over the string until we hit the terminating null. */ src = dst = str; while (*src) { - bytes = TclUtfToUniChar(src, &ch); + bytes = TclUtfToUniChar(src, &ch); upChar = Tcl_UniCharToUpper(ch); /* - * To keep badly formed Utf strings from getting inflated by - * the conversion (thereby causing a segfault), only copy the - * upper case char to dst if its size is <= the original char. + * To keep badly formed Utf strings from getting inflated by the + * conversion (thereby causing a segfault), only copy the upper case + * char to dst if its size is <= the original char. */ if (bytes < UtfCount(upChar)) { memcpy(dst, src, (size_t) bytes); dst += bytes; @@ -855,16 +851,16 @@ /* *---------------------------------------------------------------------- * * Tcl_UtfToLower -- * - * Convert uppercase characters to lowercase characters in a UTF - * string in place. The conversion may shrink the UTF string. + * Convert uppercase characters to lowercase characters in a UTF string + * in place. The conversion may shrink the UTF string. * * Results: - * Returns the number of bytes in the resulting string - * excluding the trailing null. + * Returns the number of bytes in the resulting string excluding the + * trailing null. * * Side effects: * Writes a terminating null after the last converted character. * *---------------------------------------------------------------------- @@ -886,13 +882,13 @@ while (*src) { bytes = TclUtfToUniChar(src, &ch); lowChar = Tcl_UniCharToLower(ch); /* - * To keep badly formed Utf strings from getting inflated by - * the conversion (thereby causing a segfault), only copy the - * lower case char to dst if its size is <= the original char. + * To keep badly formed Utf strings from getting inflated by the + * conversion (thereby causing a segfault), only copy the lower case + * char to dst if its size is <= the original char. */ if (bytes < UtfCount(lowChar)) { memcpy(dst, src, (size_t) bytes); dst += bytes; @@ -908,17 +904,17 @@ /* *---------------------------------------------------------------------- * * Tcl_UtfToTitle -- * - * Changes the first character of a UTF string to title case or - * uppercase and the rest of the string to lowercase. The - * conversion happens in place and may shrink the UTF string. + * Changes the first character of a UTF string to title case or uppercase + * and the rest of the string to lowercase. The conversion happens in + * place and may shrink the UTF string. * * Results: - * Returns the number of bytes in the resulting string - * excluding the trailing null. + * Returns the number of bytes in the resulting string excluding the + * trailing null. * * Side effects: * Writes a terminating null after the last converted character. * *---------------------------------------------------------------------- @@ -970,12 +966,12 @@ /* *---------------------------------------------------------------------- * * TclpUtfNcmp2 -- * - * Compare at most n bytes of utf-8 strings cs and ct. Both cs - * and ct are assumed to be at least n bytes long. + * Compare at most n bytes of utf-8 strings cs and ct. Both cs and ct are + * assumed to be at least n bytes long. * * Results: * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. * * Side effects: @@ -989,14 +985,15 @@ CONST char *cs; /* UTF string to compare to ct. */ CONST char *ct; /* UTF string cs is compared to. */ unsigned long n; /* Number of *bytes* to compare. */ { /* - * We can't simply call 'memcmp(cs, ct, n);' because we need to check - * for Tcl's \xC0\x80 non-utf-8 null encoding. - * Otherwise utf-8 lexes fine in the strcmp manner. + * We can't simply call 'memcmp(cs, ct, n);' because we need to check for + * Tcl's \xC0\x80 non-utf-8 null encoding. Otherwise utf-8 lexes fine in + * the strcmp manner. */ + register int result = 0; for ( ; n != 0; n--, cs++, ct++) { if (*cs != *ct) { result = UCHAR(*cs) - UCHAR(*ct); @@ -1003,10 +1000,11 @@ break; } } if (n && ((UCHAR(*cs) == 0xC0) || (UCHAR(*ct) == 0xC0))) { unsigned char c1, c2; + c1 = ((UCHAR(*cs) == 0xC0) && (UCHAR(cs[1]) == 0x80)) ? 0 : UCHAR(*cs); c2 = ((UCHAR(*ct) == 0xC0) && (UCHAR(ct[1]) == 0x80)) ? 0 : UCHAR(*ct); result = (c1 - c2); } return result; @@ -1015,12 +1013,12 @@ /* *---------------------------------------------------------------------- * * Tcl_UtfNcmp -- * - * Compare at most n UTF chars of string cs to string ct. Both cs - * and ct are assumed to be at least n UTF chars long. + * Compare at most numChars UTF chars of string cs to string ct. Both cs + * and ct are assumed to be at least numChars UTF chars long. * * Results: * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. * * Side effects: @@ -1028,27 +1026,30 @@ * *---------------------------------------------------------------------- */ int -Tcl_UtfNcmp(cs, ct, n) +Tcl_UtfNcmp(cs, ct, numChars) CONST char *cs; /* UTF string to compare to ct. */ CONST char *ct; /* UTF string cs is compared to. */ - unsigned long n; /* Number of UTF chars to compare. */ + unsigned long numChars; /* Number of UTF chars to compare. */ { Tcl_UniChar ch1, ch2; - /* - * Cannot use 'memcmp(cs, ct, n);' as byte representation of - * \u0000 (the pair of bytes 0xc0,0x80) is larger than byte - * representation of \u0001 (the byte 0x01.) - */ - while (n-- > 0) { - /* - * n must be interpreted as chars, not bytes. - * This should be called only when both strings are of - * at least n chars long (no need for \0 check) - */ + + /* + * Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the + * pair of bytes 0xc0,0x80) is larger than byte representation of \u0001 + * (the byte 0x01.) + */ + + while (numChars-- > 0) { + /* + * n must be interpreted as chars, not bytes. This should be called + * only when both strings are of at least n chars long (no need for \0 + * check) + */ + cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { return (ch1 - ch2); } @@ -1059,12 +1060,12 @@ /* *---------------------------------------------------------------------- * * Tcl_UtfNcasecmp -- * - * Compare at most n UTF chars of string cs to string ct case - * insensitive. Both cs and ct are assumed to be at least n + * Compare at most numChars UTF chars of string cs to string ct case + * insensitive. Both cs and ct are assumed to be at least numChars * UTF chars long. * * Results: * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. * @@ -1073,17 +1074,17 @@ * *---------------------------------------------------------------------- */ int -Tcl_UtfNcasecmp(cs, ct, n) +Tcl_UtfNcasecmp(cs, ct, numChars) CONST char *cs; /* UTF string to compare to ct. */ CONST char *ct; /* UTF string cs is compared to. */ - unsigned long n; /* Number of UTF chars to compare. */ + unsigned long numChars; /* Number of UTF chars to compare. */ { Tcl_UniChar ch1, ch2; - while (n-- > 0) { + while (numChars-- > 0) { /* * n must be interpreted as chars, not bytes. * This should be called only when both strings are of * at least n chars long (no need for \0 check) */ @@ -1210,58 +1211,60 @@ * *---------------------------------------------------------------------- */ int -Tcl_UniCharLen(str) - CONST Tcl_UniChar *str; /* Unicode string to find length of. */ +Tcl_UniCharLen(uniStr) + CONST Tcl_UniChar *uniStr; /* Unicode string to find length of. */ { int len = 0; - while (*str != '\0') { + while (*uniStr != '\0') { len++; - str++; + uniStr++; } return len; } /* *---------------------------------------------------------------------- * * Tcl_UniCharNcmp -- * - * Compare at most n unichars of string cs to string ct. Both cs - * and ct are assumed to be at least n unichars long. + * Compare at most numChars unichars of string ucs to string uct. + * Both ucs and uct are assumed to be at least numChars unichars long. * * Results: - * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. + * Return <0 if ucs < uct, 0 if ucs == uct, or >0 if ucs > uct. * * Side effects: * None. * *---------------------------------------------------------------------- */ int -Tcl_UniCharNcmp(cs, ct, n) - CONST Tcl_UniChar *cs; /* Unicode string to compare to ct. */ - CONST Tcl_UniChar *ct; /* Unicode string cs is compared to. */ - unsigned long n; /* Number of unichars to compare. */ +Tcl_UniCharNcmp(ucs, uct, numChars) + CONST Tcl_UniChar *ucs; /* Unicode string to compare to uct. */ + CONST Tcl_UniChar *uct; /* Unicode string ucs is compared to. */ + unsigned long numChars; /* Number of unichars to compare. */ { #ifdef WORDS_BIGENDIAN /* * We are definitely on a big-endian machine; memcmp() is safe */ - return memcmp(cs, ct, n*sizeof(Tcl_UniChar)); + + return memcmp(ucs, uct, numChars*sizeof(Tcl_UniChar)); #else /* !WORDS_BIGENDIAN */ /* * We can't simply call memcmp() because that is not lexically correct. */ - for ( ; n != 0; cs++, ct++, n--) { - if (*cs != *ct) { - return (*cs - *ct); + + for ( ; numChars != 0; ucs++, uct++, numChars--) { + if (*ucs != *uct) { + return (*ucs - *uct); } } return 0; #endif /* WORDS_BIGENDIAN */ } @@ -1269,33 +1272,33 @@ /* *---------------------------------------------------------------------- * * Tcl_UniCharNcasecmp -- * - * Compare at most n unichars of string cs to string ct case - * insensitive. Both cs and ct are assumed to be at least n + * Compare at most numChars unichars of string ucs to string uct case + * insensitive. Both ucs and uct are assumed to be at least numChars * unichars long. * * Results: - * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. + * Return <0 if ucs < uct, 0 if ucs == uct, or >0 if ucs > uct. * * Side effects: * None. * *---------------------------------------------------------------------- */ int -Tcl_UniCharNcasecmp(cs, ct, n) - CONST Tcl_UniChar *cs; /* Unicode string to compare to ct. */ - CONST Tcl_UniChar *ct; /* Unicode string cs is compared to. */ - unsigned long n; /* Number of unichars to compare. */ -{ - for ( ; n != 0; n--, cs++, ct++) { - if (*cs != *ct) { - Tcl_UniChar lcs = Tcl_UniCharToLower(*cs); - Tcl_UniChar lct = Tcl_UniCharToLower(*ct); +Tcl_UniCharNcasecmp(ucs, uct, numChars) + CONST Tcl_UniChar *ucs; /* Unicode string to compare to uct. */ + CONST Tcl_UniChar *uct; /* Unicode string ucs is compared to. */ + unsigned long numChars; /* Number of unichars to compare. */ +{ + for ( ; numChars != 0; numChars--, ucs++, uct++) { + if (*ucs != *uct) { + Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs); + Tcl_UniChar lct = Tcl_UniCharToLower(*uct); if (lcs != lct) { return (lcs - lct); } } } @@ -1554,12 +1557,11 @@ /* *---------------------------------------------------------------------- * * Tcl_UniCharIsWordChar -- * - * Test if a character is alphanumeric or a connector punctuation - * mark. + * Test if a character is alphanumeric or a connector punctuation mark. * * Results: * Returns 1 if character is a word character. * * Side effects: @@ -1581,67 +1583,70 @@ *---------------------------------------------------------------------- * * Tcl_UniCharCaseMatch -- * * See if a particular Unicode string matches a particular pattern. - * Allows case insensitivity. This is the Unicode equivalent of - * the char* Tcl_StringCaseMatch. The UniChar strings must be - * NULL-terminated. This has no provision for counted UniChar - * strings, thus should not be used where NULLs are expected in the - * UniChar string. Use TclUniCharMatch where possible. + * Allows case insensitivity. This is the Unicode equivalent of the char* + * Tcl_StringCaseMatch. The UniChar strings must be NULL-terminated. + * This has no provision for counted UniChar strings, thus should not be + * used where NULLs are expected in the UniChar string. Use + * TclUniCharMatch where possible. * * Results: - * The return value is 1 if string matches pattern, and - * 0 otherwise. The matching operation permits the following - * special characters in the pattern: *?\[] (see the manual - * entry for details on what these mean). + * The return value is 1 if string matches pattern, and 0 otherwise. The + * matching operation permits the following special characters in the + * pattern: *?\[] (see the manual entry for details on what these mean). * * Side effects: * None. * *---------------------------------------------------------------------- */ int -Tcl_UniCharCaseMatch(string, pattern, nocase) - CONST Tcl_UniChar *string; /* Unicode String. */ - CONST Tcl_UniChar *pattern; /* Pattern, which may contain special +Tcl_UniCharCaseMatch(uniStr, uniPattern, nocase) + CONST Tcl_UniChar *uniStr; /* Unicode String. */ + CONST Tcl_UniChar *uniPattern; + /* Pattern, which may contain special * characters. */ int nocase; /* 0 for case sensitive, 1 for insensitive */ { Tcl_UniChar ch1, p; while (1) { - p = *pattern; + p = *uniPattern; /* - * See if we're at the end of both the pattern and the string. If - * so, we succeeded. If we're at the end of the pattern but not at - * the end of the string, we failed. + * See if we're at the end of both the pattern and the string. If so, + * we succeeded. If we're at the end of the pattern but not at the end + * of the string, we failed. */ if (p == 0) { - return (*string == 0); + return (*uniStr == 0); } - if ((*string == 0) && (p != '*')) { + if ((*uniStr == 0) && (p != '*')) { return 0; } /* - * Check for a "*" as the next pattern character. It matches any - * substring. We handle this by skipping all the characters up to the + * Check for a "*" as the next pattern character. It matches any + * substring. We handle this by skipping all the characters up to the * next matching one in the pattern, and then calling ourselves * recursively for each postfix of string, until either we match or we * reach the end of the string. */ if (p == '*') { /* * Skip all successive *'s in the pattern */ - while (*(++pattern) == '*') {} - p = *pattern; + + while (*(++uniPattern) == '*') { + /* empty body */ + } + p = *uniPattern; if (p == 0) { return 1; } if (nocase) { p = Tcl_UniCharToLower(p); @@ -1650,67 +1655,71 @@ /* * Optimization for matching - cruise through the string * quickly if the next char in the pattern isn't a special * character */ + if ((p != '[') && (p != '?') && (p != '\\')) { if (nocase) { - while (*string && (p != *string) - && (p != Tcl_UniCharToLower(*string))) { - string++; + while (*uniStr && (p != *uniStr) + && (p != Tcl_UniCharToLower(*uniStr))) { + uniStr++; } } else { - while (*string && (p != *string)) { string++; } + while (*uniStr && (p != *uniStr)) { + uniStr++; + } } } - if (Tcl_UniCharCaseMatch(string, pattern, nocase)) { + if (Tcl_UniCharCaseMatch(uniStr, uniPattern, nocase)) { return 1; } - if (*string == 0) { + if (*uniStr == 0) { return 0; } - string++; + uniStr++; } } /* - * Check for a "?" as the next pattern character. It matches - * any single character. + * Check for a "?" as the next pattern character. It matches any + * single character. */ if (p == '?') { - pattern++; - string++; + uniPattern++; + uniStr++; continue; } /* - * Check for a "[" as the next pattern character. It is followed - * by a list of characters that are acceptable, or by a range - * (two characters separated by "-"). + * Check for a "[" as the next pattern character. It is followed by a + * list of characters that are acceptable, or by a range (two + * characters separated by "-"). */ if (p == '[') { Tcl_UniChar startChar, endChar; - pattern++; - ch1 = (nocase ? Tcl_UniCharToLower(*string) : *string); - string++; - while (1) { - if ((*pattern == ']') || (*pattern == 0)) { - return 0; - } - startChar = (nocase ? Tcl_UniCharToLower(*pattern) : *pattern); - pattern++; - if (*pattern == '-') { - pattern++; - if (*pattern == 0) { - return 0; - } - endChar = (nocase ? Tcl_UniCharToLower(*pattern) - : *pattern); - pattern++; + uniPattern++; + ch1 = (nocase ? Tcl_UniCharToLower(*uniStr) : *uniStr); + uniStr++; + while (1) { + if ((*uniPattern == ']') || (*uniPattern == 0)) { + return 0; + } + startChar = (nocase ? Tcl_UniCharToLower(*uniPattern) + : *uniPattern); + uniPattern++; + if (*uniPattern == '-') { + uniPattern++; + if (*uniPattern == 0) { + return 0; + } + endChar = (nocase ? Tcl_UniCharToLower(*uniPattern) + : *uniPattern); + uniPattern++; if (((startChar <= ch1) && (ch1 <= endChar)) || ((endChar <= ch1) && (ch1 <= startChar))) { /* * Matches ranges of form [a-z] or [z-a]. */ @@ -1718,64 +1727,64 @@ } } else if (startChar == ch1) { break; } } - while (*pattern != ']') { - if (*pattern == 0) { - pattern--; + while (*uniPattern != ']') { + if (*uniPattern == 0) { + uniPattern--; break; } - pattern++; + uniPattern++; } - pattern++; + uniPattern++; continue; } /* - * If the next pattern character is '\', just strip off the '\' - * so we do exact matching on the character that follows. + * If the next pattern character is '\', just strip off the '\' so we + * do exact matching on the character that follows. */ if (p == '\\') { - if (*(++pattern) == '\0') { + if (*(++uniPattern) == '\0') { return 0; } } /* - * There's no special character. Just make sure that the next - * bytes of each string match. + * There's no special character. Just make sure that the next bytes + * of each string match. */ if (nocase) { - if (Tcl_UniCharToLower(*string) != Tcl_UniCharToLower(*pattern)) { + if (Tcl_UniCharToLower(*uniStr) != + Tcl_UniCharToLower(*uniPattern)) { return 0; } - } else if (*string != *pattern) { + } else if (*uniStr != *uniPattern) { return 0; } - string++; - pattern++; + uniStr++; + uniPattern++; } } /* *---------------------------------------------------------------------- * * TclUniCharMatch -- * * See if a particular Unicode string matches a particular pattern. - * Allows case insensitivity. This is the Unicode equivalent of the - * char* Tcl_StringCaseMatch. This variant of Tcl_UniCharCaseMatch - * uses counted Strings, so embedded NULLs are allowed. + * Allows case insensitivity. This is the Unicode equivalent of the char* + * Tcl_StringCaseMatch. This variant of Tcl_UniCharCaseMatch uses counted + * Strings, so embedded NULLs are allowed. * * Results: - * The return value is 1 if string matches pattern, and - * 0 otherwise. The matching operation permits the following - * special characters in the pattern: *?\[] (see the manual - * entry for details on what these mean). + * The return value is 1 if string matches pattern, and 0 otherwise. The + * matching operation permits the following special characters in the + * pattern: *?\[] (see the manual entry for details on what these mean). * * Side effects: * None. * *---------------------------------------------------------------------- @@ -1791,18 +1800,18 @@ int nocase; /* 0 for case sensitive, 1 for insensitive */ { CONST Tcl_UniChar *stringEnd, *patternEnd; Tcl_UniChar p; - stringEnd = string + strLen; + stringEnd = string + strLen; patternEnd = pattern + ptnLen; while (1) { /* - * See if we're at the end of both the pattern and the string. If - * so, we succeeded. If we're at the end of the pattern but not at - * the end of the string, we failed. + * See if we're at the end of both the pattern and the string. If so, + * we succeeded. If we're at the end of the pattern but not at the end + * of the string, we failed. */ if (pattern == patternEnd) { return (string == stringEnd); } @@ -1810,22 +1819,25 @@ if ((string == stringEnd) && (p != '*')) { return 0; } /* - * Check for a "*" as the next pattern character. It matches any - * substring. We handle this by skipping all the characters up to the + * Check for a "*" as the next pattern character. It matches any + * substring. We handle this by skipping all the characters up to the * next matching one in the pattern, and then calling ourselves * recursively for each postfix of string, until either we match or we * reach the end of the string. */ if (p == '*') { /* - * Skip all successive *'s in the pattern + * Skip all successive *'s in the pattern. */ - while (*(++pattern) == '*') {} + + while (*(++pattern) == '*') { + /* empty body */ + } if (pattern == patternEnd) { return 1; } p = *pattern; if (nocase) { @@ -1833,12 +1845,13 @@ } while (1) { /* * Optimization for matching - cruise through the string * quickly if the next char in the pattern isn't a special - * character + * character. */ + if ((p != '[') && (p != '?') && (p != '\\')) { if (nocase) { while ((string < stringEnd) && (p != *string) && (p != Tcl_UniCharToLower(*string))) { string++; @@ -1859,24 +1872,24 @@ string++; } } /* - * Check for a "?" as the next pattern character. It matches - * any single character. + * Check for a "?" as the next pattern character. It matches any + * single character. */ if (p == '?') { pattern++; string++; continue; } /* - * Check for a "[" as the next pattern character. It is followed - * by a list of characters that are acceptable, or by a range - * (two characters separated by "-"). + * Check for a "[" as the next pattern character. It is followed by a + * list of characters that are acceptable, or by a range (two + * characters separated by "-"). */ if (p == '[') { Tcl_UniChar ch1, startChar, endChar; @@ -1918,23 +1931,23 @@ pattern++; continue; } /* - * If the next pattern character is '\', just strip off the '\' - * so we do exact matching on the character that follows. + * If the next pattern character is '\', just strip off the '\' so we + * do exact matching on the character that follows. */ if (p == '\\') { if (++pattern == patternEnd) { return 0; } } /* - * There's no special character. Just make sure that the next - * bytes of each string match. + * There's no special character. Just make sure that the next bytes of + * each string match. */ if (nocase) { if (Tcl_UniCharToLower(*string) != Tcl_UniCharToLower(*pattern)) { return 0; @@ -1944,5 +1957,13 @@ } string++; pattern++; } } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclUtil.c ================================================================== --- generic/tclUtil.c +++ generic/tclUtil.c @@ -1,141 +1,136 @@ -/* +/* * tclUtil.c -- * - * This file contains utility procedures that are used by many Tcl + * This file contains utility functions that are used by many Tcl * commands. * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 2001 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. + * 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.51 2004/12/02 00:09:40 dgp Exp $ + * RCS: @(#) $Id: tclUtil.c,v 1.51.2.20 2005/09/15 20:58:40 dgp Exp $ */ #include "tclInt.h" +#include +#include /* * The absolute pathname of the executable in which this Tcl library * is running. */ static ProcessGlobalValue executableName = {0, 0, NULL, NULL, NULL, NULL, NULL}; /* - * The following values are used in the flags returned by Tcl_ScanElement - * and used by Tcl_ConvertElement. The values TCL_DONT_USE_BRACES and - * TCL_DONT_QUOTE_HASH are defined in tcl.h; make sure neither value - * overlaps with any of the values below. + * The following values are used in the flags returned by Tcl_ScanElement and + * used by Tcl_ConvertElement. The values TCL_DONT_USE_BRACES and + * TCL_DONT_QUOTE_HASH are defined in tcl.h; make sure neither value overlaps + * with any of the values below. * * TCL_DONT_USE_BRACES - 1 means the string mustn't be enclosed in - * braces (e.g. it contains unmatched braces, - * or ends in a backslash character, or user - * just doesn't want braces); handle all - * special characters by adding backslashes. + * braces (e.g. it contains unmatched braces, or + * ends in a backslash character, or user just + * doesn't want braces); handle all special + * characters by adding backslashes. * USE_BRACES - 1 means the string contains a special * character that can be handled simply by * enclosing the entire argument in braces. - * BRACES_UNMATCHED - 1 means that braces aren't properly matched - * in the argument. - * TCL_DONT_QUOTE_HASH - 1 means the caller insists that a leading - * hash character ('#') should *not* be quoted. - * This is appropriate when the caller can - * guarantee the element is not the first element - * of a list, so [eval] cannot mis-parse the - * element as a comment. + * BRACES_UNMATCHED - 1 means that braces aren't properly matched in + * the argument. + * TCL_DONT_QUOTE_HASH - 1 means the caller insists that a leading hash + * character ('#') should *not* be quoted. This + * is appropriate when the caller can guarantee + * the element is not the first element of a + * list, so [eval] cannot mis-parse the element + * as a comment. */ #define USE_BRACES 2 #define BRACES_UNMATCHED 4 /* - * The following values determine the precision used when converting - * floating-point values to strings. This information is linked to all - * of the tcl_precision variables in all interpreters via the procedure - * TclPrecTraceProc. + * The following key is used by Tcl_PrintDouble and TclPrecTraceProc to + * access the precision to be used for double formatting. */ -static char precisionString[10] = "12"; - /* The string value of all the tcl_precision - * variables. */ -static char precisionFormat[10] = "%.12g"; - /* The format string actually used in calls - * to sprintf. */ -TCL_DECLARE_MUTEX(precisionMutex) +static Tcl_ThreadDataKey precisionKey; /* - * Prototypes for procedures defined later in this file. + * Prototypes for functions defined later in this file. */ static void ClearHash _ANSI_ARGS_((Tcl_HashTable *tablePtr)); static void FreeProcessGlobalValue _ANSI_ARGS_(( ClientData clientData)); -static void FreeThreadHash _ANSI_ARGS_ ((ClientData clientData)); -static Tcl_HashTable * GetThreadHash _ANSI_ARGS_ ((Tcl_ThreadDataKey *keyPtr)); +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)); + Tcl_Obj* objPtr)); static void UpdateStringOfEndOffset _ANSI_ARGS_((Tcl_Obj* objPtr)); /* - * The following is the Tcl object type definition for an object - * that represents a list index in the form, "end-offset". It is - * used as a performance optimization in TclGetIntForIndex. The - * internal rep is an integer, so no memory management is required - * for it. + * The following is the Tcl object type definition for an object that + * represents a list index in the form, "end-offset". It is used as a + * performance optimization in TclGetIntForIndex. The internal rep is an + * integer, so no memory management is required for it. */ Tcl_ObjType tclEndOffsetType = { "end-offset", /* name */ (Tcl_FreeInternalRepProc*) NULL, /* freeIntRepProc */ - (Tcl_DupInternalRepProc*) NULL, /* dupIntRepProc */ + (Tcl_DupInternalRepProc*) NULL, /* dupIntRepProc */ UpdateStringOfEndOffset, /* updateStringProc */ - SetEndOffsetFromAny + SetEndOffsetFromAny }; /* *---------------------------------------------------------------------- * * TclFindElement -- * - * Given a pointer into a Tcl list, locate the first (or next) - * element in the list. + * Given a pointer into a Tcl list, locate the first (or next) element in + * the list. * * Results: - * The return value is normally TCL_OK, which means that the - * element was successfully located. If TCL_ERROR is returned - * it means that list didn't have proper list structure; - * the interp's result contains a more detailed error message. + * The return value is normally TCL_OK, which means that the element was + * successfully located. If TCL_ERROR is returned it means that list + * didn't have proper list structure; the interp's result contains a more + * detailed error message. * * If TCL_OK is returned, then *elementPtr will be set to point to the * first element of list, and *nextPtr will be set to point to the * character just after any white space following the last character - * that's part of the element. If this is the last argument in the - * list, then *nextPtr will point just after the last character in the - * list (i.e., at the character at list+listLength). If sizePtr is - * non-NULL, *sizePtr is filled in with the number of characters in the - * element. If the element is in braces, then *elementPtr will point - * to the character after the opening brace and *sizePtr will not - * include either of the braces. If there isn't an element in the list, - * *sizePtr will be zero, and both *elementPtr and *termPtr will point - * just after the last character in the list. Note: this procedure does - * NOT collapse backslash sequences. + * that's part of the element. If this is the last argument in the list, + * then *nextPtr will point just after the last character in the list + * (i.e., at the character at list+listLength). If sizePtr is non-NULL, + * *sizePtr is filled in with the number of characters in the element. If + * the element is in braces, then *elementPtr will point to the character + * after the opening brace and *sizePtr will not include either of the + * braces. If there isn't an element in the list, *sizePtr will be zero, + * and both *elementPtr and *termPtr will point just after the last + * character in the list. Note: this function does NOT collapse backslash + * sequences. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, - bracePtr) - Tcl_Interp *interp; /* Interpreter to use for error reporting. - * If NULL, then no error message is left - * after errors. */ + bracePtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting. If + * NULL, then no error message is left after + * errors. */ CONST char *list; /* Points to the first byte of a string * containing a Tcl list with zero or more * elements (possibly in braces). */ int listLength; /* Number of bytes in the list's string. */ CONST char **elementPtr; /* Where to put address of first significant @@ -143,27 +138,26 @@ CONST char **nextPtr; /* Fill in with location of character just * after all white space following end of * argument (next arg or end of list). */ int *sizePtr; /* If non-zero, fill in with size of * element. */ - int *bracePtr; /* If non-zero, fill in with non-zero/zero - * to indicate that arg was/wasn't - * in braces. */ + int *bracePtr; /* If non-zero, fill in with non-zero/zero to + * indicate that arg was/wasn't in braces. */ { CONST char *p = list; CONST char *elemStart; /* Points to first byte of first element. */ CONST char *limit; /* Points just after list's last byte. */ int openBraces = 0; /* Brace nesting level during parse. */ int inQuotes = 0; int size = 0; /* lint. */ int numChars; CONST char *p2; - + /* - * Skim off leading white space and check for an opening brace or - * quote. We treat embedded NULLs in the list as bytes belonging to - * a list element. + * Skim off leading white space and check for an opening brace or quote. + * We treat embedded NULLs in the list as bytes belonging to a list + * element. */ limit = (list + listLength); while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */ p++; @@ -189,126 +183,121 @@ * Find element's end (a space, close brace, or the end of the string). */ while (p < limit) { switch (*p) { - /* * Open brace: don't treat specially unless the element is in * braces. In this case, keep a nesting count. */ - case '{': - if (openBraces != 0) { - openBraces++; - } - break; + case '{': + if (openBraces != 0) { + openBraces++; + } + break; /* * Close brace: if element is in braces, keep nesting count and * quit when the last close brace is seen. */ - case '}': - if (openBraces > 1) { - openBraces--; - } else if (openBraces == 1) { - size = (p - elemStart); - p++; - if ((p >= limit) - || isspace(UCHAR(*p))) { /* INTL: ISO space. */ - goto done; - } - - /* - * Garbage after the closing brace; return an error. - */ - - if (interp != NULL) { - char buf[100]; - - p2 = p; - while ((p2 < limit) - && (!isspace(UCHAR(*p2))) /* INTL: ISO space. */ - && (p2 < p+20)) { - p2++; - } - sprintf(buf, - "list element in braces followed by \"%.*s\" instead of space", - (int) (p2-p), p); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - } - return TCL_ERROR; - } - break; - - /* - * Backslash: skip over everything up to the end of the - * backslash sequence. - */ - - case '\\': { - Tcl_UtfBackslash(p, &numChars, NULL); - p += (numChars - 1); - break; - } + case '}': + if (openBraces > 1) { + openBraces--; + } else if (openBraces == 1) { + size = (p - elemStart); + p++; + if ((p >= limit) + || isspace(UCHAR(*p))) { /* INTL: ISO space. */ + goto done; + } + + /* + * Garbage after the closing brace; return an error. + */ + + if (interp != NULL) { + Tcl_Obj *objPtr = Tcl_NewObj(); + p2 = p; + while ((p2 < limit) + && (!isspace(UCHAR(*p2))) /* INTL: ISO space. */ + && (p2 < p+20)) { + p2++; + } + TclObjPrintf(NULL, objPtr, + "list element in braces followed by \"%.*s\" " + "instead of space", (int) (p2-p), p); + Tcl_SetObjResult(interp, objPtr); + } + return TCL_ERROR; + } + break; + + /* + * Backslash: skip over everything up to the end of the backslash + * sequence. + */ + + case '\\': + Tcl_UtfBackslash(p, &numChars, NULL); + p += (numChars - 1); + break; /* * Space: ignore if element is in braces or quotes; otherwise * terminate element. */ - case ' ': - case '\f': - case '\n': - case '\r': - case '\t': - case '\v': - if ((openBraces == 0) && !inQuotes) { - size = (p - elemStart); - goto done; - } - break; + case ' ': + case '\f': + case '\n': + case '\r': + case '\t': + case '\v': + if ((openBraces == 0) && !inQuotes) { + size = (p - elemStart); + goto done; + } + break; /* * Double-quote: if element is in quotes then terminate it. */ - case '"': - if (inQuotes) { - size = (p - elemStart); - p++; - if ((p >= limit) - || isspace(UCHAR(*p))) { /* INTL: ISO space */ - goto done; - } - - /* - * Garbage after the closing quote; return an error. - */ - - if (interp != NULL) { - char buf[100]; - - p2 = p; - while ((p2 < limit) - && (!isspace(UCHAR(*p2))) /* INTL: ISO space */ - && (p2 < p+20)) { - p2++; - } - sprintf(buf, - "list element in quotes followed by \"%.*s\" %s", - (int) (p2-p), p, "instead of space"); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - } - return TCL_ERROR; - } - break; - } - p++; - } - + case '"': + if (inQuotes) { + size = (p - elemStart); + p++; + if ((p >= limit) + || isspace(UCHAR(*p))) { /* INTL: ISO space */ + goto done; + } + + /* + * Garbage after the closing quote; return an error. + */ + + if (interp != NULL) { + Tcl_Obj *objPtr = Tcl_NewObj(); + p2 = p; + while ((p2 < limit) + && (!isspace(UCHAR(*p2))) /* INTL: ISO space */ + && (p2 < p+20)) { + p2++; + } + TclObjPrintf(NULL, objPtr, + "list element in quotes followed by \"%.*s\" " + "instead of space", (int) (p2-p), p); + Tcl_SetObjResult(interp, objPtr); + } + return TCL_ERROR; + } + break; + } + p++; + } /* * End of list: terminate element. */ @@ -327,11 +316,11 @@ return TCL_ERROR; } size = (p - elemStart); } - done: + done: while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */ p++; } *elementPtr = elemStart; *nextPtr = p; @@ -347,15 +336,15 @@ * TclCopyAndCollapse -- * * Copy a string and eliminate any backslashes that aren't in braces. * * Results: - * Count characters get copied from src to dst. Along the way, if + * Count characters get copied from src to dst. Along the way, if * backslash sequences are found outside braces, the backslashes are - * eliminated in the copy. After scanning count chars from source, a - * null character is placed at the end of dst. Returns the number - * of characters that got copied. + * eliminated in the copy. After scanning count chars from source, a null + * character is placed at the end of dst. Returns the number of + * characters that got copied. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -395,53 +384,51 @@ * Tcl_SplitList -- * * Splits a list up into its constituent fields. * * Results - * The return value is normally TCL_OK, which means that - * the list was successfully split up. If TCL_ERROR is - * returned, it means that "list" didn't have proper list - * structure; the interp's result will contain a more detailed - * error message. - * - * *argvPtr will be filled in with the address of an array - * whose elements point to the elements of list, in order. - * *argcPtr will get filled in with the number of valid elements - * in the array. A single block of memory is dynamically allocated - * to hold both the argv array and a copy of the list (with - * backslashes and braces removed in the standard way). - * The caller must eventually free this memory by calling free() - * on *argvPtr. Note: *argvPtr and *argcPtr are only modified - * if the procedure returns normally. + * The return value is normally TCL_OK, which means that the list was + * successfully split up. If TCL_ERROR is returned, it means that "list" + * didn't have proper list structure; the interp's result will contain a + * more detailed error message. + * + * *argvPtr will be filled in with the address of an array whose elements + * point to the elements of list, in order. *argcPtr will get filled in + * with the number of valid elements in the array. A single block of + * memory is dynamically allocated to hold both the argv array and a copy + * of the list (with backslashes and braces removed in the standard way). + * The caller must eventually free this memory by calling free() on + * *argvPtr. Note: *argvPtr and *argcPtr are only modified if the + * function returns normally. * * Side effects: * Memory is allocated. * *---------------------------------------------------------------------- */ int Tcl_SplitList(interp, list, argcPtr, argvPtr) - Tcl_Interp *interp; /* Interpreter to use for error reporting. - * If NULL, no error message is left. */ + Tcl_Interp *interp; /* Interpreter to use for error reporting. If + * NULL, no error message is left. */ CONST char *list; /* Pointer to string with list structure. */ - int *argcPtr; /* Pointer to location to fill in with - * the number of elements in the list. */ - CONST char ***argvPtr; /* Pointer to place to store pointer to - * array of pointers to list elements. */ + int *argcPtr; /* Pointer to location to fill in with the + * number of elements in the list. */ + CONST char ***argvPtr; /* Pointer to place to store pointer to array + * of pointers to list elements. */ { CONST char **argv; CONST char *l; char *p; int length, size, i, result, elSize, brace; CONST char *element; /* - * Figure out how much space to allocate. There must be enough - * space for both the array of pointers and also for a copy of - * the list. To estimate the number of pointers needed, count - * the number of space characters in the list. + * Figure out how much space to allocate. There must be enough space for + * both the array of pointers and also for a copy of the list. To estimate + * the number of pointers needed, count the number of space characters in + * the list. */ for (size = 1, l = list; *l != 0; l++) { if (isspace(UCHAR(*l))) { /* INTL: ISO space. */ size++; @@ -452,11 +439,11 @@ ((size * sizeof(char *)) + (l - list) + 1)); length = strlen(list); for (i = 0, p = ((char *) argv) + size*sizeof(char *); *list != 0; i++) { CONST char *prevList = list; - + result = TclFindElement(interp, list, length, &element, &list, &elSize, &brace); length -= (list - prevList); if (result != TCL_OK) { ckfree((char *) argv); @@ -494,21 +481,19 @@ /* *---------------------------------------------------------------------- * * Tcl_ScanElement -- * - * This procedure is a companion procedure to Tcl_ConvertElement. - * It scans a string to see what needs to be done to it (e.g. add - * backslashes or enclosing braces) to make the string into a - * valid Tcl list element. + * This function is a companion function to Tcl_ConvertElement. It scans + * a string to see what needs to be done to it (e.g. add backslashes or + * enclosing braces) to make the string into a valid Tcl list element. * * Results: - * The return value is an overestimate of the number of characters - * that will be needed by Tcl_ConvertElement to produce a valid - * list element from string. The word at *flagPtr is filled in - * with a value needed by Tcl_ConvertElement when doing the actual - * conversion. + * The return value is an overestimate of the number of characters that + * will be needed by Tcl_ConvertElement to produce a valid list element + * from string. The word at *flagPtr is filled in with a value needed by + * Tcl_ConvertElement when doing the actual conversion. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -526,23 +511,21 @@ /* *---------------------------------------------------------------------- * * Tcl_ScanCountedElement -- * - * This procedure is a companion procedure to - * Tcl_ConvertCountedElement. It scans a string to see what - * needs to be done to it (e.g. add backslashes or enclosing - * braces) to make the string into a valid Tcl list element. - * If length is -1, then the string is scanned up to the first - * null byte. + * This function is a companion function to Tcl_ConvertCountedElement. It + * scans a string to see what needs to be done to it (e.g. add + * backslashes or enclosing braces) to make the string into a valid Tcl + * list element. If length is -1, then the string is scanned up to the + * first null byte. * * Results: - * The return value is an overestimate of the number of characters - * that will be needed by Tcl_ConvertCountedElement to produce a - * valid list element from string. The word at *flagPtr is - * filled in with a value needed by Tcl_ConvertCountedElement - * when doing the actual conversion. + * The return value is an overestimate of the number of characters that + * will be needed by Tcl_ConvertCountedElement to produce a valid list + * element from string. The word at *flagPtr is filled in with a value + * needed by Tcl_ConvertCountedElement when doing the actual conversion. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -557,48 +540,48 @@ { int flags, nestingLevel; register CONST char *p, *lastChar; /* - * This procedure and Tcl_ConvertElement together do two things: - * - * 1. They produce a proper list, one that will yield back the - * argument strings when evaluated or when disassembled with - * Tcl_SplitList. This is the most important thing. - * - * 2. They try to produce legible output, which means minimizing the - * use of backslashes (using braces instead). However, there are - * some situations where backslashes must be used (e.g. an element - * like "{abc": the leading brace will have to be backslashed. - * For each element, one of three things must be done: - * - * (a) Use the element as-is (it doesn't contain any special - * characters). This is the most desirable option. - * - * (b) Enclose the element in braces, but leave the contents alone. - * This happens if the element contains embedded space, or if it - * contains characters with special interpretation ($, [, ;, or \), - * or if it starts with a brace or double-quote, or if there are - * no characters in the element. - * - * (c) Don't enclose the element in braces, but add backslashes to - * prevent special interpretation of special characters. This is a - * last resort used when the argument would normally fall under case - * (b) but contains unmatched braces. It also occurs if the last - * character of the argument is a backslash or if the element contains - * a backslash followed by newline. - * - * The procedure figures out how many bytes will be needed to store - * the result (actually, it overestimates). It also collects information - * about the element in the form of a flags word. - * - * Note: list elements produced by this procedure and - * Tcl_ConvertCountedElement must have the property that they can be - * enclosing in curly braces to make sub-lists. This means, for - * example, that we must not leave unmatched curly braces in the - * resulting list element. This property is necessary in order for - * procedures like Tcl_DStringStartSublist to work. + * This function and Tcl_ConvertElement together do two things: + * + * 1. They produce a proper list, one that will yield back the argument + * strings when evaluated or when disassembled with Tcl_SplitList. This + * is the most important thing. + * + * 2. They try to produce legible output, which means minimizing the use + * of backslashes (using braces instead). However, there are some + * situations where backslashes must be used (e.g. an element like + * "{abc": the leading brace will have to be backslashed. For each + * element, one of three things must be done: + * + * (a) Use the element as-is (it doesn't contain any special + * characters). This is the most desirable option. + * + * (b) Enclose the element in braces, but leave the contents alone. + * This happens if the element contains embedded space, or if it + * contains characters with special interpretation ($, [, ;, or \), + * or if it starts with a brace or double-quote, or if there are no + * characters in the element. + * + * (c) Don't enclose the element in braces, but add backslashes to + * prevent special interpretation of special characters. This is a + * last resort used when the argument would normally fall under + * case (b) but contains unmatched braces. It also occurs if the + * last character of the argument is a backslash or if the element + * contains a backslash followed by newline. + * + * The function figures out how many bytes will be needed to store the + * result (actually, it overestimates). It also collects information about + * the element in the form of a flags word. + * + * Note: list elements produced by this function and + * Tcl_ConvertCountedElement must have the property that they can be + * enclosing in curly braces to make sub-lists. This means, for example, + * that we must not leave unmatched curly braces in the resulting list + * element. This property is necessary in order for functions like + * Tcl_DStringStartSublist to work. */ nestingLevel = 0; flags = 0; if (string == NULL) { @@ -610,53 +593,53 @@ lastChar = string + length; p = string; if ((p == lastChar) || (*p == '{') || (*p == '"')) { flags |= USE_BRACES; } - for ( ; p < lastChar; p++) { - switch (*p) { - case '{': - nestingLevel++; - break; - case '}': - nestingLevel--; - if (nestingLevel < 0) { - flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED; - } - break; - case '[': - case '$': - case ';': - case ' ': - case '\f': - case '\n': - case '\r': - case '\t': - case '\v': - flags |= USE_BRACES; - break; - case '\\': - if ((p+1 == lastChar) || (p[1] == '\n')) { - flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; - } else { - int size; - - Tcl_UtfBackslash(p, &size, NULL); - p += size-1; - flags |= USE_BRACES; - } - break; + for (; p < lastChar; p++) { + switch (*p) { + case '{': + nestingLevel++; + break; + case '}': + nestingLevel--; + if (nestingLevel < 0) { + flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED; + } + break; + case '[': + case '$': + case ';': + case ' ': + case '\f': + case '\n': + case '\r': + case '\t': + case '\v': + flags |= USE_BRACES; + break; + case '\\': + if ((p+1 == lastChar) || (p[1] == '\n')) { + flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; + } else { + int size; + + Tcl_UtfBackslash(p, &size, NULL); + p += size-1; + flags |= USE_BRACES; + } + break; } } if (nestingLevel != 0) { flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; } *flagPtr = flags; /* - * Allow enough space to backslash every character plus leave - * two spaces for braces. + * Allow enough space to backslash every character plus leave two spaces + * for braces. */ return 2*(p-string) + 2; } @@ -663,20 +646,19 @@ /* *---------------------------------------------------------------------- * * Tcl_ConvertElement -- * - * This is a companion procedure to Tcl_ScanElement. Given - * the information produced by Tcl_ScanElement, this procedure - * converts a string to a list element equal to that string. + * This is a companion function to Tcl_ScanElement. Given the information + * produced by Tcl_ScanElement, this function converts a string to a list + * element equal to that string. * * Results: - * Information is copied to *dst in the form of a list element - * identical to src (i.e. if Tcl_SplitList is applied to dst it - * will produce a string identical to src). The return value is - * a count of the number of characters copied (not including the - * terminating NULL character). + * Information is copied to *dst in the form of a list element identical + * to src (i.e. if Tcl_SplitList is applied to dst it will produce a + * string identical to src). The return value is a count of the number of + * characters copied (not including the terminating NULL character). * * Side effects: * None. * *---------------------------------------------------------------------- @@ -694,21 +676,19 @@ /* *---------------------------------------------------------------------- * * Tcl_ConvertCountedElement -- * - * This is a companion procedure to Tcl_ScanCountedElement. Given - * the information produced by Tcl_ScanCountedElement, this - * procedure converts a string to a list element equal to that - * string. + * This is a companion function to Tcl_ScanCountedElement. Given the + * information produced by Tcl_ScanCountedElement, this function converts + * a string to a list element equal to that string. * * Results: - * Information is copied to *dst in the form of a list element - * identical to src (i.e. if Tcl_SplitList is applied to dst it - * will produce a string identical to src). The return value is - * a count of the number of characters copied (not including the - * terminating NULL character). + * Information is copied to *dst in the form of a list element identical + * to src (i.e. if Tcl_SplitList is applied to dst it will produce a + * string identical to src). The return value is a count of the number of + * characters copied (not including the terminating NULL character). * * Side effects: * None. * *---------------------------------------------------------------------- @@ -723,12 +703,12 @@ { register char *p = dst; register CONST char *lastChar; /* - * See the comment block at the beginning of the Tcl_ScanElement - * code for details of how this works. + * See the comment block at the beginning of the Tcl_ScanElement code for + * details of how this works. */ if (src && length == -1) { length = strlen(src); } @@ -743,99 +723,98 @@ flags |= USE_BRACES; } if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) { *p = '{'; p++; - for ( ; src != lastChar; src++, p++) { + for (; src != lastChar; src++, p++) { *p = *src; } *p = '}'; p++; } else { if (*src == '{') { /* - * Can't have a leading brace unless the whole element is - * enclosed in braces. Add a backslash before the brace. - * Furthermore, this may destroy the balance between open - * and close braces, so set BRACES_UNMATCHED. + * Can't have a leading brace unless the whole element is enclosed + * in braces. Add a backslash before the brace. Furthermore, this + * may destroy the balance between open and close braces, so set + * BRACES_UNMATCHED. */ p[0] = '\\'; p[1] = '{'; p += 2; src++; flags |= BRACES_UNMATCHED; } else if ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) { /* - * Leading '#' could be seen by [eval] as the start of - * a comment, if on the first element of a list, so - * quote it. + * Leading '#' could be seen by [eval] as the start of a comment, + * if on the first element of a list, so quote it. */ p[0] = '\\'; p[1] = '#'; p += 2; src++; } for (; src != lastChar; src++) { switch (*src) { - case ']': - case '[': - case '$': - case ';': - case ' ': - case '\\': - case '"': - *p = '\\'; - p++; - break; - case '{': - case '}': - /* - * It may not seem necessary to backslash braces, but - * it is. The reason for this is that the resulting - * list element may actually be an element of a sub-list - * enclosed in braces (e.g. if Tcl_DStringStartSublist - * has been invoked), so there may be a brace mismatch - * if the braces aren't backslashed. - */ - - if (flags & BRACES_UNMATCHED) { - *p = '\\'; - p++; - } - break; - case '\f': - *p = '\\'; - p++; - *p = 'f'; - p++; - continue; - case '\n': - *p = '\\'; - p++; - *p = 'n'; - p++; - continue; - case '\r': - *p = '\\'; - p++; - *p = 'r'; - p++; - continue; - case '\t': - *p = '\\'; - p++; - *p = 't'; - p++; - continue; - case '\v': - *p = '\\'; - p++; - *p = 'v'; - p++; - continue; + case ']': + case '[': + case '$': + case ';': + case ' ': + case '\\': + case '"': + *p = '\\'; + p++; + break; + case '{': + case '}': + /* + * It may not seem necessary to backslash braces, but it is. + * The reason for this is that the resulting list element may + * actually be an element of a sub-list enclosed in braces + * (e.g. if Tcl_DStringStartSublist has been invoked), so + * there may be a brace mismatch if the braces aren't + * backslashed. + */ + + if (flags & BRACES_UNMATCHED) { + *p = '\\'; + p++; + } + break; + case '\f': + *p = '\\'; + p++; + *p = 'f'; + p++; + continue; + case '\n': + *p = '\\'; + p++; + *p = 'n'; + p++; + continue; + case '\r': + *p = '\\'; + p++; + *p = 'r'; + p++; + continue; + case '\t': + *p = '\\'; + p++; + *p = 't'; + p++; + continue; + case '\v': + *p = '\\'; + p++; + *p = 'v'; + p++; + continue; } *p = *src; p++; } } @@ -846,19 +825,18 @@ /* *---------------------------------------------------------------------- * * Tcl_Merge -- * - * Given a collection of strings, merge them together into a - * single string that has proper Tcl list structured (i.e. - * Tcl_SplitList may be used to retrieve strings equal to the - * original elements, and Tcl_Eval will parse the string back - * into its original elements). + * Given a collection of strings, merge them together into a single + * string that has proper Tcl list structured (i.e. Tcl_SplitList may be + * used to retrieve strings equal to the original elements, and Tcl_Eval + * will parse the string back into its original elements). * * Results: - * The return value is the address of a dynamically-allocated - * string containing the merged list. + * The return value is the address of a dynamically-allocated string + * containing the merged list. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -895,11 +873,11 @@ */ result = (char *) ckalloc((unsigned) numChars); dst = result; for (i = 0; i < argc; i++) { - numChars = Tcl_ConvertElement(argv[i], dst, + numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i] | (i==0 ? 0 : TCL_DONT_QUOTE_HASH) ); dst += numChars; *dst = ' '; dst++; } @@ -921,27 +899,27 @@ * Tcl_Backslash -- * * Figure out how to handle a backslash sequence. * * Results: - * The return value is the character that should be substituted - * in place of the backslash sequence that starts at src. If - * readPtr isn't NULL then it is filled in with a count of the - * number of characters in the backslash sequence. + * The return value is the character that should be substituted in place + * of the backslash sequence that starts at src. If readPtr isn't NULL + * then it is filled in with a count of the number of characters in the + * backslash sequence. * * Side effects: * None. * *---------------------------------------------------------------------- */ char Tcl_Backslash(src, readPtr) - CONST char *src; /* Points to the backslash character of - * a backslash sequence. */ - int *readPtr; /* Fill in with number of characters read - * from src, unless NULL. */ + CONST char *src; /* Points to the backslash character of a + * backslash sequence. */ + int *readPtr; /* Fill in with number of characters read from + * src, unless NULL. */ { char buf[TCL_UTF_MAX]; Tcl_UniChar ch; Tcl_UtfBackslash(src, readPtr, buf); @@ -955,17 +933,17 @@ * Tcl_Concat -- * * Concatenate a set of strings into a single large string. * * Results: - * The return value is dynamically-allocated string containing - * a concatenation of all the strings in argv, with spaces between - * the original argv elements. + * The return value is dynamically-allocated string containing a + * concatenation of all the strings in argv, with spaces between the + * original argv elements. * * Side effects: - * Memory is allocated for the result; the caller is responsible - * for freeing the memory. + * Memory is allocated for the result; the caller is responsible for + * freeing the memory. * *---------------------------------------------------------------------- */ char * @@ -988,13 +966,12 @@ for (p = result, i = 0; i < argc; i++) { CONST char *element; int length; /* - * Clip white space off the front and back of the string - * to generate a neater result, and ignore any empty - * elements. + * Clip white space off the front and back of the string to generate a + * neater result, and ignore any empty elements. */ element = argv[i]; while (isspace(UCHAR(*element))) { /* INTL: ISO space. */ element++; @@ -1001,11 +978,11 @@ } for (length = strlen(element); (length > 0) && (isspace(UCHAR(element[length-1]))) /* INTL: ISO space. */ && ((length < 2) || (element[length-2] != '\\')); - length--) { + length--) { /* Null loop body. */ } if (length == 0) { continue; } @@ -1029,12 +1006,12 @@ * * Concatenate the strings from a set of objects into a single string * object with spaces between the original strings. * * Results: - * The return value is a new string object containing a concatenation - * of the strings in objv. Its ref count is zero. + * The return value is a new string object containing a concatenation of + * the strings in objv. Its ref count is zero. * * Side effects: * A new object is created. * *---------------------------------------------------------------------- @@ -1050,20 +1027,26 @@ char *element; char *concatStr; Tcl_Obj *objPtr; /* - * Check first to see if all the items are of list type. If so, - * we will concat them together as lists, and return a list object. - * This is only valid when the lists have no current string - * representation, since we don't know what the original type was. - * An original string rep may have lost some whitespace info when - * converted which could be important. + * Check first to see if all the items are of list type. If so, we will + * concat them together as lists, and return a list object. This is only + * valid when the lists have no current string representation, since we + * don't know what the original type was. An original string rep may have + * lost some whitespace info when converted which could be important. */ + for (i = 0; i < objc; i++) { + List *listRepPtr; + objPtr = objv[i]; - if ((objPtr->typePtr != &tclListType) || (objPtr->bytes != NULL)) { + if (objPtr->typePtr != &tclListType) { + break; + } + listRepPtr = (List *) objPtr->internalRep.twoPtrValue.ptr1; + if (objPtr->bytes != NULL && !listRepPtr->canonicalFlag) { break; } } if (i == objc) { Tcl_Obj **listv; @@ -1070,21 +1053,27 @@ int listc; objPtr = Tcl_NewListObj(0, NULL); for (i = 0; i < objc; i++) { /* - * Tcl_ListObjAppendList could be used here, but this saves - * us a bit of type checking (since we've already done it) - * Use of INT_MAX tells us to always put the new stuff on - * the end. It will be set right in Tcl_ListObjReplace. + * Tcl_ListObjAppendList could be used here, but this saves us a + * bit of type checking (since we've already done it). Use of + * INT_MAX tells us to always put the new stuff on the end. It + * will be set right in Tcl_ListObjReplace. */ + Tcl_ListObjGetElements(NULL, objv[i], &listc, &listv); Tcl_ListObjReplace(NULL, objPtr, INT_MAX, 0, listc, listv); } return objPtr; } + /* + * Something cannot be determined to be safe, so build the concatenation + * the slow way, using the string representations. + */ + allocSize = 0; for (i = 0; i < objc; i++) { objPtr = objv[i]; element = Tcl_GetStringFromObj(objPtr, &length); if ((element != NULL) && (length > 0)) { @@ -1094,65 +1083,65 @@ if (allocSize == 0) { allocSize = 1; /* enough for the NULL byte at end */ } /* - * Allocate storage for the concatenated result. Note that allocSize - * is one more than the total number of characters, and so includes - * room for the terminating NULL byte. + * Allocate storage for the concatenated result. Note that allocSize is + * one more than the total number of characters, and so includes room for + * the terminating NULL byte. */ - + concatStr = (char *) ckalloc((unsigned) allocSize); /* * Now concatenate the elements. Clip white space off the front and back - * to generate a neater result, and ignore any empty elements. Also put - * a null byte at the end. + * to generate a neater result, and ignore any empty elements. Also put a + * null byte at the end. */ finalSize = 0; if (objc == 0) { *concatStr = '\0'; } else { p = concatStr; - for (i = 0; i < objc; i++) { + for (i = 0; i < objc; i++) { objPtr = objv[i]; element = Tcl_GetStringFromObj(objPtr, &elemLength); while ((elemLength > 0) && (UCHAR(*element) < 127) && isspace(UCHAR(*element))) { /* INTL: ISO C space. */ - element++; - elemLength--; + element++; + elemLength--; } /* - * Trim trailing white space. But, be careful not to trim - * a space character if it is preceded by a backslash: in - * this case it could be significant. + * Trim trailing white space. But, be careful not to trim a space + * character if it is preceded by a backslash: in this case it + * could be significant. */ while ((elemLength > 0) && (UCHAR(element[elemLength-1]) < 127) && isspace(UCHAR(element[elemLength-1])) /* INTL: ISO C space. */ && ((elemLength < 2) || (element[elemLength-2] != '\\'))) { elemLength--; } if (elemLength == 0) { - continue; /* nothing left of this element */ + continue; /* nothing left of this element */ } memcpy((VOID *) p, (VOID *) element, (size_t) elemLength); p += elemLength; *p = ' '; p++; finalSize += (elemLength + 1); - } - if (p != concatStr) { + } + if (p != concatStr) { p[-1] = 0; finalSize -= 1; /* we overwrote the final ' ' */ - } else { + } else { *p = 0; - } + } } - + TclNewObj(objPtr); objPtr->bytes = concatStr; objPtr->length = finalSize; return objPtr; } @@ -1163,172 +1152,176 @@ * Tcl_StringMatch -- * * See if a particular string matches a particular pattern. * * Results: - * The return value is 1 if string matches pattern, and - * 0 otherwise. The matching operation permits the following - * special characters in the pattern: *?\[] (see the manual - * entry for details on what these mean). + * The return value is 1 if string matches pattern, and 0 otherwise. The + * matching operation permits the following special characters in the + * pattern: *?\[] (see the manual entry for details on what these mean). * * Side effects: * None. * *---------------------------------------------------------------------- */ int -Tcl_StringMatch(string, pattern) - CONST char *string; /* String. */ +Tcl_StringMatch(str, pattern) + CONST char *str; /* String. */ CONST char *pattern; /* Pattern, which may contain special * characters. */ { - return Tcl_StringCaseMatch(string, pattern, 0); + return Tcl_StringCaseMatch(str, pattern, 0); } /* *---------------------------------------------------------------------- * * Tcl_StringCaseMatch -- * - * See if a particular string matches a particular pattern. - * Allows case insensitivity. + * See if a particular string matches a particular pattern. Allows case + * insensitivity. * * Results: - * The return value is 1 if string matches pattern, and - * 0 otherwise. The matching operation permits the following - * special characters in the pattern: *?\[] (see the manual - * entry for details on what these mean). + * The return value is 1 if string matches pattern, and 0 otherwise. The + * matching operation permits the following special characters in the + * pattern: *?\[] (see the manual entry for details on what these mean). * * Side effects: * None. * *---------------------------------------------------------------------- */ int -Tcl_StringCaseMatch(string, pattern, nocase) - CONST char *string; /* String. */ +Tcl_StringCaseMatch(str, pattern, nocase) + CONST char *str; /* String. */ CONST char *pattern; /* Pattern, which may contain special * characters. */ int nocase; /* 0 for case sensitive, 1 for insensitive */ { int p, charLen; CONST char *pstart = pattern; Tcl_UniChar ch1, ch2; - + while (1) { p = *pattern; - + /* - * See if we're at the end of both the pattern and the string. If - * so, we succeeded. If we're at the end of the pattern but not at - * the end of the string, we failed. + * See if we're at the end of both the pattern and the string. If so, + * we succeeded. If we're at the end of the pattern but not at the end + * of the string, we failed. */ - + if (p == '\0') { - return (*string == '\0'); + return (*str == '\0'); } - if ((*string == '\0') && (p != '*')) { + if ((*str == '\0') && (p != '*')) { return 0; } /* - * Check for a "*" as the next pattern character. It matches - * any substring. We handle this by calling ourselves - * recursively for each postfix of string, until either we - * match or we reach the end of the string. + * Check for a "*" as the next pattern character. It matches any + * substring. We handle this by calling ourselves recursively for each + * postfix of string, until either we match or we reach the end of the + * string. */ - + if (p == '*') { /* * Skip all successive *'s in the pattern */ + while (*(++pattern) == '*') {} p = *pattern; if (p == '\0') { return 1; } + /* * This is a special case optimization for single-byte utf. */ + if (UCHAR(*pattern) < 0x80) { ch2 = (Tcl_UniChar) (nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern)); } else { Tcl_UtfToUniChar(pattern, &ch2); if (nocase) { ch2 = Tcl_UniCharToLower(ch2); } + } while (1) { /* * Optimization for matching - cruise through the string * quickly if the next char in the pattern isn't a special * character */ + if ((p != '[') && (p != '?') && (p != '\\')) { if (nocase) { - while (*string) { - charLen = TclUtfToUniChar(string, &ch1); + while (*str) { + charLen = TclUtfToUniChar(str, &ch1); if (ch2==ch1 || ch2==Tcl_UniCharToLower(ch1)) { break; } - string += charLen; + str += charLen; } } else { /* * There's no point in trying to make this code - * shorter, as the number of bytes you want to - * compare each time is non-constant. - */ - while (*string) { - charLen = TclUtfToUniChar(string, &ch1); - if (ch2 == ch1) { - break; - } - string += charLen; - } - } - } - if (Tcl_StringCaseMatch(string, pattern, nocase)) { - return 1; - } - if (*string == '\0') { - return 0; - } - string += TclUtfToUniChar(string, &ch1); - } - } - - /* - * Check for a "?" as the next pattern character. It matches - * any single character. + * shorter, as the number of bytes you want to compare + * each time is non-constant. + */ + + while (*str) { + charLen = TclUtfToUniChar(str, &ch1); + if (ch2 == ch1) { + break; + } + str += charLen; + } + } + } + if (Tcl_StringCaseMatch(str, pattern, nocase)) { + return 1; + } + if (*str == '\0') { + return 0; + } + str += TclUtfToUniChar(str, &ch1); + } + } + + /* + * Check for a "?" as the next pattern character. It matches any + * single character. */ if (p == '?') { pattern++; - string += TclUtfToUniChar(string, &ch1); + str += TclUtfToUniChar(str, &ch1); continue; } /* - * Check for a "[" as the next pattern character. It is followed - * by a list of characters that are acceptable, or by a range - * (two characters separated by "-"). + * Check for a "[" as the next pattern character. It is followed by a + * list of characters that are acceptable, or by a range (two + * characters separated by "-"). */ if (p == '[') { Tcl_UniChar startChar, endChar; pattern++; - if (UCHAR(*string) < 0x80) { + if (UCHAR(*str) < 0x80) { ch1 = (Tcl_UniChar) - (nocase ? tolower(UCHAR(*string)) : UCHAR(*string)); - string++; + (nocase ? tolower(UCHAR(*str)) : UCHAR(*str)); + str++; } else { - string += Tcl_UtfToUniChar(string, &ch1); + str += Tcl_UtfToUniChar(str, &ch1); if (nocase) { ch1 = Tcl_UniCharToLower(ch1); } } while (1) { @@ -1383,12 +1376,12 @@ pattern++; continue; } /* - * If the next pattern character is '\', just strip off the '\' - * so we do exact matching on the character that follows. + * If the next pattern character is '\', just strip off the '\' so we + * do exact matching on the character that follows. */ if (p == '\\') { pattern++; if (*pattern == '\0') { @@ -1395,15 +1388,15 @@ return 0; } } /* - * There's no special character. Just make sure that the next - * bytes of each string match. + * There's no special character. Just make sure that the next bytes of + * each string match. */ - string += TclUtfToUniChar(string, &ch1); + str += TclUtfToUniChar(str, &ch1); pattern += TclUtfToUniChar(pattern, &ch2); if (nocase) { if (Tcl_UniCharToLower(ch1) != Tcl_UniCharToLower(ch2)) { return 0; } @@ -1414,52 +1407,15 @@ } /* *---------------------------------------------------------------------- * - * TclMatchIsTrivial -- - * - * Test whether a particular glob pattern is a trivial pattern. - * (i.e. where matching is the same as equality testing). - * - * Results: - * A boolean indicating whether the pattern is free of all of the - * glob special chars. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclMatchIsTrivial(pattern) - CONST char *pattern; -{ - CONST char *p = pattern; - - while (1) { - switch (*p++) { - case '\0': - return 1; - case '*': - case '?': - case '[': - case '\\': - return 0; - } - } -} - -/* - *---------------------------------------------------------------------- - * * Tcl_DStringInit -- * - * Initializes a dynamic string, discarding any previous contents - * of the string (Tcl_DStringFree should have been called already - * if the dynamic string was previously in use). + * Initializes a dynamic string, discarding any previous contents of the + * string (Tcl_DStringFree should have been called already if the dynamic + * string was previously in use). * * Results: * None. * * Side effects: @@ -1481,45 +1437,45 @@ /* *---------------------------------------------------------------------- * * Tcl_DStringAppend -- * - * Append more characters to the current value of a dynamic string. + * Append more bytes to the current value of a dynamic string. * * Results: * The return value is a pointer to the dynamic string's new value. * * Side effects: - * Length bytes from string (or all of string if length is less - * than zero) are added to the current value of the string. Memory - * gets reallocated if needed to accomodate the string's new size. + * Length bytes from "bytes" (or all of "bytes" if length is less than + * zero) are added to the current value of the string. Memory gets + * reallocated if needed to accomodate the string's new size. * *---------------------------------------------------------------------- */ char * -Tcl_DStringAppend(dsPtr, string, length) +Tcl_DStringAppend(dsPtr, bytes, length) Tcl_DString *dsPtr; /* Structure describing dynamic string. */ - CONST char *string; /* String to append. If length is -1 then - * this must be null-terminated. */ - int length; /* Number of characters from string to - * append. If < 0, then append all of string, - * up to null at end. */ + CONST char *bytes; /* String to append. If length is -1 then this + * must be null-terminated. */ + int length; /* Number of bytes from "bytes" to append. If + * < 0, then append all of bytes, up to null + * at end. */ { int newSize; char *dst; CONST char *end; if (length < 0) { - length = strlen(string); + length = strlen(bytes); } newSize = length + dsPtr->length; /* - * Allocate a larger buffer for the string if the current one isn't - * large enough. Allocate extra space in the new buffer so that there - * will be room to grow before we have to allocate again. + * Allocate a larger buffer for the string if the current one isn't large + * enough. Allocate extra space in the new buffer so that there will be + * room to grow before we have to allocate again. */ if (newSize >= dsPtr->spaceAvl) { dsPtr->spaceAvl = newSize * 2; if (dsPtr->string == dsPtr->staticSpace) { @@ -1534,17 +1490,16 @@ (size_t) dsPtr->spaceAvl); } } /* - * Copy the new string into the buffer at the end of the old - * one. + * Copy the new string into the buffer at the end of the old one. */ - for (dst = dsPtr->string + dsPtr->length, end = string+length; - string < end; string++, dst++) { - *dst = *string; + for (dst = dsPtr->string + dsPtr->length, end = bytes+length; + bytes < end; bytes++, dst++) { + *dst = *bytes; } *dst = '\0'; dsPtr->length += length; return dsPtr->string; } @@ -1558,37 +1513,36 @@ * * Results: * The return value is a pointer to the dynamic string's new value. * * Side effects: - * String is reformatted as a list element and added to the current - * value of the string. Memory gets reallocated if needed to - * accomodate the string's new size. + * String is reformatted as a list element and added to the current value + * of the string. Memory gets reallocated if needed to accomodate the + * string's new size. * *---------------------------------------------------------------------- */ char * -Tcl_DStringAppendElement(dsPtr, string) +Tcl_DStringAppendElement(dsPtr, element) Tcl_DString *dsPtr; /* Structure describing dynamic string. */ - CONST char *string; /* String to append. Must be + CONST char *element; /* String to append. Must be * null-terminated. */ { int newSize, flags, strSize; char *dst; - strSize = ((string == NULL) ? 0 : strlen(string)); - newSize = Tcl_ScanCountedElement(string, strSize, &flags) + strSize = ((element== NULL) ? 0 : strlen(element)); + newSize = Tcl_ScanCountedElement(element, strSize, &flags) + dsPtr->length + 1; /* - * Allocate a larger buffer for the string if the current one isn't - * large enough. Allocate extra space in the new buffer so that there - * will be room to grow before we have to allocate again. - * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string - * to a larger buffer, since there may be embedded NULLs in the - * string in some cases. + * Allocate a larger buffer for the string if the current one isn't large + * enough. Allocate extra space in the new buffer so that there will be + * room to grow before we have to allocate again. SPECIAL NOTE: must use + * memcpy, not strcpy, to copy the string to a larger buffer, since there + * may be embedded NULLs in the string in some cases. */ if (newSize >= dsPtr->spaceAvl) { dsPtr->spaceAvl = newSize * 2; if (dsPtr->string == dsPtr->staticSpace) { @@ -1603,46 +1557,47 @@ (size_t) dsPtr->spaceAvl); } } /* - * Convert the new string to a list element and copy it into the - * buffer at the end, with a space, if needed. + * Convert the new string to a list element and copy it into the buffer at + * the end, with a space, if needed. */ dst = dsPtr->string + dsPtr->length; if (TclNeedSpace(dsPtr->string, dst)) { *dst = ' '; dst++; dsPtr->length++; + /* - * If we need a space to separate this element from preceding - * stuff, then this element will not lead a list, and need not - * have it's leading '#' quoted. + * If we need a space to separate this element from preceding stuff, + * then this element will not lead a list, and need not have it's + * leading '#' quoted. */ + flags |= TCL_DONT_QUOTE_HASH; } - dsPtr->length += Tcl_ConvertCountedElement(string, strSize, dst, flags); + dsPtr->length += Tcl_ConvertCountedElement(element, strSize, dst, flags); return dsPtr->string; } /* *---------------------------------------------------------------------- * * Tcl_DStringSetLength -- * - * Change the length of a dynamic string. This can cause the - * string to either grow or shrink, depending on the value of - * length. + * Change the length of a dynamic string. This can cause the string to + * either grow or shrink, depending on the value of length. * * Results: * None. * * Side effects: - * The length of dsPtr is changed to length and a null byte is - * stored at that position in the string. If length is larger - * than the space allocated for dsPtr, then a panic occurs. + * The length of dsPtr is changed to length and a null byte is stored at + * that position in the string. If length is larger than the space + * allocated for dsPtr, then a panic occurs. * *---------------------------------------------------------------------- */ void @@ -1655,19 +1610,19 @@ if (length < 0) { length = 0; } if (length >= dsPtr->spaceAvl) { /* - * There are two interesting cases here. In the first case, the user - * may be trying to allocate a large buffer of a specific size. It + * There are two interesting cases here. In the first case, the user + * may be trying to allocate a large buffer of a specific size. It * would be wasteful to overallocate that buffer, so we just allocate - * enough for the requested size plus the trailing null byte. In the + * enough for the requested size plus the trailing null byte. In the * second case, we are growing the buffer incrementally, so we need - * behavior similar to Tcl_DStringAppend. The requested length will - * usually be a small delta above the current spaceAvl, so we'll end up - * doubling the old size. This won't grow the buffer quite as quickly, - * but it should be close enough. + * behavior similar to Tcl_DStringAppend. The requested length will + * usually be a small delta above the current spaceAvl, so we'll end + * up doubling the old size. This won't grow the buffer quite as + * quickly, but it should be close enough. */ newsize = dsPtr->spaceAvl * 2; if (length < newsize) { dsPtr->spaceAvl = newsize; @@ -1693,21 +1648,22 @@ /* *---------------------------------------------------------------------- * * Tcl_DStringFree -- * - * Frees up any memory allocated for the dynamic string and - * reinitializes the string to an empty state. + * Frees up any memory allocated for the dynamic string and reinitializes + * the string to an empty state. * * Results: * None. * * Side effects: - * The previous contents of the dynamic string are lost, and - * the new value is an empty string. + * The previous contents of the dynamic string are lost, and the new + * value is an empty string. * - *---------------------------------------------------------------------- */ + *---------------------------------------------------------------------- + */ void Tcl_DStringFree(dsPtr) Tcl_DString *dsPtr; /* Structure describing dynamic string. */ { @@ -1723,21 +1679,20 @@ /* *---------------------------------------------------------------------- * * Tcl_DStringResult -- * - * This procedure moves the value of a dynamic string into an - * interpreter as its string result. Afterwards, the dynamic string - * is reset to an empty string. + * This function moves the value of a dynamic string into an interpreter + * as its string result. Afterwards, the dynamic string is reset to an + * empty string. * * Results: * None. * * Side effects: - * The string is "moved" to interp's result, and any existing - * string result for interp is freed. dsPtr is reinitialized to - * an empty string. + * The string is "moved" to interp's result, and any existing string + * result for interp is freed. dsPtr is reinitialized to an empty string. * *---------------------------------------------------------------------- */ void @@ -1745,21 +1700,21 @@ Tcl_Interp *interp; /* Interpreter whose result is to be reset. */ Tcl_DString *dsPtr; /* Dynamic string that is to become the * result of interp. */ { Tcl_ResetResult(interp); - + if (dsPtr->string != dsPtr->staticSpace) { interp->result = dsPtr->string; interp->freeProc = TCL_DYNAMIC; } else if (dsPtr->length < TCL_RESULT_SIZE) { interp->result = ((Interp *) interp)->resultSpace; strcpy(interp->result, dsPtr->string); } else { Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); } - + dsPtr->string = dsPtr->staticSpace; dsPtr->length = 0; dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; dsPtr->staticSpace[0] = '\0'; } @@ -1767,18 +1722,18 @@ /* *---------------------------------------------------------------------- * * Tcl_DStringGetResult -- * - * This procedure moves an interpreter's result into a dynamic string. + * This function moves an interpreter's result into a dynamic string. * * Results: * None. * * Side effects: - * The interpreter's string result is cleared, and the previous - * contents of dsPtr are freed. + * The interpreter's string result is cleared, and the previous contents + * of dsPtr are freed. * * If the string result is empty, the object result is moved to the * string result, then the object result is reset. * *---------------------------------------------------------------------- @@ -1785,22 +1740,22 @@ */ void Tcl_DStringGetResult(interp, dsPtr) Tcl_Interp *interp; /* Interpreter whose result is to be reset. */ - Tcl_DString *dsPtr; /* Dynamic string that is to become the - * result of interp. */ + Tcl_DString *dsPtr; /* Dynamic string that is to become the result + * of interp. */ { Interp *iPtr = (Interp *) interp; - + if (dsPtr->string != dsPtr->staticSpace) { ckfree(dsPtr->string); } /* - * If the string result is empty, move the object result to the - * string result, then reset the object result. + * If the string result is empty, move the object result to the string + * result, then reset the object result. */ (void) Tcl_GetStringResult(interp); dsPtr->length = strlen(iPtr->result); @@ -1823,23 +1778,23 @@ dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length + 1)); dsPtr->spaceAvl = dsPtr->length + 1; } strcpy(dsPtr->string, iPtr->result); } - + iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; } /* *---------------------------------------------------------------------- * * Tcl_DStringStartSublist -- * - * This procedure adds the necessary information to a dynamic - * string (e.g. " {" to start a sublist. Future element - * appends will be in the sublist rather than the main list. + * This function adds the necessary information to a dynamic string + * (e.g. " {") to start a sublist. Future element appends will be in the + * sublist rather than the main list. * * Results: * None. * * Side effects: @@ -1848,11 +1803,11 @@ *---------------------------------------------------------------------- */ void Tcl_DStringStartSublist(dsPtr) - Tcl_DString *dsPtr; /* Dynamic string. */ + Tcl_DString *dsPtr; /* Dynamic string. */ { if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) { Tcl_DStringAppend(dsPtr, " {", -1); } else { Tcl_DStringAppend(dsPtr, "{", -1); @@ -1862,14 +1817,13 @@ /* *---------------------------------------------------------------------- * * Tcl_DStringEndSublist -- * - * This procedure adds the necessary characters to a dynamic - * string to end a sublist (e.g. "}"). Future element appends - * will be in the enclosing (sub)list rather than the current - * sublist. + * This function adds the necessary characters to a dynamic string to end + * a sublist (e.g. "}"). Future element appends will be in the enclosing + * (sub)list rather than the current sublist. * * Results: * None. * * Side effects: @@ -1878,91 +1832,186 @@ *---------------------------------------------------------------------- */ void Tcl_DStringEndSublist(dsPtr) - Tcl_DString *dsPtr; /* Dynamic string. */ + Tcl_DString *dsPtr; /* Dynamic string. */ { Tcl_DStringAppend(dsPtr, "}", -1); } /* *---------------------------------------------------------------------- * * Tcl_PrintDouble -- * - * Given a floating-point value, this procedure converts it to - * an ASCII string using. + * Given a floating-point value, this function converts it to an ASCII + * string using. * * Results: - * The ASCII equivalent of "value" is written at "dst". It is - * written using the current precision, and it is guaranteed to - * contain a decimal point or exponent, so that it looks like - * a floating-point value and not an integer. + * The ASCII equivalent of "value" is written at "dst". It is written + * using the current precision, and it is guaranteed to contain a decimal + * point or exponent, so that it looks like a floating-point value and + * not an integer. * * Side effects: * None. * *---------------------------------------------------------------------- */ void Tcl_PrintDouble(interp, value, dst) - Tcl_Interp *interp; /* Interpreter whose tcl_precision - * variable used to be used to control - * printing. It's ignored now. */ - double value; /* Value to print as string. */ - char *dst; /* Where to store converted value; - * must have at least TCL_DOUBLE_SPACE - * characters. */ + Tcl_Interp *interp; /* Interpreter whose tcl_precision variable + * used to be used to control printing. It's + * ignored now. */ + double value; /* Value to print as string. */ + char *dst; /* Where to store converted value; must have + * at least TCL_DOUBLE_SPACE characters. */ { char *p, c; + int exp; + int signum; + char buffer[TCL_DOUBLE_SPACE]; Tcl_UniChar ch; - Tcl_MutexLock(&precisionMutex); - sprintf(dst, precisionFormat, value); - Tcl_MutexUnlock(&precisionMutex); + int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int)sizeof(int)); /* - * If the ASCII result looks like an integer, add ".0" so that it - * doesn't look like an integer anymore. This prevents floating-point - * values from being converted to integers unintentionally. - * Check for ASCII specifically to speed up the function. + * If *precisionPtr == 0, then use TclDoubleDigits to develop a decimal + * significand and exponent, then format it in E or F format as + * appropriate. If *precisionPtr != 0, use the native sprintf and then + * add a trailing ".0" if there is no decimal point in the rep. */ - for (p = dst; *p != 0; ) { - if (UCHAR(*p) < 0x80) { - c = *p++; - } else { - p += Tcl_UtfToUniChar(p, &ch); - c = UCHAR(ch); - } - if ((c == '.') || isalpha(UCHAR(c))) { /* INTL: ISO only. */ + if ( *precisionPtr == 0 ) { + /* + * Handle NaN. + */ + + if (TclIsNaN(value)) { + TclFormatNaN(value, dst); + return; + } + + /* + * Handle infinities. + */ + + if (TclIsInfinite(value)) { + if (value < 0) { + strcpy(dst, "-Inf"); + } else { + strcpy(dst, "Inf"); + } return; } + + /* + * Ordinary (normal and denormal) values. + */ + + exp = TclDoubleDigits(buffer, value, &signum); + if (signum) { + *dst++ = '-'; + } + p = buffer; + if (exp < -3 || exp > 17) { + /* + * E format for numbers < 1e-3 or >= 1e17. + */ + + *dst++ = *p++; + c = *p; + if (c != '\0') { + *dst++ = '.'; + while (c != '\0') { + *dst++ = c; + c = *++p; + } + } + sprintf(dst, "e%+d", exp-1); + } else { + /* + * F format for others. + */ + + if (exp <= 0) { + *dst++ = '0'; + } + c = *p; + while (exp-- > 0) { + if (c != '\0') { + *dst++ = c; + c = *++p; + } else { + *dst++ = '0'; + } + } + *dst++ = '.'; + if (c == '\0') { + *dst++ = '0'; + } else { + while (++exp < 0) { + *dst++ = '0'; + } + while (c != '\0') { + *dst++ = c; + c = *++p; + } + } + *dst++ = '\0'; + } + + } else { + /* + * tcl_precision is supplied, pass it to the native sprintf. + */ + + sprintf(dst, "%.*g", *precisionPtr, value); + + /* + * If the ASCII result looks like an integer, add ".0" so that it + * doesn't look like an integer anymore. This prevents floating-point + * values from being converted to integers unintentionally. Check for + * ASCII specifically to speed up the function. + */ + + for (p = dst; *p != 0; ) { + if (UCHAR(*p) < 0x80) { + c = *p++; + } else { + p += Tcl_UtfToUniChar(p, &ch); + c = UCHAR(ch); + } + if ((c == '.') || isalpha(UCHAR(c))) { /* INTL: ISO only. */ + return; + } + } + p[0] = '.'; + p[1] = '0'; + p[2] = 0; + } - p[0] = '.'; - p[1] = '0'; - p[2] = 0; } /* *---------------------------------------------------------------------- * * TclPrecTraceProc -- * - * This procedure is invoked whenever the variable "tcl_precision" - * is written. + * This function is invoked whenever the variable "tcl_precision" is + * written. * * Results: - * Returns NULL if all went well, or an error message if the - * new value for the variable doesn't make sense. + * Returns NULL if all went well, or an error message if the new value + * for the variable doesn't make sense. * * Side effects: - * If the new value doesn't make sense then this procedure - * undoes the effect of the variable modification. Otherwise - * it modifies the format string that's used by Tcl_PrintDouble. + * If the new value doesn't make sense then this function undoes the + * effect of the variable modification. Otherwise it modifies the format + * string that's used by Tcl_PrintDouble. * *---------------------------------------------------------------------- */ /* ARGSUSED */ @@ -1972,13 +2021,13 @@ Tcl_Interp *interp; /* Interpreter containing variable. */ CONST char *name1; /* Name of variable. */ CONST char *name2; /* Second part of variable name. */ int flags; /* Information about what happened. */ { - CONST char *value; - char *end; + Tcl_Obj* value; int prec; + int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int)sizeof(int)); /* * If the variable is unset, then recreate the trace. */ @@ -1990,64 +2039,48 @@ } return (char *) NULL; } /* - * When the variable is read, reset its value from our shared - * value. This is needed in case the variable was modified in - * some other interpreter so that this interpreter's value is - * out of date. + * When the variable is read, reset its value from our shared value. This + * is needed in case the variable was modified in some other interpreter + * so that this interpreter's value is out of date. */ - Tcl_MutexLock(&precisionMutex); if (flags & TCL_TRACE_READS) { - Tcl_SetVar2(interp, name1, name2, precisionString, + Tcl_SetVar2Ex(interp, name1, name2, Tcl_NewIntObj(*precisionPtr), flags & TCL_GLOBAL_ONLY); - Tcl_MutexUnlock(&precisionMutex); return (char *) NULL; } /* - * The variable is being written. Check the new value and disallow - * it if it isn't reasonable or if this is a safe interpreter (we - * don't want safe interpreters messing up the precision of other - * interpreters). + * The variable is being written. Check the new value and disallow it if + * it isn't reasonable or if this is a safe interpreter (we don't want + * safe interpreters messing up the precision of other interpreters). */ if (Tcl_IsSafe(interp)) { - Tcl_SetVar2(interp, name1, name2, precisionString, - flags & TCL_GLOBAL_ONLY); - Tcl_MutexUnlock(&precisionMutex); return "can't modify precision from a safe interpreter"; } - value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY); - if (value == NULL) { - value = ""; - } - prec = strtoul(value, &end, 10); - if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) || - (end == value) || (*end != 0)) { - Tcl_SetVar2(interp, name1, name2, precisionString, - flags & TCL_GLOBAL_ONLY); - Tcl_MutexUnlock(&precisionMutex); + value = Tcl_GetVar2Ex(interp, name1, name2, flags & TCL_GLOBAL_ONLY); + if (value == NULL + || Tcl_GetIntFromObj((Tcl_Interp*) NULL, value, &prec) != TCL_OK + || prec < 0 || prec > TCL_MAX_PREC) { return "improper value for precision"; } - TclFormatInt(precisionString, prec); - sprintf(precisionFormat, "%%.%dg", prec); - Tcl_MutexUnlock(&precisionMutex); + *precisionPtr = prec; return (char *) NULL; } /* *---------------------------------------------------------------------- * * TclNeedSpace -- * - * This procedure checks to see whether it is appropriate to - * add a space before appending a new list element to an - * existing string. + * This function checks to see whether it is appropriate to add a space + * before appending a new list element to an existing string. * * Results: * The return value is 1 if a space is appropriate, 0 otherwise. * * Side effects: @@ -2057,26 +2090,27 @@ */ int TclNeedSpace(start, end) CONST char *start; /* First character in string. */ - CONST char *end; /* End of string (place where space will - * be added, if appropriate). */ + CONST char *end; /* End of string (place where space will be + * added, if appropriate). */ { /* - * A space is needed unless either + * A space is needed unless either: * (a) we're at the start of the string, or */ + if (end == start) { return 0; } /* - * (b) we're at the start of a nested list-element, quoted with an - * open curly brace; we can be nested arbitrarily deep, so long - * as the first curly brace starts an element, so backtrack over - * open curly braces that are trailing characters of the string; and + * (b) we're at the start of a nested list-element, quoted with an open + * curly brace; we can be nested arbitrarily deep, so long as the + * first curly brace starts an element, so backtrack over open curly + * braces that are trailing characters of the string; and */ end = Tcl_UtfPrev(end, start); while (*end == '{') { if (end == start) { @@ -2085,146 +2119,62 @@ end = Tcl_UtfPrev(end, start); } /* * (c) the trailing character of the string is already a list-element - * separator (according to TclFindElement); that is, one of these - * characters: - * \u0009 \t TAB - * \u000A \n NEWLINE - * \u000B \v VERTICAL TAB - * \u000C \f FORM FEED - * \u000D \r CARRIAGE RETURN - * \u0020 SPACE - * with the condition that the penultimate character is not a - * backslash. + * separator (according to TclFindElement); that is, one of these + * characters: + * \u0009 \t TAB + * \u000A \n NEWLINE + * \u000B \v VERTICAL TAB + * \u000C \f FORM FEED + * \u000D \r CARRIAGE RETURN + * \u0020 SPACE + * with the condition that the penultimate character is not a + * backslash. */ if (*end > 0x20) { /* - * Performance tweak. All ASCII spaces are <= 0x20. So get - * a quick answer for most characters before comparing against - * all spaces in the switch below. + * Performance tweak. All ASCII spaces are <= 0x20. So get a quick + * answer for most characters before comparing against all spaces in + * the switch below. * - * NOTE: Remove this if other Unicode spaces ever get accepted - * as list-element separators. + * NOTE: Remove this if other Unicode spaces ever get accepted as + * list-element separators. */ return 1; } switch (*end) { - case ' ': - case '\t': - case '\n': - case '\r': - case '\v': - case '\f': - if ((end == start) || (end[-1] != '\\')) { - return 0; - } - } - return 1; -} - -/* - *---------------------------------------------------------------------- - * - * TclFormatInt -- - * - * This procedure formats an integer into a sequence of decimal digit - * characters in a buffer. If the integer is negative, a minus sign is - * inserted at the start of the buffer. A null character is inserted at - * the end of the formatted characters. It is the caller's - * responsibility to ensure that enough storage is available. This - * procedure has the effect of sprintf(buffer, "%d", n) but is faster. - * - * Results: - * An integer representing the number of characters formatted, not - * including the terminating \0. - * - * Side effects: - * The formatted characters are written into the storage pointer to - * by the "buffer" argument. - * - *---------------------------------------------------------------------- - */ - -int -TclFormatInt(buffer, n) - char *buffer; /* Points to the storage into which the - * formatted characters are written. */ - long n; /* The integer to format. */ -{ - long intVal; - int i; - int numFormatted, j; - char *digits = "0123456789"; - - /* - * Check first whether "n" is zero. - */ - - if (n == 0) { - buffer[0] = '0'; - buffer[1] = 0; - return 1; - } - - /* - * Check whether "n" is the maximum negative value. This is - * -2^(m-1) for an m-bit word, and has no positive equivalent; - * negating it produces the same value. - */ - - if (n == -n) { - sprintf(buffer, "%ld", n); - return strlen(buffer); - } - - /* - * Generate the characters of the result backwards in the buffer. - */ - - intVal = (n < 0? -n : n); - i = 0; - buffer[0] = '\0'; - do { - i++; - buffer[i] = digits[intVal % 10]; - intVal = intVal/10; - } while (intVal > 0); - if (n < 0) { - i++; - buffer[i] = '-'; - } - numFormatted = i; - - /* - * Now reverse the characters. - */ - - for (j = 0; j < i; j++, i--) { - char tmp = buffer[i]; - buffer[i] = buffer[j]; - buffer[j] = tmp; - } - return numFormatted; -} + case ' ': + case '\t': + case '\n': + case '\r': + case '\v': + case '\f': + if ((end == start) || (end[-1] != '\\')) { + return 0; + } + } + return 1; +} +#if 0 /* *---------------------------------------------------------------------- * * TclLooksLikeInt -- * - * This procedure decides whether the leading characters of a - * string look like an integer or something else (such as a - * floating-point number or string). + * This function decides whether the leading characters of a string look + * like an integer or something else (such as a floating-point number or + * string). * * Results: - * The return value is 1 if the leading characters of p look - * like a valid Tcl integer. If they look like a floating-point - * number (e.g. "e01" or "2.4"), or if they don't look like a - * number at all, then 0 is returned. + * The return value is 1 if the leading characters of p look like a valid + * Tcl integer. If they look like a floating-point number (e.g. "e01" or + * "2.4"), or if they don't look like a number at all, then 0 is + * returned. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -2231,153 +2181,210 @@ */ int TclLooksLikeInt(bytes, length) register CONST char *bytes; /* Points to first byte of the string. */ - int length; /* Number of bytes in the string. If < 0 - * bytes up to the first null byte are - * considered (if they may appear in an - * integer). */ + int length; /* Number of bytes in the string. If < 0 bytes + * up to the first null byte are considered + * (if they may appear in an integer). */ { register CONST char *p; if ((bytes == NULL) && (length > 0)) { Tcl_Panic("TclLooksLikeInt: cannot scan %d bytes from NULL", length); } if (length < 0) { - length = (bytes? strlen(bytes) : 0); + length = (bytes? strlen(bytes) : 0); } p = bytes; while (length && isspace(UCHAR(*p))) { /* INTL: ISO space. */ length--; p++; } if (length == 0) { - return 0; + return 0; } if ((*p == '+') || (*p == '-')) { - p++; length--; + p++; + 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; +} /* *---------------------------------------------------------------------- * * TclGetIntForIndex -- * - * This procedure returns an integer corresponding to the list index - * held in a Tcl object. The Tcl object's value is expected to be - * either an integer or a string of the form "end([+-]integer)?". + * This function returns an integer corresponding to the list index held + * in a Tcl object. The Tcl object's value is expected to be in the + * format integer([+-]integer)? or the format end([+-]integer)?. * * Results: * The return value is normally TCL_OK, which means that the index was - * successfully stored into the location referenced by "indexPtr". If - * the Tcl object referenced by "objPtr" has the value "end", the - * value stored is "endValue". If "objPtr"s values is not of the form - * "end([+-]integer)?" and - * can not be converted to an integer, TCL_ERROR is returned and, if - * "interp" is non-NULL, an error message is left in the interpreter's - * result object. + * successfully stored into the location referenced by "indexPtr". If the + * Tcl object referenced by "objPtr" has the value "end", the value + * stored is "endValue". If "objPtr"s values is not of one of the + * expected formats, TCL_ERROR is returned and, if "interp" is non-NULL, + * an error message is left in the interpreter's result object. * * Side effects: - * The object referenced by "objPtr" might be converted to an - * integer, wide integer, or end-based-index object. + * The object referenced by "objPtr" might be converted to an integer, + * wide integer, or end-based-index object. * *---------------------------------------------------------------------- */ int TclGetIntForIndex(interp, objPtr, endValue, indexPtr) - Tcl_Interp *interp; /* Interpreter to use for error reporting. - * If NULL, then no error message is left - * after errors. */ - Tcl_Obj *objPtr; /* Points to an object containing either - * "end" or an integer. */ + Tcl_Interp *interp; /* Interpreter to use for error reporting. If + * NULL, then no error message is left after + * errors. */ + Tcl_Obj *objPtr; /* Points to an object containing either "end" + * or an integer. */ int endValue; /* The value to be stored at "indexPtr" if * "objPtr" holds "end". */ int *indexPtr; /* Location filled in with an integer * representing an index. */ { - char *bytes; - int offset; - Tcl_WideInt wideOffset; - - /* - * If the object is already an integer, use it. - */ - - if (objPtr->typePtr == &tclIntType) { - *indexPtr = (int)objPtr->internalRep.longValue; - return TCL_OK; - } - - /* - * If the object is already a wide-int, and it is not out of range - * for an integer, use it. [Bug #526717] - */ - if (objPtr->typePtr == &tclWideIntType) { - TclGetWide(wideOffset,objPtr); - if (wideOffset >= Tcl_LongAsWide(INT_MIN) - && wideOffset <= Tcl_LongAsWide(INT_MAX)) { - *indexPtr = (int) Tcl_WideAsLong(wideOffset); - return TCL_OK; - } + if (Tcl_GetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) { + return TCL_OK; } if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) { /* - * If the object is already an offset from the end of the - * list, or can be converted to one, use it. + * If the object is already an offset from the end of the list, or can + * be converted to one, use it. */ *indexPtr = endValue + objPtr->internalRep.longValue; - } else if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideOffset) == TCL_OK) { - /* - * If the object can be converted to a wide integer, use - * that. [Bug #526717] - */ - - offset = (int) Tcl_WideAsLong(wideOffset); - if (Tcl_LongAsWide(offset) == wideOffset) { - /* - * But it is representable as a narrow integer, so we - * prefer that (so preserving old behaviour in the - * majority of cases.) - */ - objPtr->typePtr = &tclIntType; - objPtr->internalRep.longValue = offset; - } - *indexPtr = offset; - } else { + int opIdx, length; + char *bytes = Tcl_GetStringFromObj(objPtr, &length); + char *p = bytes; + + while (length && isspace(UCHAR(*p))) { /* INTL: ISO space. */ + length--; p++; + } + if (length == 0) { + goto parseError; + } + if ((*p == '+') || (*p == '-')) { + p++; length--; + } + opIdx = ParseInteger(p, length) + (int) (p-bytes); + if (opIdx) { + int code, first, second; + char savedOp = bytes[opIdx]; + if ((savedOp != '+') && (savedOp != '-')) { + goto parseError; + } + if (isspace(UCHAR(bytes[opIdx+1]))) { + goto parseError; + } + bytes[opIdx] = '\0'; + code = Tcl_GetInt(interp, bytes, &first); + bytes[opIdx] = savedOp; + if (code == TCL_ERROR) { + goto parseError; + } + if (TCL_ERROR == Tcl_GetInt(interp, bytes+opIdx+1, &second)) { + goto parseError; + } + if (savedOp == '+') { + *indexPtr = first + second; + } else { + *indexPtr = first - second; + } + return TCL_OK; + } + /* * Report a parse error. */ + parseError: if (interp != NULL) { - bytes = Tcl_GetString(objPtr); + char *bytes = Tcl_GetString(objPtr); + /* - * The result might not be empty; this resets it which - * should be both a cheap operation, and of little problem - * because this is an error-generation path anyway. + * The result might not be empty; this resets it which should be + * both a cheap operation, and of little problem because this is + * an error-generation path anyway. */ + Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad index \"", bytes, - "\": must be integer or end?-integer?", (char *) NULL); + "\": must be integer?[+-]integer? or end?[+-]integer?", + (char *) NULL); if (!strncmp(bytes, "end-", 3)) { bytes += 3; } TclCheckBadOctal(interp, bytes); } return TCL_ERROR; } - + return TCL_OK; } /* *---------------------------------------------------------------------- @@ -2391,13 +2398,12 @@ * None. * * Side effects: * Stores a valid string in the object's string rep. * - * This procedure does NOT free any earlier string rep. If it is - * called on an object that already has a valid string rep, it will - * leak memory. + * This function does NOT free any earlier string rep. If it is called on an + * object that already has a valid string rep, it will leak memory. * *---------------------------------------------------------------------- */ static void @@ -2421,95 +2427,108 @@ /* *---------------------------------------------------------------------- * * SetEndOffsetFromAny -- * - * Look for a string of the form "end-offset" and convert it - * to an internal representation holding the offset. + * Look for a string of the form "end[+-]offset" and convert it to an + * internal representation holding the offset. * * Results: * Returns TCL_OK if ok, TCL_ERROR if the string was badly formed. * * Side effects: - * If interp is not NULL, stores an error message in the - * interpreter result. + * If interp is not NULL, stores an error message in the interpreter + * result. * *---------------------------------------------------------------------- */ static int SetEndOffsetFromAny(interp, objPtr) - Tcl_Interp* interp; /* Tcl interpreter or NULL */ - Tcl_Obj* objPtr; /* Pointer to the object to parse */ + Tcl_Interp *interp; /* Tcl interpreter or NULL */ + Tcl_Obj* objPtr; /* Pointer to the object to parse */ { int offset; /* Offset in the "end-offset" expression */ register char* bytes; /* String rep of the object */ int length; /* Length of the object's string rep */ - /* If it's already the right type, we're fine. */ + /* + * If it's already the right type, we're fine. + */ if (objPtr->typePtr == &tclEndOffsetType) { return TCL_OK; } - /* Check for a string rep of the right form. */ + /* + * Check for a string rep of the right form. + */ bytes = Tcl_GetStringFromObj(objPtr, &length); if ((*bytes != 'e') || (strncmp(bytes, "end", (size_t)((length > 3) ? 3 : length)) != 0)) { if (interp != NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad index \"", bytes, - "\": must be end?-integer?", (char*) NULL); + "\": must be end?[+-]integer?", (char*) NULL); } return TCL_ERROR; } - /* Convert the string rep */ + /* + * Convert the string rep. + */ if (length <= 3) { offset = 0; - } else if ((length > 4) && (bytes[3] == '-')) { + } else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) { /* - * This is our limited string expression evaluator. Pass everything + * This is our limited string expression evaluator. Pass everything * after "end-" to Tcl_GetInt, then reverse for offset. */ + + if (isspace(UCHAR(bytes[4]))) { + return TCL_ERROR; + } if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { return TCL_ERROR; } - offset = -offset; + if (bytes[3] == '-') { + offset = -offset; + } } else { /* - * Conversion failed. Report the error. + * Conversion failed. Report the error. */ + if (interp != NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad index \"", bytes, - "\": must be integer or end?-integer?", (char *) NULL); + "\": must be end?[+-]integer?", (char *) NULL); } return TCL_ERROR; } /* - * The conversion succeeded. Free the old internal rep and set - * the new one. + * The conversion succeeded. Free the old internal rep and set the new + * one. */ TclFreeIntRep(objPtr); objPtr->internalRep.longValue = offset; objPtr->typePtr = &tclEndOffsetType; return TCL_OK; -} +} /* *---------------------------------------------------------------------- * * TclCheckBadOctal -- * - * This procedure checks for a bad octal value and appends a - * meaningful error to the interp's result. + * This function checks for a bad octal value and appends a meaningful + * error to the interp's result. * * Results: * 1 if the argument was a bad octal, else 0. * * Side effects: @@ -2518,20 +2537,20 @@ *---------------------------------------------------------------------- */ int TclCheckBadOctal(interp, value) - Tcl_Interp *interp; /* Interpreter to use for error reporting. - * If NULL, then no error message is left - * after errors. */ + Tcl_Interp *interp; /* Interpreter to use for error reporting. If + * NULL, then no error message is left after + * errors. */ CONST char *value; /* String to check. */ { register CONST char *p = value; /* - * A frequent mistake is invalid octal values due to an unwanted - * leading zero. Try to generate a meaningful error message. + * A frequent mistake is invalid octal values due to an unwanted leading + * zero. Try to generate a meaningful error message. */ while (isspace(UCHAR(*p))) { /* INTL: ISO space. */ p++; } @@ -2544,15 +2563,18 @@ } while (isspace(UCHAR(*p))) { /* INTL: ISO space. */ p++; } if (*p == '\0') { - /* Reached end of string */ + /* + * Reached end of string. + */ + if (interp != NULL) { /* - * Don't reset the result here because we want this result - * to be added to an existing error message as extra info. + * Don't reset the result here because we want this result to + * be added to an existing error message as extra info. */ Tcl_AppendResult(interp, " (looks like invalid octal number)", (char *) NULL); } return 1; @@ -2563,10 +2585,11 @@ /* *---------------------------------------------------------------------- * * ClearHash -- + * * Remove all the entries in the hash table *tablePtr. * *---------------------------------------------------------------------- */ @@ -2588,20 +2611,19 @@ /* *---------------------------------------------------------------------- * * GetThreadHash -- * - * Get a thread-specific (Tcl_HashTable *) associated with a - * thread data key. + * Get a thread-specific (Tcl_HashTable *) associated with a thread data + * key. * * Results: - * The Tcl_HashTable * corresponding to *keyPtr. + * The Tcl_HashTable * corresponding to *keyPtr. * * Side effects: - * The first call on a keyPtr in each thread creates a new - * Tcl_HashTable, and registers a thread exit handler to - * dispose of it. + * The first call on a keyPtr in each thread creates a new Tcl_HashTable, + * and registers a thread exit handler to dispose of it. * *---------------------------------------------------------------------- */ static Tcl_HashTable * @@ -2620,41 +2642,44 @@ /* *---------------------------------------------------------------------- * * FreeThreadHash -- - * Thread exit handler used by GetThreadHash to dispose - * of a thread hash table. + * + * Thread exit handler used by GetThreadHash to dispose of a thread hash + * table. * * Side effects: * Frees a Tcl_HashTable. * *---------------------------------------------------------------------- */ static void FreeThreadHash(clientData) - ClientData clientData; + ClientData clientData; { Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientData; + ClearHash(tablePtr); Tcl_DeleteHashTable(tablePtr); ckfree((char *) tablePtr); } /* *---------------------------------------------------------------------- * * FreeProcessGlobalValue -- - * Exit handler used by Tcl(Set|Get)ProcessGlobalValue to cleanup - * a ProcessGlobalValue at exit. + * + * Exit handler used by Tcl(Set|Get)ProcessGlobalValue to cleanup a + * ProcessGlobalValue at exit. * *---------------------------------------------------------------------- */ static void FreeProcessGlobalValue(clientData) - ClientData clientData; + ClientData clientData; { ProcessGlobalValue *pgvPtr = (ProcessGlobalValue *) clientData; pgvPtr->epoch++; pgvPtr->numBytes = 0; ckfree(pgvPtr->value); @@ -2669,15 +2694,16 @@ /* *---------------------------------------------------------------------- * * TclSetProcessGlobalValue -- * - * Utility routine to set a global value shared by all threads in - * the process while keeping a thread-local copy as well. + * Utility routine to set a global value shared by all threads in the + * process while keeping a thread-local copy as well. * *---------------------------------------------------------------------- */ + void TclSetProcessGlobalValue(pgvPtr, newValue, encoding) ProcessGlobalValue *pgvPtr; Tcl_Obj *newValue; Tcl_Encoding encoding; @@ -2686,11 +2712,15 @@ Tcl_HashTable *cacheMap; Tcl_HashEntry *hPtr; int dummy; Tcl_MutexLock(&pgvPtr->mutex); - /* Fill the global string value */ + + /* + * Fill the global string value. + */ + pgvPtr->epoch++; if (NULL != pgvPtr->value) { ckfree(pgvPtr->value); } else { Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr); @@ -2702,18 +2732,20 @@ Tcl_FreeEncoding(pgvPtr->encoding); } pgvPtr->encoding = encoding; /* - * Fill the local thread copy directly with the Tcl_Obj - * value to avoid loss of the intrep + * Fill the local thread copy directly with the Tcl_Obj value to avoid + * loss of the intrep. Increment newValue refCount early to handle case + * where we set a PGV to itself. */ + + Tcl_IncrRefCount(newValue); cacheMap = GetThreadHash(&pgvPtr->key); ClearHash(cacheMap); hPtr = Tcl_CreateHashEntry(cacheMap, (char *)pgvPtr->epoch, &dummy); Tcl_SetHashValue(hPtr, (ClientData) newValue); - Tcl_IncrRefCount(newValue); Tcl_MutexUnlock(&pgvPtr->mutex); } /* *---------------------------------------------------------------------- @@ -2738,16 +2770,16 @@ Tcl_HashEntry *hPtr; int epoch = pgvPtr->epoch; if (pgvPtr->encoding) { Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL); - if (pgvPtr->encoding != current) { + if (pgvPtr->encoding != current) { /* - * The system encoding has changed since the master - * string value was saved. Convert the master value - * to be based on the new system encoding. + * The system encoding has changed since the master string value + * was saved. Convert the master value to be based on the new + * system encoding. */ Tcl_DString native, newValue; Tcl_MutexLock(&pgvPtr->mutex); @@ -2759,11 +2791,11 @@ Tcl_DStringLength(&native), &newValue); Tcl_DStringFree(&native); ckfree(pgvPtr->value); pgvPtr->value = ckalloc((unsigned int) Tcl_DStringLength(&newValue) + 1); - memcpy((VOID *) pgvPtr->value, (VOID *) Tcl_DStringValue(&newValue), + memcpy((VOID*) pgvPtr->value, (VOID*) Tcl_DStringValue(&newValue), (size_t) Tcl_DStringLength(&newValue) + 1); Tcl_DStringFree(&newValue); Tcl_FreeEncoding(pgvPtr->encoding); pgvPtr->encoding = current; Tcl_MutexUnlock(&pgvPtr->mutex); @@ -2774,28 +2806,38 @@ cacheMap = GetThreadHash(&pgvPtr->key); hPtr = Tcl_FindHashEntry(cacheMap, (char *)epoch); if (NULL == hPtr) { int dummy; - /* No cache for the current epoch - must be a new one */ - /* First, clear the cacheMap, as anything in it must - * refer to some expired epoch.*/ + /* + * No cache for the current epoch - must be a new one. + * + * First, clear the cacheMap, as anything in it must refer to some + * expired epoch. + */ + ClearHash(cacheMap); - /* If no thread has set the shared value, call the initializer */ - Tcl_MutexLock(&pgvPtr->mutex); - if (NULL == pgvPtr->value) { - if (pgvPtr->proc) { - pgvPtr->epoch++; - (*(pgvPtr->proc))(&pgvPtr->value, &pgvPtr->numBytes, - &pgvPtr->encoding); - Tcl_CreateExitHandler(FreeProcessGlobalValue, - (ClientData) pgvPtr); - } + /* + * If no thread has set the shared value, call the initializer. + */ + + Tcl_MutexLock(&pgvPtr->mutex); + if ((NULL == pgvPtr->value) && (pgvPtr->proc)) { + pgvPtr->epoch++; + (*(pgvPtr->proc))(&pgvPtr->value, &pgvPtr->numBytes, + &pgvPtr->encoding); + if (pgvPtr->value == NULL) { + Tcl_Panic("PGV Initializer did not initialize."); + } + Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr); } - /* Store a copy of the shared value in our epoch-indexed cache */ + /* + * Store a copy of the shared value in our epoch-indexed cache. + */ + value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes); hPtr = Tcl_CreateHashEntry(cacheMap, (char *)pgvPtr->epoch, &dummy); Tcl_MutexUnlock(&pgvPtr->mutex); Tcl_SetHashValue(hPtr, (ClientData) value); Tcl_IncrRefCount(value); @@ -2806,13 +2848,12 @@ /* *---------------------------------------------------------------------- * * TclSetObjNameOfExecutable -- * - * This procedure stores the absolute pathname of - * the executable file (normally as computed by - * TclpFindExecutable). + * This function stores the absolute pathname of the executable file + * (normally as computed by TclpFindExecutable). * * Results: * None. * * Side effects: @@ -2832,19 +2873,18 @@ /* *---------------------------------------------------------------------- * * TclGetObjNameOfExecutable -- * - * This procedure retrieves the absolute pathname of the - * application in which the Tcl library is running, usually - * as previously stored by TclpFindExecutable(). - * This procedure call is the C API equivalent to the - * "info nameofexecutable" command. + * This function retrieves the absolute pathname of the application in + * which the Tcl library is running, usually as previously stored by + * TclpFindExecutable(). This function call is the C API equivalent to + * the "info nameofexecutable" command. * * Results: - * A pointer to an "fsPath" Tcl_Obj, or to an empty Tcl_Obj if - * the pathname of the application is unknown. + * A pointer to an "fsPath" Tcl_Obj, or to an empty Tcl_Obj if the + * pathname of the application is unknown. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -2859,21 +2899,19 @@ /* *---------------------------------------------------------------------- * * Tcl_GetNameOfExecutable -- * - * This procedure retrieves the absolute pathname of the - * application in which the Tcl library is running, and - * returns it in string form. + * This function retrieves the absolute pathname of the application in + * which the Tcl library is running, and returns it in string form. * - * The returned string belongs to Tcl and should be copied - * if the caller plans to keep it, to guard against it - * becoming invalid. + * The returned string belongs to Tcl and should be copied if the caller + * plans to keep it, to guard against it becoming invalid. * * Results: - * A pointer to the internal string or NULL if the internal full - * path name has not been computed or unknown. + * A pointer to the internal string or NULL if the internal full path + * name has not been computed or unknown. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -2894,25 +2932,55 @@ /* *---------------------------------------------------------------------- * * TclpGetTime -- * - * Deprecated synonym for Tcl_GetTime. + * Deprecated synonym for Tcl_GetTime. This function is provided for the + * benefit of extensions written before Tcl_GetTime was exported from the + * library. * * Results: * None. * * Side effects: * Stores current time in the buffer designated by "timePtr" * - * This procedure is provided for the benefit of extensions written - * before Tcl_GetTime was exported from the library. - * *---------------------------------------------------------------------- */ void TclpGetTime(timePtr) Tcl_Time* timePtr; { Tcl_GetTime(timePtr); } + +/* + *---------------------------------------------------------------------- + * + * TclGetPlatform -- + * + * This is a kludge that allows the test library to get access the + * internal tclPlatform variable. + * + * Results: + * Returns a pointer to the tclPlatform variable. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TclPlatformType * +TclGetPlatform() +{ + return &tclPlatform; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclVar.c ================================================================== --- generic/tclVar.c +++ generic/tclVar.c @@ -1,65 +1,66 @@ -/* +/* * tclVar.c -- * - * This file contains routines that implement Tcl variables - * (both scalars and arrays). + * This file contains routines that implement Tcl variables (both scalars + * and arrays). * * The implementation of arrays is modelled after an initial * implementation by Mark Diekhans and Karl Lehenbauer. * * Copyright (c) 1987-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001 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. + * 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.99 2004/11/12 19:16:53 dgp Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.99.2.8 2005/08/19 05:17:48 dgp Exp $ */ #include "tclInt.h" /* - * The strings below are used to indicate what went wrong when a - * variable access is denied. + * The strings below are used to indicate what went wrong when a variable + * access is denied. */ static CONST char *noSuchVar = "no such variable"; static CONST char *isArray = "variable is array"; static CONST char *needArray = "variable isn't array"; static CONST char *noSuchElement = "no such element in array"; static CONST char *danglingElement = - "upvar refers to element in deleted array"; -static CONST char *danglingVar = - "upvar refers to variable in deleted namespace"; + "upvar refers to element in deleted array"; +static CONST char *danglingVar = + "upvar refers to variable in deleted namespace"; static CONST char *badNamespace = "parent namespace doesn't exist"; static CONST char *missingName = "missing variable name"; -static CONST char *isArrayElement = "name refers to an element in an array"; +static CONST char *isArrayElement = + "name refers to an element in an array"; /* * Forward references to procedures defined later in this file: */ static void DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr)); static void DeleteArray _ANSI_ARGS_((Interp *iPtr, CONST char *arrayName, Var *varPtr, int flags)); -static int ObjMakeUpvar _ANSI_ARGS_((Tcl_Interp *interp, - CallFrame *framePtr, Tcl_Obj *otherP1Ptr, - CONST char *otherP2, CONST int otherFlags, - CONST char *myName, int myFlags, int index)); +static int ObjMakeUpvar _ANSI_ARGS_((Tcl_Interp *interp, + CallFrame *framePtr, Tcl_Obj *otherP1Ptr, + CONST char *otherP2, CONST int otherFlags, + CONST char *myName, int myFlags, int index)); static Var * NewVar _ANSI_ARGS_((void)); static ArraySearch * ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp, CONST Var *varPtr, CONST char *varName, Tcl_Obj *handleObj)); static int SetArraySearchObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); /* - * Functions defined in this file that may be exported in the future - * for use by the bytecode compiler and engine or to the public interface. + * Functions defined in this file that may be exported in the future for use + * by the bytecode compiler and engine or to the public interface. */ Var * TclLookupSimpleVar _ANSI_ARGS_((Tcl_Interp *interp, CONST char *varName, int flags, CONST int create, CONST char **errMsgPtr, int *indexPtr)); @@ -75,39 +76,36 @@ static Tcl_SetFromAnyProc PanicOnSetVarName; /* * Types of Tcl_Objs used to cache variable lookups. * - * * localVarName - INTERNALREP DEFINITION: - * longValue = index into locals table + * longValue: index into locals table * * nsVarName - INTERNALREP DEFINITION: - * twoPtrValue.ptr1: pointer to the namespace containing the - * reference - * twoPtrValue.ptr2: pointer to the corresponding Var + * twoPtrValue.ptr1: pointer to the namespace containing the reference + * twoPtrValue.ptr2: pointer to the corresponding Var * * parsedVarName - INTERNALREP DEFINITION: - * twoPtrValue.ptr1 = pointer to the array name Tcl_Obj, - * or NULL if it is a scalar variable - * twoPtrValue.ptr2 = pointer to the element name string - * (owned by this Tcl_Obj), or NULL if - * it is a scalar variable + * twoPtrValue.ptr1: pointer to the array name Tcl_Obj, or NULL if it is a + * scalar variable + * twoPtrValue.ptr2: pointer to the element name string (owned by this + * Tcl_Obj), or NULL if it is a scalar variable */ -Tcl_ObjType tclLocalVarNameType = { +static Tcl_ObjType localVarNameType = { "localVarName", NULL, DupLocalVarName, PanicOnUpdateVarName, PanicOnSetVarName }; /* - * Caching of namespace variables disabled: no simple way was found to - * avoid interfering with the resolver's idea of variable existence. - * A cached varName may keep a variable's name in the namespace's hash - * table, which is the resolver's criterion for existence (see test - * namespace-17.10). - */ + * Caching of namespace variables disabled: no simple way was found to avoid + * interfering with the resolver's idea of variable existence. A cached + * varName may keep a variable's name in the namespace's hash table, which is + * the resolver's criterion for existence (see test namespace-17.10). + */ + #define ENABLE_NS_VARNAME_CACHING 0 #if ENABLE_NS_VARNAME_CACHING static Tcl_FreeInternalRepProc FreeNsVarName; static Tcl_DupInternalRepProc DupNsVarName; @@ -125,33 +123,32 @@ /* * Type of Tcl_Objs used to speed up array searches. * * INTERNALREP DEFINITION: - * twoPtrValue.ptr1 = searchIdNumber as offset from (char*)NULL - * twoPtrValue.ptr2 = variableNameStartInString as offset from (char*)NULL + * twoPtrValue.ptr1: searchIdNumber as offset from (char*)NULL + * twoPtrValue.ptr2: variableNameStartInString as offset from (char*)NULL * - * Note that the value stored in ptr2 is the offset into the string of - * the start of the variable name and not the address of the variable - * name itself, as this can be safely copied. + * Note that the value stored in ptr2 is the offset into the string of the + * start of the variable name and not the address of the variable name itself, + * as this can be safely copied. */ + Tcl_ObjType tclArraySearchType = { "array search", NULL, NULL, NULL, SetArraySearchObj }; - /* *---------------------------------------------------------------------- * * TclLookupVar -- * - * This procedure is used to locate a variable given its name(s). It - * has been mostly superseded by TclObjLookupVar, it is now only used - * by the string-based interfaces. It is kept in tcl8.4 mainly because - * it is in the internal stubs table, so that some extension may be - * calling it. + * This procedure is used to locate a variable given its name(s). It has + * been mostly superseded by TclObjLookupVar, it is now only used by the + * string-based interfaces. It is kept in tcl8.4 mainly because it is in + * the internal stubs table, so that some extension may be calling it. * * Results: * The return value is a pointer to the variable structure indicated by * part1 and part2, or NULL if the variable couldn't be found. If the * variable is found, *arrayPtrPtr is filled in with the address of the @@ -161,58 +158,58 @@ * (VAR_UNDEFINED) variable structure is created, entered into a hash * table, and returned. * * If the variable isn't found and creation wasn't specified, or some * other error occurs, NULL is returned and an error message is left in - * the interp's result if TCL_LEAVE_ERR_MSG is set in flags. - * - * Note: it's possible for the variable returned to be VAR_UNDEFINED - * even if createPart1 or createPart2 are 1 (these only cause the hash - * table entry or array to be created). For example, the variable might - * be a global that has been unset but is still referenced by a - * procedure, or a variable that has been unset but it only being kept - * in existence (if VAR_UNDEFINED) by a trace. + * the interp's result if TCL_LEAVE_ERR_MSG is set in flags. + * + * Note: it's possible for the variable returned to be VAR_UNDEFINED even + * if createPart1 or createPart2 are 1 (these only cause the hash table + * entry or array to be created). For example, the variable might be a + * global that has been unset but is still referenced by a procedure, or + * a variable that has been unset but it only being kept in existence (if + * VAR_UNDEFINED) by a trace. * * Side effects: * New hashtable entries may be created if createPart1 or createPart2 * are 1. * *---------------------------------------------------------------------- */ + Var * TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, - arrayPtrPtr) + arrayPtrPtr) Tcl_Interp *interp; /* Interpreter to use for lookup. */ - CONST char *part1; /* If part2 isn't NULL, this is the name of - * an array. Otherwise, this - * is a full variable name that could - * include a parenthesized array element. */ + CONST char *part1; /* If part2 isn't NULL, this is the name of an + * array. Otherwise, this is a full variable + * name that could include a parenthesized + * array element. */ CONST char *part2; /* Name of element within array, or NULL. */ int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * and TCL_LEAVE_ERR_MSG bits matter. */ - CONST char *msg; /* Verb to use in error messages, e.g. - * "read" or "set". Only needed if - * TCL_LEAVE_ERR_MSG is set in flags. */ - int createPart1; /* If 1, create hash table entry for part 1 - * of name, if it doesn't already exist. If - * 0, return error if it doesn't exist. */ - int createPart2; /* If 1, create hash table entry for part 2 - * of name, if it doesn't already exist. If - * 0, return error if it doesn't exist. */ + CONST char *msg; /* Verb to use in error messages, e.g. "read" + * or "set". Only needed if TCL_LEAVE_ERR_MSG + * is set in flags. */ + int createPart1; /* If 1, create hash table entry for part 1 of + * name, if it doesn't already exist. If 0, + * return error if it doesn't exist. */ + int createPart2; /* If 1, create hash table entry for part 2 of + * name, if it doesn't already exist. If 0, + * return error if it doesn't exist. */ Var **arrayPtrPtr; /* If the name refers to an element of an * array, *arrayPtrPtr gets filled in with - * address of array variable. Otherwise - * this is set to NULL. */ + * address of array variable. Otherwise this + * is set to NULL. */ { Var *varPtr; - CONST char *elName; /* Name of array element or NULL; may be - * same as part2, or may be openParen+1. */ - int openParen, closeParen; - /* If this procedure parses a name into - * array and index, these are the offsets to - * the parens around the index. Otherwise - * they are -1. */ + CONST char *elName; /* Name of array element or NULL; may be same + * as part2, or may be openParen+1. */ + int openParen, closeParen; /* If this procedure parses a name into array + * and index, these are the offsets to the + * parens around the index. Otherwise they + * are -1. */ register CONST char *p; CONST char *errMsg = NULL; int index; #define VAR_NAME_BUF_SIZE 26 char buffer[VAR_NAME_BUF_SIZE]; @@ -223,15 +220,15 @@ openParen = closeParen = -1; /* * Parse part1 into array name and index. * Always check if part1 is an array element name and allow it only if - * part2 is not given. - * (if one does not care about creating array elements that can't be used - * from tcl, and prefer slightly better performance, one can put - * the following in an if (part2 == NULL) { ... } block and remove - * the part2's test and error reporting or move that code in array set) + * part2 is not given. (If one does not care about creating array elements + * that can't be used from tcl, and prefer slightly better performance, + * one can put the following in an if (part2 == NULL) { ... } block and + * remove the part2's test and error reporting or move that code in array + * set.) */ elName = part2; for (p = part1; *p ; p++) { if (*p == '(') { @@ -263,12 +260,12 @@ newVarName[closeParen] = '\0'; part1 = newVarName; elName = newVarName + openParen + 1; } - varPtr = TclLookupSimpleVar(interp, part1, flags, - createPart1, &errMsg, &index); + varPtr = TclLookupSimpleVar(interp, part1, flags, createPart1, + &errMsg, &index); if (varPtr == NULL) { if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) { TclVarErrMsg(interp, part1, elName, msg, errMsg); } } else { @@ -275,87 +272,86 @@ while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } if (elName != NULL) { *arrayPtrPtr = varPtr; - varPtr = TclLookupArrayElement(interp, part1, elName, flags, + varPtr = TclLookupArrayElement(interp, part1, elName, flags, msg, createPart1, createPart2, varPtr); } } if (newVarName != buffer) { ckfree(newVarName); } return varPtr; - #undef VAR_NAME_BUF_SIZE } /* *---------------------------------------------------------------------- * * TclObjLookupVar -- * - * This procedure is used by virtually all of the variable code to - * locate a variable given its name(s). The parsing into array/element - * components and (if possible) the lookup results are cached in - * part1Ptr, which is converted to one of the varNameTypes. + * This procedure is used by virtually all of the variable code to locate + * a variable given its name(s). The parsing into array/element + * components and (if possible) the lookup results are cached in + * part1Ptr, which is converted to one of the varNameTypes. * * Results: * The return value is a pointer to the variable structure indicated by - * part1Ptr and part2, or NULL if the variable couldn't be found. If - * the variable is found, *arrayPtrPtr is filled with the address of the + * part1Ptr and part2, or NULL if the variable couldn't be found. If * + * the variable is found, *arrayPtrPtr is filled with the address of the * variable structure for the array that contains the variable (or NULL * if the variable is a scalar). If the variable can't be found and * either createPart1 or createPart2 are 1, a new as-yet-undefined * (VAR_UNDEFINED) variable structure is created, entered into a hash * table, and returned. * * If the variable isn't found and creation wasn't specified, or some * other error occurs, NULL is returned and an error message is left in - * the interp's result if TCL_LEAVE_ERR_MSG is set in flags. - * - * Note: it's possible for the variable returned to be VAR_UNDEFINED - * even if createPart1 or createPart2 are 1 (these only cause the hash - * table entry or array to be created). For example, the variable might - * be a global that has been unset but is still referenced by a - * procedure, or a variable that has been unset but it only being kept - * in existence (if VAR_UNDEFINED) by a trace. + * the interp's result if TCL_LEAVE_ERR_MSG is set in flags. + * + * Note: it's possible for the variable returned to be VAR_UNDEFINED even + * if createPart1 or createPart2 are 1 (these only cause the hash table + * entry or array to be created). For example, the variable might be a + * global that has been unset but is still referenced by a procedure, or + * a variable that has been unset but it only being kept in existence (if + * VAR_UNDEFINED) by a trace. * * Side effects: * New hashtable entries may be created if createPart1 or createPart2 - * are 1. - * The object part1Ptr is converted to one of tclLocalVarNameType, - * tclNsVarNameType or tclParsedVarNameType and caches as much of the - * lookup as it can. + * are 1. The object part1Ptr is converted to one of localVarNameType, + * tclNsVarNameType or tclParsedVarNameType and caches as much of the + * lookup as it can. * *---------------------------------------------------------------------- */ + Var * TclObjLookupVar(interp, part1Ptr, part2, flags, msg, createPart1, createPart2, - arrayPtrPtr) + arrayPtrPtr) Tcl_Interp *interp; /* Interpreter to use for lookup. */ - register Tcl_Obj *part1Ptr; /* If part2 isn't NULL, this is the name - * of an array. Otherwise, this is a full - * variable name that could include a parenthesized + register Tcl_Obj *part1Ptr; /* If part2 isn't NULL, this is the name of an + * array. Otherwise, this is a full variable + * name that could include a parenthesized * array element. */ CONST char *part2; /* Name of element within array, or NULL. */ - int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, + int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * and TCL_LEAVE_ERR_MSG bits matter. */ - CONST char *msg; /* Verb to use in error messages, e.g. - * "read" or "set". Only needed if - * TCL_LEAVE_ERR_MSG is set in flags. */ - CONST int createPart1; /* If 1, create hash table entry for part 1 - * of name, if it doesn't already exist. If - * 0, return error if it doesn't exist. */ - CONST int createPart2; /* If 1, create hash table entry for part 2 - * of name, if it doesn't already exist. If - * 0, return error if it doesn't exist. */ + CONST char *msg; /* Verb to use in error messages, e.g. "read" + * or "set". Only needed if TCL_LEAVE_ERR_MSG + * is set in flags. */ + CONST int createPart1; /* If 1, create hash table entry for part 1 of + * name, if it doesn't already exist. If 0, + * return error if it doesn't exist. */ + CONST int createPart2; /* If 1, create hash table entry for part 2 of + * name, if it doesn't already exist. If 0, + * return error if it doesn't exist. */ Var **arrayPtrPtr; /* If the name refers to an element of an * array, *arrayPtrPtr gets filled in with - * address of array variable. Otherwise - * this is set to NULL. */ + * address of array variable. Otherwise this + * is set to NULL. */ { Interp *iPtr = (Interp *) interp; register Var *varPtr; /* Points to the variable's in-frame Var * structure. */ char *part1; @@ -366,21 +362,21 @@ CONST char *errMsg = NULL; CallFrame *varFramePtr = iPtr->varFramePtr; Namespace *nsPtr; /* - * If part1Ptr is a tclParsedVarNameType, separate it into the - * pre-parsed parts. + * If part1Ptr is a tclParsedVarNameType, separate it into the pre-parsed + * parts. */ *arrayPtrPtr = NULL; if (typePtr == &tclParsedVarNameType) { if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) { if (part2 != NULL) { /* - * ERROR: part1Ptr is already an array element, cannot - * specify a part2. + * ERROR: part1Ptr is already an array element, cannot specify + * a part2. */ if (flags & TCL_LEAVE_ERR_MSG) { part1 = TclGetString(part1Ptr); TclVarErrMsg(interp, part1, part2, msg, needArray); @@ -391,92 +387,98 @@ part1Ptr = (Tcl_Obj *) part1Ptr->internalRep.twoPtrValue.ptr1; typePtr = part1Ptr->typePtr; } parsed = 1; } - part1 = Tcl_GetStringFromObj(part1Ptr, &len1); + part1 = Tcl_GetStringFromObj(part1Ptr, &len1); nsPtr = ((varFramePtr == NULL)? iPtr->globalNsPtr : varFramePtr->nsPtr); if (nsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) { goto doParse; } - - if (typePtr == &tclLocalVarNameType) { + + if (typePtr == &localVarNameType) { int localIndex = (int) part1Ptr->internalRep.longValue; - if ((varFramePtr != NULL) && varFramePtr->isProcCallFrame - && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) + if ((varFramePtr != NULL) + && (varFramePtr->isProcCallFrame & FRAME_IS_PROC) + && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) && (localIndex < varFramePtr->numCompiledLocals)) { /* * use the cached index if the names coincide. */ - + varPtr = &(varFramePtr->compiledLocals[localIndex]); - if ((varPtr->name != NULL) - && (strcmp(part1, varPtr->name) == 0)) { + if ((varPtr->name != NULL) && (strcmp(part1, varPtr->name) == 0)) { goto donePart1; } } goto doneParsing; #if ENABLE_NS_VARNAME_CACHING } else if (typePtr == &tclNsVarNameType) { - Namespace *cachedNsPtr; int useGlobal, useReference; - + Namespace *cachedNsPtr = (Namespace *) + part1Ptr->internalRep.twoPtrValue.ptr1; varPtr = (Var *) part1Ptr->internalRep.twoPtrValue.ptr2; - cachedNsPtr = (Namespace *) part1Ptr->internalRep.twoPtrValue.ptr1; - useGlobal = (cachedNsPtr == iPtr->globalNsPtr) - && ((flags & TCL_GLOBAL_ONLY) - || ((*part1 == ':') && (*(part1+1) == ':')) - || (varFramePtr == NULL) - || (!varFramePtr->isProcCallFrame - && (nsPtr == iPtr->globalNsPtr))); - useReference = useGlobal || ((cachedNsPtr == nsPtr) - && ((flags & TCL_NAMESPACE_ONLY) - || (varFramePtr && !varFramePtr->isProcCallFrame - && !(flags & TCL_GLOBAL_ONLY) - /* careful: an undefined ns variable could - * be hiding a valid global reference. */ - && !TclIsVarUndefined(varPtr)))); + + useGlobal = (cachedNsPtr == iPtr->globalNsPtr) && ( + (flags & TCL_GLOBAL_ONLY) || + (*part1==':' && *(part1+1)==':') || + (varFramePtr == NULL) || + (!(varFramePtr->isProcCallFrame & FRAME_IS_PROC) + && (nsPtr == iPtr->globalNsPtr))); + + useReference = useGlobal || ((cachedNsPtr == nsPtr) && ( + (flags & TCL_NAMESPACE_ONLY) || + (varFramePtr && + !(varFramePtr->isProcCallFrame & FRAME_IS_PROC) && + !(flags & TCL_GLOBAL_ONLY) && + /* Careful: an undefined ns variable could be hiding a valid + * global reference. */ + !TclIsVarUndefined(varPtr)))); + if (useReference && (varPtr->hPtr != NULL)) { /* - * A straight global or namespace reference, use it. It isn't - * so simple to deal with 'implicit' namespace references, i.e., - * those where the reference could be to either a namespace - * or a global variable. Those we lookup again. + * A straight global or namespace reference, use it. It isn't so + * simple to deal with 'implicit' namespace references, i.e., + * those where the reference could be to either a namespace or a + * global variable. Those we lookup again. * * If (varPtr->hPtr == NULL), this might be a reference to a * variable in a deleted namespace, kept alive by e.g. part1Ptr. * We could conceivably be so unlucky that a new namespace was - * created at the same address as the deleted one, so to be - * safe we test for a valid hPtr. + * created at the same address as the deleted one, so to be safe + * we test for a valid hPtr. */ + goto donePart1; } goto doneParsing; #endif } - doParse: + doParse: if (!parsed && (*(part1 + len1 - 1) == ')')) { /* * part1Ptr is possibly an unparsed array element. */ + register int i; char *newPart2; + len2 = -1; for (i = 0; i < len1; i++) { if (*(part1 + i) == '(') { if (part2 != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { TclVarErrMsg(interp, part1, part2, msg, needArray); } - } + } /* - * part1Ptr points to an array element; first copy - * the element name to a new string part2. + * part1Ptr points to an array element; first copy the element + * name to a new string part2. */ part2 = part1 + i + 1; len2 = len1 - i - 2; len1 = i; @@ -485,49 +487,49 @@ memcpy(newPart2, part2, (unsigned int) len2); *(newPart2+len2) = '\0'; part2 = newPart2; /* - * Free the internal rep of the original part1Ptr, now - * renamed objPtr, and set it to tclParsedVarNameType. + * Free the internal rep of the original part1Ptr, now renamed + * objPtr, and set it to tclParsedVarNameType. */ objPtr = part1Ptr; TclFreeIntRep(objPtr); objPtr->typePtr = &tclParsedVarNameType; /* - * Define a new string object to hold the new part1Ptr, i.e., + * Define a new string object to hold the new part1Ptr, i.e., * the array name. Set the internal rep of objPtr, reset - * typePtr and part1 to contain the references to the - * array name. + * typePtr and part1 to contain the references to the array + * name. */ - part1Ptr = Tcl_NewStringObj(part1, len1); + TclNewStringObj(part1Ptr, part1, len1); Tcl_IncrRefCount(part1Ptr); objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) part1Ptr; - objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) part2; + objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) part2; typePtr = part1Ptr->typePtr; part1 = TclGetString(part1Ptr); break; } } } - - doneParsing: + + doneParsing: /* - * part1Ptr is not an array element; look it up, and convert - * it to one of the cached types if possible. + * part1Ptr is not an array element; look it up, and convert it to one of + * the cached types if possible. */ TclFreeIntRep(part1Ptr); part1Ptr->typePtr = NULL; - varPtr = TclLookupSimpleVar(interp, part1, flags, - createPart1, &errMsg, &index); + varPtr = TclLookupSimpleVar(interp, part1, flags, createPart1, + &errMsg, &index); if (varPtr == NULL) { if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) { TclVarErrMsg(interp, part1, part2, msg, errMsg); } return NULL; @@ -536,23 +538,24 @@ /* * Cache the newly found variable if possible. */ if (index >= 0) { - /* + /* * An indexed local variable. */ - part1Ptr->typePtr = &tclLocalVarNameType; + part1Ptr->typePtr = &localVarNameType; part1Ptr->internalRep.longValue = (long) index; #if ENABLE_NS_VARNAME_CACHING } else if (index > -3) { /* * A cacheable namespace or global variable. */ + Namespace *nsPtr; - + nsPtr = ((index == -1)? iPtr->globalNsPtr : varFramePtr->nsPtr); varPtr->refCount++; part1Ptr->typePtr = &tclNsVarNameType; part1Ptr->internalRep.twoPtrValue.ptr1 = (VOID *) nsPtr; part1Ptr->internalRep.twoPtrValue.ptr2 = (VOID *) varPtr; @@ -559,21 +562,22 @@ #endif } else { /* * At least mark part1Ptr as already parsed. */ + part1Ptr->typePtr = &tclParsedVarNameType; part1Ptr->internalRep.twoPtrValue.ptr1 = NULL; part1Ptr->internalRep.twoPtrValue.ptr2 = NULL; } - - donePart1: + + donePart1: #if 0 if (varPtr == NULL) { if (flags & TCL_LEAVE_ERR_MSG) { part1 = TclGetString(part1Ptr); - TclVarErrMsg(interp, part1, part2, msg, + TclVarErrMsg(interp, part1, part2, msg, "Cached variable reference is NULL."); } return NULL; } #endif @@ -586,23 +590,23 @@ * Array element sought: look it up. */ part1 = TclGetString(part1Ptr); *arrayPtrPtr = varPtr; - varPtr = TclLookupArrayElement(interp, part1, part2, - flags, msg, createPart1, createPart2, varPtr); + varPtr = TclLookupArrayElement(interp, part1, part2, flags, msg, + createPart1, createPart2, varPtr); } return varPtr; } /* * This flag bit should not interfere with TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, - * or TCL_LEAVE_ERR_MSG; it signals that the variable lookup is performed for + * or TCL_LEAVE_ERR_MSG; it signals that the variable lookup is performed for * upvar (or similar) purposes, with slightly different rules: - * - Bug #696893 - variable is either proc-local or in the current - * namespace; never follow the second (global) resolution path - * - Bug #631741 - do not use special namespace or interp resolvers + * - Bug #696893 - variable is either proc-local or in the current + * namespace; never follow the second (global) resolution path + * - Bug #631741 - do not use special namespace or interp resolvers * * It should also not collide with the (deprecated) TCL_PARSE_PART1 flag * (Bug #835020) */ @@ -611,39 +615,40 @@ /* *---------------------------------------------------------------------- * * TclLookupSimpleVar -- * - * This procedure is used by to locate a simple variable (i.e., not - * an array element) given its name. + * This procedure is used by to locate a simple variable (i.e., not an + * array element) given its name. * * Results: * The return value is a pointer to the variable structure indicated by - * varName, or NULL if the variable couldn't be found. If the variable - * can't be found and create is 1, a new as-yet-undefined (VAR_UNDEFINED) - * variable structure is created, entered into a hash table, and returned. - * - * If the current CallFrame corresponds to a proc and the variable found is - * one of the compiledLocals, its index is placed in *indexPtr. Otherwise, - * *indexPtr will be set to (according to the needs of TclObjLookupVar): - * -1 a global reference - * -2 a reference to a namespace variable - * -3 a non-cachable reference, i.e., one of: - * . non-indexed local var - * . a reference of unknown origin; - * . resolution by a namespace or interp resolver + * varName, or NULL if the variable couldn't be found. If the variable + * can't be found and create is 1, a new as-yet-undefined (VAR_UNDEFINED) + * variable structure is created, entered into a hash table, and + * returned. + * + * If the current CallFrame corresponds to a proc and the variable found + * is one of the compiledLocals, its index is placed in *indexPtr. + * Otherwise, *indexPtr will be set to (according to the needs of + * TclObjLookupVar): + * -1 a global reference + * -2 a reference to a namespace variable + * -3 a non-cachable reference, i.e., one of: + * . non-indexed local var + * . a reference of unknown origin; + * . resolution by a namespace or interp resolver * * If the variable isn't found and creation wasn't specified, or some * other error occurs, NULL is returned and the corresponding error - * message is left in *errMsgPtr. - * - * Note: it's possible for the variable returned to be VAR_UNDEFINED - * even if create is 1 (this only causes the hash table entry to be - * created). For example, the variable might be a global that has been - * unset but is still referenced by a procedure, or a variable that has - * been unset but it only being kept in existence (if VAR_UNDEFINED) by - * a trace. + * message is left in *errMsgPtr. + * + * Note: it's possible for the variable returned to be VAR_UNDEFINED even + * if create is 1 (this only causes the hash table entry to be created). + * For example, the variable might be a global that has been unset but is + * still referenced by a procedure, or a variable that has been unset but + * it only being kept in existence (if VAR_UNDEFINED) by a trace. * * Side effects: * A new hashtable entry may be created if create is 1. * *---------------------------------------------------------------------- @@ -650,30 +655,30 @@ */ Var * TclLookupSimpleVar(interp, varName, flags, create, errMsgPtr, indexPtr) Tcl_Interp *interp; /* Interpreter to use for lookup. */ - CONST char *varName; /* This is a simple variable name that could - * representa scalar or an array. */ - int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, - * LOOKUP_FOR_UPVAR and TCL_LEAVE_ERR_MSG bits + CONST char *varName; /* This is a simple variable name that could + * represent a scalar or an array. */ + int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, + * LOOKUP_FOR_UPVAR and TCL_LEAVE_ERR_MSG bits * matter. */ CONST int create; /* If 1, create hash table entry for varname, - * if it doesn't already exist. If 0, return + * if it doesn't already exist. If 0, return * error if it doesn't exist. */ CONST char **errMsgPtr; int *indexPtr; -{ +{ Interp *iPtr = (Interp *) interp; CallFrame *varFramePtr = iPtr->varFramePtr; /* Points to the procedure call frame whose - * variables are currently in use. Same as - * the current procedure's frame, if any, - * unless an "uplevel" is executing. */ + * variables are currently in use. Same as the + * current procedure's frame, if any, unless + * an "uplevel" is executing. */ Tcl_HashTable *tablePtr; /* Points to the hashtable, if any, in which * to look up the variable. */ - Tcl_Var var; /* Used to search for global names. */ + Tcl_Var var; /* Used to search for global names. */ Var *varPtr; /* Points to the Var structure returned for * the variable. */ Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr; ResolverScheme *resPtr; Tcl_HashEntry *hPtr; @@ -682,102 +687,100 @@ varPtr = NULL; varNsPtr = NULL; /* set non-NULL if a nonlocal variable */ *indexPtr = -3; if ((flags & TCL_GLOBAL_ONLY) || iPtr->varFramePtr == NULL) { - cxtNsPtr = iPtr->globalNsPtr; - } else { - cxtNsPtr = iPtr->varFramePtr->nsPtr; - } - - /* - * If this namespace has a variable resolver, then give it first - * crack at the variable resolution. It may return a Tcl_Var - * value, it may signal to continue onward, or it may signal - * an error. - */ - - if ((cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) - && !(flags & LOOKUP_FOR_UPVAR)) { - resPtr = iPtr->resolverPtr; - - if (cxtNsPtr->varResProc) { - result = (*cxtNsPtr->varResProc)(interp, varName, - (Tcl_Namespace *) cxtNsPtr, flags, &var); - } else { - result = TCL_CONTINUE; - } - - while (result == TCL_CONTINUE && resPtr) { - if (resPtr->varResProc) { - result = (*resPtr->varResProc)(interp, varName, - (Tcl_Namespace *) cxtNsPtr, flags, &var); - } - resPtr = resPtr->nextPtr; - } - - if (result == TCL_OK) { - varPtr = (Var *) var; - return varPtr; - } else if (result != TCL_CONTINUE) { - return NULL; - } + cxtNsPtr = iPtr->globalNsPtr; + } else { + cxtNsPtr = iPtr->varFramePtr->nsPtr; + } + + /* + * If this namespace has a variable resolver, then give it first crack at + * the variable resolution. It may return a Tcl_Var value, it may signal + * to continue onward, or it may signal an error. + */ + + if ((cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) + && !(flags & LOOKUP_FOR_UPVAR)) { + resPtr = iPtr->resolverPtr; + if (cxtNsPtr->varResProc) { + result = (*cxtNsPtr->varResProc)(interp, varName, + (Tcl_Namespace *) cxtNsPtr, flags, &var); + } else { + result = TCL_CONTINUE; + } + + while (result == TCL_CONTINUE && resPtr) { + if (resPtr->varResProc) { + result = (*resPtr->varResProc)(interp, varName, + (Tcl_Namespace *) cxtNsPtr, flags, &var); + } + resPtr = resPtr->nextPtr; + } + + if (result == TCL_OK) { + return (Var *) var; + } else if (result != TCL_CONTINUE) { + return NULL; + } } /* * Look up varName. Look it up as either a namespace variable or as a - * local variable in a procedure call frame (varFramePtr). - * Interpret varName as a namespace variable if: + * local variable in a procedure call frame (varFramePtr). Interpret + * varName as a namespace variable if: * 1) so requested by a TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY flag, * 2) there is no active frame (we're at the global :: scope), - * 3) the active frame was pushed to define the namespace context - * for a "namespace eval" or "namespace inscope" command, + * 3) the active frame was pushed to define the namespace context for a + * "namespace eval" or "namespace inscope" command, * 4) the name has namespace qualifiers ("::"s). - * Otherwise, if varName is a local variable, search first in the - * frame's array of compiler-allocated local variables, then in its - * hashtable for runtime-created local variables. + * Otherwise, if varName is a local variable, search first in the frame's + * array of compiler-allocated local variables, then in its hashtable for + * runtime-created local variables. * - * If create and the variable isn't found, create the variable and, - * if necessary, create varFramePtr's local var hashtable. + * If create and the variable isn't found, create the variable and, if + * necessary, create varFramePtr's local var hashtable. */ if (((flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) != 0) || (varFramePtr == NULL) - || !varFramePtr->isProcCallFrame + || !(varFramePtr->isProcCallFrame & FRAME_IS_PROC) || (strstr(varName, "::") != NULL)) { CONST char *tail; int lookGlobal; - - lookGlobal = (flags & TCL_GLOBAL_ONLY) - || (cxtNsPtr == iPtr->globalNsPtr) - || ((*varName == ':') && (*(varName+1) == ':')); + + lookGlobal = (flags & TCL_GLOBAL_ONLY) + || (cxtNsPtr == iPtr->globalNsPtr) + || ((*varName == ':') && (*(varName+1) == ':')); if (lookGlobal) { *indexPtr = -1; - flags = (flags | TCL_GLOBAL_ONLY) & ~(TCL_NAMESPACE_ONLY|LOOKUP_FOR_UPVAR); + flags = (flags | TCL_GLOBAL_ONLY) & + ~(TCL_NAMESPACE_ONLY | LOOKUP_FOR_UPVAR); } else { if (flags & LOOKUP_FOR_UPVAR) { flags = (flags | TCL_NAMESPACE_ONLY) & ~LOOKUP_FOR_UPVAR; } if (flags & TCL_NAMESPACE_ONLY) { *indexPtr = -2; } - } + } - /* - * Don't pass TCL_LEAVE_ERR_MSG, we may yet create the variable, - * or otherwise generate our own error! + /* + * Don't pass TCL_LEAVE_ERR_MSG, we may yet create the variable, or + * otherwise generate our own error! */ var = Tcl_FindNamespaceVar(interp, varName, (Tcl_Namespace *) cxtNsPtr, flags & ~TCL_LEAVE_ERR_MSG); if (var != (Tcl_Var) NULL) { - varPtr = (Var *) var; - } + varPtr = (Var *) var; + } if (varPtr == NULL) { - if (create) { /* var wasn't found so create it */ + if (create) { /* var wasn't found so create it */ TclGetNamespaceForQualName(interp, varName, cxtNsPtr, flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail); if (varNsPtr == NULL) { *errMsgPtr = badNamespace; return NULL; @@ -792,13 +795,14 @@ varPtr->hPtr = hPtr; varPtr->nsPtr = varNsPtr; if (lookGlobal) { /* * The variable was created starting from the global - * namespace: a global reference is returned even if - * it wasn't explicitly requested. + * namespace: a global reference is returned even if it + * wasn't explicitly requested. */ + *indexPtr = -1; } else { *indexPtr = -2; } } else { /* var wasn't found and not to create it */ @@ -810,17 +814,17 @@ Proc *procPtr = varFramePtr->procPtr; int localCt = procPtr->numCompiledLocals; CompiledLocal *localPtr = procPtr->firstLocalPtr; Var *localVarPtr = varFramePtr->compiledLocals; int varNameLen = strlen(varName); - + for (i = 0; i < localCt; i++) { if (!TclIsVarTemporary(localPtr)) { register char *localName = localVarPtr->name; if ((varName[0] == localName[0]) - && (varNameLen == localPtr->nameLength) - && (strcmp(varName, localName) == 0)) { + && (varNameLen == localPtr->nameLength) + && (strcmp(varName, localName) == 0)) { *indexPtr = i; return localVarPtr; } } localVarPtr++; @@ -837,11 +841,11 @@ hPtr = Tcl_CreateHashEntry(tablePtr, varName, &new); if (new) { varPtr = NewVar(); Tcl_SetHashValue(hPtr, varPtr); varPtr->hPtr = hPtr; - varPtr->nsPtr = NULL; /* a local variable */ + varPtr->nsPtr = NULL; /* a local variable */ } else { varPtr = (Var *) Tcl_GetHashValue(hPtr); } } else { hPtr = NULL; @@ -861,67 +865,67 @@ /* *---------------------------------------------------------------------- * * TclLookupArrayElement -- * - * This procedure is used to locate a variable which is in an array's - * hashtable given a pointer to the array's Var structure and the - * element's name. - * - * Results: - * The return value is a pointer to the variable structure , or NULL if - * the variable couldn't be found. - * - * If arrayPtr points to a variable that isn't an array and createPart1 - * is 1, the corresponding variable will be converted to an array. - * Otherwise, NULL is returned and an error message is left in - * the interp's result if TCL_LEAVE_ERR_MSG is set in flags. - * - * If the variable is not found and createPart2 is 1, the variable is - * created. Otherwise, NULL is returned and an error message is left in - * the interp's result if TCL_LEAVE_ERR_MSG is set in flags. - * - * Note: it's possible for the variable returned to be VAR_UNDEFINED - * even if createPart1 or createPart2 are 1 (these only cause the hash - * table entry or array to be created). For example, the variable might - * be a global that has been unset but is still referenced by a - * procedure, or a variable that has been unset but it only being kept - * in existence (if VAR_UNDEFINED) by a trace. - * - * Side effects: - * The variable at arrayPtr may be converted to be an array if - * createPart1 is 1. A new hashtable entry may be created if createPart2 - * is 1. + * This procedure is used to locate a variable which is in an array's + * hashtable given a pointer to the array's Var structure and the + * element's name. + * + * Results: + * The return value is a pointer to the variable structure , or NULL if + * the variable couldn't be found. + * + * If arrayPtr points to a variable that isn't an array and createPart1 + * is 1, the corresponding variable will be converted to an array. + * Otherwise, NULL is returned and an error message is left in the + * interp's result if TCL_LEAVE_ERR_MSG is set in flags. + * + * If the variable is not found and createPart2 is 1, the variable is + * created. Otherwise, NULL is returned and an error message is left in + * the interp's result if TCL_LEAVE_ERR_MSG is set in flags. + * + * Note: it's possible for the variable returned to be VAR_UNDEFINED even + * if createPart1 or createPart2 are 1 (these only cause the hash table + * entry or array to be created). For example, the variable might be a + * global that has been unset but is still referenced by a procedure, or + * a variable that has been unset but it only being kept in existence (if + * VAR_UNDEFINED) by a trace. + * + * Side effects: + * The variable at arrayPtr may be converted to be an array if + * createPart1 is 1. A new hashtable entry may be created if createPart2 + * is 1. * *---------------------------------------------------------------------- */ Var * TclLookupArrayElement(interp, arrayName, elName, flags, msg, createArray, createElem, arrayPtr) Tcl_Interp *interp; /* Interpreter to use for lookup. */ - CONST char *arrayName; /* This is the name of the array. */ + CONST char *arrayName; /* This is the name of the array. */ CONST char *elName; /* Name of element within array. */ CONST int flags; /* Only TCL_LEAVE_ERR_MSG bit matters. */ - CONST char *msg; /* Verb to use in error messages, e.g. - * "read" or "set". Only needed if - * TCL_LEAVE_ERR_MSG is set in flags. */ - CONST int createArray; /* If 1, transform arrayName to be an array - * if it isn't one yet and the transformation - * is possible. If 0, return error if it - * isn't already an array. */ - CONST int createElem; /* If 1, create hash table entry for the - * element, if it doesn't already exist. If - * 0, return error if it doesn't exist. */ - Var *arrayPtr; /* Pointer to the array's Var structure. */ + CONST char *msg; /* Verb to use in error messages, e.g. "read" + * or "set". Only needed if TCL_LEAVE_ERR_MSG + * is set in flags. */ + CONST int createArray; /* If 1, transform arrayName to be an array if + * it isn't one yet and the transformation is + * possible. If 0, return error if it isn't + * already an array. */ + CONST int createElem; /* If 1, create hash table entry for the + * element, if it doesn't already exist. If 0, + * return error if it doesn't exist. */ + Var *arrayPtr; /* Pointer to the array's Var structure. */ { Tcl_HashEntry *hPtr; int new; Var *varPtr; /* - * We're dealing with an array element. Make sure the variable is an - * array and look up the element (create the element if desired). + * We're dealing with an array element. Make sure the variable is an array + * and look up the element (create the element if desired). */ if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) { if (!createArray) { if (flags & TCL_LEAVE_ERR_MSG) { @@ -932,21 +936,22 @@ /* * Make sure we are not resurrecting a namespace variable from a * deleted namespace! */ + if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) { if (flags & TCL_LEAVE_ERR_MSG) { TclVarErrMsg(interp, arrayName, elName, msg, danglingVar); } return NULL; } TclSetVarArray(arrayPtr); TclClearVarUndefined(arrayPtr); - arrayPtr->value.tablePtr = - (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + arrayPtr->value.tablePtr = (Tcl_HashTable *) + ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS); } else if (!TclIsVarArray(arrayPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { TclVarErrMsg(interp, arrayName, elName, msg, needArray); } @@ -984,13 +989,13 @@ * * Return the value of a Tcl variable as a string. * * Results: * The return value points to the current value of varName as a string. - * If the variable is not defined or can't be read because of a clash - * in array usage then a NULL pointer is returned and an error message - * is left in the interp's result if the TCL_LEAVE_ERR_MSG flag is set. + * If the variable is not defined or can't be read because of a clash in + * array usage then a NULL pointer is returned and an error message is + * left in the interp's result if the TCL_LEAVE_ERR_MSG flag is set. * Note: the return value is only valid up until the next change to the * variable; if you depend on the value lasting longer than that, then * make yourself a private copy. * * Side effects: @@ -999,12 +1004,12 @@ *---------------------------------------------------------------------- */ CONST char * Tcl_GetVar(interp, varName, flags) - Tcl_Interp *interp; /* Command interpreter in which varName is - * to be looked up. */ + Tcl_Interp *interp; /* Command interpreter in which varName is to + * be looked up. */ CONST char *varName; /* Name of a variable in interp. */ int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG * bits. */ { @@ -1014,39 +1019,39 @@ /* *---------------------------------------------------------------------- * * Tcl_GetVar2 -- * - * Return the value of a Tcl variable as a string, given a two-part - * name consisting of array name and element within array. + * Return the value of a Tcl variable as a string, given a two-part name + * consisting of array name and element within array. * * Results: - * The return value points to the current value of the variable given - * by part1 and part2 as a string. If the specified variable doesn't - * exist, or if there is a clash in array usage, then NULL is returned - * and a message will be left in the interp's result if the - * TCL_LEAVE_ERR_MSG flag is set. Note: the return value is only valid - * up until the next change to the variable; if you depend on the value - * lasting longer than that, then make yourself a private copy. + * The return value points to the current value of the variable given by + * part1 and part2 as a string. If the specified variable doesn't exist, + * or if there is a clash in array usage, then NULL is returned and a + * message will be left in the interp's result if the TCL_LEAVE_ERR_MSG + * flag is set. Note: the return value is only valid up until the next + * change to the variable; if you depend on the value lasting longer than + * that, then make yourself a private copy. * * Side effects: * None. * *---------------------------------------------------------------------- */ CONST char * Tcl_GetVar2(interp, part1, part2, flags) - Tcl_Interp *interp; /* Command interpreter in which variable is - * to be looked up. */ - CONST char *part1; /* Name of an array (if part2 is non-NULL) - * or the name of a variable. */ + Tcl_Interp *interp; /* Command interpreter in which variable is to + * be looked up. */ + CONST char *part1; /* Name of an array (if part2 is non-NULL) or + * the name of a variable. */ CONST char *part2; /* If non-NULL, gives the name of an element * in the array part1. */ int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG - * bits. */ + * TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG * + * bits. */ { Tcl_Obj *objPtr; objPtr = Tcl_GetVar2Ex(interp, part1, part2, flags); if (objPtr == NULL) { @@ -1058,48 +1063,49 @@ /* *---------------------------------------------------------------------- * * Tcl_GetVar2Ex -- * - * Return the value of a Tcl variable as a Tcl object, given a - * two-part name consisting of array name and element within array. + * Return the value of a Tcl variable as a Tcl object, given a two-part + * name consisting of array name and element within array. * * Results: * The return value points to the current object value of the variable * given by part1Ptr and part2Ptr. If the specified variable doesn't * exist, or if there is a clash in array usage, then NULL is returned * and a message will be left in the interpreter's result if the * TCL_LEAVE_ERR_MSG flag is set. * * Side effects: - * 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. + * 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 * Tcl_GetVar2Ex(interp, part1, part2, flags) - Tcl_Interp *interp; /* Command interpreter in which variable is - * to be looked up. */ - CONST char *part1; /* Name of an array (if part2 is non-NULL) - * or the name of a variable. */ + Tcl_Interp *interp; /* Command interpreter in which variable is to + * be looked up. */ + CONST char *part1; /* Name of an array (if part2 is non-NULL) or + * the name of a variable. */ CONST char *part2; /* If non-NULL, gives the name of an element * in the array part1. */ - int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, - * and TCL_LEAVE_ERR_MSG bits. */ + int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, and + * TCL_LEAVE_ERR_MSG bits. */ { Var *varPtr, *arrayPtr; /* * We need a special flag check to see if we want to create part 1, * because commands like lappend require read traces to trigger for * previously non-existent values. */ + varPtr = TclLookupVar(interp, part1, part2, flags, "read", - /*createPart1*/ (flags & TCL_TRACE_READS), + /*createPart1*/ (flags & TCL_TRACE_READS), /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return NULL; } @@ -1109,35 +1115,35 @@ /* *---------------------------------------------------------------------- * * Tcl_ObjGetVar2 -- * - * Return the value of a Tcl variable as a Tcl object, given a - * two-part name consisting of array name and element within array. + * Return the value of a Tcl variable as a Tcl object, given a two-part + * name consisting of array name and element within array. * * Results: * The return value points to the current object value of the variable * given by part1Ptr and part2Ptr. If the specified variable doesn't * exist, or if there is a clash in array usage, then NULL is returned * and a message will be left in the interpreter's result if the * TCL_LEAVE_ERR_MSG flag is set. * * Side effects: - * 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. + * 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 * Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags) - Tcl_Interp *interp; /* Command interpreter in which variable is - * to be looked up. */ - register 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_Interp *interp; /* Command interpreter in which variable is to + * be looked up. */ + register Tcl_Obj *part1Ptr; /* Points to an object holding the name of an + * array (if part2 is non-NULL) or the name of + * a variable. */ register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding * the name of an element in the array * part1Ptr. */ int flags; /* OR-ed combination of TCL_GLOBAL_ONLY and * TCL_LEAVE_ERR_MSG bits. */ @@ -1145,18 +1151,19 @@ Var *varPtr, *arrayPtr; char *part1, *part2; part1 = TclGetString(part1Ptr); part2 = ((part2Ptr == NULL) ? NULL : TclGetString(part2Ptr)); - + /* * We need a special flag check to see if we want to create part 1, * because commands like lappend require read traces to trigger for * previously non-existent values. */ + varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read", - /*createPart1*/ (flags & TCL_TRACE_READS), + /*createPart1*/ (flags & TCL_TRACE_READS), /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return NULL; } @@ -1166,41 +1173,40 @@ /* *---------------------------------------------------------------------- * * TclPtrGetVar -- * - * Return the value of a Tcl variable as a Tcl object, given the - * pointers to the variable's (and possibly containing array's) - * VAR structure. + * Return the value of a Tcl variable as a Tcl object, given the pointers + * to the variable's (and possibly containing array's) VAR structure. * * Results: * The return value points to the current object value of the variable - * given by varPtr. If the specified variable doesn't exist, or if there - * is a clash in array usage, then NULL is returned and a message will be - * left in the interpreter's result if the TCL_LEAVE_ERR_MSG flag is set. + * given by varPtr. If the specified variable doesn't exist, or if there + * is a clash in array usage, then NULL is returned and a message will be + * left in the interpreter's result if the TCL_LEAVE_ERR_MSG flag is set. * * Side effects: - * 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. + * 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 * TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags) - Tcl_Interp *interp; /* Command interpreter in which variable is - * to be looked up. */ - register Var *varPtr; /* The variable to be read.*/ - Var *arrayPtr; /* NULL for scalar variables, pointer to - * the containing array otherwise. */ - CONST char *part1; /* Name of an array (if part2 is non-NULL) - * or the name of a variable. */ + Tcl_Interp *interp; /* Command interpreter in which variable is to + * be looked up. */ + register Var *varPtr; /* The variable to be read.*/ + Var *arrayPtr; /* NULL for scalar variables, pointer to the + * containing array otherwise. */ + CONST char *part1; /* Name of an array (if part2 is non-NULL) or + * the name of a variable. */ CONST char *part2; /* If non-NULL, gives the name of an element * in the array part1. */ - CONST int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, - * and TCL_LEAVE_ERR_MSG bits. */ + CONST int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, and + * TCL_LEAVE_ERR_MSG bits. */ { Interp *iPtr = (Interp *) interp; CONST char *msg; /* @@ -1217,18 +1223,18 @@ } /* * Return the element if it's an existing scalar variable. */ - + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) { return varPtr->value.objPtr; } - + if (flags & TCL_LEAVE_ERR_MSG) { if (TclIsVarUndefined(varPtr) && (arrayPtr != NULL) - && !TclIsVarUndefined(arrayPtr)) { + && !TclIsVarUndefined(arrayPtr)) { msg = noSuchElement; } else if (TclIsVarArray(varPtr)) { msg = isArray; } else { msg = noSuchVar; @@ -1235,15 +1241,15 @@ } TclVarErrMsg(interp, part1, part2, "read", msg); } /* - * An error. If the variable doesn't exist anymore and no-one's using - * it, then free up the relevant structures and hash table entries. + * An error. If the variable doesn't exist anymore and no-one's using it, + * then free up the relevant structures and hash table entries. */ - errorReturn: + errorReturn: if (TclIsVarUndefined(varPtr)) { TclCleanupVar(varPtr, arrayPtr); } return NULL; } @@ -1251,12 +1257,12 @@ /* *---------------------------------------------------------------------- * * Tcl_SetObjCmd -- * - * This procedure is invoked to process the "set" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "set" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result value. * * Side effects: @@ -1266,14 +1272,14 @@ */ /* ARGSUSED */ int Tcl_SetObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - register Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp;/* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Obj *varValueObj; if (objc == 2) { varValueObj = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); @@ -1281,11 +1287,10 @@ return TCL_ERROR; } Tcl_SetObjResult(interp, varValueObj); return TCL_OK; } else if (objc == 3) { - varValueObj = Tcl_ObjSetVar2(interp, objv[1], NULL, objv[2], TCL_LEAVE_ERR_MSG); if (varValueObj == NULL) { return TCL_ERROR; } @@ -1312,87 +1317,86 @@ * explanatory message will be left in the interp's result. Note that the * returned string may not be the same as newValue; this is because * variable traces may modify the variable's value. * * Side effects: - * If varName is defined as a local or global variable in interp, - * its value is changed to newValue. If varName isn't currently - * defined, then a new global variable by that name is created. + * If varName is defined as a local or global variable in interp, its + * value is changed to newValue. If varName isn't currently defined, then + * a new global variable by that name is created. * *---------------------------------------------------------------------- */ CONST char * Tcl_SetVar(interp, varName, newValue, flags) - Tcl_Interp *interp; /* Command interpreter in which varName is - * to be looked up. */ + Tcl_Interp *interp; /* Command interpreter in which varName is to + * be looked up. */ CONST char *varName; /* Name of a variable in interp. */ CONST char *newValue; /* New value for varName. */ int flags; /* Various flags that tell how to set value: - * any of TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, - * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */ + * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, + * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, + * TCL_LEAVE_ERR_MSG. */ { return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, flags); } /* *---------------------------------------------------------------------- * * Tcl_SetVar2 -- * - * Given a two-part variable name, which may refer either to a - * scalar variable or an element of an array, change the value - * of the variable. If the named scalar or array or element - * doesn't exist then create one. + * Given a two-part variable name, which may refer either to a scalar + * variable or an element of an array, change the value of the variable. + * If the named scalar or array or element doesn't exist then create one. * * Results: * Returns a pointer to the malloc'ed string which is the character - * representation of the variable's new value. The caller must not - * modify this string. If the write operation was disallowed because an - * array was expected but not found (or vice versa), then NULL is - * returned; if the TCL_LEAVE_ERR_MSG flag is set, then an explanatory - * message will be left in the interp's result. Note that the returned - * string may not be the same as newValue; this is because variable - * traces may modify the variable's value. + * representation of the variable's new value. The caller must not modify + * this string. If the write operation was disallowed because an array + * was expected but not found (or vice versa), then NULL is returned; if + * the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will be + * left in the interp's result. Note that the returned string may not be + * the same as newValue; this is because variable traces may modify the + * variable's value. * * Side effects: - * The value of the given variable is set. If either the array - * or the entry didn't exist then a new one is created. + * The value of the given variable is set. If either the array or the + * entry didn't exist then a new one is created. * *---------------------------------------------------------------------- */ CONST char * Tcl_SetVar2(interp, part1, part2, newValue, flags) - Tcl_Interp *interp; /* Command interpreter in which variable is - * to be looked up. */ - CONST char *part1; /* If part2 is NULL, this is name of scalar - * variable. Otherwise it is the name of - * an array. */ + Tcl_Interp *interp; /* Command interpreter in which variable is to + * be looked up. */ + CONST char *part1; /* If part2 is NULL, this is name of scalar + * variable. Otherwise it is the name of an + * array. */ CONST char *part2; /* Name of an element within an array, or * NULL. */ - CONST char *newValue; /* New value for variable. */ - int flags; /* Various flags that tell how to set value: - * any of TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, - * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG */ + CONST char *newValue; /* New value for variable. */ + int flags; /* Various flags that tell how to set value: + * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, + * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, or + * TCL_LEAVE_ERR_MSG */ { register Tcl_Obj *valuePtr; Tcl_Obj *varValuePtr; /* - * Create an object holding the variable's new value and use - * Tcl_SetVar2Ex to actually set the variable. + * Create an object holding the variable's new value and use Tcl_SetVar2Ex + * to actually set the variable. */ valuePtr = Tcl_NewStringObj(newValue, -1); Tcl_IncrRefCount(valuePtr); varValuePtr = Tcl_SetVar2Ex(interp, part1, part2, valuePtr, flags); - Tcl_DecrRefCount(valuePtr); /* done with the object */ - + TclDecrRefCount(valuePtr); /* done with the object */ + if (varValuePtr == NULL) { return NULL; } return TclGetString(varValuePtr); } @@ -1408,76 +1412,76 @@ * doesn't exist then create one. * * Results: * Returns a pointer to the Tcl_Obj holding the new value of the * variable. If the write operation was disallowed because an array was - * expected but not found (or vice versa), then NULL is returned; if - * the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will - * be left in the interpreter's result. Note that the returned object - * may not be the same one referenced by newValuePtr; this is because + * expected but not found (or vice versa), then NULL is returned; if the + * TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will be + * left in the interpreter's result. Note that the returned object may + * not be the same one referenced by newValuePtr; this is because * variable traces may modify the variable's value. * * Side effects: * The value of the given variable is set. If either the array or the * entry didn't exist then a new variable is created. * * The reference count is decremented for any old value of the variable * and incremented for its new value. If the new value for the variable - * is not the same one referenced by newValuePtr (perhaps as a result - * of a variable trace), then newValuePtr's ref count is left unchanged - * by Tcl_SetVar2Ex. newValuePtr's ref count is also left unchanged if - * we are appending it as a string value: that is, if "flags" includes + * is not the same one referenced by newValuePtr (perhaps as a result of + * a variable trace), then newValuePtr's ref count is left unchanged by + * Tcl_SetVar2Ex. newValuePtr's ref count is also left unchanged if we + * are appending it as a string value: that is, if "flags" includes * TCL_APPEND_VALUE but not TCL_LIST_ELEMENT. * * The reference count for the returned object is _not_ incremented: if - * you want to keep a reference to the object you must increment its - * ref count yourself. + * you want to keep a reference to the object you must increment its ref + * count yourself. * *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) - Tcl_Interp *interp; /* Command interpreter in which variable is - * to be found. */ - CONST char *part1; /* Name of an array (if part2 is non-NULL) - * or the name of a variable. */ + Tcl_Interp *interp; /* Command interpreter in which variable is to + * be found. */ + CONST char *part1; /* Name of an array (if part2 is non-NULL) or + * the name of a variable. */ CONST char *part2; /* If non-NULL, gives the name of an element * in the array part1. */ Tcl_Obj *newValuePtr; /* New value for variable. */ int flags; /* Various flags that tell how to set value: - * any of TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, - * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */ + * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, + * TCL_APPEND_VALUE, TCL_LIST_ELEMENT or + * TCL_LEAVE_ERR_MSG. */ { Var *varPtr, *arrayPtr; varPtr = TclLookupVar(interp, part1, part2, flags, "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return NULL; } - return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, - newValuePtr, flags); + return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, + newValuePtr, flags); } /* *---------------------------------------------------------------------- * * Tcl_ObjSetVar2 -- * - * This function is the same as Tcl_SetVar2Ex above, except the - * variable names are passed in Tcl object instead of strings. + * This function is the same as Tcl_SetVar2Ex above, except the variable + * names are passed in Tcl object instead of strings. * * Results: * Returns a pointer to the Tcl_Obj holding the new value of the * variable. If the write operation was disallowed because an array was - * expected but not found (or vice versa), then NULL is returned; if - * the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will - * be left in the interpreter's result. Note that the returned object - * may not be the same one referenced by newValuePtr; this is because + * expected but not found (or vice versa), then NULL is returned; if the + * TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will be + * left in the interpreter's result. Note that the returned object may + * not be the same one referenced by newValuePtr; this is because * variable traces may modify the variable's value. * * Side effects: * The value of the given variable is set. If either the array or the * entry didn't exist then a new variable is created. @@ -1485,56 +1489,56 @@ *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags) - Tcl_Interp *interp; /* Command interpreter in which variable is - * to be found. */ - register 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_Interp *interp; /* Command interpreter in which variable is to + * be found. */ + register Tcl_Obj *part1Ptr; /* Points to an object holding the name of an + * array (if part2 is non-NULL) or the name of + * a variable. */ register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding * the name of an element in the array * part1Ptr. */ Tcl_Obj *newValuePtr; /* New value for variable. */ int flags; /* Various flags that tell how to set value: - * any of TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, - * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG. */ + * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, + * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, or + * TCL_LEAVE_ERR_MSG. */ { Var *varPtr, *arrayPtr; char *part1, *part2; part1 = TclGetString(part1Ptr); - part2 = ((part2Ptr == NULL) ? NULL : TclGetString(part2Ptr)); + part2 = ((part2Ptr == NULL) ? NULL : TclGetString(part2Ptr)); varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return NULL; } - return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, - newValuePtr, flags); + return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, + newValuePtr, flags); } /* *---------------------------------------------------------------------- * * TclPtrSetVar -- * - * This function is the same as Tcl_SetVar2Ex above, except that - * it requires pointers to the variable's Var structs in addition - * to the variable names. + * This function is the same as Tcl_SetVar2Ex above, except that it + * requires pointers to the variable's Var structs in addition to the + * variable names. * * Results: * Returns a pointer to the Tcl_Obj holding the new value of the * variable. If the write operation was disallowed because an array was - * expected but not found (or vice versa), then NULL is returned; if - * the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will - * be left in the interpreter's result. Note that the returned object - * may not be the same one referenced by newValuePtr; this is because + * expected but not found (or vice versa), then NULL is returned; if the + * TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will be + * left in the interpreter's result. Note that the returned object may + * not be the same one referenced by newValuePtr; this is because * variable traces may modify the variable's value. * * Side effects: * The value of the given variable is set. If either the array or the * entry didn't exist then a new variable is created. @@ -1542,33 +1546,33 @@ *---------------------------------------------------------------------- */ Tcl_Obj * TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, newValuePtr, flags) - Tcl_Interp *interp; /* Command interpreter in which variable is - * to be looked up. */ + Tcl_Interp *interp; /* Command interpreter in which variable is to + * be looked up. */ register Var *varPtr; Var *arrayPtr; - CONST char *part1; /* Name of an array (if part2 is non-NULL) - * or the name of a variable. */ + CONST char *part1; /* Name of an array (if part2 is non-NULL) or + * the name of a variable. */ CONST char *part2; /* If non-NULL, gives the name of an element * in the array part1. */ Tcl_Obj *newValuePtr; /* New value for variable. */ - CONST int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, - * and TCL_LEAVE_ERR_MSG bits. */ + CONST int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, and + * TCL_LEAVE_ERR_MSG bits. */ { Interp *iPtr = (Interp *) interp; Tcl_Obj *oldValuePtr; Tcl_Obj *resultPtr = NULL; int result; /* * If the variable is in a hashtable and its hPtr field is NULL, then we - * may have an upvar to an array element where the array was deleted - * or an upvar to a namespace variable whose namespace was deleted. - * Generate an error (allowing the variable to be reset would screw up - * our storage allocation and is meaningless anyway). + * may have an upvar to an array element where the array was deleted or an + * upvar to a namespace variable whose namespace was deleted. Generate an + * error (allowing the variable to be reset would screw up our storage + * allocation and is meaningless anyway). */ if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) { if (flags & TCL_LEAVE_ERR_MSG) { if (TclIsVarArrayElement(varPtr)) { @@ -1590,84 +1594,83 @@ } return NULL; } /* - * Invoke any read traces that have been set for the variable if it - * is requested; this is only done in the core when lappending. + * Invoke any read traces that have been set for the variable if it is + * requested; this is only done in the core when lappending. */ - if ((flags & TCL_TRACE_READS) && ((varPtr->tracePtr != NULL) + if ((flags & TCL_TRACE_READS) && ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) { if (TCL_ERROR == TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) { return NULL; } } /* - * Set the variable's new value. If appending, append the new value to - * the variable, either as a list element or as a string. Also, if - * appending, then if the variable's old value is unshared we can modify - * it directly, otherwise we must create a new copy to modify: this is - * "copy on write". + * Set the variable's new value. If appending, append the new value to the + * variable, either as a list element or as a string. Also, if appending, + * then if the variable's old value is unshared we can modify it directly, + * otherwise we must create a new copy to modify: this is "copy on write". */ if (flags & TCL_LIST_ELEMENT && !(flags & TCL_APPEND_VALUE)) { TclSetVarUndefined(varPtr); } oldValuePtr = varPtr->value.objPtr; if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) { if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) { - Tcl_DecrRefCount(oldValuePtr); /* discard old value */ + TclDecrRefCount(oldValuePtr); /* discard old value */ varPtr->value.objPtr = NULL; oldValuePtr = NULL; } - if (flags & TCL_LIST_ELEMENT) { /* append list element */ + if (flags & TCL_LIST_ELEMENT) { /* append list element */ if (oldValuePtr == NULL) { TclNewObj(oldValuePtr); varPtr->value.objPtr = oldValuePtr; - Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */ + Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */ } else if (Tcl_IsShared(oldValuePtr)) { varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); - Tcl_DecrRefCount(oldValuePtr); + TclDecrRefCount(oldValuePtr); oldValuePtr = varPtr->value.objPtr; - Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */ + Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */ } result = Tcl_ListObjAppendElement(interp, oldValuePtr, newValuePtr); if (result != TCL_OK) { return NULL; } - } else { /* append string */ + } else { /* append string */ /* * We append newValuePtr's bytes but don't change its ref count. */ if (oldValuePtr == NULL) { varPtr->value.objPtr = newValuePtr; Tcl_IncrRefCount(newValuePtr); } else { - if (Tcl_IsShared(oldValuePtr)) { /* append to copy */ + if (Tcl_IsShared(oldValuePtr)) { /* append to copy */ varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); TclDecrRefCount(oldValuePtr); oldValuePtr = varPtr->value.objPtr; - Tcl_IncrRefCount(oldValuePtr); /* since var is ref */ + Tcl_IncrRefCount(oldValuePtr); /* since var is ref */ } Tcl_AppendObjToObj(oldValuePtr, newValuePtr); } } } else if (newValuePtr != oldValuePtr) { /* - * In this case we are replacing the value, so we don't need to - * do more than swap the objects. + * In this case we are replacing the value, so we don't need to do + * more than swap the objects. */ varPtr->value.objPtr = newValuePtr; - Tcl_IncrRefCount(newValuePtr); /* var is another ref */ + Tcl_IncrRefCount(newValuePtr); /* var is another ref */ if (oldValuePtr != NULL) { - TclDecrRefCount(oldValuePtr); /* discard old value */ + TclDecrRefCount(oldValuePtr); /* discard old value */ } } TclSetVarScalar(varPtr); TclClearVarUndefined(varPtr); if (arrayPtr != NULL) { @@ -1679,20 +1682,20 @@ */ if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { if (TCL_ERROR == TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, - (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_WRITES, (flags & TCL_LEAVE_ERR_MSG))) { goto cleanup; } } /* * Return the variable's value unless the variable was changed in some * gross way by a trace (e.g. it was unset and then recreated as an - * array). + * array). */ if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) { return varPtr->value.objPtr; } @@ -1699,40 +1702,41 @@ /* * A trace changed the value in some gross way. Return an empty string * object. */ - + resultPtr = iPtr->emptyObjPtr; /* - * If the variable doesn't exist anymore and no-one's using it, then - * free up the relevant structures and hash table entries. + * If the variable doesn't exist anymore and no-one's using it, then free + * up the relevant structures and hash table entries. */ - cleanup: + cleanup: if (TclIsVarUndefined(varPtr)) { TclCleanupVar(varPtr, arrayPtr); } return resultPtr; } +#if 0 /* *---------------------------------------------------------------------- * * TclIncrVar2 -- * * 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 amount. + * variable or an element of an array, increment the Tcl object value of + * the variable by a specified amount. * * 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 + * 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. + * 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_ @@ -1742,23 +1746,23 @@ *---------------------------------------------------------------------- */ Tcl_Obj * TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, 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_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. */ long incrAmount; /* 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. */ + 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); @@ -1778,20 +1782,19 @@ /* *---------------------------------------------------------------------- * * TclPtrIncrVar -- * - * Given the pointers to a variable and possible containing array, - * increment the Tcl object value of the variable by a specified - * amount. + * Given the pointers to a variable and possible containing array, + * increment the Tcl object value of the variable by a specified amount. * * 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 + * 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. + * 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_ @@ -1801,30 +1804,30 @@ *---------------------------------------------------------------------- */ Tcl_Obj * TclPtrIncrVar(interp, varPtr, arrayPtr, part1, part2, incrAmount, flags) - Tcl_Interp *interp; /* Command interpreter in which variable is - * to be found. */ + 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 *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. */ CONST long incrAmount; /* Amount to be added to variable. */ - 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. */ + 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; - int createdNewObj; /* Set 1 if var's value object is shared - * so we must increment a copy (i.e. copy - * on write). */ + int createdNewObj; /* Set 1 if var's value object is shared so we + * must increment a copy (i.e. copy on + * write). */ long i; varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags); if (varValuePtr == NULL) { @@ -1832,14 +1835,14 @@ "\n (reading value of variable to increment)", -1); return NULL; } /* - * Increment the variable's value. If the object is unshared we can - * modify it directly, otherwise we must create a new copy to modify: - * this is "copy on write". Then free the variable's old string - * representation, if any, since it will no longer be valid. + * Increment the variable's value. If the object is unshared we can modify + * it directly, otherwise we must create a new copy to modify: this is + * "copy on write". Then free the variable's old string representation, if + * any, since it will no longer be valid. */ createdNewObj = 0; if (Tcl_IsShared(varValuePtr)) { varValuePtr = Tcl_DuplicateObj(varValuePtr); @@ -1846,56 +1849,184 @@ createdNewObj = 1; } if (varValuePtr->typePtr == &tclWideIntType) { Tcl_WideInt wide; TclGetWide(wide,varValuePtr); - Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount)); + TclSetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount)); } else if (varValuePtr->typePtr == &tclIntType) { i = varValuePtr->internalRep.longValue; - Tcl_SetIntObj(varValuePtr, i + incrAmount); + TclSetIntObj(varValuePtr, i + incrAmount); } else { /* * Not an integer or wide internal-rep... */ + Tcl_WideInt wide; if (Tcl_GetWideIntFromObj(interp, varValuePtr, &wide) != TCL_OK) { if (createdNewObj) { - Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ + TclDecrRefCount(varValuePtr); /* free unneeded copy */ } return NULL; } if (wide <= Tcl_LongAsWide(LONG_MAX) && wide >= Tcl_LongAsWide(LONG_MIN)) { - Tcl_SetLongObj(varValuePtr, Tcl_WideAsLong(wide) + incrAmount); + TclSetLongObj(varValuePtr, Tcl_WideAsLong(wide) + incrAmount); } else { - Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount)); + TclSetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount)); } } /* * Store the variable's new value and run any write traces. */ - + 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 /* *---------------------------------------------------------------------- * * TclIncrWideVar2 -- * * 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 amount. + * variable or an element of an array, increment the Tcl object value of + * the variable by a specified amount. * * 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 + * 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. + * 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_ @@ -1905,23 +2036,23 @@ *---------------------------------------------------------------------- */ Tcl_Obj * TclIncrWideVar2(interp, part1Ptr, part2Ptr, incrAmount, 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_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_WideInt incrAmount; /* 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. */ + 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); @@ -1941,20 +2072,19 @@ /* *---------------------------------------------------------------------- * * TclPtrIncrWideVar -- * - * Given the pointers to a variable and possible containing array, - * increment the Tcl object value of the variable by a specified - * amount. + * Given the pointers to a variable and possible containing array, + * increment the Tcl object value of the variable by a specified amount. * * 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. + * 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_ @@ -1964,31 +2094,31 @@ *---------------------------------------------------------------------- */ Tcl_Obj * TclPtrIncrWideVar(interp, varPtr, arrayPtr, part1, part2, incrAmount, flags) - Tcl_Interp *interp; /* Command interpreter in which variable is - * to be found. */ + 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 *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. */ CONST Tcl_WideInt incrAmount; /* Amount to be added to variable. */ - 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. */ + 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; - int createdNewObj; /* Set 1 if var's value object is shared - * so we must increment a copy (i.e. copy - * on write). */ + int createdNewObj; /* Set 1 if var's value object is shared so we + * must increment a copy (i.e. copy on + * write). */ Tcl_WideInt wide; varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags); if (varValuePtr == NULL) { @@ -1996,75 +2126,77 @@ "\n (reading value of variable to increment)", -1); return NULL; } /* - * Increment the variable's value. If the object is unshared we can - * modify it directly, otherwise we must create a new copy to modify: - * this is "copy on write". Then free the variable's old string - * representation, if any, since it will no longer be valid. + * Increment the variable's value. If the object is unshared we can modify + * it directly, otherwise we must create a new copy to modify: this is + * "copy on write". Then free the variable's old string representation, if + * any, since it will no longer be valid. */ createdNewObj = 0; if (Tcl_IsShared(varValuePtr)) { varValuePtr = Tcl_DuplicateObj(varValuePtr); createdNewObj = 1; } if (varValuePtr->typePtr == &tclWideIntType) { TclGetWide(wide, varValuePtr); - Tcl_SetWideIntObj(varValuePtr, wide + incrAmount); + TclSetWideIntObj(varValuePtr, wide + incrAmount); } else if (varValuePtr->typePtr == &tclIntType) { long i = varValuePtr->internalRep.longValue; - Tcl_SetWideIntObj(varValuePtr, Tcl_LongAsWide(i) + incrAmount); + TclSetWideIntObj(varValuePtr, Tcl_LongAsWide(i) + incrAmount); } else { /* * Not an integer or wide internal-rep... */ + if (Tcl_GetWideIntFromObj(interp, varValuePtr, &wide) != TCL_OK) { if (createdNewObj) { - Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ + TclDecrRefCount(varValuePtr); /* free unneeded copy */ } return NULL; } - Tcl_SetWideIntObj(varValuePtr, wide + incrAmount); + TclSetWideIntObj(varValuePtr, wide + incrAmount); } /* * Store the variable's new value and run any write traces. */ - + return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, varValuePtr, flags); } +#endif /* *---------------------------------------------------------------------- * * Tcl_UnsetVar -- * * Delete a variable, so that it may not be accessed anymore. * * Results: - * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR - * if the variable can't be unset. In the event of an error, - * if the TCL_LEAVE_ERR_MSG flag is set then an error message - * is left in the interp's result. + * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR if + * the variable can't be unset. In the event of an error, if the + * TCL_LEAVE_ERR_MSG flag is set then an error message is left in the + * interp's result. * * Side effects: - * If varName is defined as a local or global variable in interp, - * it is deleted. + * If varName is defined as a local or global variable in interp, it is + * deleted. * *---------------------------------------------------------------------- */ int Tcl_UnsetVar(interp, varName, flags) - Tcl_Interp *interp; /* Command interpreter in which varName is - * to be looked up. */ - CONST char *varName; /* Name of a variable in interp. May be - * either a scalar name or an array name - * or an element in an array. */ + Tcl_Interp *interp; /* Command interpreter in which varName is to + * be looked up. */ + CONST char *varName; /* Name of a variable in interp. May be either + * a scalar name or an array name or an + * element in an array. */ int flags; /* OR-ed combination of any of * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY or * TCL_LEAVE_ERR_MSG. */ { return Tcl_UnsetVar2(interp, varName, (char *) NULL, flags); @@ -2076,27 +2208,27 @@ * Tcl_UnsetVar2 -- * * Delete a variable, given a 2-part name. * * Results: - * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR - * if the variable can't be unset. In the event of an error, - * if the TCL_LEAVE_ERR_MSG flag is set then an error message - * is left in the interp's result. + * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR if + * the variable can't be unset. In the event of an error, if the + * TCL_LEAVE_ERR_MSG flag is set then an error message is left in the + * interp's result. * * Side effects: - * If part1 and part2 indicate a local or global variable in interp, - * it is deleted. If part1 is an array name and part2 is NULL, then - * the whole array is deleted. + * If part1 and part2 indicate a local or global variable in interp, it + * is deleted. If part1 is an array name and part2 is NULL, then the + * whole array is deleted. * *---------------------------------------------------------------------- */ int Tcl_UnsetVar2(interp, part1, part2, flags) - Tcl_Interp *interp; /* Command interpreter in which varName is - * to be looked up. */ + Tcl_Interp *interp; /* Command interpreter in which varName is to + * be looked up. */ CONST char *part1; /* Name of variable or array. */ CONST char *part2; /* Name of element within array or NULL. */ int flags; /* OR-ed combination of any of * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_LEAVE_ERR_MSG. */ @@ -2109,37 +2241,36 @@ result = TclObjUnsetVar2(interp, part1Ptr, part2, flags); TclDecrRefCount(part1Ptr); return result; } - /* *---------------------------------------------------------------------- * * TclObjUnsetVar2 -- * * Delete a variable, given a 2-object name. * * Results: - * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR - * if the variable can't be unset. In the event of an error, - * if the TCL_LEAVE_ERR_MSG flag is set then an error message - * is left in the interp's result. + * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR if + * the variable can't be unset. In the event of an error, if the + * TCL_LEAVE_ERR_MSG flag is set then an error message is left in the + * interp's result. * * Side effects: - * If part1ptr and part2Ptr indicate a local or global variable in interp, - * it is deleted. If part1Ptr is an array name and part2Ptr is NULL, then - * the whole array is deleted. + * If part1ptr and part2Ptr indicate a local or global variable in + * interp, it is deleted. If part1Ptr is an array name and part2Ptr is + * NULL, then the whole array is deleted. * *---------------------------------------------------------------------- */ int TclObjUnsetVar2(interp, part1Ptr, part2, flags) - Tcl_Interp *interp; /* Command interpreter in which varName is - * to be looked up. */ + Tcl_Interp *interp; /* Command interpreter in which varName is to + * be looked up. */ Tcl_Obj *part1Ptr; /* Name of variable or array. */ CONST char *part2; /* Name of element within array or NULL. */ int flags; /* OR-ed combination of any of * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_LEAVE_ERR_MSG. */ @@ -2157,28 +2288,27 @@ varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "unset", /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); if (varPtr == NULL) { return TCL_ERROR; } - + result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK); if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) { DeleteSearches(arrayPtr); } /* - * The code below is tricky, because of the possibility that - * a trace procedure might try to access a variable being - * deleted. To handle this situation gracefully, do things - * in three steps: - * 1. Copy the contents of the variable to a dummy variable - * structure, and mark the original Var structure as undefined. + * The code below is tricky, because of the possibility that a trace + * procedure might try to access a variable being deleted. To handle this + * situation gracefully, do things in three steps: + * 1. Copy the contents of the variable to a dummy variable structure, and + * mark the original Var structure as undefined. * 2. Invoke traces and clean up the variable, using the dummy copy. - * 3. If at the end of this the original variable is still - * undefined and has no outstanding references, then delete - * it (but it could have gotten recreated by a trace). + * 3. If at the end of this the original variable is still undefined and + * has no outstanding references, then delete * it (but it could have + * gotten recreated by a trace). */ dummyVar = *varPtr; TclSetVarUndefined(varPtr); TclSetVarScalar(varPtr); @@ -2186,26 +2316,25 @@ varPtr->tracePtr = NULL; varPtr->searchPtr = NULL; /* * Keep the variable alive until we're done with it. We used to - * increase/decrease the refCount for each operation, making it - * hard to find [Bug 735335] - caused by unsetting the variable - * whose value was the variable's name. + * increase/decrease the refCount for each operation, making it hard to + * find [Bug 735335] - caused by unsetting the variable whose value was + * the variable's name. */ - + varPtr->refCount++; - /* - * Call trace procedures for the variable being deleted. Then delete - * its traces. Be sure to abort any other traces for the variable - * that are still pending. Special tricks: + * Call trace procedures for the variable being deleted. Then delete its + * traces. Be sure to abort any other traces for the variable that are + * still pending. Special tricks: * 1. We need to increment varPtr's refCount around this: TclCallVarTraces * will use dummyVar so it won't increment varPtr's refCount itself. - * 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to - * call unset traces even if other traces are pending. + * 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to call + * unset traces even if other traces are pending. */ if ((dummyVar.tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { dummyVar.flags &= ~VAR_TRACE_ACTIVE; @@ -2216,40 +2345,41 @@ VarTrace *tracePtr = dummyVar.tracePtr; dummyVar.tracePtr = tracePtr->nextPtr; Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); } for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { + activePtr = activePtr->nextPtr) { if (activePtr->varPtr == varPtr) { activePtr->nextTracePtr = NULL; } } } /* * If the variable is an array, delete all of its elements. This must be * done after calling the traces on the array, above (that's the way - * traces are defined). If it is a scalar, "discard" its object - * (decrement the ref count of its object, if any). + * traces are defined). If it is a scalar, "discard" its object (decrement + * the ref count of its object, if any). */ dummyVarPtr = &dummyVar; if (TclIsVarArray(dummyVarPtr) && !TclIsVarUndefined(dummyVarPtr)) { /* - * Deleting the elements of the array may cause traces to be fired - * on those elements. Before deleting them, bump the reference count - * of the array, so that if those trace procs make a global or upvar - * link to the array, the array is not deleted when the call stack - * gets popped (we will delete the array ourselves later in this - * function). - * - * Bumping the count can lead to the odd situation that elements of the - * array are being deleted when the array still exists, but since the - * array is about to be removed anyway, that shouldn't really matter. - */ - DeleteArray(iPtr, part1, dummyVarPtr, - (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) + * Deleting the elements of the array may cause traces to be fired on + * those elements. Before deleting them, bump the reference count of + * the array, so that if those trace procs make a global or upvar link + * to the array, the array is not deleted when the call stack gets + * popped (we will delete the array ourselves later in this function). + * + * Bumping the count can lead to the odd situation that elements of + * the array are being deleted when the array still exists, but since + * the array is about to be removed anyway, that shouldn't really + * matter. + */ + + DeleteArray(iPtr, part1, dummyVarPtr, + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS); /* Decr ref count */ } if (TclIsVarScalar(dummyVarPtr) && (dummyVarPtr->value.objPtr != NULL)) { @@ -2257,42 +2387,43 @@ TclDecrRefCount(objPtr); dummyVarPtr->value.objPtr = NULL; } /* - * If the variable was a namespace variable, decrement its reference count. + * If the variable was a namespace variable, decrement its reference + * count. */ - + if (TclIsVarNamespaceVar(varPtr)) { TclClearVarNamespaceVar(varPtr); varPtr->refCount--; } /* * It's an error to unset an undefined variable. */ - + if (result != TCL_OK) { if (flags & TCL_LEAVE_ERR_MSG) { - TclVarErrMsg(interp, part1, part2, "unset", + TclVarErrMsg(interp, part1, part2, "unset", ((arrayPtr == NULL) ? noSuchVar : noSuchElement)); } } #if ENABLE_NS_VARNAME_CACHING /* - * Try to avoid keeping the Var struct allocated due to a tclNsVarNameType + * Try to avoid keeping the Var struct allocated due to a tclNsVarNameType * keeping a reference. This removes some additional exteriorisations of * [Bug 736729], but may be a good thing independently of the bug. */ if (part1Ptr->typePtr == &tclNsVarNameType) { TclFreeIntRep(part1Ptr); part1Ptr->typePtr = NULL; } #endif - + /* * Finally, if the variable is truly not in use then free up its Var * structure and remove it from its hash table, if any. The ref count of * its value object, if any, was decremented above. */ @@ -2334,21 +2465,23 @@ Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?--? ?varName varName ...?"); return TCL_ERROR; } else if (objc == 1) { /* - * Do nothing if no arguments supplied, so as to match - * command documentation. + * Do nothing if no arguments supplied, so as to match command + * documentation. */ + return TCL_OK; } /* - * Simple, restrictive argument parsing. The only options are -- - * and -nocomplain (which must come first and be given exactly to - * be an option). + * Simple, restrictive argument parsing. The only options are -- and + * -nocomplain (which must come first and be given exactly to be an + * option). */ + i = 1; name = TclGetString(objv[i]); if (name[0] == '-') { if (strcmp("-nocomplain", name) == 0) { i++; @@ -2375,12 +2508,12 @@ /* *---------------------------------------------------------------------- * * Tcl_AppendObjCmd -- * - * This object-based procedure is invoked to process the "append" - * Tcl command. See the user documentation for details on what it does. + * This object-based procedure is invoked to process the "append" Tcl + * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result value. * * Side effects: @@ -2400,11 +2533,11 @@ Var *varPtr, *arrayPtr; char *part1; register Tcl_Obj *varValuePtr = NULL; /* Initialized to avoid compiler - * warning. */ + * warning. */ int i; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?"); return TCL_ERROR; @@ -2420,20 +2553,20 @@ "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); part1 = TclGetString(objv[1]); if (varPtr == NULL) { return TCL_ERROR; } - for (i = 2; i < objc; i++) { + for (i = 2; i < objc; i++) { /* - * Note that we do not need to increase the refCount of - * the Var pointers: should a trace delete the variable, - * the return value of TclPtrSetVar will be NULL, and we - * will not access the variable again. + * Note that we do not need to increase the refCount of the Var + * pointers: should a trace delete the variable, the return value + * of TclPtrSetVar will be NULL, and we will not access the + * variable again. */ - varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL, - objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG)); + varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL, + objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG)); if (varValuePtr == NULL) { return TCL_ERROR; } } } @@ -2444,12 +2577,12 @@ /* *---------------------------------------------------------------------- * * Tcl_LappendObjCmd -- * - * This object-based procedure is invoked to process the "lappend" - * Tcl command. See the user documentation for details on what it does. + * This object-based procedure is invoked to process the "lappend" Tcl + * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result value. * * Side effects: @@ -2465,15 +2598,14 @@ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Obj *varValuePtr, *newValuePtr; - register List *listRepPtr; - register Tcl_Obj **elemPtrs; - int numElems, numRequired, createdNewObj, createVar, i, j; + int numElems, createdNewObj, createVar; Var *varPtr, *arrayPtr; char *part1; + int result; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?"); return TCL_ERROR; } @@ -2482,40 +2614,40 @@ if (newValuePtr == NULL) { /* * The variable doesn't exist yet. Just create it with an empty * initial value. */ - - varValuePtr = Tcl_NewObj(); + + TclNewObj(varValuePtr); newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, varValuePtr, TCL_LEAVE_ERR_MSG); if (newValuePtr == NULL) { - Tcl_DecrRefCount(varValuePtr); /* free unneeded object */ + TclDecrRefCount(varValuePtr); /* free unneeded object */ return TCL_ERROR; } } } else { /* - * We have arguments to append. We used to call Tcl_SetVar2 to - * append each argument one at a time to ensure that traces were run - * for each append step. We now append the arguments all at once - * because it's faster. Note that a read trace and a write trace for - * the variable will now each only be called once. Also, if the - * variable's old value is unshared we modify it directly, otherwise - * we create a new copy to modify: this is "copy on write". + * We have arguments to append. We used to call Tcl_SetVar2 to append + * each argument one at a time to ensure that traces were run for each + * append step. We now append the arguments all at once because it's + * faster. Note that a read trace and a write trace for the variable + * will now each only be called once. Also, if the variable's old + * value is unshared we modify it directly, otherwise we create a new + * copy to modify: this is "copy on write". */ createdNewObj = 0; createVar = 1; /* - * Use the TCL_TRACE_READS flag to ensure that if we have an - * array with no elements set yet, but with a read trace on it, - * we will create the variable and get read traces triggered. - * Note that you have to protect the variable pointers around - * the TclPtrGetVar call to insure that they remain valid - * even if the variable was undefined and unused. + * Use the TCL_TRACE_READS flag to ensure that if we have an array + * with no elements set yet, but with a read trace on it, we will + * create the variable and get read traces triggered. Note that you + * have to protect the variable pointers around the TclPtrGetVar call + * to insure that they remain valid even if the variable was undefined + * and unused. */ varPtr = TclObjLookupVar(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG, "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { @@ -2524,12 +2656,12 @@ varPtr->refCount++; if (arrayPtr != NULL) { arrayPtr->refCount++; } part1 = TclGetString(objv[1]); - varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, NULL, - (TCL_TRACE_READS | TCL_LEAVE_ERR_MSG)); + varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, NULL, + (TCL_TRACE_READS | TCL_LEAVE_ERR_MSG)); varPtr->refCount--; if (arrayPtr != NULL) { arrayPtr->refCount--; } @@ -2537,83 +2669,42 @@ /* * We couldn't read the old value: either the var doesn't yet * exist or it's an array element. If it's new, we will try to * create it with Tcl_ObjSetVar2 below. */ - + createVar = (TclIsVarUndefined(varPtr)); - varValuePtr = Tcl_NewObj(); + TclNewObj(varValuePtr); createdNewObj = 1; - } else if (Tcl_IsShared(varValuePtr)) { + } else if (Tcl_IsShared(varValuePtr)) { varValuePtr = Tcl_DuplicateObj(varValuePtr); createdNewObj = 1; } - /* - * Convert the variable's old value to a list object if necessary. - */ - - if (varValuePtr->typePtr != &tclListType) { - int result = tclListType.setFromAnyProc(interp, varValuePtr); - if (result != TCL_OK) { - if (createdNewObj) { - Tcl_DecrRefCount(varValuePtr); /* free unneeded obj. */ - } - return result; - } - } - listRepPtr = (List *) varValuePtr->internalRep.twoPtrValue.ptr1; - elemPtrs = listRepPtr->elements; - numElems = listRepPtr->elemCount; - - /* - * If there is no room in the current array of element pointers, - * allocate a new, larger array and copy the pointers to it. - */ - - numRequired = numElems + (objc-2); - if (numRequired > listRepPtr->maxElemCount) { - int newMax = (2 * numRequired); - Tcl_Obj **newElemPtrs = (Tcl_Obj **) - ckalloc((unsigned) (newMax * sizeof(Tcl_Obj *))); - - memcpy((VOID *) newElemPtrs, (VOID *) elemPtrs, - (size_t) (numElems * sizeof(Tcl_Obj *))); - listRepPtr->maxElemCount = newMax; - listRepPtr->elements = newElemPtrs; - ckfree((char *) elemPtrs); - elemPtrs = newElemPtrs; - } - - /* - * Insert the new elements at the end of the list. - */ - - for (i = 2, j = numElems; i < objc; i++, j++) { - elemPtrs[j] = objv[i]; - Tcl_IncrRefCount(objv[i]); - } - listRepPtr->elemCount = numRequired; - - /* - * Invalidate and free any old string representation since it no - * longer reflects the list's internal representation. - */ - - Tcl_InvalidateStringRep(varValuePtr); + result = Tcl_ListObjLength(interp, varValuePtr, &numElems); + if (result == TCL_OK) { + result = Tcl_ListObjReplace(interp, varValuePtr, numElems, 0, + (objc-2), (objv+2)); + } + if (result != TCL_OK) { + if (createdNewObj) { + TclDecrRefCount(varValuePtr); /* free unneeded obj. */ + } + return result; + } /* * Now store the list object back into the variable. If there is an - * error setting the new value, decrement its ref count if it - * was new and we didn't create the variable. + * error setting the new value, decrement its ref count if it was new + * and we didn't create the variable. */ - - newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL, - varValuePtr, TCL_LEAVE_ERR_MSG); + + newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL, + varValuePtr, TCL_LEAVE_ERR_MSG); if (newValuePtr == NULL) { if (createdNewObj && !createVar) { - Tcl_DecrRefCount(varValuePtr); /* free unneeded obj */ + TclDecrRefCount(varValuePtr); /* free unneeded obj */ } return TCL_ERROR; } } @@ -2656,11 +2747,11 @@ * below. */ enum {ARRAY_ANYMORE, ARRAY_DONESEARCH, ARRAY_EXISTS, ARRAY_GET, ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE, - ARRAY_STARTSEARCH, ARRAY_STATISTICS, ARRAY_UNSET}; + ARRAY_STARTSEARCH, ARRAY_STATISTICS, ARRAY_UNSET}; static CONST char *arrayOptions[] = { "anymore", "donesearch", "exists", "get", "names", "nextelement", "set", "size", "startsearch", "statistics", "unset", (char *) NULL }; @@ -2669,11 +2760,10 @@ Tcl_HashEntry *hPtr; Tcl_Obj *varNamePtr; int notArray; char *varName; int index, result; - if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "option arrayName ?arg ...?"); return TCL_ERROR; } @@ -2684,19 +2774,19 @@ } /* * Locate the array variable */ - + varNamePtr = objv[2]; varName = TclGetString(varNamePtr); varPtr = TclObjLookupVar(interp, varNamePtr, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); /* - * Special array trace used to keep the env array in sync for - * array names, array get, etc. + * Special array trace used to keep the env array in sync for array names, + * array get, etc. */ if (varPtr != NULL && varPtr->tracePtr != NULL && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { if (TCL_ERROR == TclCallVarTraces(iPtr, arrayPtr, varPtr, varName, @@ -2705,435 +2795,475 @@ return TCL_ERROR; } } /* - * Verify that it is indeed an array variable. This test comes after - * the traces - the variable may actually become an array as an effect - * of said traces. + * Verify that it is indeed an array variable. This test comes after the + * traces - the variable may actually become an array as an effect of said + * traces. */ notArray = 0; if ((varPtr == NULL) || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) { notArray = 1; } switch (index) { - case ARRAY_ANYMORE: { - ArraySearch *searchPtr; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId"); - return TCL_ERROR; - } - if (notArray) { - goto error; - } - searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]); - if (searchPtr == NULL) { - return TCL_ERROR; - } - while (1) { - Var *varPtr2; - - if (searchPtr->nextEntry != NULL) { - varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry); - if (!TclIsVarUndefined(varPtr2)) { - break; - } - } - searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search); - if (searchPtr->nextEntry == NULL) { - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); - return TCL_OK; - } - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); - break; - } - case ARRAY_DONESEARCH: { - ArraySearch *searchPtr, *prevPtr; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId"); - return TCL_ERROR; - } - if (notArray) { - goto error; - } - searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]); - if (searchPtr == NULL) { - return TCL_ERROR; - } - if (varPtr->searchPtr == searchPtr) { - varPtr->searchPtr = searchPtr->nextPtr; - } else { - for (prevPtr = varPtr->searchPtr; ; - prevPtr = prevPtr->nextPtr) { - if (prevPtr->nextPtr == searchPtr) { - prevPtr->nextPtr = searchPtr->nextPtr; - break; - } - } - } - ckfree((char *) searchPtr); - break; - } - case ARRAY_EXISTS: { - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(!notArray)); - break; - } - case ARRAY_GET: { - Tcl_HashSearch search; - Var *varPtr2; - char *pattern = NULL; - char *name; - Tcl_Obj *namePtr, *valuePtr, *nameLstPtr, *tmpResPtr, **namePtrPtr; - int i, count; - - if ((objc != 3) && (objc != 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?"); - return TCL_ERROR; - } - if (notArray) { - return TCL_OK; - } - if (objc == 4) { - pattern = TclGetString(objv[3]); - } - - /* - * Store the array names in a new object. - */ - - nameLstPtr = Tcl_NewObj(); - Tcl_IncrRefCount(nameLstPtr); - - for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - varPtr2 = (Var *) Tcl_GetHashValue(hPtr); - if (TclIsVarUndefined(varPtr2)) { - continue; - } - name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); - if ((objc == 4) && !Tcl_StringMatch(name, pattern)) { - continue; /* element name doesn't match pattern */ - } - - namePtr = Tcl_NewStringObj(name, -1); - result = Tcl_ListObjAppendElement(interp, nameLstPtr, - namePtr); - if (result != TCL_OK) { - Tcl_DecrRefCount(namePtr); /* free unneeded name obj */ - Tcl_DecrRefCount(nameLstPtr); - return result; - } - } - - /* - * Make sure the Var structure of the array is not removed by - * a trace while we're working. - */ - - varPtr->refCount++; - - /* - * Get the array values corresponding to each element name - */ - - tmpResPtr = Tcl_NewObj(); - result = Tcl_ListObjGetElements(interp, nameLstPtr, - &count, &namePtrPtr); - if (result != TCL_OK) { - goto errorInArrayGet; - } - - for (i = 0; i < count; i++) { - namePtr = *namePtrPtr++; - valuePtr = Tcl_ObjGetVar2(interp, objv[2], namePtr, - TCL_LEAVE_ERR_MSG); - if (valuePtr == NULL) { - /* - * Some trace played a trick on us; we need to diagnose to - * adapt our behaviour: was the array element unset, or did - * the modification modify the complete array? - */ - - if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { - /* - * The array itself looks OK, the variable was - * undefined: forget it. - */ - - continue; - } else { - result = TCL_ERROR; - goto errorInArrayGet; - } - } - result = Tcl_DictObjPut(interp, tmpResPtr, namePtr, valuePtr); - if (result != TCL_OK) { - goto errorInArrayGet; - } - } - varPtr->refCount--; - Tcl_SetObjResult(interp, tmpResPtr); - Tcl_DecrRefCount(nameLstPtr); - break; - - errorInArrayGet: - varPtr->refCount--; - Tcl_DecrRefCount(nameLstPtr); - Tcl_DecrRefCount(tmpResPtr); /* free unneeded temp result obj */ - return result; - } - case ARRAY_NAMES: { - Tcl_HashSearch search; - Var *varPtr2; - char *pattern = NULL; - char *name; - Tcl_Obj *namePtr, *resultPtr; - int mode, matched = 0; - static CONST char *options[] = { - "-exact", "-glob", "-regexp", (char *) NULL - }; - enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP }; - - mode = OPT_GLOB; - - if ((objc < 3) || (objc > 5)) { - Tcl_WrongNumArgs(interp, 2,objv, "arrayName ?mode? ?pattern?"); - return TCL_ERROR; - } - if (notArray) { - return TCL_OK; - } - if (objc == 4) { - pattern = TclGetString(objv[3]); - } else if (objc == 5) { - pattern = TclGetString(objv[4]); - if (Tcl_GetIndexFromObj(interp, objv[3], options, "option", - 0, &mode) != TCL_OK) { - return TCL_ERROR; - } - } - resultPtr = Tcl_NewObj(); - for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - varPtr2 = (Var *) Tcl_GetHashValue(hPtr); - if (TclIsVarUndefined(varPtr2)) { - continue; - } - name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); - if (objc > 3) { - switch ((enum options) mode) { - case OPT_EXACT: - matched = (strcmp(name, pattern) == 0); - break; - case OPT_GLOB: - matched = Tcl_StringMatch(name, pattern); - break; - case OPT_REGEXP: - matched = Tcl_RegExpMatch(interp, name, - pattern); - if (matched < 0) { - Tcl_DecrRefCount(resultPtr); - return TCL_ERROR; - } - break; - } - if (matched == 0) { - continue; - } - } - - namePtr = Tcl_NewStringObj(name, -1); - result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr); - if (result != TCL_OK) { - Tcl_DecrRefCount(namePtr); /* free unneeded name obj */ - return result; - } - Tcl_SetObjResult(interp, resultPtr); - } - break; - } - case ARRAY_NEXTELEMENT: { - ArraySearch *searchPtr; - Tcl_HashEntry *hPtr; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId"); - return TCL_ERROR; - } - if (notArray) { - goto error; - } - searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]); - if (searchPtr == NULL) { - return TCL_ERROR; - } - while (1) { - Var *varPtr2; - - hPtr = searchPtr->nextEntry; - if (hPtr == NULL) { - hPtr = Tcl_NextHashEntry(&searchPtr->search); - if (hPtr == NULL) { - return TCL_OK; - } - } else { - searchPtr->nextEntry = NULL; - } - varPtr2 = (Var *) Tcl_GetHashValue(hPtr); - if (!TclIsVarUndefined(varPtr2)) { - break; - } - } - Tcl_SetObjResult(interp, Tcl_NewStringObj( - Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), -1)); - break; - } - case ARRAY_SET: { - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName list"); - return TCL_ERROR; - } - return TclArraySet(interp, objv[2], objv[3]); - } - case ARRAY_SIZE: { - Tcl_HashSearch search; - Var *varPtr2; - int size; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); - return TCL_ERROR; - } - size = 0; - if (!notArray) { - for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, - &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - varPtr2 = (Var *) Tcl_GetHashValue(hPtr); - if (TclIsVarUndefined(varPtr2)) { - continue; - } - size++; - } - } - Tcl_SetObjResult(interp, Tcl_NewIntObj(size)); - break; - } - case ARRAY_STARTSEARCH: { - ArraySearch *searchPtr; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); - return TCL_ERROR; - } - if (notArray) { - goto error; - } - searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch)); - if (varPtr->searchPtr == NULL) { - searchPtr->id = 1; - Tcl_AppendResult(interp, "s-1-", varName, NULL); - } else { - char string[TCL_INTEGER_SPACE]; - - searchPtr->id = varPtr->searchPtr->id + 1; - TclFormatInt(string, searchPtr->id); - Tcl_AppendResult(interp, "s-", string, "-", varName, NULL); - } - searchPtr->varPtr = varPtr; - searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr, - &searchPtr->search); - searchPtr->nextPtr = varPtr->searchPtr; - varPtr->searchPtr = searchPtr; - break; - } - - case ARRAY_STATISTICS: { - CONST char *stats; - - if (notArray) { - goto error; - } - - stats = Tcl_HashStats(varPtr->value.tablePtr); - if (stats != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj(stats, -1)); - ckfree((void *)stats); - } else { - Tcl_SetResult(interp, "error reading array statistics", - TCL_STATIC); - return TCL_ERROR; - } - break; - } - - case ARRAY_UNSET: { - Tcl_HashSearch search; - Var *varPtr2; - char *pattern = NULL; - char *name; - - if ((objc != 3) && (objc != 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?"); - return TCL_ERROR; - } - if (notArray) { - return TCL_OK; - } - if (objc == 3) { - /* - * When no pattern is given, just unset the whole array - */ - if (TclObjUnsetVar2(interp, varNamePtr, NULL, 0) - != TCL_OK) { - return TCL_ERROR; - } - } else { - pattern = TclGetString(objv[3]); - for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, - &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - varPtr2 = (Var *) Tcl_GetHashValue(hPtr); - if (TclIsVarUndefined(varPtr2)) { - continue; - } - name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); - if (Tcl_StringMatch(name, pattern) && - (TclObjUnsetVar2(interp, varNamePtr, name, 0) - != TCL_OK)) { - return TCL_ERROR; - } - } - } - break; - } - } - return TCL_OK; - - error: + case ARRAY_ANYMORE: { + ArraySearch *searchPtr; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId"); + return TCL_ERROR; + } + if (notArray) { + goto error; + } + searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]); + if (searchPtr == NULL) { + return TCL_ERROR; + } + while (1) { + Var *varPtr2; + + if (searchPtr->nextEntry != NULL) { + varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry); + if (!TclIsVarUndefined(varPtr2)) { + break; + } + } + searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search); + if (searchPtr->nextEntry == NULL) { + Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[0]); + return TCL_OK; + } + } + Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[1]); + break; + } + case ARRAY_DONESEARCH: { + ArraySearch *searchPtr, *prevPtr; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId"); + return TCL_ERROR; + } + if (notArray) { + goto error; + } + searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]); + if (searchPtr == NULL) { + return TCL_ERROR; + } + if (varPtr->searchPtr == searchPtr) { + varPtr->searchPtr = searchPtr->nextPtr; + } else { + for (prevPtr=varPtr->searchPtr ;; prevPtr=prevPtr->nextPtr) { + if (prevPtr->nextPtr == searchPtr) { + prevPtr->nextPtr = searchPtr->nextPtr; + break; + } + } + } + ckfree((char *) searchPtr); + break; + } + case ARRAY_NEXTELEMENT: { + ArraySearch *searchPtr; + Tcl_HashEntry *hPtr; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId"); + return TCL_ERROR; + } + if (notArray) { + goto error; + } + searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]); + if (searchPtr == NULL) { + return TCL_ERROR; + } + while (1) { + Var *varPtr2; + + hPtr = searchPtr->nextEntry; + if (hPtr == NULL) { + hPtr = Tcl_NextHashEntry(&searchPtr->search); + if (hPtr == NULL) { + return TCL_OK; + } + } else { + searchPtr->nextEntry = NULL; + } + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (!TclIsVarUndefined(varPtr2)) { + break; + } + } + Tcl_SetObjResult(interp, Tcl_NewStringObj( + Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), -1)); + break; + } + case ARRAY_STARTSEARCH: { + ArraySearch *searchPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + return TCL_ERROR; + } + if (notArray) { + goto error; + } + searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch)); + if (varPtr->searchPtr == NULL) { + searchPtr->id = 1; + Tcl_AppendResult(interp, "s-1-", varName, NULL); + } else { + char string[TCL_INTEGER_SPACE]; + + searchPtr->id = varPtr->searchPtr->id + 1; + TclFormatInt(string, searchPtr->id); + Tcl_AppendResult(interp, "s-", string, "-", varName, NULL); + } + searchPtr->varPtr = varPtr; + searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr, + &searchPtr->search); + searchPtr->nextPtr = varPtr->searchPtr; + varPtr->searchPtr = searchPtr; + break; + } + + case ARRAY_EXISTS: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[!notArray]); + break; + case ARRAY_GET: { + Tcl_HashSearch search; + Var *varPtr2; + char *pattern = NULL; + char *name; + Tcl_Obj *namePtr, *valuePtr, *nameLstPtr, *tmpResPtr, **namePtrPtr; + int i, count; + + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?"); + return TCL_ERROR; + } + if (notArray) { + return TCL_OK; + } + if (objc == 4) { + pattern = TclGetString(objv[3]); + } + + /* + * Store the array names in a new object. + */ + + TclNewObj(nameLstPtr); + Tcl_IncrRefCount(nameLstPtr); + if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { + hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, pattern); + if (hPtr == NULL) { + goto searchDone; + } + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (TclIsVarUndefined(varPtr2)) { + goto searchDone; + } + result = Tcl_ListObjAppendElement(interp, nameLstPtr, + Tcl_NewStringObj(pattern, -1)); + if (result != TCL_OK) { + TclDecrRefCount(nameLstPtr); + return result; + } + goto searchDone; + } + for (hPtr=Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); + hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search)) { + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (TclIsVarUndefined(varPtr2)) { + continue; + } + name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); + if ((objc == 4) && !Tcl_StringMatch(name, pattern)) { + continue; /* element name doesn't match pattern */ + } + + namePtr = Tcl_NewStringObj(name, -1); + result = Tcl_ListObjAppendElement(interp, nameLstPtr, namePtr); + if (result != TCL_OK) { + TclDecrRefCount(namePtr); /* free unneeded name obj */ + TclDecrRefCount(nameLstPtr); + return result; + } + } + + searchDone: + /* + * Make sure the Var structure of the array is not removed by a trace + * while we're working. + */ + + varPtr->refCount++; + + /* + * Get the array values corresponding to each element name + */ + + TclNewObj(tmpResPtr); + result = Tcl_ListObjGetElements(interp, nameLstPtr, + &count, &namePtrPtr); + if (result != TCL_OK) { + goto errorInArrayGet; + } + + for (i=0 ; irefCount--; + Tcl_SetObjResult(interp, tmpResPtr); + TclDecrRefCount(nameLstPtr); + break; + + errorInArrayGet: + varPtr->refCount--; + TclDecrRefCount(nameLstPtr); + TclDecrRefCount(tmpResPtr); /* free unneeded temp result */ + return result; + } + case ARRAY_NAMES: { + Tcl_HashSearch search; + Var *varPtr2; + char *pattern = NULL; + char *name; + Tcl_Obj *namePtr, *resultPtr; + int mode, matched = 0; + static CONST char *options[] = { + "-exact", "-glob", "-regexp", (char *) NULL + }; + enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP }; + + mode = OPT_GLOB; + + if ((objc < 3) || (objc > 5)) { + Tcl_WrongNumArgs(interp, 2,objv, "arrayName ?mode? ?pattern?"); + return TCL_ERROR; + } + if (notArray) { + return TCL_OK; + } + if (objc == 4) { + pattern = TclGetString(objv[3]); + } else if (objc == 5) { + pattern = TclGetString(objv[4]); + if (Tcl_GetIndexFromObj(interp, objv[3], options, "option", 0, + &mode) != TCL_OK) { + return TCL_ERROR; + } + } + TclNewObj(resultPtr); + if (((enum options) mode)==OPT_GLOB && pattern!=NULL && + TclMatchIsTrivial(pattern)) { + hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, pattern); + if ((hPtr != NULL) && + !TclIsVarUndefined((Var *) Tcl_GetHashValue(hPtr))) { + result = Tcl_ListObjAppendElement(interp, resultPtr, + Tcl_NewStringObj(pattern, -1)); + if (result != TCL_OK) { + TclDecrRefCount(resultPtr); + return result; + } + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + for (hPtr=Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); + hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search)) { + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (TclIsVarUndefined(varPtr2)) { + continue; + } + name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); + if (objc > 3) { + switch ((enum options) mode) { + case OPT_EXACT: + matched = (strcmp(name, pattern) == 0); + break; + case OPT_GLOB: + matched = Tcl_StringMatch(name, pattern); + break; + case OPT_REGEXP: + matched = Tcl_RegExpMatch(interp, name, pattern); + if (matched < 0) { + TclDecrRefCount(resultPtr); + return TCL_ERROR; + } + break; + } + if (matched == 0) { + continue; + } + } + + namePtr = Tcl_NewStringObj(name, -1); + result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr); + if (result != TCL_OK) { + TclDecrRefCount(resultPtr); + TclDecrRefCount(namePtr); /* free unneeded name obj */ + return result; + } + } + Tcl_SetObjResult(interp, resultPtr); + break; + } + case ARRAY_SET: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName list"); + return TCL_ERROR; + } + return TclArraySet(interp, objv[2], objv[3]); + case ARRAY_UNSET: { + Tcl_HashSearch search; + Var *varPtr2; + char *pattern = NULL; + char *name; + + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?"); + return TCL_ERROR; + } + if (notArray) { + return TCL_OK; + } + if (objc == 3) { + /* + * When no pattern is given, just unset the whole array. + */ + + if (TclObjUnsetVar2(interp, varNamePtr, NULL, 0) != TCL_OK) { + return TCL_ERROR; + } + } else { + pattern = TclGetString(objv[3]); + if (TclMatchIsTrivial(pattern)) { + hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, pattern); + if (hPtr != NULL && + !TclIsVarUndefined((Var *)Tcl_GetHashValue(hPtr))){ + return TclObjUnsetVar2(interp, varNamePtr, pattern, 0); + } + return TCL_OK; + } + for (hPtr=Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); + hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search)) { + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (TclIsVarUndefined(varPtr2)) { + continue; + } + name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); + if (Tcl_StringMatch(name, pattern) && + TclObjUnsetVar2(interp, varNamePtr, name, + 0) != TCL_OK) { + return TCL_ERROR; + } + } + } + break; + } + + case ARRAY_SIZE: { + Tcl_HashSearch search; + Var *varPtr2; + int size; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + return TCL_ERROR; + } + size = 0; + + /* + * Must iterate in order to get chance to check for present but + * "undefined" entries. + */ + + if (!notArray) { + for (hPtr=Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); + hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search)) { + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (TclIsVarUndefined(varPtr2)) { + continue; + } + size++; + } + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(size)); + break; + } + + case ARRAY_STATISTICS: { + CONST char *stats; + + if (notArray) { + goto error; + } + + stats = Tcl_HashStats(varPtr->value.tablePtr); + if (stats != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj(stats, -1)); + ckfree((void *)stats); + } else { + Tcl_SetResult(interp, "error reading array statistics",TCL_STATIC); + return TCL_ERROR; + } + break; + } + } + return TCL_OK; + + error: Tcl_AppendResult(interp, "\"", varName, "\" isn't an array", NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * TclArraySet -- * - * Set the elements of an array. If there are no elements to - * set, create an empty array. This routine is used by the - * Tcl_ArrayObjCmd and by the TclSetupEnv routine. + * Set the elements of an array. If there are no elements to set, create + * an empty array. This routine is used by the Tcl_ArrayObjCmd and by + * the TclSetupEnv routine. * * Results: * A standard Tcl result object. * * Side effects: @@ -3144,18 +3274,18 @@ int TclArraySet(interp, arrayNameObj, arrayElemObj) Tcl_Interp *interp; /* Current interpreter. */ Tcl_Obj *arrayNameObj; /* The array name. */ - Tcl_Obj *arrayElemObj; /* The array elements list or dict. If - * this is NULL, create an empty array. */ + Tcl_Obj *arrayElemObj; /* The array elements list or dict. If this + * is NULL, create an empty array. */ { Var *varPtr, *arrayPtr; Tcl_Obj **elemPtrs; int result, elemLen, i, nameLen; char *varName, *p; - + varName = Tcl_GetStringFromObj(arrayNameObj, &nameLen); p = varName + nameLen - 1; if (*p == ')') { while (--p >= varName) { if (*p == '(') { @@ -3188,31 +3318,32 @@ if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) { return TCL_ERROR; } if (done == 0) { /* - * Empty, so we'll just force the array to be properly - * existing instead. + * Empty, so we'll just force the array to be properly existing + * instead. */ + goto ensureArray; } /* - * Don't need to look at result of Tcl_DictObjFirst as we've - * just successfully used a dictionary operation on the same - * object. + * Don't need to look at result of Tcl_DictObjFirst as we've just + * successfully used a dictionary operation on the same object. */ for (Tcl_DictObjFirst(interp, arrayElemObj, &search, &keyPtr, &valuePtr, &done) ; !done ; Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done)) { /* - * At this point, it would be nice if the key was directly - * usable by the array. This isn't the case though. + * At this point, it would be nice if the key was directly usable + * by the array. This isn't the case though. */ + char *part2 = TclGetString(keyPtr); - Var *elemVarPtr = TclLookupArrayElement(interp, varName, + Var *elemVarPtr = TclLookupArrayElement(interp, varName, part2, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr); if ((elemVarPtr == NULL) || (TclPtrSetVar(interp, elemVarPtr, varPtr, varName, part2, valuePtr, TCL_LEAVE_ERR_MSG) == NULL)) { @@ -3240,19 +3371,20 @@ if (elemLen == 0) { goto ensureArray; } /* - * We needn't worry about traces invalidating arrayPtr: should - * that be the case, TclPtrSetVar will return NULL so that we - * break out of the loop and return an error. + * We needn't worry about traces invalidating arrayPtr: should that be + * the case, TclPtrSetVar will return NULL so that we break out of the + * loop and return an error. */ - for (i = 0; i < elemLen; i += 2) { + for (i=0 ; iresult. + * A standard Tcl completion code. If an error occurs then an error + * message is left in iPtr->result. * * Side effects: * The variable given by myName is linked to the variable in framePtr * given by otherP1 and otherP2, so that references to myName are * redirected to the other variable like a symbolic link. @@ -3312,13 +3443,14 @@ * *---------------------------------------------------------------------- */ static int -ObjMakeUpvar(interp, framePtr, otherP1Ptr, otherP2, otherFlags, myName, myFlags, index) - Tcl_Interp *interp; /* Interpreter containing variables. Used - * for error messages, too. */ +ObjMakeUpvar(interp, framePtr, otherP1Ptr, otherP2, otherFlags, myName, + myFlags, index) + Tcl_Interp *interp; /* Interpreter containing variables. Used for + * error messages, too. */ CallFrame *framePtr; /* Call frame containing "other" variable. * NULL means use global :: context. */ Tcl_Obj *otherP1Ptr; CONST char *otherP2; /* Two-part name of variable in framePtr. */ CONST int otherFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: @@ -3325,119 +3457,118 @@ * indicates scope of "other" variable. */ CONST char *myName; /* Name of variable which will refer to * otherP1/otherP2. Must be a scalar. */ int myFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: * indicates scope of myName. */ - int index; /* If the variable to be linked is an indexed - * scalar, this is its index. Otherwise, -1. */ + int index; /* If the variable to be linked is an indexed + * scalar, this is its index. Otherwise, -1 */ { Interp *iPtr = (Interp *) interp; Var *otherPtr, *varPtr, *arrayPtr; CallFrame *varFramePtr; CONST char *errMsg; CONST char *p; /* - * Find "other" in "framePtr". If not looking up other in just the - * current namespace, temporarily replace the current var frame - * pointer in the interpreter in order to use TclObjLookupVar. + * Find "other" in "framePtr". If not looking up other in just the current + * namespace, temporarily replace the current var frame pointer in the + * interpreter in order to use TclObjLookupVar. */ varFramePtr = iPtr->varFramePtr; if (!(otherFlags & TCL_NAMESPACE_ONLY)) { iPtr->varFramePtr = framePtr; } otherPtr = TclObjLookupVar(interp, otherP1Ptr, otherP2, (otherFlags | TCL_LEAVE_ERR_MSG), "access", - /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (!(otherFlags & TCL_NAMESPACE_ONLY)) { iPtr->varFramePtr = varFramePtr; } if (otherPtr == NULL) { return TCL_ERROR; } if (index >= 0) { - if (!varFramePtr->isProcCallFrame) { + if (!(varFramePtr->isProcCallFrame & FRAME_IS_PROC)) { Tcl_Panic("ObjMakeUpvar called with an index outside from a proc.\n"); } varPtr = &(varFramePtr->compiledLocals[index]); } else { /* - * Check that we are not trying to create a namespace var linked to - * a local variable in a procedure. If we allowed this, the local - * variable in the shorter-lived procedure frame could go away - * leaving the namespace var's reference invalid. + * Check that we are not trying to create a namespace var linked to a + * local variable in a procedure. If we allowed this, the local + * variable in the shorter-lived procedure frame could go away leaving + * the namespace var's reference invalid. */ - - if (((otherP2 ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL) + + if (((otherP2 ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL) && ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) || (varFramePtr == NULL) - || !varFramePtr->isProcCallFrame + || !(varFramePtr->isProcCallFrame & FRAME_IS_PROC) || (strstr(myName, "::") != NULL))) { Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", myName, "\": upvar won't create namespace variable that ", "refers to procedure variable", (char *) NULL); return TCL_ERROR; } - + /* - * Do not permit the new variable to look like an array reference, - * as it will not be reachable in that case [Bug 600812, TIP 184]. - * The "definition" of what "looks like an array reference" is - * consistent (and must remain consistent) with the code in - * TclObjLookupVar(). + * Do not permit the new variable to look like an array reference, as + * it will not be reachable in that case [Bug 600812, TIP 184]. The + * "definition" of what "looks like an array reference" is consistent + * (and must remain consistent) with the code in TclObjLookupVar(). */ p = strstr(myName, "("); if (p != NULL) { p += strlen(p)-1; if (*p == ')') { - /* + /* * myName looks like an array reference. */ - + Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", - myName, "\": upvar won't create a scalar variable that ", - "looks like an array element", (char *) NULL); + myName, "\": upvar won't create a scalar variable ", + "that looks like an array element", (char *) NULL); return TCL_ERROR; } } /* * Lookup and eventually create the new variable. Set the flag bit - * LOOKUP_FOR_UPVAR to indicate the special resolution rules for - * upvar purposes: + * LOOKUP_FOR_UPVAR to indicate the special resolution rules for upvar + * purposes: * - Bug #696893 - variable is either proc-local or in the current - * namespace; never follow the second (global) resolution path - * - Bug #631741 - do not use special namespace or interp resolvers + * namespace; never follow the second (global) resolution path. + * - Bug #631741 - do not use special namespace or interp resolvers. */ - - varPtr = TclLookupSimpleVar(interp, myName, (myFlags | LOOKUP_FOR_UPVAR), - /* create */ 1, &errMsg, &index); + + varPtr = TclLookupSimpleVar(interp, myName, (myFlags|LOOKUP_FOR_UPVAR), + /* create */ 1, &errMsg, &index); if (varPtr == NULL) { TclVarErrMsg(interp, myName, NULL, "create", errMsg); return TCL_ERROR; } } if (varPtr == otherPtr) { Tcl_SetResult((Tcl_Interp *) iPtr, - "can't upvar from variable to itself", TCL_STATIC); + "can't upvar from variable to itself", TCL_STATIC); return TCL_ERROR; } if (varPtr->tracePtr != NULL) { Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, - "\" has traces: can't use for upvar", (char *) NULL); + "\" has traces: can't use for upvar", (char *) NULL); return TCL_ERROR; } else if (!TclIsVarUndefined(varPtr)) { /* * The variable already existed. Make sure this variable "varPtr" - * isn't the same as "otherPtr" (avoid circular links). Also, if - * it's not an upvar then it's an error. If it is an upvar, then - * just disconnect it from the thing it currently refers to. + * isn't the same as "otherPtr" (avoid circular links). Also, if it's + * not an upvar then it's an error. If it is an upvar, then just + * disconnect it from the thing it currently refers to. */ if (TclIsVarLink(varPtr)) { Var *linkPtr = varPtr->value.linkPtr; if (linkPtr == otherPtr) { @@ -3463,35 +3594,34 @@ /* *---------------------------------------------------------------------- * * Tcl_UpVar -- * - * This procedure links one variable to another, just like - * the "upvar" command. + * This procedure links one variable to another, just like the "upvar" + * command. * * Results: - * A standard Tcl completion code. If an error occurs then - * an error message is left in the interp's result. + * A standard Tcl completion code. If an error occurs then an error + * message is left in the interp's result. * * Side effects: * The variable in frameName whose name is given by varName becomes - * accessible under the name localName, so that references to - * localName are redirected to the other variable like a symbolic - * link. + * accessible under the name localName, so that references to localName + * are redirected to the other variable like a symbolic link. * *---------------------------------------------------------------------- */ int Tcl_UpVar(interp, frameName, varName, localName, flags) - Tcl_Interp *interp; /* Command interpreter in which varName is - * to be looked up. */ + Tcl_Interp *interp; /* Command interpreter in which varName is to + * be looked up. */ CONST char *frameName; /* Name of the frame containing the source * variable, such as "1" or "#0". */ CONST char *varName; /* Name of a variable in interp to link to. - * May be either a scalar name or an - * element in an array. */ + * May be either a scalar name or an element + * in an array. */ CONST char *localName; /* Name of link variable. */ int flags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: * indicates scope of localName. */ { return Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags); @@ -3500,35 +3630,34 @@ /* *---------------------------------------------------------------------- * * Tcl_UpVar2 -- * - * This procedure links one variable to another, just like - * the "upvar" command. + * This procedure links one variable to another, just like the "upvar" + * command. * * Results: - * A standard Tcl completion code. If an error occurs then - * an error message is left in the interp's result. + * A standard Tcl completion code. If an error occurs then an error + * message is left in the interp's result. * * Side effects: - * The variable in frameName whose name is given by part1 and - * part2 becomes accessible under the name localName, so that - * references to localName are redirected to the other variable - * like a symbolic link. + * The variable in frameName whose name is given by part1 and part2 + * becomes accessible under the name localName, so that references to + * localName are redirected to the other variable like a symbolic link. * *---------------------------------------------------------------------- */ int Tcl_UpVar2(interp, frameName, part1, part2, localName, flags) - Tcl_Interp *interp; /* Interpreter containing variables. Used - * for error messages too. */ + Tcl_Interp *interp; /* Interpreter containing variables. Used for + * error messages too. */ CONST char *frameName; /* Name of the frame containing the source * variable, such as "1" or "#0". */ CONST char *part1; - CONST char *part2; /* Two parts of source variable name to - * link to. */ + CONST char *part2; /* Two parts of source variable name to link + * to. */ CONST char *localName; /* Name of link variable. */ int flags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: * indicates scope of localName. */ { int result; @@ -3551,27 +3680,27 @@ /* *---------------------------------------------------------------------- * * Tcl_GetVariableFullName -- * - * Given a Tcl_Var token returned by Tcl_FindNamespaceVar, this - * procedure appends to an object the namespace variable's full - * name, qualified by a sequence of parent namespace names. + * Given a Tcl_Var token returned by Tcl_FindNamespaceVar, this procedure + * appends to an object the namespace variable's full name, qualified by + * a sequence of parent namespace names. * * Results: - * None. + * None. * * Side effects: - * The variable's fully-qualified name is appended to the string + * The variable's fully-qualified name is appended to the string * representation of objPtr. * *---------------------------------------------------------------------- */ void Tcl_GetVariableFullName(interp, variable, objPtr) - Tcl_Interp *interp; /* Interpreter containing the variable. */ + Tcl_Interp *interp; /* Interpreter containing the variable. */ Tcl_Var variable; /* Token for the variable returned by a * previous call to Tcl_FindNamespaceVar. */ Tcl_Obj *objPtr; /* Points to the object onto which the * variable's full name is appended. */ { @@ -3578,12 +3707,12 @@ Interp *iPtr = (Interp *) interp; register Var *varPtr = (Var *) variable; char *name; /* - * Add the full name of the containing namespace (if any), followed by - * the "::" separator, then the variable name. + * Add the full name of the containing namespace (if any), followed by the + * "::" separator, then the variable name. */ if (varPtr != NULL) { if (!TclIsVarArrayElement(varPtr)) { if (varPtr->nsPtr != NULL) { @@ -3638,47 +3767,47 @@ } /* * If we are not executing inside a Tcl procedure, just return. */ - + if ((iPtr->varFramePtr == NULL) - || !iPtr->varFramePtr->isProcCallFrame) { + || !(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC)) { return TCL_OK; } for (i = 1; i < objc; i++) { /* * Make a local variable linked to its counterpart in the global :: * namespace. */ - + objPtr = objv[i]; varName = TclGetString(objPtr); /* * The variable name might have a scope qualifier, but the name for - * the local "link" variable must be the simple name at the tail. + * the local "link" variable must be the simple name at the tail. */ for (tail = varName; *tail != '\0'; tail++) { /* empty body */ } - while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) { - tail--; + while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) { + tail--; } - if ((*tail == ':') && (tail > varName)) { - tail++; + if ((*tail == ':') && (tail > varName)) { + tail++; } /* * Link to the variable "varName" in the global :: namespace. */ - + result = ObjMakeUpvar(interp, (CallFrame *) NULL, objPtr, NULL, /*otherFlags*/ TCL_GLOBAL_ONLY, - /*myName*/ tail, /*myFlags*/ 0, -1); + /*myName*/ tail, /*myFlags*/ 0, -1); if (result != TCL_OK) { return result; } } return TCL_OK; @@ -3697,26 +3826,25 @@ * One or more variables can be created. The variables are initialized * with the specified values. The value for the last variable is * optional. * * If the variable does not exist, it is created and given the optional - * value. If it already exists, it is simply set to the optional - * value. Normally, "name" is an unqualified name, so it is created in - * the current namespace. If it includes namespace qualifiers, it can - * be created in another namespace. - * - * If the variable command is executed inside a Tcl procedure, it - * creates a local variable linked to the newly-created namespace - * variable. + * value. If it already exists, it is simply set to the optional value. + * Normally, "name" is an unqualified name, so it is created in the + * current namespace. If it includes namespace qualifiers, it can be + * created in another namespace. + * + * If the variable command is executed inside a Tcl procedure, it creates + * a local variable linked to the newly-created namespace variable. * * Results: - * Returns TCL_OK if the variable is found or created. Returns - * TCL_ERROR if anything goes wrong. + * Returns TCL_OK if the variable is found or created. Returns TCL_ERROR + * if anything goes wrong. * * Side effects: - * If anything goes wrong, this procedure returns an error message - * as the result in the interpreter's result object. + * If anything goes wrong, this procedure returns an error message as the + * result in the interpreter's result object. * *---------------------------------------------------------------------- */ int @@ -3738,35 +3866,36 @@ return TCL_ERROR; } for (i = 1; i < objc; i = i+2) { /* - * Look up each variable in the current namespace context, creating - * it if necessary. + * Look up each variable in the current namespace context, creating it + * if necessary. */ - + varNamePtr = objv[i]; varName = TclGetString(varNamePtr); varPtr = TclObjLookupVar(interp, varNamePtr, NULL, - (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "define", - /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr); - - if (arrayPtr != NULL) { - /* - * Variable cannot be an element in an array. If arrayPtr is - * non-null, it is, so throw up an error and return. - */ - TclVarErrMsg(interp, varName, NULL, "define", isArrayElement); - return TCL_ERROR; - } + (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "define", + /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr); + + if (arrayPtr != NULL) { + /* + * Variable cannot be an element in an array. If arrayPtr is + * non-null, it is, so throw up an error and return. + */ + + TclVarErrMsg(interp, varName, NULL, "define", isArrayElement); + return TCL_ERROR; + } if (varPtr == NULL) { return TCL_ERROR; } /* - * Mark the variable as a namespace variable and increment its + * Mark the variable as a namespace variable and increment its * reference count so that it will persist until its namespace is * destroyed or until the variable is unset. */ if (!TclIsVarNamespaceVar(varPtr)) { @@ -3774,14 +3903,13 @@ varPtr->refCount++; } /* * If a value was specified, set the variable to that value. - * Otherwise, if the variable is new, leave it undefined. - * (If the variable already exists and no value was specified, - * leave its value unchanged; just create the local link if - * we're in a Tcl procedure). + * Otherwise, if the variable is new, leave it undefined. (If the + * variable already exists and no value was specified, leave its value + * unchanged; just create the local link if we're in a Tcl procedure). */ if (i+1 < objc) { /* a value was specified */ varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, varName, NULL, objv[i+1], (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG)); @@ -3789,40 +3917,40 @@ return TCL_ERROR; } } /* - * If we are executing inside a Tcl procedure, create a local - * variable linked to the new namespace variable "varName". + * If we are executing inside a Tcl procedure, create a local variable + * linked to the new namespace variable "varName". */ if ((iPtr->varFramePtr != NULL) - && iPtr->varFramePtr->isProcCallFrame) { + && (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC)) { /* * varName might have a scope qualifier, but the name for the * local "link" variable must be the simple name at the tail. * * Locate tail in one pass: drop any prefix after two *or more* * consecutive ":" characters). */ - for (tail = cp = varName; *cp != '\0'; ) { + for (tail=cp=varName ; *cp!='\0' ;) { if (*cp++ == ':') { while (*cp == ':') { tail = ++cp; } } } - + /* * Create a local link "tail" to the variable "varName" in the * current namespace. */ - + result = ObjMakeUpvar(interp, (CallFrame *) NULL, /*otherP1*/ varNamePtr, /*otherP2*/ NULL, - /*otherFlags*/ TCL_NAMESPACE_ONLY, + /*otherFlags*/ TCL_NAMESPACE_ONLY, /*myName*/ tail, /*myFlags*/ 0, -1); if (result != TCL_OK) { return result; } } @@ -3833,12 +3961,12 @@ /* *---------------------------------------------------------------------- * * Tcl_UpvarObjCmd -- * - * This object-based procedure is invoked to process the "upvar" - * Tcl command. See the user documentation for details on what it does. + * This object-based procedure is invoked to process the "upvar" Tcl + * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result value. * * Side effects: @@ -3858,19 +3986,19 @@ CallFrame *framePtr; char *localName; int result; if (objc < 3) { - upvarSyntax: + upvarSyntax: Tcl_WrongNumArgs(interp, 1, objv, "?level? otherVar localVar ?otherVar localVar ...?"); return TCL_ERROR; } /* * Find the call frame containing each of the "other variables" to be - * linked to. + * linked to. */ result = TclObjGetFrame(interp, objv[1], &framePtr); if (result == -1) { return TCL_ERROR; @@ -3880,16 +4008,16 @@ goto upvarSyntax; } objv += result+1; /* - * Iterate over each (other variable, local variable) pair. - * Divide the other variable name into two parts, then call - * MakeUpvar to do all the work of linking it to the local variable. + * Iterate over each (other variable, local variable) pair. Divide the + * other variable name into two parts, then call MakeUpvar to do all the + * work of linking it to the local variable. */ - for ( ; objc > 0; objc -= 2, objv += 2) { + for (; objc>0 ; objc-=2, objv+=2) { localName = TclGetString(objv[1]); result = ObjMakeUpvar(interp, framePtr, /* othervarName */ objv[0], NULL, 0, /* myVarName */ localName, /*flags*/ 0, -1); if (result != TCL_OK) { return TCL_ERROR; @@ -3901,19 +4029,19 @@ /* *---------------------------------------------------------------------- * * NewVar -- * - * Create a new heap-allocated variable that will eventually be - * entered into a hashtable. + * Create a new heap-allocated variable that will eventually be entered + * into a hashtable. * * Results: * The return value is a pointer to the new variable structure. It is * marked as a scalar variable (and not a link or array variable). Its * value initially is NULL. The variable is not part of any hash table - * yet. Since it will be in a hashtable and not in a call frame, its - * name field is set NULL. It is initially marked as undefined. + * yet. Since it will be in a hashtable and not in a call frame, its name + * field is set NULL. It is initially marked as undefined. * * Side effects: * Storage gets allocated. * *---------------------------------------------------------------------- @@ -3939,22 +4067,21 @@ /* *---------------------------------------------------------------------- * * SetArraySearchObj -- * - * This function converts the given tcl object into one that - * has the "array search" internal type. + * This function converts the given tcl object into one that has the + * "array search" internal type. * * Results: - * TCL_OK if the conversion succeeded, and TCL_ERROR if it failed - * (when an error message will be placed in the interpreter's - * result.) + * TCL_OK if the conversion succeeded, and TCL_ERROR if it failed (when + * an error message will be placed in the interpreter's result.) * * Side effects: - * Updates the internal type and representation of the object to - * make this an array-search object. See the tclArraySearchType - * declaration above for details of the internal representation. + * Updates the internal type and representation of the object to make + * this an array-search object. See the tclArraySearchType declaration + * above for details of the internal representation. * *---------------------------------------------------------------------- */ static int @@ -3974,46 +4101,51 @@ string = TclGetString(objPtr); /* * Parse the id into the three parts separated by dashes. */ + if ((string[0] != 's') || (string[1] != '-')) { - syntax: - Tcl_AppendResult(interp, "illegal search identifier \"", string, - "\"", (char *) NULL); - return TCL_ERROR; + goto syntax; } id = strtoul(string+2, &end, 10); if ((end == (string+2)) || (*end != '-')) { goto syntax; } + /* - * Can't perform value check in this context, so place reference - * to place in string to use for the check in the object instead. + * Can't perform value check in this context, so place reference to place + * in string to use for the check in the object instead. */ + end++; offset = end - string; TclFreeIntRep(objPtr); objPtr->typePtr = &tclArraySearchType; - objPtr->internalRep.twoPtrValue.ptr1 = (VOID *)(((char *)NULL)+id); - objPtr->internalRep.twoPtrValue.ptr2 = (VOID *)(((char *)NULL)+offset); + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *)(((char *)NULL) + id); + objPtr->internalRep.twoPtrValue.ptr2 = (VOID *)(((char *)NULL) + offset); return TCL_OK; + + syntax: + Tcl_AppendResult(interp, "illegal search identifier \"", string, "\"", + (char *) NULL); + return TCL_ERROR; } /* *---------------------------------------------------------------------- * * ParseSearchId -- * - * This procedure translates from a tcl object to a pointer to an - * active array search (if there is one that matches the string). + * This procedure translates from a tcl object to a pointer to an active + * array search (if there is one that matches the string). * * Results: - * The return value is a pointer to the array search indicated - * by string, or NULL if there isn't one. If NULL is returned, - * the interp's result contains an error message. + * The return value is a pointer to the array search indicated by string, + * or NULL if there isn't one. If NULL is returned, the interp's result + * contains an error message. * * Side effects: * The tcl object might have its internal type and representation * modified. * @@ -4037,42 +4169,47 @@ ArraySearch *searchPtr; /* * Parse the id. */ + if (Tcl_ConvertToType(interp, handleObj, &tclArraySearchType) != TCL_OK) { return NULL; } + /* * Cast is safe, since always came from an int in the first place. */ + id = (int)(((char*)handleObj->internalRep.twoPtrValue.ptr1) - - ((char*)NULL)); + ((char*)NULL)); string = TclGetString(handleObj); offset = (((char*)handleObj->internalRep.twoPtrValue.ptr2) - - ((char*)NULL)); + ((char*)NULL)); + /* - * This test cannot be placed inside the Tcl_Obj machinery, since - * it is dependent on the variable context. + * This test cannot be placed inside the Tcl_Obj machinery, since it is + * dependent on the variable context. */ + if (strcmp(string+offset, varName) != 0) { Tcl_AppendResult(interp, "search identifier \"", string, "\" isn't for variable \"", varName, "\"", (char *) NULL); return NULL; } /* - * Search through the list of active searches on the interpreter - * to see if the desired one exists. + * Search through the list of active searches on the interpreter to see if + * the desired one exists. * - * Note that we cannot store the searchPtr directly in the Tcl_Obj - * as that would run into trouble when DeleteSearches() was called - * so we must scan this list every time. + * Note that we cannot store the searchPtr directly in the Tcl_Obj as that + * would run into trouble when DeleteSearches() was called so we must scan + * this list every time. */ for (searchPtr = varPtr->searchPtr; searchPtr != NULL; - searchPtr = searchPtr->nextPtr) { + searchPtr = searchPtr->nextPtr) { if (searchPtr->id == id) { return searchPtr; } } Tcl_AppendResult(interp, "couldn't find search \"", string, "\"", @@ -4083,12 +4220,12 @@ /* *---------------------------------------------------------------------- * * DeleteSearches -- * - * This procedure is called to free up all of the searches - * associated with an array variable. + * This procedure is called to free up all of the searches associated + * with an array variable. * * Results: * None. * * Side effects: @@ -4097,12 +4234,12 @@ *---------------------------------------------------------------------- */ static void DeleteSearches(arrayVarPtr) - register Var *arrayVarPtr; /* Variable whose searches are - * to be deleted. */ + register Var *arrayVarPtr; /* Variable whose searches are to be + * deleted. */ { ArraySearch *searchPtr; while (arrayVarPtr->searchPtr != NULL) { searchPtr = arrayVarPtr->searchPtr; @@ -4114,22 +4251,21 @@ /* *---------------------------------------------------------------------- * * TclDeleteVars -- * - * This procedure is called to recycle all the storage space - * associated with a table of variables. For this procedure - * to work correctly, it must not be possible for any of the - * variables in the table to be accessed from Tcl commands - * (e.g. from trace procedures). + * This procedure is called to recycle all the storage space associated + * with a table of variables. For this procedure to work correctly, it + * must not be possible for any of the variables in the table to be + * accessed from Tcl commands (e.g. from trace procedures). * * Results: * None. * * Side effects: - * Variables are deleted and trace procedures are invoked, if - * any are declared. + * Variables are deleted and trace procedures are invoked, if any are + * declared. * *---------------------------------------------------------------------- */ void @@ -4161,19 +4297,19 @@ if (Tcl_InterpDeleted(interp)) { flags |= TCL_INTERP_DESTROYED; } for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { + hPtr = Tcl_NextHashEntry(&search)) { varPtr = (Var *) Tcl_GetHashValue(hPtr); /* - * For global/upvar variables referenced in procedures, decrement - * the reference count on the variable referred to, and free - * the referenced variable if it's no longer needed. Don't delete - * the hash entry for the other variable if it's in the same table - * as us: this will happen automatically later on. + * For global/upvar variables referenced in procedures, decrement the + * reference count on the variable referred to, and free the + * referenced variable if it's no longer needed. Don't delete the hash + * entry for the other variable if it's in the same table as us: this + * will happen automatically later on. */ if (TclIsVarLink(varPtr)) { linkPtr = varPtr->value.linkPtr; linkPtr->refCount--; @@ -4188,44 +4324,42 @@ } } } /* - * Invoke traces on the variable that is being deleted, then - * free up the variable's space (no need to free the hash - * entry here, unless we're dealing with a global variable: - * the hash entries will be deleted automatically when the - * whole table is deleted). Note that we give TclCallVarTraces - * the variable's fully-qualified name so that any called - * trace procedures can refer to these variables being + * Invoke traces on the variable that is being deleted, then free up + * the variable's space (no need to free the hash entry here, unless + * we're dealing with a global variable: the hash entries will be + * deleted automatically when the whole table is deleted). Note that + * we give TclCallVarTraces the variable's fully-qualified name so + * that any called trace procedures can refer to these variables being * deleted. */ if (varPtr->tracePtr != NULL) { - objPtr = Tcl_NewObj(); - Tcl_IncrRefCount(objPtr); /* until done with traces */ + TclNewObj(objPtr); + Tcl_IncrRefCount(objPtr); /* until done with traces */ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr); TclCallVarTraces(iPtr, (Var *) NULL, varPtr, TclGetString(objPtr), NULL, flags, /* leaveErrMsg */ 0); - Tcl_DecrRefCount(objPtr); /* free no longer needed obj */ + TclDecrRefCount(objPtr); /* free no longer needed obj */ while (varPtr->tracePtr != NULL) { VarTrace *tracePtr = varPtr->tracePtr; varPtr->tracePtr = tracePtr->nextPtr; Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); } for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { + activePtr = activePtr->nextPtr) { if (activePtr->varPtr == varPtr) { activePtr->nextTracePtr = NULL; } } } - + if (TclIsVarArray(varPtr)) { - DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr, - flags); + DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr, flags); varPtr->value.tablePtr = NULL; } if (TclIsVarScalar(varPtr) && (varPtr->value.objPtr != NULL)) { objPtr = varPtr->value.objPtr; TclDecrRefCount(objPtr); @@ -4235,14 +4369,13 @@ varPtr->tracePtr = NULL; TclSetVarUndefined(varPtr); TclSetVarScalar(varPtr); /* - * If the variable was a namespace variable, decrement its - * reference count. We are in the process of destroying its - * namespace so that namespace will no longer "refer" to the - * variable. + * If the variable was a namespace variable, decrement its reference + * count. We are in the process of destroying its namespace so that + * namespace will no longer "refer" to the variable. */ if (TclIsVarNamespaceVar(varPtr)) { TclClearVarNamespaceVar(varPtr); varPtr->refCount--; @@ -4264,34 +4397,32 @@ /* *---------------------------------------------------------------------- * * TclDeleteCompiledLocalVars -- * - * This procedure is called to recycle storage space associated with - * the compiler-allocated array of local variables in a procedure call - * frame. This procedure resembles TclDeleteVars above except that each - * variable is stored in a call frame and not a hash table. For this - * procedure to work correctly, it must not be possible for any of the - * variable in the table to be accessed from Tcl commands (e.g. from - * trace procedures). + * This procedure is called to recycle storage space associated with the + * compiler-allocated array of local variables in a procedure call frame. + * This procedure resembles TclDeleteVars above except that each variable + * is stored in a call frame and not a hash table. For this procedure to + * work correctly, it must not be possible for any of the variable in the + * table to be accessed from Tcl commands (e.g. from trace procedures). * * Results: * None. * * Side effects: - * Variables are deleted and trace procedures are invoked, if - * any are declared. + * Variables are deleted and trace procedures are invoked, if any are + * declared. * *---------------------------------------------------------------------- */ void TclDeleteCompiledLocalVars(iPtr, framePtr) Interp *iPtr; /* Interpreter to which variables belong. */ - CallFrame *framePtr; /* Procedure call frame containing - * compiler-assigned local variables to - * delete. */ + CallFrame *framePtr; /* Procedure call frame containing compiler- + * assigned local variables to delete. */ { register Var *varPtr; int flags; /* Flags passed to trace procedures. */ Var *linkPtr; ActiveVarTrace *activePtr; @@ -4300,15 +4431,15 @@ flags = TCL_TRACE_UNSETS; numLocals = framePtr->numCompiledLocals; varPtr = framePtr->compiledLocals; for (i = 0; i < numLocals; i++) { /* - * For global/upvar variables referenced in procedures, decrement - * the reference count on the variable referred to, and free - * the referenced variable if it's no longer needed. Don't delete - * the hash entry for the other variable if it's in the same table - * as us: this will happen automatically later on. + * For global/upvar variables referenced in procedures, decrement the + * reference count on the variable referred to, and free the + * referenced variable if it's no longer needed. Don't delete the hash + * entry for the other variable if it's in the same table as us: this + * will happen automatically later on. */ if (TclIsVarLink(varPtr)) { linkPtr = varPtr->value.linkPtr; linkPtr->refCount--; @@ -4336,23 +4467,23 @@ VarTrace *tracePtr = varPtr->tracePtr; varPtr->tracePtr = tracePtr->nextPtr; Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); } for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { + activePtr = activePtr->nextPtr) { if (activePtr->varPtr == varPtr) { activePtr->nextTracePtr = NULL; } } } - /* + /* * Now if the variable is an array, delete its element hash table. - * Otherwise, if it's a scalar variable, decrement the ref count - * of its value. + * Otherwise, if it's a scalar variable, decrement the ref count of + * its value. */ - + if (TclIsVarArray(varPtr) && (varPtr->value.tablePtr != NULL)) { DeleteArray(iPtr, varPtr->name, varPtr, flags); } if (TclIsVarScalar(varPtr) && (varPtr->value.objPtr != NULL)) { TclDecrRefCount(varPtr->value.objPtr); @@ -4369,48 +4500,46 @@ /* *---------------------------------------------------------------------- * * DeleteArray -- * - * This procedure is called to free up everything in an array - * variable. It's the caller's responsibility to make sure - * that the array is no longer accessible before this procedure - * is called. + * This procedure is called to free up everything in an array variable. + * It's the caller's responsibility to make sure that the array is no + * longer accessible before this procedure is called. * * Results: * None. * * Side effects: * All storage associated with varPtr's array elements is deleted * (including the array's hash table). Deletion trace procedures for - * array elements are invoked, then deleted. Any pending traces for - * array elements are also deleted. + * array elements are invoked, then deleted. Any pending traces for array + * elements are also deleted. * *---------------------------------------------------------------------- */ static void DeleteArray(iPtr, arrayName, varPtr, flags) - Interp *iPtr; /* Interpreter containing array. */ - CONST char *arrayName; /* Name of array (used for trace - * callbacks). */ - Var *varPtr; /* Pointer to variable structure. */ - int flags; /* Flags to pass to TclCallVarTraces: - * TCL_TRACE_UNSETS and sometimes - * TCL_INTERP_DESTROYED, - * TCL_NAMESPACE_ONLY, or - * TCL_GLOBAL_ONLY. */ + Interp *iPtr; /* Interpreter containing array. */ + CONST char *arrayName; /* Name of array (used for trace + * callbacks). */ + Var *varPtr; /* Pointer to variable structure. */ + int flags; /* Flags to pass to TclCallVarTraces: + * TCL_TRACE_UNSETS and sometimes + * TCL_INTERP_DESTROYED, TCL_NAMESPACE_ONLY, + * or TCL_GLOBAL_ONLY. */ { Tcl_HashSearch search; register Tcl_HashEntry *hPtr; register Var *elPtr; ActiveVarTrace *activePtr; Tcl_Obj *objPtr; DeleteSearches(varPtr); for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { elPtr = (Var *) Tcl_GetHashValue(hPtr); if (TclIsVarScalar(elPtr) && (elPtr->value.objPtr != NULL)) { objPtr = elPtr->value.objPtr; TclDecrRefCount(objPtr); elPtr->value.objPtr = NULL; @@ -4421,15 +4550,16 @@ TclCallVarTraces(iPtr, (Var *) NULL, elPtr, arrayName, Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags, /* leaveErrMsg */ 0); while (elPtr->tracePtr != NULL) { VarTrace *tracePtr = elPtr->tracePtr; + elPtr->tracePtr = tracePtr->nextPtr; - Tcl_EventuallyFree((ClientData) tracePtr,TCL_DYNAMIC); + Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); } for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { + activePtr = activePtr->nextPtr) { if (activePtr->varPtr == elPtr) { activePtr->nextTracePtr = NULL; } } } @@ -4436,14 +4566,13 @@ TclSetVarUndefined(elPtr); TclSetVarScalar(elPtr); /* * Even though array elements are not supposed to be namespace - * variables, some combinations of [upvar] and [variable] may - * create such beasts - see [Bug 604239]. This is necessary to - * avoid leaking the corresponding Var struct, and is otherwise - * harmless. + * variables, some combinations of [upvar] and [variable] may create + * such beasts - see [Bug 604239]. This is necessary to avoid leaking + * the corresponding Var struct, and is otherwise harmless. */ if (TclIsVarNamespaceVar(elPtr)) { TclClearVarNamespaceVar(elPtr); elPtr->refCount--; @@ -4459,34 +4588,33 @@ /* *---------------------------------------------------------------------- * * TclCleanupVar -- * - * This procedure is called when it looks like it may be OK to free up - * a variable's storage. If the variable is in a hashtable, its Var + * This procedure is called when it looks like it may be OK to free up a + * variable's storage. If the variable is in a hashtable, its Var * structure and hash table entry will be freed along with those of its - * containing array, if any. This procedure is called, for example, - * when a trace on a variable deletes a variable. + * containing array, if any. This procedure is called, for example, when + * a trace on a variable deletes a variable. * * Results: * None. * * Side effects: * If the variable (or its containing array) really is dead and in a - * hashtable, then its Var structure, and possibly its hash table - * entry, is freed up. + * hashtable, then its Var structure, and possibly its hash table entry, + * is freed up. * *---------------------------------------------------------------------- */ void TclCleanupVar(varPtr, arrayPtr) - Var *varPtr; /* Pointer to variable that may be a - * candidate for being expunged. */ - Var *arrayPtr; /* Array that contains the variable, or - * NULL if this variable isn't an array - * element. */ + Var *varPtr; /* Pointer to variable that may be a candidate + * for being expunged. */ + Var *arrayPtr; /* Array that contains the variable, or NULL + * if this variable isn't an array element. */ { if (TclIsVarUndefined(varPtr) && (varPtr->refCount == 0) && (varPtr->tracePtr == NULL) && (varPtr->flags & VAR_IN_HASHTABLE)) { if (varPtr->hPtr != NULL) { @@ -4495,11 +4623,11 @@ ckfree((char *) varPtr); } if (arrayPtr != NULL) { if (TclIsVarUndefined(arrayPtr) && (arrayPtr->refCount == 0) && (arrayPtr->tracePtr == NULL) - && (arrayPtr->flags & VAR_IN_HASHTABLE)) { + && (arrayPtr->flags & VAR_IN_HASHTABLE)) { if (arrayPtr->hPtr != NULL) { Tcl_DeleteHashEntry(arrayPtr->hPtr); } ckfree((char *) arrayPtr); } @@ -4508,38 +4636,38 @@ /* *---------------------------------------------------------------------- * * TclVarErrMsg -- * - * Generate a reasonable error message describing why a variable - * operation failed. + * Generate a reasonable error message describing why a variable + * operation failed. * * Results: - * None. + * None. * * Side effects: - * The interp's result is set to hold a message identifying the - * variable given by part1 and part2 and describing why the - * variable operation failed. + * The interp's result is set to hold a message identifying the variable + * given by part1 and part2 and describing why the variable operation + * failed. * *---------------------------------------------------------------------- */ void TclVarErrMsg(interp, part1, part2, operation, reason) - Tcl_Interp *interp; /* Interpreter in which to record message. */ + Tcl_Interp *interp; /* Interpreter in which to record message. */ CONST char *part1; CONST char *part2; /* Variable's two-part name. */ - CONST char *operation; /* String describing operation that failed, - * e.g. "read", "set", or "unset". */ - CONST char *reason; /* String describing why operation failed. */ + CONST char *operation; /* String describing operation that failed, + * e.g. "read", "set", or "unset". */ + CONST char *reason; /* String describing why operation failed. */ { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can't ", operation, " \"", part1, (char *) NULL); if (part2 != NULL) { - Tcl_AppendResult(interp, "(", part2, ")", (char *) NULL); + Tcl_AppendResult(interp, "(", part2, ")", (char *) NULL); } Tcl_AppendResult(interp, "\": ", reason, (char *) NULL); } /* @@ -4549,12 +4677,11 @@ * *---------------------------------------------------------------------- */ /* - * Panic functions that should never be called in normal - * operation. + * Panic functions that should never be called in normal operation. */ static void PanicOnUpdateVarName(objPtr) Tcl_Obj *objPtr; @@ -4571,11 +4698,11 @@ Tcl_Panic("ERROR: setFromAnyProc of type %s should not be called.", objPtr->typePtr->name); return TCL_ERROR; } -/* +/* * localVarName - * * INTERNALREP DEFINITION: * longValue = index into locals table */ @@ -4584,29 +4711,28 @@ DupLocalVarName(srcPtr, dupPtr) Tcl_Obj *srcPtr; Tcl_Obj *dupPtr; { dupPtr->internalRep.longValue = srcPtr->internalRep.longValue; - dupPtr->typePtr = &tclLocalVarNameType; + dupPtr->typePtr = &localVarNameType; } #if ENABLE_NS_VARNAME_CACHING -/* +/* * nsVarName - * * INTERNALREP DEFINITION: - * twoPtrValue.ptr1: pointer to the namespace containing the - * reference. - * twoPtrValue.ptr2: pointer to the corresponding Var + * twoPtrValue.ptr1: pointer to the namespace containing the reference. + * twoPtrValue.ptr2: pointer to the corresponding Var */ -static void +static void FreeNsVarName(objPtr) Tcl_Obj *objPtr; { register Var *varPtr = (Var *) objPtr->internalRep.twoPtrValue.ptr2; - + varPtr->refCount--; if (TclIsVarUndefined(varPtr) && (varPtr->refCount == 0)) { TclCleanupVar(varPtr, NULL); } } @@ -4624,29 +4750,27 @@ varPtr->refCount++; dupPtr->typePtr = &tclNsVarNameType; } #endif -/* +/* * parsedVarName - * * INTERNALREP DEFINITION: - * twoPtrValue.ptr1 = pointer to the array name Tcl_Obj - * (NULL if scalar) - * twoPtrValue.ptr2 = pointer to the element name string - * (owned by this Tcl_Obj), or NULL if - * it is a scalar variable + * twoPtrValue.ptr1 = pointer to the array name Tcl_Obj (NULL if scalar) + * twoPtrValue.ptr2 = pointer to the element name string (owned by this + * Tcl_Obj), or NULL if it is a scalar variable */ -static void +static void FreeParsedVarName(objPtr) Tcl_Obj *objPtr; { - register Tcl_Obj *arrayPtr = - (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr1; + register Tcl_Obj *arrayPtr = (Tcl_Obj *) + objPtr->internalRep.twoPtrValue.ptr1; register char *elem = (char *) objPtr->internalRep.twoPtrValue.ptr2; - + if (arrayPtr != NULL) { TclDecrRefCount(arrayPtr); ckfree(elem); } } @@ -4654,12 +4778,12 @@ static void DupParsedVarName(srcPtr, dupPtr) Tcl_Obj *srcPtr; Tcl_Obj *dupPtr; { - register Tcl_Obj *arrayPtr = - (Tcl_Obj *) srcPtr->internalRep.twoPtrValue.ptr1; + register Tcl_Obj *arrayPtr = (Tcl_Obj *) + srcPtr->internalRep.twoPtrValue.ptr1; register char *elem = (char *) srcPtr->internalRep.twoPtrValue.ptr2; char *elemCopy; unsigned int elemLen; if (arrayPtr != NULL) { @@ -4685,15 +4809,16 @@ char *part1, *p; int len1, len2, totalLen; if (arrayPtr == NULL) { /* - * This is a parsed scalar name: what is it - * doing here? + * This is a parsed scalar name: what is it doing here? */ + Tcl_Panic("ERROR: scalar parsedVarName without a string rep.\n"); } + part1 = Tcl_GetStringFromObj(arrayPtr, &len1); len2 = strlen(part2); totalLen = len1 + len2 + 2; p = ckalloc((unsigned int) totalLen + 1); @@ -4706,5 +4831,13 @@ memcpy(p, part2, (unsigned int) len2); p += len2; *p++ = ')'; *p = '\0'; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ ADDED generic/tommath.h Index: generic/tommath.h ================================================================== --- /dev/null +++ generic/tommath.h @@ -0,0 +1,608 @@ +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ +#ifndef BN_H_ +#define BN_H_ + +#ifdef TCL_TOMMATH +#include +#endif +#ifndef TOMMATH_STORAGE_CLASS +#define TOMMATH_STORAGE_CLASS extern +#endif + +#include +#include +#include +#include +#include + +#include + +#ifndef MIN + #define MIN(x,y) ((x)<(y)?(x):(y)) +#endif + +#ifndef MAX + #define MAX(x,y) ((x)>(y)?(x):(y)) +#endif + +#ifdef __cplusplus +extern "C" { + +/* C++ compilers don't like assigning void * to mp_digit * */ +#define OPT_CAST(x) (x *) + +#else + +/* C on the other hand doesn't care */ +#define OPT_CAST(x) + +#endif + + +/* detect 64-bit mode if possible */ +#if defined(__x86_64__) + #if !(defined(MP_64BIT) && defined(MP_16BIT) && defined(MP_8BIT)) + #define MP_64BIT + #endif +#endif + +/* some default configurations. + * + * A "mp_digit" must be able to hold DIGIT_BIT + 1 bits + * A "mp_word" must be able to hold 2*DIGIT_BIT + 1 bits + * + * At the very least a mp_digit must be able to hold 7 bits + * [any size beyond that is ok provided it doesn't overflow the data type] + */ +#ifdef MP_8BIT +#ifndef MP_DIGIT_DECLARED + typedef unsigned char mp_digit; +#define MP_DIGIT_DECLARED +#endif + typedef unsigned short mp_word; +#elif defined(MP_16BIT) +#ifndef MP_DIGIT_DECLARED + typedef unsigned short mp_digit; +#define MP_DIGIT_DECLARED +#endif + typedef unsigned long mp_word; +#elif defined(MP_64BIT) + /* for GCC only on supported platforms */ +#ifndef CRYPT + typedef unsigned long long ulong64; + typedef signed long long long64; +#endif + +#ifndef MP_DIGIT_DECLARED + typedef unsigned long mp_digit; +#define MP_DIGIT_DECLARED +#endif + typedef unsigned long mp_word __attribute__ ((mode(TI))); + + #define DIGIT_BIT 60 +#else + /* this is the default case, 28-bit digits */ + + /* this is to make porting into LibTomCrypt easier :-) */ +#ifndef CRYPT + #if defined(_MSC_VER) || defined(__BORLANDC__) + typedef unsigned __int64 ulong64; + typedef signed __int64 long64; + #else + typedef unsigned long long ulong64; + typedef signed long long long64; + #endif +#endif + +#ifndef MP_DIGIT_DECLARED + typedef unsigned long mp_digit; +#define MP_DIGIT_DECLARED +#endif + typedef ulong64 mp_word; + +#ifdef MP_31BIT + /* this is an extension that uses 31-bit digits */ + #define DIGIT_BIT 31 +#else + /* default case is 28-bit digits, defines MP_28BIT as a handy macro to test */ + #define DIGIT_BIT 28 + #define MP_28BIT +#endif +#endif + +/* define heap macros */ +#ifndef CRYPT + /* default to libc stuff */ + #ifndef XMALLOC + #define XMALLOC malloc + #define XFREE free + #define XREALLOC realloc + #define XCALLOC calloc + #else + /* prototypes for our heap functions */ + extern void *XMALLOC(size_t n); + extern void *XREALLOC(void *p, size_t n); + extern void *XCALLOC(size_t n, size_t s); + extern void XFREE(void *p); + #endif +#endif + + +/* otherwise the bits per digit is calculated automatically from the size of a mp_digit */ +#ifndef DIGIT_BIT + #define DIGIT_BIT ((int)((CHAR_BIT * sizeof(mp_digit) - 1))) /* bits per digit */ +#endif + +#define MP_DIGIT_BIT DIGIT_BIT +#define MP_MASK ((((mp_digit)1)<<((mp_digit)DIGIT_BIT))-((mp_digit)1)) +#define MP_DIGIT_MAX MP_MASK + +/* equalities */ +#define MP_LT -1 /* less than */ +#define MP_EQ 0 /* equal to */ +#define MP_GT 1 /* greater than */ + +#define MP_ZPOS 0 /* positive integer */ +#define MP_NEG 1 /* negative */ + +#define MP_OKAY 0 /* ok result */ +#define MP_MEM -2 /* out of mem */ +#define MP_VAL -3 /* invalid input */ +#define MP_RANGE MP_VAL + +#define MP_YES 1 /* yes response */ +#define MP_NO 0 /* no response */ + +/* Primality generation flags */ +#define LTM_PRIME_BBS 0x0001 /* BBS style prime */ +#define LTM_PRIME_SAFE 0x0002 /* Safe prime (p-1)/2 == prime */ +#define LTM_PRIME_2MSB_ON 0x0008 /* force 2nd MSB to 1 */ + +typedef int mp_err; + +/* you'll have to tune these... */ +extern int KARATSUBA_MUL_CUTOFF, + KARATSUBA_SQR_CUTOFF, + TOOM_MUL_CUTOFF, + TOOM_SQR_CUTOFF; + +/* define this to use lower memory usage routines (exptmods mostly) */ +/* #define MP_LOW_MEM */ + +/* default precision */ +#ifndef MP_PREC + #ifndef MP_LOW_MEM + #define MP_PREC 32 /* default digits of precision */ + #else + #define MP_PREC 8 /* default digits of precision */ + #endif +#endif + +/* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */ +#define MP_WARRAY (1 << (sizeof(mp_word) * CHAR_BIT - 2 * DIGIT_BIT + 1)) + +/* the infamous mp_int structure */ +#ifndef MP_INT_DECLARED +#define MP_INT_DECLARED +typedef struct mp_int mp_int; +#endif +struct mp_int { + int used, alloc, sign; + mp_digit *dp; +}; + +/* callback for mp_prime_random, should fill dst with random bytes and return how many read [upto len] */ +typedef int ltm_prime_callback(unsigned char *dst, int len, void *dat); + + +#define USED(m) ((m)->used) +#define DIGIT(m,k) ((m)->dp[(k)]) +#define SIGN(m) ((m)->sign) + +/* error code to char* string */ +TOMMATH_STORAGE_CLASS char *mp_error_to_string(int code); + +/* ---> init and deinit bignum functions <--- */ +/* init a bignum */ +TOMMATH_STORAGE_CLASS int mp_init(mp_int *a); + +/* free a bignum */ +TOMMATH_STORAGE_CLASS void mp_clear(mp_int *a); + +/* init a null terminated series of arguments */ +TOMMATH_STORAGE_CLASS int mp_init_multi(mp_int *mp, ...); + +/* clear a null terminated series of arguments */ +TOMMATH_STORAGE_CLASS void mp_clear_multi(mp_int *mp, ...); + +/* exchange two ints */ +TOMMATH_STORAGE_CLASS void mp_exch(mp_int *a, mp_int *b); + +/* shrink ram required for a bignum */ +TOMMATH_STORAGE_CLASS int mp_shrink(mp_int *a); + +/* grow an int to a given size */ +TOMMATH_STORAGE_CLASS int mp_grow(mp_int *a, int size); + +/* init to a given number of digits */ +TOMMATH_STORAGE_CLASS int mp_init_size(mp_int *a, int size); + +/* ---> Basic Manipulations <--- */ +#define mp_iszero(a) (((a)->used == 0) ? MP_YES : MP_NO) +#define mp_iseven(a) (((a)->used == 0 || (((a)->dp[0] & 1) == 0)) ? MP_YES : MP_NO) +#define mp_isodd(a) (((a)->used > 0 && (((a)->dp[0] & 1) == 1)) ? MP_YES : MP_NO) + +/* set to zero */ +TOMMATH_STORAGE_CLASS void mp_zero(mp_int *a); + +/* set to a digit */ +TOMMATH_STORAGE_CLASS void mp_set(mp_int *a, mp_digit b); + +/* set a 32-bit const */ +TOMMATH_STORAGE_CLASS int mp_set_int(mp_int *a, unsigned long b); + +/* get a 32-bit value */ +unsigned long mp_get_int(mp_int * a); + +/* initialize and set a digit */ +TOMMATH_STORAGE_CLASS int mp_init_set (mp_int * a, mp_digit b); + +/* initialize and set 32-bit value */ +TOMMATH_STORAGE_CLASS int mp_init_set_int (mp_int * a, unsigned long b); + +/* copy, b = a */ +TOMMATH_STORAGE_CLASS int mp_copy(mp_int *a, mp_int *b); + +/* inits and copies, a = b */ +TOMMATH_STORAGE_CLASS int mp_init_copy(mp_int *a, mp_int *b); + +/* trim unused digits */ +TOMMATH_STORAGE_CLASS void mp_clamp(mp_int *a); + +/* ---> digit manipulation <--- */ + +/* right shift by "b" digits */ +TOMMATH_STORAGE_CLASS void mp_rshd(mp_int *a, int b); + +/* left shift by "b" digits */ +TOMMATH_STORAGE_CLASS int mp_lshd(mp_int *a, int b); + +/* c = a / 2**b */ +TOMMATH_STORAGE_CLASS int mp_div_2d(mp_int *a, int b, mp_int *c, mp_int *d); + +/* b = a/2 */ +TOMMATH_STORAGE_CLASS int mp_div_2(mp_int *a, mp_int *b); + +/* c = a * 2**b */ +TOMMATH_STORAGE_CLASS int mp_mul_2d(mp_int *a, int b, mp_int *c); + +/* b = a*2 */ +TOMMATH_STORAGE_CLASS int mp_mul_2(mp_int *a, mp_int *b); + +/* c = a mod 2**d */ +TOMMATH_STORAGE_CLASS int mp_mod_2d(mp_int *a, int b, mp_int *c); + +/* computes a = 2**b */ +TOMMATH_STORAGE_CLASS int mp_2expt(mp_int *a, int b); + +/* Counts the number of lsbs which are zero before the first zero bit */ +TOMMATH_STORAGE_CLASS int mp_cnt_lsb(mp_int *a); + +/* I Love Earth! */ + +/* makes a pseudo-random int of a given size */ +TOMMATH_STORAGE_CLASS int mp_rand(mp_int *a, int digits); + +/* ---> binary operations <--- */ +/* c = a XOR b */ +TOMMATH_STORAGE_CLASS int mp_xor(mp_int *a, mp_int *b, mp_int *c); + +/* c = a OR b */ +TOMMATH_STORAGE_CLASS int mp_or(mp_int *a, mp_int *b, mp_int *c); + +/* c = a AND b */ +TOMMATH_STORAGE_CLASS int mp_and(mp_int *a, mp_int *b, mp_int *c); + +/* ---> Basic arithmetic <--- */ + +/* b = -a */ +TOMMATH_STORAGE_CLASS int mp_neg(mp_int *a, mp_int *b); + +/* b = |a| */ +TOMMATH_STORAGE_CLASS int mp_abs(mp_int *a, mp_int *b); + +/* compare a to b */ +TOMMATH_STORAGE_CLASS int mp_cmp(mp_int *a, mp_int *b); + +/* compare |a| to |b| */ +TOMMATH_STORAGE_CLASS int mp_cmp_mag(mp_int *a, mp_int *b); + +/* c = a + b */ +TOMMATH_STORAGE_CLASS int mp_add(mp_int *a, mp_int *b, mp_int *c); + +/* c = a - b */ +TOMMATH_STORAGE_CLASS int mp_sub(mp_int *a, mp_int *b, mp_int *c); + +/* c = a * b */ +TOMMATH_STORAGE_CLASS int mp_mul(mp_int *a, mp_int *b, mp_int *c); + +/* b = a*a */ +TOMMATH_STORAGE_CLASS int mp_sqr(mp_int *a, mp_int *b); + +/* a/b => cb + d == a */ +TOMMATH_STORAGE_CLASS int mp_div(mp_int *a, mp_int *b, mp_int *c, mp_int *d); + +/* c = a mod b, 0 <= c < b */ +TOMMATH_STORAGE_CLASS int mp_mod(mp_int *a, mp_int *b, mp_int *c); + +/* ---> single digit functions <--- */ + +/* compare against a single digit */ +TOMMATH_STORAGE_CLASS int mp_cmp_d(mp_int *a, mp_digit b); + +/* c = a + b */ +TOMMATH_STORAGE_CLASS int mp_add_d(mp_int *a, mp_digit b, mp_int *c); + +/* c = a - b */ +TOMMATH_STORAGE_CLASS int mp_sub_d(mp_int *a, mp_digit b, mp_int *c); + +/* c = a * b */ +TOMMATH_STORAGE_CLASS int mp_mul_d(mp_int *a, mp_digit b, mp_int *c); + +/* a/b => cb + d == a */ +TOMMATH_STORAGE_CLASS int mp_div_d(mp_int *a, mp_digit b, mp_int *c, mp_digit *d); + +/* a/3 => 3c + d == a */ +TOMMATH_STORAGE_CLASS int mp_div_3(mp_int *a, mp_int *c, mp_digit *d); + +/* c = a**b */ +TOMMATH_STORAGE_CLASS int mp_expt_d(mp_int *a, mp_digit b, mp_int *c); + +/* c = a mod b, 0 <= c < b */ +TOMMATH_STORAGE_CLASS int mp_mod_d(mp_int *a, mp_digit b, mp_digit *c); + +/* ---> number theory <--- */ + +/* d = a + b (mod c) */ +TOMMATH_STORAGE_CLASS int mp_addmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); + +/* d = a - b (mod c) */ +TOMMATH_STORAGE_CLASS int mp_submod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); + +/* d = a * b (mod c) */ +TOMMATH_STORAGE_CLASS int mp_mulmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); + +/* c = a * a (mod b) */ +TOMMATH_STORAGE_CLASS int mp_sqrmod(mp_int *a, mp_int *b, mp_int *c); + +/* c = 1/a (mod b) */ +TOMMATH_STORAGE_CLASS int mp_invmod(mp_int *a, mp_int *b, mp_int *c); + +/* c = (a, b) */ +TOMMATH_STORAGE_CLASS int mp_gcd(mp_int *a, mp_int *b, mp_int *c); + +/* produces value such that U1*a + U2*b = U3 */ +TOMMATH_STORAGE_CLASS int mp_exteuclid(mp_int *a, mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3); + +/* c = [a, b] or (a*b)/(a, b) */ +TOMMATH_STORAGE_CLASS int mp_lcm(mp_int *a, mp_int *b, mp_int *c); + +/* finds one of the b'th root of a, such that |c|**b <= |a| + * + * returns error if a < 0 and b is even + */ +TOMMATH_STORAGE_CLASS int mp_n_root(mp_int *a, mp_digit b, mp_int *c); + +/* special sqrt algo */ +TOMMATH_STORAGE_CLASS int mp_sqrt(mp_int *arg, mp_int *ret); + +/* is number a square? */ +TOMMATH_STORAGE_CLASS int mp_is_square(mp_int *arg, int *ret); + +/* computes the jacobi c = (a | n) (or Legendre if b is prime) */ +TOMMATH_STORAGE_CLASS int mp_jacobi(mp_int *a, mp_int *n, int *c); + +/* used to setup the Barrett reduction for a given modulus b */ +TOMMATH_STORAGE_CLASS int mp_reduce_setup(mp_int *a, mp_int *b); + +/* Barrett Reduction, computes a (mod b) with a precomputed value c + * + * Assumes that 0 < a <= b*b, note if 0 > a > -(b*b) then you can merely + * compute the reduction as -1 * mp_reduce(mp_abs(a)) [pseudo code]. + */ +TOMMATH_STORAGE_CLASS int mp_reduce(mp_int *a, mp_int *b, mp_int *c); + +/* setups the montgomery reduction */ +TOMMATH_STORAGE_CLASS int mp_montgomery_setup(mp_int *a, mp_digit *mp); + +/* computes a = B**n mod b without division or multiplication useful for + * normalizing numbers in a Montgomery system. + */ +TOMMATH_STORAGE_CLASS int mp_montgomery_calc_normalization(mp_int *a, mp_int *b); + +/* computes x/R == x (mod N) via Montgomery Reduction */ +TOMMATH_STORAGE_CLASS int mp_montgomery_reduce(mp_int *a, mp_int *m, mp_digit mp); + +/* returns 1 if a is a valid DR modulus */ +TOMMATH_STORAGE_CLASS int mp_dr_is_modulus(mp_int *a); + +/* sets the value of "d" required for mp_dr_reduce */ +TOMMATH_STORAGE_CLASS void mp_dr_setup(mp_int *a, mp_digit *d); + +/* reduces a modulo b using the Diminished Radix method */ +TOMMATH_STORAGE_CLASS int mp_dr_reduce(mp_int *a, mp_int *b, mp_digit mp); + +/* returns true if a can be reduced with mp_reduce_2k */ +TOMMATH_STORAGE_CLASS int mp_reduce_is_2k(mp_int *a); + +/* determines k value for 2k reduction */ +TOMMATH_STORAGE_CLASS int mp_reduce_2k_setup(mp_int *a, mp_digit *d); + +/* reduces a modulo b where b is of the form 2**p - k [0 <= a] */ +TOMMATH_STORAGE_CLASS int mp_reduce_2k(mp_int *a, mp_int *n, mp_digit d); + +/* returns true if a can be reduced with mp_reduce_2k_l */ +TOMMATH_STORAGE_CLASS int mp_reduce_is_2k_l(mp_int *a); + +/* determines k value for 2k reduction */ +TOMMATH_STORAGE_CLASS int mp_reduce_2k_setup_l(mp_int *a, mp_int *d); + +/* reduces a modulo b where b is of the form 2**p - k [0 <= a] */ +TOMMATH_STORAGE_CLASS int mp_reduce_2k_l(mp_int *a, mp_int *n, mp_int *d); + +/* d = a**b (mod c) */ +TOMMATH_STORAGE_CLASS int mp_exptmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); + +/* ---> Primes <--- */ + +/* number of primes */ +#ifdef MP_8BIT + #define PRIME_SIZE 31 +#else + #define PRIME_SIZE 256 +#endif + +/* table of first PRIME_SIZE primes */ +extern const mp_digit ltm_prime_tab[]; + +/* result=1 if a is divisible by one of the first PRIME_SIZE primes */ +TOMMATH_STORAGE_CLASS int mp_prime_is_divisible(mp_int *a, int *result); + +/* performs one Fermat test of "a" using base "b". + * Sets result to 0 if composite or 1 if probable prime + */ +TOMMATH_STORAGE_CLASS int mp_prime_fermat(mp_int *a, mp_int *b, int *result); + +/* performs one Miller-Rabin test of "a" using base "b". + * Sets result to 0 if composite or 1 if probable prime + */ +TOMMATH_STORAGE_CLASS int mp_prime_miller_rabin(mp_int *a, mp_int *b, int *result); + +/* This gives [for a given bit size] the number of trials required + * such that Miller-Rabin gives a prob of failure lower than 2^-96 + */ +TOMMATH_STORAGE_CLASS int mp_prime_rabin_miller_trials(int size); + +/* performs t rounds of Miller-Rabin on "a" using the first + * t prime bases. Also performs an initial sieve of trial + * division. Determines if "a" is prime with probability + * of error no more than (1/4)**t. + * + * Sets result to 1 if probably prime, 0 otherwise + */ +TOMMATH_STORAGE_CLASS int mp_prime_is_prime(mp_int *a, int t, int *result); + +/* finds the next prime after the number "a" using "t" trials + * of Miller-Rabin. + * + * bbs_style = 1 means the prime must be congruent to 3 mod 4 + */ +TOMMATH_STORAGE_CLASS int mp_prime_next_prime(mp_int *a, int t, int bbs_style); + +/* makes a truly random prime of a given size (bytes), + * call with bbs = 1 if you want it to be congruent to 3 mod 4 + * + * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can + * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself + * so it can be NULL + * + * The prime generated will be larger than 2^(8*size). + */ +#define mp_prime_random(a, t, size, bbs, cb, dat) mp_prime_random_ex(a, t, ((size) * 8) + 1, (bbs==1)?LTM_PRIME_BBS:0, cb, dat) + +/* makes a truly random prime of a given size (bits), + * + * Flags are as follows: + * + * LTM_PRIME_BBS - make prime congruent to 3 mod 4 + * LTM_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies LTM_PRIME_BBS) + * LTM_PRIME_2MSB_OFF - make the 2nd highest bit zero + * LTM_PRIME_2MSB_ON - make the 2nd highest bit one + * + * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can + * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself + * so it can be NULL + * + */ +TOMMATH_STORAGE_CLASS int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback cb, void *dat); + +/* ---> radix conversion <--- */ +TOMMATH_STORAGE_CLASS int mp_count_bits(mp_int *a); + +TOMMATH_STORAGE_CLASS int mp_unsigned_bin_size(mp_int *a); +TOMMATH_STORAGE_CLASS int mp_read_unsigned_bin(mp_int *a, const unsigned char *b, int c); +TOMMATH_STORAGE_CLASS int mp_to_unsigned_bin(mp_int *a, unsigned char *b); +TOMMATH_STORAGE_CLASS int mp_to_unsigned_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen); + +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_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); +TOMMATH_STORAGE_CLASS int mp_toradix(mp_int *a, char *str, int radix); +TOMMATH_STORAGE_CLASS int mp_toradix_n(mp_int * a, char *str, int radix, int maxlen); +TOMMATH_STORAGE_CLASS int mp_radix_size(mp_int *a, int radix, int *size); + +TOMMATH_STORAGE_CLASS int mp_fread(mp_int *a, int radix, FILE *stream); +TOMMATH_STORAGE_CLASS int mp_fwrite(mp_int *a, int radix, FILE *stream); + +#define mp_read_raw(mp, str, len) mp_read_signed_bin((mp), (str), (len)) +#define mp_raw_size(mp) mp_signed_bin_size(mp) +#define mp_toraw(mp, str) mp_to_signed_bin((mp), (str)) +#define mp_read_mag(mp, str, len) mp_read_unsigned_bin((mp), (str), (len)) +#define mp_mag_size(mp) mp_unsigned_bin_size(mp) +#define mp_tomag(mp, str) mp_to_unsigned_bin((mp), (str)) + +#define mp_tobinary(M, S) mp_toradix((M), (S), 2) +#define mp_tooctal(M, S) mp_toradix((M), (S), 8) +#define mp_todecimal(M, S) mp_toradix((M), (S), 10) +#define mp_tohex(M, S) mp_toradix((M), (S), 16) + +/* lowlevel functions, do not call! */ +TOMMATH_STORAGE_CLASS int s_mp_add(mp_int *a, mp_int *b, mp_int *c); +TOMMATH_STORAGE_CLASS int s_mp_sub(mp_int *a, mp_int *b, mp_int *c); +#define s_mp_mul(a, b, c) s_mp_mul_digs(a, b, c, (a)->used + (b)->used + 1) +TOMMATH_STORAGE_CLASS int fast_s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs); +TOMMATH_STORAGE_CLASS int s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs); +TOMMATH_STORAGE_CLASS int fast_s_mp_mul_high_digs(mp_int *a, mp_int *b, mp_int *c, int digs); +TOMMATH_STORAGE_CLASS int s_mp_mul_high_digs(mp_int *a, mp_int *b, mp_int *c, int digs); +TOMMATH_STORAGE_CLASS int fast_s_mp_sqr(mp_int *a, mp_int *b); +TOMMATH_STORAGE_CLASS int s_mp_sqr(mp_int *a, mp_int *b); +TOMMATH_STORAGE_CLASS int mp_karatsuba_mul(mp_int *a, mp_int *b, mp_int *c); +TOMMATH_STORAGE_CLASS int mp_toom_mul(mp_int *a, mp_int *b, mp_int *c); +TOMMATH_STORAGE_CLASS int mp_karatsuba_sqr(mp_int *a, mp_int *b); +TOMMATH_STORAGE_CLASS int mp_toom_sqr(mp_int *a, mp_int *b); +TOMMATH_STORAGE_CLASS int fast_mp_invmod(mp_int *a, mp_int *b, mp_int *c); +TOMMATH_STORAGE_CLASS int mp_invmod_slow (mp_int * a, mp_int * b, mp_int * c); +TOMMATH_STORAGE_CLASS int fast_mp_montgomery_reduce(mp_int *a, mp_int *m, mp_digit mp); +TOMMATH_STORAGE_CLASS int mp_exptmod_fast(mp_int *G, mp_int *X, mp_int *P, mp_int *Y, int mode); +TOMMATH_STORAGE_CLASS int s_mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y, int mode); +TOMMATH_STORAGE_CLASS void bn_reverse(unsigned char *s, int len); + +extern const char *mp_s_rmap; + +#ifdef __cplusplus + } +#endif + +#endif + + +/* $Source: /root/tcl/repos-to-convert/tcl/generic/tommath.h,v $ */ +/* $Revision: 1.1.2.4 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ + Index: library/auto.tcl ================================================================== --- library/auto.tcl +++ library/auto.tcl @@ -1,11 +1,11 @@ # auto.tcl -- # # utility procs formerly in init.tcl dealing with auto execution # of commands and can be auto loaded themselves. # -# RCS: @(#) $Id: auto.tcl,v 1.21 2004/12/01 22:14:20 dgp Exp $ +# RCS: @(#) $Id: auto.tcl,v 1.21.2.3 2005/08/02 18:16:14 dgp Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1998 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution @@ -14,27 +14,31 @@ # auto_reset -- # # Destroy all cached information for auto-loading and auto-execution, # so that the information gets recomputed the next time it's needed. -# Also delete any procedures that are listed in the auto-load index -# except those defined in this file. +# Also delete any commands that are listed in the auto-load index. # # Arguments: # None. proc auto_reset {} { - variable ::tcl::auto_oldpath - global auto_execs auto_index - foreach p [info procs] { - if {[info exists auto_index($p)]} { - rename $p {} + if {[array exists ::auto_index]} { + foreach cmdName [array names ::auto_index] { + set fqcn [namespace which $cmdName] + if {$fqcn eq ""} {continue} + rename $fqcn {} + } + } + unset -nocomplain ::auto_execs ::auto_index ::tcl::auto_oldpath + if {[catch {llength $::auto_path}]} { + set ::auto_path [list [info library]] + } else { + if {[info library] ni $::auto_path} { + lappend ::auto_path [info library] } } - catch {unset auto_execs} - catch {unset auto_index} - catch {unset auto_oldpath} } # tcl_findLibrary -- # # This is a utility for extensions that searches for a library directory @@ -56,12 +60,11 @@ set dirs {} set errors {} # The C application may have hardwired a path, which we honor - set variableSet [info exists the_library] - if {$variableSet && $the_library ne ""} { + if {[info exists the_library] && $the_library ne ""} { lappend dirs $the_library } else { # Do the canonical search @@ -151,13 +154,11 @@ append errors "$file: $msg\n" append errors [dict get $opts -errorinfo]\n } } } - if {!$variableSet} { - unset the_library - } + unset -nocomplain the_library set msg "Can't find a usable $initScript in the following directories: \n" append msg " $dirs\n\n" append msg "$errors\n\n" append msg "This probably means that $basename wasn't installed properly.\n" error $msg @@ -209,11 +210,11 @@ if {[llength $args] == 0} { set args *.tcl } auto_mkindex_parser::init - foreach file [glob {expand}$args] { + foreach file [glob -- {expand}$args] { if {[catch {auto_mkindex_parser::mkindex $file} msg opts] == 0} { append index $msg } else { cd $oldDir return -options $opts $msg @@ -242,11 +243,11 @@ append index "# element name is the name of a command and the value is\n" append index "# a script that loads the command.\n\n" if {[llength $args] == 0} { set args *.tcl } - foreach file [glob {expand}$args] { + foreach file [glob -- {expand}$args] { set f "" set error [catch { set f [open $file] while {[gets $f line] >= 0} { if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} { @@ -287,11 +288,14 @@ variable parser "" ;# parser used to build index variable index "" ;# maintains index as it is built variable scriptFile "" ;# name of file being processed variable contextStack "" ;# stack of namespace scopes variable imports "" ;# keeps track of all imported cmds - variable initCommands "" ;# list of commands that create aliases + variable initCommands ;# list of commands that create aliases + if {![info exists initCommands]} { + set initCommands [list] + } proc init {} { variable parser variable initCommands @@ -435,24 +439,23 @@ proc auto_mkindex_parser::commandInit {name arglist body} { variable parser set ns [namespace qualifiers $name] set tail [namespace tail $name] - if {[string equal $ns ""]} { - set fakeName "[namespace current]::_%@fake_$tail" + if {$ns eq ""} { + set fakeName [namespace current]::_%@fake_$tail } else { - set fakeName [string map {:: _} "_%@fake_$name"] - set fakeName "[namespace current]::$fakeName" + set fakeName [namespace current]::[string map {:: _} _%@fake_$name] } proc $fakeName $arglist $body # YUK! Tcl won't let us alias fully qualified command names, # so we can't handle names like "::itcl::class". Instead, # we have to build procs with the fully qualified names, and # have the procs point to the aliases. - if {[string match "*::*" $name]} { + if {[string match *::* $name]} { set exportCmd [list _%@namespace export [namespace tail $name]] $parser eval [list _%@namespace eval $ns $exportCmd] # The following proc definition does not work if you # want to tolerate space or something else diabolical @@ -498,20 +501,24 @@ break } } } - if {[string equal [namespace qualifiers $name] ""]} { + if {[namespace qualifiers $name] eq ""} { set name [namespace tail $name] } elseif {![string match ::* $name]} { set name "::$name" } # Earlier, mkindex replaced all $'s with \0. Now, we have to reverse # that replacement. return [string map [list \0 \$] $name] } + +if {[llength $::auto_mkindex_parser::initCommands]} { + return +} # Register all of the procedures for the auto_mkindex parser that # will build the "tclIndex" file. # AUTO MKINDEX: proc name arglist body @@ -538,11 +545,11 @@ # to force it to be loaded. This should be a noop if the package has # already been loaded auto_mkindex_parser::hook { if {![catch {package require tbcload}]} { - if {[llength [info commands tbcload::bcproc]] == 0} { + if {[namespace which -command tbcload::bcproc] eq ""} { auto_load tbcload::bcproc } load {} tbcload $auto_mkindex_parser::parser # AUTO MKINDEX: tbcload::bcproc name arglist body @@ -589,15 +596,15 @@ } import { variable parser variable imports foreach pattern $args { - if {[string compare $pattern "-force"]} { + if {$pattern ne "-force"} { lappend imports $pattern } } catch {$parser eval "_%@namespace import $args"} } } } return Index: library/clock.tcl ================================================================== --- library/clock.tcl +++ library/clock.tcl @@ -11,11 +11,11 @@ # # Copyright (c) 2004 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: clock.tcl,v 1.12 2004/11/30 15:45:04 kennykb Exp $ +# RCS: @(#) $Id: clock.tcl,v 1.12.2.4 2005/08/15 18:14:00 dgp Exp $ # #---------------------------------------------------------------------- # We must have message catalogs that support the root locale, and # we need access to the Registry on Windows systems. We also need @@ -80,13 +80,41 @@ # Import the message catalog commands that we use. namespace import ::msgcat::mcload namespace import ::msgcat::mclocale +} + +#---------------------------------------------------------------------- +# +# ::tcl::clock::Initialize -- +# +# Finish initializing the 'clock' subsystem +# +# Results: +# None. +# +# Side effects: +# Namespace variable in the 'clock' subsystem are initialized. +# +# The '::tcl::clock::Initialize' procedure initializes the namespace +# variables and root locale message catalog for the 'clock' subsystem. +# It is broken into a procedure rather than simply evaluated as a script +# so that it will be able to use local variables, avoiding the dangers +# of 'creative writing' as in Bug 1185933. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::Initialize {} { + + rename ::tcl::clock::Initialize {} + + variable LibDir + # Define the Greenwich time zone - proc initTZData {} { + proc InitTZData {} { variable TZData array unset TZData set TZData(:Etc/GMT) { {-9223372036854775808 0 0 GMT} } @@ -94,11 +122,11 @@ set TZData(:Etc/UTC) { {-9223372036854775808 0 0 UTC} } set TZData(:UTC) $TZData(:Etc/UTC) } - initTZData + InitTZData # Define the message catalog for the root locale. ::msgcat::mcmset {} { AM {am} @@ -225,25 +253,21 @@ # Paths at which binary time zone data for the Olson libraries # are known to reside on various operating systems variable ZoneinfoPaths {} - proc ZoneinfoInit {} { - variable ZoneinfoPaths - rename ZoneinfoInit {} - foreach path { - /usr/share/zoneinfo - /usr/share/lib/zoneinfo - /usr/local/etc/zoneinfo - C:/Progra~1/cygwin/usr/local/etc/zoneinfo - } { - if { [file isdirectory $path] } { - lappend ZoneinfoPaths $path - } - } - } - ZoneinfoInit + foreach path { + /usr/share/zoneinfo + /usr/share/lib/zoneinfo + /usr/lib/zoneinfo + /usr/local/etc/zoneinfo + C:/Progra~1/cygwin/usr/local/etc/zoneinfo + } { + if { [file isdirectory $path] } { + lappend ZoneinfoPaths $path + } + } # Define the directories for time zone data and message catalogs. variable DataDir [file join $LibDir tzdata] variable MsgDir [file join $LibDir msgs] @@ -262,11 +286,10 @@ } set i 0 foreach j $DaysInRomanMonthInLeapYear { lappend DaysInPriorMonthsInLeapYear [incr i $j] } - unset i j # Another epoch (Hi, Jeff!) variable Roddenberry 1946 @@ -596,10 +619,11 @@ # and whose values are lists of quads # comprising start time, UTC offset, # Daylight Saving Time indicator, and # time zone abbreviation. } +::tcl::clock::Initialize #---------------------------------------------------------------------- # # clock format -- # @@ -705,11 +729,11 @@ # Format the result set state {} set retval {} foreach char [split $format {}] { - switch -exact $state { + switch -exact -- $state { {} { if { [string equal % $char] } { set state percent } else { append retval $char @@ -1302,14 +1326,10 @@ # Do relative weekday if { [llength $parseWeekday] > 0 } { - # TODO - There's no reason for this to involve the - # ISO calendar; day of week is determined by - # Julian Day and there's no need to extract - # week of year foreach {dayOrdinal dayOfWeek} $parseWeekday break set date2 [GetJulianDay \ [ConvertUTCToLocal \ [dict create seconds $seconds] \ $timezone]] @@ -2905,22 +2925,22 @@ if { ![catch {getenv TCL_TZ} result] } { set timezone $result } elseif { ![catch {getenv TZ} result] } { set timezone $result - } else { - if { [info exists CachedSystemTimeZone] } { - set timezone $CachedSystemTimeZone - } else { - if { $::tcl_platform(platform) eq {windows} } { - set timezone [GuessWindowsTimeZone] - } else { - set timezone :localtime - } - set CachedSystemTimeZone $timezone - } - } + } elseif { [info exists CachedSystemTimeZone] } { + set timezone $CachedSystemTimeZone + } elseif { $::tcl_platform(platform) eq {windows} } { + set timezone [GuessWindowsTimeZone] + } elseif { [file exists /etc/localtime] + && ![catch {ReadZoneinfoFile \ + Tcl/Localtime /etc/localtime}] } { + set timezone :Tcl/Localtime + } else { + set timezone :localtime + } + set CachedSystemTimeZone $timezone if { ![dict exists $TimeZoneBad $timezone] } { dict set TimeZoneBad $timezone [catch {SetupTimeZone $timezone}] } if { [dict get $TimeZoneBad $timezone] } { return :localtime @@ -3293,11 +3313,11 @@ # We couldn't parse this as a POSIX time zone. Try # again with a time zone file - this time without a colon if { [catch { LoadTimeZoneFile $timezone }] - && [catch { LoadZoneinfoFile $timezone } - opts] } { + && [catch { ZoneinfoFile $timezone } - opts] } { dict unset opts -errorinfo return -options $opts "time zone $timezone not found" } set TZData($timezone) $TZData(:$timezone) } @@ -3335,10 +3355,11 @@ proc ::tcl::clock::GuessWindowsTimeZone {} { variable WinZoneInfo variable NoRegistry + variable TimeZoneBad if { [info exists NoRegistry] } { return :localtime } @@ -3368,13 +3389,24 @@ # Missing values in the Registry - bail out return :localtime } - # Make up a Posix time zone specifier if we can't find one + # Make up a Posix time zone specifier if we can't find one. + # Check here that the tzdata file exists, in case we're running + # in an environment (e.g. starpack) where tzdata is incomplete. + # (Bug 1237907) - if { ! [dict exists $WinZoneInfo $data] } { + if { [dict exists $WinZoneInfo $data] } { + set tzname [dict get $WinZoneInfo $data] + if { ! [dict exists $TimeZoneBad $tzname] } { + dict set TimeZoneBad $tzname [catch {SetupTimeZone $tzname}] + } + } else { + set tzname {} + } + if { $tzname eq {} || [dict get $TimeZoneBad $tzname] } { foreach { bias stdBias dstBias stdYear stdMonth stdDayOfWeek stdDayOfMonth stdHour stdMinute stdSecond stdMillisec dstYear dstMonth dstDayOfWeek dstDayOfMonth @@ -3383,28 +3415,33 @@ set stdDelta [expr { $bias + $stdBias }] set dstDelta [expr { $bias + $dstBias }] if { $stdDelta <= 0 } { set stdSignum + set stdDelta [expr { - $stdDelta }] + set dispStdSignum - } else { set stdSignum - + set dispStdSignum + } set hh [::format %02d [expr { $stdDelta / 3600 }]] set mm [::format %02d [expr { ($stdDelta / 60 ) % 60 }]] set ss [::format %02d [expr { $stdDelta % 60 }]] - append tzname < $stdSignum $hh $mm > $stdSignum $hh : $mm : $ss + set tzname {} + append tzname < $dispStdSignum $hh $mm > $stdSignum $hh : $mm : $ss if { $stdMonth >= 0 } { if { $dstDelta <= 0 } { set dstSignum + set dstDelta [expr { - $dstDelta }] + set dispDstSignum - } else { set dstSignum - + set dispDstSignum + } set hh [::format %02d [expr { $dstDelta / 3600 }]] set mm [::format %02d [expr { ($dstDelta / 60 ) % 60 }]] set ss [::format %02d [expr { $dstDelta % 60 }]] - append tzname < $dstSignum $hh $mm > $dstSignum $hh : $mm : $ss + append tzname < $dispDstSignum $hh $mm > $dstSignum $hh : $mm : $ss if { $dstYear == 0 } { append tzname ,M $dstMonth . $dstDayOfMonth . $dstDayOfWeek } else { # I have not been able to find any locale on which # Windows converts time zone on a fixed day of the year, @@ -3487,11 +3524,11 @@ # LoadZoneinfoFile -- # # Loads a binary time zone information file in Olson format. # # Parameters: -# fileName - Path name of the file to load. +# fileName - Relative path name of the file to load. # # Results: # Returns an empty result normally; returns an error if no # Olson file was found or the file was malformed in some way. # @@ -3500,12 +3537,10 @@ # #---------------------------------------------------------------------- proc ::tcl::clock::LoadZoneinfoFile { fileName } { - variable MINWIDE - variable TZData variable ZoneinfoPaths # Since an unsafe interp uses the [clock] command in the master, # this code is security sensitive. Make sure that the path name # cannot escape the given directory. @@ -3520,10 +3555,37 @@ if { [file readable $fname] && [file isfile $fname] } { break } unset fname } + ReadZoneinfoFile $fileName $fname +} + +#---------------------------------------------------------------------- +# +# LoadZoneinfoFile -- +# +# Loads a binary time zone information file in Olson format. +# +# Parameters: +# fileName - Name of the time zone (relative path name of the +# file). +# fname - Absolute path name of the file. +# +# Results: +# Returns an empty result normally; returns an error if no +# Olson file was found or the file was malformed in some way. +# +# Side effects: +# TZData(:fileName) contains the time zone data +# +#---------------------------------------------------------------------- + + +proc ReadZoneinfoFile {fileName fname} { + variable MINWIDE + variable TZData if { ![info exists fname] } { return -code error "$fileName not found" } if { [file size $fname] > 262144 } { @@ -3605,11 +3667,11 @@ set abbrev [dict get $abbrevs $abbrInd] lappend r [list $t $gmtoff $isDst $abbrev] } set TZData(:$fileName) $r - + return } #---------------------------------------------------------------------- # # ParsePosixTimeZone -- @@ -4409,30 +4471,38 @@ variable DaysInPriorMonthsInCommonYear variable DaysInPriorMonthsInLeapYear # Get absolute year number from the civil year - switch -exact [dict get $date era] { + switch -exact -- [dict get $date era] { BCE { set year [expr { 1 - [dict get $date year] }] } CE { set year [dict get $date year] } } + + # If month is out of range, reduce modulo 12 and adjust year accordingly. + + set month [expr { [dict get $date month] - 1 }] + incr year [expr { $month / 12 }] + set month [expr { ( $month % 12 ) + 1 }] + dict set date era CE; dict set date year $year; dict set date month $month + set ym1 [expr { $year - 1 }] # Try the Gregorian calendar first. dict set date gregorian 1 set jd [expr { 1721425 + [dict get $date dayOfMonth] + ( [IsGregorianLeapYear $date] ? [lindex $DaysInPriorMonthsInLeapYear \ - [expr { [dict get $date month] - 1}]] + [expr { $month - 1}]] : [lindex $DaysInPriorMonthsInCommonYear \ - [expr { [dict get $date month] - 1}]] ) + [expr { $month - 1}]] ) + ( 365 * $ym1 ) + ( $ym1 / 4 ) - ( $ym1 / 100 ) + ( $ym1 / 400 ) }] @@ -4443,13 +4513,13 @@ dict set date gregorian 0 set jd [expr { 1721423 + [dict get $date dayOfMonth] + ( ( $year % 4 == 0 ) ? [lindex $DaysInPriorMonthsInLeapYear \ - [expr { [dict get $date month] - 1}]] + [expr { $month - 1}]] : [lindex $DaysInPriorMonthsInCommonYear \ - [expr { [dict get $date month] - 1}]] ) + [expr { $month - 1}]] ) + ( 365 * $ym1 ) + ( $ym1 / 4 ) }] } dict set date julianDay $jd @@ -4481,16 +4551,13 @@ # #---------------------------------------------------------------------- proc ::tcl::clock::GetJulianDayFromEraYearDay { date } { - variable DaysInPriorMonthsInCommonYear - variable DaysInPriorMonthsInLeapYear - # Get absolute year number from the civil year - switch -exact [dict get $date era] { + switch -exact -- [dict get $date era] { BCE { set year [expr { 1 - [dict get $date year] }] } CE { set year [dict get $date year] @@ -5026,17 +5093,18 @@ proc ::tcl::clock::ClearCaches {} { variable LocaleNumeralCache variable McLoaded variable CachedSystemTimeZone - variable TZData + variable TimeZoneBad foreach p [info procs [namespace current]::scanproc'*] { rename $p {} } set LocaleNumeralCache {} set McLoaded {} catch {unset CachedSystemTimeZone} - initTZData + set TimeZoneBad {} + InitTZData } Index: library/history.tcl ================================================================== --- library/history.tcl +++ library/history.tcl @@ -1,10 +1,10 @@ # history.tcl -- # # Implementation of the history command. # -# RCS: @(#) $Id: history.tcl,v 1.6 2003/03/19 21:57:42 dgp Exp $ +# RCS: @(#) $Id: history.tcl,v 1.6.4.1 2005/08/02 18:16:14 dgp Exp $ # # Copyright (c) 1997 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -166,18 +166,18 @@ proc tcl::HistAdd {command {exec {}}} { variable history # Do not add empty commands to the history - if {[string trim $command] == ""} { + if {[string trim $command] eq ""} { return "" } set i [incr history(nextid)] set history($i) $command set j [incr history(oldest)] - if {[info exists history($j)]} {unset history($j)} + unset -nocomplain history($j) if {[string match e* $exec]} { return [uplevel #0 $command] } else { return {} } @@ -196,17 +196,17 @@ # Side Effects: # Updates history(keep) if a limit is specified proc tcl::HistKeep {{limit {}}} { variable history - if {[string length $limit] == 0} { + if {$limit eq ""} { return $history(keep) } else { set oldold $history(oldest) set history(oldest) [expr {$history(nextid) - $limit}] for {} {$oldold <= $history(oldest)} {incr oldold} { - if {[info exists history($oldold)]} {unset history($oldold)} + unset -nocomplain history($oldold) } set history(keep) $limit } } @@ -244,11 +244,11 @@ # Results: # A formatted history list proc tcl::HistInfo {{num {}}} { variable history - if {$num == {}} { + if {$num eq ""} { set num [expr {$history(keep) + 1}] } set result {} set newline "" for {set i [expr {$history(nextid) - $num + 1}]} \ @@ -278,11 +278,11 @@ # Side Effects: # Replaces the current history list item with the one being redone. proc tcl::HistRedo {{event -1}} { variable history - if {[string length $event] == 0} { + if {$event eq ""} { set event -1 } set i [HistIndex $event] if {$i == $history(nextid)} { return -code error "cannot redo the current event" Index: library/http/http.tcl ================================================================== --- library/http/http.tcl +++ library/http/http.tcl @@ -7,11 +7,11 @@ # defined in the safe base. # # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: http.tcl,v 1.48 2004/05/25 22:56:33 hobbs Exp $ +# RCS: @(#) $Id: http.tcl,v 1.48.2.2 2005/10/08 13:44:37 dgp Exp $ # Rough version history: # 1.0 Old http_get interface # 2.0 http:: namespace and http::geturl # 2.1 Added callbacks to handle arriving data, and timeouts @@ -20,14 +20,14 @@ # This version also cleans up error cases and eliminates the # "ioerror" status in favor of raising an error # 2.4 Added -binary option to http::geturl and charset element # to the state array. -package require Tcl 8.2 +package require Tcl 8.4 # keep this in sync with pkgIndex.tcl # and with the install directories in Makefiles -package provide http 2.5.0 +package provide http 2.5.1 namespace eval http { variable http array set http { -accept */* @@ -37,20 +37,25 @@ -urlencoding utf-8 } set http(-useragent) "Tcl http client package [package provide http]" proc init {} { - variable formMap - variable alphanumeric a-zA-Z0-9 + # Set up the map for quoting chars + # RFC3986 Section 2.3 say percent encode all except: + # "... percent-encoded octets in the ranges of ALPHA + # (%41-%5A and %61-%7A), DIGIT (%30-%39), hyphen (%2D), + # period (%2E), underscore (%5F), or tilde (%7E) should + # not be created by URI producers ..." for {set i 0} {$i <= 256} {incr i} { set c [format %c $i] - if {![string match \[$alphanumeric\] $c]} { - set formMap($c) %[format %.2x $i] + if {![string match {[-._~a-zA-Z0-9]} $c]} { + set map($c) %[format %.2x $i] } } # These are handled specially - array set formMap { " " + \n %0d%0a } + array set map { " " + \n %0d%0a } + variable formMap [array get map] } init variable urlTypes array set urlTypes { @@ -366,19 +371,19 @@ if {$state(-timeout) > 0} { fileevent $s writable [list http::Connect $token] http::wait $token - if {[string equal $state(status) "error"]} { + if {$state(status) eq "error"} { # something went wrong while trying to establish the connection # Clean up after events and such, but DON'T call the command # callback (if available) because we're going to throw an # exception from here instead. set err [lindex $state(error) 0] cleanup $token return -code error $err - } elseif {![string equal $state(status) "connect"]} { + } elseif {$state(status) ne "connect"} { # Likely to be connection timeout return $token } set state(status) "" } @@ -424,11 +429,11 @@ } puts $s "User-Agent: $http(-useragent)" foreach {key value} $state(-headers) { set value [string map [list \n "" \r ""] $value] set key [string trim $key] - if {[string equal $key "Content-Length"]} { + if {$key eq "Content-Length"} { set contDone 1 set state(querylength) $value } if {[string length $key]} { puts $s "$key: $value" @@ -480,11 +485,11 @@ # geturl does EVERYTHING asynchronously, so if the user # calls it synchronously, we just do a wait here. wait $token - if {[string equal $state(status) "error"]} { + if {$state(status) eq "error"} { # Something went wrong, so throw the exception, and the # enclosing catch will do cleanup. return -code error [lindex $state(error) 0] } } @@ -496,11 +501,11 @@ # (if available) because we're going to throw an exception from here # instead. # if state(status) is error, it means someone's already called Finish # to do the above-described clean up. - if {[string equal $state(status) "error"]} { + if {$state(status) eq "error"} { Finish $token $err 1 } cleanup $token return -code error $err } @@ -676,11 +681,11 @@ if {[eof $s]} { Eof $token return } - if {[string equal $state(state) "header"]} { + if {$state(state) eq "header"} { if {[catch {gets $s line} n]} { Finish $token $n } elseif {$n == 0} { variable encodings set state(state) body @@ -814,11 +819,11 @@ # Clean up the socket proc http::Eof {token} { variable $token upvar 0 $token state - if {[string equal $state(state) "header"]} { + if {$state(state) eq "header"} { # Premature eof set state(status) eof } else { set state(status) ok } @@ -864,11 +869,11 @@ proc http::formatQuery {args} { set result "" set sep "" foreach i $args { append result $sep [mapReply $i] - if {[string equal $sep "="]} { + if {$sep eq "="} { set sep & } else { set sep = } } @@ -886,24 +891,27 @@ # The encoded string proc http::mapReply {string} { variable http variable formMap - variable alphanumeric # The spec says: "non-alphanumeric characters are replaced by '%HH'" - # 1 leave alphanumerics characters alone - # 2 Convert every other character to an array lookup - # 3 Escape constructs that are "special" to the tcl parser - # 4 "subst" the result, doing all the array substitutions + # Use a pre-computed map and [string map] to do the conversion + # (much faster than [regsub]/[subst]). [Bug 1020491] if {$http(-urlencoding) ne ""} { set string [encoding convertto $http(-urlencoding) $string] + return [string map $formMap $string] + } + set converted [string map $formMap $string] + if {[string match "*\[\u0100-\uffff\]*" $converted]} { + regexp {[\u0100-\uffff]} $converted badChar + # Return this error message for maximum compatability... :^/ + return -code error \ + "can't read \"formMap($badChar)\": no such element in array" } - regsub -all \[^$alphanumeric\] $string {$formMap(&)} string - regsub -all {[][{})\\]\)} $string {\\&} string - return [subst -nocommand $string] + return $converted } # http::ProxyRequired -- # Default proxy filter. # Index: library/http/pkgIndex.tcl ================================================================== --- library/http/pkgIndex.tcl +++ library/http/pkgIndex.tcl @@ -6,7 +6,7 @@ # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. -if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded http 2.5.0 [list tclPkgSetup $dir http 2.5.0 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister}}}] +if {![package vsatisfies [package provide Tcl] 8.4]} {return} +package ifneeded http 2.5.1 [list tclPkgSetup $dir http 2.5.1 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister}}}] Index: library/init.tcl ================================================================== --- library/init.tcl +++ library/init.tcl @@ -1,11 +1,11 @@ # init.tcl -- # # Default system startup file for Tcl-based applications. Defines # "unknown" procedure and auto-load facilities. # -# RCS: @(#) $Id: init.tcl,v 1.69 2004/11/30 22:19:21 dgp Exp $ +# RCS: @(#) $Id: init.tcl,v 1.69.2.7 2005/10/08 13:44:37 dgp Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 Scriptics Corporation. # Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. @@ -46,34 +46,98 @@ set auto_path "" } } namespace eval tcl { variable Dir - if {[info library] != ""} { - foreach Dir [list [info library] [file dirname [info library]]] { - if {[lsearch -exact $::auto_path $Dir] < 0} { - lappend ::auto_path $Dir - } + foreach Dir [list $::tcl_library [file dirname $::tcl_library]] { + if {$Dir ni $::auto_path} { + lappend ::auto_path $Dir } } set Dir [file join [file dirname [file dirname \ [info nameofexecutable]]] lib] - if {[lsearch -exact $::auto_path $Dir] < 0} { + if {$Dir ni $::auto_path} { lappend ::auto_path $Dir } - if {[info exists ::tcl_pkgPath]} { + catch { foreach Dir $::tcl_pkgPath { - if {[lsearch -exact $::auto_path $Dir] < 0} { + if {$Dir ni $::auto_path} { lappend ::auto_path $Dir } } } + + variable Path [unsupported::EncodingDirs] + set Dir [file join $::tcl_library encoding] + if {$Dir ni $Path} { + lappend Path $Dir + unsupported::EncodingDirs $Path + } + + # Set up the 'chan' ensemble (TIP #208). + namespace eval chan { + # TIP #219. Added methods: create, postevent. + namespace ensemble create -command ::chan -map { + blocked ::fblocked + close ::close + configure ::fconfigure + copy ::fcopy + create ::tcl::chan::rCreate + eof ::eof + event ::fileevent + flush ::flush + gets ::gets + names {::file channels} + postevent ::tcl::chan::rPostevent + puts ::puts + read ::read + seek ::seek + tell ::tell + truncate ::tcl::chan::Truncate + } + } + + # TIP #255 min and max functions + namespace eval mathfunc { + proc min {args} { + if {[llength $args] == 0} { + return -code error \ + "too few arguments to math function \"min\"" + } + set val Inf + foreach arg $args { + # This will handle forcing the numeric value without + # ruining the internal type of a numeric object + if {[catch {expr {double($arg)}} err]} { + return -code error $err + } + if {$arg < $val} { set val $arg } + } + return $val + } + proc max {args} { + if {[llength $args] == 0} { + return -code error \ + "too few arguments to math function \"max\"" + } + set val -Inf + foreach arg $args { + # This will handle forcing the numeric value without + # ruining the internal type of a numeric object + if {[catch {expr {double($arg)}} err]} { + return -code error $err + } + if {$arg > $val} { set val $arg } + } + return $val + } + } } - + # Windows specific end of initialization -if {(![interp issafe]) && [string equal $tcl_platform(platform) "windows"]} { +if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} { namespace eval tcl { proc EnvTraceProc {lo n1 n2 op} { set x $::env($n2) set ::env($lo) $x set ::env([string toupper $lo]) $x @@ -80,27 +144,27 @@ } proc InitWinEnv {} { global env tcl_platform foreach p [array names env] { set u [string toupper $p] - if {![string equal $u $p]} { + if {$u ne $p} { switch -- $u { COMSPEC - PATH { if {![info exists env($u)]} { set env($u) $env($p) } - trace variable env($p) w \ + trace add variable env($p) write \ [namespace code [list EnvTraceProc $p]] - trace variable env($u) w \ + trace add variable env($u) write \ [namespace code [list EnvTraceProc $p]] } } } } if {![info exists env(COMSPEC)]} { - if {[string equal $tcl_platform(os) "Windows NT"]} { + if {$tcl_platform(os) eq "Windows NT"} { set env(COMSPEC) cmd.exe } else { set env(COMSPEC) command.com } } @@ -109,23 +173,52 @@ } } # Setup the unknown package handler -package unknown tclPkgUnknown + +if {[interp issafe]} { + package unknown ::tclPkgUnknown +} else { + # Set up search for Tcl Modules (TIP #189). + # and setup platform specific unknown package handlers + if {$::tcl_platform(os) eq "Darwin" + && $::tcl_platform(platform) eq "unix"} { + package unknown {::tcl::tm::UnknownHandler \ + {::tcl::MacOSXPkgUnknown ::tclPkgUnknown}} + } else { + package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown} + } + + # Set up the 'clock' ensemble + + namespace eval ::tcl::clock [list variable TclLibDir $::tcl_library] + + proc clock args { + namespace eval ::tcl::clock [list namespace ensemble create -command \ + [uplevel 1 [list namespace origin [lindex [info level 0] 0]]] \ + -subcommands { + add clicks format microseconds milliseconds scan seconds + }] + + # Auto-loading stubs for 'clock.tcl' + + foreach cmd {add format scan} { + proc ::tcl::clock::$cmd args { + variable TclLibDir + source -encoding utf-8 [file join $TclLibDir clock.tcl] + return [uplevel 1 [info level 0]] + } + } -if {![interp issafe]} { - # setup platform specific unknown package handlers - if {[string equal $::tcl_platform(platform) "unix"] && \ - [string equal $::tcl_platform(os) "Darwin"]} { - package unknown [list tcl::MacOSXPkgUnknown [package unknown]] + return [uplevel 1 [info level 0]] } } # Conditionalize for presence of exec. -if {[llength [info commands exec]] == 0} { +if {[namespace which -command exec] eq ""} { # Some machines do not have exec. Also, on all # platforms, safe interpreters do not have exec. set auto_noexec 1 @@ -132,11 +225,11 @@ } # Define a log command (which can be overwitten to log errors # differently, specially when stderr is not available) -if {[llength [info commands tclLog]] == 0} { +if {[namespace which -command tclLog] eq ""} { proc tclLog {string} { catch {puts stderr $string} } } @@ -179,11 +272,11 @@ return -options $opts $result } catch {set savedErrorInfo $::errorInfo} catch {set savedErrorCode $::errorCode} - set name [lindex $args 0] + set name $cmd if {![info exists auto_noload]} { # # Make sure we're not trying to load the same proc twice. # if {[info exists UnknownPending($name)]} { @@ -213,12 +306,12 @@ # construct the stack trace. # set errorInfo [dict get $opts -errorinfo] set errorCode [dict get $opts -errorcode] set cinfo $args - if {[string bytelength $cinfo] > 153} { - set cinfo [string range $cinfo 0 152] + if {[string bytelength $cinfo] > 150} { + set cinfo [string range $cinfo 0 150] while {[string bytelength $cinfo] > 150} { set cinfo [string range $cinfo 0 end-1] } append cinfo ... } @@ -257,68 +350,82 @@ [list CORE UNKNOWN BADTRACE $einfo $expect $errorInfo] } return -code error -errorcode $errorCode \ -errorinfo $einfo $msg } else { - return -code $code $msg + dict incr opts -level + return -options $opts $msg } } } - if {([info level] == 1) && [string equal [info script] ""] \ + if {([info level] == 1) && ([info script] eq "") \ && [info exists tcl_interactive] && $tcl_interactive} { if {![info exists auto_noexec]} { set new [auto_execok $name] - if {$new != ""} { + if {$new ne ""} { set redir "" - if {[string equal [info commands console] ""]} { + if {[namespace which -command console] eq ""} { set redir ">&@stdout <@stdin" } - return [uplevel 1 exec $redir $new [lrange $args 1 end]] + uplevel 1 [list ::catch \ + [concat exec $redir $new [lrange $args 1 end]] \ + ::tcl::UnknownResult ::tcl::UnknownOptions] + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult } } - if {[string equal $name "!!"]} { + if {$name eq "!!"} { set newcmd [history event] - } elseif {[regexp {^!(.+)$} $name dummy event]} { + } elseif {[regexp {^!(.+)$} $name -> event]} { set newcmd [history event $event] - } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} { + } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} { set newcmd [history event -1] catch {regsub -all -- $old $newcmd $new newcmd} } if {[info exists newcmd]} { tclLog $newcmd history change $newcmd 0 - return [uplevel 1 $newcmd] + uplevel 1 [list ::catch $newcmd \ + ::tcl::UnknownResult ::tcl::UnknownOptions] + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult } set ret [catch {set candidates [info commands $name*]} msg] - if {[string equal $name "::"]} { + if {$name eq "::"} { set name "" } if {$ret != 0} { dict append opts -errorinfo \ "\n (expanding command prefix \"$name\" in unknown)" return -options $opts $msg } + # Handle empty $name separately due to strangeness in [string first] + if {$name eq ""} { + if {[llength $candidates] != 1} { + return -code error "empty command name \"\"" + } + # It's not really possible to reach here. + return [uplevel 1 [lreplace $args 0 0 [lindex $candidates 0]]] + } # Filter out bogus matches when $name contained # a glob-special char [Bug 946952] set cmds [list] foreach x $candidates { - if {[string range $x 0 [expr [string length $name]-1]] eq $name} { + if {[string first $name $x] == 0} { lappend cmds $x } } if {[llength $cmds] == 1} { - return [uplevel 1 [lreplace $args 0 0 $cmds]] + uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] \ + ::tcl::UnknownResult ::tcl::UnknownOptions] + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult } if {[llength $cmds]} { - if {[string equal $name ""]} { - return -code error "empty command name \"\"" - } else { - return -code error \ - "ambiguous command name \"$name\": [lsort $cmds]" - } + return -code error "ambiguous command name \"$name\": [lsort $cmds]" } } return -code error "invalid command name \"$name\"" } @@ -335,11 +442,11 @@ # for instance. If not given, namespace current is used. proc auto_load {cmd {namespace {}}} { global auto_index auto_path - if {[string length $namespace] == 0} { + if {$namespace eq ""} { set namespace [uplevel 1 [list ::namespace current]] } set nameList [auto_qualify $cmd $namespace] # workaround non canonical auto_index entries that might be around # from older auto_mkindex versions @@ -388,12 +495,11 @@ proc auto_load_index {} { variable ::tcl::auto_oldpath global auto_index auto_path - if {[info exists auto_oldpath] && \ - [string equal $auto_oldpath $auto_path]} { + if {[info exists auto_oldpath] && ($auto_oldpath eq $auto_path)} { return 0 } set auto_oldpath $auto_path # Check if we are a safe interpreter. In that case, we support only @@ -408,16 +514,15 @@ } elseif {[catch {set f [open [file join $dir tclIndex]]}]} { continue } else { set error [catch { set id [gets $f] - if {[string equal $id \ - "# Tcl autoload index file, version 2.0"]} { + if {$id eq "# Tcl autoload index file, version 2.0"} { eval [read $f] - } elseif {[string equal $id "# Tcl autoload index file: each line identifies a Tcl"]} { + } elseif {$id eq "# Tcl autoload index file: each line identifies a Tcl"]} { while {[gets $f line] >= 0} { - if {[string equal [string index $line 0] "#"] \ + if {([string index $line 0] eq "#") \ || ([llength $line] != 2)} { continue } set name [lindex $line 0] set auto_index($name) \ @@ -425,11 +530,11 @@ } } else { error "[file join $dir tclIndex] isn't a proper Tcl index file" } } msg opts] - if {$f != ""} { + if {$f ne ""} { close $f } if {$error} { return -options $opts $msg } @@ -464,32 +569,32 @@ # Before each return case we give an example of which category it is # with the following form : # ( inputCmd, inputNameSpace) -> output - if {[regexp {^::(.*)$} $cmd x tail]} { + if {[string match ::* $cmd]} { if {$n > 1} { # ( ::foo::bar , * ) -> ::foo::bar return [list $cmd] } else { # ( ::global , * ) -> global - return [list $tail] + return [list [string range $cmd 2 end]] } } # Potentially returning 2 elements to try : # (if the current namespace is not the global one) if {$n == 0} { - if {[string equal $namespace ::]} { + if {$namespace eq "::"} { # ( nocolons , :: ) -> nocolons return [list $cmd] } else { # ( nocolons , ::sub ) -> ::sub::nocolons nocolons return [list ${namespace}::$cmd $cmd] } - } elseif {[string equal $namespace ::]} { + } elseif {$namespace eq "::"} { # ( foo::bar , :: ) -> ::foo::bar return [list ::$cmd] } else { # ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar return [list ${namespace}::$cmd ::$cmd] @@ -540,11 +645,11 @@ # for speed. # # Arguments: # name - Name of a command. -if {[string equal windows $tcl_platform(platform)]} { +if {$tcl_platform(platform) eq "windows"} { # Windows version. # # Note that info executable doesn't work under Windows, so we have to # look for files with .exe, .com, or .bat extensions. Also, the path # may be in the Path or PATH environment variables, and path @@ -558,11 +663,11 @@ } set auto_execs($name) "" set shellBuiltins [list cls copy date del erase dir echo mkdir \ md rename ren rmdir rd time type ver vol] - if {[string equal $tcl_platform(os) "Windows NT"]} { + if {$tcl_platform(os) eq "Windows NT"} { # NT includes the 'start' built-in lappend shellBuiltins "start" } if {[info exists env(PATHEXT)]} { # Add an initial ; to have the {} extension check first. @@ -569,11 +674,11 @@ set execExtensions [split ";$env(PATHEXT)" ";"] } else { set execExtensions [list {} .com .exe .bat] } - if {[lsearch -exact $shellBuiltins $name] != -1} { + if {$name in $shellBuiltins} { # When this is command.com for some reason on Win2K, Tcl won't # exec it unless the case is right, which this corrects. COMSPEC # may not point to a real file, so do the check. set cmd $env(COMSPEC) if {[file exists $cmd]} { @@ -595,11 +700,11 @@ set path "[file dirname [info nameof]];.;" if {[info exists env(WINDIR)]} { set windir $env(WINDIR) } if {[info exists windir]} { - if {[string equal $tcl_platform(os) "Windows NT"]} { + if {$tcl_platform(os) eq "Windows NT"} { append path "$windir/system32;" } append path "$windir/system;$windir;" } @@ -609,11 +714,11 @@ } } foreach dir [split $path {;}] { # Skip already checked directories - if {[info exists checked($dir)] || [string equal {} $dir]} { continue } + if {[info exists checked($dir)] || ($dir eq {})} { continue } set checked($dir) {} foreach ext $execExtensions { set file [file join $dir ${name}${ext}] if {[file exists $file] && ![file isdirectory $file]} { return [set auto_execs($name) [list $file]] @@ -638,11 +743,11 @@ set auto_execs($name) [list $name] } return $auto_execs($name) } foreach dir [split $env(PATH) :] { - if {[string equal $dir ""]} { + if {$dir eq ""} { set dir . } set file [file join $dir $name] if {[file executable $file] && ![file isdirectory $file]} { set auto_execs($name) [list $file] @@ -670,26 +775,26 @@ # dest - destination directory proc tcl::CopyDirectory {action src dest} { set nsrc [file normalize $src] set ndest [file normalize $dest] - if {[string equal $action "renaming"]} { + if {$action eq "renaming"} { # Can't rename volumes. We could give a more precise # error message here, but that would break the test suite. - if {[lsearch -exact [file volumes] $nsrc] != -1} { + if {$nsrc in [file volumes]} { return -code error "error $action \"$src\" to\ \"$dest\": trying to rename a volume or move a directory\ into itself" } } if {[file exists $dest]} { - if {$nsrc == $ndest} { + if {$nsrc eq $ndest} { return -code error "error $action \"$src\" to\ \"$dest\": trying to rename a volume or move a directory\ into itself" } - if {[string equal $action "copying"]} { + if {$action eq "copying"} { # We used to throw an error here, but, looking more closely # at the core copy code in tclFCmd.c, if the destination # exists, then we should only call this function if -force # is true, which means we just want to over-write. So, # the following code is now commented out. @@ -700,24 +805,24 @@ # Depending on the platform, and on the current # working directory, the directories '.', '..' # can be returned in various combinations. Anyway, # if any other file is returned, we must signal an error. set existing [glob -nocomplain -directory $dest * .*] - eval [list lappend existing] \ - [glob -nocomplain -directory $dest -type hidden * .*] + lappend existing {expand}[glob -nocomplain -directory $dest \ + -type hidden * .*] foreach s $existing { - if {([file tail $s] != ".") && ([file tail $s] != "..")} { + if {([file tail $s] ne ".") && ([file tail $s] ne "..")} { return -code error "error $action \"$src\" to\ \"$dest\": file already exists" } } } } else { if {[string first $nsrc $ndest] != -1} { set srclen [expr {[llength [file split $nsrc]] -1}] set ndest [lindex [file split $ndest] $srclen] - if {$ndest == [file tail $nsrc]} { + if {$ndest eq [file tail $nsrc]} { return -code error "error $action \"$src\" to\ \"$dest\": trying to rename a volume or move a directory\ into itself" } } @@ -731,52 +836,11 @@ # or filesystems hidden files may have other interpretations. set filelist [concat [glob -nocomplain -directory $src *] \ [glob -nocomplain -directory $src -types hidden *]] foreach s [lsort -unique $filelist] { - if {([file tail $s] != ".") && ([file tail $s] != "..")} { + if {([file tail $s] ne ".") && ([file tail $s] ne "..")} { file copy -force $s [file join $dest [file tail $s]] } } return } - -# Set up the 'clock' ensemble - -if { ![interp issafe] } { - - namespace eval ::tcl::clock \ - [list variable TclLibDir [file dirname [info script]]] - - namespace eval ::tcl::clock { - namespace ensemble create -command ::clock \ - -subcommands { - add clicks format - microseconds milliseconds - scan seconds - } - - # Auto-loading stub for 'clock.tcl' - - proc add args { - variable TclLibDir - source -encoding utf-8 [file join $TclLibDir clock.tcl] - return [uplevel 1 [info level 0]] - } - proc format args { - variable TclLibDir - source -encoding utf-8 [file join $TclLibDir clock.tcl] - return [uplevel 1 [info level 0]] - } - proc scan args { - variable TclLibDir - source -encoding utf-8 [file join $TclLibDir clock.tcl] - return [uplevel 1 [info level 0]] - } - } -} - -# Set up search for Tcl Modules (TIP #189). - -if { ![interp issafe] } { - source [file join [file dirname [info script]] tm.tcl] -} DELETED library/ldAout.tcl Index: library/ldAout.tcl ================================================================== --- library/ldAout.tcl +++ /dev/null @@ -1,233 +0,0 @@ -# ldAout.tcl -- -# -# This "tclldAout" procedure in this script acts as a replacement -# for the "ld" command when linking an object file that will be -# loaded dynamically into Tcl or Tk using pseudo-static linking. -# -# Parameters: -# The arguments to the script are the command line options for -# an "ld" command. -# -# Results: -# The "ld" command is parsed, and the "-o" option determines the -# module name. ".a" and ".o" options are accumulated. -# The input archives and object files are examined with the "nm" -# command to determine whether the modules initialization -# entry and safe initialization entry are present. A trivial -# C function that locates the entries is composed, compiled, and -# its .o file placed before all others in the command; then -# "ld" is executed to bind the objects together. -# -# RCS: @(#) $Id: ldAout.tcl,v 1.6 2003/03/19 21:57:42 dgp Exp $ -# -# Copyright (c) 1995, by General Electric Company. All rights reserved. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# This work was supported in part by the ARPA Manufacturing Automation -# and Design Engineering (MADE) Initiative through ARPA contract -# F33615-94-C-4400. - -proc tclLdAout {{cc {}} {shlib_suffix {}} {shlib_cflags none}} { - global env - global argv - - if {[string equal $cc ""]} { - set cc $env(CC) - } - - # if only two parameters are supplied there is assumed that the - # only shlib_suffix is missing. This parameter is anyway available - # as "info sharedlibextension" too, so there is no need to transfer - # 3 parameters to the function tclLdAout. For compatibility, this - # function now accepts both 2 and 3 parameters. - - if {[string equal $shlib_suffix ""]} { - set shlib_cflags $env(SHLIB_CFLAGS) - } elseif {[string equal $shlib_cflags "none"]} { - set shlib_cflags $shlib_suffix - } - - # seenDotO is nonzero if a .o or .a file has been seen - set seenDotO 0 - - # minusO is nonzero if the last command line argument was "-o". - set minusO 0 - - # head has command line arguments up to but not including the first - # .o or .a file. tail has the rest of the arguments. - set head {} - set tail {} - - # nmCommand is the "nm" command that lists global symbols from the - # object files. - set nmCommand {|nm -g} - - # entryProtos is the table of _Init and _SafeInit prototypes found in the - # module. - set entryProtos {} - - # entryPoints is the table of _Init and _SafeInit entries found in the - # module. - set entryPoints {} - - # libraries is the list of -L and -l flags to the linker. - set libraries {} - set libdirs {} - - # Process command line arguments - foreach a $argv { - if {!$minusO && [regexp {\.[ao]$} $a]} { - set seenDotO 1 - lappend nmCommand $a - } - if {$minusO} { - set outputFile $a - set minusO 0 - } elseif {![string compare $a -o]} { - set minusO 1 - } - if {[string match -nocase "-l*" $a]} { - lappend libraries $a - if {[string match "-L*" $a]} { - lappend libdirs [string range $a 2 end] - } - } elseif {$seenDotO} { - lappend tail $a - } else { - lappend head $a - } - } - lappend libdirs /lib /usr/lib - - # MIPS -- If there are corresponding G0 libraries, replace the - # ordinary ones with the G0 ones. - - set libs {} - foreach lib $libraries { - if {[string match "-l*" $lib]} { - set lname [string range $lib 2 end] - foreach dir $libdirs { - if {[file exists [file join $dir lib${lname}_G0.a]]} { - set lname ${lname}_G0 - break - } - } - lappend libs -l$lname - } else { - lappend libs $lib - } - } - set libraries $libs - - # Extract the module name from the "-o" option - - if {![info exists outputFile]} { - error "-o option must be supplied to link a Tcl load module" - } - set m [file tail $outputFile] - if {[regexp {\.a$} $outputFile]} { - set shlib_suffix .a - } else { - set shlib_suffix "" - } - if {[regexp {\..*$} $outputFile match]} { - set l [expr {[string length $m] - [string length $match]}] - } else { - error "Output file does not appear to have a suffix" - } - set modName [string tolower $m 0 [expr {$l-1}]] - if {[string match "lib*" $modName]} { - set modName [string range $modName 3 end] - } - if {[regexp {[0-9\.]*(_g0)?$} $modName match]} { - set modName [string range $modName 0 [expr {[string length $modName]-[string length $match]-1}]] - } - set modName [string totitle $modName] - - # Catalog initialization entry points found in the module - - set f [open $nmCommand r] - while {[gets $f l] >= 0} { - if {[regexp {T[ ]*_?([A-Z][a-z0-9_]*_(Safe)?Init(__FP10Tcl_Interp)?)$} $l trash symbol]} { - if {![regexp {_?([A-Z][a-z0-9_]*_(Safe)?Init)} $symbol trash s]} { - set s $symbol - } - append entryProtos {extern int } $symbol { (); } \n - append entryPoints { } \{ { "} $s {", } $symbol { } \} , \n - } - } - close $f - - if {[string equal $entryPoints ""]} { - error "No entry point found in objects" - } - - # Compose a C function that resolves the initialization entry points and - # embeds the required libraries in the object code. - - set C {#include } - append C \n - append C {char TclLoadLibraries_} $modName { [] =} \n - append C { "@LIBS: } $libraries {";} \n - append C $entryProtos - append C {static struct } \{ \n - append C { char * name;} \n - append C { int (*value)();} \n - append C \} {dictionary [] = } \{ \n - append C $entryPoints - append C { 0, 0 } \n \} \; \n - append C {typedef struct Tcl_Interp Tcl_Interp;} \n - append C {typedef int Tcl_PackageInitProc (Tcl_Interp *);} \n - append C {Tcl_PackageInitProc *} \n - append C TclLoadDictionary_ $modName { (symbol)} \n - append C { CONST char * symbol;} \n - append C { - { - int i; - for (i = 0; dictionary [i] . name != 0; ++i) { - if (!strcmp (symbol, dictionary [i] . name)) { - return dictionary [i].value; - } - } - return 0; - } - } - append C \n - - - # Write the C module and compile it - - set cFile tcl$modName.c - set f [open $cFile w] - puts -nonewline $f $C - close $f - set ccCommand "$cc -c $shlib_cflags $cFile" - puts stderr $ccCommand - eval exec $ccCommand - - # Now compose and execute the ld command that packages the module - - if {[string equal $shlib_suffix ".a"]} { - set ldCommand "ar cr $outputFile" - regsub { -o} $tail {} tail - } else { - set ldCommand ld - foreach item $head { - lappend ldCommand $item - } - } - lappend ldCommand tcl$modName.o - foreach item $tail { - lappend ldCommand $item - } - puts stderr $ldCommand - eval exec $ldCommand - if {[string equal $shlib_suffix ".a"]} { - exec ranlib $outputFile - } - - # Clean up working files - exec /bin/rm $cFile [file rootname $cFile].o -} DELETED library/msgs/af_ZA.msg Index: library/msgs/af_ZA.msg ================================================================== --- library/msgs/af_ZA.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset af_ZA DATE_FORMAT "%d %B %Y" - ::msgcat::mcset af_ZA TIME_FORMAT_12 "%l:%M:%S %P" - ::msgcat::mcset af_ZA DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" -} ADDED library/msgs/af_za.msg Index: library/msgs/af_za.msg ================================================================== --- /dev/null +++ library/msgs/af_za.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset af_ZA DATE_FORMAT "%d %B %Y" + ::msgcat::mcset af_ZA TIME_FORMAT_12 "%l:%M:%S %P" + ::msgcat::mcset af_ZA DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" +} DELETED library/msgs/ar_IN.msg Index: library/msgs/ar_IN.msg ================================================================== --- library/msgs/ar_IN.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset ar_IN DATE_FORMAT "%A %d %B %Y" - ::msgcat::mcset ar_IN TIME_FORMAT_12 "%I:%M:%S %z" - ::msgcat::mcset ar_IN DATE_TIME_FORMAT "%A %d %B %Y %I:%M:%S %z %z" -} DELETED library/msgs/ar_JO.msg Index: library/msgs/ar_JO.msg ================================================================== --- library/msgs/ar_JO.msg +++ /dev/null @@ -1,39 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset ar_JO DAYS_OF_WEEK_ABBREV [list \ - "\u0627\u0644\u0623\u062d\u062f"\ - "\u0627\u0644\u0627\u062b\u0646\u064a\u0646"\ - "\u0627\u0644\u062b\u0644\u0627\u062b\u0627\u0621"\ - "\u0627\u0644\u0623\u0631\u0628\u0639\u0627\u0621"\ - "\u0627\u0644\u062e\u0645\u064a\u0633"\ - "\u0627\u0644\u062c\u0645\u0639\u0629"\ - "\u0627\u0644\u0633\u0628\u062a"] - ::msgcat::mcset ar_JO MONTHS_ABBREV [list \ - "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ - "\u0634\u0628\u0627\u0637"\ - "\u0622\u0630\u0627\u0631"\ - "\u0646\u064a\u0633\u0627\u0646"\ - "\u0646\u0648\u0627\u0631"\ - "\u062d\u0632\u064a\u0631\u0627\u0646"\ - "\u062a\u0645\u0648\u0632"\ - "\u0622\u0628"\ - "\u0623\u064a\u0644\u0648\u0644"\ - "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\ - "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ - "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\ - ""] - ::msgcat::mcset ar_JO MONTHS_FULL [list \ - "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ - "\u0634\u0628\u0627\u0637"\ - "\u0622\u0630\u0627\u0631"\ - "\u0646\u064a\u0633\u0627\u0646"\ - "\u0646\u0648\u0627\u0631"\ - "\u062d\u0632\u064a\u0631\u0627\u0646"\ - "\u062a\u0645\u0648\u0632"\ - "\u0622\u0628"\ - "\u0623\u064a\u0644\u0648\u0644"\ - "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\ - "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ - "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\ - ""] -} DELETED library/msgs/ar_LB.msg Index: library/msgs/ar_LB.msg ================================================================== --- library/msgs/ar_LB.msg +++ /dev/null @@ -1,39 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset ar_LB DAYS_OF_WEEK_ABBREV [list \ - "\u0627\u0644\u0623\u062d\u062f"\ - "\u0627\u0644\u0627\u062b\u0646\u064a\u0646"\ - "\u0627\u0644\u062b\u0644\u0627\u062b\u0627\u0621"\ - "\u0627\u0644\u0623\u0631\u0628\u0639\u0627\u0621"\ - "\u0627\u0644\u062e\u0645\u064a\u0633"\ - "\u0627\u0644\u062c\u0645\u0639\u0629"\ - "\u0627\u0644\u0633\u0628\u062a"] - ::msgcat::mcset ar_LB MONTHS_ABBREV [list \ - "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ - "\u0634\u0628\u0627\u0637"\ - "\u0622\u0630\u0627\u0631"\ - "\u0646\u064a\u0633\u0627\u0646"\ - "\u0646\u0648\u0627\u0631"\ - "\u062d\u0632\u064a\u0631\u0627\u0646"\ - "\u062a\u0645\u0648\u0632"\ - "\u0622\u0628"\ - "\u0623\u064a\u0644\u0648\u0644"\ - "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\ - "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ - "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\ - ""] - ::msgcat::mcset ar_LB MONTHS_FULL [list \ - "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ - "\u0634\u0628\u0627\u0637"\ - "\u0622\u0630\u0627\u0631"\ - "\u0646\u064a\u0633\u0627\u0646"\ - "\u0646\u0648\u0627\u0631"\ - "\u062d\u0632\u064a\u0631\u0627\u0646"\ - "\u062a\u0645\u0648\u0632"\ - "\u0622\u0628"\ - "\u0623\u064a\u0644\u0648\u0644"\ - "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\ - "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ - "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\ - ""] -} DELETED library/msgs/ar_SY.msg Index: library/msgs/ar_SY.msg ================================================================== --- library/msgs/ar_SY.msg +++ /dev/null @@ -1,39 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset ar_SY DAYS_OF_WEEK_ABBREV [list \ - "\u0627\u0644\u0623\u062d\u062f"\ - "\u0627\u0644\u0627\u062b\u0646\u064a\u0646"\ - "\u0627\u0644\u062b\u0644\u0627\u062b\u0627\u0621"\ - "\u0627\u0644\u0623\u0631\u0628\u0639\u0627\u0621"\ - "\u0627\u0644\u062e\u0645\u064a\u0633"\ - "\u0627\u0644\u062c\u0645\u0639\u0629"\ - "\u0627\u0644\u0633\u0628\u062a"] - ::msgcat::mcset ar_SY MONTHS_ABBREV [list \ - "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ - "\u0634\u0628\u0627\u0637"\ - "\u0622\u0630\u0627\u0631"\ - "\u0646\u064a\u0633\u0627\u0646"\ - "\u0646\u0648\u0627\u0631"\ - "\u062d\u0632\u064a\u0631\u0627\u0646"\ - "\u062a\u0645\u0648\u0632"\ - "\u0622\u0628"\ - "\u0623\u064a\u0644\u0648\u0644"\ - "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\ - "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ - "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\ - ""] - ::msgcat::mcset ar_SY MONTHS_FULL [list \ - "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ - "\u0634\u0628\u0627\u0637"\ - "\u0622\u0630\u0627\u0631"\ - "\u0646\u064a\u0633\u0627\u0646"\ - "\u0646\u0648\u0627\u0631\u0627\u0646"\ - "\u062d\u0632\u064a\u0631"\ - "\u062a\u0645\u0648\u0632"\ - "\u0622\u0628"\ - "\u0623\u064a\u0644\u0648\u0644"\ - "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\ - "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ - "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\ - ""] -} ADDED library/msgs/ar_in.msg Index: library/msgs/ar_in.msg ================================================================== --- /dev/null +++ library/msgs/ar_in.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset ar_IN DATE_FORMAT "%A %d %B %Y" + ::msgcat::mcset ar_IN TIME_FORMAT_12 "%I:%M:%S %z" + ::msgcat::mcset ar_IN DATE_TIME_FORMAT "%A %d %B %Y %I:%M:%S %z %z" +} ADDED library/msgs/ar_jo.msg Index: library/msgs/ar_jo.msg ================================================================== --- /dev/null +++ library/msgs/ar_jo.msg @@ -0,0 +1,39 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset ar_JO DAYS_OF_WEEK_ABBREV [list \ + "\u0627\u0644\u0623\u062d\u062f"\ + "\u0627\u0644\u0627\u062b\u0646\u064a\u0646"\ + "\u0627\u0644\u062b\u0644\u0627\u062b\u0627\u0621"\ + "\u0627\u0644\u0623\u0631\u0628\u0639\u0627\u0621"\ + "\u0627\u0644\u062e\u0645\u064a\u0633"\ + "\u0627\u0644\u062c\u0645\u0639\u0629"\ + "\u0627\u0644\u0633\u0628\u062a"] + ::msgcat::mcset ar_JO MONTHS_ABBREV [list \ + "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ + "\u0634\u0628\u0627\u0637"\ + "\u0622\u0630\u0627\u0631"\ + "\u0646\u064a\u0633\u0627\u0646"\ + "\u0646\u0648\u0627\u0631"\ + "\u062d\u0632\u064a\u0631\u0627\u0646"\ + "\u062a\u0645\u0648\u0632"\ + "\u0622\u0628"\ + "\u0623\u064a\u0644\u0648\u0644"\ + "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\ + "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ + "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\ + ""] + ::msgcat::mcset ar_JO MONTHS_FULL [list \ + "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ + "\u0634\u0628\u0627\u0637"\ + "\u0622\u0630\u0627\u0631"\ + "\u0646\u064a\u0633\u0627\u0646"\ + "\u0646\u0648\u0627\u0631"\ + "\u062d\u0632\u064a\u0631\u0627\u0646"\ + "\u062a\u0645\u0648\u0632"\ + "\u0622\u0628"\ + "\u0623\u064a\u0644\u0648\u0644"\ + "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\ + "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ + "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\ + ""] +} ADDED library/msgs/ar_lb.msg Index: library/msgs/ar_lb.msg ================================================================== --- /dev/null +++ library/msgs/ar_lb.msg @@ -0,0 +1,39 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset ar_LB DAYS_OF_WEEK_ABBREV [list \ + "\u0627\u0644\u0623\u062d\u062f"\ + "\u0627\u0644\u0627\u062b\u0646\u064a\u0646"\ + "\u0627\u0644\u062b\u0644\u0627\u062b\u0627\u0621"\ + "\u0627\u0644\u0623\u0631\u0628\u0639\u0627\u0621"\ + "\u0627\u0644\u062e\u0645\u064a\u0633"\ + "\u0627\u0644\u062c\u0645\u0639\u0629"\ + "\u0627\u0644\u0633\u0628\u062a"] + ::msgcat::mcset ar_LB MONTHS_ABBREV [list \ + "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ + "\u0634\u0628\u0627\u0637"\ + "\u0622\u0630\u0627\u0631"\ + "\u0646\u064a\u0633\u0627\u0646"\ + "\u0646\u0648\u0627\u0631"\ + "\u062d\u0632\u064a\u0631\u0627\u0646"\ + "\u062a\u0645\u0648\u0632"\ + "\u0622\u0628"\ + "\u0623\u064a\u0644\u0648\u0644"\ + "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\ + "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ + "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\ + ""] + ::msgcat::mcset ar_LB MONTHS_FULL [list \ + "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ + "\u0634\u0628\u0627\u0637"\ + "\u0622\u0630\u0627\u0631"\ + "\u0646\u064a\u0633\u0627\u0646"\ + "\u0646\u0648\u0627\u0631"\ + "\u062d\u0632\u064a\u0631\u0627\u0646"\ + "\u062a\u0645\u0648\u0632"\ + "\u0622\u0628"\ + "\u0623\u064a\u0644\u0648\u0644"\ + "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\ + "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ + "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\ + ""] +} ADDED library/msgs/ar_sy.msg Index: library/msgs/ar_sy.msg ================================================================== --- /dev/null +++ library/msgs/ar_sy.msg @@ -0,0 +1,39 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset ar_SY DAYS_OF_WEEK_ABBREV [list \ + "\u0627\u0644\u0623\u062d\u062f"\ + "\u0627\u0644\u0627\u062b\u0646\u064a\u0646"\ + "\u0627\u0644\u062b\u0644\u0627\u062b\u0627\u0621"\ + "\u0627\u0644\u0623\u0631\u0628\u0639\u0627\u0621"\ + "\u0627\u0644\u062e\u0645\u064a\u0633"\ + "\u0627\u0644\u062c\u0645\u0639\u0629"\ + "\u0627\u0644\u0633\u0628\u062a"] + ::msgcat::mcset ar_SY MONTHS_ABBREV [list \ + "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ + "\u0634\u0628\u0627\u0637"\ + "\u0622\u0630\u0627\u0631"\ + "\u0646\u064a\u0633\u0627\u0646"\ + "\u0646\u0648\u0627\u0631"\ + "\u062d\u0632\u064a\u0631\u0627\u0646"\ + "\u062a\u0645\u0648\u0632"\ + "\u0622\u0628"\ + "\u0623\u064a\u0644\u0648\u0644"\ + "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\ + "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ + "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\ + ""] + ::msgcat::mcset ar_SY MONTHS_FULL [list \ + "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ + "\u0634\u0628\u0627\u0637"\ + "\u0622\u0630\u0627\u0631"\ + "\u0646\u064a\u0633\u0627\u0646"\ + "\u0646\u0648\u0627\u0631\u0627\u0646"\ + "\u062d\u0632\u064a\u0631"\ + "\u062a\u0645\u0648\u0632"\ + "\u0622\u0628"\ + "\u0623\u064a\u0644\u0648\u0644"\ + "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\ + "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ + "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\ + ""] +} DELETED library/msgs/bn_IN.msg Index: library/msgs/bn_IN.msg ================================================================== --- library/msgs/bn_IN.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset bn_IN DATE_FORMAT "%A %d %b %Y" - ::msgcat::mcset bn_IN TIME_FORMAT_12 "%I:%M:%S %z" - ::msgcat::mcset bn_IN DATE_TIME_FORMAT "%A %d %b %Y %I:%M:%S %z %z" -} ADDED library/msgs/bn_in.msg Index: library/msgs/bn_in.msg ================================================================== --- /dev/null +++ library/msgs/bn_in.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset bn_IN DATE_FORMAT "%A %d %b %Y" + ::msgcat::mcset bn_IN TIME_FORMAT_12 "%I:%M:%S %z" + ::msgcat::mcset bn_IN DATE_TIME_FORMAT "%A %d %b %Y %I:%M:%S %z %z" +} DELETED library/msgs/de_AT.msg Index: library/msgs/de_AT.msg ================================================================== --- library/msgs/de_AT.msg +++ /dev/null @@ -1,35 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset de_AT MONTHS_ABBREV [list \ - "J\u00e4n"\ - "Feb"\ - "M\u00e4r"\ - "Apr"\ - "Mai"\ - "Jun"\ - "Jul"\ - "Aug"\ - "Sep"\ - "Okt"\ - "Nov"\ - "Dez"\ - ""] - ::msgcat::mcset de_AT MONTHS_FULL [list \ - "J\u00e4nner"\ - "Februar"\ - "M\u00e4rz"\ - "April"\ - "Mai"\ - "Juni"\ - "Juli"\ - "August"\ - "September"\ - "Oktober"\ - "November"\ - "Dezember"\ - ""] - ::msgcat::mcset de_AT DATE_FORMAT "%Y-%m-%d" - ::msgcat::mcset de_AT TIME_FORMAT "%T" - ::msgcat::mcset de_AT TIME_FORMAT_12 "%T" - ::msgcat::mcset de_AT DATE_TIME_FORMAT "%a %d %b %Y %T %z" -} DELETED library/msgs/de_BE.msg Index: library/msgs/de_BE.msg ================================================================== --- library/msgs/de_BE.msg +++ /dev/null @@ -1,53 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset de_BE DAYS_OF_WEEK_ABBREV [list \ - "Son"\ - "Mon"\ - "Die"\ - "Mit"\ - "Don"\ - "Fre"\ - "Sam"] - ::msgcat::mcset de_BE DAYS_OF_WEEK_FULL [list \ - "Sonntag"\ - "Montag"\ - "Dienstag"\ - "Mittwoch"\ - "Donnerstag"\ - "Freitag"\ - "Samstag"] - ::msgcat::mcset de_BE MONTHS_ABBREV [list \ - "Jan"\ - "Feb"\ - "M\u00e4r"\ - "Apr"\ - "Mai"\ - "Jun"\ - "Jul"\ - "Aug"\ - "Sep"\ - "Okt"\ - "Nov"\ - "Dez"\ - ""] - ::msgcat::mcset de_BE MONTHS_FULL [list \ - "Januar"\ - "Februar"\ - "M\u00e4rz"\ - "April"\ - "Mai"\ - "Juni"\ - "Juli"\ - "August"\ - "September"\ - "Oktober"\ - "November"\ - "Dezember"\ - ""] - ::msgcat::mcset de_BE AM "vorm" - ::msgcat::mcset de_BE PM "nachm" - ::msgcat::mcset de_BE DATE_FORMAT "%Y-%m-%d" - ::msgcat::mcset de_BE TIME_FORMAT "%T" - ::msgcat::mcset de_BE TIME_FORMAT_12 "%T" - ::msgcat::mcset de_BE DATE_TIME_FORMAT "%a %d %b %Y %T %z" -} ADDED library/msgs/de_at.msg Index: library/msgs/de_at.msg ================================================================== --- /dev/null +++ library/msgs/de_at.msg @@ -0,0 +1,35 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset de_AT MONTHS_ABBREV [list \ + "J\u00e4n"\ + "Feb"\ + "M\u00e4r"\ + "Apr"\ + "Mai"\ + "Jun"\ + "Jul"\ + "Aug"\ + "Sep"\ + "Okt"\ + "Nov"\ + "Dez"\ + ""] + ::msgcat::mcset de_AT MONTHS_FULL [list \ + "J\u00e4nner"\ + "Februar"\ + "M\u00e4rz"\ + "April"\ + "Mai"\ + "Juni"\ + "Juli"\ + "August"\ + "September"\ + "Oktober"\ + "November"\ + "Dezember"\ + ""] + ::msgcat::mcset de_AT DATE_FORMAT "%Y-%m-%d" + ::msgcat::mcset de_AT TIME_FORMAT "%T" + ::msgcat::mcset de_AT TIME_FORMAT_12 "%T" + ::msgcat::mcset de_AT DATE_TIME_FORMAT "%a %d %b %Y %T %z" +} ADDED library/msgs/de_be.msg Index: library/msgs/de_be.msg ================================================================== --- /dev/null +++ library/msgs/de_be.msg @@ -0,0 +1,53 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset de_BE DAYS_OF_WEEK_ABBREV [list \ + "Son"\ + "Mon"\ + "Die"\ + "Mit"\ + "Don"\ + "Fre"\ + "Sam"] + ::msgcat::mcset de_BE DAYS_OF_WEEK_FULL [list \ + "Sonntag"\ + "Montag"\ + "Dienstag"\ + "Mittwoch"\ + "Donnerstag"\ + "Freitag"\ + "Samstag"] + ::msgcat::mcset de_BE MONTHS_ABBREV [list \ + "Jan"\ + "Feb"\ + "M\u00e4r"\ + "Apr"\ + "Mai"\ + "Jun"\ + "Jul"\ + "Aug"\ + "Sep"\ + "Okt"\ + "Nov"\ + "Dez"\ + ""] + ::msgcat::mcset de_BE MONTHS_FULL [list \ + "Januar"\ + "Februar"\ + "M\u00e4rz"\ + "April"\ + "Mai"\ + "Juni"\ + "Juli"\ + "August"\ + "September"\ + "Oktober"\ + "November"\ + "Dezember"\ + ""] + ::msgcat::mcset de_BE AM "vorm" + ::msgcat::mcset de_BE PM "nachm" + ::msgcat::mcset de_BE DATE_FORMAT "%Y-%m-%d" + ::msgcat::mcset de_BE TIME_FORMAT "%T" + ::msgcat::mcset de_BE TIME_FORMAT_12 "%T" + ::msgcat::mcset de_BE DATE_TIME_FORMAT "%a %d %b %Y %T %z" +} DELETED library/msgs/en_AU.msg Index: library/msgs/en_AU.msg ================================================================== --- library/msgs/en_AU.msg +++ /dev/null @@ -1,7 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset en_AU DATE_FORMAT "%e/%m/%Y" - ::msgcat::mcset en_AU TIME_FORMAT "%H:%M:%S" - ::msgcat::mcset en_AU TIME_FORMAT_12 "%I:%M:%S %P %z" - ::msgcat::mcset en_AU DATE_TIME_FORMAT "%e/%m/%Y %H:%M:%S %z" -} DELETED library/msgs/en_BE.msg Index: library/msgs/en_BE.msg ================================================================== --- library/msgs/en_BE.msg +++ /dev/null @@ -1,7 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset en_BE DATE_FORMAT "%d %b %Y" - ::msgcat::mcset en_BE TIME_FORMAT "%k:%M:%S" - ::msgcat::mcset en_BE TIME_FORMAT_12 "%k h %M min %S s %z" - ::msgcat::mcset en_BE DATE_TIME_FORMAT "%d %b %Y %k:%M:%S %z" -} DELETED library/msgs/en_BW.msg Index: library/msgs/en_BW.msg ================================================================== --- library/msgs/en_BW.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset en_BW DATE_FORMAT "%d %B %Y" - ::msgcat::mcset en_BW TIME_FORMAT_12 "%l:%M:%S %P" - ::msgcat::mcset en_BW DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" -} DELETED library/msgs/en_CA.msg Index: library/msgs/en_CA.msg ================================================================== --- library/msgs/en_CA.msg +++ /dev/null @@ -1,7 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset en_CA DATE_FORMAT "%d/%m/%y" - ::msgcat::mcset en_CA TIME_FORMAT "%r" - ::msgcat::mcset en_CA TIME_FORMAT_12 "%I:%M:%S %p" - ::msgcat::mcset en_CA DATE_TIME_FORMAT "%a %d %b %Y %r %z" -} DELETED library/msgs/en_GB.msg Index: library/msgs/en_GB.msg ================================================================== --- library/msgs/en_GB.msg +++ /dev/null @@ -1,7 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset en_GB DATE_FORMAT "%d/%m/%y" - ::msgcat::mcset en_GB TIME_FORMAT "%T" - ::msgcat::mcset en_GB TIME_FORMAT_12 "%T" - ::msgcat::mcset en_GB DATE_TIME_FORMAT "%a %d %b %Y %T %z" -} DELETED library/msgs/en_HK.msg Index: library/msgs/en_HK.msg ================================================================== --- library/msgs/en_HK.msg +++ /dev/null @@ -1,8 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset en_HK AM "AM" - ::msgcat::mcset en_HK PM "PM" - ::msgcat::mcset en_HK DATE_FORMAT "%B %e, %Y" - ::msgcat::mcset en_HK TIME_FORMAT_12 "%l:%M:%S %P" - ::msgcat::mcset en_HK DATE_TIME_FORMAT "%B %e, %Y %l:%M:%S %P %z" -} DELETED library/msgs/en_IE.msg Index: library/msgs/en_IE.msg ================================================================== --- library/msgs/en_IE.msg +++ /dev/null @@ -1,7 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset en_IE DATE_FORMAT "%d/%m/%y" - ::msgcat::mcset en_IE TIME_FORMAT "%T" - ::msgcat::mcset en_IE TIME_FORMAT_12 "%T" - ::msgcat::mcset en_IE DATE_TIME_FORMAT "%a %d %b %Y %T %z" -} DELETED library/msgs/en_IN.msg Index: library/msgs/en_IN.msg ================================================================== --- library/msgs/en_IN.msg +++ /dev/null @@ -1,8 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset en_IN AM "AM" - ::msgcat::mcset en_IN PM "PM" - ::msgcat::mcset en_IN DATE_FORMAT "%d %B %Y" - ::msgcat::mcset en_IN TIME_FORMAT "%H:%M:%S" - ::msgcat::mcset en_IN DATE_TIME_FORMAT "%d %B %Y %H:%M:%S %z" -} DELETED library/msgs/en_NZ.msg Index: library/msgs/en_NZ.msg ================================================================== --- library/msgs/en_NZ.msg +++ /dev/null @@ -1,7 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset en_NZ DATE_FORMAT "%e/%m/%Y" - ::msgcat::mcset en_NZ TIME_FORMAT "%H:%M:%S" - ::msgcat::mcset en_NZ TIME_FORMAT_12 "%I:%M:%S %P %z" - ::msgcat::mcset en_NZ DATE_TIME_FORMAT "%e/%m/%Y %H:%M:%S %z" -} DELETED library/msgs/en_PH.msg Index: library/msgs/en_PH.msg ================================================================== --- library/msgs/en_PH.msg +++ /dev/null @@ -1,8 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset en_PH AM "AM" - ::msgcat::mcset en_PH PM "PM" - ::msgcat::mcset en_PH DATE_FORMAT "%B %e, %Y" - ::msgcat::mcset en_PH TIME_FORMAT_12 "%l:%M:%S %P" - ::msgcat::mcset en_PH DATE_TIME_FORMAT "%B %e, %Y %l:%M:%S %P %z" -} DELETED library/msgs/en_SG.msg Index: library/msgs/en_SG.msg ================================================================== --- library/msgs/en_SG.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset en_SG DATE_FORMAT "%d %b %Y" - ::msgcat::mcset en_SG TIME_FORMAT_12 "%P %I:%M:%S" - ::msgcat::mcset en_SG DATE_TIME_FORMAT "%d %b %Y %P %I:%M:%S %z" -} DELETED library/msgs/en_ZA.msg Index: library/msgs/en_ZA.msg ================================================================== --- library/msgs/en_ZA.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset en_ZA DATE_FORMAT "%Y/%m/%d" - ::msgcat::mcset en_ZA TIME_FORMAT_12 "%I:%M:%S" - ::msgcat::mcset en_ZA DATE_TIME_FORMAT "%Y/%m/%d %I:%M:%S %z" -} DELETED library/msgs/en_ZW.msg Index: library/msgs/en_ZW.msg ================================================================== --- library/msgs/en_ZW.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset en_ZW DATE_FORMAT "%d %B %Y" - ::msgcat::mcset en_ZW TIME_FORMAT_12 "%l:%M:%S %P" - ::msgcat::mcset en_ZW DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" -} ADDED library/msgs/en_au.msg Index: library/msgs/en_au.msg ================================================================== --- /dev/null +++ library/msgs/en_au.msg @@ -0,0 +1,7 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset en_AU DATE_FORMAT "%e/%m/%Y" + ::msgcat::mcset en_AU TIME_FORMAT "%H:%M:%S" + ::msgcat::mcset en_AU TIME_FORMAT_12 "%I:%M:%S %P %z" + ::msgcat::mcset en_AU DATE_TIME_FORMAT "%e/%m/%Y %H:%M:%S %z" +} ADDED library/msgs/en_be.msg Index: library/msgs/en_be.msg ================================================================== --- /dev/null +++ library/msgs/en_be.msg @@ -0,0 +1,7 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset en_BE DATE_FORMAT "%d %b %Y" + ::msgcat::mcset en_BE TIME_FORMAT "%k:%M:%S" + ::msgcat::mcset en_BE TIME_FORMAT_12 "%k h %M min %S s %z" + ::msgcat::mcset en_BE DATE_TIME_FORMAT "%d %b %Y %k:%M:%S %z" +} ADDED library/msgs/en_bw.msg Index: library/msgs/en_bw.msg ================================================================== --- /dev/null +++ library/msgs/en_bw.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset en_BW DATE_FORMAT "%d %B %Y" + ::msgcat::mcset en_BW TIME_FORMAT_12 "%l:%M:%S %P" + ::msgcat::mcset en_BW DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" +} ADDED library/msgs/en_ca.msg Index: library/msgs/en_ca.msg ================================================================== --- /dev/null +++ library/msgs/en_ca.msg @@ -0,0 +1,7 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset en_CA DATE_FORMAT "%d/%m/%y" + ::msgcat::mcset en_CA TIME_FORMAT "%r" + ::msgcat::mcset en_CA TIME_FORMAT_12 "%I:%M:%S %p" + ::msgcat::mcset en_CA DATE_TIME_FORMAT "%a %d %b %Y %r %z" +} ADDED library/msgs/en_gb.msg Index: library/msgs/en_gb.msg ================================================================== --- /dev/null +++ library/msgs/en_gb.msg @@ -0,0 +1,7 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset en_GB DATE_FORMAT "%d/%m/%y" + ::msgcat::mcset en_GB TIME_FORMAT "%T" + ::msgcat::mcset en_GB TIME_FORMAT_12 "%T" + ::msgcat::mcset en_GB DATE_TIME_FORMAT "%a %d %b %Y %T %z" +} ADDED library/msgs/en_hk.msg Index: library/msgs/en_hk.msg ================================================================== --- /dev/null +++ library/msgs/en_hk.msg @@ -0,0 +1,8 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset en_HK AM "AM" + ::msgcat::mcset en_HK PM "PM" + ::msgcat::mcset en_HK DATE_FORMAT "%B %e, %Y" + ::msgcat::mcset en_HK TIME_FORMAT_12 "%l:%M:%S %P" + ::msgcat::mcset en_HK DATE_TIME_FORMAT "%B %e, %Y %l:%M:%S %P %z" +} ADDED library/msgs/en_ie.msg Index: library/msgs/en_ie.msg ================================================================== --- /dev/null +++ library/msgs/en_ie.msg @@ -0,0 +1,7 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset en_IE DATE_FORMAT "%d/%m/%y" + ::msgcat::mcset en_IE TIME_FORMAT "%T" + ::msgcat::mcset en_IE TIME_FORMAT_12 "%T" + ::msgcat::mcset en_IE DATE_TIME_FORMAT "%a %d %b %Y %T %z" +} ADDED library/msgs/en_in.msg Index: library/msgs/en_in.msg ================================================================== --- /dev/null +++ library/msgs/en_in.msg @@ -0,0 +1,8 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset en_IN AM "AM" + ::msgcat::mcset en_IN PM "PM" + ::msgcat::mcset en_IN DATE_FORMAT "%d %B %Y" + ::msgcat::mcset en_IN TIME_FORMAT "%H:%M:%S" + ::msgcat::mcset en_IN DATE_TIME_FORMAT "%d %B %Y %H:%M:%S %z" +} ADDED library/msgs/en_nz.msg Index: library/msgs/en_nz.msg ================================================================== --- /dev/null +++ library/msgs/en_nz.msg @@ -0,0 +1,7 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset en_NZ DATE_FORMAT "%e/%m/%Y" + ::msgcat::mcset en_NZ TIME_FORMAT "%H:%M:%S" + ::msgcat::mcset en_NZ TIME_FORMAT_12 "%I:%M:%S %P %z" + ::msgcat::mcset en_NZ DATE_TIME_FORMAT "%e/%m/%Y %H:%M:%S %z" +} ADDED library/msgs/en_ph.msg Index: library/msgs/en_ph.msg ================================================================== --- /dev/null +++ library/msgs/en_ph.msg @@ -0,0 +1,8 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset en_PH AM "AM" + ::msgcat::mcset en_PH PM "PM" + ::msgcat::mcset en_PH DATE_FORMAT "%B %e, %Y" + ::msgcat::mcset en_PH TIME_FORMAT_12 "%l:%M:%S %P" + ::msgcat::mcset en_PH DATE_TIME_FORMAT "%B %e, %Y %l:%M:%S %P %z" +} ADDED library/msgs/en_sg.msg Index: library/msgs/en_sg.msg ================================================================== --- /dev/null +++ library/msgs/en_sg.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset en_SG DATE_FORMAT "%d %b %Y" + ::msgcat::mcset en_SG TIME_FORMAT_12 "%P %I:%M:%S" + ::msgcat::mcset en_SG DATE_TIME_FORMAT "%d %b %Y %P %I:%M:%S %z" +} ADDED library/msgs/en_za.msg Index: library/msgs/en_za.msg ================================================================== --- /dev/null +++ library/msgs/en_za.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset en_ZA DATE_FORMAT "%Y/%m/%d" + ::msgcat::mcset en_ZA TIME_FORMAT_12 "%I:%M:%S" + ::msgcat::mcset en_ZA DATE_TIME_FORMAT "%Y/%m/%d %I:%M:%S %z" +} ADDED library/msgs/en_zw.msg Index: library/msgs/en_zw.msg ================================================================== --- /dev/null +++ library/msgs/en_zw.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset en_ZW DATE_FORMAT "%d %B %Y" + ::msgcat::mcset en_ZW TIME_FORMAT_12 "%l:%M:%S %P" + ::msgcat::mcset en_ZW DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" +} DELETED library/msgs/es_AR.msg Index: library/msgs/es_AR.msg ================================================================== --- library/msgs/es_AR.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset es_AR DATE_FORMAT "%d/%m/%Y" - ::msgcat::mcset es_AR TIME_FORMAT "%H:%M:%S" - ::msgcat::mcset es_AR DATE_TIME_FORMAT "%d/%m/%Y %H:%M:%S %z" -} DELETED library/msgs/es_BO.msg Index: library/msgs/es_BO.msg ================================================================== --- library/msgs/es_BO.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset es_BO DATE_FORMAT "%d-%m-%Y" - ::msgcat::mcset es_BO TIME_FORMAT_12 "%I:%M:%S %P" - ::msgcat::mcset es_BO DATE_TIME_FORMAT "%d-%m-%Y %I:%M:%S %P %z" -} DELETED library/msgs/es_CL.msg Index: library/msgs/es_CL.msg ================================================================== --- library/msgs/es_CL.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset es_CL DATE_FORMAT "%d-%m-%Y" - ::msgcat::mcset es_CL TIME_FORMAT_12 "%I:%M:%S %P" - ::msgcat::mcset es_CL DATE_TIME_FORMAT "%d-%m-%Y %I:%M:%S %P %z" -} DELETED library/msgs/es_CO.msg Index: library/msgs/es_CO.msg ================================================================== --- library/msgs/es_CO.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset es_CO DATE_FORMAT "%e/%m/%Y" - ::msgcat::mcset es_CO TIME_FORMAT_12 "%I:%M:%S %P" - ::msgcat::mcset es_CO DATE_TIME_FORMAT "%e/%m/%Y %I:%M:%S %P %z" -} DELETED library/msgs/es_CR.msg Index: library/msgs/es_CR.msg ================================================================== --- library/msgs/es_CR.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset es_CR DATE_FORMAT "%d/%m/%Y" - ::msgcat::mcset es_CR TIME_FORMAT_12 "%I:%M:%S %P" - ::msgcat::mcset es_CR DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" -} DELETED library/msgs/es_DO.msg Index: library/msgs/es_DO.msg ================================================================== --- library/msgs/es_DO.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset es_DO DATE_FORMAT "%m/%d/%Y" - ::msgcat::mcset es_DO TIME_FORMAT_12 "%I:%M:%S %P" - ::msgcat::mcset es_DO DATE_TIME_FORMAT "%m/%d/%Y %I:%M:%S %P %z" -} DELETED library/msgs/es_EC.msg Index: library/msgs/es_EC.msg ================================================================== --- library/msgs/es_EC.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset es_EC DATE_FORMAT "%d/%m/%Y" - ::msgcat::mcset es_EC TIME_FORMAT_12 "%I:%M:%S %P" - ::msgcat::mcset es_EC DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" -} DELETED library/msgs/es_GT.msg Index: library/msgs/es_GT.msg ================================================================== --- library/msgs/es_GT.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset es_GT DATE_FORMAT "%e/%m/%Y" - ::msgcat::mcset es_GT TIME_FORMAT_12 "%I:%M:%S %P" - ::msgcat::mcset es_GT DATE_TIME_FORMAT "%e/%m/%Y %I:%M:%S %P %z" -} DELETED library/msgs/es_HN.msg Index: library/msgs/es_HN.msg ================================================================== --- library/msgs/es_HN.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset es_HN DATE_FORMAT "%m-%d-%Y" - ::msgcat::mcset es_HN TIME_FORMAT_12 "%I:%M:%S %P" - ::msgcat::mcset es_HN DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z" -} DELETED library/msgs/es_MX.msg Index: library/msgs/es_MX.msg ================================================================== --- library/msgs/es_MX.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset es_MX DATE_FORMAT "%e/%m/%Y" - ::msgcat::mcset es_MX TIME_FORMAT_12 "%I:%M:%S %P" - ::msgcat::mcset es_MX DATE_TIME_FORMAT "%e/%m/%Y %I:%M:%S %P %z" -} DELETED library/msgs/es_NI.msg Index: library/msgs/es_NI.msg ================================================================== --- library/msgs/es_NI.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset es_NI DATE_FORMAT "%m-%d-%Y" - ::msgcat::mcset es_NI TIME_FORMAT_12 "%I:%M:%S %P" - ::msgcat::mcset es_NI DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z" -} DELETED library/msgs/es_PA.msg Index: library/msgs/es_PA.msg ================================================================== --- library/msgs/es_PA.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset es_PA DATE_FORMAT "%m/%d/%Y" - ::msgcat::mcset es_PA TIME_FORMAT_12 "%I:%M:%S %P" - ::msgcat::mcset es_PA DATE_TIME_FORMAT "%m/%d/%Y %I:%M:%S %P %z" -} DELETED library/msgs/es_PE.msg Index: library/msgs/es_PE.msg ================================================================== --- library/msgs/es_PE.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset es_PE DATE_FORMAT "%d/%m/%Y" - ::msgcat::mcset es_PE TIME_FORMAT_12 "%I:%M:%S %P" - ::msgcat::mcset es_PE DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" -} DELETED library/msgs/es_PR.msg Index: library/msgs/es_PR.msg ================================================================== --- library/msgs/es_PR.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset es_PR DATE_FORMAT "%m-%d-%Y" - ::msgcat::mcset es_PR TIME_FORMAT_12 "%I:%M:%S %P" - ::msgcat::mcset es_PR DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z" -} DELETED library/msgs/es_PY.msg Index: library/msgs/es_PY.msg ================================================================== --- library/msgs/es_PY.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset es_PY DATE_FORMAT "%d/%m/%Y" - ::msgcat::mcset es_PY TIME_FORMAT_12 "%I:%M:%S %P" - ::msgcat::mcset es_PY DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" -} DELETED library/msgs/es_SV.msg Index: library/msgs/es_SV.msg ================================================================== --- library/msgs/es_SV.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset es_SV DATE_FORMAT "%m-%d-%Y" - ::msgcat::mcset es_SV TIME_FORMAT_12 "%I:%M:%S %P" - ::msgcat::mcset es_SV DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z" -} DELETED library/msgs/es_UY.msg Index: library/msgs/es_UY.msg ================================================================== --- library/msgs/es_UY.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset es_UY DATE_FORMAT "%d/%m/%Y" - ::msgcat::mcset es_UY TIME_FORMAT_12 "%I:%M:%S %P" - ::msgcat::mcset es_UY DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" -} DELETED library/msgs/es_VE.msg Index: library/msgs/es_VE.msg ================================================================== --- library/msgs/es_VE.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset es_VE DATE_FORMAT "%d/%m/%Y" - ::msgcat::mcset es_VE TIME_FORMAT_12 "%I:%M:%S %P" - ::msgcat::mcset es_VE DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" -} ADDED library/msgs/es_ar.msg Index: library/msgs/es_ar.msg ================================================================== --- /dev/null +++ library/msgs/es_ar.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset es_AR DATE_FORMAT "%d/%m/%Y" + ::msgcat::mcset es_AR TIME_FORMAT "%H:%M:%S" + ::msgcat::mcset es_AR DATE_TIME_FORMAT "%d/%m/%Y %H:%M:%S %z" +} ADDED library/msgs/es_bo.msg Index: library/msgs/es_bo.msg ================================================================== --- /dev/null +++ library/msgs/es_bo.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset es_BO DATE_FORMAT "%d-%m-%Y" + ::msgcat::mcset es_BO TIME_FORMAT_12 "%I:%M:%S %P" + ::msgcat::mcset es_BO DATE_TIME_FORMAT "%d-%m-%Y %I:%M:%S %P %z" +} ADDED library/msgs/es_cl.msg Index: library/msgs/es_cl.msg ================================================================== --- /dev/null +++ library/msgs/es_cl.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset es_CL DATE_FORMAT "%d-%m-%Y" + ::msgcat::mcset es_CL TIME_FORMAT_12 "%I:%M:%S %P" + ::msgcat::mcset es_CL DATE_TIME_FORMAT "%d-%m-%Y %I:%M:%S %P %z" +} ADDED library/msgs/es_co.msg Index: library/msgs/es_co.msg ================================================================== --- /dev/null +++ library/msgs/es_co.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset es_CO DATE_FORMAT "%e/%m/%Y" + ::msgcat::mcset es_CO TIME_FORMAT_12 "%I:%M:%S %P" + ::msgcat::mcset es_CO DATE_TIME_FORMAT "%e/%m/%Y %I:%M:%S %P %z" +} ADDED library/msgs/es_cr.msg Index: library/msgs/es_cr.msg ================================================================== --- /dev/null +++ library/msgs/es_cr.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset es_CR DATE_FORMAT "%d/%m/%Y" + ::msgcat::mcset es_CR TIME_FORMAT_12 "%I:%M:%S %P" + ::msgcat::mcset es_CR DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" +} ADDED library/msgs/es_do.msg Index: library/msgs/es_do.msg ================================================================== --- /dev/null +++ library/msgs/es_do.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset es_DO DATE_FORMAT "%m/%d/%Y" + ::msgcat::mcset es_DO TIME_FORMAT_12 "%I:%M:%S %P" + ::msgcat::mcset es_DO DATE_TIME_FORMAT "%m/%d/%Y %I:%M:%S %P %z" +} ADDED library/msgs/es_ec.msg Index: library/msgs/es_ec.msg ================================================================== --- /dev/null +++ library/msgs/es_ec.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset es_EC DATE_FORMAT "%d/%m/%Y" + ::msgcat::mcset es_EC TIME_FORMAT_12 "%I:%M:%S %P" + ::msgcat::mcset es_EC DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" +} ADDED library/msgs/es_gt.msg Index: library/msgs/es_gt.msg ================================================================== --- /dev/null +++ library/msgs/es_gt.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset es_GT DATE_FORMAT "%e/%m/%Y" + ::msgcat::mcset es_GT TIME_FORMAT_12 "%I:%M:%S %P" + ::msgcat::mcset es_GT DATE_TIME_FORMAT "%e/%m/%Y %I:%M:%S %P %z" +} ADDED library/msgs/es_hn.msg Index: library/msgs/es_hn.msg ================================================================== --- /dev/null +++ library/msgs/es_hn.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset es_HN DATE_FORMAT "%m-%d-%Y" + ::msgcat::mcset es_HN TIME_FORMAT_12 "%I:%M:%S %P" + ::msgcat::mcset es_HN DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z" +} ADDED library/msgs/es_mx.msg Index: library/msgs/es_mx.msg ================================================================== --- /dev/null +++ library/msgs/es_mx.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset es_MX DATE_FORMAT "%e/%m/%Y" + ::msgcat::mcset es_MX TIME_FORMAT_12 "%I:%M:%S %P" + ::msgcat::mcset es_MX DATE_TIME_FORMAT "%e/%m/%Y %I:%M:%S %P %z" +} ADDED library/msgs/es_ni.msg Index: library/msgs/es_ni.msg ================================================================== --- /dev/null +++ library/msgs/es_ni.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset es_NI DATE_FORMAT "%m-%d-%Y" + ::msgcat::mcset es_NI TIME_FORMAT_12 "%I:%M:%S %P" + ::msgcat::mcset es_NI DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z" +} ADDED library/msgs/es_pa.msg Index: library/msgs/es_pa.msg ================================================================== --- /dev/null +++ library/msgs/es_pa.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset es_PA DATE_FORMAT "%m/%d/%Y" + ::msgcat::mcset es_PA TIME_FORMAT_12 "%I:%M:%S %P" + ::msgcat::mcset es_PA DATE_TIME_FORMAT "%m/%d/%Y %I:%M:%S %P %z" +} ADDED library/msgs/es_pe.msg Index: library/msgs/es_pe.msg ================================================================== --- /dev/null +++ library/msgs/es_pe.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset es_PE DATE_FORMAT "%d/%m/%Y" + ::msgcat::mcset es_PE TIME_FORMAT_12 "%I:%M:%S %P" + ::msgcat::mcset es_PE DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" +} ADDED library/msgs/es_pr.msg Index: library/msgs/es_pr.msg ================================================================== --- /dev/null +++ library/msgs/es_pr.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset es_PR DATE_FORMAT "%m-%d-%Y" + ::msgcat::mcset es_PR TIME_FORMAT_12 "%I:%M:%S %P" + ::msgcat::mcset es_PR DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z" +} ADDED library/msgs/es_py.msg Index: library/msgs/es_py.msg ================================================================== --- /dev/null +++ library/msgs/es_py.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset es_PY DATE_FORMAT "%d/%m/%Y" + ::msgcat::mcset es_PY TIME_FORMAT_12 "%I:%M:%S %P" + ::msgcat::mcset es_PY DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" +} ADDED library/msgs/es_sv.msg Index: library/msgs/es_sv.msg ================================================================== --- /dev/null +++ library/msgs/es_sv.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset es_SV DATE_FORMAT "%m-%d-%Y" + ::msgcat::mcset es_SV TIME_FORMAT_12 "%I:%M:%S %P" + ::msgcat::mcset es_SV DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z" +} ADDED library/msgs/es_uy.msg Index: library/msgs/es_uy.msg ================================================================== --- /dev/null +++ library/msgs/es_uy.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset es_UY DATE_FORMAT "%d/%m/%Y" + ::msgcat::mcset es_UY TIME_FORMAT_12 "%I:%M:%S %P" + ::msgcat::mcset es_UY DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" +} ADDED library/msgs/es_ve.msg Index: library/msgs/es_ve.msg ================================================================== --- /dev/null +++ library/msgs/es_ve.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset es_VE DATE_FORMAT "%d/%m/%Y" + ::msgcat::mcset es_VE TIME_FORMAT_12 "%I:%M:%S %P" + ::msgcat::mcset es_VE DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" +} DELETED library/msgs/eu_ES.msg Index: library/msgs/eu_ES.msg ================================================================== --- library/msgs/eu_ES.msg +++ /dev/null @@ -1,7 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset eu_ES DATE_FORMAT "%a, %Yeko %bren %da" - ::msgcat::mcset eu_ES TIME_FORMAT "%T" - ::msgcat::mcset eu_ES TIME_FORMAT_12 "%T" - ::msgcat::mcset eu_ES DATE_TIME_FORMAT "%y-%m-%d %T %z" -} ADDED library/msgs/eu_es.msg Index: library/msgs/eu_es.msg ================================================================== --- /dev/null +++ library/msgs/eu_es.msg @@ -0,0 +1,7 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset eu_ES DATE_FORMAT "%a, %Yeko %bren %da" + ::msgcat::mcset eu_ES TIME_FORMAT "%T" + ::msgcat::mcset eu_ES TIME_FORMAT_12 "%T" + ::msgcat::mcset eu_ES DATE_TIME_FORMAT "%y-%m-%d %T %z" +} DELETED library/msgs/fa_IN.msg Index: library/msgs/fa_IN.msg ================================================================== --- library/msgs/fa_IN.msg +++ /dev/null @@ -1,52 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset fa_IN DAYS_OF_WEEK_ABBREV [list \ - "\u06cc\u2214"\ - "\u062f\u2214"\ - "\u0633\u2214"\ - "\u0686\u2214"\ - "\u067e\u2214"\ - "\u062c\u2214"\ - "\u0634\u2214"] - ::msgcat::mcset fa_IN DAYS_OF_WEEK_FULL [list \ - "\u06cc\u06cc\u200c\u0634\u0646\u0628\u0647"\ - "\u062f\u0648\u0634\u0646\u0628\u0647"\ - "\u0633\u0647\u200c\u0634\u0646\u0628\u0647"\ - "\u0686\u0647\u0627\u0631\u0634\u0646\u0628\u0647"\ - "\u067e\u0646\u062c\u200c\u0634\u0646\u0628\u0647"\ - "\u062c\u0645\u0639\u0647"\ - "\u0634\u0646\u0628\u0647"] - ::msgcat::mcset fa_IN MONTHS_ABBREV [list \ - "\u0698\u0627\u0646"\ - "\u0641\u0648\u0631"\ - "\u0645\u0627\u0631"\ - "\u0622\u0648\u0631"\ - "\u0645\u0640\u0647"\ - "\u0698\u0648\u0646"\ - "\u0698\u0648\u06cc"\ - "\u0627\u0648\u062a"\ - "\u0633\u067e\u062a"\ - "\u0627\u0643\u062a"\ - "\u0646\u0648\u0627"\ - "\u062f\u0633\u0627"\ - ""] - ::msgcat::mcset fa_IN MONTHS_FULL [list \ - "\u0698\u0627\u0646\u0648\u06cc\u0647"\ - "\u0641\u0648\u0631\u0648\u06cc\u0647"\ - "\u0645\u0627\u0631\u0633"\ - "\u0622\u0648\u0631\u06cc\u0644"\ - "\u0645\u0647"\ - "\u0698\u0648\u0626\u0646"\ - "\u0698\u0648\u0626\u06cc\u0647"\ - "\u0627\u0648\u062a"\ - "\u0633\u067e\u062a\u0627\u0645\u0628\u0631"\ - "\u0627\u0643\u062a\u0628\u0631"\ - "\u0646\u0648\u0627\u0645\u0628\u0631"\ - "\u062f\u0633\u0627\u0645\u0628\u0631"\ - ""] - ::msgcat::mcset fa_IN AM "\u0635\u0628\u062d" - ::msgcat::mcset fa_IN PM "\u0639\u0635\u0631" - ::msgcat::mcset fa_IN DATE_FORMAT "%A %d %B %Y" - ::msgcat::mcset fa_IN TIME_FORMAT_12 "%I:%M:%S %z" - ::msgcat::mcset fa_IN DATE_TIME_FORMAT "%A %d %B %Y %I:%M:%S %z %z" -} DELETED library/msgs/fa_IR.msg Index: library/msgs/fa_IR.msg ================================================================== --- library/msgs/fa_IR.msg +++ /dev/null @@ -1,9 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset fa_IR AM "\u0635\u0628\u062d" - ::msgcat::mcset fa_IR PM "\u0639\u0635\u0631" - ::msgcat::mcset fa_IR DATE_FORMAT "%d\u2044%m\u2044%Y" - ::msgcat::mcset fa_IR TIME_FORMAT "%S:%M:%H" - ::msgcat::mcset fa_IR TIME_FORMAT_12 "%S:%M:%l %P" - ::msgcat::mcset fa_IR DATE_TIME_FORMAT "%d\u2044%m\u2044%Y %S:%M:%H %z" -} ADDED library/msgs/fa_in.msg Index: library/msgs/fa_in.msg ================================================================== --- /dev/null +++ library/msgs/fa_in.msg @@ -0,0 +1,52 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset fa_IN DAYS_OF_WEEK_ABBREV [list \ + "\u06cc\u2214"\ + "\u062f\u2214"\ + "\u0633\u2214"\ + "\u0686\u2214"\ + "\u067e\u2214"\ + "\u062c\u2214"\ + "\u0634\u2214"] + ::msgcat::mcset fa_IN DAYS_OF_WEEK_FULL [list \ + "\u06cc\u06cc\u200c\u0634\u0646\u0628\u0647"\ + "\u062f\u0648\u0634\u0646\u0628\u0647"\ + "\u0633\u0647\u200c\u0634\u0646\u0628\u0647"\ + "\u0686\u0647\u0627\u0631\u0634\u0646\u0628\u0647"\ + "\u067e\u0646\u062c\u200c\u0634\u0646\u0628\u0647"\ + "\u062c\u0645\u0639\u0647"\ + "\u0634\u0646\u0628\u0647"] + ::msgcat::mcset fa_IN MONTHS_ABBREV [list \ + "\u0698\u0627\u0646"\ + "\u0641\u0648\u0631"\ + "\u0645\u0627\u0631"\ + "\u0622\u0648\u0631"\ + "\u0645\u0640\u0647"\ + "\u0698\u0648\u0646"\ + "\u0698\u0648\u06cc"\ + "\u0627\u0648\u062a"\ + "\u0633\u067e\u062a"\ + "\u0627\u0643\u062a"\ + "\u0646\u0648\u0627"\ + "\u062f\u0633\u0627"\ + ""] + ::msgcat::mcset fa_IN MONTHS_FULL [list \ + "\u0698\u0627\u0646\u0648\u06cc\u0647"\ + "\u0641\u0648\u0631\u0648\u06cc\u0647"\ + "\u0645\u0627\u0631\u0633"\ + "\u0622\u0648\u0631\u06cc\u0644"\ + "\u0645\u0647"\ + "\u0698\u0648\u0626\u0646"\ + "\u0698\u0648\u0626\u06cc\u0647"\ + "\u0627\u0648\u062a"\ + "\u0633\u067e\u062a\u0627\u0645\u0628\u0631"\ + "\u0627\u0643\u062a\u0628\u0631"\ + "\u0646\u0648\u0627\u0645\u0628\u0631"\ + "\u062f\u0633\u0627\u0645\u0628\u0631"\ + ""] + ::msgcat::mcset fa_IN AM "\u0635\u0628\u062d" + ::msgcat::mcset fa_IN PM "\u0639\u0635\u0631" + ::msgcat::mcset fa_IN DATE_FORMAT "%A %d %B %Y" + ::msgcat::mcset fa_IN TIME_FORMAT_12 "%I:%M:%S %z" + ::msgcat::mcset fa_IN DATE_TIME_FORMAT "%A %d %B %Y %I:%M:%S %z %z" +} ADDED library/msgs/fa_ir.msg Index: library/msgs/fa_ir.msg ================================================================== --- /dev/null +++ library/msgs/fa_ir.msg @@ -0,0 +1,9 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset fa_IR AM "\u0635\u0628\u062d" + ::msgcat::mcset fa_IR PM "\u0639\u0635\u0631" + ::msgcat::mcset fa_IR DATE_FORMAT "%d\u2044%m\u2044%Y" + ::msgcat::mcset fa_IR TIME_FORMAT "%S:%M:%H" + ::msgcat::mcset fa_IR TIME_FORMAT_12 "%S:%M:%l %P" + ::msgcat::mcset fa_IR DATE_TIME_FORMAT "%d\u2044%m\u2044%Y %S:%M:%H %z" +} DELETED library/msgs/fo_FO.msg Index: library/msgs/fo_FO.msg ================================================================== --- library/msgs/fo_FO.msg +++ /dev/null @@ -1,7 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset fo_FO DATE_FORMAT "%d/%m-%Y" - ::msgcat::mcset fo_FO TIME_FORMAT "%T" - ::msgcat::mcset fo_FO TIME_FORMAT_12 "%T" - ::msgcat::mcset fo_FO DATE_TIME_FORMAT "%a %d %b %Y %T %z" -} ADDED library/msgs/fo_fo.msg Index: library/msgs/fo_fo.msg ================================================================== --- /dev/null +++ library/msgs/fo_fo.msg @@ -0,0 +1,7 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset fo_FO DATE_FORMAT "%d/%m-%Y" + ::msgcat::mcset fo_FO TIME_FORMAT "%T" + ::msgcat::mcset fo_FO TIME_FORMAT_12 "%T" + ::msgcat::mcset fo_FO DATE_TIME_FORMAT "%a %d %b %Y %T %z" +} DELETED library/msgs/fr_BE.msg Index: library/msgs/fr_BE.msg ================================================================== --- library/msgs/fr_BE.msg +++ /dev/null @@ -1,7 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset fr_BE DATE_FORMAT "%d/%m/%y" - ::msgcat::mcset fr_BE TIME_FORMAT "%T" - ::msgcat::mcset fr_BE TIME_FORMAT_12 "%T" - ::msgcat::mcset fr_BE DATE_TIME_FORMAT "%a %d %b %Y %T %z" -} DELETED library/msgs/fr_CA.msg Index: library/msgs/fr_CA.msg ================================================================== --- library/msgs/fr_CA.msg +++ /dev/null @@ -1,7 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset fr_CA DATE_FORMAT "%Y-%m-%d" - ::msgcat::mcset fr_CA TIME_FORMAT "%T" - ::msgcat::mcset fr_CA TIME_FORMAT_12 "%T" - ::msgcat::mcset fr_CA DATE_TIME_FORMAT "%a %d %b %Y %T %z" -} DELETED library/msgs/fr_CH.msg Index: library/msgs/fr_CH.msg ================================================================== --- library/msgs/fr_CH.msg +++ /dev/null @@ -1,7 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset fr_CH DATE_FORMAT "%d. %m. %y" - ::msgcat::mcset fr_CH TIME_FORMAT "%T" - ::msgcat::mcset fr_CH TIME_FORMAT_12 "%T" - ::msgcat::mcset fr_CH DATE_TIME_FORMAT "%a %d %b %Y %T %z" -} ADDED library/msgs/fr_be.msg Index: library/msgs/fr_be.msg ================================================================== --- /dev/null +++ library/msgs/fr_be.msg @@ -0,0 +1,7 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset fr_BE DATE_FORMAT "%d/%m/%y" + ::msgcat::mcset fr_BE TIME_FORMAT "%T" + ::msgcat::mcset fr_BE TIME_FORMAT_12 "%T" + ::msgcat::mcset fr_BE DATE_TIME_FORMAT "%a %d %b %Y %T %z" +} ADDED library/msgs/fr_ca.msg Index: library/msgs/fr_ca.msg ================================================================== --- /dev/null +++ library/msgs/fr_ca.msg @@ -0,0 +1,7 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset fr_CA DATE_FORMAT "%Y-%m-%d" + ::msgcat::mcset fr_CA TIME_FORMAT "%T" + ::msgcat::mcset fr_CA TIME_FORMAT_12 "%T" + ::msgcat::mcset fr_CA DATE_TIME_FORMAT "%a %d %b %Y %T %z" +} ADDED library/msgs/fr_ch.msg Index: library/msgs/fr_ch.msg ================================================================== --- /dev/null +++ library/msgs/fr_ch.msg @@ -0,0 +1,7 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset fr_CH DATE_FORMAT "%d. %m. %y" + ::msgcat::mcset fr_CH TIME_FORMAT "%T" + ::msgcat::mcset fr_CH TIME_FORMAT_12 "%T" + ::msgcat::mcset fr_CH DATE_TIME_FORMAT "%a %d %b %Y %T %z" +} DELETED library/msgs/ga_IE.msg Index: library/msgs/ga_IE.msg ================================================================== --- library/msgs/ga_IE.msg +++ /dev/null @@ -1,7 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset ga_IE DATE_FORMAT "%d.%m.%y" - ::msgcat::mcset ga_IE TIME_FORMAT "%T" - ::msgcat::mcset ga_IE TIME_FORMAT_12 "%T" - ::msgcat::mcset ga_IE DATE_TIME_FORMAT "%a %d %b %Y %T %z" -} ADDED library/msgs/ga_ie.msg Index: library/msgs/ga_ie.msg ================================================================== --- /dev/null +++ library/msgs/ga_ie.msg @@ -0,0 +1,7 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset ga_IE DATE_FORMAT "%d.%m.%y" + ::msgcat::mcset ga_IE TIME_FORMAT "%T" + ::msgcat::mcset ga_IE TIME_FORMAT_12 "%T" + ::msgcat::mcset ga_IE DATE_TIME_FORMAT "%a %d %b %Y %T %z" +} DELETED library/msgs/gl_ES.msg Index: library/msgs/gl_ES.msg ================================================================== --- library/msgs/gl_ES.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset gl_ES DATE_FORMAT "%d %B %Y" - ::msgcat::mcset gl_ES TIME_FORMAT_12 "%l:%M:%S %P" - ::msgcat::mcset gl_ES DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" -} ADDED library/msgs/gl_es.msg Index: library/msgs/gl_es.msg ================================================================== --- /dev/null +++ library/msgs/gl_es.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset gl_ES DATE_FORMAT "%d %B %Y" + ::msgcat::mcset gl_ES TIME_FORMAT_12 "%l:%M:%S %P" + ::msgcat::mcset gl_ES DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" +} DELETED library/msgs/gv_GB.msg Index: library/msgs/gv_GB.msg ================================================================== --- library/msgs/gv_GB.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset gv_GB DATE_FORMAT "%d %B %Y" - ::msgcat::mcset gv_GB TIME_FORMAT_12 "%l:%M:%S %P" - ::msgcat::mcset gv_GB DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" -} ADDED library/msgs/gv_gb.msg Index: library/msgs/gv_gb.msg ================================================================== --- /dev/null +++ library/msgs/gv_gb.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset gv_GB DATE_FORMAT "%d %B %Y" + ::msgcat::mcset gv_GB TIME_FORMAT_12 "%l:%M:%S %P" + ::msgcat::mcset gv_GB DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" +} DELETED library/msgs/hi_IN.msg Index: library/msgs/hi_IN.msg ================================================================== --- library/msgs/hi_IN.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset hi_IN DATE_FORMAT "%d %M %Y" - ::msgcat::mcset hi_IN TIME_FORMAT_12 "%I:%M:%S %P" - ::msgcat::mcset hi_IN DATE_TIME_FORMAT "%d %M %Y %I:%M:%S %P %z" -} ADDED library/msgs/hi_in.msg Index: library/msgs/hi_in.msg ================================================================== --- /dev/null +++ library/msgs/hi_in.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset hi_IN DATE_FORMAT "%d %M %Y" + ::msgcat::mcset hi_IN TIME_FORMAT_12 "%I:%M:%S %P" + ::msgcat::mcset hi_IN DATE_TIME_FORMAT "%d %M %Y %I:%M:%S %P %z" +} DELETED library/msgs/id_ID.msg Index: library/msgs/id_ID.msg ================================================================== --- library/msgs/id_ID.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset id_ID DATE_FORMAT "%d %B %Y" - ::msgcat::mcset id_ID TIME_FORMAT_12 "%l:%M:%S %P" - ::msgcat::mcset id_ID DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" -} ADDED library/msgs/id_id.msg Index: library/msgs/id_id.msg ================================================================== --- /dev/null +++ library/msgs/id_id.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset id_ID DATE_FORMAT "%d %B %Y" + ::msgcat::mcset id_ID TIME_FORMAT_12 "%l:%M:%S %P" + ::msgcat::mcset id_ID DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" +} DELETED library/msgs/it_CH.msg Index: library/msgs/it_CH.msg ================================================================== --- library/msgs/it_CH.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset it_CH DATE_FORMAT "%e. %B %Y" - ::msgcat::mcset it_CH TIME_FORMAT "%H:%M:%S" - ::msgcat::mcset it_CH DATE_TIME_FORMAT "%e. %B %Y %H:%M:%S %z" -} ADDED library/msgs/it_ch.msg Index: library/msgs/it_ch.msg ================================================================== --- /dev/null +++ library/msgs/it_ch.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset it_CH DATE_FORMAT "%e. %B %Y" + ::msgcat::mcset it_CH TIME_FORMAT "%H:%M:%S" + ::msgcat::mcset it_CH DATE_TIME_FORMAT "%e. %B %Y %H:%M:%S %z" +} DELETED library/msgs/kl_GL.msg Index: library/msgs/kl_GL.msg ================================================================== --- library/msgs/kl_GL.msg +++ /dev/null @@ -1,7 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset kl_GL DATE_FORMAT "%d %b %Y" - ::msgcat::mcset kl_GL TIME_FORMAT "%T" - ::msgcat::mcset kl_GL TIME_FORMAT_12 "%T" - ::msgcat::mcset kl_GL DATE_TIME_FORMAT "%a %d %b %Y %T %z" -} ADDED library/msgs/kl_gl.msg Index: library/msgs/kl_gl.msg ================================================================== --- /dev/null +++ library/msgs/kl_gl.msg @@ -0,0 +1,7 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset kl_GL DATE_FORMAT "%d %b %Y" + ::msgcat::mcset kl_GL TIME_FORMAT "%T" + ::msgcat::mcset kl_GL TIME_FORMAT_12 "%T" + ::msgcat::mcset kl_GL DATE_TIME_FORMAT "%a %d %b %Y %T %z" +} DELETED library/msgs/ko_KR.msg Index: library/msgs/ko_KR.msg ================================================================== --- library/msgs/ko_KR.msg +++ /dev/null @@ -1,8 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset ko_KR BCE "\uae30\uc6d0\uc804" - ::msgcat::mcset ko_KR CE "\uc11c\uae30" - ::msgcat::mcset ko_KR DATE_FORMAT "%Y.%m.%d" - ::msgcat::mcset ko_KR TIME_FORMAT_12 "%P %l:%M:%S" - ::msgcat::mcset ko_KR DATE_TIME_FORMAT "%Y.%m.%d %P %l:%M:%S %z" -} ADDED library/msgs/ko_kr.msg Index: library/msgs/ko_kr.msg ================================================================== --- /dev/null +++ library/msgs/ko_kr.msg @@ -0,0 +1,8 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset ko_KR BCE "\uae30\uc6d0\uc804" + ::msgcat::mcset ko_KR CE "\uc11c\uae30" + ::msgcat::mcset ko_KR DATE_FORMAT "%Y.%m.%d" + ::msgcat::mcset ko_KR TIME_FORMAT_12 "%P %l:%M:%S" + ::msgcat::mcset ko_KR DATE_TIME_FORMAT "%Y.%m.%d %P %l:%M:%S %z" +} DELETED library/msgs/kok_IN.msg Index: library/msgs/kok_IN.msg ================================================================== --- library/msgs/kok_IN.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset kok_IN DATE_FORMAT "%d %M %Y" - ::msgcat::mcset kok_IN TIME_FORMAT_12 "%I:%M:%S %P" - ::msgcat::mcset kok_IN DATE_TIME_FORMAT "%d %M %Y %I:%M:%S %P %z" -} ADDED library/msgs/kok_in.msg Index: library/msgs/kok_in.msg ================================================================== --- /dev/null +++ library/msgs/kok_in.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset kok_IN DATE_FORMAT "%d %M %Y" + ::msgcat::mcset kok_IN TIME_FORMAT_12 "%I:%M:%S %P" + ::msgcat::mcset kok_IN DATE_TIME_FORMAT "%d %M %Y %I:%M:%S %P %z" +} DELETED library/msgs/kw_GB.msg Index: library/msgs/kw_GB.msg ================================================================== --- library/msgs/kw_GB.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset kw_GB DATE_FORMAT "%d %B %Y" - ::msgcat::mcset kw_GB TIME_FORMAT_12 "%l:%M:%S %P" - ::msgcat::mcset kw_GB DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" -} ADDED library/msgs/kw_gb.msg Index: library/msgs/kw_gb.msg ================================================================== --- /dev/null +++ library/msgs/kw_gb.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset kw_GB DATE_FORMAT "%d %B %Y" + ::msgcat::mcset kw_GB TIME_FORMAT_12 "%l:%M:%S %P" + ::msgcat::mcset kw_GB DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" +} DELETED library/msgs/mr_IN.msg Index: library/msgs/mr_IN.msg ================================================================== --- library/msgs/mr_IN.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset mr_IN DATE_FORMAT "%d %M %Y" - ::msgcat::mcset mr_IN TIME_FORMAT_12 "%I:%M:%S %P" - ::msgcat::mcset mr_IN DATE_TIME_FORMAT "%d %M %Y %I:%M:%S %P %z" -} ADDED library/msgs/mr_in.msg Index: library/msgs/mr_in.msg ================================================================== --- /dev/null +++ library/msgs/mr_in.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset mr_IN DATE_FORMAT "%d %M %Y" + ::msgcat::mcset mr_IN TIME_FORMAT_12 "%I:%M:%S %P" + ::msgcat::mcset mr_IN DATE_TIME_FORMAT "%d %M %Y %I:%M:%S %P %z" +} DELETED library/msgs/ms_MY.msg Index: library/msgs/ms_MY.msg ================================================================== --- library/msgs/ms_MY.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset ms_MY DATE_FORMAT "%A %d %b %Y" - ::msgcat::mcset ms_MY TIME_FORMAT_12 "%I:%M:%S %z" - ::msgcat::mcset ms_MY DATE_TIME_FORMAT "%A %d %b %Y %I:%M:%S %z %z" -} ADDED library/msgs/ms_my.msg Index: library/msgs/ms_my.msg ================================================================== --- /dev/null +++ library/msgs/ms_my.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset ms_MY DATE_FORMAT "%A %d %b %Y" + ::msgcat::mcset ms_MY TIME_FORMAT_12 "%I:%M:%S %z" + ::msgcat::mcset ms_MY DATE_TIME_FORMAT "%A %d %b %Y %I:%M:%S %z %z" +} DELETED library/msgs/nl_BE.msg Index: library/msgs/nl_BE.msg ================================================================== --- library/msgs/nl_BE.msg +++ /dev/null @@ -1,7 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset nl_BE DATE_FORMAT "%d-%m-%y" - ::msgcat::mcset nl_BE TIME_FORMAT "%T" - ::msgcat::mcset nl_BE TIME_FORMAT_12 "%T" - ::msgcat::mcset nl_BE DATE_TIME_FORMAT "%a %d %b %Y %T %z" -} ADDED library/msgs/nl_be.msg Index: library/msgs/nl_be.msg ================================================================== --- /dev/null +++ library/msgs/nl_be.msg @@ -0,0 +1,7 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset nl_BE DATE_FORMAT "%d-%m-%y" + ::msgcat::mcset nl_BE TIME_FORMAT "%T" + ::msgcat::mcset nl_BE TIME_FORMAT_12 "%T" + ::msgcat::mcset nl_BE DATE_TIME_FORMAT "%a %d %b %Y %T %z" +} DELETED library/msgs/pt_BR.msg Index: library/msgs/pt_BR.msg ================================================================== --- library/msgs/pt_BR.msg +++ /dev/null @@ -1,7 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset pt_BR DATE_FORMAT "%d-%m-%Y" - ::msgcat::mcset pt_BR TIME_FORMAT "%T" - ::msgcat::mcset pt_BR TIME_FORMAT_12 "%T" - ::msgcat::mcset pt_BR DATE_TIME_FORMAT "%a %d %b %Y %T %z" -} ADDED library/msgs/pt_br.msg Index: library/msgs/pt_br.msg ================================================================== --- /dev/null +++ library/msgs/pt_br.msg @@ -0,0 +1,7 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset pt_BR DATE_FORMAT "%d-%m-%Y" + ::msgcat::mcset pt_BR TIME_FORMAT "%T" + ::msgcat::mcset pt_BR TIME_FORMAT_12 "%T" + ::msgcat::mcset pt_BR DATE_TIME_FORMAT "%a %d %b %Y %T %z" +} DELETED library/msgs/ru_UA.msg Index: library/msgs/ru_UA.msg ================================================================== --- library/msgs/ru_UA.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset ru_UA DATE_FORMAT "%d.%m.%Y" - ::msgcat::mcset ru_UA TIME_FORMAT "%k:%M:%S" - ::msgcat::mcset ru_UA DATE_TIME_FORMAT "%d.%m.%Y %k:%M:%S %z" -} ADDED library/msgs/ru_ua.msg Index: library/msgs/ru_ua.msg ================================================================== --- /dev/null +++ library/msgs/ru_ua.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset ru_UA DATE_FORMAT "%d.%m.%Y" + ::msgcat::mcset ru_UA TIME_FORMAT "%k:%M:%S" + ::msgcat::mcset ru_UA DATE_TIME_FORMAT "%d.%m.%Y %k:%M:%S %z" +} DELETED library/msgs/ta_IN.msg Index: library/msgs/ta_IN.msg ================================================================== --- library/msgs/ta_IN.msg +++ /dev/null @@ -1,6 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset ta_IN DATE_FORMAT "%d %M %Y" - ::msgcat::mcset ta_IN TIME_FORMAT_12 "%I:%M:%S %P" - ::msgcat::mcset ta_IN DATE_TIME_FORMAT "%d %M %Y %I:%M:%S %P %z" -} ADDED library/msgs/ta_in.msg Index: library/msgs/ta_in.msg ================================================================== --- /dev/null +++ library/msgs/ta_in.msg @@ -0,0 +1,6 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset ta_IN DATE_FORMAT "%d %M %Y" + ::msgcat::mcset ta_IN TIME_FORMAT_12 "%I:%M:%S %P" + ::msgcat::mcset ta_IN DATE_TIME_FORMAT "%d %M %Y %I:%M:%S %P %z" +} DELETED library/msgs/te_IN.msg Index: library/msgs/te_IN.msg ================================================================== --- library/msgs/te_IN.msg +++ /dev/null @@ -1,8 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset te_IN AM "\u0c2a\u0c42\u0c30\u0c4d\u0c35\u0c3e\u0c39\u0c4d\u0c28" - ::msgcat::mcset te_IN PM "\u0c05\u0c2a\u0c30\u0c3e\u0c39\u0c4d\u0c28" - ::msgcat::mcset te_IN DATE_FORMAT "%d/%m/%Y" - ::msgcat::mcset te_IN TIME_FORMAT_12 "%I:%M:%S %P" - ::msgcat::mcset te_IN DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" -} ADDED library/msgs/te_in.msg Index: library/msgs/te_in.msg ================================================================== --- /dev/null +++ library/msgs/te_in.msg @@ -0,0 +1,8 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset te_IN AM "\u0c2a\u0c42\u0c30\u0c4d\u0c35\u0c3e\u0c39\u0c4d\u0c28" + ::msgcat::mcset te_IN PM "\u0c05\u0c2a\u0c30\u0c3e\u0c39\u0c4d\u0c28" + ::msgcat::mcset te_IN DATE_FORMAT "%d/%m/%Y" + ::msgcat::mcset te_IN TIME_FORMAT_12 "%I:%M:%S %P" + ::msgcat::mcset te_IN DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" +} DELETED library/msgs/zh_CN.msg Index: library/msgs/zh_CN.msg ================================================================== --- library/msgs/zh_CN.msg +++ /dev/null @@ -1,7 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset zh_CN DATE_FORMAT "%Y-%m-%e" - ::msgcat::mcset zh_CN TIME_FORMAT "%k:%M:%S" - ::msgcat::mcset zh_CN TIME_FORMAT_12 "%P%I\u65f6%M\u5206%S\u79d2" - ::msgcat::mcset zh_CN DATE_TIME_FORMAT "%Y-%m-%e %k:%M:%S %z" -} DELETED library/msgs/zh_HK.msg Index: library/msgs/zh_HK.msg ================================================================== --- library/msgs/zh_HK.msg +++ /dev/null @@ -1,28 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset zh_HK DAYS_OF_WEEK_ABBREV [list \ - "\u65e5"\ - "\u4e00"\ - "\u4e8c"\ - "\u4e09"\ - "\u56db"\ - "\u4e94"\ - "\u516d"] - ::msgcat::mcset zh_HK MONTHS_ABBREV [list \ - "1\u6708"\ - "2\u6708"\ - "3\u6708"\ - "4\u6708"\ - "5\u6708"\ - "6\u6708"\ - "7\u6708"\ - "8\u6708"\ - "9\u6708"\ - "10\u6708"\ - "11\u6708"\ - "12\u6708"\ - ""] - ::msgcat::mcset zh_HK DATE_FORMAT "%Y\u5e74%m\u6708%e\u65e5" - ::msgcat::mcset zh_HK TIME_FORMAT_12 "%P%I:%M:%S" - ::msgcat::mcset zh_HK DATE_TIME_FORMAT "%Y\u5e74%m\u6708%e\u65e5 %P%I:%M:%S %z" -} DELETED library/msgs/zh_SG.msg Index: library/msgs/zh_SG.msg ================================================================== --- library/msgs/zh_SG.msg +++ /dev/null @@ -1,8 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset zh_SG AM "\u4e0a\u5348" - ::msgcat::mcset zh_SG PM "\u4e2d\u5348" - ::msgcat::mcset zh_SG DATE_FORMAT "%d %B %Y" - ::msgcat::mcset zh_SG TIME_FORMAT_12 "%P %I:%M:%S" - ::msgcat::mcset zh_SG DATE_TIME_FORMAT "%d %B %Y %P %I:%M:%S %z" -} DELETED library/msgs/zh_TW.msg Index: library/msgs/zh_TW.msg ================================================================== --- library/msgs/zh_TW.msg +++ /dev/null @@ -1,8 +0,0 @@ -# created by tools/loadICU.tcl -- do not edit -namespace eval ::tcl::clock { - ::msgcat::mcset zh_TW BCE "\u6c11\u570b\u524d" - ::msgcat::mcset zh_TW CE "\u6c11\u570b" - ::msgcat::mcset zh_TW DATE_FORMAT "%Y/%m/%e" - ::msgcat::mcset zh_TW TIME_FORMAT_12 "%P %I:%M:%S" - ::msgcat::mcset zh_TW DATE_TIME_FORMAT "%Y/%m/%e %P %I:%M:%S %z" -} ADDED library/msgs/zh_cn.msg Index: library/msgs/zh_cn.msg ================================================================== --- /dev/null +++ library/msgs/zh_cn.msg @@ -0,0 +1,7 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset zh_CN DATE_FORMAT "%Y-%m-%e" + ::msgcat::mcset zh_CN TIME_FORMAT "%k:%M:%S" + ::msgcat::mcset zh_CN TIME_FORMAT_12 "%P%I\u65f6%M\u5206%S\u79d2" + ::msgcat::mcset zh_CN DATE_TIME_FORMAT "%Y-%m-%e %k:%M:%S %z" +} ADDED library/msgs/zh_hk.msg Index: library/msgs/zh_hk.msg ================================================================== --- /dev/null +++ library/msgs/zh_hk.msg @@ -0,0 +1,28 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset zh_HK DAYS_OF_WEEK_ABBREV [list \ + "\u65e5"\ + "\u4e00"\ + "\u4e8c"\ + "\u4e09"\ + "\u56db"\ + "\u4e94"\ + "\u516d"] + ::msgcat::mcset zh_HK MONTHS_ABBREV [list \ + "1\u6708"\ + "2\u6708"\ + "3\u6708"\ + "4\u6708"\ + "5\u6708"\ + "6\u6708"\ + "7\u6708"\ + "8\u6708"\ + "9\u6708"\ + "10\u6708"\ + "11\u6708"\ + "12\u6708"\ + ""] + ::msgcat::mcset zh_HK DATE_FORMAT "%Y\u5e74%m\u6708%e\u65e5" + ::msgcat::mcset zh_HK TIME_FORMAT_12 "%P%I:%M:%S" + ::msgcat::mcset zh_HK DATE_TIME_FORMAT "%Y\u5e74%m\u6708%e\u65e5 %P%I:%M:%S %z" +} ADDED library/msgs/zh_sg.msg Index: library/msgs/zh_sg.msg ================================================================== --- /dev/null +++ library/msgs/zh_sg.msg @@ -0,0 +1,8 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset zh_SG AM "\u4e0a\u5348" + ::msgcat::mcset zh_SG PM "\u4e2d\u5348" + ::msgcat::mcset zh_SG DATE_FORMAT "%d %B %Y" + ::msgcat::mcset zh_SG TIME_FORMAT_12 "%P %I:%M:%S" + ::msgcat::mcset zh_SG DATE_TIME_FORMAT "%d %B %Y %P %I:%M:%S %z" +} ADDED library/msgs/zh_tw.msg Index: library/msgs/zh_tw.msg ================================================================== --- /dev/null +++ library/msgs/zh_tw.msg @@ -0,0 +1,8 @@ +# created by tools/loadICU.tcl -- do not edit +namespace eval ::tcl::clock { + ::msgcat::mcset zh_TW BCE "\u6c11\u570b\u524d" + ::msgcat::mcset zh_TW CE "\u6c11\u570b" + ::msgcat::mcset zh_TW DATE_FORMAT "%Y/%m/%e" + ::msgcat::mcset zh_TW TIME_FORMAT_12 "%P %I:%M:%S" + ::msgcat::mcset zh_TW DATE_TIME_FORMAT "%Y/%m/%e %P %I:%M:%S %z" +} Index: library/package.tcl ================================================================== --- library/package.tcl +++ library/package.tcl @@ -1,11 +1,11 @@ # package.tcl -- # # utility procs formerly in init.tcl which can be loaded on demand # for package management. # -# RCS: @(#) $Id: package.tcl,v 1.32 2004/08/02 22:01:38 dgp Exp $ +# RCS: @(#) $Id: package.tcl,v 1.32.2.1 2005/08/02 18:16:15 dgp Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1998 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution @@ -29,20 +29,20 @@ # Results: # Returns 1 if the extension matches, 0 otherwise proc tcl::Pkg::CompareExtension { fileName {ext {}} } { global tcl_platform - if {![string length $ext]} {set ext [info sharedlibextension]} - if {[string equal $tcl_platform(platform) "windows"]} { + if {$ext eq ""} {set ext [info sharedlibextension]} + if {$tcl_platform(platform) eq "windows"} { return [string equal -nocase [file extension $fileName] $ext] } else { # Some unices add trailing numbers after the .so, so # we could have something like '.so.1.2'. set root $fileName while {1} { set currExt [file extension $root] - if {[string equal $currExt $ext]} { + if {$currExt eq $ext} { return 1 } # The current extension does not match; if it is not a numeric # value, quit, as we are only looking to ignore version number @@ -133,30 +133,30 @@ if {[llength $patternList] == 0} { set patternList [list "*.tcl" "*[info sharedlibextension]"] } if {[catch { - glob -directory $dir -tails -types {r f} {expand}$patternList + glob -directory $dir -tails -types {r f} -- {expand}$patternList } fileList o]} { return -options $o $fileList } foreach file $fileList { # For each file, figure out what commands and packages it provides. # To do this, create a child interpreter, load the file into the # interpreter, and get a list of the new commands and packages # that are defined. - if {[string equal $file pkgIndex.tcl]} { + if {$file eq "pkgIndex.tcl"} { continue } set c [interp create] # Load into the child any packages currently loaded in the parent # interpreter that match the -load pattern. - if {[string length $loadPat]} { + if {$loadPat ne ""} { if {$doVerbose} { tclLog "currently loaded packages: '[info loaded]'" tclLog "trying to load all packages matching $loadPat" } if {![llength [info loaded]]} { @@ -178,11 +178,11 @@ tclLog "warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err" } } elseif {$doVerbose} { tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]" } - if {[string equal [lindex $pkg 1] "Tk"]} { + if {[lindex $pkg 1] eq "Tk"} { # Withdraw . if Tk was loaded, to avoid showing a window. $c eval [list wm withdraw .] } } @@ -261,11 +261,11 @@ foreach ::tcl::x [::tcl::GetAllNamespaces] { set ::tcl::namespaces($::tcl::x) 1 } foreach ::tcl::x [package names] { - if {[string compare [package provide $::tcl::x] ""]} { + if {[package provide $::tcl::x] ne ""} { set ::tcl::packages($::tcl::x) 1 } } set ::tcl::origCmds [info commands] @@ -309,11 +309,11 @@ foreach ::tcl::x [info commands] { set ::tcl::newCmds($::tcl::x) 1 } foreach ::tcl::x $::tcl::origCmds { - catch {unset ::tcl::newCmds($::tcl::x)} + unset -nocomplain ::tcl::newCmds($::tcl::x) } foreach ::tcl::x [array names ::tcl::newCmds] { # determine which namespace a command comes from set ::tcl::abs [namespace origin $::tcl::x] @@ -322,11 +322,11 @@ # ::, this is required by the unknown command set ::tcl::abs \ [lindex [auto_qualify $::tcl::abs ::] 0] - if {[string compare $::tcl::x $::tcl::abs]} { + if {$::tcl::x ne $::tcl::abs} { # Name changed during qualification set ::tcl::newCmds($::tcl::abs) 1 unset ::tcl::newCmds($::tcl::x) } @@ -336,11 +336,11 @@ # Look through the packages that appeared, and if there is # a version provided, then record it foreach ::tcl::x [package names] { - if {[string compare [package provide $::tcl::x] ""] \ + if {[package provide $::tcl::x] ne "" && ![info exists ::tcl::packages($::tcl::x)]} { lappend ::tcl::newPkgs \ [list $::tcl::x [package provide $::tcl::x]] } } @@ -435,11 +435,11 @@ package provide $pkg $version foreach fileInfo $files { set f [lindex $fileInfo 0] set type [lindex $fileInfo 1] foreach cmd [lindex $fileInfo 2] { - if {[string equal $type "load"]} { + if {$type eq "load"} { set auto_index($cmd) [list load [file join $dir $f] $pkg] } else { set auto_index($cmd) [list source [file join $dir $f]] } } Index: library/parray.tcl ================================================================== --- library/parray.tcl +++ library/parray.tcl @@ -1,9 +1,9 @@ # parray: # Print the contents of a global array on stdout. # -# RCS: @(#) $Id: parray.tcl,v 1.3 1998/09/14 18:40:03 stanton Exp $ +# RCS: @(#) $Id: parray.tcl,v 1.3.44.1 2005/07/12 20:37:06 kennykb Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution @@ -14,16 +14,17 @@ upvar 1 $a array if {![array exists array]} { error "\"$a\" isn't an array" } set maxl 0 - foreach name [lsort [array names array $pattern]] { + set names [lsort [array names array $pattern]] + foreach name $names { if {[string length $name] > $maxl} { set maxl [string length $name] } } set maxl [expr {$maxl + [string length $a] + 2}] - foreach name [lsort [array names array $pattern]] { + foreach name $names { set nameString [format %s(%s) $a $name] puts stdout [format "%-*s = %s" $maxl $nameString $array($name)] } } Index: library/safe.tcl ================================================================== --- library/safe.tcl +++ library/safe.tcl @@ -10,11 +10,11 @@ # Copyright (c) 1996-1997 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: safe.tcl,v 1.14 2004/06/29 09:34:44 dkf Exp $ +# RCS: @(#) $Id: safe.tcl,v 1.14.2.1 2005/08/02 18:16:15 dgp Exp $ # # The implementation is based on namespaces. These naming conventions # are followed: # Private procs starts with uppercase. @@ -75,11 +75,11 @@ proc InterpStatics {} { foreach v {Args statics noStatics} { upvar $v $v } set flag [::tcl::OptProcArgGiven -noStatics]; - if {$flag && ($noStatics == $statics) + if {$flag && (!$noStatics == !$statics) && ([::tcl::OptProcArgGiven -statics])} { return -code error\ "conflicting values given for -statics and -noStatics" } if {$flag} { @@ -96,11 +96,11 @@ upvar $v $v } set flag [::tcl::OptProcArgGiven -nestedLoadOk]; # note that the test here is the opposite of the "InterpStatics" # one (it is not -noNested... because of the wanted default value) - if {$flag && ($nestedLoadOk != $nested) + if {$flag && (!$nestedLoadOk != !$nested) && ([::tcl::OptProcArgGiven -nested])} { return -code error\ "conflicting values given for -nested and -nestedLoadOk" } if {$flag} { @@ -322,11 +322,11 @@ proc ::safe::InterpSetConfig {slave access_path staticsok\ nestedok deletehook} { # determine and store the access path if empty - if {[string equal "" $access_path]} { + if {$access_path eq ""} { set access_path [uplevel \#0 set auto_path] # Make sure that tcl_library is in auto_path # and at the first position (needed by setAccessPath) set where [lsearch -exact $access_path [info library]] if {$where == -1} { @@ -762,11 +762,11 @@ set package [lindex $args 0] # Determine where to load. load use a relative interp path # and {} means self, so we can directly and safely use passed arg. set target [lindex $args 1] - if {[string length $target]} { + if {$target ne ""} { # we will try to load into a sub sub interp # check that we want to authorize that. if {![NestedOk $slave]} { Log $slave "loading to a sub interp (nestedok)\ disabled (trying to load $package to $target)" @@ -774,13 +774,13 @@ } } # Determine what kind of load is requested - if {[string length $file] == 0} { + if {$file eq ""} { # static package loading - if {[string length $package] == 0} { + if {$package eq ""} { set msg "load error: empty filename and no package name" Log $slave $msg return -code error $msg } if {![StaticsOk $slave]} { @@ -844,11 +844,11 @@ # the subcommands of a command: proc Subset {slave command okpat args} { set subcommand [lindex $args 0] if {[regexp $okpat $subcommand]} { - return [$command $subcommand {expand}[lrange $args 1 end]] + return [$command {expand}$args] } set msg "not allowed to invoke subcommand $subcommand of $command" Log $slave $msg error $msg } @@ -879,15 +879,14 @@ set okpat "^(name.*|convert.*)\$" set subcommand [lindex $args 0] if {[regexp $okpat $subcommand]} { - return [::interp invokehidden $slave encoding $subcommand \ - {expand}[lrange $args 1 end]] + return [::interp invokehidden $slave encoding {expand}$args] } - if {[string match $subcommand system]} { + if {[string first $subcommand system] == 0} { if {$argc == 1} { # passed all the tests , lets source it: if {[catch {::interp invokehidden \ $slave encoding system} msg]} { Log $slave $msg Index: library/tclIndex ================================================================== --- library/tclIndex +++ library/tclIndex @@ -72,10 +72,16 @@ set auto_index(::safe::AliasSource) [list source [file join $dir safe.tcl]] set auto_index(::safe::AliasLoad) [list source [file join $dir safe.tcl]] set auto_index(::safe::FileInAccessPath) [list source [file join $dir safe.tcl]] set auto_index(::safe::Subset) [list source [file join $dir safe.tcl]] set auto_index(::safe::AliasSubset) [list source [file join $dir safe.tcl]] +set auto_index(::safe::AliasEncoding) [list source [file join $dir safe.tcl]] set auto_index(tcl_wordBreakAfter) [list source [file join $dir word.tcl]] set auto_index(tcl_wordBreakBefore) [list source [file join $dir word.tcl]] set auto_index(tcl_endOfWord) [list source [file join $dir word.tcl]] set auto_index(tcl_startOfNextWord) [list source [file join $dir word.tcl]] set auto_index(tcl_startOfPreviousWord) [list source [file join $dir word.tcl]] +set auto_index(::tcl::tm::add) [list source [file join $dir tm.tcl]] +set auto_index(::tcl::tm::remove) [list source [file join $dir tm.tcl]] +set auto_index(::tcl::tm::list) [list source [file join $dir tm.tcl]] +set auto_index(::tcl::tm::UnknownHandler) [list source [file join $dir tm.tcl]] +set auto_index(::tcl::tm::roots) [list source [file join $dir tm.tcl]] Index: library/tcltest/pkgIndex.tcl ================================================================== --- library/tcltest/pkgIndex.tcl +++ library/tcltest/pkgIndex.tcl @@ -7,6 +7,6 @@ # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.3]} {return} -package ifneeded tcltest 2.2.7 [list source [file join $dir tcltest.tcl]] +package ifneeded tcltest 2.2.8 [list source [file join $dir tcltest.tcl]] Index: library/tcltest/tcltest.tcl ================================================================== --- library/tcltest/tcltest.tcl +++ library/tcltest/tcltest.tcl @@ -14,19 +14,19 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2000 by Ajuba Solutions # Contributions from Don Porter, NIST, 2002. (not subject to US copyright) # All rights reserved. # -# RCS: @(#) $Id: tcltest.tcl,v 1.93 2004/11/02 19:03:29 dgp Exp $ +# RCS: @(#) $Id: tcltest.tcl,v 1.93.2.1 2005/03/09 15:57:18 kennykb Exp $ package require Tcl 8.3 ;# uses [glob -directory] namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.2.7 + variable Version 2.2.8 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] # yourself. You don't need tcltest to wrap it for you. variable version [package provide Tcl] @@ -2567,18 +2567,20 @@ # List files in $directory that match patterns to run. set matchFileList [list] foreach match [matchFiles] { set matchFileList [concat $matchFileList \ - [glob -directory $directory -nocomplain -- $match]] + [glob -directory $directory -types {b c f p s} \ + -nocomplain -- $match]] } # List files in $directory that match patterns to skip. set skipFileList [list] foreach skip [skipFiles] { set skipFileList [concat $skipFileList \ - [glob -directory $directory -nocomplain -- $skip]] + [glob -directory $directory -types {b c f p s} \ + -nocomplain -- $skip]] } # Add to result list all files in match list and not in skip list foreach file $matchFileList { if {[lsearch -exact $skipFileList $file] == -1} { @@ -2616,29 +2618,24 @@ # Determine the skip list first, to avoid [glob]-ing over subdirectories # we're going to throw away anyway. Be sure we skip the $rootdir if it # comes up to avoid infinite loops. set skipDirs [list $rootdir] foreach pattern [skipDirectories] { - foreach path [glob -directory $rootdir -nocomplain -- $pattern] { - if {[file isdirectory $path]} { - lappend skipDirs $path - } - } + set skipDirs [concat $skipDirs [glob -directory $rootdir -types d \ + -nocomplain -- $pattern]] } # Now step through the matching directories, prune out the skipped ones # as you go. set matchDirs [list] foreach pattern [matchDirectories] { - foreach path [glob -directory $rootdir -nocomplain -- $pattern] { - if {[file isdirectory $path]} { - if {[lsearch -exact $skipDirs $path] == -1} { - set matchDirs [concat $matchDirs \ - [GetMatchingDirectories $path]] - if {[file exists [file join $path all.tcl]]} { - lappend matchDirs $path - } + foreach path [glob -directory $rootdir -types d -nocomplain -- \ + $pattern] { + if {[lsearch -exact $skipDirs $path] == -1} { + set matchDirs [concat $matchDirs [GetMatchingDirectories $path]] + if {[file exists [file join $path all.tcl]]} { + lappend matchDirs $path } } } } Index: library/tm.tcl ================================================================== --- library/tm.tcl +++ library/tm.tcl @@ -351,15 +351,14 @@ foreach pa $paths { set p [file join $pa tcl$major] for {set n $minor} {$n >= 0} {incr n -1} { path add [file normalize [file join $p ${major}.${n}]] } - path add [file normalize [file join $pa site-tcl]] + path add [file normalize [file join $p site-tcl]] } return } # Initialization. Set up the default paths, then insert the new # handler into the chain. ::tcl::tm::Defaults -package unknown [list ::tcl::tm::UnknownHandler [package unknown]] Index: library/tzdata/Africa/Timbuktu ================================================================== --- library/tzdata/Africa/Timbuktu +++ library/tzdata/Africa/Timbuktu @@ -1,6 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit - -set TZData(:Africa/Timbuktu) { - {-9223372036854775808 -724 0 LMT} - {-1830383276 0 0 GMT} +if {![info exists TZData(Africa/Bamako)]} { + LoadTimeZoneFile Africa/Bamako } +set TZData(:Africa/Timbuktu) $TZData(:Africa/Bamako) Index: library/tzdata/Africa/Tunis ================================================================== --- library/tzdata/Africa/Tunis +++ library/tzdata/Africa/Tunis @@ -26,6 +26,8 @@ {591148800 3600 0 CET} {606873600 7200 1 CEST} {622598400 3600 0 CET} {641520000 7200 1 CEST} {654652800 3600 0 CET} + {1114905600 7200 1 CEST} + {1128042000 3600 0 CET} } Index: library/tzdata/America/Adak ================================================================== --- library/tzdata/America/Adak +++ library/tzdata/America/Adak @@ -85,192 +85,192 @@ {1099220400 -36000 0 HAST} {1112529600 -32400 1 HADT} {1130670000 -36000 0 HAST} {1143979200 -32400 1 HADT} {1162119600 -36000 0 HAST} - {1175428800 -32400 1 HADT} - {1193569200 -36000 0 HAST} - {1207483200 -32400 1 HADT} - {1225018800 -36000 0 HAST} - {1238932800 -32400 1 HADT} - {1256468400 -36000 0 HAST} - {1270382400 -32400 1 HADT} - {1288522800 -36000 0 HAST} - {1301832000 -32400 1 HADT} - {1319972400 -36000 0 HAST} - {1333281600 -32400 1 HADT} - {1351422000 -36000 0 HAST} - {1365336000 -32400 1 HADT} - {1382871600 -36000 0 HAST} - {1396785600 -32400 1 HADT} - {1414321200 -36000 0 HAST} - {1428235200 -32400 1 HADT} - {1445770800 -36000 0 HAST} - {1459684800 -32400 1 HADT} - {1477825200 -36000 0 HAST} - {1491134400 -32400 1 HADT} - {1509274800 -36000 0 HAST} - {1522584000 -32400 1 HADT} - {1540724400 -36000 0 HAST} - {1554638400 -32400 1 HADT} - {1572174000 -36000 0 HAST} - {1586088000 -32400 1 HADT} - {1603623600 -36000 0 HAST} - {1617537600 -32400 1 HADT} - {1635678000 -36000 0 HAST} - {1648987200 -32400 1 HADT} - {1667127600 -36000 0 HAST} - {1680436800 -32400 1 HADT} - {1698577200 -36000 0 HAST} - {1712491200 -32400 1 HADT} - {1730026800 -36000 0 HAST} - {1743940800 -32400 1 HADT} - {1761476400 -36000 0 HAST} - {1775390400 -32400 1 HADT} - {1792926000 -36000 0 HAST} - {1806840000 -32400 1 HADT} - {1824980400 -36000 0 HAST} - {1838289600 -32400 1 HADT} - {1856430000 -36000 0 HAST} - {1869739200 -32400 1 HADT} - {1887879600 -36000 0 HAST} - {1901793600 -32400 1 HADT} - {1919329200 -36000 0 HAST} - {1933243200 -32400 1 HADT} - {1950778800 -36000 0 HAST} - {1964692800 -32400 1 HADT} - {1982833200 -36000 0 HAST} - {1996142400 -32400 1 HADT} - {2014282800 -36000 0 HAST} - {2027592000 -32400 1 HADT} - {2045732400 -36000 0 HAST} - {2059041600 -32400 1 HADT} - {2077182000 -36000 0 HAST} - {2091096000 -32400 1 HADT} - {2108631600 -36000 0 HAST} - {2122545600 -32400 1 HADT} - {2140081200 -36000 0 HAST} - {2153995200 -32400 1 HADT} - {2172135600 -36000 0 HAST} - {2185444800 -32400 1 HADT} - {2203585200 -36000 0 HAST} - {2216894400 -32400 1 HADT} - {2235034800 -36000 0 HAST} - {2248948800 -32400 1 HADT} - {2266484400 -36000 0 HAST} - {2280398400 -32400 1 HADT} - {2297934000 -36000 0 HAST} - {2311848000 -32400 1 HADT} - {2329383600 -36000 0 HAST} - {2343297600 -32400 1 HADT} - {2361438000 -36000 0 HAST} - {2374747200 -32400 1 HADT} - {2392887600 -36000 0 HAST} - {2406196800 -32400 1 HADT} - {2424337200 -36000 0 HAST} - {2438251200 -32400 1 HADT} - {2455786800 -36000 0 HAST} - {2469700800 -32400 1 HADT} - {2487236400 -36000 0 HAST} - {2501150400 -32400 1 HADT} - {2519290800 -36000 0 HAST} - {2532600000 -32400 1 HADT} - {2550740400 -36000 0 HAST} - {2564049600 -32400 1 HADT} - {2582190000 -36000 0 HAST} - {2596104000 -32400 1 HADT} - {2613639600 -36000 0 HAST} - {2627553600 -32400 1 HADT} - {2645089200 -36000 0 HAST} - {2659003200 -32400 1 HADT} - {2676538800 -36000 0 HAST} - {2690452800 -32400 1 HADT} - {2708593200 -36000 0 HAST} - {2721902400 -32400 1 HADT} - {2740042800 -36000 0 HAST} - {2753352000 -32400 1 HADT} - {2771492400 -36000 0 HAST} - {2785406400 -32400 1 HADT} - {2802942000 -36000 0 HAST} - {2816856000 -32400 1 HADT} - {2834391600 -36000 0 HAST} - {2848305600 -32400 1 HADT} - {2866446000 -36000 0 HAST} - {2879755200 -32400 1 HADT} - {2897895600 -36000 0 HAST} - {2911204800 -32400 1 HADT} - {2929345200 -36000 0 HAST} - {2942654400 -32400 1 HADT} - {2960794800 -36000 0 HAST} - {2974708800 -32400 1 HADT} - {2992244400 -36000 0 HAST} - {3006158400 -32400 1 HADT} - {3023694000 -36000 0 HAST} - {3037608000 -32400 1 HADT} - {3055748400 -36000 0 HAST} - {3069057600 -32400 1 HADT} - {3087198000 -36000 0 HAST} - {3100507200 -32400 1 HADT} - {3118647600 -36000 0 HAST} - {3132561600 -32400 1 HADT} - {3150097200 -36000 0 HAST} - {3164011200 -32400 1 HADT} - {3181546800 -36000 0 HAST} - {3195460800 -32400 1 HADT} - {3212996400 -36000 0 HAST} - {3226910400 -32400 1 HADT} - {3245050800 -36000 0 HAST} - {3258360000 -32400 1 HADT} - {3276500400 -36000 0 HAST} - {3289809600 -32400 1 HADT} - {3307950000 -36000 0 HAST} - {3321864000 -32400 1 HADT} - {3339399600 -36000 0 HAST} - {3353313600 -32400 1 HADT} - {3370849200 -36000 0 HAST} - {3384763200 -32400 1 HADT} - {3402903600 -36000 0 HAST} - {3416212800 -32400 1 HADT} - {3434353200 -36000 0 HAST} - {3447662400 -32400 1 HADT} - {3465802800 -36000 0 HAST} - {3479716800 -32400 1 HADT} - {3497252400 -36000 0 HAST} - {3511166400 -32400 1 HADT} - {3528702000 -36000 0 HAST} - {3542616000 -32400 1 HADT} - {3560151600 -36000 0 HAST} - {3574065600 -32400 1 HADT} - {3592206000 -36000 0 HAST} - {3605515200 -32400 1 HADT} - {3623655600 -36000 0 HAST} - {3636964800 -32400 1 HADT} - {3655105200 -36000 0 HAST} - {3669019200 -32400 1 HADT} - {3686554800 -36000 0 HAST} - {3700468800 -32400 1 HADT} - {3718004400 -36000 0 HAST} - {3731918400 -32400 1 HADT} - {3750058800 -36000 0 HAST} - {3763368000 -32400 1 HADT} - {3781508400 -36000 0 HAST} - {3794817600 -32400 1 HADT} - {3812958000 -36000 0 HAST} - {3826267200 -32400 1 HADT} - {3844407600 -36000 0 HAST} - {3858321600 -32400 1 HADT} - {3875857200 -36000 0 HAST} - {3889771200 -32400 1 HADT} - {3907306800 -36000 0 HAST} - {3921220800 -32400 1 HADT} - {3939361200 -36000 0 HAST} - {3952670400 -32400 1 HADT} - {3970810800 -36000 0 HAST} - {3984120000 -32400 1 HADT} - {4002260400 -36000 0 HAST} - {4016174400 -32400 1 HADT} - {4033710000 -36000 0 HAST} - {4047624000 -32400 1 HADT} - {4065159600 -36000 0 HAST} - {4079073600 -32400 1 HADT} - {4096609200 -36000 0 HAST} + {1173614400 -32400 1 HADT} + {1194174000 -36000 0 HAST} + {1205064000 -32400 1 HADT} + {1225623600 -36000 0 HAST} + {1236513600 -32400 1 HADT} + {1257073200 -36000 0 HAST} + {1268568000 -32400 1 HADT} + {1289127600 -36000 0 HAST} + {1300017600 -32400 1 HADT} + {1320577200 -36000 0 HAST} + {1331467200 -32400 1 HADT} + {1352026800 -36000 0 HAST} + {1362916800 -32400 1 HADT} + {1383476400 -36000 0 HAST} + {1394366400 -32400 1 HADT} + {1414926000 -36000 0 HAST} + {1425816000 -32400 1 HADT} + {1446375600 -36000 0 HAST} + {1457870400 -32400 1 HADT} + {1478430000 -36000 0 HAST} + {1489320000 -32400 1 HADT} + {1509879600 -36000 0 HAST} + {1520769600 -32400 1 HADT} + {1541329200 -36000 0 HAST} + {1552219200 -32400 1 HADT} + {1572778800 -36000 0 HAST} + {1583668800 -32400 1 HADT} + {1604228400 -36000 0 HAST} + {1615723200 -32400 1 HADT} + {1636282800 -36000 0 HAST} + {1647172800 -32400 1 HADT} + {1667732400 -36000 0 HAST} + {1678622400 -32400 1 HADT} + {1699182000 -36000 0 HAST} + {1710072000 -32400 1 HADT} + {1730631600 -36000 0 HAST} + {1741521600 -32400 1 HADT} + {1762081200 -36000 0 HAST} + {1772971200 -32400 1 HADT} + {1793530800 -36000 0 HAST} + {1805025600 -32400 1 HADT} + {1825585200 -36000 0 HAST} + {1836475200 -32400 1 HADT} + {1857034800 -36000 0 HAST} + {1867924800 -32400 1 HADT} + {1888484400 -36000 0 HAST} + {1899374400 -32400 1 HADT} + {1919934000 -36000 0 HAST} + {1930824000 -32400 1 HADT} + {1951383600 -36000 0 HAST} + {1962878400 -32400 1 HADT} + {1983438000 -36000 0 HAST} + {1994328000 -32400 1 HADT} + {2014887600 -36000 0 HAST} + {2025777600 -32400 1 HADT} + {2046337200 -36000 0 HAST} + {2057227200 -32400 1 HADT} + {2077786800 -36000 0 HAST} + {2088676800 -32400 1 HADT} + {2109236400 -36000 0 HAST} + {2120126400 -32400 1 HADT} + {2140686000 -36000 0 HAST} + {2152180800 -32400 1 HADT} + {2172740400 -36000 0 HAST} + {2183630400 -32400 1 HADT} + {2204190000 -36000 0 HAST} + {2215080000 -32400 1 HADT} + {2235639600 -36000 0 HAST} + {2246529600 -32400 1 HADT} + {2267089200 -36000 0 HAST} + {2277979200 -32400 1 HADT} + {2298538800 -36000 0 HAST} + {2309428800 -32400 1 HADT} + {2329988400 -36000 0 HAST} + {2341483200 -32400 1 HADT} + {2362042800 -36000 0 HAST} + {2372932800 -32400 1 HADT} + {2393492400 -36000 0 HAST} + {2404382400 -32400 1 HADT} + {2424942000 -36000 0 HAST} + {2435832000 -32400 1 HADT} + {2456391600 -36000 0 HAST} + {2467281600 -32400 1 HADT} + {2487841200 -36000 0 HAST} + {2499336000 -32400 1 HADT} + {2519895600 -36000 0 HAST} + {2530785600 -32400 1 HADT} + {2551345200 -36000 0 HAST} + {2562235200 -32400 1 HADT} + {2582794800 -36000 0 HAST} + {2593684800 -32400 1 HADT} + {2614244400 -36000 0 HAST} + {2625134400 -32400 1 HADT} + {2645694000 -36000 0 HAST} + {2656584000 -32400 1 HADT} + {2677143600 -36000 0 HAST} + {2688638400 -32400 1 HADT} + {2709198000 -36000 0 HAST} + {2720088000 -32400 1 HADT} + {2740647600 -36000 0 HAST} + {2751537600 -32400 1 HADT} + {2772097200 -36000 0 HAST} + {2782987200 -32400 1 HADT} + {2803546800 -36000 0 HAST} + {2814436800 -32400 1 HADT} + {2834996400 -36000 0 HAST} + {2846491200 -32400 1 HADT} + {2867050800 -36000 0 HAST} + {2877940800 -32400 1 HADT} + {2898500400 -36000 0 HAST} + {2909390400 -32400 1 HADT} + {2929950000 -36000 0 HAST} + {2940840000 -32400 1 HADT} + {2961399600 -36000 0 HAST} + {2972289600 -32400 1 HADT} + {2992849200 -36000 0 HAST} + {3003739200 -32400 1 HADT} + {3024298800 -36000 0 HAST} + {3035793600 -32400 1 HADT} + {3056353200 -36000 0 HAST} + {3067243200 -32400 1 HADT} + {3087802800 -36000 0 HAST} + {3098692800 -32400 1 HADT} + {3119252400 -36000 0 HAST} + {3130142400 -32400 1 HADT} + {3150702000 -36000 0 HAST} + {3161592000 -32400 1 HADT} + {3182151600 -36000 0 HAST} + {3193041600 -32400 1 HADT} + {3213601200 -36000 0 HAST} + {3225096000 -32400 1 HADT} + {3245655600 -36000 0 HAST} + {3256545600 -32400 1 HADT} + {3277105200 -36000 0 HAST} + {3287995200 -32400 1 HADT} + {3308554800 -36000 0 HAST} + {3319444800 -32400 1 HADT} + {3340004400 -36000 0 HAST} + {3350894400 -32400 1 HADT} + {3371454000 -36000 0 HAST} + {3382948800 -32400 1 HADT} + {3403508400 -36000 0 HAST} + {3414398400 -32400 1 HADT} + {3434958000 -36000 0 HAST} + {3445848000 -32400 1 HADT} + {3466407600 -36000 0 HAST} + {3477297600 -32400 1 HADT} + {3497857200 -36000 0 HAST} + {3508747200 -32400 1 HADT} + {3529306800 -36000 0 HAST} + {3540196800 -32400 1 HADT} + {3560756400 -36000 0 HAST} + {3572251200 -32400 1 HADT} + {3592810800 -36000 0 HAST} + {3603700800 -32400 1 HADT} + {3624260400 -36000 0 HAST} + {3635150400 -32400 1 HADT} + {3655710000 -36000 0 HAST} + {3666600000 -32400 1 HADT} + {3687159600 -36000 0 HAST} + {3698049600 -32400 1 HADT} + {3718609200 -36000 0 HAST} + {3730104000 -32400 1 HADT} + {3750663600 -36000 0 HAST} + {3761553600 -32400 1 HADT} + {3782113200 -36000 0 HAST} + {3793003200 -32400 1 HADT} + {3813562800 -36000 0 HAST} + {3824452800 -32400 1 HADT} + {3845012400 -36000 0 HAST} + {3855902400 -32400 1 HADT} + {3876462000 -36000 0 HAST} + {3887352000 -32400 1 HADT} + {3907911600 -36000 0 HAST} + {3919406400 -32400 1 HADT} + {3939966000 -36000 0 HAST} + {3950856000 -32400 1 HADT} + {3971415600 -36000 0 HAST} + {3982305600 -32400 1 HADT} + {4002865200 -36000 0 HAST} + {4013755200 -32400 1 HADT} + {4034314800 -36000 0 HAST} + {4045204800 -32400 1 HADT} + {4065764400 -36000 0 HAST} + {4076654400 -32400 1 HADT} + {4097214000 -36000 0 HAST} } Index: library/tzdata/America/Anchorage ================================================================== --- library/tzdata/America/Anchorage +++ library/tzdata/America/Anchorage @@ -85,192 +85,192 @@ {1099216800 -32400 0 AKST} {1112526000 -28800 1 AKDT} {1130666400 -32400 0 AKST} {1143975600 -28800 1 AKDT} {1162116000 -32400 0 AKST} - {1175425200 -28800 1 AKDT} - {1193565600 -32400 0 AKST} - {1207479600 -28800 1 AKDT} - {1225015200 -32400 0 AKST} - {1238929200 -28800 1 AKDT} - {1256464800 -32400 0 AKST} - {1270378800 -28800 1 AKDT} - {1288519200 -32400 0 AKST} - {1301828400 -28800 1 AKDT} - {1319968800 -32400 0 AKST} - {1333278000 -28800 1 AKDT} - {1351418400 -32400 0 AKST} - {1365332400 -28800 1 AKDT} - {1382868000 -32400 0 AKST} - {1396782000 -28800 1 AKDT} - {1414317600 -32400 0 AKST} - {1428231600 -28800 1 AKDT} - {1445767200 -32400 0 AKST} - {1459681200 -28800 1 AKDT} - {1477821600 -32400 0 AKST} - {1491130800 -28800 1 AKDT} - {1509271200 -32400 0 AKST} - {1522580400 -28800 1 AKDT} - {1540720800 -32400 0 AKST} - {1554634800 -28800 1 AKDT} - {1572170400 -32400 0 AKST} - {1586084400 -28800 1 AKDT} - {1603620000 -32400 0 AKST} - {1617534000 -28800 1 AKDT} - {1635674400 -32400 0 AKST} - {1648983600 -28800 1 AKDT} - {1667124000 -32400 0 AKST} - {1680433200 -28800 1 AKDT} - {1698573600 -32400 0 AKST} - {1712487600 -28800 1 AKDT} - {1730023200 -32400 0 AKST} - {1743937200 -28800 1 AKDT} - {1761472800 -32400 0 AKST} - {1775386800 -28800 1 AKDT} - {1792922400 -32400 0 AKST} - {1806836400 -28800 1 AKDT} - {1824976800 -32400 0 AKST} - {1838286000 -28800 1 AKDT} - {1856426400 -32400 0 AKST} - {1869735600 -28800 1 AKDT} - {1887876000 -32400 0 AKST} - {1901790000 -28800 1 AKDT} - {1919325600 -32400 0 AKST} - {1933239600 -28800 1 AKDT} - {1950775200 -32400 0 AKST} - {1964689200 -28800 1 AKDT} - {1982829600 -32400 0 AKST} - {1996138800 -28800 1 AKDT} - {2014279200 -32400 0 AKST} - {2027588400 -28800 1 AKDT} - {2045728800 -32400 0 AKST} - {2059038000 -28800 1 AKDT} - {2077178400 -32400 0 AKST} - {2091092400 -28800 1 AKDT} - {2108628000 -32400 0 AKST} - {2122542000 -28800 1 AKDT} - {2140077600 -32400 0 AKST} - {2153991600 -28800 1 AKDT} - {2172132000 -32400 0 AKST} - {2185441200 -28800 1 AKDT} - {2203581600 -32400 0 AKST} - {2216890800 -28800 1 AKDT} - {2235031200 -32400 0 AKST} - {2248945200 -28800 1 AKDT} - {2266480800 -32400 0 AKST} - {2280394800 -28800 1 AKDT} - {2297930400 -32400 0 AKST} - {2311844400 -28800 1 AKDT} - {2329380000 -32400 0 AKST} - {2343294000 -28800 1 AKDT} - {2361434400 -32400 0 AKST} - {2374743600 -28800 1 AKDT} - {2392884000 -32400 0 AKST} - {2406193200 -28800 1 AKDT} - {2424333600 -32400 0 AKST} - {2438247600 -28800 1 AKDT} - {2455783200 -32400 0 AKST} - {2469697200 -28800 1 AKDT} - {2487232800 -32400 0 AKST} - {2501146800 -28800 1 AKDT} - {2519287200 -32400 0 AKST} - {2532596400 -28800 1 AKDT} - {2550736800 -32400 0 AKST} - {2564046000 -28800 1 AKDT} - {2582186400 -32400 0 AKST} - {2596100400 -28800 1 AKDT} - {2613636000 -32400 0 AKST} - {2627550000 -28800 1 AKDT} - {2645085600 -32400 0 AKST} - {2658999600 -28800 1 AKDT} - {2676535200 -32400 0 AKST} - {2690449200 -28800 1 AKDT} - {2708589600 -32400 0 AKST} - {2721898800 -28800 1 AKDT} - {2740039200 -32400 0 AKST} - {2753348400 -28800 1 AKDT} - {2771488800 -32400 0 AKST} - {2785402800 -28800 1 AKDT} - {2802938400 -32400 0 AKST} - {2816852400 -28800 1 AKDT} - {2834388000 -32400 0 AKST} - {2848302000 -28800 1 AKDT} - {2866442400 -32400 0 AKST} - {2879751600 -28800 1 AKDT} - {2897892000 -32400 0 AKST} - {2911201200 -28800 1 AKDT} - {2929341600 -32400 0 AKST} - {2942650800 -28800 1 AKDT} - {2960791200 -32400 0 AKST} - {2974705200 -28800 1 AKDT} - {2992240800 -32400 0 AKST} - {3006154800 -28800 1 AKDT} - {3023690400 -32400 0 AKST} - {3037604400 -28800 1 AKDT} - {3055744800 -32400 0 AKST} - {3069054000 -28800 1 AKDT} - {3087194400 -32400 0 AKST} - {3100503600 -28800 1 AKDT} - {3118644000 -32400 0 AKST} - {3132558000 -28800 1 AKDT} - {3150093600 -32400 0 AKST} - {3164007600 -28800 1 AKDT} - {3181543200 -32400 0 AKST} - {3195457200 -28800 1 AKDT} - {3212992800 -32400 0 AKST} - {3226906800 -28800 1 AKDT} - {3245047200 -32400 0 AKST} - {3258356400 -28800 1 AKDT} - {3276496800 -32400 0 AKST} - {3289806000 -28800 1 AKDT} - {3307946400 -32400 0 AKST} - {3321860400 -28800 1 AKDT} - {3339396000 -32400 0 AKST} - {3353310000 -28800 1 AKDT} - {3370845600 -32400 0 AKST} - {3384759600 -28800 1 AKDT} - {3402900000 -32400 0 AKST} - {3416209200 -28800 1 AKDT} - {3434349600 -32400 0 AKST} - {3447658800 -28800 1 AKDT} - {3465799200 -32400 0 AKST} - {3479713200 -28800 1 AKDT} - {3497248800 -32400 0 AKST} - {3511162800 -28800 1 AKDT} - {3528698400 -32400 0 AKST} - {3542612400 -28800 1 AKDT} - {3560148000 -32400 0 AKST} - {3574062000 -28800 1 AKDT} - {3592202400 -32400 0 AKST} - {3605511600 -28800 1 AKDT} - {3623652000 -32400 0 AKST} - {3636961200 -28800 1 AKDT} - {3655101600 -32400 0 AKST} - {3669015600 -28800 1 AKDT} - {3686551200 -32400 0 AKST} - {3700465200 -28800 1 AKDT} - {3718000800 -32400 0 AKST} - {3731914800 -28800 1 AKDT} - {3750055200 -32400 0 AKST} - {3763364400 -28800 1 AKDT} - {3781504800 -32400 0 AKST} - {3794814000 -28800 1 AKDT} - {3812954400 -32400 0 AKST} - {3826263600 -28800 1 AKDT} - {3844404000 -32400 0 AKST} - {3858318000 -28800 1 AKDT} - {3875853600 -32400 0 AKST} - {3889767600 -28800 1 AKDT} - {3907303200 -32400 0 AKST} - {3921217200 -28800 1 AKDT} - {3939357600 -32400 0 AKST} - {3952666800 -28800 1 AKDT} - {3970807200 -32400 0 AKST} - {3984116400 -28800 1 AKDT} - {4002256800 -32400 0 AKST} - {4016170800 -28800 1 AKDT} - {4033706400 -32400 0 AKST} - {4047620400 -28800 1 AKDT} - {4065156000 -32400 0 AKST} - {4079070000 -28800 1 AKDT} - {4096605600 -32400 0 AKST} + {1173610800 -28800 1 AKDT} + {1194170400 -32400 0 AKST} + {1205060400 -28800 1 AKDT} + {1225620000 -32400 0 AKST} + {1236510000 -28800 1 AKDT} + {1257069600 -32400 0 AKST} + {1268564400 -28800 1 AKDT} + {1289124000 -32400 0 AKST} + {1300014000 -28800 1 AKDT} + {1320573600 -32400 0 AKST} + {1331463600 -28800 1 AKDT} + {1352023200 -32400 0 AKST} + {1362913200 -28800 1 AKDT} + {1383472800 -32400 0 AKST} + {1394362800 -28800 1 AKDT} + {1414922400 -32400 0 AKST} + {1425812400 -28800 1 AKDT} + {1446372000 -32400 0 AKST} + {1457866800 -28800 1 AKDT} + {1478426400 -32400 0 AKST} + {1489316400 -28800 1 AKDT} + {1509876000 -32400 0 AKST} + {1520766000 -28800 1 AKDT} + {1541325600 -32400 0 AKST} + {1552215600 -28800 1 AKDT} + {1572775200 -32400 0 AKST} + {1583665200 -28800 1 AKDT} + {1604224800 -32400 0 AKST} + {1615719600 -28800 1 AKDT} + {1636279200 -32400 0 AKST} + {1647169200 -28800 1 AKDT} + {1667728800 -32400 0 AKST} + {1678618800 -28800 1 AKDT} + {1699178400 -32400 0 AKST} + {1710068400 -28800 1 AKDT} + {1730628000 -32400 0 AKST} + {1741518000 -28800 1 AKDT} + {1762077600 -32400 0 AKST} + {1772967600 -28800 1 AKDT} + {1793527200 -32400 0 AKST} + {1805022000 -28800 1 AKDT} + {1825581600 -32400 0 AKST} + {1836471600 -28800 1 AKDT} + {1857031200 -32400 0 AKST} + {1867921200 -28800 1 AKDT} + {1888480800 -32400 0 AKST} + {1899370800 -28800 1 AKDT} + {1919930400 -32400 0 AKST} + {1930820400 -28800 1 AKDT} + {1951380000 -32400 0 AKST} + {1962874800 -28800 1 AKDT} + {1983434400 -32400 0 AKST} + {1994324400 -28800 1 AKDT} + {2014884000 -32400 0 AKST} + {2025774000 -28800 1 AKDT} + {2046333600 -32400 0 AKST} + {2057223600 -28800 1 AKDT} + {2077783200 -32400 0 AKST} + {2088673200 -28800 1 AKDT} + {2109232800 -32400 0 AKST} + {2120122800 -28800 1 AKDT} + {2140682400 -32400 0 AKST} + {2152177200 -28800 1 AKDT} + {2172736800 -32400 0 AKST} + {2183626800 -28800 1 AKDT} + {2204186400 -32400 0 AKST} + {2215076400 -28800 1 AKDT} + {2235636000 -32400 0 AKST} + {2246526000 -28800 1 AKDT} + {2267085600 -32400 0 AKST} + {2277975600 -28800 1 AKDT} + {2298535200 -32400 0 AKST} + {2309425200 -28800 1 AKDT} + {2329984800 -32400 0 AKST} + {2341479600 -28800 1 AKDT} + {2362039200 -32400 0 AKST} + {2372929200 -28800 1 AKDT} + {2393488800 -32400 0 AKST} + {2404378800 -28800 1 AKDT} + {2424938400 -32400 0 AKST} + {2435828400 -28800 1 AKDT} + {2456388000 -32400 0 AKST} + {2467278000 -28800 1 AKDT} + {2487837600 -32400 0 AKST} + {2499332400 -28800 1 AKDT} + {2519892000 -32400 0 AKST} + {2530782000 -28800 1 AKDT} + {2551341600 -32400 0 AKST} + {2562231600 -28800 1 AKDT} + {2582791200 -32400 0 AKST} + {2593681200 -28800 1 AKDT} + {2614240800 -32400 0 AKST} + {2625130800 -28800 1 AKDT} + {2645690400 -32400 0 AKST} + {2656580400 -28800 1 AKDT} + {2677140000 -32400 0 AKST} + {2688634800 -28800 1 AKDT} + {2709194400 -32400 0 AKST} + {2720084400 -28800 1 AKDT} + {2740644000 -32400 0 AKST} + {2751534000 -28800 1 AKDT} + {2772093600 -32400 0 AKST} + {2782983600 -28800 1 AKDT} + {2803543200 -32400 0 AKST} + {2814433200 -28800 1 AKDT} + {2834992800 -32400 0 AKST} + {2846487600 -28800 1 AKDT} + {2867047200 -32400 0 AKST} + {2877937200 -28800 1 AKDT} + {2898496800 -32400 0 AKST} + {2909386800 -28800 1 AKDT} + {2929946400 -32400 0 AKST} + {2940836400 -28800 1 AKDT} + {2961396000 -32400 0 AKST} + {2972286000 -28800 1 AKDT} + {2992845600 -32400 0 AKST} + {3003735600 -28800 1 AKDT} + {3024295200 -32400 0 AKST} + {3035790000 -28800 1 AKDT} + {3056349600 -32400 0 AKST} + {3067239600 -28800 1 AKDT} + {3087799200 -32400 0 AKST} + {3098689200 -28800 1 AKDT} + {3119248800 -32400 0 AKST} + {3130138800 -28800 1 AKDT} + {3150698400 -32400 0 AKST} + {3161588400 -28800 1 AKDT} + {3182148000 -32400 0 AKST} + {3193038000 -28800 1 AKDT} + {3213597600 -32400 0 AKST} + {3225092400 -28800 1 AKDT} + {3245652000 -32400 0 AKST} + {3256542000 -28800 1 AKDT} + {3277101600 -32400 0 AKST} + {3287991600 -28800 1 AKDT} + {3308551200 -32400 0 AKST} + {3319441200 -28800 1 AKDT} + {3340000800 -32400 0 AKST} + {3350890800 -28800 1 AKDT} + {3371450400 -32400 0 AKST} + {3382945200 -28800 1 AKDT} + {3403504800 -32400 0 AKST} + {3414394800 -28800 1 AKDT} + {3434954400 -32400 0 AKST} + {3445844400 -28800 1 AKDT} + {3466404000 -32400 0 AKST} + {3477294000 -28800 1 AKDT} + {3497853600 -32400 0 AKST} + {3508743600 -28800 1 AKDT} + {3529303200 -32400 0 AKST} + {3540193200 -28800 1 AKDT} + {3560752800 -32400 0 AKST} + {3572247600 -28800 1 AKDT} + {3592807200 -32400 0 AKST} + {3603697200 -28800 1 AKDT} + {3624256800 -32400 0 AKST} + {3635146800 -28800 1 AKDT} + {3655706400 -32400 0 AKST} + {3666596400 -28800 1 AKDT} + {3687156000 -32400 0 AKST} + {3698046000 -28800 1 AKDT} + {3718605600 -32400 0 AKST} + {3730100400 -28800 1 AKDT} + {3750660000 -32400 0 AKST} + {3761550000 -28800 1 AKDT} + {3782109600 -32400 0 AKST} + {3792999600 -28800 1 AKDT} + {3813559200 -32400 0 AKST} + {3824449200 -28800 1 AKDT} + {3845008800 -32400 0 AKST} + {3855898800 -28800 1 AKDT} + {3876458400 -32400 0 AKST} + {3887348400 -28800 1 AKDT} + {3907908000 -32400 0 AKST} + {3919402800 -28800 1 AKDT} + {3939962400 -32400 0 AKST} + {3950852400 -28800 1 AKDT} + {3971412000 -32400 0 AKST} + {3982302000 -28800 1 AKDT} + {4002861600 -32400 0 AKST} + {4013751600 -28800 1 AKDT} + {4034311200 -32400 0 AKST} + {4045201200 -28800 1 AKDT} + {4065760800 -32400 0 AKST} + {4076650800 -28800 1 AKDT} + {4097210400 -32400 0 AKST} } Index: library/tzdata/America/Argentina/ComodRivadavia ================================================================== --- library/tzdata/America/Argentina/ComodRivadavia +++ library/tzdata/America/Argentina/ComodRivadavia @@ -1,65 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit - -set TZData(:America/Argentina/ComodRivadavia) { - {-9223372036854775808 -16200 0 LMT} - {-2372095800 -15408 0 CMT} - {-1567453392 -14400 0 ART} - {-1233432000 -10800 0 ARST} - {-1222981200 -14400 0 ART} - {-1205956800 -10800 1 ARST} - {-1194037200 -14400 0 ART} - {-1172865600 -10800 1 ARST} - {-1162501200 -14400 0 ART} - {-1141329600 -10800 1 ARST} - {-1130965200 -14400 0 ART} - {-1109793600 -10800 1 ARST} - {-1099429200 -14400 0 ART} - {-1078257600 -10800 1 ARST} - {-1067806800 -14400 0 ART} - {-1046635200 -10800 1 ARST} - {-1036270800 -14400 0 ART} - {-1015099200 -10800 1 ARST} - {-1004734800 -14400 0 ART} - {-983563200 -10800 1 ARST} - {-973198800 -14400 0 ART} - {-952027200 -10800 1 ARST} - {-941576400 -14400 0 ART} - {-931032000 -10800 1 ARST} - {-900882000 -14400 0 ART} - {-890337600 -10800 1 ARST} - {-833749200 -14400 0 ART} - {-827265600 -10800 1 ARST} - {-752274000 -14400 0 ART} - {-733780800 -10800 1 ARST} - {-197326800 -14400 0 ART} - {-190843200 -10800 1 ARST} - {-184194000 -14400 0 ART} - {-164491200 -10800 1 ARST} - {-152658000 -14400 0 ART} - {-132955200 -10800 1 ARST} - {-121122000 -14400 0 ART} - {-101419200 -10800 1 ARST} - {-86821200 -14400 0 ART} - {-71092800 -10800 1 ARST} - {-54766800 -14400 0 ART} - {-39038400 -10800 1 ARST} - {-23317200 -14400 0 ART} - {-7588800 -10800 0 ART} - {128142000 -7200 1 ARST} - {136605600 -10800 0 ART} - {596948400 -7200 1 ARST} - {605066400 -10800 0 ART} - {624423600 -7200 1 ARST} - {636516000 -10800 0 ART} - {656478000 -7200 1 ARST} - {667965600 -14400 0 WART} - {687931200 -7200 0 ARST} - {699415200 -10800 0 ART} - {719377200 -7200 1 ARST} - {731469600 -10800 0 ART} - {938916000 -10800 0 ART} - {938919600 -10800 1 ARST} - {952056000 -10800 0 ART} - {1086058800 -14400 0 WART} - {1087704000 -10800 0 ART} -} +if {![info exists TZData(America/Argentina/Catamarca)]} { + LoadTimeZoneFile America/Argentina/Catamarca +} +set TZData(:America/Argentina/ComodRivadavia) $TZData(:America/Argentina/Catamarca) Index: library/tzdata/America/Asuncion ================================================================== --- library/tzdata/America/Asuncion +++ library/tzdata/America/Asuncion @@ -63,197 +63,197 @@ {1018148400 -14400 0 PYT} {1030852800 -10800 1 PYST} {1049598000 -14400 0 PYT} {1062907200 -10800 1 PYST} {1081047600 -14400 0 PYT} - {1094356800 -10800 1 PYST} - {1112497200 -14400 0 PYT} - {1125806400 -10800 1 PYST} - {1143946800 -14400 0 PYT} - {1157256000 -10800 1 PYST} - {1175396400 -14400 0 PYT} - {1188705600 -10800 1 PYST} - {1207450800 -14400 0 PYT} - {1220760000 -10800 1 PYST} - {1238900400 -14400 0 PYT} - {1252209600 -10800 1 PYST} - {1270350000 -14400 0 PYT} - {1283659200 -10800 1 PYST} - {1301799600 -14400 0 PYT} - {1315108800 -10800 1 PYST} - {1333249200 -14400 0 PYT} - {1346558400 -10800 1 PYST} - {1365303600 -14400 0 PYT} - {1378008000 -10800 1 PYST} - {1396753200 -14400 0 PYT} - {1410062400 -10800 1 PYST} - {1428202800 -14400 0 PYT} - {1441512000 -10800 1 PYST} - {1459652400 -14400 0 PYT} - {1472961600 -10800 1 PYST} - {1491102000 -14400 0 PYT} - {1504411200 -10800 1 PYST} - {1522551600 -14400 0 PYT} - {1535860800 -10800 1 PYST} - {1554606000 -14400 0 PYT} - {1567310400 -10800 1 PYST} - {1586055600 -14400 0 PYT} - {1599364800 -10800 1 PYST} - {1617505200 -14400 0 PYT} - {1630814400 -10800 1 PYST} - {1648954800 -14400 0 PYT} - {1662264000 -10800 1 PYST} - {1680404400 -14400 0 PYT} - {1693713600 -10800 1 PYST} - {1712458800 -14400 0 PYT} - {1725163200 -10800 1 PYST} - {1743908400 -14400 0 PYT} - {1757217600 -10800 1 PYST} - {1775358000 -14400 0 PYT} - {1788667200 -10800 1 PYST} - {1806807600 -14400 0 PYT} - {1820116800 -10800 1 PYST} - {1838257200 -14400 0 PYT} - {1851566400 -10800 1 PYST} - {1869706800 -14400 0 PYT} - {1883016000 -10800 1 PYST} - {1901761200 -14400 0 PYT} - {1914465600 -10800 1 PYST} - {1933210800 -14400 0 PYT} - {1946520000 -10800 1 PYST} - {1964660400 -14400 0 PYT} - {1977969600 -10800 1 PYST} - {1996110000 -14400 0 PYT} - {2009419200 -10800 1 PYST} - {2027559600 -14400 0 PYT} - {2040868800 -10800 1 PYST} - {2059009200 -14400 0 PYT} - {2072318400 -10800 1 PYST} - {2091063600 -14400 0 PYT} - {2104372800 -10800 1 PYST} - {2122513200 -14400 0 PYT} - {2135822400 -10800 1 PYST} - {2153962800 -14400 0 PYT} - {2167272000 -10800 1 PYST} - {2185412400 -14400 0 PYT} - {2198721600 -10800 1 PYST} - {2216862000 -14400 0 PYT} - {2230171200 -10800 1 PYST} - {2248916400 -14400 0 PYT} - {2261620800 -10800 1 PYST} - {2280366000 -14400 0 PYT} - {2293675200 -10800 1 PYST} - {2311815600 -14400 0 PYT} - {2325124800 -10800 1 PYST} - {2343265200 -14400 0 PYT} - {2356574400 -10800 1 PYST} - {2374714800 -14400 0 PYT} - {2388024000 -10800 1 PYST} - {2406164400 -14400 0 PYT} - {2419473600 -10800 1 PYST} - {2438218800 -14400 0 PYT} - {2450923200 -10800 1 PYST} - {2469668400 -14400 0 PYT} - {2482977600 -10800 1 PYST} - {2501118000 -14400 0 PYT} - {2514427200 -10800 1 PYST} - {2532567600 -14400 0 PYT} - {2545876800 -10800 1 PYST} - {2564017200 -14400 0 PYT} - {2577326400 -10800 1 PYST} - {2596071600 -14400 0 PYT} - {2608776000 -10800 1 PYST} - {2627521200 -14400 0 PYT} - {2640830400 -10800 1 PYST} - {2658970800 -14400 0 PYT} - {2672280000 -10800 1 PYST} - {2690420400 -14400 0 PYT} - {2703729600 -10800 1 PYST} - {2721870000 -14400 0 PYT} - {2735179200 -10800 1 PYST} - {2753319600 -14400 0 PYT} - {2766628800 -10800 1 PYST} - {2785374000 -14400 0 PYT} - {2798078400 -10800 1 PYST} - {2816823600 -14400 0 PYT} - {2830132800 -10800 1 PYST} - {2848273200 -14400 0 PYT} - {2861582400 -10800 1 PYST} - {2879722800 -14400 0 PYT} - {2893032000 -10800 1 PYST} - {2911172400 -14400 0 PYT} - {2924481600 -10800 1 PYST} - {2942622000 -14400 0 PYT} - {2955931200 -10800 1 PYST} - {2974676400 -14400 0 PYT} - {2987985600 -10800 1 PYST} - {3006126000 -14400 0 PYT} - {3019435200 -10800 1 PYST} - {3037575600 -14400 0 PYT} - {3050884800 -10800 1 PYST} - {3069025200 -14400 0 PYT} - {3082334400 -10800 1 PYST} - {3100474800 -14400 0 PYT} - {3113784000 -10800 1 PYST} - {3132529200 -14400 0 PYT} - {3145233600 -10800 1 PYST} - {3163978800 -14400 0 PYT} - {3177288000 -10800 1 PYST} - {3195428400 -14400 0 PYT} - {3208737600 -10800 1 PYST} - {3226878000 -14400 0 PYT} - {3240187200 -10800 1 PYST} - {3258327600 -14400 0 PYT} - {3271636800 -10800 1 PYST} - {3289777200 -14400 0 PYT} - {3303086400 -10800 1 PYST} - {3321831600 -14400 0 PYT} - {3334536000 -10800 1 PYST} - {3353281200 -14400 0 PYT} - {3366590400 -10800 1 PYST} - {3384730800 -14400 0 PYT} - {3398040000 -10800 1 PYST} - {3416180400 -14400 0 PYT} - {3429489600 -10800 1 PYST} - {3447630000 -14400 0 PYT} - {3460939200 -10800 1 PYST} - {3479684400 -14400 0 PYT} - {3492388800 -10800 1 PYST} - {3511134000 -14400 0 PYT} - {3524443200 -10800 1 PYST} - {3542583600 -14400 0 PYT} - {3555892800 -10800 1 PYST} - {3574033200 -14400 0 PYT} - {3587342400 -10800 1 PYST} - {3605482800 -14400 0 PYT} - {3618792000 -10800 1 PYST} - {3636932400 -14400 0 PYT} - {3650241600 -10800 1 PYST} - {3668986800 -14400 0 PYT} - {3681691200 -10800 1 PYST} - {3700436400 -14400 0 PYT} - {3713745600 -10800 1 PYST} - {3731886000 -14400 0 PYT} - {3745195200 -10800 1 PYST} - {3763335600 -14400 0 PYT} - {3776644800 -10800 1 PYST} - {3794785200 -14400 0 PYT} - {3808094400 -10800 1 PYST} - {3826234800 -14400 0 PYT} - {3839544000 -10800 1 PYST} - {3858289200 -14400 0 PYT} - {3871598400 -10800 1 PYST} - {3889738800 -14400 0 PYT} - {3903048000 -10800 1 PYST} - {3921188400 -14400 0 PYT} - {3934497600 -10800 1 PYST} - {3952638000 -14400 0 PYT} - {3965947200 -10800 1 PYST} - {3984087600 -14400 0 PYT} - {3997396800 -10800 1 PYST} - {4016142000 -14400 0 PYT} - {4028846400 -10800 1 PYST} - {4047591600 -14400 0 PYT} - {4060900800 -10800 1 PYST} - {4079041200 -14400 0 PYT} - {4092350400 -10800 1 PYST} + {1097985600 -10800 1 PYST} + {1110682800 -14400 0 PYT} + {1129435200 -10800 1 PYST} + {1142132400 -14400 0 PYT} + {1160884800 -10800 1 PYST} + {1173582000 -14400 0 PYT} + {1192939200 -10800 1 PYST} + {1205031600 -14400 0 PYT} + {1224388800 -10800 1 PYST} + {1236481200 -14400 0 PYT} + {1255838400 -10800 1 PYST} + {1268535600 -14400 0 PYT} + {1287288000 -10800 1 PYST} + {1299985200 -14400 0 PYT} + {1318737600 -10800 1 PYST} + {1331434800 -14400 0 PYT} + {1350792000 -10800 1 PYST} + {1362884400 -14400 0 PYT} + {1382241600 -10800 1 PYST} + {1394334000 -14400 0 PYT} + {1413691200 -10800 1 PYST} + {1425783600 -14400 0 PYT} + {1445140800 -10800 1 PYST} + {1457838000 -14400 0 PYT} + {1476590400 -10800 1 PYST} + {1489287600 -14400 0 PYT} + {1508040000 -10800 1 PYST} + {1520737200 -14400 0 PYT} + {1540094400 -10800 1 PYST} + {1552186800 -14400 0 PYT} + {1571544000 -10800 1 PYST} + {1583636400 -14400 0 PYT} + {1602993600 -10800 1 PYST} + {1615690800 -14400 0 PYT} + {1634443200 -10800 1 PYST} + {1647140400 -14400 0 PYT} + {1665892800 -10800 1 PYST} + {1678590000 -14400 0 PYT} + {1697342400 -10800 1 PYST} + {1710039600 -14400 0 PYT} + {1729396800 -10800 1 PYST} + {1741489200 -14400 0 PYT} + {1760846400 -10800 1 PYST} + {1772938800 -14400 0 PYT} + {1792296000 -10800 1 PYST} + {1804993200 -14400 0 PYT} + {1823745600 -10800 1 PYST} + {1836442800 -14400 0 PYT} + {1855195200 -10800 1 PYST} + {1867892400 -14400 0 PYT} + {1887249600 -10800 1 PYST} + {1899342000 -14400 0 PYT} + {1918699200 -10800 1 PYST} + {1930791600 -14400 0 PYT} + {1950148800 -10800 1 PYST} + {1962846000 -14400 0 PYT} + {1981598400 -10800 1 PYST} + {1994295600 -14400 0 PYT} + {2013048000 -10800 1 PYST} + {2025745200 -14400 0 PYT} + {2044497600 -10800 1 PYST} + {2057194800 -14400 0 PYT} + {2076552000 -10800 1 PYST} + {2088644400 -14400 0 PYT} + {2108001600 -10800 1 PYST} + {2120094000 -14400 0 PYT} + {2139451200 -10800 1 PYST} + {2152148400 -14400 0 PYT} + {2170900800 -10800 1 PYST} + {2183598000 -14400 0 PYT} + {2202350400 -10800 1 PYST} + {2215047600 -14400 0 PYT} + {2234404800 -10800 1 PYST} + {2246497200 -14400 0 PYT} + {2265854400 -10800 1 PYST} + {2277946800 -14400 0 PYT} + {2297304000 -10800 1 PYST} + {2309396400 -14400 0 PYT} + {2328753600 -10800 1 PYST} + {2341450800 -14400 0 PYT} + {2360203200 -10800 1 PYST} + {2372900400 -14400 0 PYT} + {2391652800 -10800 1 PYST} + {2404350000 -14400 0 PYT} + {2423707200 -10800 1 PYST} + {2435799600 -14400 0 PYT} + {2455156800 -10800 1 PYST} + {2467249200 -14400 0 PYT} + {2486606400 -10800 1 PYST} + {2499303600 -14400 0 PYT} + {2518056000 -10800 1 PYST} + {2530753200 -14400 0 PYT} + {2549505600 -10800 1 PYST} + {2562202800 -14400 0 PYT} + {2580955200 -10800 1 PYST} + {2593652400 -14400 0 PYT} + {2613009600 -10800 1 PYST} + {2625102000 -14400 0 PYT} + {2644459200 -10800 1 PYST} + {2656551600 -14400 0 PYT} + {2675908800 -10800 1 PYST} + {2688606000 -14400 0 PYT} + {2707358400 -10800 1 PYST} + {2720055600 -14400 0 PYT} + {2738808000 -10800 1 PYST} + {2751505200 -14400 0 PYT} + {2770862400 -10800 1 PYST} + {2782954800 -14400 0 PYT} + {2802312000 -10800 1 PYST} + {2814404400 -14400 0 PYT} + {2833761600 -10800 1 PYST} + {2846458800 -14400 0 PYT} + {2865211200 -10800 1 PYST} + {2877908400 -14400 0 PYT} + {2896660800 -10800 1 PYST} + {2909358000 -14400 0 PYT} + {2928110400 -10800 1 PYST} + {2940807600 -14400 0 PYT} + {2960164800 -10800 1 PYST} + {2972257200 -14400 0 PYT} + {2991614400 -10800 1 PYST} + {3003706800 -14400 0 PYT} + {3023064000 -10800 1 PYST} + {3035761200 -14400 0 PYT} + {3054513600 -10800 1 PYST} + {3067210800 -14400 0 PYT} + {3085963200 -10800 1 PYST} + {3098660400 -14400 0 PYT} + {3118017600 -10800 1 PYST} + {3130110000 -14400 0 PYT} + {3149467200 -10800 1 PYST} + {3161559600 -14400 0 PYT} + {3180916800 -10800 1 PYST} + {3193009200 -14400 0 PYT} + {3212366400 -10800 1 PYST} + {3225063600 -14400 0 PYT} + {3243816000 -10800 1 PYST} + {3256513200 -14400 0 PYT} + {3275265600 -10800 1 PYST} + {3287962800 -14400 0 PYT} + {3307320000 -10800 1 PYST} + {3319412400 -14400 0 PYT} + {3338769600 -10800 1 PYST} + {3350862000 -14400 0 PYT} + {3370219200 -10800 1 PYST} + {3382916400 -14400 0 PYT} + {3401668800 -10800 1 PYST} + {3414366000 -14400 0 PYT} + {3433118400 -10800 1 PYST} + {3445815600 -14400 0 PYT} + {3464568000 -10800 1 PYST} + {3477265200 -14400 0 PYT} + {3496622400 -10800 1 PYST} + {3508714800 -14400 0 PYT} + {3528072000 -10800 1 PYST} + {3540164400 -14400 0 PYT} + {3559521600 -10800 1 PYST} + {3572218800 -14400 0 PYT} + {3590971200 -10800 1 PYST} + {3603668400 -14400 0 PYT} + {3622420800 -10800 1 PYST} + {3635118000 -14400 0 PYT} + {3654475200 -10800 1 PYST} + {3666567600 -14400 0 PYT} + {3685924800 -10800 1 PYST} + {3698017200 -14400 0 PYT} + {3717374400 -10800 1 PYST} + {3730071600 -14400 0 PYT} + {3748824000 -10800 1 PYST} + {3761521200 -14400 0 PYT} + {3780273600 -10800 1 PYST} + {3792970800 -14400 0 PYT} + {3811723200 -10800 1 PYST} + {3824420400 -14400 0 PYT} + {3843777600 -10800 1 PYST} + {3855870000 -14400 0 PYT} + {3875227200 -10800 1 PYST} + {3887319600 -14400 0 PYT} + {3906676800 -10800 1 PYST} + {3919374000 -14400 0 PYT} + {3938126400 -10800 1 PYST} + {3950823600 -14400 0 PYT} + {3969576000 -10800 1 PYST} + {3982273200 -14400 0 PYT} + {4001630400 -10800 1 PYST} + {4013722800 -14400 0 PYT} + {4033080000 -10800 1 PYST} + {4045172400 -14400 0 PYT} + {4064529600 -10800 1 PYST} + {4076622000 -14400 0 PYT} + {4095979200 -10800 1 PYST} } Index: library/tzdata/America/Boise ================================================================== --- library/tzdata/America/Boise +++ library/tzdata/America/Boise @@ -1,10 +1,10 @@ # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Boise) { {-9223372036854775808 -27889 0 LMT} - {-2717640911 -28800 0 PST} + {-2717640000 -28800 0 PST} {-1633269600 -25200 1 PDT} {-1615129200 -28800 0 PST} {-1601820000 -25200 1 PDT} {-1583679600 -28800 0 PST} {-1471788000 -25200 0 MST} @@ -90,192 +90,192 @@ {1099209600 -25200 0 MST} {1112518800 -21600 1 MDT} {1130659200 -25200 0 MST} {1143968400 -21600 1 MDT} {1162108800 -25200 0 MST} - {1175418000 -21600 1 MDT} - {1193558400 -25200 0 MST} - {1207472400 -21600 1 MDT} - {1225008000 -25200 0 MST} - {1238922000 -21600 1 MDT} - {1256457600 -25200 0 MST} - {1270371600 -21600 1 MDT} - {1288512000 -25200 0 MST} - {1301821200 -21600 1 MDT} - {1319961600 -25200 0 MST} - {1333270800 -21600 1 MDT} - {1351411200 -25200 0 MST} - {1365325200 -21600 1 MDT} - {1382860800 -25200 0 MST} - {1396774800 -21600 1 MDT} - {1414310400 -25200 0 MST} - {1428224400 -21600 1 MDT} - {1445760000 -25200 0 MST} - {1459674000 -21600 1 MDT} - {1477814400 -25200 0 MST} - {1491123600 -21600 1 MDT} - {1509264000 -25200 0 MST} - {1522573200 -21600 1 MDT} - {1540713600 -25200 0 MST} - {1554627600 -21600 1 MDT} - {1572163200 -25200 0 MST} - {1586077200 -21600 1 MDT} - {1603612800 -25200 0 MST} - {1617526800 -21600 1 MDT} - {1635667200 -25200 0 MST} - {1648976400 -21600 1 MDT} - {1667116800 -25200 0 MST} - {1680426000 -21600 1 MDT} - {1698566400 -25200 0 MST} - {1712480400 -21600 1 MDT} - {1730016000 -25200 0 MST} - {1743930000 -21600 1 MDT} - {1761465600 -25200 0 MST} - {1775379600 -21600 1 MDT} - {1792915200 -25200 0 MST} - {1806829200 -21600 1 MDT} - {1824969600 -25200 0 MST} - {1838278800 -21600 1 MDT} - {1856419200 -25200 0 MST} - {1869728400 -21600 1 MDT} - {1887868800 -25200 0 MST} - {1901782800 -21600 1 MDT} - {1919318400 -25200 0 MST} - {1933232400 -21600 1 MDT} - {1950768000 -25200 0 MST} - {1964682000 -21600 1 MDT} - {1982822400 -25200 0 MST} - {1996131600 -21600 1 MDT} - {2014272000 -25200 0 MST} - {2027581200 -21600 1 MDT} - {2045721600 -25200 0 MST} - {2059030800 -21600 1 MDT} - {2077171200 -25200 0 MST} - {2091085200 -21600 1 MDT} - {2108620800 -25200 0 MST} - {2122534800 -21600 1 MDT} - {2140070400 -25200 0 MST} - {2153984400 -21600 1 MDT} - {2172124800 -25200 0 MST} - {2185434000 -21600 1 MDT} - {2203574400 -25200 0 MST} - {2216883600 -21600 1 MDT} - {2235024000 -25200 0 MST} - {2248938000 -21600 1 MDT} - {2266473600 -25200 0 MST} - {2280387600 -21600 1 MDT} - {2297923200 -25200 0 MST} - {2311837200 -21600 1 MDT} - {2329372800 -25200 0 MST} - {2343286800 -21600 1 MDT} - {2361427200 -25200 0 MST} - {2374736400 -21600 1 MDT} - {2392876800 -25200 0 MST} - {2406186000 -21600 1 MDT} - {2424326400 -25200 0 MST} - {2438240400 -21600 1 MDT} - {2455776000 -25200 0 MST} - {2469690000 -21600 1 MDT} - {2487225600 -25200 0 MST} - {2501139600 -21600 1 MDT} - {2519280000 -25200 0 MST} - {2532589200 -21600 1 MDT} - {2550729600 -25200 0 MST} - {2564038800 -21600 1 MDT} - {2582179200 -25200 0 MST} - {2596093200 -21600 1 MDT} - {2613628800 -25200 0 MST} - {2627542800 -21600 1 MDT} - {2645078400 -25200 0 MST} - {2658992400 -21600 1 MDT} - {2676528000 -25200 0 MST} - {2690442000 -21600 1 MDT} - {2708582400 -25200 0 MST} - {2721891600 -21600 1 MDT} - {2740032000 -25200 0 MST} - {2753341200 -21600 1 MDT} - {2771481600 -25200 0 MST} - {2785395600 -21600 1 MDT} - {2802931200 -25200 0 MST} - {2816845200 -21600 1 MDT} - {2834380800 -25200 0 MST} - {2848294800 -21600 1 MDT} - {2866435200 -25200 0 MST} - {2879744400 -21600 1 MDT} - {2897884800 -25200 0 MST} - {2911194000 -21600 1 MDT} - {2929334400 -25200 0 MST} - {2942643600 -21600 1 MDT} - {2960784000 -25200 0 MST} - {2974698000 -21600 1 MDT} - {2992233600 -25200 0 MST} - {3006147600 -21600 1 MDT} - {3023683200 -25200 0 MST} - {3037597200 -21600 1 MDT} - {3055737600 -25200 0 MST} - {3069046800 -21600 1 MDT} - {3087187200 -25200 0 MST} - {3100496400 -21600 1 MDT} - {3118636800 -25200 0 MST} - {3132550800 -21600 1 MDT} - {3150086400 -25200 0 MST} - {3164000400 -21600 1 MDT} - {3181536000 -25200 0 MST} - {3195450000 -21600 1 MDT} - {3212985600 -25200 0 MST} - {3226899600 -21600 1 MDT} - {3245040000 -25200 0 MST} - {3258349200 -21600 1 MDT} - {3276489600 -25200 0 MST} - {3289798800 -21600 1 MDT} - {3307939200 -25200 0 MST} - {3321853200 -21600 1 MDT} - {3339388800 -25200 0 MST} - {3353302800 -21600 1 MDT} - {3370838400 -25200 0 MST} - {3384752400 -21600 1 MDT} - {3402892800 -25200 0 MST} - {3416202000 -21600 1 MDT} - {3434342400 -25200 0 MST} - {3447651600 -21600 1 MDT} - {3465792000 -25200 0 MST} - {3479706000 -21600 1 MDT} - {3497241600 -25200 0 MST} - {3511155600 -21600 1 MDT} - {3528691200 -25200 0 MST} - {3542605200 -21600 1 MDT} - {3560140800 -25200 0 MST} - {3574054800 -21600 1 MDT} - {3592195200 -25200 0 MST} - {3605504400 -21600 1 MDT} - {3623644800 -25200 0 MST} - {3636954000 -21600 1 MDT} - {3655094400 -25200 0 MST} - {3669008400 -21600 1 MDT} - {3686544000 -25200 0 MST} - {3700458000 -21600 1 MDT} - {3717993600 -25200 0 MST} - {3731907600 -21600 1 MDT} - {3750048000 -25200 0 MST} - {3763357200 -21600 1 MDT} - {3781497600 -25200 0 MST} - {3794806800 -21600 1 MDT} - {3812947200 -25200 0 MST} - {3826256400 -21600 1 MDT} - {3844396800 -25200 0 MST} - {3858310800 -21600 1 MDT} - {3875846400 -25200 0 MST} - {3889760400 -21600 1 MDT} - {3907296000 -25200 0 MST} - {3921210000 -21600 1 MDT} - {3939350400 -25200 0 MST} - {3952659600 -21600 1 MDT} - {3970800000 -25200 0 MST} - {3984109200 -21600 1 MDT} - {4002249600 -25200 0 MST} - {4016163600 -21600 1 MDT} - {4033699200 -25200 0 MST} - {4047613200 -21600 1 MDT} - {4065148800 -25200 0 MST} - {4079062800 -21600 1 MDT} - {4096598400 -25200 0 MST} + {1173603600 -21600 1 MDT} + {1194163200 -25200 0 MST} + {1205053200 -21600 1 MDT} + {1225612800 -25200 0 MST} + {1236502800 -21600 1 MDT} + {1257062400 -25200 0 MST} + {1268557200 -21600 1 MDT} + {1289116800 -25200 0 MST} + {1300006800 -21600 1 MDT} + {1320566400 -25200 0 MST} + {1331456400 -21600 1 MDT} + {1352016000 -25200 0 MST} + {1362906000 -21600 1 MDT} + {1383465600 -25200 0 MST} + {1394355600 -21600 1 MDT} + {1414915200 -25200 0 MST} + {1425805200 -21600 1 MDT} + {1446364800 -25200 0 MST} + {1457859600 -21600 1 MDT} + {1478419200 -25200 0 MST} + {1489309200 -21600 1 MDT} + {1509868800 -25200 0 MST} + {1520758800 -21600 1 MDT} + {1541318400 -25200 0 MST} + {1552208400 -21600 1 MDT} + {1572768000 -25200 0 MST} + {1583658000 -21600 1 MDT} + {1604217600 -25200 0 MST} + {1615712400 -21600 1 MDT} + {1636272000 -25200 0 MST} + {1647162000 -21600 1 MDT} + {1667721600 -25200 0 MST} + {1678611600 -21600 1 MDT} + {1699171200 -25200 0 MST} + {1710061200 -21600 1 MDT} + {1730620800 -25200 0 MST} + {1741510800 -21600 1 MDT} + {1762070400 -25200 0 MST} + {1772960400 -21600 1 MDT} + {1793520000 -25200 0 MST} + {1805014800 -21600 1 MDT} + {1825574400 -25200 0 MST} + {1836464400 -21600 1 MDT} + {1857024000 -25200 0 MST} + {1867914000 -21600 1 MDT} + {1888473600 -25200 0 MST} + {1899363600 -21600 1 MDT} + {1919923200 -25200 0 MST} + {1930813200 -21600 1 MDT} + {1951372800 -25200 0 MST} + {1962867600 -21600 1 MDT} + {1983427200 -25200 0 MST} + {1994317200 -21600 1 MDT} + {2014876800 -25200 0 MST} + {2025766800 -21600 1 MDT} + {2046326400 -25200 0 MST} + {2057216400 -21600 1 MDT} + {2077776000 -25200 0 MST} + {2088666000 -21600 1 MDT} + {2109225600 -25200 0 MST} + {2120115600 -21600 1 MDT} + {2140675200 -25200 0 MST} + {2152170000 -21600 1 MDT} + {2172729600 -25200 0 MST} + {2183619600 -21600 1 MDT} + {2204179200 -25200 0 MST} + {2215069200 -21600 1 MDT} + {2235628800 -25200 0 MST} + {2246518800 -21600 1 MDT} + {2267078400 -25200 0 MST} + {2277968400 -21600 1 MDT} + {2298528000 -25200 0 MST} + {2309418000 -21600 1 MDT} + {2329977600 -25200 0 MST} + {2341472400 -21600 1 MDT} + {2362032000 -25200 0 MST} + {2372922000 -21600 1 MDT} + {2393481600 -25200 0 MST} + {2404371600 -21600 1 MDT} + {2424931200 -25200 0 MST} + {2435821200 -21600 1 MDT} + {2456380800 -25200 0 MST} + {2467270800 -21600 1 MDT} + {2487830400 -25200 0 MST} + {2499325200 -21600 1 MDT} + {2519884800 -25200 0 MST} + {2530774800 -21600 1 MDT} + {2551334400 -25200 0 MST} + {2562224400 -21600 1 MDT} + {2582784000 -25200 0 MST} + {2593674000 -21600 1 MDT} + {2614233600 -25200 0 MST} + {2625123600 -21600 1 MDT} + {2645683200 -25200 0 MST} + {2656573200 -21600 1 MDT} + {2677132800 -25200 0 MST} + {2688627600 -21600 1 MDT} + {2709187200 -25200 0 MST} + {2720077200 -21600 1 MDT} + {2740636800 -25200 0 MST} + {2751526800 -21600 1 MDT} + {2772086400 -25200 0 MST} + {2782976400 -21600 1 MDT} + {2803536000 -25200 0 MST} + {2814426000 -21600 1 MDT} + {2834985600 -25200 0 MST} + {2846480400 -21600 1 MDT} + {2867040000 -25200 0 MST} + {2877930000 -21600 1 MDT} + {2898489600 -25200 0 MST} + {2909379600 -21600 1 MDT} + {2929939200 -25200 0 MST} + {2940829200 -21600 1 MDT} + {2961388800 -25200 0 MST} + {2972278800 -21600 1 MDT} + {2992838400 -25200 0 MST} + {3003728400 -21600 1 MDT} + {3024288000 -25200 0 MST} + {3035782800 -21600 1 MDT} + {3056342400 -25200 0 MST} + {3067232400 -21600 1 MDT} + {3087792000 -25200 0 MST} + {3098682000 -21600 1 MDT} + {3119241600 -25200 0 MST} + {3130131600 -21600 1 MDT} + {3150691200 -25200 0 MST} + {3161581200 -21600 1 MDT} + {3182140800 -25200 0 MST} + {3193030800 -21600 1 MDT} + {3213590400 -25200 0 MST} + {3225085200 -21600 1 MDT} + {3245644800 -25200 0 MST} + {3256534800 -21600 1 MDT} + {3277094400 -25200 0 MST} + {3287984400 -21600 1 MDT} + {3308544000 -25200 0 MST} + {3319434000 -21600 1 MDT} + {3339993600 -25200 0 MST} + {3350883600 -21600 1 MDT} + {3371443200 -25200 0 MST} + {3382938000 -21600 1 MDT} + {3403497600 -25200 0 MST} + {3414387600 -21600 1 MDT} + {3434947200 -25200 0 MST} + {3445837200 -21600 1 MDT} + {3466396800 -25200 0 MST} + {3477286800 -21600 1 MDT} + {3497846400 -25200 0 MST} + {3508736400 -21600 1 MDT} + {3529296000 -25200 0 MST} + {3540186000 -21600 1 MDT} + {3560745600 -25200 0 MST} + {3572240400 -21600 1 MDT} + {3592800000 -25200 0 MST} + {3603690000 -21600 1 MDT} + {3624249600 -25200 0 MST} + {3635139600 -21600 1 MDT} + {3655699200 -25200 0 MST} + {3666589200 -21600 1 MDT} + {3687148800 -25200 0 MST} + {3698038800 -21600 1 MDT} + {3718598400 -25200 0 MST} + {3730093200 -21600 1 MDT} + {3750652800 -25200 0 MST} + {3761542800 -21600 1 MDT} + {3782102400 -25200 0 MST} + {3792992400 -21600 1 MDT} + {3813552000 -25200 0 MST} + {3824442000 -21600 1 MDT} + {3845001600 -25200 0 MST} + {3855891600 -21600 1 MDT} + {3876451200 -25200 0 MST} + {3887341200 -21600 1 MDT} + {3907900800 -25200 0 MST} + {3919395600 -21600 1 MDT} + {3939955200 -25200 0 MST} + {3950845200 -21600 1 MDT} + {3971404800 -25200 0 MST} + {3982294800 -21600 1 MDT} + {4002854400 -25200 0 MST} + {4013744400 -21600 1 MDT} + {4034304000 -25200 0 MST} + {4045194000 -21600 1 MDT} + {4065753600 -25200 0 MST} + {4076643600 -21600 1 MDT} + {4097203200 -25200 0 MST} } Index: library/tzdata/America/Chicago ================================================================== --- library/tzdata/America/Chicago +++ library/tzdata/America/Chicago @@ -1,10 +1,10 @@ # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Chicago) { {-9223372036854775808 -21036 0 LMT} - {-2717647764 -21600 0 CST} + {-2717647200 -21600 0 CST} {-1633276800 -18000 1 CDT} {-1615136400 -21600 0 CST} {-1601827200 -18000 1 CDT} {-1583686800 -21600 0 CST} {-1577901600 -21600 0 CST} @@ -178,192 +178,192 @@ {1099206000 -21600 0 CST} {1112515200 -18000 1 CDT} {1130655600 -21600 0 CST} {1143964800 -18000 1 CDT} {1162105200 -21600 0 CST} - {1175414400 -18000 1 CDT} - {1193554800 -21600 0 CST} - {1207468800 -18000 1 CDT} - {1225004400 -21600 0 CST} - {1238918400 -18000 1 CDT} - {1256454000 -21600 0 CST} - {1270368000 -18000 1 CDT} - {1288508400 -21600 0 CST} - {1301817600 -18000 1 CDT} - {1319958000 -21600 0 CST} - {1333267200 -18000 1 CDT} - {1351407600 -21600 0 CST} - {1365321600 -18000 1 CDT} - {1382857200 -21600 0 CST} - {1396771200 -18000 1 CDT} - {1414306800 -21600 0 CST} - {1428220800 -18000 1 CDT} - {1445756400 -21600 0 CST} - {1459670400 -18000 1 CDT} - {1477810800 -21600 0 CST} - {1491120000 -18000 1 CDT} - {1509260400 -21600 0 CST} - {1522569600 -18000 1 CDT} - {1540710000 -21600 0 CST} - {1554624000 -18000 1 CDT} - {1572159600 -21600 0 CST} - {1586073600 -18000 1 CDT} - {1603609200 -21600 0 CST} - {1617523200 -18000 1 CDT} - {1635663600 -21600 0 CST} - {1648972800 -18000 1 CDT} - {1667113200 -21600 0 CST} - {1680422400 -18000 1 CDT} - {1698562800 -21600 0 CST} - {1712476800 -18000 1 CDT} - {1730012400 -21600 0 CST} - {1743926400 -18000 1 CDT} - {1761462000 -21600 0 CST} - {1775376000 -18000 1 CDT} - {1792911600 -21600 0 CST} - {1806825600 -18000 1 CDT} - {1824966000 -21600 0 CST} - {1838275200 -18000 1 CDT} - {1856415600 -21600 0 CST} - {1869724800 -18000 1 CDT} - {1887865200 -21600 0 CST} - {1901779200 -18000 1 CDT} - {1919314800 -21600 0 CST} - {1933228800 -18000 1 CDT} - {1950764400 -21600 0 CST} - {1964678400 -18000 1 CDT} - {1982818800 -21600 0 CST} - {1996128000 -18000 1 CDT} - {2014268400 -21600 0 CST} - {2027577600 -18000 1 CDT} - {2045718000 -21600 0 CST} - {2059027200 -18000 1 CDT} - {2077167600 -21600 0 CST} - {2091081600 -18000 1 CDT} - {2108617200 -21600 0 CST} - {2122531200 -18000 1 CDT} - {2140066800 -21600 0 CST} - {2153980800 -18000 1 CDT} - {2172121200 -21600 0 CST} - {2185430400 -18000 1 CDT} - {2203570800 -21600 0 CST} - {2216880000 -18000 1 CDT} - {2235020400 -21600 0 CST} - {2248934400 -18000 1 CDT} - {2266470000 -21600 0 CST} - {2280384000 -18000 1 CDT} - {2297919600 -21600 0 CST} - {2311833600 -18000 1 CDT} - {2329369200 -21600 0 CST} - {2343283200 -18000 1 CDT} - {2361423600 -21600 0 CST} - {2374732800 -18000 1 CDT} - {2392873200 -21600 0 CST} - {2406182400 -18000 1 CDT} - {2424322800 -21600 0 CST} - {2438236800 -18000 1 CDT} - {2455772400 -21600 0 CST} - {2469686400 -18000 1 CDT} - {2487222000 -21600 0 CST} - {2501136000 -18000 1 CDT} - {2519276400 -21600 0 CST} - {2532585600 -18000 1 CDT} - {2550726000 -21600 0 CST} - {2564035200 -18000 1 CDT} - {2582175600 -21600 0 CST} - {2596089600 -18000 1 CDT} - {2613625200 -21600 0 CST} - {2627539200 -18000 1 CDT} - {2645074800 -21600 0 CST} - {2658988800 -18000 1 CDT} - {2676524400 -21600 0 CST} - {2690438400 -18000 1 CDT} - {2708578800 -21600 0 CST} - {2721888000 -18000 1 CDT} - {2740028400 -21600 0 CST} - {2753337600 -18000 1 CDT} - {2771478000 -21600 0 CST} - {2785392000 -18000 1 CDT} - {2802927600 -21600 0 CST} - {2816841600 -18000 1 CDT} - {2834377200 -21600 0 CST} - {2848291200 -18000 1 CDT} - {2866431600 -21600 0 CST} - {2879740800 -18000 1 CDT} - {2897881200 -21600 0 CST} - {2911190400 -18000 1 CDT} - {2929330800 -21600 0 CST} - {2942640000 -18000 1 CDT} - {2960780400 -21600 0 CST} - {2974694400 -18000 1 CDT} - {2992230000 -21600 0 CST} - {3006144000 -18000 1 CDT} - {3023679600 -21600 0 CST} - {3037593600 -18000 1 CDT} - {3055734000 -21600 0 CST} - {3069043200 -18000 1 CDT} - {3087183600 -21600 0 CST} - {3100492800 -18000 1 CDT} - {3118633200 -21600 0 CST} - {3132547200 -18000 1 CDT} - {3150082800 -21600 0 CST} - {3163996800 -18000 1 CDT} - {3181532400 -21600 0 CST} - {3195446400 -18000 1 CDT} - {3212982000 -21600 0 CST} - {3226896000 -18000 1 CDT} - {3245036400 -21600 0 CST} - {3258345600 -18000 1 CDT} - {3276486000 -21600 0 CST} - {3289795200 -18000 1 CDT} - {3307935600 -21600 0 CST} - {3321849600 -18000 1 CDT} - {3339385200 -21600 0 CST} - {3353299200 -18000 1 CDT} - {3370834800 -21600 0 CST} - {3384748800 -18000 1 CDT} - {3402889200 -21600 0 CST} - {3416198400 -18000 1 CDT} - {3434338800 -21600 0 CST} - {3447648000 -18000 1 CDT} - {3465788400 -21600 0 CST} - {3479702400 -18000 1 CDT} - {3497238000 -21600 0 CST} - {3511152000 -18000 1 CDT} - {3528687600 -21600 0 CST} - {3542601600 -18000 1 CDT} - {3560137200 -21600 0 CST} - {3574051200 -18000 1 CDT} - {3592191600 -21600 0 CST} - {3605500800 -18000 1 CDT} - {3623641200 -21600 0 CST} - {3636950400 -18000 1 CDT} - {3655090800 -21600 0 CST} - {3669004800 -18000 1 CDT} - {3686540400 -21600 0 CST} - {3700454400 -18000 1 CDT} - {3717990000 -21600 0 CST} - {3731904000 -18000 1 CDT} - {3750044400 -21600 0 CST} - {3763353600 -18000 1 CDT} - {3781494000 -21600 0 CST} - {3794803200 -18000 1 CDT} - {3812943600 -21600 0 CST} - {3826252800 -18000 1 CDT} - {3844393200 -21600 0 CST} - {3858307200 -18000 1 CDT} - {3875842800 -21600 0 CST} - {3889756800 -18000 1 CDT} - {3907292400 -21600 0 CST} - {3921206400 -18000 1 CDT} - {3939346800 -21600 0 CST} - {3952656000 -18000 1 CDT} - {3970796400 -21600 0 CST} - {3984105600 -18000 1 CDT} - {4002246000 -21600 0 CST} - {4016160000 -18000 1 CDT} - {4033695600 -21600 0 CST} - {4047609600 -18000 1 CDT} - {4065145200 -21600 0 CST} - {4079059200 -18000 1 CDT} - {4096594800 -21600 0 CST} + {1173600000 -18000 1 CDT} + {1194159600 -21600 0 CST} + {1205049600 -18000 1 CDT} + {1225609200 -21600 0 CST} + {1236499200 -18000 1 CDT} + {1257058800 -21600 0 CST} + {1268553600 -18000 1 CDT} + {1289113200 -21600 0 CST} + {1300003200 -18000 1 CDT} + {1320562800 -21600 0 CST} + {1331452800 -18000 1 CDT} + {1352012400 -21600 0 CST} + {1362902400 -18000 1 CDT} + {1383462000 -21600 0 CST} + {1394352000 -18000 1 CDT} + {1414911600 -21600 0 CST} + {1425801600 -18000 1 CDT} + {1446361200 -21600 0 CST} + {1457856000 -18000 1 CDT} + {1478415600 -21600 0 CST} + {1489305600 -18000 1 CDT} + {1509865200 -21600 0 CST} + {1520755200 -18000 1 CDT} + {1541314800 -21600 0 CST} + {1552204800 -18000 1 CDT} + {1572764400 -21600 0 CST} + {1583654400 -18000 1 CDT} + {1604214000 -21600 0 CST} + {1615708800 -18000 1 CDT} + {1636268400 -21600 0 CST} + {1647158400 -18000 1 CDT} + {1667718000 -21600 0 CST} + {1678608000 -18000 1 CDT} + {1699167600 -21600 0 CST} + {1710057600 -18000 1 CDT} + {1730617200 -21600 0 CST} + {1741507200 -18000 1 CDT} + {1762066800 -21600 0 CST} + {1772956800 -18000 1 CDT} + {1793516400 -21600 0 CST} + {1805011200 -18000 1 CDT} + {1825570800 -21600 0 CST} + {1836460800 -18000 1 CDT} + {1857020400 -21600 0 CST} + {1867910400 -18000 1 CDT} + {1888470000 -21600 0 CST} + {1899360000 -18000 1 CDT} + {1919919600 -21600 0 CST} + {1930809600 -18000 1 CDT} + {1951369200 -21600 0 CST} + {1962864000 -18000 1 CDT} + {1983423600 -21600 0 CST} + {1994313600 -18000 1 CDT} + {2014873200 -21600 0 CST} + {2025763200 -18000 1 CDT} + {2046322800 -21600 0 CST} + {2057212800 -18000 1 CDT} + {2077772400 -21600 0 CST} + {2088662400 -18000 1 CDT} + {2109222000 -21600 0 CST} + {2120112000 -18000 1 CDT} + {2140671600 -21600 0 CST} + {2152166400 -18000 1 CDT} + {2172726000 -21600 0 CST} + {2183616000 -18000 1 CDT} + {2204175600 -21600 0 CST} + {2215065600 -18000 1 CDT} + {2235625200 -21600 0 CST} + {2246515200 -18000 1 CDT} + {2267074800 -21600 0 CST} + {2277964800 -18000 1 CDT} + {2298524400 -21600 0 CST} + {2309414400 -18000 1 CDT} + {2329974000 -21600 0 CST} + {2341468800 -18000 1 CDT} + {2362028400 -21600 0 CST} + {2372918400 -18000 1 CDT} + {2393478000 -21600 0 CST} + {2404368000 -18000 1 CDT} + {2424927600 -21600 0 CST} + {2435817600 -18000 1 CDT} + {2456377200 -21600 0 CST} + {2467267200 -18000 1 CDT} + {2487826800 -21600 0 CST} + {2499321600 -18000 1 CDT} + {2519881200 -21600 0 CST} + {2530771200 -18000 1 CDT} + {2551330800 -21600 0 CST} + {2562220800 -18000 1 CDT} + {2582780400 -21600 0 CST} + {2593670400 -18000 1 CDT} + {2614230000 -21600 0 CST} + {2625120000 -18000 1 CDT} + {2645679600 -21600 0 CST} + {2656569600 -18000 1 CDT} + {2677129200 -21600 0 CST} + {2688624000 -18000 1 CDT} + {2709183600 -21600 0 CST} + {2720073600 -18000 1 CDT} + {2740633200 -21600 0 CST} + {2751523200 -18000 1 CDT} + {2772082800 -21600 0 CST} + {2782972800 -18000 1 CDT} + {2803532400 -21600 0 CST} + {2814422400 -18000 1 CDT} + {2834982000 -21600 0 CST} + {2846476800 -18000 1 CDT} + {2867036400 -21600 0 CST} + {2877926400 -18000 1 CDT} + {2898486000 -21600 0 CST} + {2909376000 -18000 1 CDT} + {2929935600 -21600 0 CST} + {2940825600 -18000 1 CDT} + {2961385200 -21600 0 CST} + {2972275200 -18000 1 CDT} + {2992834800 -21600 0 CST} + {3003724800 -18000 1 CDT} + {3024284400 -21600 0 CST} + {3035779200 -18000 1 CDT} + {3056338800 -21600 0 CST} + {3067228800 -18000 1 CDT} + {3087788400 -21600 0 CST} + {3098678400 -18000 1 CDT} + {3119238000 -21600 0 CST} + {3130128000 -18000 1 CDT} + {3150687600 -21600 0 CST} + {3161577600 -18000 1 CDT} + {3182137200 -21600 0 CST} + {3193027200 -18000 1 CDT} + {3213586800 -21600 0 CST} + {3225081600 -18000 1 CDT} + {3245641200 -21600 0 CST} + {3256531200 -18000 1 CDT} + {3277090800 -21600 0 CST} + {3287980800 -18000 1 CDT} + {3308540400 -21600 0 CST} + {3319430400 -18000 1 CDT} + {3339990000 -21600 0 CST} + {3350880000 -18000 1 CDT} + {3371439600 -21600 0 CST} + {3382934400 -18000 1 CDT} + {3403494000 -21600 0 CST} + {3414384000 -18000 1 CDT} + {3434943600 -21600 0 CST} + {3445833600 -18000 1 CDT} + {3466393200 -21600 0 CST} + {3477283200 -18000 1 CDT} + {3497842800 -21600 0 CST} + {3508732800 -18000 1 CDT} + {3529292400 -21600 0 CST} + {3540182400 -18000 1 CDT} + {3560742000 -21600 0 CST} + {3572236800 -18000 1 CDT} + {3592796400 -21600 0 CST} + {3603686400 -18000 1 CDT} + {3624246000 -21600 0 CST} + {3635136000 -18000 1 CDT} + {3655695600 -21600 0 CST} + {3666585600 -18000 1 CDT} + {3687145200 -21600 0 CST} + {3698035200 -18000 1 CDT} + {3718594800 -21600 0 CST} + {3730089600 -18000 1 CDT} + {3750649200 -21600 0 CST} + {3761539200 -18000 1 CDT} + {3782098800 -21600 0 CST} + {3792988800 -18000 1 CDT} + {3813548400 -21600 0 CST} + {3824438400 -18000 1 CDT} + {3844998000 -21600 0 CST} + {3855888000 -18000 1 CDT} + {3876447600 -21600 0 CST} + {3887337600 -18000 1 CDT} + {3907897200 -21600 0 CST} + {3919392000 -18000 1 CDT} + {3939951600 -21600 0 CST} + {3950841600 -18000 1 CDT} + {3971401200 -21600 0 CST} + {3982291200 -18000 1 CDT} + {4002850800 -21600 0 CST} + {4013740800 -18000 1 CDT} + {4034300400 -21600 0 CST} + {4045190400 -18000 1 CDT} + {4065750000 -21600 0 CST} + {4076640000 -18000 1 CDT} + {4097199600 -21600 0 CST} } ADDED library/tzdata/America/Coral_Harbour Index: library/tzdata/America/Coral_Harbour ================================================================== --- /dev/null +++ library/tzdata/America/Coral_Harbour @@ -0,0 +1,14 @@ +# created by ../tools/tclZIC.tcl - do not edit + +set TZData(:America/Coral_Harbour) { + {-9223372036854775808 -19960 0 LMT} + {-2713890440 -18000 0 EST} + {-1632070800 -14400 1 EDT} + {-1615140000 -18000 0 EST} + {-1596992400 -14400 1 EDT} + {-1583179200 -18000 0 EST} + {-880218000 -14400 1 EWT} + {-769395600 -14400 1 EPT} + {-765396000 -18000 0 EST} + {-757364400 -18000 0 EST} +} Index: library/tzdata/America/Denver ================================================================== --- library/tzdata/America/Denver +++ library/tzdata/America/Denver @@ -1,10 +1,10 @@ # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Denver) { {-9223372036854775808 -25196 0 LMT} - {-2717643604 -25200 0 MST} + {-2717643600 -25200 0 MST} {-1633273200 -21600 1 MDT} {-1615132800 -25200 0 MST} {-1601823600 -21600 1 MDT} {-1583683200 -25200 0 MST} {-1577898000 -25200 0 MST} @@ -100,192 +100,192 @@ {1099209600 -25200 0 MST} {1112518800 -21600 1 MDT} {1130659200 -25200 0 MST} {1143968400 -21600 1 MDT} {1162108800 -25200 0 MST} - {1175418000 -21600 1 MDT} - {1193558400 -25200 0 MST} - {1207472400 -21600 1 MDT} - {1225008000 -25200 0 MST} - {1238922000 -21600 1 MDT} - {1256457600 -25200 0 MST} - {1270371600 -21600 1 MDT} - {1288512000 -25200 0 MST} - {1301821200 -21600 1 MDT} - {1319961600 -25200 0 MST} - {1333270800 -21600 1 MDT} - {1351411200 -25200 0 MST} - {1365325200 -21600 1 MDT} - {1382860800 -25200 0 MST} - {1396774800 -21600 1 MDT} - {1414310400 -25200 0 MST} - {1428224400 -21600 1 MDT} - {1445760000 -25200 0 MST} - {1459674000 -21600 1 MDT} - {1477814400 -25200 0 MST} - {1491123600 -21600 1 MDT} - {1509264000 -25200 0 MST} - {1522573200 -21600 1 MDT} - {1540713600 -25200 0 MST} - {1554627600 -21600 1 MDT} - {1572163200 -25200 0 MST} - {1586077200 -21600 1 MDT} - {1603612800 -25200 0 MST} - {1617526800 -21600 1 MDT} - {1635667200 -25200 0 MST} - {1648976400 -21600 1 MDT} - {1667116800 -25200 0 MST} - {1680426000 -21600 1 MDT} - {1698566400 -25200 0 MST} - {1712480400 -21600 1 MDT} - {1730016000 -25200 0 MST} - {1743930000 -21600 1 MDT} - {1761465600 -25200 0 MST} - {1775379600 -21600 1 MDT} - {1792915200 -25200 0 MST} - {1806829200 -21600 1 MDT} - {1824969600 -25200 0 MST} - {1838278800 -21600 1 MDT} - {1856419200 -25200 0 MST} - {1869728400 -21600 1 MDT} - {1887868800 -25200 0 MST} - {1901782800 -21600 1 MDT} - {1919318400 -25200 0 MST} - {1933232400 -21600 1 MDT} - {1950768000 -25200 0 MST} - {1964682000 -21600 1 MDT} - {1982822400 -25200 0 MST} - {1996131600 -21600 1 MDT} - {2014272000 -25200 0 MST} - {2027581200 -21600 1 MDT} - {2045721600 -25200 0 MST} - {2059030800 -21600 1 MDT} - {2077171200 -25200 0 MST} - {2091085200 -21600 1 MDT} - {2108620800 -25200 0 MST} - {2122534800 -21600 1 MDT} - {2140070400 -25200 0 MST} - {2153984400 -21600 1 MDT} - {2172124800 -25200 0 MST} - {2185434000 -21600 1 MDT} - {2203574400 -25200 0 MST} - {2216883600 -21600 1 MDT} - {2235024000 -25200 0 MST} - {2248938000 -21600 1 MDT} - {2266473600 -25200 0 MST} - {2280387600 -21600 1 MDT} - {2297923200 -25200 0 MST} - {2311837200 -21600 1 MDT} - {2329372800 -25200 0 MST} - {2343286800 -21600 1 MDT} - {2361427200 -25200 0 MST} - {2374736400 -21600 1 MDT} - {2392876800 -25200 0 MST} - {2406186000 -21600 1 MDT} - {2424326400 -25200 0 MST} - {2438240400 -21600 1 MDT} - {2455776000 -25200 0 MST} - {2469690000 -21600 1 MDT} - {2487225600 -25200 0 MST} - {2501139600 -21600 1 MDT} - {2519280000 -25200 0 MST} - {2532589200 -21600 1 MDT} - {2550729600 -25200 0 MST} - {2564038800 -21600 1 MDT} - {2582179200 -25200 0 MST} - {2596093200 -21600 1 MDT} - {2613628800 -25200 0 MST} - {2627542800 -21600 1 MDT} - {2645078400 -25200 0 MST} - {2658992400 -21600 1 MDT} - {2676528000 -25200 0 MST} - {2690442000 -21600 1 MDT} - {2708582400 -25200 0 MST} - {2721891600 -21600 1 MDT} - {2740032000 -25200 0 MST} - {2753341200 -21600 1 MDT} - {2771481600 -25200 0 MST} - {2785395600 -21600 1 MDT} - {2802931200 -25200 0 MST} - {2816845200 -21600 1 MDT} - {2834380800 -25200 0 MST} - {2848294800 -21600 1 MDT} - {2866435200 -25200 0 MST} - {2879744400 -21600 1 MDT} - {2897884800 -25200 0 MST} - {2911194000 -21600 1 MDT} - {2929334400 -25200 0 MST} - {2942643600 -21600 1 MDT} - {2960784000 -25200 0 MST} - {2974698000 -21600 1 MDT} - {2992233600 -25200 0 MST} - {3006147600 -21600 1 MDT} - {3023683200 -25200 0 MST} - {3037597200 -21600 1 MDT} - {3055737600 -25200 0 MST} - {3069046800 -21600 1 MDT} - {3087187200 -25200 0 MST} - {3100496400 -21600 1 MDT} - {3118636800 -25200 0 MST} - {3132550800 -21600 1 MDT} - {3150086400 -25200 0 MST} - {3164000400 -21600 1 MDT} - {3181536000 -25200 0 MST} - {3195450000 -21600 1 MDT} - {3212985600 -25200 0 MST} - {3226899600 -21600 1 MDT} - {3245040000 -25200 0 MST} - {3258349200 -21600 1 MDT} - {3276489600 -25200 0 MST} - {3289798800 -21600 1 MDT} - {3307939200 -25200 0 MST} - {3321853200 -21600 1 MDT} - {3339388800 -25200 0 MST} - {3353302800 -21600 1 MDT} - {3370838400 -25200 0 MST} - {3384752400 -21600 1 MDT} - {3402892800 -25200 0 MST} - {3416202000 -21600 1 MDT} - {3434342400 -25200 0 MST} - {3447651600 -21600 1 MDT} - {3465792000 -25200 0 MST} - {3479706000 -21600 1 MDT} - {3497241600 -25200 0 MST} - {3511155600 -21600 1 MDT} - {3528691200 -25200 0 MST} - {3542605200 -21600 1 MDT} - {3560140800 -25200 0 MST} - {3574054800 -21600 1 MDT} - {3592195200 -25200 0 MST} - {3605504400 -21600 1 MDT} - {3623644800 -25200 0 MST} - {3636954000 -21600 1 MDT} - {3655094400 -25200 0 MST} - {3669008400 -21600 1 MDT} - {3686544000 -25200 0 MST} - {3700458000 -21600 1 MDT} - {3717993600 -25200 0 MST} - {3731907600 -21600 1 MDT} - {3750048000 -25200 0 MST} - {3763357200 -21600 1 MDT} - {3781497600 -25200 0 MST} - {3794806800 -21600 1 MDT} - {3812947200 -25200 0 MST} - {3826256400 -21600 1 MDT} - {3844396800 -25200 0 MST} - {3858310800 -21600 1 MDT} - {3875846400 -25200 0 MST} - {3889760400 -21600 1 MDT} - {3907296000 -25200 0 MST} - {3921210000 -21600 1 MDT} - {3939350400 -25200 0 MST} - {3952659600 -21600 1 MDT} - {3970800000 -25200 0 MST} - {3984109200 -21600 1 MDT} - {4002249600 -25200 0 MST} - {4016163600 -21600 1 MDT} - {4033699200 -25200 0 MST} - {4047613200 -21600 1 MDT} - {4065148800 -25200 0 MST} - {4079062800 -21600 1 MDT} - {4096598400 -25200 0 MST} + {1173603600 -21600 1 MDT} + {1194163200 -25200 0 MST} + {1205053200 -21600 1 MDT} + {1225612800 -25200 0 MST} + {1236502800 -21600 1 MDT} + {1257062400 -25200 0 MST} + {1268557200 -21600 1 MDT} + {1289116800 -25200 0 MST} + {1300006800 -21600 1 MDT} + {1320566400 -25200 0 MST} + {1331456400 -21600 1 MDT} + {1352016000 -25200 0 MST} + {1362906000 -21600 1 MDT} + {1383465600 -25200 0 MST} + {1394355600 -21600 1 MDT} + {1414915200 -25200 0 MST} + {1425805200 -21600 1 MDT} + {1446364800 -25200 0 MST} + {1457859600 -21600 1 MDT} + {1478419200 -25200 0 MST} + {1489309200 -21600 1 MDT} + {1509868800 -25200 0 MST} + {1520758800 -21600 1 MDT} + {1541318400 -25200 0 MST} + {1552208400 -21600 1 MDT} + {1572768000 -25200 0 MST} + {1583658000 -21600 1 MDT} + {1604217600 -25200 0 MST} + {1615712400 -21600 1 MDT} + {1636272000 -25200 0 MST} + {1647162000 -21600 1 MDT} + {1667721600 -25200 0 MST} + {1678611600 -21600 1 MDT} + {1699171200 -25200 0 MST} + {1710061200 -21600 1 MDT} + {1730620800 -25200 0 MST} + {1741510800 -21600 1 MDT} + {1762070400 -25200 0 MST} + {1772960400 -21600 1 MDT} + {1793520000 -25200 0 MST} + {1805014800 -21600 1 MDT} + {1825574400 -25200 0 MST} + {1836464400 -21600 1 MDT} + {1857024000 -25200 0 MST} + {1867914000 -21600 1 MDT} + {1888473600 -25200 0 MST} + {1899363600 -21600 1 MDT} + {1919923200 -25200 0 MST} + {1930813200 -21600 1 MDT} + {1951372800 -25200 0 MST} + {1962867600 -21600 1 MDT} + {1983427200 -25200 0 MST} + {1994317200 -21600 1 MDT} + {2014876800 -25200 0 MST} + {2025766800 -21600 1 MDT} + {2046326400 -25200 0 MST} + {2057216400 -21600 1 MDT} + {2077776000 -25200 0 MST} + {2088666000 -21600 1 MDT} + {2109225600 -25200 0 MST} + {2120115600 -21600 1 MDT} + {2140675200 -25200 0 MST} + {2152170000 -21600 1 MDT} + {2172729600 -25200 0 MST} + {2183619600 -21600 1 MDT} + {2204179200 -25200 0 MST} + {2215069200 -21600 1 MDT} + {2235628800 -25200 0 MST} + {2246518800 -21600 1 MDT} + {2267078400 -25200 0 MST} + {2277968400 -21600 1 MDT} + {2298528000 -25200 0 MST} + {2309418000 -21600 1 MDT} + {2329977600 -25200 0 MST} + {2341472400 -21600 1 MDT} + {2362032000 -25200 0 MST} + {2372922000 -21600 1 MDT} + {2393481600 -25200 0 MST} + {2404371600 -21600 1 MDT} + {2424931200 -25200 0 MST} + {2435821200 -21600 1 MDT} + {2456380800 -25200 0 MST} + {2467270800 -21600 1 MDT} + {2487830400 -25200 0 MST} + {2499325200 -21600 1 MDT} + {2519884800 -25200 0 MST} + {2530774800 -21600 1 MDT} + {2551334400 -25200 0 MST} + {2562224400 -21600 1 MDT} + {2582784000 -25200 0 MST} + {2593674000 -21600 1 MDT} + {2614233600 -25200 0 MST} + {2625123600 -21600 1 MDT} + {2645683200 -25200 0 MST} + {2656573200 -21600 1 MDT} + {2677132800 -25200 0 MST} + {2688627600 -21600 1 MDT} + {2709187200 -25200 0 MST} + {2720077200 -21600 1 MDT} + {2740636800 -25200 0 MST} + {2751526800 -21600 1 MDT} + {2772086400 -25200 0 MST} + {2782976400 -21600 1 MDT} + {2803536000 -25200 0 MST} + {2814426000 -21600 1 MDT} + {2834985600 -25200 0 MST} + {2846480400 -21600 1 MDT} + {2867040000 -25200 0 MST} + {2877930000 -21600 1 MDT} + {2898489600 -25200 0 MST} + {2909379600 -21600 1 MDT} + {2929939200 -25200 0 MST} + {2940829200 -21600 1 MDT} + {2961388800 -25200 0 MST} + {2972278800 -21600 1 MDT} + {2992838400 -25200 0 MST} + {3003728400 -21600 1 MDT} + {3024288000 -25200 0 MST} + {3035782800 -21600 1 MDT} + {3056342400 -25200 0 MST} + {3067232400 -21600 1 MDT} + {3087792000 -25200 0 MST} + {3098682000 -21600 1 MDT} + {3119241600 -25200 0 MST} + {3130131600 -21600 1 MDT} + {3150691200 -25200 0 MST} + {3161581200 -21600 1 MDT} + {3182140800 -25200 0 MST} + {3193030800 -21600 1 MDT} + {3213590400 -25200 0 MST} + {3225085200 -21600 1 MDT} + {3245644800 -25200 0 MST} + {3256534800 -21600 1 MDT} + {3277094400 -25200 0 MST} + {3287984400 -21600 1 MDT} + {3308544000 -25200 0 MST} + {3319434000 -21600 1 MDT} + {3339993600 -25200 0 MST} + {3350883600 -21600 1 MDT} + {3371443200 -25200 0 MST} + {3382938000 -21600 1 MDT} + {3403497600 -25200 0 MST} + {3414387600 -21600 1 MDT} + {3434947200 -25200 0 MST} + {3445837200 -21600 1 MDT} + {3466396800 -25200 0 MST} + {3477286800 -21600 1 MDT} + {3497846400 -25200 0 MST} + {3508736400 -21600 1 MDT} + {3529296000 -25200 0 MST} + {3540186000 -21600 1 MDT} + {3560745600 -25200 0 MST} + {3572240400 -21600 1 MDT} + {3592800000 -25200 0 MST} + {3603690000 -21600 1 MDT} + {3624249600 -25200 0 MST} + {3635139600 -21600 1 MDT} + {3655699200 -25200 0 MST} + {3666589200 -21600 1 MDT} + {3687148800 -25200 0 MST} + {3698038800 -21600 1 MDT} + {3718598400 -25200 0 MST} + {3730093200 -21600 1 MDT} + {3750652800 -25200 0 MST} + {3761542800 -21600 1 MDT} + {3782102400 -25200 0 MST} + {3792992400 -21600 1 MDT} + {3813552000 -25200 0 MST} + {3824442000 -21600 1 MDT} + {3845001600 -25200 0 MST} + {3855891600 -21600 1 MDT} + {3876451200 -25200 0 MST} + {3887341200 -21600 1 MDT} + {3907900800 -25200 0 MST} + {3919395600 -21600 1 MDT} + {3939955200 -25200 0 MST} + {3950845200 -21600 1 MDT} + {3971404800 -25200 0 MST} + {3982294800 -21600 1 MDT} + {4002854400 -25200 0 MST} + {4013744400 -21600 1 MDT} + {4034304000 -25200 0 MST} + {4045194000 -21600 1 MDT} + {4065753600 -25200 0 MST} + {4076643600 -21600 1 MDT} + {4097203200 -25200 0 MST} } Index: library/tzdata/America/Detroit ================================================================== --- library/tzdata/America/Detroit +++ library/tzdata/America/Detroit @@ -81,192 +81,192 @@ {1099202400 -18000 0 EST} {1112511600 -14400 1 EDT} {1130652000 -18000 0 EST} {1143961200 -14400 1 EDT} {1162101600 -18000 0 EST} - {1175410800 -14400 1 EDT} - {1193551200 -18000 0 EST} - {1207465200 -14400 1 EDT} - {1225000800 -18000 0 EST} - {1238914800 -14400 1 EDT} - {1256450400 -18000 0 EST} - {1270364400 -14400 1 EDT} - {1288504800 -18000 0 EST} - {1301814000 -14400 1 EDT} - {1319954400 -18000 0 EST} - {1333263600 -14400 1 EDT} - {1351404000 -18000 0 EST} - {1365318000 -14400 1 EDT} - {1382853600 -18000 0 EST} - {1396767600 -14400 1 EDT} - {1414303200 -18000 0 EST} - {1428217200 -14400 1 EDT} - {1445752800 -18000 0 EST} - {1459666800 -14400 1 EDT} - {1477807200 -18000 0 EST} - {1491116400 -14400 1 EDT} - {1509256800 -18000 0 EST} - {1522566000 -14400 1 EDT} - {1540706400 -18000 0 EST} - {1554620400 -14400 1 EDT} - {1572156000 -18000 0 EST} - {1586070000 -14400 1 EDT} - {1603605600 -18000 0 EST} - {1617519600 -14400 1 EDT} - {1635660000 -18000 0 EST} - {1648969200 -14400 1 EDT} - {1667109600 -18000 0 EST} - {1680418800 -14400 1 EDT} - {1698559200 -18000 0 EST} - {1712473200 -14400 1 EDT} - {1730008800 -18000 0 EST} - {1743922800 -14400 1 EDT} - {1761458400 -18000 0 EST} - {1775372400 -14400 1 EDT} - {1792908000 -18000 0 EST} - {1806822000 -14400 1 EDT} - {1824962400 -18000 0 EST} - {1838271600 -14400 1 EDT} - {1856412000 -18000 0 EST} - {1869721200 -14400 1 EDT} - {1887861600 -18000 0 EST} - {1901775600 -14400 1 EDT} - {1919311200 -18000 0 EST} - {1933225200 -14400 1 EDT} - {1950760800 -18000 0 EST} - {1964674800 -14400 1 EDT} - {1982815200 -18000 0 EST} - {1996124400 -14400 1 EDT} - {2014264800 -18000 0 EST} - {2027574000 -14400 1 EDT} - {2045714400 -18000 0 EST} - {2059023600 -14400 1 EDT} - {2077164000 -18000 0 EST} - {2091078000 -14400 1 EDT} - {2108613600 -18000 0 EST} - {2122527600 -14400 1 EDT} - {2140063200 -18000 0 EST} - {2153977200 -14400 1 EDT} - {2172117600 -18000 0 EST} - {2185426800 -14400 1 EDT} - {2203567200 -18000 0 EST} - {2216876400 -14400 1 EDT} - {2235016800 -18000 0 EST} - {2248930800 -14400 1 EDT} - {2266466400 -18000 0 EST} - {2280380400 -14400 1 EDT} - {2297916000 -18000 0 EST} - {2311830000 -14400 1 EDT} - {2329365600 -18000 0 EST} - {2343279600 -14400 1 EDT} - {2361420000 -18000 0 EST} - {2374729200 -14400 1 EDT} - {2392869600 -18000 0 EST} - {2406178800 -14400 1 EDT} - {2424319200 -18000 0 EST} - {2438233200 -14400 1 EDT} - {2455768800 -18000 0 EST} - {2469682800 -14400 1 EDT} - {2487218400 -18000 0 EST} - {2501132400 -14400 1 EDT} - {2519272800 -18000 0 EST} - {2532582000 -14400 1 EDT} - {2550722400 -18000 0 EST} - {2564031600 -14400 1 EDT} - {2582172000 -18000 0 EST} - {2596086000 -14400 1 EDT} - {2613621600 -18000 0 EST} - {2627535600 -14400 1 EDT} - {2645071200 -18000 0 EST} - {2658985200 -14400 1 EDT} - {2676520800 -18000 0 EST} - {2690434800 -14400 1 EDT} - {2708575200 -18000 0 EST} - {2721884400 -14400 1 EDT} - {2740024800 -18000 0 EST} - {2753334000 -14400 1 EDT} - {2771474400 -18000 0 EST} - {2785388400 -14400 1 EDT} - {2802924000 -18000 0 EST} - {2816838000 -14400 1 EDT} - {2834373600 -18000 0 EST} - {2848287600 -14400 1 EDT} - {2866428000 -18000 0 EST} - {2879737200 -14400 1 EDT} - {2897877600 -18000 0 EST} - {2911186800 -14400 1 EDT} - {2929327200 -18000 0 EST} - {2942636400 -14400 1 EDT} - {2960776800 -18000 0 EST} - {2974690800 -14400 1 EDT} - {2992226400 -18000 0 EST} - {3006140400 -14400 1 EDT} - {3023676000 -18000 0 EST} - {3037590000 -14400 1 EDT} - {3055730400 -18000 0 EST} - {3069039600 -14400 1 EDT} - {3087180000 -18000 0 EST} - {3100489200 -14400 1 EDT} - {3118629600 -18000 0 EST} - {3132543600 -14400 1 EDT} - {3150079200 -18000 0 EST} - {3163993200 -14400 1 EDT} - {3181528800 -18000 0 EST} - {3195442800 -14400 1 EDT} - {3212978400 -18000 0 EST} - {3226892400 -14400 1 EDT} - {3245032800 -18000 0 EST} - {3258342000 -14400 1 EDT} - {3276482400 -18000 0 EST} - {3289791600 -14400 1 EDT} - {3307932000 -18000 0 EST} - {3321846000 -14400 1 EDT} - {3339381600 -18000 0 EST} - {3353295600 -14400 1 EDT} - {3370831200 -18000 0 EST} - {3384745200 -14400 1 EDT} - {3402885600 -18000 0 EST} - {3416194800 -14400 1 EDT} - {3434335200 -18000 0 EST} - {3447644400 -14400 1 EDT} - {3465784800 -18000 0 EST} - {3479698800 -14400 1 EDT} - {3497234400 -18000 0 EST} - {3511148400 -14400 1 EDT} - {3528684000 -18000 0 EST} - {3542598000 -14400 1 EDT} - {3560133600 -18000 0 EST} - {3574047600 -14400 1 EDT} - {3592188000 -18000 0 EST} - {3605497200 -14400 1 EDT} - {3623637600 -18000 0 EST} - {3636946800 -14400 1 EDT} - {3655087200 -18000 0 EST} - {3669001200 -14400 1 EDT} - {3686536800 -18000 0 EST} - {3700450800 -14400 1 EDT} - {3717986400 -18000 0 EST} - {3731900400 -14400 1 EDT} - {3750040800 -18000 0 EST} - {3763350000 -14400 1 EDT} - {3781490400 -18000 0 EST} - {3794799600 -14400 1 EDT} - {3812940000 -18000 0 EST} - {3826249200 -14400 1 EDT} - {3844389600 -18000 0 EST} - {3858303600 -14400 1 EDT} - {3875839200 -18000 0 EST} - {3889753200 -14400 1 EDT} - {3907288800 -18000 0 EST} - {3921202800 -14400 1 EDT} - {3939343200 -18000 0 EST} - {3952652400 -14400 1 EDT} - {3970792800 -18000 0 EST} - {3984102000 -14400 1 EDT} - {4002242400 -18000 0 EST} - {4016156400 -14400 1 EDT} - {4033692000 -18000 0 EST} - {4047606000 -14400 1 EDT} - {4065141600 -18000 0 EST} - {4079055600 -14400 1 EDT} - {4096591200 -18000 0 EST} + {1173596400 -14400 1 EDT} + {1194156000 -18000 0 EST} + {1205046000 -14400 1 EDT} + {1225605600 -18000 0 EST} + {1236495600 -14400 1 EDT} + {1257055200 -18000 0 EST} + {1268550000 -14400 1 EDT} + {1289109600 -18000 0 EST} + {1299999600 -14400 1 EDT} + {1320559200 -18000 0 EST} + {1331449200 -14400 1 EDT} + {1352008800 -18000 0 EST} + {1362898800 -14400 1 EDT} + {1383458400 -18000 0 EST} + {1394348400 -14400 1 EDT} + {1414908000 -18000 0 EST} + {1425798000 -14400 1 EDT} + {1446357600 -18000 0 EST} + {1457852400 -14400 1 EDT} + {1478412000 -18000 0 EST} + {1489302000 -14400 1 EDT} + {1509861600 -18000 0 EST} + {1520751600 -14400 1 EDT} + {1541311200 -18000 0 EST} + {1552201200 -14400 1 EDT} + {1572760800 -18000 0 EST} + {1583650800 -14400 1 EDT} + {1604210400 -18000 0 EST} + {1615705200 -14400 1 EDT} + {1636264800 -18000 0 EST} + {1647154800 -14400 1 EDT} + {1667714400 -18000 0 EST} + {1678604400 -14400 1 EDT} + {1699164000 -18000 0 EST} + {1710054000 -14400 1 EDT} + {1730613600 -18000 0 EST} + {1741503600 -14400 1 EDT} + {1762063200 -18000 0 EST} + {1772953200 -14400 1 EDT} + {1793512800 -18000 0 EST} + {1805007600 -14400 1 EDT} + {1825567200 -18000 0 EST} + {1836457200 -14400 1 EDT} + {1857016800 -18000 0 EST} + {1867906800 -14400 1 EDT} + {1888466400 -18000 0 EST} + {1899356400 -14400 1 EDT} + {1919916000 -18000 0 EST} + {1930806000 -14400 1 EDT} + {1951365600 -18000 0 EST} + {1962860400 -14400 1 EDT} + {1983420000 -18000 0 EST} + {1994310000 -14400 1 EDT} + {2014869600 -18000 0 EST} + {2025759600 -14400 1 EDT} + {2046319200 -18000 0 EST} + {2057209200 -14400 1 EDT} + {2077768800 -18000 0 EST} + {2088658800 -14400 1 EDT} + {2109218400 -18000 0 EST} + {2120108400 -14400 1 EDT} + {2140668000 -18000 0 EST} + {2152162800 -14400 1 EDT} + {2172722400 -18000 0 EST} + {2183612400 -14400 1 EDT} + {2204172000 -18000 0 EST} + {2215062000 -14400 1 EDT} + {2235621600 -18000 0 EST} + {2246511600 -14400 1 EDT} + {2267071200 -18000 0 EST} + {2277961200 -14400 1 EDT} + {2298520800 -18000 0 EST} + {2309410800 -14400 1 EDT} + {2329970400 -18000 0 EST} + {2341465200 -14400 1 EDT} + {2362024800 -18000 0 EST} + {2372914800 -14400 1 EDT} + {2393474400 -18000 0 EST} + {2404364400 -14400 1 EDT} + {2424924000 -18000 0 EST} + {2435814000 -14400 1 EDT} + {2456373600 -18000 0 EST} + {2467263600 -14400 1 EDT} + {2487823200 -18000 0 EST} + {2499318000 -14400 1 EDT} + {2519877600 -18000 0 EST} + {2530767600 -14400 1 EDT} + {2551327200 -18000 0 EST} + {2562217200 -14400 1 EDT} + {2582776800 -18000 0 EST} + {2593666800 -14400 1 EDT} + {2614226400 -18000 0 EST} + {2625116400 -14400 1 EDT} + {2645676000 -18000 0 EST} + {2656566000 -14400 1 EDT} + {2677125600 -18000 0 EST} + {2688620400 -14400 1 EDT} + {2709180000 -18000 0 EST} + {2720070000 -14400 1 EDT} + {2740629600 -18000 0 EST} + {2751519600 -14400 1 EDT} + {2772079200 -18000 0 EST} + {2782969200 -14400 1 EDT} + {2803528800 -18000 0 EST} + {2814418800 -14400 1 EDT} + {2834978400 -18000 0 EST} + {2846473200 -14400 1 EDT} + {2867032800 -18000 0 EST} + {2877922800 -14400 1 EDT} + {2898482400 -18000 0 EST} + {2909372400 -14400 1 EDT} + {2929932000 -18000 0 EST} + {2940822000 -14400 1 EDT} + {2961381600 -18000 0 EST} + {2972271600 -14400 1 EDT} + {2992831200 -18000 0 EST} + {3003721200 -14400 1 EDT} + {3024280800 -18000 0 EST} + {3035775600 -14400 1 EDT} + {3056335200 -18000 0 EST} + {3067225200 -14400 1 EDT} + {3087784800 -18000 0 EST} + {3098674800 -14400 1 EDT} + {3119234400 -18000 0 EST} + {3130124400 -14400 1 EDT} + {3150684000 -18000 0 EST} + {3161574000 -14400 1 EDT} + {3182133600 -18000 0 EST} + {3193023600 -14400 1 EDT} + {3213583200 -18000 0 EST} + {3225078000 -14400 1 EDT} + {3245637600 -18000 0 EST} + {3256527600 -14400 1 EDT} + {3277087200 -18000 0 EST} + {3287977200 -14400 1 EDT} + {3308536800 -18000 0 EST} + {3319426800 -14400 1 EDT} + {3339986400 -18000 0 EST} + {3350876400 -14400 1 EDT} + {3371436000 -18000 0 EST} + {3382930800 -14400 1 EDT} + {3403490400 -18000 0 EST} + {3414380400 -14400 1 EDT} + {3434940000 -18000 0 EST} + {3445830000 -14400 1 EDT} + {3466389600 -18000 0 EST} + {3477279600 -14400 1 EDT} + {3497839200 -18000 0 EST} + {3508729200 -14400 1 EDT} + {3529288800 -18000 0 EST} + {3540178800 -14400 1 EDT} + {3560738400 -18000 0 EST} + {3572233200 -14400 1 EDT} + {3592792800 -18000 0 EST} + {3603682800 -14400 1 EDT} + {3624242400 -18000 0 EST} + {3635132400 -14400 1 EDT} + {3655692000 -18000 0 EST} + {3666582000 -14400 1 EDT} + {3687141600 -18000 0 EST} + {3698031600 -14400 1 EDT} + {3718591200 -18000 0 EST} + {3730086000 -14400 1 EDT} + {3750645600 -18000 0 EST} + {3761535600 -14400 1 EDT} + {3782095200 -18000 0 EST} + {3792985200 -14400 1 EDT} + {3813544800 -18000 0 EST} + {3824434800 -14400 1 EDT} + {3844994400 -18000 0 EST} + {3855884400 -14400 1 EDT} + {3876444000 -18000 0 EST} + {3887334000 -14400 1 EDT} + {3907893600 -18000 0 EST} + {3919388400 -14400 1 EDT} + {3939948000 -18000 0 EST} + {3950838000 -14400 1 EDT} + {3971397600 -18000 0 EST} + {3982287600 -14400 1 EDT} + {4002847200 -18000 0 EST} + {4013737200 -14400 1 EDT} + {4034296800 -18000 0 EST} + {4045186800 -14400 1 EDT} + {4065746400 -18000 0 EST} + {4076636400 -14400 1 EDT} + {4097196000 -18000 0 EST} } Index: library/tzdata/America/Fort_Wayne ================================================================== --- library/tzdata/America/Fort_Wayne +++ library/tzdata/America/Fort_Wayne @@ -1,5 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Indianapolis)]} { - LoadTimeZoneFile America/Indianapolis +if {![info exists TZData(America/Indiana/Indianapolis)]} { + LoadTimeZoneFile America/Indiana/Indianapolis } -set TZData(:America/Fort_Wayne) $TZData(:America/Indianapolis) +set TZData(:America/Fort_Wayne) $TZData(:America/Indiana/Indianapolis) Index: library/tzdata/America/Indiana/Indianapolis ================================================================== --- library/tzdata/America/Indiana/Indianapolis +++ library/tzdata/America/Indiana/Indianapolis @@ -1,5 +1,234 @@ # created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Indianapolis)]} { - LoadTimeZoneFile America/Indianapolis + +set TZData(:America/Indiana/Indianapolis) { + {-9223372036854775808 -20678 0 LMT} + {-2717647200 -21600 0 CST} + {-1633276800 -18000 1 CDT} + {-1615136400 -21600 0 CST} + {-1601827200 -18000 1 CDT} + {-1583686800 -21600 0 CST} + {-1577901600 -21600 0 CST} + {-900259200 -18000 1 CDT} + {-891795600 -21600 0 CST} + {-883591200 -21600 0 CST} + {-880214400 -18000 1 CWT} + {-769395600 -18000 1 CPT} + {-765392400 -21600 0 CST} + {-757360800 -21600 0 CST} + {-747244800 -18000 1 CDT} + {-733942800 -21600 0 CST} + {-715795200 -18000 1 CDT} + {-702493200 -21600 0 CST} + {-684345600 -18000 1 CDT} + {-671043600 -21600 0 CST} + {-652896000 -18000 1 CDT} + {-639594000 -21600 0 CST} + {-620841600 -18000 1 CDT} + {-608144400 -21600 0 CST} + {-589392000 -18000 1 CDT} + {-576090000 -21600 0 CST} + {-557942400 -18000 1 CDT} + {-544640400 -21600 0 CST} + {-526492800 -18000 1 CDT} + {-513190800 -21600 0 CST} + {-495043200 -18000 1 CDT} + {-481741200 -21600 0 CST} + {-463593600 -18000 0 EST} + {-386787600 -21600 0 CST} + {-368640000 -18000 0 EST} + {-31518000 -18000 0 EST} + {-21488400 -14400 1 EDT} + {-5767200 -18000 0 EST} + {9961200 -14400 1 EDT} + {25682400 -18000 0 EST} + {31554000 -18000 0 EST} + {1136091600 -18000 0 EST} + {1143961200 -14400 1 EDT} + {1162101600 -18000 0 EST} + {1173596400 -14400 1 EDT} + {1194156000 -18000 0 EST} + {1205046000 -14400 1 EDT} + {1225605600 -18000 0 EST} + {1236495600 -14400 1 EDT} + {1257055200 -18000 0 EST} + {1268550000 -14400 1 EDT} + {1289109600 -18000 0 EST} + {1299999600 -14400 1 EDT} + {1320559200 -18000 0 EST} + {1331449200 -14400 1 EDT} + {1352008800 -18000 0 EST} + {1362898800 -14400 1 EDT} + {1383458400 -18000 0 EST} + {1394348400 -14400 1 EDT} + {1414908000 -18000 0 EST} + {1425798000 -14400 1 EDT} + {1446357600 -18000 0 EST} + {1457852400 -14400 1 EDT} + {1478412000 -18000 0 EST} + {1489302000 -14400 1 EDT} + {1509861600 -18000 0 EST} + {1520751600 -14400 1 EDT} + {1541311200 -18000 0 EST} + {1552201200 -14400 1 EDT} + {1572760800 -18000 0 EST} + {1583650800 -14400 1 EDT} + {1604210400 -18000 0 EST} + {1615705200 -14400 1 EDT} + {1636264800 -18000 0 EST} + {1647154800 -14400 1 EDT} + {1667714400 -18000 0 EST} + {1678604400 -14400 1 EDT} + {1699164000 -18000 0 EST} + {1710054000 -14400 1 EDT} + {1730613600 -18000 0 EST} + {1741503600 -14400 1 EDT} + {1762063200 -18000 0 EST} + {1772953200 -14400 1 EDT} + {1793512800 -18000 0 EST} + {1805007600 -14400 1 EDT} + {1825567200 -18000 0 EST} + {1836457200 -14400 1 EDT} + {1857016800 -18000 0 EST} + {1867906800 -14400 1 EDT} + {1888466400 -18000 0 EST} + {1899356400 -14400 1 EDT} + {1919916000 -18000 0 EST} + {1930806000 -14400 1 EDT} + {1951365600 -18000 0 EST} + {1962860400 -14400 1 EDT} + {1983420000 -18000 0 EST} + {1994310000 -14400 1 EDT} + {2014869600 -18000 0 EST} + {2025759600 -14400 1 EDT} + {2046319200 -18000 0 EST} + {2057209200 -14400 1 EDT} + {2077768800 -18000 0 EST} + {2088658800 -14400 1 EDT} + {2109218400 -18000 0 EST} + {2120108400 -14400 1 EDT} + {2140668000 -18000 0 EST} + {2152162800 -14400 1 EDT} + {2172722400 -18000 0 EST} + {2183612400 -14400 1 EDT} + {2204172000 -18000 0 EST} + {2215062000 -14400 1 EDT} + {2235621600 -18000 0 EST} + {2246511600 -14400 1 EDT} + {2267071200 -18000 0 EST} + {2277961200 -14400 1 EDT} + {2298520800 -18000 0 EST} + {2309410800 -14400 1 EDT} + {2329970400 -18000 0 EST} + {2341465200 -14400 1 EDT} + {2362024800 -18000 0 EST} + {2372914800 -14400 1 EDT} + {2393474400 -18000 0 EST} + {2404364400 -14400 1 EDT} + {2424924000 -18000 0 EST} + {2435814000 -14400 1 EDT} + {2456373600 -18000 0 EST} + {2467263600 -14400 1 EDT} + {2487823200 -18000 0 EST} + {2499318000 -14400 1 EDT} + {2519877600 -18000 0 EST} + {2530767600 -14400 1 EDT} + {2551327200 -18000 0 EST} + {2562217200 -14400 1 EDT} + {2582776800 -18000 0 EST} + {2593666800 -14400 1 EDT} + {2614226400 -18000 0 EST} + {2625116400 -14400 1 EDT} + {2645676000 -18000 0 EST} + {2656566000 -14400 1 EDT} + {2677125600 -18000 0 EST} + {2688620400 -14400 1 EDT} + {2709180000 -18000 0 EST} + {2720070000 -14400 1 EDT} + {2740629600 -18000 0 EST} + {2751519600 -14400 1 EDT} + {2772079200 -18000 0 EST} + {2782969200 -14400 1 EDT} + {2803528800 -18000 0 EST} + {2814418800 -14400 1 EDT} + {2834978400 -18000 0 EST} + {2846473200 -14400 1 EDT} + {2867032800 -18000 0 EST} + {2877922800 -14400 1 EDT} + {2898482400 -18000 0 EST} + {2909372400 -14400 1 EDT} + {2929932000 -18000 0 EST} + {2940822000 -14400 1 EDT} + {2961381600 -18000 0 EST} + {2972271600 -14400 1 EDT} + {2992831200 -18000 0 EST} + {3003721200 -14400 1 EDT} + {3024280800 -18000 0 EST} + {3035775600 -14400 1 EDT} + {3056335200 -18000 0 EST} + {3067225200 -14400 1 EDT} + {3087784800 -18000 0 EST} + {3098674800 -14400 1 EDT} + {3119234400 -18000 0 EST} + {3130124400 -14400 1 EDT} + {3150684000 -18000 0 EST} + {3161574000 -14400 1 EDT} + {3182133600 -18000 0 EST} + {3193023600 -14400 1 EDT} + {3213583200 -18000 0 EST} + {3225078000 -14400 1 EDT} + {3245637600 -18000 0 EST} + {3256527600 -14400 1 EDT} + {3277087200 -18000 0 EST} + {3287977200 -14400 1 EDT} + {3308536800 -18000 0 EST} + {3319426800 -14400 1 EDT} + {3339986400 -18000 0 EST} + {3350876400 -14400 1 EDT} + {3371436000 -18000 0 EST} + {3382930800 -14400 1 EDT} + {3403490400 -18000 0 EST} + {3414380400 -14400 1 EDT} + {3434940000 -18000 0 EST} + {3445830000 -14400 1 EDT} + {3466389600 -18000 0 EST} + {3477279600 -14400 1 EDT} + {3497839200 -18000 0 EST} + {3508729200 -14400 1 EDT} + {3529288800 -18000 0 EST} + {3540178800 -14400 1 EDT} + {3560738400 -18000 0 EST} + {3572233200 -14400 1 EDT} + {3592792800 -18000 0 EST} + {3603682800 -14400 1 EDT} + {3624242400 -18000 0 EST} + {3635132400 -14400 1 EDT} + {3655692000 -18000 0 EST} + {3666582000 -14400 1 EDT} + {3687141600 -18000 0 EST} + {3698031600 -14400 1 EDT} + {3718591200 -18000 0 EST} + {3730086000 -14400 1 EDT} + {3750645600 -18000 0 EST} + {3761535600 -14400 1 EDT} + {3782095200 -18000 0 EST} + {3792985200 -14400 1 EDT} + {3813544800 -18000 0 EST} + {3824434800 -14400 1 EDT} + {3844994400 -18000 0 EST} + {3855884400 -14400 1 EDT} + {3876444000 -18000 0 EST} + {3887334000 -14400 1 EDT} + {3907893600 -18000 0 EST} + {3919388400 -14400 1 EDT} + {3939948000 -18000 0 EST} + {3950838000 -14400 1 EDT} + {3971397600 -18000 0 EST} + {3982287600 -14400 1 EDT} + {4002847200 -18000 0 EST} + {4013737200 -14400 1 EDT} + {4034296800 -18000 0 EST} + {4045186800 -14400 1 EDT} + {4065746400 -18000 0 EST} + {4076636400 -14400 1 EDT} + {4097196000 -18000 0 EST} } -set TZData(:America/Indiana/Indianapolis) $TZData(:America/Indianapolis) Index: library/tzdata/America/Indiana/Knox ================================================================== --- library/tzdata/America/Indiana/Knox +++ library/tzdata/America/Indiana/Knox @@ -1,10 +1,10 @@ # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Indiana/Knox) { {-9223372036854775808 -20790 0 LMT} - {-2717648010 -21600 0 CST} + {-2717647200 -21600 0 CST} {-1633276800 -18000 1 CDT} {-1615136400 -21600 0 CST} {-1601827200 -18000 1 CDT} {-1583686800 -21600 0 CST} {-880214400 -18000 1 CWT} @@ -91,6 +91,195 @@ {625647600 -21600 0 CST} {638956800 -18000 1 CDT} {657097200 -21600 0 CST} {671011200 -18000 1 CDT} {688550400 -18000 0 EST} + {1136091600 -18000 0 EST} + {1143961200 -14400 1 EDT} + {1162101600 -18000 0 EST} + {1173596400 -14400 1 EDT} + {1194156000 -18000 0 EST} + {1205046000 -14400 1 EDT} + {1225605600 -18000 0 EST} + {1236495600 -14400 1 EDT} + {1257055200 -18000 0 EST} + {1268550000 -14400 1 EDT} + {1289109600 -18000 0 EST} + {1299999600 -14400 1 EDT} + {1320559200 -18000 0 EST} + {1331449200 -14400 1 EDT} + {1352008800 -18000 0 EST} + {1362898800 -14400 1 EDT} + {1383458400 -18000 0 EST} + {1394348400 -14400 1 EDT} + {1414908000 -18000 0 EST} + {1425798000 -14400 1 EDT} + {1446357600 -18000 0 EST} + {1457852400 -14400 1 EDT} + {1478412000 -18000 0 EST} + {1489302000 -14400 1 EDT} + {1509861600 -18000 0 EST} + {1520751600 -14400 1 EDT} + {1541311200 -18000 0 EST} + {1552201200 -14400 1 EDT} + {1572760800 -18000 0 EST} + {1583650800 -14400 1 EDT} + {1604210400 -18000 0 EST} + {1615705200 -14400 1 EDT} + {1636264800 -18000 0 EST} + {1647154800 -14400 1 EDT} + {1667714400 -18000 0 EST} + {1678604400 -14400 1 EDT} + {1699164000 -18000 0 EST} + {1710054000 -14400 1 EDT} + {1730613600 -18000 0 EST} + {1741503600 -14400 1 EDT} + {1762063200 -18000 0 EST} + {1772953200 -14400 1 EDT} + {1793512800 -18000 0 EST} + {1805007600 -14400 1 EDT} + {1825567200 -18000 0 EST} + {1836457200 -14400 1 EDT} + {1857016800 -18000 0 EST} + {1867906800 -14400 1 EDT} + {1888466400 -18000 0 EST} + {1899356400 -14400 1 EDT} + {1919916000 -18000 0 EST} + {1930806000 -14400 1 EDT} + {1951365600 -18000 0 EST} + {1962860400 -14400 1 EDT} + {1983420000 -18000 0 EST} + {1994310000 -14400 1 EDT} + {2014869600 -18000 0 EST} + {2025759600 -14400 1 EDT} + {2046319200 -18000 0 EST} + {2057209200 -14400 1 EDT} + {2077768800 -18000 0 EST} + {2088658800 -14400 1 EDT} + {2109218400 -18000 0 EST} + {2120108400 -14400 1 EDT} + {2140668000 -18000 0 EST} + {2152162800 -14400 1 EDT} + {2172722400 -18000 0 EST} + {2183612400 -14400 1 EDT} + {2204172000 -18000 0 EST} + {2215062000 -14400 1 EDT} + {2235621600 -18000 0 EST} + {2246511600 -14400 1 EDT} + {2267071200 -18000 0 EST} + {2277961200 -14400 1 EDT} + {2298520800 -18000 0 EST} + {2309410800 -14400 1 EDT} + {2329970400 -18000 0 EST} + {2341465200 -14400 1 EDT} + {2362024800 -18000 0 EST} + {2372914800 -14400 1 EDT} + {2393474400 -18000 0 EST} + {2404364400 -14400 1 EDT} + {2424924000 -18000 0 EST} + {2435814000 -14400 1 EDT} + {2456373600 -18000 0 EST} + {2467263600 -14400 1 EDT} + {2487823200 -18000 0 EST} + {2499318000 -14400 1 EDT} + {2519877600 -18000 0 EST} + {2530767600 -14400 1 EDT} + {2551327200 -18000 0 EST} + {2562217200 -14400 1 EDT} + {2582776800 -18000 0 EST} + {2593666800 -14400 1 EDT} + {2614226400 -18000 0 EST} + {2625116400 -14400 1 EDT} + {2645676000 -18000 0 EST} + {2656566000 -14400 1 EDT} + {2677125600 -18000 0 EST} + {2688620400 -14400 1 EDT} + {2709180000 -18000 0 EST} + {2720070000 -14400 1 EDT} + {2740629600 -18000 0 EST} + {2751519600 -14400 1 EDT} + {2772079200 -18000 0 EST} + {2782969200 -14400 1 EDT} + {2803528800 -18000 0 EST} + {2814418800 -14400 1 EDT} + {2834978400 -18000 0 EST} + {2846473200 -14400 1 EDT} + {2867032800 -18000 0 EST} + {2877922800 -14400 1 EDT} + {2898482400 -18000 0 EST} + {2909372400 -14400 1 EDT} + {2929932000 -18000 0 EST} + {2940822000 -14400 1 EDT} + {2961381600 -18000 0 EST} + {2972271600 -14400 1 EDT} + {2992831200 -18000 0 EST} + {3003721200 -14400 1 EDT} + {3024280800 -18000 0 EST} + {3035775600 -14400 1 EDT} + {3056335200 -18000 0 EST} + {3067225200 -14400 1 EDT} + {3087784800 -18000 0 EST} + {3098674800 -14400 1 EDT} + {3119234400 -18000 0 EST} + {3130124400 -14400 1 EDT} + {3150684000 -18000 0 EST} + {3161574000 -14400 1 EDT} + {3182133600 -18000 0 EST} + {3193023600 -14400 1 EDT} + {3213583200 -18000 0 EST} + {3225078000 -14400 1 EDT} + {3245637600 -18000 0 EST} + {3256527600 -14400 1 EDT} + {3277087200 -18000 0 EST} + {3287977200 -14400 1 EDT} + {3308536800 -18000 0 EST} + {3319426800 -14400 1 EDT} + {3339986400 -18000 0 EST} + {3350876400 -14400 1 EDT} + {3371436000 -18000 0 EST} + {3382930800 -14400 1 EDT} + {3403490400 -18000 0 EST} + {3414380400 -14400 1 EDT} + {3434940000 -18000 0 EST} + {3445830000 -14400 1 EDT} + {3466389600 -18000 0 EST} + {3477279600 -14400 1 EDT} + {3497839200 -18000 0 EST} + {3508729200 -14400 1 EDT} + {3529288800 -18000 0 EST} + {3540178800 -14400 1 EDT} + {3560738400 -18000 0 EST} + {3572233200 -14400 1 EDT} + {3592792800 -18000 0 EST} + {3603682800 -14400 1 EDT} + {3624242400 -18000 0 EST} + {3635132400 -14400 1 EDT} + {3655692000 -18000 0 EST} + {3666582000 -14400 1 EDT} + {3687141600 -18000 0 EST} + {3698031600 -14400 1 EDT} + {3718591200 -18000 0 EST} + {3730086000 -14400 1 EDT} + {3750645600 -18000 0 EST} + {3761535600 -14400 1 EDT} + {3782095200 -18000 0 EST} + {3792985200 -14400 1 EDT} + {3813544800 -18000 0 EST} + {3824434800 -14400 1 EDT} + {3844994400 -18000 0 EST} + {3855884400 -14400 1 EDT} + {3876444000 -18000 0 EST} + {3887334000 -14400 1 EDT} + {3907893600 -18000 0 EST} + {3919388400 -14400 1 EDT} + {3939948000 -18000 0 EST} + {3950838000 -14400 1 EDT} + {3971397600 -18000 0 EST} + {3982287600 -14400 1 EDT} + {4002847200 -18000 0 EST} + {4013737200 -14400 1 EDT} + {4034296800 -18000 0 EST} + {4045186800 -14400 1 EDT} + {4065746400 -18000 0 EST} + {4076636400 -14400 1 EDT} + {4097196000 -18000 0 EST} } Index: library/tzdata/America/Indiana/Marengo ================================================================== --- library/tzdata/America/Indiana/Marengo +++ library/tzdata/America/Indiana/Marengo @@ -1,10 +1,10 @@ # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Indiana/Marengo) { {-9223372036854775808 -20723 0 LMT} - {-2717648077 -21600 0 CST} + {-2717647200 -21600 0 CST} {-1633276800 -18000 1 CDT} {-1615136400 -21600 0 CST} {-1601827200 -18000 1 CDT} {-1583686800 -21600 0 CST} {-880214400 -18000 1 CWT} @@ -42,6 +42,195 @@ {126687600 -18000 1 CDT} {152089200 -18000 0 EST} {162370800 -14400 1 EDT} {183535200 -18000 0 EST} {189320400 -18000 0 EST} + {1136091600 -18000 0 EST} + {1143961200 -14400 1 EDT} + {1162101600 -18000 0 EST} + {1173596400 -14400 1 EDT} + {1194156000 -18000 0 EST} + {1205046000 -14400 1 EDT} + {1225605600 -18000 0 EST} + {1236495600 -14400 1 EDT} + {1257055200 -18000 0 EST} + {1268550000 -14400 1 EDT} + {1289109600 -18000 0 EST} + {1299999600 -14400 1 EDT} + {1320559200 -18000 0 EST} + {1331449200 -14400 1 EDT} + {1352008800 -18000 0 EST} + {1362898800 -14400 1 EDT} + {1383458400 -18000 0 EST} + {1394348400 -14400 1 EDT} + {1414908000 -18000 0 EST} + {1425798000 -14400 1 EDT} + {1446357600 -18000 0 EST} + {1457852400 -14400 1 EDT} + {1478412000 -18000 0 EST} + {1489302000 -14400 1 EDT} + {1509861600 -18000 0 EST} + {1520751600 -14400 1 EDT} + {1541311200 -18000 0 EST} + {1552201200 -14400 1 EDT} + {1572760800 -18000 0 EST} + {1583650800 -14400 1 EDT} + {1604210400 -18000 0 EST} + {1615705200 -14400 1 EDT} + {1636264800 -18000 0 EST} + {1647154800 -14400 1 EDT} + {1667714400 -18000 0 EST} + {1678604400 -14400 1 EDT} + {1699164000 -18000 0 EST} + {1710054000 -14400 1 EDT} + {1730613600 -18000 0 EST} + {1741503600 -14400 1 EDT} + {1762063200 -18000 0 EST} + {1772953200 -14400 1 EDT} + {1793512800 -18000 0 EST} + {1805007600 -14400 1 EDT} + {1825567200 -18000 0 EST} + {1836457200 -14400 1 EDT} + {1857016800 -18000 0 EST} + {1867906800 -14400 1 EDT} + {1888466400 -18000 0 EST} + {1899356400 -14400 1 EDT} + {1919916000 -18000 0 EST} + {1930806000 -14400 1 EDT} + {1951365600 -18000 0 EST} + {1962860400 -14400 1 EDT} + {1983420000 -18000 0 EST} + {1994310000 -14400 1 EDT} + {2014869600 -18000 0 EST} + {2025759600 -14400 1 EDT} + {2046319200 -18000 0 EST} + {2057209200 -14400 1 EDT} + {2077768800 -18000 0 EST} + {2088658800 -14400 1 EDT} + {2109218400 -18000 0 EST} + {2120108400 -14400 1 EDT} + {2140668000 -18000 0 EST} + {2152162800 -14400 1 EDT} + {2172722400 -18000 0 EST} + {2183612400 -14400 1 EDT} + {2204172000 -18000 0 EST} + {2215062000 -14400 1 EDT} + {2235621600 -18000 0 EST} + {2246511600 -14400 1 EDT} + {2267071200 -18000 0 EST} + {2277961200 -14400 1 EDT} + {2298520800 -18000 0 EST} + {2309410800 -14400 1 EDT} + {2329970400 -18000 0 EST} + {2341465200 -14400 1 EDT} + {2362024800 -18000 0 EST} + {2372914800 -14400 1 EDT} + {2393474400 -18000 0 EST} + {2404364400 -14400 1 EDT} + {2424924000 -18000 0 EST} + {2435814000 -14400 1 EDT} + {2456373600 -18000 0 EST} + {2467263600 -14400 1 EDT} + {2487823200 -18000 0 EST} + {2499318000 -14400 1 EDT} + {2519877600 -18000 0 EST} + {2530767600 -14400 1 EDT} + {2551327200 -18000 0 EST} + {2562217200 -14400 1 EDT} + {2582776800 -18000 0 EST} + {2593666800 -14400 1 EDT} + {2614226400 -18000 0 EST} + {2625116400 -14400 1 EDT} + {2645676000 -18000 0 EST} + {2656566000 -14400 1 EDT} + {2677125600 -18000 0 EST} + {2688620400 -14400 1 EDT} + {2709180000 -18000 0 EST} + {2720070000 -14400 1 EDT} + {2740629600 -18000 0 EST} + {2751519600 -14400 1 EDT} + {2772079200 -18000 0 EST} + {2782969200 -14400 1 EDT} + {2803528800 -18000 0 EST} + {2814418800 -14400 1 EDT} + {2834978400 -18000 0 EST} + {2846473200 -14400 1 EDT} + {2867032800 -18000 0 EST} + {2877922800 -14400 1 EDT} + {2898482400 -18000 0 EST} + {2909372400 -14400 1 EDT} + {2929932000 -18000 0 EST} + {2940822000 -14400 1 EDT} + {2961381600 -18000 0 EST} + {2972271600 -14400 1 EDT} + {2992831200 -18000 0 EST} + {3003721200 -14400 1 EDT} + {3024280800 -18000 0 EST} + {3035775600 -14400 1 EDT} + {3056335200 -18000 0 EST} + {3067225200 -14400 1 EDT} + {3087784800 -18000 0 EST} + {3098674800 -14400 1 EDT} + {3119234400 -18000 0 EST} + {3130124400 -14400 1 EDT} + {3150684000 -18000 0 EST} + {3161574000 -14400 1 EDT} + {3182133600 -18000 0 EST} + {3193023600 -14400 1 EDT} + {3213583200 -18000 0 EST} + {3225078000 -14400 1 EDT} + {3245637600 -18000 0 EST} + {3256527600 -14400 1 EDT} + {3277087200 -18000 0 EST} + {3287977200 -14400 1 EDT} + {3308536800 -18000 0 EST} + {3319426800 -14400 1 EDT} + {3339986400 -18000 0 EST} + {3350876400 -14400 1 EDT} + {3371436000 -18000 0 EST} + {3382930800 -14400 1 EDT} + {3403490400 -18000 0 EST} + {3414380400 -14400 1 EDT} + {3434940000 -18000 0 EST} + {3445830000 -14400 1 EDT} + {3466389600 -18000 0 EST} + {3477279600 -14400 1 EDT} + {3497839200 -18000 0 EST} + {3508729200 -14400 1 EDT} + {3529288800 -18000 0 EST} + {3540178800 -14400 1 EDT} + {3560738400 -18000 0 EST} + {3572233200 -14400 1 EDT} + {3592792800 -18000 0 EST} + {3603682800 -14400 1 EDT} + {3624242400 -18000 0 EST} + {3635132400 -14400 1 EDT} + {3655692000 -18000 0 EST} + {3666582000 -14400 1 EDT} + {3687141600 -18000 0 EST} + {3698031600 -14400 1 EDT} + {3718591200 -18000 0 EST} + {3730086000 -14400 1 EDT} + {3750645600 -18000 0 EST} + {3761535600 -14400 1 EDT} + {3782095200 -18000 0 EST} + {3792985200 -14400 1 EDT} + {3813544800 -18000 0 EST} + {3824434800 -14400 1 EDT} + {3844994400 -18000 0 EST} + {3855884400 -14400 1 EDT} + {3876444000 -18000 0 EST} + {3887334000 -14400 1 EDT} + {3907893600 -18000 0 EST} + {3919388400 -14400 1 EDT} + {3939948000 -18000 0 EST} + {3950838000 -14400 1 EDT} + {3971397600 -18000 0 EST} + {3982287600 -14400 1 EDT} + {4002847200 -18000 0 EST} + {4013737200 -14400 1 EDT} + {4034296800 -18000 0 EST} + {4045186800 -14400 1 EDT} + {4065746400 -18000 0 EST} + {4076636400 -14400 1 EDT} + {4097196000 -18000 0 EST} } Index: library/tzdata/America/Indiana/Vevay ================================================================== --- library/tzdata/America/Indiana/Vevay +++ library/tzdata/America/Indiana/Vevay @@ -1,10 +1,10 @@ # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Indiana/Vevay) { {-9223372036854775808 -20416 0 LMT} - {-2717648384 -21600 0 CST} + {-2717647200 -21600 0 CST} {-1633276800 -18000 1 CDT} {-1615136400 -21600 0 CST} {-1601827200 -18000 1 CDT} {-1583686800 -21600 0 CST} {-880214400 -18000 1 CWT} @@ -19,6 +19,195 @@ {41410800 -14400 1 EDT} {57736800 -18000 0 EST} {73465200 -14400 1 EDT} {89186400 -18000 0 EST} {94712400 -18000 0 EST} + {1136091600 -18000 0 EST} + {1143961200 -14400 1 EDT} + {1162101600 -18000 0 EST} + {1173596400 -14400 1 EDT} + {1194156000 -18000 0 EST} + {1205046000 -14400 1 EDT} + {1225605600 -18000 0 EST} + {1236495600 -14400 1 EDT} + {1257055200 -18000 0 EST} + {1268550000 -14400 1 EDT} + {1289109600 -18000 0 EST} + {1299999600 -14400 1 EDT} + {1320559200 -18000 0 EST} + {1331449200 -14400 1 EDT} + {1352008800 -18000 0 EST} + {1362898800 -14400 1 EDT} + {1383458400 -18000 0 EST} + {1394348400 -14400 1 EDT} + {1414908000 -18000 0 EST} + {1425798000 -14400 1 EDT} + {1446357600 -18000 0 EST} + {1457852400 -14400 1 EDT} + {1478412000 -18000 0 EST} + {1489302000 -14400 1 EDT} + {1509861600 -18000 0 EST} + {1520751600 -14400 1 EDT} + {1541311200 -18000 0 EST} + {1552201200 -14400 1 EDT} + {1572760800 -18000 0 EST} + {1583650800 -14400 1 EDT} + {1604210400 -18000 0 EST} + {1615705200 -14400 1 EDT} + {1636264800 -18000 0 EST} + {1647154800 -14400 1 EDT} + {1667714400 -18000 0 EST} + {1678604400 -14400 1 EDT} + {1699164000 -18000 0 EST} + {1710054000 -14400 1 EDT} + {1730613600 -18000 0 EST} + {1741503600 -14400 1 EDT} + {1762063200 -18000 0 EST} + {1772953200 -14400 1 EDT} + {1793512800 -18000 0 EST} + {1805007600 -14400 1 EDT} + {1825567200 -18000 0 EST} + {1836457200 -14400 1 EDT} + {1857016800 -18000 0 EST} + {1867906800 -14400 1 EDT} + {1888466400 -18000 0 EST} + {1899356400 -14400 1 EDT} + {1919916000 -18000 0 EST} + {1930806000 -14400 1 EDT} + {1951365600 -18000 0 EST} + {1962860400 -14400 1 EDT} + {1983420000 -18000 0 EST} + {1994310000 -14400 1 EDT} + {2014869600 -18000 0 EST} + {2025759600 -14400 1 EDT} + {2046319200 -18000 0 EST} + {2057209200 -14400 1 EDT} + {2077768800 -18000 0 EST} + {2088658800 -14400 1 EDT} + {2109218400 -18000 0 EST} + {2120108400 -14400 1 EDT} + {2140668000 -18000 0 EST} + {2152162800 -14400 1 EDT} + {2172722400 -18000 0 EST} + {2183612400 -14400 1 EDT} + {2204172000 -18000 0 EST} + {2215062000 -14400 1 EDT} + {2235621600 -18000 0 EST} + {2246511600 -14400 1 EDT} + {2267071200 -18000 0 EST} + {2277961200 -14400 1 EDT} + {2298520800 -18000 0 EST} + {2309410800 -14400 1 EDT} + {2329970400 -18000 0 EST} + {2341465200 -14400 1 EDT} + {2362024800 -18000 0 EST} + {2372914800 -14400 1 EDT} + {2393474400 -18000 0 EST} + {2404364400 -14400 1 EDT} + {2424924000 -18000 0 EST} + {2435814000 -14400 1 EDT} + {2456373600 -18000 0 EST} + {2467263600 -14400 1 EDT} + {2487823200 -18000 0 EST} + {2499318000 -14400 1 EDT} + {2519877600 -18000 0 EST} + {2530767600 -14400 1 EDT} + {2551327200 -18000 0 EST} + {2562217200 -14400 1 EDT} + {2582776800 -18000 0 EST} + {2593666800 -14400 1 EDT} + {2614226400 -18000 0 EST} + {2625116400 -14400 1 EDT} + {2645676000 -18000 0 EST} + {2656566000 -14400 1 EDT} + {2677125600 -18000 0 EST} + {2688620400 -14400 1 EDT} + {2709180000 -18000 0 EST} + {2720070000 -14400 1 EDT} + {2740629600 -18000 0 EST} + {2751519600 -14400 1 EDT} + {2772079200 -18000 0 EST} + {2782969200 -14400 1 EDT} + {2803528800 -18000 0 EST} + {2814418800 -14400 1 EDT} + {2834978400 -18000 0 EST} + {2846473200 -14400 1 EDT} + {2867032800 -18000 0 EST} + {2877922800 -14400 1 EDT} + {2898482400 -18000 0 EST} + {2909372400 -14400 1 EDT} + {2929932000 -18000 0 EST} + {2940822000 -14400 1 EDT} + {2961381600 -18000 0 EST} + {2972271600 -14400 1 EDT} + {2992831200 -18000 0 EST} + {3003721200 -14400 1 EDT} + {3024280800 -18000 0 EST} + {3035775600 -14400 1 EDT} + {3056335200 -18000 0 EST} + {3067225200 -14400 1 EDT} + {3087784800 -18000 0 EST} + {3098674800 -14400 1 EDT} + {3119234400 -18000 0 EST} + {3130124400 -14400 1 EDT} + {3150684000 -18000 0 EST} + {3161574000 -14400 1 EDT} + {3182133600 -18000 0 EST} + {3193023600 -14400 1 EDT} + {3213583200 -18000 0 EST} + {3225078000 -14400 1 EDT} + {3245637600 -18000 0 EST} + {3256527600 -14400 1 EDT} + {3277087200 -18000 0 EST} + {3287977200 -14400 1 EDT} + {3308536800 -18000 0 EST} + {3319426800 -14400 1 EDT} + {3339986400 -18000 0 EST} + {3350876400 -14400 1 EDT} + {3371436000 -18000 0 EST} + {3382930800 -14400 1 EDT} + {3403490400 -18000 0 EST} + {3414380400 -14400 1 EDT} + {3434940000 -18000 0 EST} + {3445830000 -14400 1 EDT} + {3466389600 -18000 0 EST} + {3477279600 -14400 1 EDT} + {3497839200 -18000 0 EST} + {3508729200 -14400 1 EDT} + {3529288800 -18000 0 EST} + {3540178800 -14400 1 EDT} + {3560738400 -18000 0 EST} + {3572233200 -14400 1 EDT} + {3592792800 -18000 0 EST} + {3603682800 -14400 1 EDT} + {3624242400 -18000 0 EST} + {3635132400 -14400 1 EDT} + {3655692000 -18000 0 EST} + {3666582000 -14400 1 EDT} + {3687141600 -18000 0 EST} + {3698031600 -14400 1 EDT} + {3718591200 -18000 0 EST} + {3730086000 -14400 1 EDT} + {3750645600 -18000 0 EST} + {3761535600 -14400 1 EDT} + {3782095200 -18000 0 EST} + {3792985200 -14400 1 EDT} + {3813544800 -18000 0 EST} + {3824434800 -14400 1 EDT} + {3844994400 -18000 0 EST} + {3855884400 -14400 1 EDT} + {3876444000 -18000 0 EST} + {3887334000 -14400 1 EDT} + {3907893600 -18000 0 EST} + {3919388400 -14400 1 EDT} + {3939948000 -18000 0 EST} + {3950838000 -14400 1 EDT} + {3971397600 -18000 0 EST} + {3982287600 -14400 1 EDT} + {4002847200 -18000 0 EST} + {4013737200 -14400 1 EDT} + {4034296800 -18000 0 EST} + {4045186800 -14400 1 EDT} + {4065746400 -18000 0 EST} + {4076636400 -14400 1 EDT} + {4097196000 -18000 0 EST} } Index: library/tzdata/America/Indianapolis ================================================================== --- library/tzdata/America/Indianapolis +++ library/tzdata/America/Indianapolis @@ -1,45 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit - -set TZData(:America/Indianapolis) { - {-9223372036854775808 -20678 0 LMT} - {-2717648122 -21600 0 CST} - {-1633276800 -18000 1 CDT} - {-1615136400 -21600 0 CST} - {-1601827200 -18000 1 CDT} - {-1583686800 -21600 0 CST} - {-1577901600 -21600 0 CST} - {-900259200 -18000 1 CDT} - {-891795600 -21600 0 CST} - {-883591200 -21600 0 CST} - {-880214400 -18000 1 CWT} - {-769395600 -18000 1 CPT} - {-765392400 -21600 0 CST} - {-757360800 -21600 0 CST} - {-747244800 -18000 1 CDT} - {-733942800 -21600 0 CST} - {-715795200 -18000 1 CDT} - {-702493200 -21600 0 CST} - {-684345600 -18000 1 CDT} - {-671043600 -21600 0 CST} - {-652896000 -18000 1 CDT} - {-639594000 -21600 0 CST} - {-620841600 -18000 1 CDT} - {-608144400 -21600 0 CST} - {-589392000 -18000 1 CDT} - {-576090000 -21600 0 CST} - {-557942400 -18000 1 CDT} - {-544640400 -21600 0 CST} - {-526492800 -18000 1 CDT} - {-513190800 -21600 0 CST} - {-495043200 -18000 1 CDT} - {-481741200 -21600 0 CST} - {-463593600 -18000 0 EST} - {-386787600 -21600 0 CST} - {-368640000 -18000 0 EST} - {-31518000 -18000 0 EST} - {-21488400 -14400 1 EDT} - {-5767200 -18000 0 EST} - {9961200 -14400 1 EDT} - {25682400 -18000 0 EST} - {31554000 -18000 0 EST} -} +if {![info exists TZData(America/Indiana/Indianapolis)]} { + LoadTimeZoneFile America/Indiana/Indianapolis +} +set TZData(:America/Indianapolis) $TZData(:America/Indiana/Indianapolis) Index: library/tzdata/America/Juneau ================================================================== --- library/tzdata/America/Juneau +++ library/tzdata/America/Juneau @@ -84,192 +84,192 @@ {1099216800 -32400 0 AKST} {1112526000 -28800 1 AKDT} {1130666400 -32400 0 AKST} {1143975600 -28800 1 AKDT} {1162116000 -32400 0 AKST} - {1175425200 -28800 1 AKDT} - {1193565600 -32400 0 AKST} - {1207479600 -28800 1 AKDT} - {1225015200 -32400 0 AKST} - {1238929200 -28800 1 AKDT} - {1256464800 -32400 0 AKST} - {1270378800 -28800 1 AKDT} - {1288519200 -32400 0 AKST} - {1301828400 -28800 1 AKDT} - {1319968800 -32400 0 AKST} - {1333278000 -28800 1 AKDT} - {1351418400 -32400 0 AKST} - {1365332400 -28800 1 AKDT} - {1382868000 -32400 0 AKST} - {1396782000 -28800 1 AKDT} - {1414317600 -32400 0 AKST} - {1428231600 -28800 1 AKDT} - {1445767200 -32400 0 AKST} - {1459681200 -28800 1 AKDT} - {1477821600 -32400 0 AKST} - {1491130800 -28800 1 AKDT} - {1509271200 -32400 0 AKST} - {1522580400 -28800 1 AKDT} - {1540720800 -32400 0 AKST} - {1554634800 -28800 1 AKDT} - {1572170400 -32400 0 AKST} - {1586084400 -28800 1 AKDT} - {1603620000 -32400 0 AKST} - {1617534000 -28800 1 AKDT} - {1635674400 -32400 0 AKST} - {1648983600 -28800 1 AKDT} - {1667124000 -32400 0 AKST} - {1680433200 -28800 1 AKDT} - {1698573600 -32400 0 AKST} - {1712487600 -28800 1 AKDT} - {1730023200 -32400 0 AKST} - {1743937200 -28800 1 AKDT} - {1761472800 -32400 0 AKST} - {1775386800 -28800 1 AKDT} - {1792922400 -32400 0 AKST} - {1806836400 -28800 1 AKDT} - {1824976800 -32400 0 AKST} - {1838286000 -28800 1 AKDT} - {1856426400 -32400 0 AKST} - {1869735600 -28800 1 AKDT} - {1887876000 -32400 0 AKST} - {1901790000 -28800 1 AKDT} - {1919325600 -32400 0 AKST} - {1933239600 -28800 1 AKDT} - {1950775200 -32400 0 AKST} - {1964689200 -28800 1 AKDT} - {1982829600 -32400 0 AKST} - {1996138800 -28800 1 AKDT} - {2014279200 -32400 0 AKST} - {2027588400 -28800 1 AKDT} - {2045728800 -32400 0 AKST} - {2059038000 -28800 1 AKDT} - {2077178400 -32400 0 AKST} - {2091092400 -28800 1 AKDT} - {2108628000 -32400 0 AKST} - {2122542000 -28800 1 AKDT} - {2140077600 -32400 0 AKST} - {2153991600 -28800 1 AKDT} - {2172132000 -32400 0 AKST} - {2185441200 -28800 1 AKDT} - {2203581600 -32400 0 AKST} - {2216890800 -28800 1 AKDT} - {2235031200 -32400 0 AKST} - {2248945200 -28800 1 AKDT} - {2266480800 -32400 0 AKST} - {2280394800 -28800 1 AKDT} - {2297930400 -32400 0 AKST} - {2311844400 -28800 1 AKDT} - {2329380000 -32400 0 AKST} - {2343294000 -28800 1 AKDT} - {2361434400 -32400 0 AKST} - {2374743600 -28800 1 AKDT} - {2392884000 -32400 0 AKST} - {2406193200 -28800 1 AKDT} - {2424333600 -32400 0 AKST} - {2438247600 -28800 1 AKDT} - {2455783200 -32400 0 AKST} - {2469697200 -28800 1 AKDT} - {2487232800 -32400 0 AKST} - {2501146800 -28800 1 AKDT} - {2519287200 -32400 0 AKST} - {2532596400 -28800 1 AKDT} - {2550736800 -32400 0 AKST} - {2564046000 -28800 1 AKDT} - {2582186400 -32400 0 AKST} - {2596100400 -28800 1 AKDT} - {2613636000 -32400 0 AKST} - {2627550000 -28800 1 AKDT} - {2645085600 -32400 0 AKST} - {2658999600 -28800 1 AKDT} - {2676535200 -32400 0 AKST} - {2690449200 -28800 1 AKDT} - {2708589600 -32400 0 AKST} - {2721898800 -28800 1 AKDT} - {2740039200 -32400 0 AKST} - {2753348400 -28800 1 AKDT} - {2771488800 -32400 0 AKST} - {2785402800 -28800 1 AKDT} - {2802938400 -32400 0 AKST} - {2816852400 -28800 1 AKDT} - {2834388000 -32400 0 AKST} - {2848302000 -28800 1 AKDT} - {2866442400 -32400 0 AKST} - {2879751600 -28800 1 AKDT} - {2897892000 -32400 0 AKST} - {2911201200 -28800 1 AKDT} - {2929341600 -32400 0 AKST} - {2942650800 -28800 1 AKDT} - {2960791200 -32400 0 AKST} - {2974705200 -28800 1 AKDT} - {2992240800 -32400 0 AKST} - {3006154800 -28800 1 AKDT} - {3023690400 -32400 0 AKST} - {3037604400 -28800 1 AKDT} - {3055744800 -32400 0 AKST} - {3069054000 -28800 1 AKDT} - {3087194400 -32400 0 AKST} - {3100503600 -28800 1 AKDT} - {3118644000 -32400 0 AKST} - {3132558000 -28800 1 AKDT} - {3150093600 -32400 0 AKST} - {3164007600 -28800 1 AKDT} - {3181543200 -32400 0 AKST} - {3195457200 -28800 1 AKDT} - {3212992800 -32400 0 AKST} - {3226906800 -28800 1 AKDT} - {3245047200 -32400 0 AKST} - {3258356400 -28800 1 AKDT} - {3276496800 -32400 0 AKST} - {3289806000 -28800 1 AKDT} - {3307946400 -32400 0 AKST} - {3321860400 -28800 1 AKDT} - {3339396000 -32400 0 AKST} - {3353310000 -28800 1 AKDT} - {3370845600 -32400 0 AKST} - {3384759600 -28800 1 AKDT} - {3402900000 -32400 0 AKST} - {3416209200 -28800 1 AKDT} - {3434349600 -32400 0 AKST} - {3447658800 -28800 1 AKDT} - {3465799200 -32400 0 AKST} - {3479713200 -28800 1 AKDT} - {3497248800 -32400 0 AKST} - {3511162800 -28800 1 AKDT} - {3528698400 -32400 0 AKST} - {3542612400 -28800 1 AKDT} - {3560148000 -32400 0 AKST} - {3574062000 -28800 1 AKDT} - {3592202400 -32400 0 AKST} - {3605511600 -28800 1 AKDT} - {3623652000 -32400 0 AKST} - {3636961200 -28800 1 AKDT} - {3655101600 -32400 0 AKST} - {3669015600 -28800 1 AKDT} - {3686551200 -32400 0 AKST} - {3700465200 -28800 1 AKDT} - {3718000800 -32400 0 AKST} - {3731914800 -28800 1 AKDT} - {3750055200 -32400 0 AKST} - {3763364400 -28800 1 AKDT} - {3781504800 -32400 0 AKST} - {3794814000 -28800 1 AKDT} - {3812954400 -32400 0 AKST} - {3826263600 -28800 1 AKDT} - {3844404000 -32400 0 AKST} - {3858318000 -28800 1 AKDT} - {3875853600 -32400 0 AKST} - {3889767600 -28800 1 AKDT} - {3907303200 -32400 0 AKST} - {3921217200 -28800 1 AKDT} - {3939357600 -32400 0 AKST} - {3952666800 -28800 1 AKDT} - {3970807200 -32400 0 AKST} - {3984116400 -28800 1 AKDT} - {4002256800 -32400 0 AKST} - {4016170800 -28800 1 AKDT} - {4033706400 -32400 0 AKST} - {4047620400 -28800 1 AKDT} - {4065156000 -32400 0 AKST} - {4079070000 -28800 1 AKDT} - {4096605600 -32400 0 AKST} + {1173610800 -28800 1 AKDT} + {1194170400 -32400 0 AKST} + {1205060400 -28800 1 AKDT} + {1225620000 -32400 0 AKST} + {1236510000 -28800 1 AKDT} + {1257069600 -32400 0 AKST} + {1268564400 -28800 1 AKDT} + {1289124000 -32400 0 AKST} + {1300014000 -28800 1 AKDT} + {1320573600 -32400 0 AKST} + {1331463600 -28800 1 AKDT} + {1352023200 -32400 0 AKST} + {1362913200 -28800 1 AKDT} + {1383472800 -32400 0 AKST} + {1394362800 -28800 1 AKDT} + {1414922400 -32400 0 AKST} + {1425812400 -28800 1 AKDT} + {1446372000 -32400 0 AKST} + {1457866800 -28800 1 AKDT} + {1478426400 -32400 0 AKST} + {1489316400 -28800 1 AKDT} + {1509876000 -32400 0 AKST} + {1520766000 -28800 1 AKDT} + {1541325600 -32400 0 AKST} + {1552215600 -28800 1 AKDT} + {1572775200 -32400 0 AKST} + {1583665200 -28800 1 AKDT} + {1604224800 -32400 0 AKST} + {1615719600 -28800 1 AKDT} + {1636279200 -32400 0 AKST} + {1647169200 -28800 1 AKDT} + {1667728800 -32400 0 AKST} + {1678618800 -28800 1 AKDT} + {1699178400 -32400 0 AKST} + {1710068400 -28800 1 AKDT} + {1730628000 -32400 0 AKST} + {1741518000 -28800 1 AKDT} + {1762077600 -32400 0 AKST} + {1772967600 -28800 1 AKDT} + {1793527200 -32400 0 AKST} + {1805022000 -28800 1 AKDT} + {1825581600 -32400 0 AKST} + {1836471600 -28800 1 AKDT} + {1857031200 -32400 0 AKST} + {1867921200 -28800 1 AKDT} + {1888480800 -32400 0 AKST} + {1899370800 -28800 1 AKDT} + {1919930400 -32400 0 AKST} + {1930820400 -28800 1 AKDT} + {1951380000 -32400 0 AKST} + {1962874800 -28800 1 AKDT} + {1983434400 -32400 0 AKST} + {1994324400 -28800 1 AKDT} + {2014884000 -32400 0 AKST} + {2025774000 -28800 1 AKDT} + {2046333600 -32400 0 AKST} + {2057223600 -28800 1 AKDT} + {2077783200 -32400 0 AKST} + {2088673200 -28800 1 AKDT} + {2109232800 -32400 0 AKST} + {2120122800 -28800 1 AKDT} + {2140682400 -32400 0 AKST} + {2152177200 -28800 1 AKDT} + {2172736800 -32400 0 AKST} + {2183626800 -28800 1 AKDT} + {2204186400 -32400 0 AKST} + {2215076400 -28800 1 AKDT} + {2235636000 -32400 0 AKST} + {2246526000 -28800 1 AKDT} + {2267085600 -32400 0 AKST} + {2277975600 -28800 1 AKDT} + {2298535200 -32400 0 AKST} + {2309425200 -28800 1 AKDT} + {2329984800 -32400 0 AKST} + {2341479600 -28800 1 AKDT} + {2362039200 -32400 0 AKST} + {2372929200 -28800 1 AKDT} + {2393488800 -32400 0 AKST} + {2404378800 -28800 1 AKDT} + {2424938400 -32400 0 AKST} + {2435828400 -28800 1 AKDT} + {2456388000 -32400 0 AKST} + {2467278000 -28800 1 AKDT} + {2487837600 -32400 0 AKST} + {2499332400 -28800 1 AKDT} + {2519892000 -32400 0 AKST} + {2530782000 -28800 1 AKDT} + {2551341600 -32400 0 AKST} + {2562231600 -28800 1 AKDT} + {2582791200 -32400 0 AKST} + {2593681200 -28800 1 AKDT} + {2614240800 -32400 0 AKST} + {2625130800 -28800 1 AKDT} + {2645690400 -32400 0 AKST} + {2656580400 -28800 1 AKDT} + {2677140000 -32400 0 AKST} + {2688634800 -28800 1 AKDT} + {2709194400 -32400 0 AKST} + {2720084400 -28800 1 AKDT} + {2740644000 -32400 0 AKST} + {2751534000 -28800 1 AKDT} + {2772093600 -32400 0 AKST} + {2782983600 -28800 1 AKDT} + {2803543200 -32400 0 AKST} + {2814433200 -28800 1 AKDT} + {2834992800 -32400 0 AKST} + {2846487600 -28800 1 AKDT} + {2867047200 -32400 0 AKST} + {2877937200 -28800 1 AKDT} + {2898496800 -32400 0 AKST} + {2909386800 -28800 1 AKDT} + {2929946400 -32400 0 AKST} + {2940836400 -28800 1 AKDT} + {2961396000 -32400 0 AKST} + {2972286000 -28800 1 AKDT} + {2992845600 -32400 0 AKST} + {3003735600 -28800 1 AKDT} + {3024295200 -32400 0 AKST} + {3035790000 -28800 1 AKDT} + {3056349600 -32400 0 AKST} + {3067239600 -28800 1 AKDT} + {3087799200 -32400 0 AKST} + {3098689200 -28800 1 AKDT} + {3119248800 -32400 0 AKST} + {3130138800 -28800 1 AKDT} + {3150698400 -32400 0 AKST} + {3161588400 -28800 1 AKDT} + {3182148000 -32400 0 AKST} + {3193038000 -28800 1 AKDT} + {3213597600 -32400 0 AKST} + {3225092400 -28800 1 AKDT} + {3245652000 -32400 0 AKST} + {3256542000 -28800 1 AKDT} + {3277101600 -32400 0 AKST} + {3287991600 -28800 1 AKDT} + {3308551200 -32400 0 AKST} + {3319441200 -28800 1 AKDT} + {3340000800 -32400 0 AKST} + {3350890800 -28800 1 AKDT} + {3371450400 -32400 0 AKST} + {3382945200 -28800 1 AKDT} + {3403504800 -32400 0 AKST} + {3414394800 -28800 1 AKDT} + {3434954400 -32400 0 AKST} + {3445844400 -28800 1 AKDT} + {3466404000 -32400 0 AKST} + {3477294000 -28800 1 AKDT} + {3497853600 -32400 0 AKST} + {3508743600 -28800 1 AKDT} + {3529303200 -32400 0 AKST} + {3540193200 -28800 1 AKDT} + {3560752800 -32400 0 AKST} + {3572247600 -28800 1 AKDT} + {3592807200 -32400 0 AKST} + {3603697200 -28800 1 AKDT} + {3624256800 -32400 0 AKST} + {3635146800 -28800 1 AKDT} + {3655706400 -32400 0 AKST} + {3666596400 -28800 1 AKDT} + {3687156000 -32400 0 AKST} + {3698046000 -28800 1 AKDT} + {3718605600 -32400 0 AKST} + {3730100400 -28800 1 AKDT} + {3750660000 -32400 0 AKST} + {3761550000 -28800 1 AKDT} + {3782109600 -32400 0 AKST} + {3792999600 -28800 1 AKDT} + {3813559200 -32400 0 AKST} + {3824449200 -28800 1 AKDT} + {3845008800 -32400 0 AKST} + {3855898800 -28800 1 AKDT} + {3876458400 -32400 0 AKST} + {3887348400 -28800 1 AKDT} + {3907908000 -32400 0 AKST} + {3919402800 -28800 1 AKDT} + {3939962400 -32400 0 AKST} + {3950852400 -28800 1 AKDT} + {3971412000 -32400 0 AKST} + {3982302000 -28800 1 AKDT} + {4002861600 -32400 0 AKST} + {4013751600 -28800 1 AKDT} + {4034311200 -32400 0 AKST} + {4045201200 -28800 1 AKDT} + {4065760800 -32400 0 AKST} + {4076650800 -28800 1 AKDT} + {4097210400 -32400 0 AKST} } Index: library/tzdata/America/Kentucky/Louisville ================================================================== --- library/tzdata/America/Kentucky/Louisville +++ library/tzdata/America/Kentucky/Louisville @@ -1,5 +1,314 @@ # created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Louisville)]} { - LoadTimeZoneFile America/Louisville + +set TZData(:America/Kentucky/Louisville) { + {-9223372036854775808 -20582 0 LMT} + {-2717647200 -21600 0 CST} + {-1633276800 -18000 1 CDT} + {-1615136400 -21600 0 CST} + {-1601827200 -18000 1 CDT} + {-1583686800 -21600 0 CST} + {-1546279200 -21600 0 CST} + {-1535904000 -18000 1 CDT} + {-1525280400 -21600 0 CST} + {-905097600 -18000 1 CDT} + {-891795600 -21600 0 CST} + {-883591200 -21600 0 CST} + {-880214400 -18000 1 CWT} + {-769395600 -18000 1 CPT} + {-765392400 -21600 0 CST} + {-757360800 -21600 0 CST} + {-747244800 -18000 1 CDT} + {-744224400 -21600 0 CST} + {-715795200 -18000 1 CDT} + {-684349200 -18000 1 CDT} + {-652899600 -18000 1 CDT} + {-620845200 -18000 1 CDT} + {-608144400 -21600 0 CST} + {-589392000 -18000 1 CDT} + {-576090000 -21600 0 CST} + {-557942400 -18000 1 CDT} + {-544640400 -21600 0 CST} + {-526492800 -18000 1 CDT} + {-513190800 -21600 0 CST} + {-495043200 -18000 1 CDT} + {-481741200 -21600 0 CST} + {-463593600 -18000 1 CDT} + {-450291600 -21600 0 CST} + {-431539200 -18000 1 CDT} + {-415818000 -21600 0 CST} + {-400089600 -18000 1 CDT} + {-384368400 -21600 0 CST} + {-368640000 -18000 1 CDT} + {-352918800 -21600 0 CST} + {-337190400 -18000 1 CDT} + {-321469200 -21600 0 CST} + {-305740800 -18000 1 CDT} + {-289414800 -21600 0 CST} + {-273686400 -18000 1 CDT} + {-266432400 -18000 0 EST} + {-63140400 -18000 0 EST} + {-52938000 -14400 1 EDT} + {-37216800 -18000 0 EST} + {-21488400 -14400 1 EDT} + {-5767200 -18000 0 EST} + {9961200 -14400 1 EDT} + {25682400 -18000 0 EST} + {41410800 -14400 1 EDT} + {57736800 -18000 0 EST} + {73465200 -14400 1 EDT} + {89186400 -18000 0 EST} + {104914800 -14400 1 EDT} + {120636000 -18000 0 EST} + {126687600 -18000 1 CDT} + {152089200 -18000 0 EST} + {162370800 -14400 1 EDT} + {183535200 -18000 0 EST} + {199263600 -14400 1 EDT} + {215589600 -18000 0 EST} + {230713200 -14400 1 EDT} + {247039200 -18000 0 EST} + {262767600 -14400 1 EDT} + {278488800 -18000 0 EST} + {294217200 -14400 1 EDT} + {309938400 -18000 0 EST} + {325666800 -14400 1 EDT} + {341388000 -18000 0 EST} + {357116400 -14400 1 EDT} + {372837600 -18000 0 EST} + {388566000 -14400 1 EDT} + {404892000 -18000 0 EST} + {420015600 -14400 1 EDT} + {436341600 -18000 0 EST} + {452070000 -14400 1 EDT} + {467791200 -18000 0 EST} + {483519600 -14400 1 EDT} + {499240800 -18000 0 EST} + {514969200 -14400 1 EDT} + {530690400 -18000 0 EST} + {544604400 -14400 1 EDT} + {562140000 -18000 0 EST} + {576054000 -14400 1 EDT} + {594194400 -18000 0 EST} + {607503600 -14400 1 EDT} + {625644000 -18000 0 EST} + {638953200 -14400 1 EDT} + {657093600 -18000 0 EST} + {671007600 -14400 1 EDT} + {688543200 -18000 0 EST} + {702457200 -14400 1 EDT} + {719992800 -18000 0 EST} + {733906800 -14400 1 EDT} + {752047200 -18000 0 EST} + {765356400 -14400 1 EDT} + {783496800 -18000 0 EST} + {796806000 -14400 1 EDT} + {814946400 -18000 0 EST} + {828860400 -14400 1 EDT} + {846396000 -18000 0 EST} + {860310000 -14400 1 EDT} + {877845600 -18000 0 EST} + {891759600 -14400 1 EDT} + {909295200 -18000 0 EST} + {923209200 -14400 1 EDT} + {941349600 -18000 0 EST} + {954658800 -14400 1 EDT} + {972799200 -18000 0 EST} + {986108400 -14400 1 EDT} + {1004248800 -18000 0 EST} + {1018162800 -14400 1 EDT} + {1035698400 -18000 0 EST} + {1049612400 -14400 1 EDT} + {1067148000 -18000 0 EST} + {1081062000 -14400 1 EDT} + {1099202400 -18000 0 EST} + {1112511600 -14400 1 EDT} + {1130652000 -18000 0 EST} + {1143961200 -14400 1 EDT} + {1162101600 -18000 0 EST} + {1173596400 -14400 1 EDT} + {1194156000 -18000 0 EST} + {1205046000 -14400 1 EDT} + {1225605600 -18000 0 EST} + {1236495600 -14400 1 EDT} + {1257055200 -18000 0 EST} + {1268550000 -14400 1 EDT} + {1289109600 -18000 0 EST} + {1299999600 -14400 1 EDT} + {1320559200 -18000 0 EST} + {1331449200 -14400 1 EDT} + {1352008800 -18000 0 EST} + {1362898800 -14400 1 EDT} + {1383458400 -18000 0 EST} + {1394348400 -14400 1 EDT} + {1414908000 -18000 0 EST} + {1425798000 -14400 1 EDT} + {1446357600 -18000 0 EST} + {1457852400 -14400 1 EDT} + {1478412000 -18000 0 EST} + {1489302000 -14400 1 EDT} + {1509861600 -18000 0 EST} + {1520751600 -14400 1 EDT} + {1541311200 -18000 0 EST} + {1552201200 -14400 1 EDT} + {1572760800 -18000 0 EST} + {1583650800 -14400 1 EDT} + {1604210400 -18000 0 EST} + {1615705200 -14400 1 EDT} + {1636264800 -18000 0 EST} + {1647154800 -14400 1 EDT} + {1667714400 -18000 0 EST} + {1678604400 -14400 1 EDT} + {1699164000 -18000 0 EST} + {1710054000 -14400 1 EDT} + {1730613600 -18000 0 EST} + {1741503600 -14400 1 EDT} + {1762063200 -18000 0 EST} + {1772953200 -14400 1 EDT} + {1793512800 -18000 0 EST} + {1805007600 -14400 1 EDT} + {1825567200 -18000 0 EST} + {1836457200 -14400 1 EDT} + {1857016800 -18000 0 EST} + {1867906800 -14400 1 EDT} + {1888466400 -18000 0 EST} + {1899356400 -14400 1 EDT} + {1919916000 -18000 0 EST} + {1930806000 -14400 1 EDT} + {1951365600 -18000 0 EST} + {1962860400 -14400 1 EDT} + {1983420000 -18000 0 EST} + {1994310000 -14400 1 EDT} + {2014869600 -18000 0 EST} + {2025759600 -14400 1 EDT} + {2046319200 -18000 0 EST} + {2057209200 -14400 1 EDT} + {2077768800 -18000 0 EST} + {2088658800 -14400 1 EDT} + {2109218400 -18000 0 EST} + {2120108400 -14400 1 EDT} + {2140668000 -18000 0 EST} + {2152162800 -14400 1 EDT} + {2172722400 -18000 0 EST} + {2183612400 -14400 1 EDT} + {2204172000 -18000 0 EST} + {2215062000 -14400 1 EDT} + {2235621600 -18000 0 EST} + {2246511600 -14400 1 EDT} + {2267071200 -18000 0 EST} + {2277961200 -14400 1 EDT} + {2298520800 -18000 0 EST} + {2309410800 -14400 1 EDT} + {2329970400 -18000 0 EST} + {2341465200 -14400 1 EDT} + {2362024800 -18000 0 EST} + {2372914800 -14400 1 EDT} + {2393474400 -18000 0 EST} + {2404364400 -14400 1 EDT} + {2424924000 -18000 0 EST} + {2435814000 -14400 1 EDT} + {2456373600 -18000 0 EST} + {2467263600 -14400 1 EDT} + {2487823200 -18000 0 EST} + {2499318000 -14400 1 EDT} + {2519877600 -18000 0 EST} + {2530767600 -14400 1 EDT} + {2551327200 -18000 0 EST} + {2562217200 -14400 1 EDT} + {2582776800 -18000 0 EST} + {2593666800 -14400 1 EDT} + {2614226400 -18000 0 EST} + {2625116400 -14400 1 EDT} + {2645676000 -18000 0 EST} + {2656566000 -14400 1 EDT} + {2677125600 -18000 0 EST} + {2688620400 -14400 1 EDT} + {2709180000 -18000 0 EST} + {2720070000 -14400 1 EDT} + {2740629600 -18000 0 EST} + {2751519600 -14400 1 EDT} + {2772079200 -18000 0 EST} + {2782969200 -14400 1 EDT} + {2803528800 -18000 0 EST} + {2814418800 -14400 1 EDT} + {2834978400 -18000 0 EST} + {2846473200 -14400 1 EDT} + {2867032800 -18000 0 EST} + {2877922800 -14400 1 EDT} + {2898482400 -18000 0 EST} + {2909372400 -14400 1 EDT} + {2929932000 -18000 0 EST} + {2940822000 -14400 1 EDT} + {2961381600 -18000 0 EST} + {2972271600 -14400 1 EDT} + {2992831200 -18000 0 EST} + {3003721200 -14400 1 EDT} + {3024280800 -18000 0 EST} + {3035775600 -14400 1 EDT} + {3056335200 -18000 0 EST} + {3067225200 -14400 1 EDT} + {3087784800 -18000 0 EST} + {3098674800 -14400 1 EDT} + {3119234400 -18000 0 EST} + {3130124400 -14400 1 EDT} + {3150684000 -18000 0 EST} + {3161574000 -14400 1 EDT} + {3182133600 -18000 0 EST} + {3193023600 -14400 1 EDT} + {3213583200 -18000 0 EST} + {3225078000 -14400 1 EDT} + {3245637600 -18000 0 EST} + {3256527600 -14400 1 EDT} + {3277087200 -18000 0 EST} + {3287977200 -14400 1 EDT} + {3308536800 -18000 0 EST} + {3319426800 -14400 1 EDT} + {3339986400 -18000 0 EST} + {3350876400 -14400 1 EDT} + {3371436000 -18000 0 EST} + {3382930800 -14400 1 EDT} + {3403490400 -18000 0 EST} + {3414380400 -14400 1 EDT} + {3434940000 -18000 0 EST} + {3445830000 -14400 1 EDT} + {3466389600 -18000 0 EST} + {3477279600 -14400 1 EDT} + {3497839200 -18000 0 EST} + {3508729200 -14400 1 EDT} + {3529288800 -18000 0 EST} + {3540178800 -14400 1 EDT} + {3560738400 -18000 0 EST} + {3572233200 -14400 1 EDT} + {3592792800 -18000 0 EST} + {3603682800 -14400 1 EDT} + {3624242400 -18000 0 EST} + {3635132400 -14400 1 EDT} + {3655692000 -18000 0 EST} + {3666582000 -14400 1 EDT} + {3687141600 -18000 0 EST} + {3698031600 -14400 1 EDT} + {3718591200 -18000 0 EST} + {3730086000 -14400 1 EDT} + {3750645600 -18000 0 EST} + {3761535600 -14400 1 EDT} + {3782095200 -18000 0 EST} + {3792985200 -14400 1 EDT} + {3813544800 -18000 0 EST} + {3824434800 -14400 1 EDT} + {3844994400 -18000 0 EST} + {3855884400 -14400 1 EDT} + {3876444000 -18000 0 EST} + {3887334000 -14400 1 EDT} + {3907893600 -18000 0 EST} + {3919388400 -14400 1 EDT} + {3939948000 -18000 0 EST} + {3950838000 -14400 1 EDT} + {3971397600 -18000 0 EST} + {3982287600 -14400 1 EDT} + {4002847200 -18000 0 EST} + {4013737200 -14400 1 EDT} + {4034296800 -18000 0 EST} + {4045186800 -14400 1 EDT} + {4065746400 -18000 0 EST} + {4076636400 -14400 1 EDT} + {4097196000 -18000 0 EST} } -set TZData(:America/Kentucky/Louisville) $TZData(:America/Louisville) Index: library/tzdata/America/Kentucky/Monticello ================================================================== --- library/tzdata/America/Kentucky/Monticello +++ library/tzdata/America/Kentucky/Monticello @@ -1,10 +1,10 @@ # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Kentucky/Monticello) { {-9223372036854775808 -20364 0 LMT} - {-2717648436 -21600 0 CST} + {-2717647200 -21600 0 CST} {-1633276800 -18000 1 CDT} {-1615136400 -21600 0 CST} {-1601827200 -18000 1 CDT} {-1583686800 -21600 0 CST} {-880214400 -18000 1 CWT} @@ -88,192 +88,192 @@ {1099202400 -18000 0 EST} {1112511600 -14400 1 EDT} {1130652000 -18000 0 EST} {1143961200 -14400 1 EDT} {1162101600 -18000 0 EST} - {1175410800 -14400 1 EDT} - {1193551200 -18000 0 EST} - {1207465200 -14400 1 EDT} - {1225000800 -18000 0 EST} - {1238914800 -14400 1 EDT} - {1256450400 -18000 0 EST} - {1270364400 -14400 1 EDT} - {1288504800 -18000 0 EST} - {1301814000 -14400 1 EDT} - {1319954400 -18000 0 EST} - {1333263600 -14400 1 EDT} - {1351404000 -18000 0 EST} - {1365318000 -14400 1 EDT} - {1382853600 -18000 0 EST} - {1396767600 -14400 1 EDT} - {1414303200 -18000 0 EST} - {1428217200 -14400 1 EDT} - {1445752800 -18000 0 EST} - {1459666800 -14400 1 EDT} - {1477807200 -18000 0 EST} - {1491116400 -14400 1 EDT} - {1509256800 -18000 0 EST} - {1522566000 -14400 1 EDT} - {1540706400 -18000 0 EST} - {1554620400 -14400 1 EDT} - {1572156000 -18000 0 EST} - {1586070000 -14400 1 EDT} - {1603605600 -18000 0 EST} - {1617519600 -14400 1 EDT} - {1635660000 -18000 0 EST} - {1648969200 -14400 1 EDT} - {1667109600 -18000 0 EST} - {1680418800 -14400 1 EDT} - {1698559200 -18000 0 EST} - {1712473200 -14400 1 EDT} - {1730008800 -18000 0 EST} - {1743922800 -14400 1 EDT} - {1761458400 -18000 0 EST} - {1775372400 -14400 1 EDT} - {1792908000 -18000 0 EST} - {1806822000 -14400 1 EDT} - {1824962400 -18000 0 EST} - {1838271600 -14400 1 EDT} - {1856412000 -18000 0 EST} - {1869721200 -14400 1 EDT} - {1887861600 -18000 0 EST} - {1901775600 -14400 1 EDT} - {1919311200 -18000 0 EST} - {1933225200 -14400 1 EDT} - {1950760800 -18000 0 EST} - {1964674800 -14400 1 EDT} - {1982815200 -18000 0 EST} - {1996124400 -14400 1 EDT} - {2014264800 -18000 0 EST} - {2027574000 -14400 1 EDT} - {2045714400 -18000 0 EST} - {2059023600 -14400 1 EDT} - {2077164000 -18000 0 EST} - {2091078000 -14400 1 EDT} - {2108613600 -18000 0 EST} - {2122527600 -14400 1 EDT} - {2140063200 -18000 0 EST} - {2153977200 -14400 1 EDT} - {2172117600 -18000 0 EST} - {2185426800 -14400 1 EDT} - {2203567200 -18000 0 EST} - {2216876400 -14400 1 EDT} - {2235016800 -18000 0 EST} - {2248930800 -14400 1 EDT} - {2266466400 -18000 0 EST} - {2280380400 -14400 1 EDT} - {2297916000 -18000 0 EST} - {2311830000 -14400 1 EDT} - {2329365600 -18000 0 EST} - {2343279600 -14400 1 EDT} - {2361420000 -18000 0 EST} - {2374729200 -14400 1 EDT} - {2392869600 -18000 0 EST} - {2406178800 -14400 1 EDT} - {2424319200 -18000 0 EST} - {2438233200 -14400 1 EDT} - {2455768800 -18000 0 EST} - {2469682800 -14400 1 EDT} - {2487218400 -18000 0 EST} - {2501132400 -14400 1 EDT} - {2519272800 -18000 0 EST} - {2532582000 -14400 1 EDT} - {2550722400 -18000 0 EST} - {2564031600 -14400 1 EDT} - {2582172000 -18000 0 EST} - {2596086000 -14400 1 EDT} - {2613621600 -18000 0 EST} - {2627535600 -14400 1 EDT} - {2645071200 -18000 0 EST} - {2658985200 -14400 1 EDT} - {2676520800 -18000 0 EST} - {2690434800 -14400 1 EDT} - {2708575200 -18000 0 EST} - {2721884400 -14400 1 EDT} - {2740024800 -18000 0 EST} - {2753334000 -14400 1 EDT} - {2771474400 -18000 0 EST} - {2785388400 -14400 1 EDT} - {2802924000 -18000 0 EST} - {2816838000 -14400 1 EDT} - {2834373600 -18000 0 EST} - {2848287600 -14400 1 EDT} - {2866428000 -18000 0 EST} - {2879737200 -14400 1 EDT} - {2897877600 -18000 0 EST} - {2911186800 -14400 1 EDT} - {2929327200 -18000 0 EST} - {2942636400 -14400 1 EDT} - {2960776800 -18000 0 EST} - {2974690800 -14400 1 EDT} - {2992226400 -18000 0 EST} - {3006140400 -14400 1 EDT} - {3023676000 -18000 0 EST} - {3037590000 -14400 1 EDT} - {3055730400 -18000 0 EST} - {3069039600 -14400 1 EDT} - {3087180000 -18000 0 EST} - {3100489200 -14400 1 EDT} - {3118629600 -18000 0 EST} - {3132543600 -14400 1 EDT} - {3150079200 -18000 0 EST} - {3163993200 -14400 1 EDT} - {3181528800 -18000 0 EST} - {3195442800 -14400 1 EDT} - {3212978400 -18000 0 EST} - {3226892400 -14400 1 EDT} - {3245032800 -18000 0 EST} - {3258342000 -14400 1 EDT} - {3276482400 -18000 0 EST} - {3289791600 -14400 1 EDT} - {3307932000 -18000 0 EST} - {3321846000 -14400 1 EDT} - {3339381600 -18000 0 EST} - {3353295600 -14400 1 EDT} - {3370831200 -18000 0 EST} - {3384745200 -14400 1 EDT} - {3402885600 -18000 0 EST} - {3416194800 -14400 1 EDT} - {3434335200 -18000 0 EST} - {3447644400 -14400 1 EDT} - {3465784800 -18000 0 EST} - {3479698800 -14400 1 EDT} - {3497234400 -18000 0 EST} - {3511148400 -14400 1 EDT} - {3528684000 -18000 0 EST} - {3542598000 -14400 1 EDT} - {3560133600 -18000 0 EST} - {3574047600 -14400 1 EDT} - {3592188000 -18000 0 EST} - {3605497200 -14400 1 EDT} - {3623637600 -18000 0 EST} - {3636946800 -14400 1 EDT} - {3655087200 -18000 0 EST} - {3669001200 -14400 1 EDT} - {3686536800 -18000 0 EST} - {3700450800 -14400 1 EDT} - {3717986400 -18000 0 EST} - {3731900400 -14400 1 EDT} - {3750040800 -18000 0 EST} - {3763350000 -14400 1 EDT} - {3781490400 -18000 0 EST} - {3794799600 -14400 1 EDT} - {3812940000 -18000 0 EST} - {3826249200 -14400 1 EDT} - {3844389600 -18000 0 EST} - {3858303600 -14400 1 EDT} - {3875839200 -18000 0 EST} - {3889753200 -14400 1 EDT} - {3907288800 -18000 0 EST} - {3921202800 -14400 1 EDT} - {3939343200 -18000 0 EST} - {3952652400 -14400 1 EDT} - {3970792800 -18000 0 EST} - {3984102000 -14400 1 EDT} - {4002242400 -18000 0 EST} - {4016156400 -14400 1 EDT} - {4033692000 -18000 0 EST} - {4047606000 -14400 1 EDT} - {4065141600 -18000 0 EST} - {4079055600 -14400 1 EDT} - {4096591200 -18000 0 EST} + {1173596400 -14400 1 EDT} + {1194156000 -18000 0 EST} + {1205046000 -14400 1 EDT} + {1225605600 -18000 0 EST} + {1236495600 -14400 1 EDT} + {1257055200 -18000 0 EST} + {1268550000 -14400 1 EDT} + {1289109600 -18000 0 EST} + {1299999600 -14400 1 EDT} + {1320559200 -18000 0 EST} + {1331449200 -14400 1 EDT} + {1352008800 -18000 0 EST} + {1362898800 -14400 1 EDT} + {1383458400 -18000 0 EST} + {1394348400 -14400 1 EDT} + {1414908000 -18000 0 EST} + {1425798000 -14400 1 EDT} + {1446357600 -18000 0 EST} + {1457852400 -14400 1 EDT} + {1478412000 -18000 0 EST} + {1489302000 -14400 1 EDT} + {1509861600 -18000 0 EST} + {1520751600 -14400 1 EDT} + {1541311200 -18000 0 EST} + {1552201200 -14400 1 EDT} + {1572760800 -18000 0 EST} + {1583650800 -14400 1 EDT} + {1604210400 -18000 0 EST} + {1615705200 -14400 1 EDT} + {1636264800 -18000 0 EST} + {1647154800 -14400 1 EDT} + {1667714400 -18000 0 EST} + {1678604400 -14400 1 EDT} + {1699164000 -18000 0 EST} + {1710054000 -14400 1 EDT} + {1730613600 -18000 0 EST} + {1741503600 -14400 1 EDT} + {1762063200 -18000 0 EST} + {1772953200 -14400 1 EDT} + {1793512800 -18000 0 EST} + {1805007600 -14400 1 EDT} + {1825567200 -18000 0 EST} + {1836457200 -14400 1 EDT} + {1857016800 -18000 0 EST} + {1867906800 -14400 1 EDT} + {1888466400 -18000 0 EST} + {1899356400 -14400 1 EDT} + {1919916000 -18000 0 EST} + {1930806000 -14400 1 EDT} + {1951365600 -18000 0 EST} + {1962860400 -14400 1 EDT} + {1983420000 -18000 0 EST} + {1994310000 -14400 1 EDT} + {2014869600 -18000 0 EST} + {2025759600 -14400 1 EDT} + {2046319200 -18000 0 EST} + {2057209200 -14400 1 EDT} + {2077768800 -18000 0 EST} + {2088658800 -14400 1 EDT} + {2109218400 -18000 0 EST} + {2120108400 -14400 1 EDT} + {2140668000 -18000 0 EST} + {2152162800 -14400 1 EDT} + {2172722400 -18000 0 EST} + {2183612400 -14400 1 EDT} + {2204172000 -18000 0 EST} + {2215062000 -14400 1 EDT} + {2235621600 -18000 0 EST} + {2246511600 -14400 1 EDT} + {2267071200 -18000 0 EST} + {2277961200 -14400 1 EDT} + {2298520800 -18000 0 EST} + {2309410800 -14400 1 EDT} + {2329970400 -18000 0 EST} + {2341465200 -14400 1 EDT} + {2362024800 -18000 0 EST} + {2372914800 -14400 1 EDT} + {2393474400 -18000 0 EST} + {2404364400 -14400 1 EDT} + {2424924000 -18000 0 EST} + {2435814000 -14400 1 EDT} + {2456373600 -18000 0 EST} + {2467263600 -14400 1 EDT} + {2487823200 -18000 0 EST} + {2499318000 -14400 1 EDT} + {2519877600 -18000 0 EST} + {2530767600 -14400 1 EDT} + {2551327200 -18000 0 EST} + {2562217200 -14400 1 EDT} + {2582776800 -18000 0 EST} + {2593666800 -14400 1 EDT} + {2614226400 -18000 0 EST} + {2625116400 -14400 1 EDT} + {2645676000 -18000 0 EST} + {2656566000 -14400 1 EDT} + {2677125600 -18000 0 EST} + {2688620400 -14400 1 EDT} + {2709180000 -18000 0 EST} + {2720070000 -14400 1 EDT} + {2740629600 -18000 0 EST} + {2751519600 -14400 1 EDT} + {2772079200 -18000 0 EST} + {2782969200 -14400 1 EDT} + {2803528800 -18000 0 EST} + {2814418800 -14400 1 EDT} + {2834978400 -18000 0 EST} + {2846473200 -14400 1 EDT} + {2867032800 -18000 0 EST} + {2877922800 -14400 1 EDT} + {2898482400 -18000 0 EST} + {2909372400 -14400 1 EDT} + {2929932000 -18000 0 EST} + {2940822000 -14400 1 EDT} + {2961381600 -18000 0 EST} + {2972271600 -14400 1 EDT} + {2992831200 -18000 0 EST} + {3003721200 -14400 1 EDT} + {3024280800 -18000 0 EST} + {3035775600 -14400 1 EDT} + {3056335200 -18000 0 EST} + {3067225200 -14400 1 EDT} + {3087784800 -18000 0 EST} + {3098674800 -14400 1 EDT} + {3119234400 -18000 0 EST} + {3130124400 -14400 1 EDT} + {3150684000 -18000 0 EST} + {3161574000 -14400 1 EDT} + {3182133600 -18000 0 EST} + {3193023600 -14400 1 EDT} + {3213583200 -18000 0 EST} + {3225078000 -14400 1 EDT} + {3245637600 -18000 0 EST} + {3256527600 -14400 1 EDT} + {3277087200 -18000 0 EST} + {3287977200 -14400 1 EDT} + {3308536800 -18000 0 EST} + {3319426800 -14400 1 EDT} + {3339986400 -18000 0 EST} + {3350876400 -14400 1 EDT} + {3371436000 -18000 0 EST} + {3382930800 -14400 1 EDT} + {3403490400 -18000 0 EST} + {3414380400 -14400 1 EDT} + {3434940000 -18000 0 EST} + {3445830000 -14400 1 EDT} + {3466389600 -18000 0 EST} + {3477279600 -14400 1 EDT} + {3497839200 -18000 0 EST} + {3508729200 -14400 1 EDT} + {3529288800 -18000 0 EST} + {3540178800 -14400 1 EDT} + {3560738400 -18000 0 EST} + {3572233200 -14400 1 EDT} + {3592792800 -18000 0 EST} + {3603682800 -14400 1 EDT} + {3624242400 -18000 0 EST} + {3635132400 -14400 1 EDT} + {3655692000 -18000 0 EST} + {3666582000 -14400 1 EDT} + {3687141600 -18000 0 EST} + {3698031600 -14400 1 EDT} + {3718591200 -18000 0 EST} + {3730086000 -14400 1 EDT} + {3750645600 -18000 0 EST} + {3761535600 -14400 1 EDT} + {3782095200 -18000 0 EST} + {3792985200 -14400 1 EDT} + {3813544800 -18000 0 EST} + {3824434800 -14400 1 EDT} + {3844994400 -18000 0 EST} + {3855884400 -14400 1 EDT} + {3876444000 -18000 0 EST} + {3887334000 -14400 1 EDT} + {3907893600 -18000 0 EST} + {3919388400 -14400 1 EDT} + {3939948000 -18000 0 EST} + {3950838000 -14400 1 EDT} + {3971397600 -18000 0 EST} + {3982287600 -14400 1 EDT} + {4002847200 -18000 0 EST} + {4013737200 -14400 1 EDT} + {4034296800 -18000 0 EST} + {4045186800 -14400 1 EDT} + {4065746400 -18000 0 EST} + {4076636400 -14400 1 EDT} + {4097196000 -18000 0 EST} } Index: library/tzdata/America/Los_Angeles ================================================================== --- library/tzdata/America/Los_Angeles +++ library/tzdata/America/Los_Angeles @@ -1,10 +1,10 @@ # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Los_Angeles) { {-9223372036854775808 -28378 0 LMT} - {-2717640422 -28800 0 PST} + {-2717640000 -28800 0 PST} {-1633269600 -25200 1 PDT} {-1615129200 -28800 0 PST} {-1601820000 -25200 1 PDT} {-1583679600 -28800 0 PST} {-880207200 -25200 1 PWT} @@ -126,192 +126,192 @@ {1099213200 -28800 0 PST} {1112522400 -25200 1 PDT} {1130662800 -28800 0 PST} {1143972000 -25200 1 PDT} {1162112400 -28800 0 PST} - {1175421600 -25200 1 PDT} - {1193562000 -28800 0 PST} - {1207476000 -25200 1 PDT} - {1225011600 -28800 0 PST} - {1238925600 -25200 1 PDT} - {1256461200 -28800 0 PST} - {1270375200 -25200 1 PDT} - {1288515600 -28800 0 PST} - {1301824800 -25200 1 PDT} - {1319965200 -28800 0 PST} - {1333274400 -25200 1 PDT} - {1351414800 -28800 0 PST} - {1365328800 -25200 1 PDT} - {1382864400 -28800 0 PST} - {1396778400 -25200 1 PDT} - {1414314000 -28800 0 PST} - {1428228000 -25200 1 PDT} - {1445763600 -28800 0 PST} - {1459677600 -25200 1 PDT} - {1477818000 -28800 0 PST} - {1491127200 -25200 1 PDT} - {1509267600 -28800 0 PST} - {1522576800 -25200 1 PDT} - {1540717200 -28800 0 PST} - {1554631200 -25200 1 PDT} - {1572166800 -28800 0 PST} - {1586080800 -25200 1 PDT} - {1603616400 -28800 0 PST} - {1617530400 -25200 1 PDT} - {1635670800 -28800 0 PST} - {1648980000 -25200 1 PDT} - {1667120400 -28800 0 PST} - {1680429600 -25200 1 PDT} - {1698570000 -28800 0 PST} - {1712484000 -25200 1 PDT} - {1730019600 -28800 0 PST} - {1743933600 -25200 1 PDT} - {1761469200 -28800 0 PST} - {1775383200 -25200 1 PDT} - {1792918800 -28800 0 PST} - {1806832800 -25200 1 PDT} - {1824973200 -28800 0 PST} - {1838282400 -25200 1 PDT} - {1856422800 -28800 0 PST} - {1869732000 -25200 1 PDT} - {1887872400 -28800 0 PST} - {1901786400 -25200 1 PDT} - {1919322000 -28800 0 PST} - {1933236000 -25200 1 PDT} - {1950771600 -28800 0 PST} - {1964685600 -25200 1 PDT} - {1982826000 -28800 0 PST} - {1996135200 -25200 1 PDT} - {2014275600 -28800 0 PST} - {2027584800 -25200 1 PDT} - {2045725200 -28800 0 PST} - {2059034400 -25200 1 PDT} - {2077174800 -28800 0 PST} - {2091088800 -25200 1 PDT} - {2108624400 -28800 0 PST} - {2122538400 -25200 1 PDT} - {2140074000 -28800 0 PST} - {2153988000 -25200 1 PDT} - {2172128400 -28800 0 PST} - {2185437600 -25200 1 PDT} - {2203578000 -28800 0 PST} - {2216887200 -25200 1 PDT} - {2235027600 -28800 0 PST} - {2248941600 -25200 1 PDT} - {2266477200 -28800 0 PST} - {2280391200 -25200 1 PDT} - {2297926800 -28800 0 PST} - {2311840800 -25200 1 PDT} - {2329376400 -28800 0 PST} - {2343290400 -25200 1 PDT} - {2361430800 -28800 0 PST} - {2374740000 -25200 1 PDT} - {2392880400 -28800 0 PST} - {2406189600 -25200 1 PDT} - {2424330000 -28800 0 PST} - {2438244000 -25200 1 PDT} - {2455779600 -28800 0 PST} - {2469693600 -25200 1 PDT} - {2487229200 -28800 0 PST} - {2501143200 -25200 1 PDT} - {2519283600 -28800 0 PST} - {2532592800 -25200 1 PDT} - {2550733200 -28800 0 PST} - {2564042400 -25200 1 PDT} - {2582182800 -28800 0 PST} - {2596096800 -25200 1 PDT} - {2613632400 -28800 0 PST} - {2627546400 -25200 1 PDT} - {2645082000 -28800 0 PST} - {2658996000 -25200 1 PDT} - {2676531600 -28800 0 PST} - {2690445600 -25200 1 PDT} - {2708586000 -28800 0 PST} - {2721895200 -25200 1 PDT} - {2740035600 -28800 0 PST} - {2753344800 -25200 1 PDT} - {2771485200 -28800 0 PST} - {2785399200 -25200 1 PDT} - {2802934800 -28800 0 PST} - {2816848800 -25200 1 PDT} - {2834384400 -28800 0 PST} - {2848298400 -25200 1 PDT} - {2866438800 -28800 0 PST} - {2879748000 -25200 1 PDT} - {2897888400 -28800 0 PST} - {2911197600 -25200 1 PDT} - {2929338000 -28800 0 PST} - {2942647200 -25200 1 PDT} - {2960787600 -28800 0 PST} - {2974701600 -25200 1 PDT} - {2992237200 -28800 0 PST} - {3006151200 -25200 1 PDT} - {3023686800 -28800 0 PST} - {3037600800 -25200 1 PDT} - {3055741200 -28800 0 PST} - {3069050400 -25200 1 PDT} - {3087190800 -28800 0 PST} - {3100500000 -25200 1 PDT} - {3118640400 -28800 0 PST} - {3132554400 -25200 1 PDT} - {3150090000 -28800 0 PST} - {3164004000 -25200 1 PDT} - {3181539600 -28800 0 PST} - {3195453600 -25200 1 PDT} - {3212989200 -28800 0 PST} - {3226903200 -25200 1 PDT} - {3245043600 -28800 0 PST} - {3258352800 -25200 1 PDT} - {3276493200 -28800 0 PST} - {3289802400 -25200 1 PDT} - {3307942800 -28800 0 PST} - {3321856800 -25200 1 PDT} - {3339392400 -28800 0 PST} - {3353306400 -25200 1 PDT} - {3370842000 -28800 0 PST} - {3384756000 -25200 1 PDT} - {3402896400 -28800 0 PST} - {3416205600 -25200 1 PDT} - {3434346000 -28800 0 PST} - {3447655200 -25200 1 PDT} - {3465795600 -28800 0 PST} - {3479709600 -25200 1 PDT} - {3497245200 -28800 0 PST} - {3511159200 -25200 1 PDT} - {3528694800 -28800 0 PST} - {3542608800 -25200 1 PDT} - {3560144400 -28800 0 PST} - {3574058400 -25200 1 PDT} - {3592198800 -28800 0 PST} - {3605508000 -25200 1 PDT} - {3623648400 -28800 0 PST} - {3636957600 -25200 1 PDT} - {3655098000 -28800 0 PST} - {3669012000 -25200 1 PDT} - {3686547600 -28800 0 PST} - {3700461600 -25200 1 PDT} - {3717997200 -28800 0 PST} - {3731911200 -25200 1 PDT} - {3750051600 -28800 0 PST} - {3763360800 -25200 1 PDT} - {3781501200 -28800 0 PST} - {3794810400 -25200 1 PDT} - {3812950800 -28800 0 PST} - {3826260000 -25200 1 PDT} - {3844400400 -28800 0 PST} - {3858314400 -25200 1 PDT} - {3875850000 -28800 0 PST} - {3889764000 -25200 1 PDT} - {3907299600 -28800 0 PST} - {3921213600 -25200 1 PDT} - {3939354000 -28800 0 PST} - {3952663200 -25200 1 PDT} - {3970803600 -28800 0 PST} - {3984112800 -25200 1 PDT} - {4002253200 -28800 0 PST} - {4016167200 -25200 1 PDT} - {4033702800 -28800 0 PST} - {4047616800 -25200 1 PDT} - {4065152400 -28800 0 PST} - {4079066400 -25200 1 PDT} - {4096602000 -28800 0 PST} + {1173607200 -25200 1 PDT} + {1194166800 -28800 0 PST} + {1205056800 -25200 1 PDT} + {1225616400 -28800 0 PST} + {1236506400 -25200 1 PDT} + {1257066000 -28800 0 PST} + {1268560800 -25200 1 PDT} + {1289120400 -28800 0 PST} + {1300010400 -25200 1 PDT} + {1320570000 -28800 0 PST} + {1331460000 -25200 1 PDT} + {1352019600 -28800 0 PST} + {1362909600 -25200 1 PDT} + {1383469200 -28800 0 PST} + {1394359200 -25200 1 PDT} + {1414918800 -28800 0 PST} + {1425808800 -25200 1 PDT} + {1446368400 -28800 0 PST} + {1457863200 -25200 1 PDT} + {1478422800 -28800 0 PST} + {1489312800 -25200 1 PDT} + {1509872400 -28800 0 PST} + {1520762400 -25200 1 PDT} + {1541322000 -28800 0 PST} + {1552212000 -25200 1 PDT} + {1572771600 -28800 0 PST} + {1583661600 -25200 1 PDT} + {1604221200 -28800 0 PST} + {1615716000 -25200 1 PDT} + {1636275600 -28800 0 PST} + {1647165600 -25200 1 PDT} + {1667725200 -28800 0 PST} + {1678615200 -25200 1 PDT} + {1699174800 -28800 0 PST} + {1710064800 -25200 1 PDT} + {1730624400 -28800 0 PST} + {1741514400 -25200 1 PDT} + {1762074000 -28800 0 PST} + {1772964000 -25200 1 PDT} + {1793523600 -28800 0 PST} + {1805018400 -25200 1 PDT} + {1825578000 -28800 0 PST} + {1836468000 -25200 1 PDT} + {1857027600 -28800 0 PST} + {1867917600 -25200 1 PDT} + {1888477200 -28800 0 PST} + {1899367200 -25200 1 PDT} + {1919926800 -28800 0 PST} + {1930816800 -25200 1 PDT} + {1951376400 -28800 0 PST} + {1962871200 -25200 1 PDT} + {1983430800 -28800 0 PST} + {1994320800 -25200 1 PDT} + {2014880400 -28800 0 PST} + {2025770400 -25200 1 PDT} + {2046330000 -28800 0 PST} + {2057220000 -25200 1 PDT} + {2077779600 -28800 0 PST} + {2088669600 -25200 1 PDT} + {2109229200 -28800 0 PST} + {2120119200 -25200 1 PDT} + {2140678800 -28800 0 PST} + {2152173600 -25200 1 PDT} + {2172733200 -28800 0 PST} + {2183623200 -25200 1 PDT} + {2204182800 -28800 0 PST} + {2215072800 -25200 1 PDT} + {2235632400 -28800 0 PST} + {2246522400 -25200 1 PDT} + {2267082000 -28800 0 PST} + {2277972000 -25200 1 PDT} + {2298531600 -28800 0 PST} + {2309421600 -25200 1 PDT} + {2329981200 -28800 0 PST} + {2341476000 -25200 1 PDT} + {2362035600 -28800 0 PST} + {2372925600 -25200 1 PDT} + {2393485200 -28800 0 PST} + {2404375200 -25200 1 PDT} + {2424934800 -28800 0 PST} + {2435824800 -25200 1 PDT} + {2456384400 -28800 0 PST} + {2467274400 -25200 1 PDT} + {2487834000 -28800 0 PST} + {2499328800 -25200 1 PDT} + {2519888400 -28800 0 PST} + {2530778400 -25200 1 PDT} + {2551338000 -28800 0 PST} + {2562228000 -25200 1 PDT} + {2582787600 -28800 0 PST} + {2593677600 -25200 1 PDT} + {2614237200 -28800 0 PST} + {2625127200 -25200 1 PDT} + {2645686800 -28800 0 PST} + {2656576800 -25200 1 PDT} + {2677136400 -28800 0 PST} + {2688631200 -25200 1 PDT} + {2709190800 -28800 0 PST} + {2720080800 -25200 1 PDT} + {2740640400 -28800 0 PST} + {2751530400 -25200 1 PDT} + {2772090000 -28800 0 PST} + {2782980000 -25200 1 PDT} + {2803539600 -28800 0 PST} + {2814429600 -25200 1 PDT} + {2834989200 -28800 0 PST} + {2846484000 -25200 1 PDT} + {2867043600 -28800 0 PST} + {2877933600 -25200 1 PDT} + {2898493200 -28800 0 PST} + {2909383200 -25200 1 PDT} + {2929942800 -28800 0 PST} + {2940832800 -25200 1 PDT} + {2961392400 -28800 0 PST} + {2972282400 -25200 1 PDT} + {2992842000 -28800 0 PST} + {3003732000 -25200 1 PDT} + {3024291600 -28800 0 PST} + {3035786400 -25200 1 PDT} + {3056346000 -28800 0 PST} + {3067236000 -25200 1 PDT} + {3087795600 -28800 0 PST} + {3098685600 -25200 1 PDT} + {3119245200 -28800 0 PST} + {3130135200 -25200 1 PDT} + {3150694800 -28800 0 PST} + {3161584800 -25200 1 PDT} + {3182144400 -28800 0 PST} + {3193034400 -25200 1 PDT} + {3213594000 -28800 0 PST} + {3225088800 -25200 1 PDT} + {3245648400 -28800 0 PST} + {3256538400 -25200 1 PDT} + {3277098000 -28800 0 PST} + {3287988000 -25200 1 PDT} + {3308547600 -28800 0 PST} + {3319437600 -25200 1 PDT} + {3339997200 -28800 0 PST} + {3350887200 -25200 1 PDT} + {3371446800 -28800 0 PST} + {3382941600 -25200 1 PDT} + {3403501200 -28800 0 PST} + {3414391200 -25200 1 PDT} + {3434950800 -28800 0 PST} + {3445840800 -25200 1 PDT} + {3466400400 -28800 0 PST} + {3477290400 -25200 1 PDT} + {3497850000 -28800 0 PST} + {3508740000 -25200 1 PDT} + {3529299600 -28800 0 PST} + {3540189600 -25200 1 PDT} + {3560749200 -28800 0 PST} + {3572244000 -25200 1 PDT} + {3592803600 -28800 0 PST} + {3603693600 -25200 1 PDT} + {3624253200 -28800 0 PST} + {3635143200 -25200 1 PDT} + {3655702800 -28800 0 PST} + {3666592800 -25200 1 PDT} + {3687152400 -28800 0 PST} + {3698042400 -25200 1 PDT} + {3718602000 -28800 0 PST} + {3730096800 -25200 1 PDT} + {3750656400 -28800 0 PST} + {3761546400 -25200 1 PDT} + {3782106000 -28800 0 PST} + {3792996000 -25200 1 PDT} + {3813555600 -28800 0 PST} + {3824445600 -25200 1 PDT} + {3845005200 -28800 0 PST} + {3855895200 -25200 1 PDT} + {3876454800 -28800 0 PST} + {3887344800 -25200 1 PDT} + {3907904400 -28800 0 PST} + {3919399200 -25200 1 PDT} + {3939958800 -28800 0 PST} + {3950848800 -25200 1 PDT} + {3971408400 -28800 0 PST} + {3982298400 -25200 1 PDT} + {4002858000 -28800 0 PST} + {4013748000 -25200 1 PDT} + {4034307600 -28800 0 PST} + {4045197600 -25200 1 PDT} + {4065757200 -28800 0 PST} + {4076647200 -25200 1 PDT} + {4097206800 -28800 0 PST} } Index: library/tzdata/America/Louisville ================================================================== --- library/tzdata/America/Louisville +++ library/tzdata/America/Louisville @@ -1,314 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit - -set TZData(:America/Louisville) { - {-9223372036854775808 -20582 0 LMT} - {-2717648218 -21600 0 CST} - {-1633276800 -18000 1 CDT} - {-1615136400 -21600 0 CST} - {-1601827200 -18000 1 CDT} - {-1583686800 -21600 0 CST} - {-1546279200 -21600 0 CST} - {-1535904000 -18000 1 CDT} - {-1525280400 -21600 0 CST} - {-905097600 -18000 1 CDT} - {-891795600 -21600 0 CST} - {-883591200 -21600 0 CST} - {-880214400 -18000 1 CWT} - {-769395600 -18000 1 CPT} - {-765392400 -21600 0 CST} - {-757360800 -21600 0 CST} - {-747244800 -18000 1 CDT} - {-744224400 -21600 0 CST} - {-715795200 -18000 1 CDT} - {-684349200 -18000 1 CDT} - {-652899600 -18000 1 CDT} - {-620845200 -18000 1 CDT} - {-608144400 -21600 0 CST} - {-589392000 -18000 1 CDT} - {-576090000 -21600 0 CST} - {-557942400 -18000 1 CDT} - {-544640400 -21600 0 CST} - {-526492800 -18000 1 CDT} - {-513190800 -21600 0 CST} - {-495043200 -18000 1 CDT} - {-481741200 -21600 0 CST} - {-463593600 -18000 1 CDT} - {-450291600 -21600 0 CST} - {-431539200 -18000 1 CDT} - {-415818000 -21600 0 CST} - {-400089600 -18000 1 CDT} - {-384368400 -21600 0 CST} - {-368640000 -18000 1 CDT} - {-352918800 -21600 0 CST} - {-337190400 -18000 1 CDT} - {-321469200 -21600 0 CST} - {-305740800 -18000 1 CDT} - {-289414800 -21600 0 CST} - {-273686400 -18000 1 CDT} - {-266432400 -18000 0 EST} - {-63140400 -18000 0 EST} - {-52938000 -14400 1 EDT} - {-37216800 -18000 0 EST} - {-21488400 -14400 1 EDT} - {-5767200 -18000 0 EST} - {9961200 -14400 1 EDT} - {25682400 -18000 0 EST} - {41410800 -14400 1 EDT} - {57736800 -18000 0 EST} - {73465200 -14400 1 EDT} - {89186400 -18000 0 EST} - {104914800 -14400 1 EDT} - {120636000 -18000 0 EST} - {126687600 -18000 1 CDT} - {152089200 -18000 0 EST} - {162370800 -14400 1 EDT} - {183535200 -18000 0 EST} - {199263600 -14400 1 EDT} - {215589600 -18000 0 EST} - {230713200 -14400 1 EDT} - {247039200 -18000 0 EST} - {262767600 -14400 1 EDT} - {278488800 -18000 0 EST} - {294217200 -14400 1 EDT} - {309938400 -18000 0 EST} - {325666800 -14400 1 EDT} - {341388000 -18000 0 EST} - {357116400 -14400 1 EDT} - {372837600 -18000 0 EST} - {388566000 -14400 1 EDT} - {404892000 -18000 0 EST} - {420015600 -14400 1 EDT} - {436341600 -18000 0 EST} - {452070000 -14400 1 EDT} - {467791200 -18000 0 EST} - {483519600 -14400 1 EDT} - {499240800 -18000 0 EST} - {514969200 -14400 1 EDT} - {530690400 -18000 0 EST} - {544604400 -14400 1 EDT} - {562140000 -18000 0 EST} - {576054000 -14400 1 EDT} - {594194400 -18000 0 EST} - {607503600 -14400 1 EDT} - {625644000 -18000 0 EST} - {638953200 -14400 1 EDT} - {657093600 -18000 0 EST} - {671007600 -14400 1 EDT} - {688543200 -18000 0 EST} - {702457200 -14400 1 EDT} - {719992800 -18000 0 EST} - {733906800 -14400 1 EDT} - {752047200 -18000 0 EST} - {765356400 -14400 1 EDT} - {783496800 -18000 0 EST} - {796806000 -14400 1 EDT} - {814946400 -18000 0 EST} - {828860400 -14400 1 EDT} - {846396000 -18000 0 EST} - {860310000 -14400 1 EDT} - {877845600 -18000 0 EST} - {891759600 -14400 1 EDT} - {909295200 -18000 0 EST} - {923209200 -14400 1 EDT} - {941349600 -18000 0 EST} - {954658800 -14400 1 EDT} - {972799200 -18000 0 EST} - {986108400 -14400 1 EDT} - {1004248800 -18000 0 EST} - {1018162800 -14400 1 EDT} - {1035698400 -18000 0 EST} - {1049612400 -14400 1 EDT} - {1067148000 -18000 0 EST} - {1081062000 -14400 1 EDT} - {1099202400 -18000 0 EST} - {1112511600 -14400 1 EDT} - {1130652000 -18000 0 EST} - {1143961200 -14400 1 EDT} - {1162101600 -18000 0 EST} - {1175410800 -14400 1 EDT} - {1193551200 -18000 0 EST} - {1207465200 -14400 1 EDT} - {1225000800 -18000 0 EST} - {1238914800 -14400 1 EDT} - {1256450400 -18000 0 EST} - {1270364400 -14400 1 EDT} - {1288504800 -18000 0 EST} - {1301814000 -14400 1 EDT} - {1319954400 -18000 0 EST} - {1333263600 -14400 1 EDT} - {1351404000 -18000 0 EST} - {1365318000 -14400 1 EDT} - {1382853600 -18000 0 EST} - {1396767600 -14400 1 EDT} - {1414303200 -18000 0 EST} - {1428217200 -14400 1 EDT} - {1445752800 -18000 0 EST} - {1459666800 -14400 1 EDT} - {1477807200 -18000 0 EST} - {1491116400 -14400 1 EDT} - {1509256800 -18000 0 EST} - {1522566000 -14400 1 EDT} - {1540706400 -18000 0 EST} - {1554620400 -14400 1 EDT} - {1572156000 -18000 0 EST} - {1586070000 -14400 1 EDT} - {1603605600 -18000 0 EST} - {1617519600 -14400 1 EDT} - {1635660000 -18000 0 EST} - {1648969200 -14400 1 EDT} - {1667109600 -18000 0 EST} - {1680418800 -14400 1 EDT} - {1698559200 -18000 0 EST} - {1712473200 -14400 1 EDT} - {1730008800 -18000 0 EST} - {1743922800 -14400 1 EDT} - {1761458400 -18000 0 EST} - {1775372400 -14400 1 EDT} - {1792908000 -18000 0 EST} - {1806822000 -14400 1 EDT} - {1824962400 -18000 0 EST} - {1838271600 -14400 1 EDT} - {1856412000 -18000 0 EST} - {1869721200 -14400 1 EDT} - {1887861600 -18000 0 EST} - {1901775600 -14400 1 EDT} - {1919311200 -18000 0 EST} - {1933225200 -14400 1 EDT} - {1950760800 -18000 0 EST} - {1964674800 -14400 1 EDT} - {1982815200 -18000 0 EST} - {1996124400 -14400 1 EDT} - {2014264800 -18000 0 EST} - {2027574000 -14400 1 EDT} - {2045714400 -18000 0 EST} - {2059023600 -14400 1 EDT} - {2077164000 -18000 0 EST} - {2091078000 -14400 1 EDT} - {2108613600 -18000 0 EST} - {2122527600 -14400 1 EDT} - {2140063200 -18000 0 EST} - {2153977200 -14400 1 EDT} - {2172117600 -18000 0 EST} - {2185426800 -14400 1 EDT} - {2203567200 -18000 0 EST} - {2216876400 -14400 1 EDT} - {2235016800 -18000 0 EST} - {2248930800 -14400 1 EDT} - {2266466400 -18000 0 EST} - {2280380400 -14400 1 EDT} - {2297916000 -18000 0 EST} - {2311830000 -14400 1 EDT} - {2329365600 -18000 0 EST} - {2343279600 -14400 1 EDT} - {2361420000 -18000 0 EST} - {2374729200 -14400 1 EDT} - {2392869600 -18000 0 EST} - {2406178800 -14400 1 EDT} - {2424319200 -18000 0 EST} - {2438233200 -14400 1 EDT} - {2455768800 -18000 0 EST} - {2469682800 -14400 1 EDT} - {2487218400 -18000 0 EST} - {2501132400 -14400 1 EDT} - {2519272800 -18000 0 EST} - {2532582000 -14400 1 EDT} - {2550722400 -18000 0 EST} - {2564031600 -14400 1 EDT} - {2582172000 -18000 0 EST} - {2596086000 -14400 1 EDT} - {2613621600 -18000 0 EST} - {2627535600 -14400 1 EDT} - {2645071200 -18000 0 EST} - {2658985200 -14400 1 EDT} - {2676520800 -18000 0 EST} - {2690434800 -14400 1 EDT} - {2708575200 -18000 0 EST} - {2721884400 -14400 1 EDT} - {2740024800 -18000 0 EST} - {2753334000 -14400 1 EDT} - {2771474400 -18000 0 EST} - {2785388400 -14400 1 EDT} - {2802924000 -18000 0 EST} - {2816838000 -14400 1 EDT} - {2834373600 -18000 0 EST} - {2848287600 -14400 1 EDT} - {2866428000 -18000 0 EST} - {2879737200 -14400 1 EDT} - {2897877600 -18000 0 EST} - {2911186800 -14400 1 EDT} - {2929327200 -18000 0 EST} - {2942636400 -14400 1 EDT} - {2960776800 -18000 0 EST} - {2974690800 -14400 1 EDT} - {2992226400 -18000 0 EST} - {3006140400 -14400 1 EDT} - {3023676000 -18000 0 EST} - {3037590000 -14400 1 EDT} - {3055730400 -18000 0 EST} - {3069039600 -14400 1 EDT} - {3087180000 -18000 0 EST} - {3100489200 -14400 1 EDT} - {3118629600 -18000 0 EST} - {3132543600 -14400 1 EDT} - {3150079200 -18000 0 EST} - {3163993200 -14400 1 EDT} - {3181528800 -18000 0 EST} - {3195442800 -14400 1 EDT} - {3212978400 -18000 0 EST} - {3226892400 -14400 1 EDT} - {3245032800 -18000 0 EST} - {3258342000 -14400 1 EDT} - {3276482400 -18000 0 EST} - {3289791600 -14400 1 EDT} - {3307932000 -18000 0 EST} - {3321846000 -14400 1 EDT} - {3339381600 -18000 0 EST} - {3353295600 -14400 1 EDT} - {3370831200 -18000 0 EST} - {3384745200 -14400 1 EDT} - {3402885600 -18000 0 EST} - {3416194800 -14400 1 EDT} - {3434335200 -18000 0 EST} - {3447644400 -14400 1 EDT} - {3465784800 -18000 0 EST} - {3479698800 -14400 1 EDT} - {3497234400 -18000 0 EST} - {3511148400 -14400 1 EDT} - {3528684000 -18000 0 EST} - {3542598000 -14400 1 EDT} - {3560133600 -18000 0 EST} - {3574047600 -14400 1 EDT} - {3592188000 -18000 0 EST} - {3605497200 -14400 1 EDT} - {3623637600 -18000 0 EST} - {3636946800 -14400 1 EDT} - {3655087200 -18000 0 EST} - {3669001200 -14400 1 EDT} - {3686536800 -18000 0 EST} - {3700450800 -14400 1 EDT} - {3717986400 -18000 0 EST} - {3731900400 -14400 1 EDT} - {3750040800 -18000 0 EST} - {3763350000 -14400 1 EDT} - {3781490400 -18000 0 EST} - {3794799600 -14400 1 EDT} - {3812940000 -18000 0 EST} - {3826249200 -14400 1 EDT} - {3844389600 -18000 0 EST} - {3858303600 -14400 1 EDT} - {3875839200 -18000 0 EST} - {3889753200 -14400 1 EDT} - {3907288800 -18000 0 EST} - {3921202800 -14400 1 EDT} - {3939343200 -18000 0 EST} - {3952652400 -14400 1 EDT} - {3970792800 -18000 0 EST} - {3984102000 -14400 1 EDT} - {4002242400 -18000 0 EST} - {4016156400 -14400 1 EDT} - {4033692000 -18000 0 EST} - {4047606000 -14400 1 EDT} - {4065141600 -18000 0 EST} - {4079055600 -14400 1 EDT} - {4096591200 -18000 0 EST} -} +if {![info exists TZData(America/Kentucky/Louisville)]} { + LoadTimeZoneFile America/Kentucky/Louisville +} +set TZData(:America/Louisville) $TZData(:America/Kentucky/Louisville) Index: library/tzdata/America/Managua ================================================================== --- library/tzdata/America/Managua +++ library/tzdata/America/Managua @@ -12,6 +12,8 @@ {330584400 -21600 0 CST} {694260000 -18000 1 CDT} {717310800 -21600 0 CST} {725882400 -18000 0 EST} {912488400 -21600 0 CST} + {1113112800 -18000 1 CDT} + {1127019600 -21600 0 CST} } Index: library/tzdata/America/Menominee ================================================================== --- library/tzdata/America/Menominee +++ library/tzdata/America/Menominee @@ -83,192 +83,192 @@ {1099206000 -21600 0 CST} {1112515200 -18000 1 CDT} {1130655600 -21600 0 CST} {1143964800 -18000 1 CDT} {1162105200 -21600 0 CST} - {1175414400 -18000 1 CDT} - {1193554800 -21600 0 CST} - {1207468800 -18000 1 CDT} - {1225004400 -21600 0 CST} - {1238918400 -18000 1 CDT} - {1256454000 -21600 0 CST} - {1270368000 -18000 1 CDT} - {1288508400 -21600 0 CST} - {1301817600 -18000 1 CDT} - {1319958000 -21600 0 CST} - {1333267200 -18000 1 CDT} - {1351407600 -21600 0 CST} - {1365321600 -18000 1 CDT} - {1382857200 -21600 0 CST} - {1396771200 -18000 1 CDT} - {1414306800 -21600 0 CST} - {1428220800 -18000 1 CDT} - {1445756400 -21600 0 CST} - {1459670400 -18000 1 CDT} - {1477810800 -21600 0 CST} - {1491120000 -18000 1 CDT} - {1509260400 -21600 0 CST} - {1522569600 -18000 1 CDT} - {1540710000 -21600 0 CST} - {1554624000 -18000 1 CDT} - {1572159600 -21600 0 CST} - {1586073600 -18000 1 CDT} - {1603609200 -21600 0 CST} - {1617523200 -18000 1 CDT} - {1635663600 -21600 0 CST} - {1648972800 -18000 1 CDT} - {1667113200 -21600 0 CST} - {1680422400 -18000 1 CDT} - {1698562800 -21600 0 CST} - {1712476800 -18000 1 CDT} - {1730012400 -21600 0 CST} - {1743926400 -18000 1 CDT} - {1761462000 -21600 0 CST} - {1775376000 -18000 1 CDT} - {1792911600 -21600 0 CST} - {1806825600 -18000 1 CDT} - {1824966000 -21600 0 CST} - {1838275200 -18000 1 CDT} - {1856415600 -21600 0 CST} - {1869724800 -18000 1 CDT} - {1887865200 -21600 0 CST} - {1901779200 -18000 1 CDT} - {1919314800 -21600 0 CST} - {1933228800 -18000 1 CDT} - {1950764400 -21600 0 CST} - {1964678400 -18000 1 CDT} - {1982818800 -21600 0 CST} - {1996128000 -18000 1 CDT} - {2014268400 -21600 0 CST} - {2027577600 -18000 1 CDT} - {2045718000 -21600 0 CST} - {2059027200 -18000 1 CDT} - {2077167600 -21600 0 CST} - {2091081600 -18000 1 CDT} - {2108617200 -21600 0 CST} - {2122531200 -18000 1 CDT} - {2140066800 -21600 0 CST} - {2153980800 -18000 1 CDT} - {2172121200 -21600 0 CST} - {2185430400 -18000 1 CDT} - {2203570800 -21600 0 CST} - {2216880000 -18000 1 CDT} - {2235020400 -21600 0 CST} - {2248934400 -18000 1 CDT} - {2266470000 -21600 0 CST} - {2280384000 -18000 1 CDT} - {2297919600 -21600 0 CST} - {2311833600 -18000 1 CDT} - {2329369200 -21600 0 CST} - {2343283200 -18000 1 CDT} - {2361423600 -21600 0 CST} - {2374732800 -18000 1 CDT} - {2392873200 -21600 0 CST} - {2406182400 -18000 1 CDT} - {2424322800 -21600 0 CST} - {2438236800 -18000 1 CDT} - {2455772400 -21600 0 CST} - {2469686400 -18000 1 CDT} - {2487222000 -21600 0 CST} - {2501136000 -18000 1 CDT} - {2519276400 -21600 0 CST} - {2532585600 -18000 1 CDT} - {2550726000 -21600 0 CST} - {2564035200 -18000 1 CDT} - {2582175600 -21600 0 CST} - {2596089600 -18000 1 CDT} - {2613625200 -21600 0 CST} - {2627539200 -18000 1 CDT} - {2645074800 -21600 0 CST} - {2658988800 -18000 1 CDT} - {2676524400 -21600 0 CST} - {2690438400 -18000 1 CDT} - {2708578800 -21600 0 CST} - {2721888000 -18000 1 CDT} - {2740028400 -21600 0 CST} - {2753337600 -18000 1 CDT} - {2771478000 -21600 0 CST} - {2785392000 -18000 1 CDT} - {2802927600 -21600 0 CST} - {2816841600 -18000 1 CDT} - {2834377200 -21600 0 CST} - {2848291200 -18000 1 CDT} - {2866431600 -21600 0 CST} - {2879740800 -18000 1 CDT} - {2897881200 -21600 0 CST} - {2911190400 -18000 1 CDT} - {2929330800 -21600 0 CST} - {2942640000 -18000 1 CDT} - {2960780400 -21600 0 CST} - {2974694400 -18000 1 CDT} - {2992230000 -21600 0 CST} - {3006144000 -18000 1 CDT} - {3023679600 -21600 0 CST} - {3037593600 -18000 1 CDT} - {3055734000 -21600 0 CST} - {3069043200 -18000 1 CDT} - {3087183600 -21600 0 CST} - {3100492800 -18000 1 CDT} - {3118633200 -21600 0 CST} - {3132547200 -18000 1 CDT} - {3150082800 -21600 0 CST} - {3163996800 -18000 1 CDT} - {3181532400 -21600 0 CST} - {3195446400 -18000 1 CDT} - {3212982000 -21600 0 CST} - {3226896000 -18000 1 CDT} - {3245036400 -21600 0 CST} - {3258345600 -18000 1 CDT} - {3276486000 -21600 0 CST} - {3289795200 -18000 1 CDT} - {3307935600 -21600 0 CST} - {3321849600 -18000 1 CDT} - {3339385200 -21600 0 CST} - {3353299200 -18000 1 CDT} - {3370834800 -21600 0 CST} - {3384748800 -18000 1 CDT} - {3402889200 -21600 0 CST} - {3416198400 -18000 1 CDT} - {3434338800 -21600 0 CST} - {3447648000 -18000 1 CDT} - {3465788400 -21600 0 CST} - {3479702400 -18000 1 CDT} - {3497238000 -21600 0 CST} - {3511152000 -18000 1 CDT} - {3528687600 -21600 0 CST} - {3542601600 -18000 1 CDT} - {3560137200 -21600 0 CST} - {3574051200 -18000 1 CDT} - {3592191600 -21600 0 CST} - {3605500800 -18000 1 CDT} - {3623641200 -21600 0 CST} - {3636950400 -18000 1 CDT} - {3655090800 -21600 0 CST} - {3669004800 -18000 1 CDT} - {3686540400 -21600 0 CST} - {3700454400 -18000 1 CDT} - {3717990000 -21600 0 CST} - {3731904000 -18000 1 CDT} - {3750044400 -21600 0 CST} - {3763353600 -18000 1 CDT} - {3781494000 -21600 0 CST} - {3794803200 -18000 1 CDT} - {3812943600 -21600 0 CST} - {3826252800 -18000 1 CDT} - {3844393200 -21600 0 CST} - {3858307200 -18000 1 CDT} - {3875842800 -21600 0 CST} - {3889756800 -18000 1 CDT} - {3907292400 -21600 0 CST} - {3921206400 -18000 1 CDT} - {3939346800 -21600 0 CST} - {3952656000 -18000 1 CDT} - {3970796400 -21600 0 CST} - {3984105600 -18000 1 CDT} - {4002246000 -21600 0 CST} - {4016160000 -18000 1 CDT} - {4033695600 -21600 0 CST} - {4047609600 -18000 1 CDT} - {4065145200 -21600 0 CST} - {4079059200 -18000 1 CDT} - {4096594800 -21600 0 CST} + {1173600000 -18000 1 CDT} + {1194159600 -21600 0 CST} + {1205049600 -18000 1 CDT} + {1225609200 -21600 0 CST} + {1236499200 -18000 1 CDT} + {1257058800 -21600 0 CST} + {1268553600 -18000 1 CDT} + {1289113200 -21600 0 CST} + {1300003200 -18000 1 CDT} + {1320562800 -21600 0 CST} + {1331452800 -18000 1 CDT} + {1352012400 -21600 0 CST} + {1362902400 -18000 1 CDT} + {1383462000 -21600 0 CST} + {1394352000 -18000 1 CDT} + {1414911600 -21600 0 CST} + {1425801600 -18000 1 CDT} + {1446361200 -21600 0 CST} + {1457856000 -18000 1 CDT} + {1478415600 -21600 0 CST} + {1489305600 -18000 1 CDT} + {1509865200 -21600 0 CST} + {1520755200 -18000 1 CDT} + {1541314800 -21600 0 CST} + {1552204800 -18000 1 CDT} + {1572764400 -21600 0 CST} + {1583654400 -18000 1 CDT} + {1604214000 -21600 0 CST} + {1615708800 -18000 1 CDT} + {1636268400 -21600 0 CST} + {1647158400 -18000 1 CDT} + {1667718000 -21600 0 CST} + {1678608000 -18000 1 CDT} + {1699167600 -21600 0 CST} + {1710057600 -18000 1 CDT} + {1730617200 -21600 0 CST} + {1741507200 -18000 1 CDT} + {1762066800 -21600 0 CST} + {1772956800 -18000 1 CDT} + {1793516400 -21600 0 CST} + {1805011200 -18000 1 CDT} + {1825570800 -21600 0 CST} + {1836460800 -18000 1 CDT} + {1857020400 -21600 0 CST} + {1867910400 -18000 1 CDT} + {1888470000 -21600 0 CST} + {1899360000 -18000 1 CDT} + {1919919600 -21600 0 CST} + {1930809600 -18000 1 CDT} + {1951369200 -21600 0 CST} + {1962864000 -18000 1 CDT} + {1983423600 -21600 0 CST} + {1994313600 -18000 1 CDT} + {2014873200 -21600 0 CST} + {2025763200 -18000 1 CDT} + {2046322800 -21600 0 CST} + {2057212800 -18000 1 CDT} + {2077772400 -21600 0 CST} + {2088662400 -18000 1 CDT} + {2109222000 -21600 0 CST} + {2120112000 -18000 1 CDT} + {2140671600 -21600 0 CST} + {2152166400 -18000 1 CDT} + {2172726000 -21600 0 CST} + {2183616000 -18000 1 CDT} + {2204175600 -21600 0 CST} + {2215065600 -18000 1 CDT} + {2235625200 -21600 0 CST} + {2246515200 -18000 1 CDT} + {2267074800 -21600 0 CST} + {2277964800 -18000 1 CDT} + {2298524400 -21600 0 CST} + {2309414400 -18000 1 CDT} + {2329974000 -21600 0 CST} + {2341468800 -18000 1 CDT} + {2362028400 -21600 0 CST} + {2372918400 -18000 1 CDT} + {2393478000 -21600 0 CST} + {2404368000 -18000 1 CDT} + {2424927600 -21600 0 CST} + {2435817600 -18000 1 CDT} + {2456377200 -21600 0 CST} + {2467267200 -18000 1 CDT} + {2487826800 -21600 0 CST} + {2499321600 -18000 1 CDT} + {2519881200 -21600 0 CST} + {2530771200 -18000 1 CDT} + {2551330800 -21600 0 CST} + {2562220800 -18000 1 CDT} + {2582780400 -21600 0 CST} + {2593670400 -18000 1 CDT} + {2614230000 -21600 0 CST} + {2625120000 -18000 1 CDT} + {2645679600 -21600 0 CST} + {2656569600 -18000 1 CDT} + {2677129200 -21600 0 CST} + {2688624000 -18000 1 CDT} + {2709183600 -21600 0 CST} + {2720073600 -18000 1 CDT} + {2740633200 -21600 0 CST} + {2751523200 -18000 1 CDT} + {2772082800 -21600 0 CST} + {2782972800 -18000 1 CDT} + {2803532400 -21600 0 CST} + {2814422400 -18000 1 CDT} + {2834982000 -21600 0 CST} + {2846476800 -18000 1 CDT} + {2867036400 -21600 0 CST} + {2877926400 -18000 1 CDT} + {2898486000 -21600 0 CST} + {2909376000 -18000 1 CDT} + {2929935600 -21600 0 CST} + {2940825600 -18000 1 CDT} + {2961385200 -21600 0 CST} + {2972275200 -18000 1 CDT} + {2992834800 -21600 0 CST} + {3003724800 -18000 1 CDT} + {3024284400 -21600 0 CST} + {3035779200 -18000 1 CDT} + {3056338800 -21600 0 CST} + {3067228800 -18000 1 CDT} + {3087788400 -21600 0 CST} + {3098678400 -18000 1 CDT} + {3119238000 -21600 0 CST} + {3130128000 -18000 1 CDT} + {3150687600 -21600 0 CST} + {3161577600 -18000 1 CDT} + {3182137200 -21600 0 CST} + {3193027200 -18000 1 CDT} + {3213586800 -21600 0 CST} + {3225081600 -18000 1 CDT} + {3245641200 -21600 0 CST} + {3256531200 -18000 1 CDT} + {3277090800 -21600 0 CST} + {3287980800 -18000 1 CDT} + {3308540400 -21600 0 CST} + {3319430400 -18000 1 CDT} + {3339990000 -21600 0 CST} + {3350880000 -18000 1 CDT} + {3371439600 -21600 0 CST} + {3382934400 -18000 1 CDT} + {3403494000 -21600 0 CST} + {3414384000 -18000 1 CDT} + {3434943600 -21600 0 CST} + {3445833600 -18000 1 CDT} + {3466393200 -21600 0 CST} + {3477283200 -18000 1 CDT} + {3497842800 -21600 0 CST} + {3508732800 -18000 1 CDT} + {3529292400 -21600 0 CST} + {3540182400 -18000 1 CDT} + {3560742000 -21600 0 CST} + {3572236800 -18000 1 CDT} + {3592796400 -21600 0 CST} + {3603686400 -18000 1 CDT} + {3624246000 -21600 0 CST} + {3635136000 -18000 1 CDT} + {3655695600 -21600 0 CST} + {3666585600 -18000 1 CDT} + {3687145200 -21600 0 CST} + {3698035200 -18000 1 CDT} + {3718594800 -21600 0 CST} + {3730089600 -18000 1 CDT} + {3750649200 -21600 0 CST} + {3761539200 -18000 1 CDT} + {3782098800 -21600 0 CST} + {3792988800 -18000 1 CDT} + {3813548400 -21600 0 CST} + {3824438400 -18000 1 CDT} + {3844998000 -21600 0 CST} + {3855888000 -18000 1 CDT} + {3876447600 -21600 0 CST} + {3887337600 -18000 1 CDT} + {3907897200 -21600 0 CST} + {3919392000 -18000 1 CDT} + {3939951600 -21600 0 CST} + {3950841600 -18000 1 CDT} + {3971401200 -21600 0 CST} + {3982291200 -18000 1 CDT} + {4002850800 -21600 0 CST} + {4013740800 -18000 1 CDT} + {4034300400 -21600 0 CST} + {4045190400 -18000 1 CDT} + {4065750000 -21600 0 CST} + {4076640000 -18000 1 CDT} + {4097199600 -21600 0 CST} } Index: library/tzdata/America/Montevideo ================================================================== --- library/tzdata/America/Montevideo +++ library/tzdata/America/Montevideo @@ -65,7 +65,9 @@ {688532400 -7200 1 UYST} {699415200 -10800 0 UYT} {719377200 -7200 1 UYST} {730864800 -10800 0 UYT} {1095562800 -7200 1 UYST} - {1110679200 -10800 0 UYT} + {1111896000 -10800 0 UYT} + {1128834000 -7200 1 UYST} + {1142136000 -10800 0 UYT} } Index: library/tzdata/America/New_York ================================================================== --- library/tzdata/America/New_York +++ library/tzdata/America/New_York @@ -1,10 +1,10 @@ # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/New_York) { {-9223372036854775808 -17762 0 LMT} - {-2717651038 -18000 0 EST} + {-2717650800 -18000 0 EST} {-1633280400 -14400 1 EDT} {-1615140000 -18000 0 EST} {-1601830800 -14400 1 EDT} {-1583690400 -18000 0 EST} {-1577905200 -18000 0 EST} @@ -178,192 +178,192 @@ {1099202400 -18000 0 EST} {1112511600 -14400 1 EDT} {1130652000 -18000 0 EST} {1143961200 -14400 1 EDT} {1162101600 -18000 0 EST} - {1175410800 -14400 1 EDT} - {1193551200 -18000 0 EST} - {1207465200 -14400 1 EDT} - {1225000800 -18000 0 EST} - {1238914800 -14400 1 EDT} - {1256450400 -18000 0 EST} - {1270364400 -14400 1 EDT} - {1288504800 -18000 0 EST} - {1301814000 -14400 1 EDT} - {1319954400 -18000 0 EST} - {1333263600 -14400 1 EDT} - {1351404000 -18000 0 EST} - {1365318000 -14400 1 EDT} - {1382853600 -18000 0 EST} - {1396767600 -14400 1 EDT} - {1414303200 -18000 0 EST} - {1428217200 -14400 1 EDT} - {1445752800 -18000 0 EST} - {1459666800 -14400 1 EDT} - {1477807200 -18000 0 EST} - {1491116400 -14400 1 EDT} - {1509256800 -18000 0 EST} - {1522566000 -14400 1 EDT} - {1540706400 -18000 0 EST} - {1554620400 -14400 1 EDT} - {1572156000 -18000 0 EST} - {1586070000 -14400 1 EDT} - {1603605600 -18000 0 EST} - {1617519600 -14400 1 EDT} - {1635660000 -18000 0 EST} - {1648969200 -14400 1 EDT} - {1667109600 -18000 0 EST} - {1680418800 -14400 1 EDT} - {1698559200 -18000 0 EST} - {1712473200 -14400 1 EDT} - {1730008800 -18000 0 EST} - {1743922800 -14400 1 EDT} - {1761458400 -18000 0 EST} - {1775372400 -14400 1 EDT} - {1792908000 -18000 0 EST} - {1806822000 -14400 1 EDT} - {1824962400 -18000 0 EST} - {1838271600 -14400 1 EDT} - {1856412000 -18000 0 EST} - {1869721200 -14400 1 EDT} - {1887861600 -18000 0 EST} - {1901775600 -14400 1 EDT} - {1919311200 -18000 0 EST} - {1933225200 -14400 1 EDT} - {1950760800 -18000 0 EST} - {1964674800 -14400 1 EDT} - {1982815200 -18000 0 EST} - {1996124400 -14400 1 EDT} - {2014264800 -18000 0 EST} - {2027574000 -14400 1 EDT} - {2045714400 -18000 0 EST} - {2059023600 -14400 1 EDT} - {2077164000 -18000 0 EST} - {2091078000 -14400 1 EDT} - {2108613600 -18000 0 EST} - {2122527600 -14400 1 EDT} - {2140063200 -18000 0 EST} - {2153977200 -14400 1 EDT} - {2172117600 -18000 0 EST} - {2185426800 -14400 1 EDT} - {2203567200 -18000 0 EST} - {2216876400 -14400 1 EDT} - {2235016800 -18000 0 EST} - {2248930800 -14400 1 EDT} - {2266466400 -18000 0 EST} - {2280380400 -14400 1 EDT} - {2297916000 -18000 0 EST} - {2311830000 -14400 1 EDT} - {2329365600 -18000 0 EST} - {2343279600 -14400 1 EDT} - {2361420000 -18000 0 EST} - {2374729200 -14400 1 EDT} - {2392869600 -18000 0 EST} - {2406178800 -14400 1 EDT} - {2424319200 -18000 0 EST} - {2438233200 -14400 1 EDT} - {2455768800 -18000 0 EST} - {2469682800 -14400 1 EDT} - {2487218400 -18000 0 EST} - {2501132400 -14400 1 EDT} - {2519272800 -18000 0 EST} - {2532582000 -14400 1 EDT} - {2550722400 -18000 0 EST} - {2564031600 -14400 1 EDT} - {2582172000 -18000 0 EST} - {2596086000 -14400 1 EDT} - {2613621600 -18000 0 EST} - {2627535600 -14400 1 EDT} - {2645071200 -18000 0 EST} - {2658985200 -14400 1 EDT} - {2676520800 -18000 0 EST} - {2690434800 -14400 1 EDT} - {2708575200 -18000 0 EST} - {2721884400 -14400 1 EDT} - {2740024800 -18000 0 EST} - {2753334000 -14400 1 EDT} - {2771474400 -18000 0 EST} - {2785388400 -14400 1 EDT} - {2802924000 -18000 0 EST} - {2816838000 -14400 1 EDT} - {2834373600 -18000 0 EST} - {2848287600 -14400 1 EDT} - {2866428000 -18000 0 EST} - {2879737200 -14400 1 EDT} - {2897877600 -18000 0 EST} - {2911186800 -14400 1 EDT} - {2929327200 -18000 0 EST} - {2942636400 -14400 1 EDT} - {2960776800 -18000 0 EST} - {2974690800 -14400 1 EDT} - {2992226400 -18000 0 EST} - {3006140400 -14400 1 EDT} - {3023676000 -18000 0 EST} - {3037590000 -14400 1 EDT} - {3055730400 -18000 0 EST} - {3069039600 -14400 1 EDT} - {3087180000 -18000 0 EST} - {3100489200 -14400 1 EDT} - {3118629600 -18000 0 EST} - {3132543600 -14400 1 EDT} - {3150079200 -18000 0 EST} - {3163993200 -14400 1 EDT} - {3181528800 -18000 0 EST} - {3195442800 -14400 1 EDT} - {3212978400 -18000 0 EST} - {3226892400 -14400 1 EDT} - {3245032800 -18000 0 EST} - {3258342000 -14400 1 EDT} - {3276482400 -18000 0 EST} - {3289791600 -14400 1 EDT} - {3307932000 -18000 0 EST} - {3321846000 -14400 1 EDT} - {3339381600 -18000 0 EST} - {3353295600 -14400 1 EDT} - {3370831200 -18000 0 EST} - {3384745200 -14400 1 EDT} - {3402885600 -18000 0 EST} - {3416194800 -14400 1 EDT} - {3434335200 -18000 0 EST} - {3447644400 -14400 1 EDT} - {3465784800 -18000 0 EST} - {3479698800 -14400 1 EDT} - {3497234400 -18000 0 EST} - {3511148400 -14400 1 EDT} - {3528684000 -18000 0 EST} - {3542598000 -14400 1 EDT} - {3560133600 -18000 0 EST} - {3574047600 -14400 1 EDT} - {3592188000 -18000 0 EST} - {3605497200 -14400 1 EDT} - {3623637600 -18000 0 EST} - {3636946800 -14400 1 EDT} - {3655087200 -18000 0 EST} - {3669001200 -14400 1 EDT} - {3686536800 -18000 0 EST} - {3700450800 -14400 1 EDT} - {3717986400 -18000 0 EST} - {3731900400 -14400 1 EDT} - {3750040800 -18000 0 EST} - {3763350000 -14400 1 EDT} - {3781490400 -18000 0 EST} - {3794799600 -14400 1 EDT} - {3812940000 -18000 0 EST} - {3826249200 -14400 1 EDT} - {3844389600 -18000 0 EST} - {3858303600 -14400 1 EDT} - {3875839200 -18000 0 EST} - {3889753200 -14400 1 EDT} - {3907288800 -18000 0 EST} - {3921202800 -14400 1 EDT} - {3939343200 -18000 0 EST} - {3952652400 -14400 1 EDT} - {3970792800 -18000 0 EST} - {3984102000 -14400 1 EDT} - {4002242400 -18000 0 EST} - {4016156400 -14400 1 EDT} - {4033692000 -18000 0 EST} - {4047606000 -14400 1 EDT} - {4065141600 -18000 0 EST} - {4079055600 -14400 1 EDT} - {4096591200 -18000 0 EST} + {1173596400 -14400 1 EDT} + {1194156000 -18000 0 EST} + {1205046000 -14400 1 EDT} + {1225605600 -18000 0 EST} + {1236495600 -14400 1 EDT} + {1257055200 -18000 0 EST} + {1268550000 -14400 1 EDT} + {1289109600 -18000 0 EST} + {1299999600 -14400 1 EDT} + {1320559200 -18000 0 EST} + {1331449200 -14400 1 EDT} + {1352008800 -18000 0 EST} + {1362898800 -14400 1 EDT} + {1383458400 -18000 0 EST} + {1394348400 -14400 1 EDT} + {1414908000 -18000 0 EST} + {1425798000 -14400 1 EDT} + {1446357600 -18000 0 EST} + {1457852400 -14400 1 EDT} + {1478412000 -18000 0 EST} + {1489302000 -14400 1 EDT} + {1509861600 -18000 0 EST} + {1520751600 -14400 1 EDT} + {1541311200 -18000 0 EST} + {1552201200 -14400 1 EDT} + {1572760800 -18000 0 EST} + {1583650800 -14400 1 EDT} + {1604210400 -18000 0 EST} + {1615705200 -14400 1 EDT} + {1636264800 -18000 0 EST} + {1647154800 -14400 1 EDT} + {1667714400 -18000 0 EST} + {1678604400 -14400 1 EDT} + {1699164000 -18000 0 EST} + {1710054000 -14400 1 EDT} + {1730613600 -18000 0 EST} + {1741503600 -14400 1 EDT} + {1762063200 -18000 0 EST} + {1772953200 -14400 1 EDT} + {1793512800 -18000 0 EST} + {1805007600 -14400 1 EDT} + {1825567200 -18000 0 EST} + {1836457200 -14400 1 EDT} + {1857016800 -18000 0 EST} + {1867906800 -14400 1 EDT} + {1888466400 -18000 0 EST} + {1899356400 -14400 1 EDT} + {1919916000 -18000 0 EST} + {1930806000 -14400 1 EDT} + {1951365600 -18000 0 EST} + {1962860400 -14400 1 EDT} + {1983420000 -18000 0 EST} + {1994310000 -14400 1 EDT} + {2014869600 -18000 0 EST} + {2025759600 -14400 1 EDT} + {2046319200 -18000 0 EST} + {2057209200 -14400 1 EDT} + {2077768800 -18000 0 EST} + {2088658800 -14400 1 EDT} + {2109218400 -18000 0 EST} + {2120108400 -14400 1 EDT} + {2140668000 -18000 0 EST} + {2152162800 -14400 1 EDT} + {2172722400 -18000 0 EST} + {2183612400 -14400 1 EDT} + {2204172000 -18000 0 EST} + {2215062000 -14400 1 EDT} + {2235621600 -18000 0 EST} + {2246511600 -14400 1 EDT} + {2267071200 -18000 0 EST} + {2277961200 -14400 1 EDT} + {2298520800 -18000 0 EST} + {2309410800 -14400 1 EDT} + {2329970400 -18000 0 EST} + {2341465200 -14400 1 EDT} + {2362024800 -18000 0 EST} + {2372914800 -14400 1 EDT} + {2393474400 -18000 0 EST} + {2404364400 -14400 1 EDT} + {2424924000 -18000 0 EST} + {2435814000 -14400 1 EDT} + {2456373600 -18000 0 EST} + {2467263600 -14400 1 EDT} + {2487823200 -18000 0 EST} + {2499318000 -14400 1 EDT} + {2519877600 -18000 0 EST} + {2530767600 -14400 1 EDT} + {2551327200 -18000 0 EST} + {2562217200 -14400 1 EDT} + {2582776800 -18000 0 EST} + {2593666800 -14400 1 EDT} + {2614226400 -18000 0 EST} + {2625116400 -14400 1 EDT} + {2645676000 -18000 0 EST} + {2656566000 -14400 1 EDT} + {2677125600 -18000 0 EST} + {2688620400 -14400 1 EDT} + {2709180000 -18000 0 EST} + {2720070000 -14400 1 EDT} + {2740629600 -18000 0 EST} + {2751519600 -14400 1 EDT} + {2772079200 -18000 0 EST} + {2782969200 -14400 1 EDT} + {2803528800 -18000 0 EST} + {2814418800 -14400 1 EDT} + {2834978400 -18000 0 EST} + {2846473200 -14400 1 EDT} + {2867032800 -18000 0 EST} + {2877922800 -14400 1 EDT} + {2898482400 -18000 0 EST} + {2909372400 -14400 1 EDT} + {2929932000 -18000 0 EST} + {2940822000 -14400 1 EDT} + {2961381600 -18000 0 EST} + {2972271600 -14400 1 EDT} + {2992831200 -18000 0 EST} + {3003721200 -14400 1 EDT} + {3024280800 -18000 0 EST} + {3035775600 -14400 1 EDT} + {3056335200 -18000 0 EST} + {3067225200 -14400 1 EDT} + {3087784800 -18000 0 EST} + {3098674800 -14400 1 EDT} + {3119234400 -18000 0 EST} + {3130124400 -14400 1 EDT} + {3150684000 -18000 0 EST} + {3161574000 -14400 1 EDT} + {3182133600 -18000 0 EST} + {3193023600 -14400 1 EDT} + {3213583200 -18000 0 EST} + {3225078000 -14400 1 EDT} + {3245637600 -18000 0 EST} + {3256527600 -14400 1 EDT} + {3277087200 -18000 0 EST} + {3287977200 -14400 1 EDT} + {3308536800 -18000 0 EST} + {3319426800 -14400 1 EDT} + {3339986400 -18000 0 EST} + {3350876400 -14400 1 EDT} + {3371436000 -18000 0 EST} + {3382930800 -14400 1 EDT} + {3403490400 -18000 0 EST} + {3414380400 -14400 1 EDT} + {3434940000 -18000 0 EST} + {3445830000 -14400 1 EDT} + {3466389600 -18000 0 EST} + {3477279600 -14400 1 EDT} + {3497839200 -18000 0 EST} + {3508729200 -14400 1 EDT} + {3529288800 -18000 0 EST} + {3540178800 -14400 1 EDT} + {3560738400 -18000 0 EST} + {3572233200 -14400 1 EDT} + {3592792800 -18000 0 EST} + {3603682800 -14400 1 EDT} + {3624242400 -18000 0 EST} + {3635132400 -14400 1 EDT} + {3655692000 -18000 0 EST} + {3666582000 -14400 1 EDT} + {3687141600 -18000 0 EST} + {3698031600 -14400 1 EDT} + {3718591200 -18000 0 EST} + {3730086000 -14400 1 EDT} + {3750645600 -18000 0 EST} + {3761535600 -14400 1 EDT} + {3782095200 -18000 0 EST} + {3792985200 -14400 1 EDT} + {3813544800 -18000 0 EST} + {3824434800 -14400 1 EDT} + {3844994400 -18000 0 EST} + {3855884400 -14400 1 EDT} + {3876444000 -18000 0 EST} + {3887334000 -14400 1 EDT} + {3907893600 -18000 0 EST} + {3919388400 -14400 1 EDT} + {3939948000 -18000 0 EST} + {3950838000 -14400 1 EDT} + {3971397600 -18000 0 EST} + {3982287600 -14400 1 EDT} + {4002847200 -18000 0 EST} + {4013737200 -14400 1 EDT} + {4034296800 -18000 0 EST} + {4045186800 -14400 1 EDT} + {4065746400 -18000 0 EST} + {4076636400 -14400 1 EDT} + {4097196000 -18000 0 EST} } Index: library/tzdata/America/Nome ================================================================== --- library/tzdata/America/Nome +++ library/tzdata/America/Nome @@ -85,192 +85,192 @@ {1099216800 -32400 0 AKST} {1112526000 -28800 1 AKDT} {1130666400 -32400 0 AKST} {1143975600 -28800 1 AKDT} {1162116000 -32400 0 AKST} - {1175425200 -28800 1 AKDT} - {1193565600 -32400 0 AKST} - {1207479600 -28800 1 AKDT} - {1225015200 -32400 0 AKST} - {1238929200 -28800 1 AKDT} - {1256464800 -32400 0 AKST} - {1270378800 -28800 1 AKDT} - {1288519200 -32400 0 AKST} - {1301828400 -28800 1 AKDT} - {1319968800 -32400 0 AKST} - {1333278000 -28800 1 AKDT} - {1351418400 -32400 0 AKST} - {1365332400 -28800 1 AKDT} - {1382868000 -32400 0 AKST} - {1396782000 -28800 1 AKDT} - {1414317600 -32400 0 AKST} - {1428231600 -28800 1 AKDT} - {1445767200 -32400 0 AKST} - {1459681200 -28800 1 AKDT} - {1477821600 -32400 0 AKST} - {1491130800 -28800 1 AKDT} - {1509271200 -32400 0 AKST} - {1522580400 -28800 1 AKDT} - {1540720800 -32400 0 AKST} - {1554634800 -28800 1 AKDT} - {1572170400 -32400 0 AKST} - {1586084400 -28800 1 AKDT} - {1603620000 -32400 0 AKST} - {1617534000 -28800 1 AKDT} - {1635674400 -32400 0 AKST} - {1648983600 -28800 1 AKDT} - {1667124000 -32400 0 AKST} - {1680433200 -28800 1 AKDT} - {1698573600 -32400 0 AKST} - {1712487600 -28800 1 AKDT} - {1730023200 -32400 0 AKST} - {1743937200 -28800 1 AKDT} - {1761472800 -32400 0 AKST} - {1775386800 -28800 1 AKDT} - {1792922400 -32400 0 AKST} - {1806836400 -28800 1 AKDT} - {1824976800 -32400 0 AKST} - {1838286000 -28800 1 AKDT} - {1856426400 -32400 0 AKST} - {1869735600 -28800 1 AKDT} - {1887876000 -32400 0 AKST} - {1901790000 -28800 1 AKDT} - {1919325600 -32400 0 AKST} - {1933239600 -28800 1 AKDT} - {1950775200 -32400 0 AKST} - {1964689200 -28800 1 AKDT} - {1982829600 -32400 0 AKST} - {1996138800 -28800 1 AKDT} - {2014279200 -32400 0 AKST} - {2027588400 -28800 1 AKDT} - {2045728800 -32400 0 AKST} - {2059038000 -28800 1 AKDT} - {2077178400 -32400 0 AKST} - {2091092400 -28800 1 AKDT} - {2108628000 -32400 0 AKST} - {2122542000 -28800 1 AKDT} - {2140077600 -32400 0 AKST} - {2153991600 -28800 1 AKDT} - {2172132000 -32400 0 AKST} - {2185441200 -28800 1 AKDT} - {2203581600 -32400 0 AKST} - {2216890800 -28800 1 AKDT} - {2235031200 -32400 0 AKST} - {2248945200 -28800 1 AKDT} - {2266480800 -32400 0 AKST} - {2280394800 -28800 1 AKDT} - {2297930400 -32400 0 AKST} - {2311844400 -28800 1 AKDT} - {2329380000 -32400 0 AKST} - {2343294000 -28800 1 AKDT} - {2361434400 -32400 0 AKST} - {2374743600 -28800 1 AKDT} - {2392884000 -32400 0 AKST} - {2406193200 -28800 1 AKDT} - {2424333600 -32400 0 AKST} - {2438247600 -28800 1 AKDT} - {2455783200 -32400 0 AKST} - {2469697200 -28800 1 AKDT} - {2487232800 -32400 0 AKST} - {2501146800 -28800 1 AKDT} - {2519287200 -32400 0 AKST} - {2532596400 -28800 1 AKDT} - {2550736800 -32400 0 AKST} - {2564046000 -28800 1 AKDT} - {2582186400 -32400 0 AKST} - {2596100400 -28800 1 AKDT} - {2613636000 -32400 0 AKST} - {2627550000 -28800 1 AKDT} - {2645085600 -32400 0 AKST} - {2658999600 -28800 1 AKDT} - {2676535200 -32400 0 AKST} - {2690449200 -28800 1 AKDT} - {2708589600 -32400 0 AKST} - {2721898800 -28800 1 AKDT} - {2740039200 -32400 0 AKST} - {2753348400 -28800 1 AKDT} - {2771488800 -32400 0 AKST} - {2785402800 -28800 1 AKDT} - {2802938400 -32400 0 AKST} - {2816852400 -28800 1 AKDT} - {2834388000 -32400 0 AKST} - {2848302000 -28800 1 AKDT} - {2866442400 -32400 0 AKST} - {2879751600 -28800 1 AKDT} - {2897892000 -32400 0 AKST} - {2911201200 -28800 1 AKDT} - {2929341600 -32400 0 AKST} - {2942650800 -28800 1 AKDT} - {2960791200 -32400 0 AKST} - {2974705200 -28800 1 AKDT} - {2992240800 -32400 0 AKST} - {3006154800 -28800 1 AKDT} - {3023690400 -32400 0 AKST} - {3037604400 -28800 1 AKDT} - {3055744800 -32400 0 AKST} - {3069054000 -28800 1 AKDT} - {3087194400 -32400 0 AKST} - {3100503600 -28800 1 AKDT} - {3118644000 -32400 0 AKST} - {3132558000 -28800 1 AKDT} - {3150093600 -32400 0 AKST} - {3164007600 -28800 1 AKDT} - {3181543200 -32400 0 AKST} - {3195457200 -28800 1 AKDT} - {3212992800 -32400 0 AKST} - {3226906800 -28800 1 AKDT} - {3245047200 -32400 0 AKST} - {3258356400 -28800 1 AKDT} - {3276496800 -32400 0 AKST} - {3289806000 -28800 1 AKDT} - {3307946400 -32400 0 AKST} - {3321860400 -28800 1 AKDT} - {3339396000 -32400 0 AKST} - {3353310000 -28800 1 AKDT} - {3370845600 -32400 0 AKST} - {3384759600 -28800 1 AKDT} - {3402900000 -32400 0 AKST} - {3416209200 -28800 1 AKDT} - {3434349600 -32400 0 AKST} - {3447658800 -28800 1 AKDT} - {3465799200 -32400 0 AKST} - {3479713200 -28800 1 AKDT} - {3497248800 -32400 0 AKST} - {3511162800 -28800 1 AKDT} - {3528698400 -32400 0 AKST} - {3542612400 -28800 1 AKDT} - {3560148000 -32400 0 AKST} - {3574062000 -28800 1 AKDT} - {3592202400 -32400 0 AKST} - {3605511600 -28800 1 AKDT} - {3623652000 -32400 0 AKST} - {3636961200 -28800 1 AKDT} - {3655101600 -32400 0 AKST} - {3669015600 -28800 1 AKDT} - {3686551200 -32400 0 AKST} - {3700465200 -28800 1 AKDT} - {3718000800 -32400 0 AKST} - {3731914800 -28800 1 AKDT} - {3750055200 -32400 0 AKST} - {3763364400 -28800 1 AKDT} - {3781504800 -32400 0 AKST} - {3794814000 -28800 1 AKDT} - {3812954400 -32400 0 AKST} - {3826263600 -28800 1 AKDT} - {3844404000 -32400 0 AKST} - {3858318000 -28800 1 AKDT} - {3875853600 -32400 0 AKST} - {3889767600 -28800 1 AKDT} - {3907303200 -32400 0 AKST} - {3921217200 -28800 1 AKDT} - {3939357600 -32400 0 AKST} - {3952666800 -28800 1 AKDT} - {3970807200 -32400 0 AKST} - {3984116400 -28800 1 AKDT} - {4002256800 -32400 0 AKST} - {4016170800 -28800 1 AKDT} - {4033706400 -32400 0 AKST} - {4047620400 -28800 1 AKDT} - {4065156000 -32400 0 AKST} - {4079070000 -28800 1 AKDT} - {4096605600 -32400 0 AKST} + {1173610800 -28800 1 AKDT} + {1194170400 -32400 0 AKST} + {1205060400 -28800 1 AKDT} + {1225620000 -32400 0 AKST} + {1236510000 -28800 1 AKDT} + {1257069600 -32400 0 AKST} + {1268564400 -28800 1 AKDT} + {1289124000 -32400 0 AKST} + {1300014000 -28800 1 AKDT} + {1320573600 -32400 0 AKST} + {1331463600 -28800 1 AKDT} + {1352023200 -32400 0 AKST} + {1362913200 -28800 1 AKDT} + {1383472800 -32400 0 AKST} + {1394362800 -28800 1 AKDT} + {1414922400 -32400 0 AKST} + {1425812400 -28800 1 AKDT} + {1446372000 -32400 0 AKST} + {1457866800 -28800 1 AKDT} + {1478426400 -32400 0 AKST} + {1489316400 -28800 1 AKDT} + {1509876000 -32400 0 AKST} + {1520766000 -28800 1 AKDT} + {1541325600 -32400 0 AKST} + {1552215600 -28800 1 AKDT} + {1572775200 -32400 0 AKST} + {1583665200 -28800 1 AKDT} + {1604224800 -32400 0 AKST} + {1615719600 -28800 1 AKDT} + {1636279200 -32400 0 AKST} + {1647169200 -28800 1 AKDT} + {1667728800 -32400 0 AKST} + {1678618800 -28800 1 AKDT} + {1699178400 -32400 0 AKST} + {1710068400 -28800 1 AKDT} + {1730628000 -32400 0 AKST} + {1741518000 -28800 1 AKDT} + {1762077600 -32400 0 AKST} + {1772967600 -28800 1 AKDT} + {1793527200 -32400 0 AKST} + {1805022000 -28800 1 AKDT} + {1825581600 -32400 0 AKST} + {1836471600 -28800 1 AKDT} + {1857031200 -32400 0 AKST} + {1867921200 -28800 1 AKDT} + {1888480800 -32400 0 AKST} + {1899370800 -28800 1 AKDT} + {1919930400 -32400 0 AKST} + {1930820400 -28800 1 AKDT} + {1951380000 -32400 0 AKST} + {1962874800 -28800 1 AKDT} + {1983434400 -32400 0 AKST} + {1994324400 -28800 1 AKDT} + {2014884000 -32400 0 AKST} + {2025774000 -28800 1 AKDT} + {2046333600 -32400 0 AKST} + {2057223600 -28800 1 AKDT} + {2077783200 -32400 0 AKST} + {2088673200 -28800 1 AKDT} + {2109232800 -32400 0 AKST} + {2120122800 -28800 1 AKDT} + {2140682400 -32400 0 AKST} + {2152177200 -28800 1 AKDT} + {2172736800 -32400 0 AKST} + {2183626800 -28800 1 AKDT} + {2204186400 -32400 0 AKST} + {2215076400 -28800 1 AKDT} + {2235636000 -32400 0 AKST} + {2246526000 -28800 1 AKDT} + {2267085600 -32400 0 AKST} + {2277975600 -28800 1 AKDT} + {2298535200 -32400 0 AKST} + {2309425200 -28800 1 AKDT} + {2329984800 -32400 0 AKST} + {2341479600 -28800 1 AKDT} + {2362039200 -32400 0 AKST} + {2372929200 -28800 1 AKDT} + {2393488800 -32400 0 AKST} + {2404378800 -28800 1 AKDT} + {2424938400 -32400 0 AKST} + {2435828400 -28800 1 AKDT} + {2456388000 -32400 0 AKST} + {2467278000 -28800 1 AKDT} + {2487837600 -32400 0 AKST} + {2499332400 -28800 1 AKDT} + {2519892000 -32400 0 AKST} + {2530782000 -28800 1 AKDT} + {2551341600 -32400 0 AKST} + {2562231600 -28800 1 AKDT} + {2582791200 -32400 0 AKST} + {2593681200 -28800 1 AKDT} + {2614240800 -32400 0 AKST} + {2625130800 -28800 1 AKDT} + {2645690400 -32400 0 AKST} + {2656580400 -28800 1 AKDT} + {2677140000 -32400 0 AKST} + {2688634800 -28800 1 AKDT} + {2709194400 -32400 0 AKST} + {2720084400 -28800 1 AKDT} + {2740644000 -32400 0 AKST} + {2751534000 -28800 1 AKDT} + {2772093600 -32400 0 AKST} + {2782983600 -28800 1 AKDT} + {2803543200 -32400 0 AKST} + {2814433200 -28800 1 AKDT} + {2834992800 -32400 0 AKST} + {2846487600 -28800 1 AKDT} + {2867047200 -32400 0 AKST} + {2877937200 -28800 1 AKDT} + {2898496800 -32400 0 AKST} + {2909386800 -28800 1 AKDT} + {2929946400 -32400 0 AKST} + {2940836400 -28800 1 AKDT} + {2961396000 -32400 0 AKST} + {2972286000 -28800 1 AKDT} + {2992845600 -32400 0 AKST} + {3003735600 -28800 1 AKDT} + {3024295200 -32400 0 AKST} + {3035790000 -28800 1 AKDT} + {3056349600 -32400 0 AKST} + {3067239600 -28800 1 AKDT} + {3087799200 -32400 0 AKST} + {3098689200 -28800 1 AKDT} + {3119248800 -32400 0 AKST} + {3130138800 -28800 1 AKDT} + {3150698400 -32400 0 AKST} + {3161588400 -28800 1 AKDT} + {3182148000 -32400 0 AKST} + {3193038000 -28800 1 AKDT} + {3213597600 -32400 0 AKST} + {3225092400 -28800 1 AKDT} + {3245652000 -32400 0 AKST} + {3256542000 -28800 1 AKDT} + {3277101600 -32400 0 AKST} + {3287991600 -28800 1 AKDT} + {3308551200 -32400 0 AKST} + {3319441200 -28800 1 AKDT} + {3340000800 -32400 0 AKST} + {3350890800 -28800 1 AKDT} + {3371450400 -32400 0 AKST} + {3382945200 -28800 1 AKDT} + {3403504800 -32400 0 AKST} + {3414394800 -28800 1 AKDT} + {3434954400 -32400 0 AKST} + {3445844400 -28800 1 AKDT} + {3466404000 -32400 0 AKST} + {3477294000 -28800 1 AKDT} + {3497853600 -32400 0 AKST} + {3508743600 -28800 1 AKDT} + {3529303200 -32400 0 AKST} + {3540193200 -28800 1 AKDT} + {3560752800 -32400 0 AKST} + {3572247600 -28800 1 AKDT} + {3592807200 -32400 0 AKST} + {3603697200 -28800 1 AKDT} + {3624256800 -32400 0 AKST} + {3635146800 -28800 1 AKDT} + {3655706400 -32400 0 AKST} + {3666596400 -28800 1 AKDT} + {3687156000 -32400 0 AKST} + {3698046000 -28800 1 AKDT} + {3718605600 -32400 0 AKST} + {3730100400 -28800 1 AKDT} + {3750660000 -32400 0 AKST} + {3761550000 -28800 1 AKDT} + {3782109600 -32400 0 AKST} + {3792999600 -28800 1 AKDT} + {3813559200 -32400 0 AKST} + {3824449200 -28800 1 AKDT} + {3845008800 -32400 0 AKST} + {3855898800 -28800 1 AKDT} + {3876458400 -32400 0 AKST} + {3887348400 -28800 1 AKDT} + {3907908000 -32400 0 AKST} + {3919402800 -28800 1 AKDT} + {3939962400 -32400 0 AKST} + {3950852400 -28800 1 AKDT} + {3971412000 -32400 0 AKST} + {3982302000 -28800 1 AKDT} + {4002861600 -32400 0 AKST} + {4013751600 -28800 1 AKDT} + {4034311200 -32400 0 AKST} + {4045201200 -28800 1 AKDT} + {4065760800 -32400 0 AKST} + {4076650800 -28800 1 AKDT} + {4097210400 -32400 0 AKST} } Index: library/tzdata/America/North_Dakota/Center ================================================================== --- library/tzdata/America/North_Dakota/Center +++ library/tzdata/America/North_Dakota/Center @@ -1,10 +1,10 @@ # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/North_Dakota/Center) { {-9223372036854775808 -24312 0 LMT} - {-2717644488 -25200 0 MST} + {-2717643600 -25200 0 MST} {-1633273200 -21600 1 MDT} {-1615132800 -25200 0 MST} {-1601823600 -21600 1 MDT} {-1583683200 -25200 0 MST} {-880210800 -21600 1 MWT} @@ -88,192 +88,192 @@ {1099206000 -21600 0 CST} {1112515200 -18000 1 CDT} {1130655600 -21600 0 CST} {1143964800 -18000 1 CDT} {1162105200 -21600 0 CST} - {1175414400 -18000 1 CDT} - {1193554800 -21600 0 CST} - {1207468800 -18000 1 CDT} - {1225004400 -21600 0 CST} - {1238918400 -18000 1 CDT} - {1256454000 -21600 0 CST} - {1270368000 -18000 1 CDT} - {1288508400 -21600 0 CST} - {1301817600 -18000 1 CDT} - {1319958000 -21600 0 CST} - {1333267200 -18000 1 CDT} - {1351407600 -21600 0 CST} - {1365321600 -18000 1 CDT} - {1382857200 -21600 0 CST} - {1396771200 -18000 1 CDT} - {1414306800 -21600 0 CST} - {1428220800 -18000 1 CDT} - {1445756400 -21600 0 CST} - {1459670400 -18000 1 CDT} - {1477810800 -21600 0 CST} - {1491120000 -18000 1 CDT} - {1509260400 -21600 0 CST} - {1522569600 -18000 1 CDT} - {1540710000 -21600 0 CST} - {1554624000 -18000 1 CDT} - {1572159600 -21600 0 CST} - {1586073600 -18000 1 CDT} - {1603609200 -21600 0 CST} - {1617523200 -18000 1 CDT} - {1635663600 -21600 0 CST} - {1648972800 -18000 1 CDT} - {1667113200 -21600 0 CST} - {1680422400 -18000 1 CDT} - {1698562800 -21600 0 CST} - {1712476800 -18000 1 CDT} - {1730012400 -21600 0 CST} - {1743926400 -18000 1 CDT} - {1761462000 -21600 0 CST} - {1775376000 -18000 1 CDT} - {1792911600 -21600 0 CST} - {1806825600 -18000 1 CDT} - {1824966000 -21600 0 CST} - {1838275200 -18000 1 CDT} - {1856415600 -21600 0 CST} - {1869724800 -18000 1 CDT} - {1887865200 -21600 0 CST} - {1901779200 -18000 1 CDT} - {1919314800 -21600 0 CST} - {1933228800 -18000 1 CDT} - {1950764400 -21600 0 CST} - {1964678400 -18000 1 CDT} - {1982818800 -21600 0 CST} - {1996128000 -18000 1 CDT} - {2014268400 -21600 0 CST} - {2027577600 -18000 1 CDT} - {2045718000 -21600 0 CST} - {2059027200 -18000 1 CDT} - {2077167600 -21600 0 CST} - {2091081600 -18000 1 CDT} - {2108617200 -21600 0 CST} - {2122531200 -18000 1 CDT} - {2140066800 -21600 0 CST} - {2153980800 -18000 1 CDT} - {2172121200 -21600 0 CST} - {2185430400 -18000 1 CDT} - {2203570800 -21600 0 CST} - {2216880000 -18000 1 CDT} - {2235020400 -21600 0 CST} - {2248934400 -18000 1 CDT} - {2266470000 -21600 0 CST} - {2280384000 -18000 1 CDT} - {2297919600 -21600 0 CST} - {2311833600 -18000 1 CDT} - {2329369200 -21600 0 CST} - {2343283200 -18000 1 CDT} - {2361423600 -21600 0 CST} - {2374732800 -18000 1 CDT} - {2392873200 -21600 0 CST} - {2406182400 -18000 1 CDT} - {2424322800 -21600 0 CST} - {2438236800 -18000 1 CDT} - {2455772400 -21600 0 CST} - {2469686400 -18000 1 CDT} - {2487222000 -21600 0 CST} - {2501136000 -18000 1 CDT} - {2519276400 -21600 0 CST} - {2532585600 -18000 1 CDT} - {2550726000 -21600 0 CST} - {2564035200 -18000 1 CDT} - {2582175600 -21600 0 CST} - {2596089600 -18000 1 CDT} - {2613625200 -21600 0 CST} - {2627539200 -18000 1 CDT} - {2645074800 -21600 0 CST} - {2658988800 -18000 1 CDT} - {2676524400 -21600 0 CST} - {2690438400 -18000 1 CDT} - {2708578800 -21600 0 CST} - {2721888000 -18000 1 CDT} - {2740028400 -21600 0 CST} - {2753337600 -18000 1 CDT} - {2771478000 -21600 0 CST} - {2785392000 -18000 1 CDT} - {2802927600 -21600 0 CST} - {2816841600 -18000 1 CDT} - {2834377200 -21600 0 CST} - {2848291200 -18000 1 CDT} - {2866431600 -21600 0 CST} - {2879740800 -18000 1 CDT} - {2897881200 -21600 0 CST} - {2911190400 -18000 1 CDT} - {2929330800 -21600 0 CST} - {2942640000 -18000 1 CDT} - {2960780400 -21600 0 CST} - {2974694400 -18000 1 CDT} - {2992230000 -21600 0 CST} - {3006144000 -18000 1 CDT} - {3023679600 -21600 0 CST} - {3037593600 -18000 1 CDT} - {3055734000 -21600 0 CST} - {3069043200 -18000 1 CDT} - {3087183600 -21600 0 CST} - {3100492800 -18000 1 CDT} - {3118633200 -21600 0 CST} - {3132547200 -18000 1 CDT} - {3150082800 -21600 0 CST} - {3163996800 -18000 1 CDT} - {3181532400 -21600 0 CST} - {3195446400 -18000 1 CDT} - {3212982000 -21600 0 CST} - {3226896000 -18000 1 CDT} - {3245036400 -21600 0 CST} - {3258345600 -18000 1 CDT} - {3276486000 -21600 0 CST} - {3289795200 -18000 1 CDT} - {3307935600 -21600 0 CST} - {3321849600 -18000 1 CDT} - {3339385200 -21600 0 CST} - {3353299200 -18000 1 CDT} - {3370834800 -21600 0 CST} - {3384748800 -18000 1 CDT} - {3402889200 -21600 0 CST} - {3416198400 -18000 1 CDT} - {3434338800 -21600 0 CST} - {3447648000 -18000 1 CDT} - {3465788400 -21600 0 CST} - {3479702400 -18000 1 CDT} - {3497238000 -21600 0 CST} - {3511152000 -18000 1 CDT} - {3528687600 -21600 0 CST} - {3542601600 -18000 1 CDT} - {3560137200 -21600 0 CST} - {3574051200 -18000 1 CDT} - {3592191600 -21600 0 CST} - {3605500800 -18000 1 CDT} - {3623641200 -21600 0 CST} - {3636950400 -18000 1 CDT} - {3655090800 -21600 0 CST} - {3669004800 -18000 1 CDT} - {3686540400 -21600 0 CST} - {3700454400 -18000 1 CDT} - {3717990000 -21600 0 CST} - {3731904000 -18000 1 CDT} - {3750044400 -21600 0 CST} - {3763353600 -18000 1 CDT} - {3781494000 -21600 0 CST} - {3794803200 -18000 1 CDT} - {3812943600 -21600 0 CST} - {3826252800 -18000 1 CDT} - {3844393200 -21600 0 CST} - {3858307200 -18000 1 CDT} - {3875842800 -21600 0 CST} - {3889756800 -18000 1 CDT} - {3907292400 -21600 0 CST} - {3921206400 -18000 1 CDT} - {3939346800 -21600 0 CST} - {3952656000 -18000 1 CDT} - {3970796400 -21600 0 CST} - {3984105600 -18000 1 CDT} - {4002246000 -21600 0 CST} - {4016160000 -18000 1 CDT} - {4033695600 -21600 0 CST} - {4047609600 -18000 1 CDT} - {4065145200 -21600 0 CST} - {4079059200 -18000 1 CDT} - {4096594800 -21600 0 CST} + {1173600000 -18000 1 CDT} + {1194159600 -21600 0 CST} + {1205049600 -18000 1 CDT} + {1225609200 -21600 0 CST} + {1236499200 -18000 1 CDT} + {1257058800 -21600 0 CST} + {1268553600 -18000 1 CDT} + {1289113200 -21600 0 CST} + {1300003200 -18000 1 CDT} + {1320562800 -21600 0 CST} + {1331452800 -18000 1 CDT} + {1352012400 -21600 0 CST} + {1362902400 -18000 1 CDT} + {1383462000 -21600 0 CST} + {1394352000 -18000 1 CDT} + {1414911600 -21600 0 CST} + {1425801600 -18000 1 CDT} + {1446361200 -21600 0 CST} + {1457856000 -18000 1 CDT} + {1478415600 -21600 0 CST} + {1489305600 -18000 1 CDT} + {1509865200 -21600 0 CST} + {1520755200 -18000 1 CDT} + {1541314800 -21600 0 CST} + {1552204800 -18000 1 CDT} + {1572764400 -21600 0 CST} + {1583654400 -18000 1 CDT} + {1604214000 -21600 0 CST} + {1615708800 -18000 1 CDT} + {1636268400 -21600 0 CST} + {1647158400 -18000 1 CDT} + {1667718000 -21600 0 CST} + {1678608000 -18000 1 CDT} + {1699167600 -21600 0 CST} + {1710057600 -18000 1 CDT} + {1730617200 -21600 0 CST} + {1741507200 -18000 1 CDT} + {1762066800 -21600 0 CST} + {1772956800 -18000 1 CDT} + {1793516400 -21600 0 CST} + {1805011200 -18000 1 CDT} + {1825570800 -21600 0 CST} + {1836460800 -18000 1 CDT} + {1857020400 -21600 0 CST} + {1867910400 -18000 1 CDT} + {1888470000 -21600 0 CST} + {1899360000 -18000 1 CDT} + {1919919600 -21600 0 CST} + {1930809600 -18000 1 CDT} + {1951369200 -21600 0 CST} + {1962864000 -18000 1 CDT} + {1983423600 -21600 0 CST} + {1994313600 -18000 1 CDT} + {2014873200 -21600 0 CST} + {2025763200 -18000 1 CDT} + {2046322800 -21600 0 CST} + {2057212800 -18000 1 CDT} + {2077772400 -21600 0 CST} + {2088662400 -18000 1 CDT} + {2109222000 -21600 0 CST} + {2120112000 -18000 1 CDT} + {2140671600 -21600 0 CST} + {2152166400 -18000 1 CDT} + {2172726000 -21600 0 CST} + {2183616000 -18000 1 CDT} + {2204175600 -21600 0 CST} + {2215065600 -18000 1 CDT} + {2235625200 -21600 0 CST} + {2246515200 -18000 1 CDT} + {2267074800 -21600 0 CST} + {2277964800 -18000 1 CDT} + {2298524400 -21600 0 CST} + {2309414400 -18000 1 CDT} + {2329974000 -21600 0 CST} + {2341468800 -18000 1 CDT} + {2362028400 -21600 0 CST} + {2372918400 -18000 1 CDT} + {2393478000 -21600 0 CST} + {2404368000 -18000 1 CDT} + {2424927600 -21600 0 CST} + {2435817600 -18000 1 CDT} + {2456377200 -21600 0 CST} + {2467267200 -18000 1 CDT} + {2487826800 -21600 0 CST} + {2499321600 -18000 1 CDT} + {2519881200 -21600 0 CST} + {2530771200 -18000 1 CDT} + {2551330800 -21600 0 CST} + {2562220800 -18000 1 CDT} + {2582780400 -21600 0 CST} + {2593670400 -18000 1 CDT} + {2614230000 -21600 0 CST} + {2625120000 -18000 1 CDT} + {2645679600 -21600 0 CST} + {2656569600 -18000 1 CDT} + {2677129200 -21600 0 CST} + {2688624000 -18000 1 CDT} + {2709183600 -21600 0 CST} + {2720073600 -18000 1 CDT} + {2740633200 -21600 0 CST} + {2751523200 -18000 1 CDT} + {2772082800 -21600 0 CST} + {2782972800 -18000 1 CDT} + {2803532400 -21600 0 CST} + {2814422400 -18000 1 CDT} + {2834982000 -21600 0 CST} + {2846476800 -18000 1 CDT} + {2867036400 -21600 0 CST} + {2877926400 -18000 1 CDT} + {2898486000 -21600 0 CST} + {2909376000 -18000 1 CDT} + {2929935600 -21600 0 CST} + {2940825600 -18000 1 CDT} + {2961385200 -21600 0 CST} + {2972275200 -18000 1 CDT} + {2992834800 -21600 0 CST} + {3003724800 -18000 1 CDT} + {3024284400 -21600 0 CST} + {3035779200 -18000 1 CDT} + {3056338800 -21600 0 CST} + {3067228800 -18000 1 CDT} + {3087788400 -21600 0 CST} + {3098678400 -18000 1 CDT} + {3119238000 -21600 0 CST} + {3130128000 -18000 1 CDT} + {3150687600 -21600 0 CST} + {3161577600 -18000 1 CDT} + {3182137200 -21600 0 CST} + {3193027200 -18000 1 CDT} + {3213586800 -21600 0 CST} + {3225081600 -18000 1 CDT} + {3245641200 -21600 0 CST} + {3256531200 -18000 1 CDT} + {3277090800 -21600 0 CST} + {3287980800 -18000 1 CDT} + {3308540400 -21600 0 CST} + {3319430400 -18000 1 CDT} + {3339990000 -21600 0 CST} + {3350880000 -18000 1 CDT} + {3371439600 -21600 0 CST} + {3382934400 -18000 1 CDT} + {3403494000 -21600 0 CST} + {3414384000 -18000 1 CDT} + {3434943600 -21600 0 CST} + {3445833600 -18000 1 CDT} + {3466393200 -21600 0 CST} + {3477283200 -18000 1 CDT} + {3497842800 -21600 0 CST} + {3508732800 -18000 1 CDT} + {3529292400 -21600 0 CST} + {3540182400 -18000 1 CDT} + {3560742000 -21600 0 CST} + {3572236800 -18000 1 CDT} + {3592796400 -21600 0 CST} + {3603686400 -18000 1 CDT} + {3624246000 -21600 0 CST} + {3635136000 -18000 1 CDT} + {3655695600 -21600 0 CST} + {3666585600 -18000 1 CDT} + {3687145200 -21600 0 CST} + {3698035200 -18000 1 CDT} + {3718594800 -21600 0 CST} + {3730089600 -18000 1 CDT} + {3750649200 -21600 0 CST} + {3761539200 -18000 1 CDT} + {3782098800 -21600 0 CST} + {3792988800 -18000 1 CDT} + {3813548400 -21600 0 CST} + {3824438400 -18000 1 CDT} + {3844998000 -21600 0 CST} + {3855888000 -18000 1 CDT} + {3876447600 -21600 0 CST} + {3887337600 -18000 1 CDT} + {3907897200 -21600 0 CST} + {3919392000 -18000 1 CDT} + {3939951600 -21600 0 CST} + {3950841600 -18000 1 CDT} + {3971401200 -21600 0 CST} + {3982291200 -18000 1 CDT} + {4002850800 -21600 0 CST} + {4013740800 -18000 1 CDT} + {4034300400 -21600 0 CST} + {4045190400 -18000 1 CDT} + {4065750000 -21600 0 CST} + {4076640000 -18000 1 CDT} + {4097199600 -21600 0 CST} } Index: library/tzdata/America/Phoenix ================================================================== --- library/tzdata/America/Phoenix +++ library/tzdata/America/Phoenix @@ -1,10 +1,10 @@ # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Phoenix) { {-9223372036854775808 -26898 0 LMT} - {-2717641902 -25200 0 MST} + {-2717643600 -25200 0 MST} {-1633273200 -21600 1 MDT} {-1615132800 -25200 0 MST} {-1601823600 -21600 1 MDT} {-1583683200 -25200 0 MST} {-880210800 -21600 1 MWT} Index: library/tzdata/America/Port-au-Prince ================================================================== --- library/tzdata/America/Port-au-Prince +++ library/tzdata/America/Port-au-Prince @@ -32,6 +32,8 @@ {814928400 -18000 0 EST} {828838800 -14400 1 EDT} {846378000 -18000 0 EST} {860288400 -14400 1 EDT} {877827600 -18000 0 EST} + {1112504400 -14400 1 EDT} + {1130644800 -18000 0 EST} } Index: library/tzdata/America/Rosario ================================================================== --- library/tzdata/America/Rosario +++ library/tzdata/America/Rosario @@ -1,5 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Cordoba)]} { - LoadTimeZoneFile America/Cordoba +if {![info exists TZData(America/Argentina/Cordoba)]} { + LoadTimeZoneFile America/Argentina/Cordoba } -set TZData(:America/Rosario) $TZData(:America/Cordoba) +set TZData(:America/Rosario) $TZData(:America/Argentina/Cordoba) Index: library/tzdata/America/Yakutat ================================================================== --- library/tzdata/America/Yakutat +++ library/tzdata/America/Yakutat @@ -85,192 +85,192 @@ {1099216800 -32400 0 AKST} {1112526000 -28800 1 AKDT} {1130666400 -32400 0 AKST} {1143975600 -28800 1 AKDT} {1162116000 -32400 0 AKST} - {1175425200 -28800 1 AKDT} - {1193565600 -32400 0 AKST} - {1207479600 -28800 1 AKDT} - {1225015200 -32400 0 AKST} - {1238929200 -28800 1 AKDT} - {1256464800 -32400 0 AKST} - {1270378800 -28800 1 AKDT} - {1288519200 -32400 0 AKST} - {1301828400 -28800 1 AKDT} - {1319968800 -32400 0 AKST} - {1333278000 -28800 1 AKDT} - {1351418400 -32400 0 AKST} - {1365332400 -28800 1 AKDT} - {1382868000 -32400 0 AKST} - {1396782000 -28800 1 AKDT} - {1414317600 -32400 0 AKST} - {1428231600 -28800 1 AKDT} - {1445767200 -32400 0 AKST} - {1459681200 -28800 1 AKDT} - {1477821600 -32400 0 AKST} - {1491130800 -28800 1 AKDT} - {1509271200 -32400 0 AKST} - {1522580400 -28800 1 AKDT} - {1540720800 -32400 0 AKST} - {1554634800 -28800 1 AKDT} - {1572170400 -32400 0 AKST} - {1586084400 -28800 1 AKDT} - {1603620000 -32400 0 AKST} - {1617534000 -28800 1 AKDT} - {1635674400 -32400 0 AKST} - {1648983600 -28800 1 AKDT} - {1667124000 -32400 0 AKST} - {1680433200 -28800 1 AKDT} - {1698573600 -32400 0 AKST} - {1712487600 -28800 1 AKDT} - {1730023200 -32400 0 AKST} - {1743937200 -28800 1 AKDT} - {1761472800 -32400 0 AKST} - {1775386800 -28800 1 AKDT} - {1792922400 -32400 0 AKST} - {1806836400 -28800 1 AKDT} - {1824976800 -32400 0 AKST} - {1838286000 -28800 1 AKDT} - {1856426400 -32400 0 AKST} - {1869735600 -28800 1 AKDT} - {1887876000 -32400 0 AKST} - {1901790000 -28800 1 AKDT} - {1919325600 -32400 0 AKST} - {1933239600 -28800 1 AKDT} - {1950775200 -32400 0 AKST} - {1964689200 -28800 1 AKDT} - {1982829600 -32400 0 AKST} - {1996138800 -28800 1 AKDT} - {2014279200 -32400 0 AKST} - {2027588400 -28800 1 AKDT} - {2045728800 -32400 0 AKST} - {2059038000 -28800 1 AKDT} - {2077178400 -32400 0 AKST} - {2091092400 -28800 1 AKDT} - {2108628000 -32400 0 AKST} - {2122542000 -28800 1 AKDT} - {2140077600 -32400 0 AKST} - {2153991600 -28800 1 AKDT} - {2172132000 -32400 0 AKST} - {2185441200 -28800 1 AKDT} - {2203581600 -32400 0 AKST} - {2216890800 -28800 1 AKDT} - {2235031200 -32400 0 AKST} - {2248945200 -28800 1 AKDT} - {2266480800 -32400 0 AKST} - {2280394800 -28800 1 AKDT} - {2297930400 -32400 0 AKST} - {2311844400 -28800 1 AKDT} - {2329380000 -32400 0 AKST} - {2343294000 -28800 1 AKDT} - {2361434400 -32400 0 AKST} - {2374743600 -28800 1 AKDT} - {2392884000 -32400 0 AKST} - {2406193200 -28800 1 AKDT} - {2424333600 -32400 0 AKST} - {2438247600 -28800 1 AKDT} - {2455783200 -32400 0 AKST} - {2469697200 -28800 1 AKDT} - {2487232800 -32400 0 AKST} - {2501146800 -28800 1 AKDT} - {2519287200 -32400 0 AKST} - {2532596400 -28800 1 AKDT} - {2550736800 -32400 0 AKST} - {2564046000 -28800 1 AKDT} - {2582186400 -32400 0 AKST} - {2596100400 -28800 1 AKDT} - {2613636000 -32400 0 AKST} - {2627550000 -28800 1 AKDT} - {2645085600 -32400 0 AKST} - {2658999600 -28800 1 AKDT} - {2676535200 -32400 0 AKST} - {2690449200 -28800 1 AKDT} - {2708589600 -32400 0 AKST} - {2721898800 -28800 1 AKDT} - {2740039200 -32400 0 AKST} - {2753348400 -28800 1 AKDT} - {2771488800 -32400 0 AKST} - {2785402800 -28800 1 AKDT} - {2802938400 -32400 0 AKST} - {2816852400 -28800 1 AKDT} - {2834388000 -32400 0 AKST} - {2848302000 -28800 1 AKDT} - {2866442400 -32400 0 AKST} - {2879751600 -28800 1 AKDT} - {2897892000 -32400 0 AKST} - {2911201200 -28800 1 AKDT} - {2929341600 -32400 0 AKST} - {2942650800 -28800 1 AKDT} - {2960791200 -32400 0 AKST} - {2974705200 -28800 1 AKDT} - {2992240800 -32400 0 AKST} - {3006154800 -28800 1 AKDT} - {3023690400 -32400 0 AKST} - {3037604400 -28800 1 AKDT} - {3055744800 -32400 0 AKST} - {3069054000 -28800 1 AKDT} - {3087194400 -32400 0 AKST} - {3100503600 -28800 1 AKDT} - {3118644000 -32400 0 AKST} - {3132558000 -28800 1 AKDT} - {3150093600 -32400 0 AKST} - {3164007600 -28800 1 AKDT} - {3181543200 -32400 0 AKST} - {3195457200 -28800 1 AKDT} - {3212992800 -32400 0 AKST} - {3226906800 -28800 1 AKDT} - {3245047200 -32400 0 AKST} - {3258356400 -28800 1 AKDT} - {3276496800 -32400 0 AKST} - {3289806000 -28800 1 AKDT} - {3307946400 -32400 0 AKST} - {3321860400 -28800 1 AKDT} - {3339396000 -32400 0 AKST} - {3353310000 -28800 1 AKDT} - {3370845600 -32400 0 AKST} - {3384759600 -28800 1 AKDT} - {3402900000 -32400 0 AKST} - {3416209200 -28800 1 AKDT} - {3434349600 -32400 0 AKST} - {3447658800 -28800 1 AKDT} - {3465799200 -32400 0 AKST} - {3479713200 -28800 1 AKDT} - {3497248800 -32400 0 AKST} - {3511162800 -28800 1 AKDT} - {3528698400 -32400 0 AKST} - {3542612400 -28800 1 AKDT} - {3560148000 -32400 0 AKST} - {3574062000 -28800 1 AKDT} - {3592202400 -32400 0 AKST} - {3605511600 -28800 1 AKDT} - {3623652000 -32400 0 AKST} - {3636961200 -28800 1 AKDT} - {3655101600 -32400 0 AKST} - {3669015600 -28800 1 AKDT} - {3686551200 -32400 0 AKST} - {3700465200 -28800 1 AKDT} - {3718000800 -32400 0 AKST} - {3731914800 -28800 1 AKDT} - {3750055200 -32400 0 AKST} - {3763364400 -28800 1 AKDT} - {3781504800 -32400 0 AKST} - {3794814000 -28800 1 AKDT} - {3812954400 -32400 0 AKST} - {3826263600 -28800 1 AKDT} - {3844404000 -32400 0 AKST} - {3858318000 -28800 1 AKDT} - {3875853600 -32400 0 AKST} - {3889767600 -28800 1 AKDT} - {3907303200 -32400 0 AKST} - {3921217200 -28800 1 AKDT} - {3939357600 -32400 0 AKST} - {3952666800 -28800 1 AKDT} - {3970807200 -32400 0 AKST} - {3984116400 -28800 1 AKDT} - {4002256800 -32400 0 AKST} - {4016170800 -28800 1 AKDT} - {4033706400 -32400 0 AKST} - {4047620400 -28800 1 AKDT} - {4065156000 -32400 0 AKST} - {4079070000 -28800 1 AKDT} - {4096605600 -32400 0 AKST} + {1173610800 -28800 1 AKDT} + {1194170400 -32400 0 AKST} + {1205060400 -28800 1 AKDT} + {1225620000 -32400 0 AKST} + {1236510000 -28800 1 AKDT} + {1257069600 -32400 0 AKST} + {1268564400 -28800 1 AKDT} + {1289124000 -32400 0 AKST} + {1300014000 -28800 1 AKDT} + {1320573600 -32400 0 AKST} + {1331463600 -28800 1 AKDT} + {1352023200 -32400 0 AKST} + {1362913200 -28800 1 AKDT} + {1383472800 -32400 0 AKST} + {1394362800 -28800 1 AKDT} + {1414922400 -32400 0 AKST} + {1425812400 -28800 1 AKDT} + {1446372000 -32400 0 AKST} + {1457866800 -28800 1 AKDT} + {1478426400 -32400 0 AKST} + {1489316400 -28800 1 AKDT} + {1509876000 -32400 0 AKST} + {1520766000 -28800 1 AKDT} + {1541325600 -32400 0 AKST} + {1552215600 -28800 1 AKDT} + {1572775200 -32400 0 AKST} + {1583665200 -28800 1 AKDT} + {1604224800 -32400 0 AKST} + {1615719600 -28800 1 AKDT} + {1636279200 -32400 0 AKST} + {1647169200 -28800 1 AKDT} + {1667728800 -32400 0 AKST} + {1678618800 -28800 1 AKDT} + {1699178400 -32400 0 AKST} + {1710068400 -28800 1 AKDT} + {1730628000 -32400 0 AKST} + {1741518000 -28800 1 AKDT} + {1762077600 -32400 0 AKST} + {1772967600 -28800 1 AKDT} + {1793527200 -32400 0 AKST} + {1805022000 -28800 1 AKDT} + {1825581600 -32400 0 AKST} + {1836471600 -28800 1 AKDT} + {1857031200 -32400 0 AKST} + {1867921200 -28800 1 AKDT} + {1888480800 -32400 0 AKST} + {1899370800 -28800 1 AKDT} + {1919930400 -32400 0 AKST} + {1930820400 -28800 1 AKDT} + {1951380000 -32400 0 AKST} + {1962874800 -28800 1 AKDT} + {1983434400 -32400 0 AKST} + {1994324400 -28800 1 AKDT} + {2014884000 -32400 0 AKST} + {2025774000 -28800 1 AKDT} + {2046333600 -32400 0 AKST} + {2057223600 -28800 1 AKDT} + {2077783200 -32400 0 AKST} + {2088673200 -28800 1 AKDT} + {2109232800 -32400 0 AKST} + {2120122800 -28800 1 AKDT} + {2140682400 -32400 0 AKST} + {2152177200 -28800 1 AKDT} + {2172736800 -32400 0 AKST} + {2183626800 -28800 1 AKDT} + {2204186400 -32400 0 AKST} + {2215076400 -28800 1 AKDT} + {2235636000 -32400 0 AKST} + {2246526000 -28800 1 AKDT} + {2267085600 -32400 0 AKST} + {2277975600 -28800 1 AKDT} + {2298535200 -32400 0 AKST} + {2309425200 -28800 1 AKDT} + {2329984800 -32400 0 AKST} + {2341479600 -28800 1 AKDT} + {2362039200 -32400 0 AKST} + {2372929200 -28800 1 AKDT} + {2393488800 -32400 0 AKST} + {2404378800 -28800 1 AKDT} + {2424938400 -32400 0 AKST} + {2435828400 -28800 1 AKDT} + {2456388000 -32400 0 AKST} + {2467278000 -28800 1 AKDT} + {2487837600 -32400 0 AKST} + {2499332400 -28800 1 AKDT} + {2519892000 -32400 0 AKST} + {2530782000 -28800 1 AKDT} + {2551341600 -32400 0 AKST} + {2562231600 -28800 1 AKDT} + {2582791200 -32400 0 AKST} + {2593681200 -28800 1 AKDT} + {2614240800 -32400 0 AKST} + {2625130800 -28800 1 AKDT} + {2645690400 -32400 0 AKST} + {2656580400 -28800 1 AKDT} + {2677140000 -32400 0 AKST} + {2688634800 -28800 1 AKDT} + {2709194400 -32400 0 AKST} + {2720084400 -28800 1 AKDT} + {2740644000 -32400 0 AKST} + {2751534000 -28800 1 AKDT} + {2772093600 -32400 0 AKST} + {2782983600 -28800 1 AKDT} + {2803543200 -32400 0 AKST} + {2814433200 -28800 1 AKDT} + {2834992800 -32400 0 AKST} + {2846487600 -28800 1 AKDT} + {2867047200 -32400 0 AKST} + {2877937200 -28800 1 AKDT} + {2898496800 -32400 0 AKST} + {2909386800 -28800 1 AKDT} + {2929946400 -32400 0 AKST} + {2940836400 -28800 1 AKDT} + {2961396000 -32400 0 AKST} + {2972286000 -28800 1 AKDT} + {2992845600 -32400 0 AKST} + {3003735600 -28800 1 AKDT} + {3024295200 -32400 0 AKST} + {3035790000 -28800 1 AKDT} + {3056349600 -32400 0 AKST} + {3067239600 -28800 1 AKDT} + {3087799200 -32400 0 AKST} + {3098689200 -28800 1 AKDT} + {3119248800 -32400 0 AKST} + {3130138800 -28800 1 AKDT} + {3150698400 -32400 0 AKST} + {3161588400 -28800 1 AKDT} + {3182148000 -32400 0 AKST} + {3193038000 -28800 1 AKDT} + {3213597600 -32400 0 AKST} + {3225092400 -28800 1 AKDT} + {3245652000 -32400 0 AKST} + {3256542000 -28800 1 AKDT} + {3277101600 -32400 0 AKST} + {3287991600 -28800 1 AKDT} + {3308551200 -32400 0 AKST} + {3319441200 -28800 1 AKDT} + {3340000800 -32400 0 AKST} + {3350890800 -28800 1 AKDT} + {3371450400 -32400 0 AKST} + {3382945200 -28800 1 AKDT} + {3403504800 -32400 0 AKST} + {3414394800 -28800 1 AKDT} + {3434954400 -32400 0 AKST} + {3445844400 -28800 1 AKDT} + {3466404000 -32400 0 AKST} + {3477294000 -28800 1 AKDT} + {3497853600 -32400 0 AKST} + {3508743600 -28800 1 AKDT} + {3529303200 -32400 0 AKST} + {3540193200 -28800 1 AKDT} + {3560752800 -32400 0 AKST} + {3572247600 -28800 1 AKDT} + {3592807200 -32400 0 AKST} + {3603697200 -28800 1 AKDT} + {3624256800 -32400 0 AKST} + {3635146800 -28800 1 AKDT} + {3655706400 -32400 0 AKST} + {3666596400 -28800 1 AKDT} + {3687156000 -32400 0 AKST} + {3698046000 -28800 1 AKDT} + {3718605600 -32400 0 AKST} + {3730100400 -28800 1 AKDT} + {3750660000 -32400 0 AKST} + {3761550000 -28800 1 AKDT} + {3782109600 -32400 0 AKST} + {3792999600 -28800 1 AKDT} + {3813559200 -32400 0 AKST} + {3824449200 -28800 1 AKDT} + {3845008800 -32400 0 AKST} + {3855898800 -28800 1 AKDT} + {3876458400 -32400 0 AKST} + {3887348400 -28800 1 AKDT} + {3907908000 -32400 0 AKST} + {3919402800 -28800 1 AKDT} + {3939962400 -32400 0 AKST} + {3950852400 -28800 1 AKDT} + {3971412000 -32400 0 AKST} + {3982302000 -28800 1 AKDT} + {4002861600 -32400 0 AKST} + {4013751600 -28800 1 AKDT} + {4034311200 -32400 0 AKST} + {4045201200 -28800 1 AKDT} + {4065760800 -32400 0 AKST} + {4076650800 -28800 1 AKDT} + {4097210400 -32400 0 AKST} } Index: library/tzdata/Asia/Almaty ================================================================== --- library/tzdata/Asia/Almaty +++ library/tzdata/Asia/Almaty @@ -50,196 +50,7 @@ {1035684000 21600 0 ALMT} {1048989600 25200 1 ALMST} {1067133600 21600 0 ALMT} {1080439200 25200 1 ALMST} {1099188000 21600 0 ALMT} - {1111888800 25200 1 ALMST} - {1130637600 21600 0 ALMT} - {1143338400 25200 1 ALMST} - {1162087200 21600 0 ALMT} - {1174788000 25200 1 ALMST} - {1193536800 21600 0 ALMT} - {1206842400 25200 1 ALMST} - {1224986400 21600 0 ALMT} - {1238292000 25200 1 ALMST} - {1256436000 21600 0 ALMT} - {1269741600 25200 1 ALMST} - {1288490400 21600 0 ALMT} - {1301191200 25200 1 ALMST} - {1319940000 21600 0 ALMT} - {1332640800 25200 1 ALMST} - {1351389600 21600 0 ALMT} - {1364695200 25200 1 ALMST} - {1382839200 21600 0 ALMT} - {1396144800 25200 1 ALMST} - {1414288800 21600 0 ALMT} - {1427594400 25200 1 ALMST} - {1445738400 21600 0 ALMT} - {1459044000 25200 1 ALMST} - {1477792800 21600 0 ALMT} - {1490493600 25200 1 ALMST} - {1509242400 21600 0 ALMT} - {1521943200 25200 1 ALMST} - {1540692000 21600 0 ALMT} - {1553997600 25200 1 ALMST} - {1572141600 21600 0 ALMT} - {1585447200 25200 1 ALMST} - {1603591200 21600 0 ALMT} - {1616896800 25200 1 ALMST} - {1635645600 21600 0 ALMT} - {1648346400 25200 1 ALMST} - {1667095200 21600 0 ALMT} - {1679796000 25200 1 ALMST} - {1698544800 21600 0 ALMT} - {1711850400 25200 1 ALMST} - {1729994400 21600 0 ALMT} - {1743300000 25200 1 ALMST} - {1761444000 21600 0 ALMT} - {1774749600 25200 1 ALMST} - {1792893600 21600 0 ALMT} - {1806199200 25200 1 ALMST} - {1824948000 21600 0 ALMT} - {1837648800 25200 1 ALMST} - {1856397600 21600 0 ALMT} - {1869098400 25200 1 ALMST} - {1887847200 21600 0 ALMT} - {1901152800 25200 1 ALMST} - {1919296800 21600 0 ALMT} - {1932602400 25200 1 ALMST} - {1950746400 21600 0 ALMT} - {1964052000 25200 1 ALMST} - {1982800800 21600 0 ALMT} - {1995501600 25200 1 ALMST} - {2014250400 21600 0 ALMT} - {2026951200 25200 1 ALMST} - {2045700000 21600 0 ALMT} - {2058400800 25200 1 ALMST} - {2077149600 21600 0 ALMT} - {2090455200 25200 1 ALMST} - {2108599200 21600 0 ALMT} - {2121904800 25200 1 ALMST} - {2140048800 21600 0 ALMT} - {2153354400 25200 1 ALMST} - {2172103200 21600 0 ALMT} - {2184804000 25200 1 ALMST} - {2203552800 21600 0 ALMT} - {2216253600 25200 1 ALMST} - {2235002400 21600 0 ALMT} - {2248308000 25200 1 ALMST} - {2266452000 21600 0 ALMT} - {2279757600 25200 1 ALMST} - {2297901600 21600 0 ALMT} - {2311207200 25200 1 ALMST} - {2329351200 21600 0 ALMT} - {2342656800 25200 1 ALMST} - {2361405600 21600 0 ALMT} - {2374106400 25200 1 ALMST} - {2392855200 21600 0 ALMT} - {2405556000 25200 1 ALMST} - {2424304800 21600 0 ALMT} - {2437610400 25200 1 ALMST} - {2455754400 21600 0 ALMT} - {2469060000 25200 1 ALMST} - {2487204000 21600 0 ALMT} - {2500509600 25200 1 ALMST} - {2519258400 21600 0 ALMT} - {2531959200 25200 1 ALMST} - {2550708000 21600 0 ALMT} - {2563408800 25200 1 ALMST} - {2582157600 21600 0 ALMT} - {2595463200 25200 1 ALMST} - {2613607200 21600 0 ALMT} - {2626912800 25200 1 ALMST} - {2645056800 21600 0 ALMT} - {2658362400 25200 1 ALMST} - {2676506400 21600 0 ALMT} - {2689812000 25200 1 ALMST} - {2708560800 21600 0 ALMT} - {2721261600 25200 1 ALMST} - {2740010400 21600 0 ALMT} - {2752711200 25200 1 ALMST} - {2771460000 21600 0 ALMT} - {2784765600 25200 1 ALMST} - {2802909600 21600 0 ALMT} - {2816215200 25200 1 ALMST} - {2834359200 21600 0 ALMT} - {2847664800 25200 1 ALMST} - {2866413600 21600 0 ALMT} - {2879114400 25200 1 ALMST} - {2897863200 21600 0 ALMT} - {2910564000 25200 1 ALMST} - {2929312800 21600 0 ALMT} - {2942013600 25200 1 ALMST} - {2960762400 21600 0 ALMT} - {2974068000 25200 1 ALMST} - {2992212000 21600 0 ALMT} - {3005517600 25200 1 ALMST} - {3023661600 21600 0 ALMT} - {3036967200 25200 1 ALMST} - {3055716000 21600 0 ALMT} - {3068416800 25200 1 ALMST} - {3087165600 21600 0 ALMT} - {3099866400 25200 1 ALMST} - {3118615200 21600 0 ALMT} - {3131920800 25200 1 ALMST} - {3150064800 21600 0 ALMT} - {3163370400 25200 1 ALMST} - {3181514400 21600 0 ALMT} - {3194820000 25200 1 ALMST} - {3212964000 21600 0 ALMT} - {3226269600 25200 1 ALMST} - {3245018400 21600 0 ALMT} - {3257719200 25200 1 ALMST} - {3276468000 21600 0 ALMT} - {3289168800 25200 1 ALMST} - {3307917600 21600 0 ALMT} - {3321223200 25200 1 ALMST} - {3339367200 21600 0 ALMT} - {3352672800 25200 1 ALMST} - {3370816800 21600 0 ALMT} - {3384122400 25200 1 ALMST} - {3402871200 21600 0 ALMT} - {3415572000 25200 1 ALMST} - {3434320800 21600 0 ALMT} - {3447021600 25200 1 ALMST} - {3465770400 21600 0 ALMT} - {3479076000 25200 1 ALMST} - {3497220000 21600 0 ALMT} - {3510525600 25200 1 ALMST} - {3528669600 21600 0 ALMT} - {3541975200 25200 1 ALMST} - {3560119200 21600 0 ALMT} - {3573424800 25200 1 ALMST} - {3592173600 21600 0 ALMT} - {3604874400 25200 1 ALMST} - {3623623200 21600 0 ALMT} - {3636324000 25200 1 ALMST} - {3655072800 21600 0 ALMT} - {3668378400 25200 1 ALMST} - {3686522400 21600 0 ALMT} - {3699828000 25200 1 ALMST} - {3717972000 21600 0 ALMT} - {3731277600 25200 1 ALMST} - {3750026400 21600 0 ALMT} - {3762727200 25200 1 ALMST} - {3781476000 21600 0 ALMT} - {3794176800 25200 1 ALMST} - {3812925600 21600 0 ALMT} - {3825626400 25200 1 ALMST} - {3844375200 21600 0 ALMT} - {3857680800 25200 1 ALMST} - {3875824800 21600 0 ALMT} - {3889130400 25200 1 ALMST} - {3907274400 21600 0 ALMT} - {3920580000 25200 1 ALMST} - {3939328800 21600 0 ALMT} - {3952029600 25200 1 ALMST} - {3970778400 21600 0 ALMT} - {3983479200 25200 1 ALMST} - {4002228000 21600 0 ALMT} - {4015533600 25200 1 ALMST} - {4033677600 21600 0 ALMT} - {4046983200 25200 1 ALMST} - {4065127200 21600 0 ALMT} - {4078432800 25200 1 ALMST} - {4096576800 21600 0 ALMT} + {1110823200 21600 0 ALMT} } Index: library/tzdata/Asia/Aqtau ================================================================== --- library/tzdata/Asia/Aqtau +++ library/tzdata/Asia/Aqtau @@ -52,196 +52,7 @@ {1035684000 14400 0 AQTT} {1048989600 18000 1 AQTST} {1067133600 14400 0 AQTT} {1080439200 18000 1 AQTST} {1099188000 14400 0 AQTT} - {1111888800 18000 1 AQTST} - {1130637600 14400 0 AQTT} - {1143338400 18000 1 AQTST} - {1162087200 14400 0 AQTT} - {1174788000 18000 1 AQTST} - {1193536800 14400 0 AQTT} - {1206842400 18000 1 AQTST} - {1224986400 14400 0 AQTT} - {1238292000 18000 1 AQTST} - {1256436000 14400 0 AQTT} - {1269741600 18000 1 AQTST} - {1288490400 14400 0 AQTT} - {1301191200 18000 1 AQTST} - {1319940000 14400 0 AQTT} - {1332640800 18000 1 AQTST} - {1351389600 14400 0 AQTT} - {1364695200 18000 1 AQTST} - {1382839200 14400 0 AQTT} - {1396144800 18000 1 AQTST} - {1414288800 14400 0 AQTT} - {1427594400 18000 1 AQTST} - {1445738400 14400 0 AQTT} - {1459044000 18000 1 AQTST} - {1477792800 14400 0 AQTT} - {1490493600 18000 1 AQTST} - {1509242400 14400 0 AQTT} - {1521943200 18000 1 AQTST} - {1540692000 14400 0 AQTT} - {1553997600 18000 1 AQTST} - {1572141600 14400 0 AQTT} - {1585447200 18000 1 AQTST} - {1603591200 14400 0 AQTT} - {1616896800 18000 1 AQTST} - {1635645600 14400 0 AQTT} - {1648346400 18000 1 AQTST} - {1667095200 14400 0 AQTT} - {1679796000 18000 1 AQTST} - {1698544800 14400 0 AQTT} - {1711850400 18000 1 AQTST} - {1729994400 14400 0 AQTT} - {1743300000 18000 1 AQTST} - {1761444000 14400 0 AQTT} - {1774749600 18000 1 AQTST} - {1792893600 14400 0 AQTT} - {1806199200 18000 1 AQTST} - {1824948000 14400 0 AQTT} - {1837648800 18000 1 AQTST} - {1856397600 14400 0 AQTT} - {1869098400 18000 1 AQTST} - {1887847200 14400 0 AQTT} - {1901152800 18000 1 AQTST} - {1919296800 14400 0 AQTT} - {1932602400 18000 1 AQTST} - {1950746400 14400 0 AQTT} - {1964052000 18000 1 AQTST} - {1982800800 14400 0 AQTT} - {1995501600 18000 1 AQTST} - {2014250400 14400 0 AQTT} - {2026951200 18000 1 AQTST} - {2045700000 14400 0 AQTT} - {2058400800 18000 1 AQTST} - {2077149600 14400 0 AQTT} - {2090455200 18000 1 AQTST} - {2108599200 14400 0 AQTT} - {2121904800 18000 1 AQTST} - {2140048800 14400 0 AQTT} - {2153354400 18000 1 AQTST} - {2172103200 14400 0 AQTT} - {2184804000 18000 1 AQTST} - {2203552800 14400 0 AQTT} - {2216253600 18000 1 AQTST} - {2235002400 14400 0 AQTT} - {2248308000 18000 1 AQTST} - {2266452000 14400 0 AQTT} - {2279757600 18000 1 AQTST} - {2297901600 14400 0 AQTT} - {2311207200 18000 1 AQTST} - {2329351200 14400 0 AQTT} - {2342656800 18000 1 AQTST} - {2361405600 14400 0 AQTT} - {2374106400 18000 1 AQTST} - {2392855200 14400 0 AQTT} - {2405556000 18000 1 AQTST} - {2424304800 14400 0 AQTT} - {2437610400 18000 1 AQTST} - {2455754400 14400 0 AQTT} - {2469060000 18000 1 AQTST} - {2487204000 14400 0 AQTT} - {2500509600 18000 1 AQTST} - {2519258400 14400 0 AQTT} - {2531959200 18000 1 AQTST} - {2550708000 14400 0 AQTT} - {2563408800 18000 1 AQTST} - {2582157600 14400 0 AQTT} - {2595463200 18000 1 AQTST} - {2613607200 14400 0 AQTT} - {2626912800 18000 1 AQTST} - {2645056800 14400 0 AQTT} - {2658362400 18000 1 AQTST} - {2676506400 14400 0 AQTT} - {2689812000 18000 1 AQTST} - {2708560800 14400 0 AQTT} - {2721261600 18000 1 AQTST} - {2740010400 14400 0 AQTT} - {2752711200 18000 1 AQTST} - {2771460000 14400 0 AQTT} - {2784765600 18000 1 AQTST} - {2802909600 14400 0 AQTT} - {2816215200 18000 1 AQTST} - {2834359200 14400 0 AQTT} - {2847664800 18000 1 AQTST} - {2866413600 14400 0 AQTT} - {2879114400 18000 1 AQTST} - {2897863200 14400 0 AQTT} - {2910564000 18000 1 AQTST} - {2929312800 14400 0 AQTT} - {2942013600 18000 1 AQTST} - {2960762400 14400 0 AQTT} - {2974068000 18000 1 AQTST} - {2992212000 14400 0 AQTT} - {3005517600 18000 1 AQTST} - {3023661600 14400 0 AQTT} - {3036967200 18000 1 AQTST} - {3055716000 14400 0 AQTT} - {3068416800 18000 1 AQTST} - {3087165600 14400 0 AQTT} - {3099866400 18000 1 AQTST} - {3118615200 14400 0 AQTT} - {3131920800 18000 1 AQTST} - {3150064800 14400 0 AQTT} - {3163370400 18000 1 AQTST} - {3181514400 14400 0 AQTT} - {3194820000 18000 1 AQTST} - {3212964000 14400 0 AQTT} - {3226269600 18000 1 AQTST} - {3245018400 14400 0 AQTT} - {3257719200 18000 1 AQTST} - {3276468000 14400 0 AQTT} - {3289168800 18000 1 AQTST} - {3307917600 14400 0 AQTT} - {3321223200 18000 1 AQTST} - {3339367200 14400 0 AQTT} - {3352672800 18000 1 AQTST} - {3370816800 14400 0 AQTT} - {3384122400 18000 1 AQTST} - {3402871200 14400 0 AQTT} - {3415572000 18000 1 AQTST} - {3434320800 14400 0 AQTT} - {3447021600 18000 1 AQTST} - {3465770400 14400 0 AQTT} - {3479076000 18000 1 AQTST} - {3497220000 14400 0 AQTT} - {3510525600 18000 1 AQTST} - {3528669600 14400 0 AQTT} - {3541975200 18000 1 AQTST} - {3560119200 14400 0 AQTT} - {3573424800 18000 1 AQTST} - {3592173600 14400 0 AQTT} - {3604874400 18000 1 AQTST} - {3623623200 14400 0 AQTT} - {3636324000 18000 1 AQTST} - {3655072800 14400 0 AQTT} - {3668378400 18000 1 AQTST} - {3686522400 14400 0 AQTT} - {3699828000 18000 1 AQTST} - {3717972000 14400 0 AQTT} - {3731277600 18000 1 AQTST} - {3750026400 14400 0 AQTT} - {3762727200 18000 1 AQTST} - {3781476000 14400 0 AQTT} - {3794176800 18000 1 AQTST} - {3812925600 14400 0 AQTT} - {3825626400 18000 1 AQTST} - {3844375200 14400 0 AQTT} - {3857680800 18000 1 AQTST} - {3875824800 14400 0 AQTT} - {3889130400 18000 1 AQTST} - {3907274400 14400 0 AQTT} - {3920580000 18000 1 AQTST} - {3939328800 14400 0 AQTT} - {3952029600 18000 1 AQTST} - {3970778400 14400 0 AQTT} - {3983479200 18000 1 AQTST} - {4002228000 14400 0 AQTT} - {4015533600 18000 1 AQTST} - {4033677600 14400 0 AQTT} - {4046983200 18000 1 AQTST} - {4065127200 14400 0 AQTT} - {4078432800 18000 1 AQTST} - {4096576800 14400 0 AQTT} + {1110830400 18000 0 AQTT} } Index: library/tzdata/Asia/Aqtobe ================================================================== --- library/tzdata/Asia/Aqtobe +++ library/tzdata/Asia/Aqtobe @@ -51,196 +51,7 @@ {1035684000 18000 0 AQTT} {1048989600 21600 1 AQTST} {1067133600 18000 0 AQTT} {1080439200 21600 1 AQTST} {1099188000 18000 0 AQTT} - {1111888800 21600 1 AQTST} - {1130637600 18000 0 AQTT} - {1143338400 21600 1 AQTST} - {1162087200 18000 0 AQTT} - {1174788000 21600 1 AQTST} - {1193536800 18000 0 AQTT} - {1206842400 21600 1 AQTST} - {1224986400 18000 0 AQTT} - {1238292000 21600 1 AQTST} - {1256436000 18000 0 AQTT} - {1269741600 21600 1 AQTST} - {1288490400 18000 0 AQTT} - {1301191200 21600 1 AQTST} - {1319940000 18000 0 AQTT} - {1332640800 21600 1 AQTST} - {1351389600 18000 0 AQTT} - {1364695200 21600 1 AQTST} - {1382839200 18000 0 AQTT} - {1396144800 21600 1 AQTST} - {1414288800 18000 0 AQTT} - {1427594400 21600 1 AQTST} - {1445738400 18000 0 AQTT} - {1459044000 21600 1 AQTST} - {1477792800 18000 0 AQTT} - {1490493600 21600 1 AQTST} - {1509242400 18000 0 AQTT} - {1521943200 21600 1 AQTST} - {1540692000 18000 0 AQTT} - {1553997600 21600 1 AQTST} - {1572141600 18000 0 AQTT} - {1585447200 21600 1 AQTST} - {1603591200 18000 0 AQTT} - {1616896800 21600 1 AQTST} - {1635645600 18000 0 AQTT} - {1648346400 21600 1 AQTST} - {1667095200 18000 0 AQTT} - {1679796000 21600 1 AQTST} - {1698544800 18000 0 AQTT} - {1711850400 21600 1 AQTST} - {1729994400 18000 0 AQTT} - {1743300000 21600 1 AQTST} - {1761444000 18000 0 AQTT} - {1774749600 21600 1 AQTST} - {1792893600 18000 0 AQTT} - {1806199200 21600 1 AQTST} - {1824948000 18000 0 AQTT} - {1837648800 21600 1 AQTST} - {1856397600 18000 0 AQTT} - {1869098400 21600 1 AQTST} - {1887847200 18000 0 AQTT} - {1901152800 21600 1 AQTST} - {1919296800 18000 0 AQTT} - {1932602400 21600 1 AQTST} - {1950746400 18000 0 AQTT} - {1964052000 21600 1 AQTST} - {1982800800 18000 0 AQTT} - {1995501600 21600 1 AQTST} - {2014250400 18000 0 AQTT} - {2026951200 21600 1 AQTST} - {2045700000 18000 0 AQTT} - {2058400800 21600 1 AQTST} - {2077149600 18000 0 AQTT} - {2090455200 21600 1 AQTST} - {2108599200 18000 0 AQTT} - {2121904800 21600 1 AQTST} - {2140048800 18000 0 AQTT} - {2153354400 21600 1 AQTST} - {2172103200 18000 0 AQTT} - {2184804000 21600 1 AQTST} - {2203552800 18000 0 AQTT} - {2216253600 21600 1 AQTST} - {2235002400 18000 0 AQTT} - {2248308000 21600 1 AQTST} - {2266452000 18000 0 AQTT} - {2279757600 21600 1 AQTST} - {2297901600 18000 0 AQTT} - {2311207200 21600 1 AQTST} - {2329351200 18000 0 AQTT} - {2342656800 21600 1 AQTST} - {2361405600 18000 0 AQTT} - {2374106400 21600 1 AQTST} - {2392855200 18000 0 AQTT} - {2405556000 21600 1 AQTST} - {2424304800 18000 0 AQTT} - {2437610400 21600 1 AQTST} - {2455754400 18000 0 AQTT} - {2469060000 21600 1 AQTST} - {2487204000 18000 0 AQTT} - {2500509600 21600 1 AQTST} - {2519258400 18000 0 AQTT} - {2531959200 21600 1 AQTST} - {2550708000 18000 0 AQTT} - {2563408800 21600 1 AQTST} - {2582157600 18000 0 AQTT} - {2595463200 21600 1 AQTST} - {2613607200 18000 0 AQTT} - {2626912800 21600 1 AQTST} - {2645056800 18000 0 AQTT} - {2658362400 21600 1 AQTST} - {2676506400 18000 0 AQTT} - {2689812000 21600 1 AQTST} - {2708560800 18000 0 AQTT} - {2721261600 21600 1 AQTST} - {2740010400 18000 0 AQTT} - {2752711200 21600 1 AQTST} - {2771460000 18000 0 AQTT} - {2784765600 21600 1 AQTST} - {2802909600 18000 0 AQTT} - {2816215200 21600 1 AQTST} - {2834359200 18000 0 AQTT} - {2847664800 21600 1 AQTST} - {2866413600 18000 0 AQTT} - {2879114400 21600 1 AQTST} - {2897863200 18000 0 AQTT} - {2910564000 21600 1 AQTST} - {2929312800 18000 0 AQTT} - {2942013600 21600 1 AQTST} - {2960762400 18000 0 AQTT} - {2974068000 21600 1 AQTST} - {2992212000 18000 0 AQTT} - {3005517600 21600 1 AQTST} - {3023661600 18000 0 AQTT} - {3036967200 21600 1 AQTST} - {3055716000 18000 0 AQTT} - {3068416800 21600 1 AQTST} - {3087165600 18000 0 AQTT} - {3099866400 21600 1 AQTST} - {3118615200 18000 0 AQTT} - {3131920800 21600 1 AQTST} - {3150064800 18000 0 AQTT} - {3163370400 21600 1 AQTST} - {3181514400 18000 0 AQTT} - {3194820000 21600 1 AQTST} - {3212964000 18000 0 AQTT} - {3226269600 21600 1 AQTST} - {3245018400 18000 0 AQTT} - {3257719200 21600 1 AQTST} - {3276468000 18000 0 AQTT} - {3289168800 21600 1 AQTST} - {3307917600 18000 0 AQTT} - {3321223200 21600 1 AQTST} - {3339367200 18000 0 AQTT} - {3352672800 21600 1 AQTST} - {3370816800 18000 0 AQTT} - {3384122400 21600 1 AQTST} - {3402871200 18000 0 AQTT} - {3415572000 21600 1 AQTST} - {3434320800 18000 0 AQTT} - {3447021600 21600 1 AQTST} - {3465770400 18000 0 AQTT} - {3479076000 21600 1 AQTST} - {3497220000 18000 0 AQTT} - {3510525600 21600 1 AQTST} - {3528669600 18000 0 AQTT} - {3541975200 21600 1 AQTST} - {3560119200 18000 0 AQTT} - {3573424800 21600 1 AQTST} - {3592173600 18000 0 AQTT} - {3604874400 21600 1 AQTST} - {3623623200 18000 0 AQTT} - {3636324000 21600 1 AQTST} - {3655072800 18000 0 AQTT} - {3668378400 21600 1 AQTST} - {3686522400 18000 0 AQTT} - {3699828000 21600 1 AQTST} - {3717972000 18000 0 AQTT} - {3731277600 21600 1 AQTST} - {3750026400 18000 0 AQTT} - {3762727200 21600 1 AQTST} - {3781476000 18000 0 AQTT} - {3794176800 21600 1 AQTST} - {3812925600 18000 0 AQTT} - {3825626400 21600 1 AQTST} - {3844375200 18000 0 AQTT} - {3857680800 21600 1 AQTST} - {3875824800 18000 0 AQTT} - {3889130400 21600 1 AQTST} - {3907274400 18000 0 AQTT} - {3920580000 21600 1 AQTST} - {3939328800 18000 0 AQTT} - {3952029600 21600 1 AQTST} - {3970778400 18000 0 AQTT} - {3983479200 21600 1 AQTST} - {4002228000 18000 0 AQTT} - {4015533600 21600 1 AQTST} - {4033677600 18000 0 AQTT} - {4046983200 21600 1 AQTST} - {4065127200 18000 0 AQTT} - {4078432800 21600 1 AQTST} - {4096576800 18000 0 AQTT} + {1110826800 18000 0 AQTT} } Index: library/tzdata/Asia/Baku ================================================================== --- library/tzdata/Asia/Baku +++ library/tzdata/Asia/Baku @@ -26,12 +26,11 @@ {654660000 14400 0 BAKT} {670384800 14400 1 BAKST} {683496000 14400 0 AZST} {686109600 10800 0 AZT} {701812800 14400 1 AZST} - {717534000 10800 0 AZT} - {717559200 14400 0 AZT} + {717537600 14400 0 AZT} {820440000 14400 0 AZT} {828234000 18000 1 AZST} {846378000 14400 0 AZT} {852062400 14400 0 AZT} {859669200 18000 1 AZST} Index: library/tzdata/Asia/Bishkek ================================================================== --- library/tzdata/Asia/Bishkek +++ library/tzdata/Asia/Bishkek @@ -51,195 +51,7 @@ {1048973400 21600 1 KGST} {1067113800 18000 0 KGT} {1080423000 21600 1 KGST} {1099168200 18000 0 KGT} {1111872600 21600 1 KGST} - {1130617800 18000 0 KGT} - {1143322200 21600 1 KGST} - {1162067400 18000 0 KGT} - {1174771800 21600 1 KGST} - {1193517000 18000 0 KGT} - {1206826200 21600 1 KGST} - {1224966600 18000 0 KGT} - {1238275800 21600 1 KGST} - {1256416200 18000 0 KGT} - {1269725400 21600 1 KGST} - {1288470600 18000 0 KGT} - {1301175000 21600 1 KGST} - {1319920200 18000 0 KGT} - {1332624600 21600 1 KGST} - {1351369800 18000 0 KGT} - {1364679000 21600 1 KGST} - {1382819400 18000 0 KGT} - {1396128600 21600 1 KGST} - {1414269000 18000 0 KGT} - {1427578200 21600 1 KGST} - {1445718600 18000 0 KGT} - {1459027800 21600 1 KGST} - {1477773000 18000 0 KGT} - {1490477400 21600 1 KGST} - {1509222600 18000 0 KGT} - {1521927000 21600 1 KGST} - {1540672200 18000 0 KGT} - {1553981400 21600 1 KGST} - {1572121800 18000 0 KGT} - {1585431000 21600 1 KGST} - {1603571400 18000 0 KGT} - {1616880600 21600 1 KGST} - {1635625800 18000 0 KGT} - {1648330200 21600 1 KGST} - {1667075400 18000 0 KGT} - {1679779800 21600 1 KGST} - {1698525000 18000 0 KGT} - {1711834200 21600 1 KGST} - {1729974600 18000 0 KGT} - {1743283800 21600 1 KGST} - {1761424200 18000 0 KGT} - {1774733400 21600 1 KGST} - {1792873800 18000 0 KGT} - {1806183000 21600 1 KGST} - {1824928200 18000 0 KGT} - {1837632600 21600 1 KGST} - {1856377800 18000 0 KGT} - {1869082200 21600 1 KGST} - {1887827400 18000 0 KGT} - {1901136600 21600 1 KGST} - {1919277000 18000 0 KGT} - {1932586200 21600 1 KGST} - {1950726600 18000 0 KGT} - {1964035800 21600 1 KGST} - {1982781000 18000 0 KGT} - {1995485400 21600 1 KGST} - {2014230600 18000 0 KGT} - {2026935000 21600 1 KGST} - {2045680200 18000 0 KGT} - {2058384600 21600 1 KGST} - {2077129800 18000 0 KGT} - {2090439000 21600 1 KGST} - {2108579400 18000 0 KGT} - {2121888600 21600 1 KGST} - {2140029000 18000 0 KGT} - {2153338200 21600 1 KGST} - {2172083400 18000 0 KGT} - {2184787800 21600 1 KGST} - {2203533000 18000 0 KGT} - {2216237400 21600 1 KGST} - {2234982600 18000 0 KGT} - {2248291800 21600 1 KGST} - {2266432200 18000 0 KGT} - {2279741400 21600 1 KGST} - {2297881800 18000 0 KGT} - {2311191000 21600 1 KGST} - {2329331400 18000 0 KGT} - {2342640600 21600 1 KGST} - {2361385800 18000 0 KGT} - {2374090200 21600 1 KGST} - {2392835400 18000 0 KGT} - {2405539800 21600 1 KGST} - {2424285000 18000 0 KGT} - {2437594200 21600 1 KGST} - {2455734600 18000 0 KGT} - {2469043800 21600 1 KGST} - {2487184200 18000 0 KGT} - {2500493400 21600 1 KGST} - {2519238600 18000 0 KGT} - {2531943000 21600 1 KGST} - {2550688200 18000 0 KGT} - {2563392600 21600 1 KGST} - {2582137800 18000 0 KGT} - {2595447000 21600 1 KGST} - {2613587400 18000 0 KGT} - {2626896600 21600 1 KGST} - {2645037000 18000 0 KGT} - {2658346200 21600 1 KGST} - {2676486600 18000 0 KGT} - {2689795800 21600 1 KGST} - {2708541000 18000 0 KGT} - {2721245400 21600 1 KGST} - {2739990600 18000 0 KGT} - {2752695000 21600 1 KGST} - {2771440200 18000 0 KGT} - {2784749400 21600 1 KGST} - {2802889800 18000 0 KGT} - {2816199000 21600 1 KGST} - {2834339400 18000 0 KGT} - {2847648600 21600 1 KGST} - {2866393800 18000 0 KGT} - {2879098200 21600 1 KGST} - {2897843400 18000 0 KGT} - {2910547800 21600 1 KGST} - {2929293000 18000 0 KGT} - {2941997400 21600 1 KGST} - {2960742600 18000 0 KGT} - {2974051800 21600 1 KGST} - {2992192200 18000 0 KGT} - {3005501400 21600 1 KGST} - {3023641800 18000 0 KGT} - {3036951000 21600 1 KGST} - {3055696200 18000 0 KGT} - {3068400600 21600 1 KGST} - {3087145800 18000 0 KGT} - {3099850200 21600 1 KGST} - {3118595400 18000 0 KGT} - {3131904600 21600 1 KGST} - {3150045000 18000 0 KGT} - {3163354200 21600 1 KGST} - {3181494600 18000 0 KGT} - {3194803800 21600 1 KGST} - {3212944200 18000 0 KGT} - {3226253400 21600 1 KGST} - {3244998600 18000 0 KGT} - {3257703000 21600 1 KGST} - {3276448200 18000 0 KGT} - {3289152600 21600 1 KGST} - {3307897800 18000 0 KGT} - {3321207000 21600 1 KGST} - {3339347400 18000 0 KGT} - {3352656600 21600 1 KGST} - {3370797000 18000 0 KGT} - {3384106200 21600 1 KGST} - {3402851400 18000 0 KGT} - {3415555800 21600 1 KGST} - {3434301000 18000 0 KGT} - {3447005400 21600 1 KGST} - {3465750600 18000 0 KGT} - {3479059800 21600 1 KGST} - {3497200200 18000 0 KGT} - {3510509400 21600 1 KGST} - {3528649800 18000 0 KGT} - {3541959000 21600 1 KGST} - {3560099400 18000 0 KGT} - {3573408600 21600 1 KGST} - {3592153800 18000 0 KGT} - {3604858200 21600 1 KGST} - {3623603400 18000 0 KGT} - {3636307800 21600 1 KGST} - {3655053000 18000 0 KGT} - {3668362200 21600 1 KGST} - {3686502600 18000 0 KGT} - {3699811800 21600 1 KGST} - {3717952200 18000 0 KGT} - {3731261400 21600 1 KGST} - {3750006600 18000 0 KGT} - {3762711000 21600 1 KGST} - {3781456200 18000 0 KGT} - {3794160600 21600 1 KGST} - {3812905800 18000 0 KGT} - {3825610200 21600 1 KGST} - {3844355400 18000 0 KGT} - {3857664600 21600 1 KGST} - {3875805000 18000 0 KGT} - {3889114200 21600 1 KGST} - {3907254600 18000 0 KGT} - {3920563800 21600 1 KGST} - {3939309000 18000 0 KGT} - {3952013400 21600 1 KGST} - {3970758600 18000 0 KGT} - {3983463000 21600 1 KGST} - {4002208200 18000 0 KGT} - {4015517400 21600 1 KGST} - {4033657800 18000 0 KGT} - {4046967000 21600 1 KGST} - {4065107400 18000 0 KGT} - {4078416600 21600 1 KGST} - {4096557000 18000 0 KGT} + {1123783200 21600 0 KGT} } Index: library/tzdata/Asia/Dili ================================================================== --- library/tzdata/Asia/Dili +++ library/tzdata/Asia/Dili @@ -1,10 +1,10 @@ # created by ../tools/tclZIC.tcl - do not edit set TZData(:Asia/Dili) { {-9223372036854775808 30140 0 LMT} - {-1830414140 28800 0 TPT} + {-1830414140 28800 0 TLT} {-879152400 32400 0 JST} - {-770634000 32400 0 TPT} + {-770634000 32400 0 TLT} {199897200 28800 0 CIT} - {969120000 32400 0 TPT} + {969120000 32400 0 TLT} } Index: library/tzdata/Asia/Jerusalem ================================================================== --- library/tzdata/Asia/Jerusalem +++ library/tzdata/Asia/Jerusalem @@ -77,196 +77,72 @@ {1033941600 7200 0 IST} {1048806000 10800 1 IDT} {1065132000 7200 0 IST} {1081292400 10800 1 IDT} {1095804000 7200 0 IST} - {1112310000 10800 1 IDT} - {1128117600 7200 0 IST} - {1143846000 10800 1 IDT} - {1159653600 7200 0 IST} - {1175382000 10800 1 IDT} - {1191189600 7200 0 IST} - {1207004400 10800 1 IDT} - {1222812000 7200 0 IST} - {1238540400 10800 1 IDT} - {1254348000 7200 0 IST} - {1270076400 10800 1 IDT} - {1285884000 7200 0 IST} - {1301612400 10800 1 IDT} - {1317420000 7200 0 IST} - {1333234800 10800 1 IDT} - {1349042400 7200 0 IST} - {1364770800 10800 1 IDT} - {1380578400 7200 0 IST} - {1396306800 10800 1 IDT} - {1412114400 7200 0 IST} - {1427842800 10800 1 IDT} - {1443650400 7200 0 IST} - {1459465200 10800 1 IDT} - {1475272800 7200 0 IST} - {1491001200 10800 1 IDT} - {1506808800 7200 0 IST} - {1522537200 10800 1 IDT} - {1538344800 7200 0 IST} - {1554073200 10800 1 IDT} - {1569880800 7200 0 IST} - {1585695600 10800 1 IDT} - {1601503200 7200 0 IST} - {1617231600 10800 1 IDT} - {1633039200 7200 0 IST} - {1648767600 10800 1 IDT} - {1664575200 7200 0 IST} - {1680303600 10800 1 IDT} - {1696111200 7200 0 IST} - {1711926000 10800 1 IDT} - {1727733600 7200 0 IST} - {1743462000 10800 1 IDT} - {1759269600 7200 0 IST} - {1774998000 10800 1 IDT} - {1790805600 7200 0 IST} - {1806534000 10800 1 IDT} - {1822341600 7200 0 IST} - {1838156400 10800 1 IDT} - {1853964000 7200 0 IST} - {1869692400 10800 1 IDT} - {1885500000 7200 0 IST} - {1901228400 10800 1 IDT} - {1917036000 7200 0 IST} - {1932764400 10800 1 IDT} - {1948572000 7200 0 IST} - {1964386800 10800 1 IDT} - {1980194400 7200 0 IST} - {1995922800 10800 1 IDT} - {2011730400 7200 0 IST} - {2027458800 10800 1 IDT} - {2043266400 7200 0 IST} - {2058994800 10800 1 IDT} - {2074802400 7200 0 IST} - {2090617200 10800 1 IDT} - {2106424800 7200 0 IST} - {2122153200 10800 1 IDT} - {2137960800 7200 0 IST} - {2153689200 10800 1 IDT} - {2169496800 7200 0 IST} - {2185225200 10800 1 IDT} - {2201032800 7200 0 IST} - {2216847600 10800 1 IDT} - {2232655200 7200 0 IST} - {2248383600 10800 1 IDT} - {2264191200 7200 0 IST} - {2279919600 10800 1 IDT} - {2295727200 7200 0 IST} - {2311455600 10800 1 IDT} - {2327263200 7200 0 IST} - {2343078000 10800 1 IDT} - {2358885600 7200 0 IST} - {2374614000 10800 1 IDT} - {2390421600 7200 0 IST} - {2406150000 10800 1 IDT} - {2421957600 7200 0 IST} - {2437686000 10800 1 IDT} - {2453493600 7200 0 IST} - {2469308400 10800 1 IDT} - {2485116000 7200 0 IST} - {2500844400 10800 1 IDT} - {2516652000 7200 0 IST} - {2532380400 10800 1 IDT} - {2548188000 7200 0 IST} - {2563916400 10800 1 IDT} - {2579724000 7200 0 IST} - {2595538800 10800 1 IDT} - {2611346400 7200 0 IST} - {2627074800 10800 1 IDT} - {2642882400 7200 0 IST} - {2658610800 10800 1 IDT} - {2674418400 7200 0 IST} - {2690146800 10800 1 IDT} - {2705954400 7200 0 IST} - {2721769200 10800 1 IDT} - {2737576800 7200 0 IST} - {2753305200 10800 1 IDT} - {2769112800 7200 0 IST} - {2784841200 10800 1 IDT} - {2800648800 7200 0 IST} - {2816377200 10800 1 IDT} - {2832184800 7200 0 IST} - {2847999600 10800 1 IDT} - {2863807200 7200 0 IST} - {2879535600 10800 1 IDT} - {2895343200 7200 0 IST} - {2911071600 10800 1 IDT} - {2926879200 7200 0 IST} - {2942607600 10800 1 IDT} - {2958415200 7200 0 IST} - {2974230000 10800 1 IDT} - {2990037600 7200 0 IST} - {3005766000 10800 1 IDT} - {3021573600 7200 0 IST} - {3037302000 10800 1 IDT} - {3053109600 7200 0 IST} - {3068838000 10800 1 IDT} - {3084645600 7200 0 IST} - {3100460400 10800 1 IDT} - {3116268000 7200 0 IST} - {3131996400 10800 1 IDT} - {3147804000 7200 0 IST} - {3163532400 10800 1 IDT} - {3179340000 7200 0 IST} - {3195068400 10800 1 IDT} - {3210876000 7200 0 IST} - {3226690800 10800 1 IDT} - {3242498400 7200 0 IST} - {3258226800 10800 1 IDT} - {3274034400 7200 0 IST} - {3289762800 10800 1 IDT} - {3305570400 7200 0 IST} - {3321298800 10800 1 IDT} - {3337106400 7200 0 IST} - {3352921200 10800 1 IDT} - {3368728800 7200 0 IST} - {3384457200 10800 1 IDT} - {3400264800 7200 0 IST} - {3415993200 10800 1 IDT} - {3431800800 7200 0 IST} - {3447529200 10800 1 IDT} - {3463336800 7200 0 IST} - {3479151600 10800 1 IDT} - {3494959200 7200 0 IST} - {3510687600 10800 1 IDT} - {3526495200 7200 0 IST} - {3542223600 10800 1 IDT} - {3558031200 7200 0 IST} - {3573759600 10800 1 IDT} - {3589567200 7200 0 IST} - {3605382000 10800 1 IDT} - {3621189600 7200 0 IST} - {3636918000 10800 1 IDT} - {3652725600 7200 0 IST} - {3668454000 10800 1 IDT} - {3684261600 7200 0 IST} - {3699990000 10800 1 IDT} - {3715797600 7200 0 IST} - {3731612400 10800 1 IDT} - {3747420000 7200 0 IST} - {3763148400 10800 1 IDT} - {3778956000 7200 0 IST} - {3794684400 10800 1 IDT} - {3810492000 7200 0 IST} - {3826220400 10800 1 IDT} - {3842028000 7200 0 IST} - {3857842800 10800 1 IDT} - {3873650400 7200 0 IST} - {3889378800 10800 1 IDT} - {3905186400 7200 0 IST} - {3920914800 10800 1 IDT} - {3936722400 7200 0 IST} - {3952450800 10800 1 IDT} - {3968258400 7200 0 IST} - {3984073200 10800 1 IDT} - {3999880800 7200 0 IST} - {4015609200 10800 1 IDT} - {4031416800 7200 0 IST} - {4047145200 10800 1 IDT} - {4062952800 7200 0 IST} - {4078681200 10800 1 IDT} - {4094488800 7200 0 IST} + {1112313600 10800 1 IDT} + {1128812400 7200 0 IST} + {1143763200 10800 1 IDT} + {1159657200 7200 0 IST} + {1175212800 10800 1 IDT} + {1189897200 7200 0 IST} + {1206662400 10800 1 IDT} + {1223161200 7200 0 IST} + {1238112000 10800 1 IDT} + {1254006000 7200 0 IST} + {1269561600 10800 1 IDT} + {1284246000 7200 0 IST} + {1301616000 10800 1 IDT} + {1317510000 7200 0 IST} + {1333065600 10800 1 IDT} + {1348354800 7200 0 IST} + {1364515200 10800 1 IDT} + {1378594800 7200 0 IST} + {1395964800 10800 1 IDT} + {1411858800 7200 0 IST} + {1427414400 10800 1 IDT} + {1442703600 7200 0 IST} + {1459468800 10800 1 IDT} + {1475967600 7200 0 IST} + {1490918400 10800 1 IDT} + {1506207600 7200 0 IST} + {1522368000 10800 1 IDT} + {1537052400 7200 0 IST} + {1553817600 10800 1 IDT} + {1570316400 7200 0 IST} + {1585267200 10800 1 IDT} + {1601161200 7200 0 IST} + {1616716800 10800 1 IDT} + {1631401200 7200 0 IST} + {1648771200 10800 1 IDT} + {1664665200 7200 0 IST} + {1680220800 10800 1 IDT} + {1695510000 7200 0 IST} + {1711670400 10800 1 IDT} + {1728169200 7200 0 IST} + {1743120000 10800 1 IDT} + {1759014000 7200 0 IST} + {1774569600 10800 1 IDT} + {1789858800 7200 0 IST} + {1806019200 10800 1 IDT} + {1823122800 7200 0 IST} + {1838073600 10800 1 IDT} + {1853362800 7200 0 IST} + {1869523200 10800 1 IDT} + {1884207600 7200 0 IST} + {1900972800 10800 1 IDT} + {1917471600 7200 0 IST} + {1932422400 10800 1 IDT} + {1947711600 7200 0 IST} + {1963872000 10800 1 IDT} + {1978556400 7200 0 IST} + {1995926400 10800 1 IDT} + {2011820400 7200 0 IST} + {2027376000 10800 1 IDT} + {2042060400 7200 0 IST} + {2058825600 10800 1 IDT} + {2075324400 7200 0 IST} + {2090275200 10800 1 IDT} + {2106169200 7200 0 IST} + {2121724800 10800 1 IDT} + {2136409200 7200 0 IST} } Index: library/tzdata/Asia/Oral ================================================================== --- library/tzdata/Asia/Oral +++ library/tzdata/Asia/Oral @@ -52,196 +52,7 @@ {1035684000 14400 0 ORAT} {1048989600 18000 1 ORAST} {1067133600 14400 0 ORAT} {1080439200 18000 1 ORAST} {1099188000 14400 0 ORAT} - {1111888800 18000 1 ORAST} - {1130637600 14400 0 ORAT} - {1143338400 18000 1 ORAST} - {1162087200 14400 0 ORAT} - {1174788000 18000 1 ORAST} - {1193536800 14400 0 ORAT} - {1206842400 18000 1 ORAST} - {1224986400 14400 0 ORAT} - {1238292000 18000 1 ORAST} - {1256436000 14400 0 ORAT} - {1269741600 18000 1 ORAST} - {1288490400 14400 0 ORAT} - {1301191200 18000 1 ORAST} - {1319940000 14400 0 ORAT} - {1332640800 18000 1 ORAST} - {1351389600 14400 0 ORAT} - {1364695200 18000 1 ORAST} - {1382839200 14400 0 ORAT} - {1396144800 18000 1 ORAST} - {1414288800 14400 0 ORAT} - {1427594400 18000 1 ORAST} - {1445738400 14400 0 ORAT} - {1459044000 18000 1 ORAST} - {1477792800 14400 0 ORAT} - {1490493600 18000 1 ORAST} - {1509242400 14400 0 ORAT} - {1521943200 18000 1 ORAST} - {1540692000 14400 0 ORAT} - {1553997600 18000 1 ORAST} - {1572141600 14400 0 ORAT} - {1585447200 18000 1 ORAST} - {1603591200 14400 0 ORAT} - {1616896800 18000 1 ORAST} - {1635645600 14400 0 ORAT} - {1648346400 18000 1 ORAST} - {1667095200 14400 0 ORAT} - {1679796000 18000 1 ORAST} - {1698544800 14400 0 ORAT} - {1711850400 18000 1 ORAST} - {1729994400 14400 0 ORAT} - {1743300000 18000 1 ORAST} - {1761444000 14400 0 ORAT} - {1774749600 18000 1 ORAST} - {1792893600 14400 0 ORAT} - {1806199200 18000 1 ORAST} - {1824948000 14400 0 ORAT} - {1837648800 18000 1 ORAST} - {1856397600 14400 0 ORAT} - {1869098400 18000 1 ORAST} - {1887847200 14400 0 ORAT} - {1901152800 18000 1 ORAST} - {1919296800 14400 0 ORAT} - {1932602400 18000 1 ORAST} - {1950746400 14400 0 ORAT} - {1964052000 18000 1 ORAST} - {1982800800 14400 0 ORAT} - {1995501600 18000 1 ORAST} - {2014250400 14400 0 ORAT} - {2026951200 18000 1 ORAST} - {2045700000 14400 0 ORAT} - {2058400800 18000 1 ORAST} - {2077149600 14400 0 ORAT} - {2090455200 18000 1 ORAST} - {2108599200 14400 0 ORAT} - {2121904800 18000 1 ORAST} - {2140048800 14400 0 ORAT} - {2153354400 18000 1 ORAST} - {2172103200 14400 0 ORAT} - {2184804000 18000 1 ORAST} - {2203552800 14400 0 ORAT} - {2216253600 18000 1 ORAST} - {2235002400 14400 0 ORAT} - {2248308000 18000 1 ORAST} - {2266452000 14400 0 ORAT} - {2279757600 18000 1 ORAST} - {2297901600 14400 0 ORAT} - {2311207200 18000 1 ORAST} - {2329351200 14400 0 ORAT} - {2342656800 18000 1 ORAST} - {2361405600 14400 0 ORAT} - {2374106400 18000 1 ORAST} - {2392855200 14400 0 ORAT} - {2405556000 18000 1 ORAST} - {2424304800 14400 0 ORAT} - {2437610400 18000 1 ORAST} - {2455754400 14400 0 ORAT} - {2469060000 18000 1 ORAST} - {2487204000 14400 0 ORAT} - {2500509600 18000 1 ORAST} - {2519258400 14400 0 ORAT} - {2531959200 18000 1 ORAST} - {2550708000 14400 0 ORAT} - {2563408800 18000 1 ORAST} - {2582157600 14400 0 ORAT} - {2595463200 18000 1 ORAST} - {2613607200 14400 0 ORAT} - {2626912800 18000 1 ORAST} - {2645056800 14400 0 ORAT} - {2658362400 18000 1 ORAST} - {2676506400 14400 0 ORAT} - {2689812000 18000 1 ORAST} - {2708560800 14400 0 ORAT} - {2721261600 18000 1 ORAST} - {2740010400 14400 0 ORAT} - {2752711200 18000 1 ORAST} - {2771460000 14400 0 ORAT} - {2784765600 18000 1 ORAST} - {2802909600 14400 0 ORAT} - {2816215200 18000 1 ORAST} - {2834359200 14400 0 ORAT} - {2847664800 18000 1 ORAST} - {2866413600 14400 0 ORAT} - {2879114400 18000 1 ORAST} - {2897863200 14400 0 ORAT} - {2910564000 18000 1 ORAST} - {2929312800 14400 0 ORAT} - {2942013600 18000 1 ORAST} - {2960762400 14400 0 ORAT} - {2974068000 18000 1 ORAST} - {2992212000 14400 0 ORAT} - {3005517600 18000 1 ORAST} - {3023661600 14400 0 ORAT} - {3036967200 18000 1 ORAST} - {3055716000 14400 0 ORAT} - {3068416800 18000 1 ORAST} - {3087165600 14400 0 ORAT} - {3099866400 18000 1 ORAST} - {3118615200 14400 0 ORAT} - {3131920800 18000 1 ORAST} - {3150064800 14400 0 ORAT} - {3163370400 18000 1 ORAST} - {3181514400 14400 0 ORAT} - {3194820000 18000 1 ORAST} - {3212964000 14400 0 ORAT} - {3226269600 18000 1 ORAST} - {3245018400 14400 0 ORAT} - {3257719200 18000 1 ORAST} - {3276468000 14400 0 ORAT} - {3289168800 18000 1 ORAST} - {3307917600 14400 0 ORAT} - {3321223200 18000 1 ORAST} - {3339367200 14400 0 ORAT} - {3352672800 18000 1 ORAST} - {3370816800 14400 0 ORAT} - {3384122400 18000 1 ORAST} - {3402871200 14400 0 ORAT} - {3415572000 18000 1 ORAST} - {3434320800 14400 0 ORAT} - {3447021600 18000 1 ORAST} - {3465770400 14400 0 ORAT} - {3479076000 18000 1 ORAST} - {3497220000 14400 0 ORAT} - {3510525600 18000 1 ORAST} - {3528669600 14400 0 ORAT} - {3541975200 18000 1 ORAST} - {3560119200 14400 0 ORAT} - {3573424800 18000 1 ORAST} - {3592173600 14400 0 ORAT} - {3604874400 18000 1 ORAST} - {3623623200 14400 0 ORAT} - {3636324000 18000 1 ORAST} - {3655072800 14400 0 ORAT} - {3668378400 18000 1 ORAST} - {3686522400 14400 0 ORAT} - {3699828000 18000 1 ORAST} - {3717972000 14400 0 ORAT} - {3731277600 18000 1 ORAST} - {3750026400 14400 0 ORAT} - {3762727200 18000 1 ORAST} - {3781476000 14400 0 ORAT} - {3794176800 18000 1 ORAST} - {3812925600 14400 0 ORAT} - {3825626400 18000 1 ORAST} - {3844375200 14400 0 ORAT} - {3857680800 18000 1 ORAST} - {3875824800 14400 0 ORAT} - {3889130400 18000 1 ORAST} - {3907274400 14400 0 ORAT} - {3920580000 18000 1 ORAST} - {3939328800 14400 0 ORAT} - {3952029600 18000 1 ORAST} - {3970778400 14400 0 ORAT} - {3983479200 18000 1 ORAST} - {4002228000 14400 0 ORAT} - {4015533600 18000 1 ORAST} - {4033677600 14400 0 ORAT} - {4046983200 18000 1 ORAST} - {4065127200 14400 0 ORAT} - {4078432800 18000 1 ORAST} - {4096576800 14400 0 ORAT} + {1110830400 18000 0 ORAT} } Index: library/tzdata/Asia/Qyzylorda ================================================================== --- library/tzdata/Asia/Qyzylorda +++ library/tzdata/Asia/Qyzylorda @@ -52,196 +52,7 @@ {1035684000 21600 0 QYZT} {1048989600 25200 1 QYZST} {1067133600 21600 0 QYZT} {1080439200 25200 1 QYZST} {1099188000 21600 0 QYZT} - {1111888800 25200 1 QYZST} - {1130637600 21600 0 QYZT} - {1143338400 25200 1 QYZST} - {1162087200 21600 0 QYZT} - {1174788000 25200 1 QYZST} - {1193536800 21600 0 QYZT} - {1206842400 25200 1 QYZST} - {1224986400 21600 0 QYZT} - {1238292000 25200 1 QYZST} - {1256436000 21600 0 QYZT} - {1269741600 25200 1 QYZST} - {1288490400 21600 0 QYZT} - {1301191200 25200 1 QYZST} - {1319940000 21600 0 QYZT} - {1332640800 25200 1 QYZST} - {1351389600 21600 0 QYZT} - {1364695200 25200 1 QYZST} - {1382839200 21600 0 QYZT} - {1396144800 25200 1 QYZST} - {1414288800 21600 0 QYZT} - {1427594400 25200 1 QYZST} - {1445738400 21600 0 QYZT} - {1459044000 25200 1 QYZST} - {1477792800 21600 0 QYZT} - {1490493600 25200 1 QYZST} - {1509242400 21600 0 QYZT} - {1521943200 25200 1 QYZST} - {1540692000 21600 0 QYZT} - {1553997600 25200 1 QYZST} - {1572141600 21600 0 QYZT} - {1585447200 25200 1 QYZST} - {1603591200 21600 0 QYZT} - {1616896800 25200 1 QYZST} - {1635645600 21600 0 QYZT} - {1648346400 25200 1 QYZST} - {1667095200 21600 0 QYZT} - {1679796000 25200 1 QYZST} - {1698544800 21600 0 QYZT} - {1711850400 25200 1 QYZST} - {1729994400 21600 0 QYZT} - {1743300000 25200 1 QYZST} - {1761444000 21600 0 QYZT} - {1774749600 25200 1 QYZST} - {1792893600 21600 0 QYZT} - {1806199200 25200 1 QYZST} - {1824948000 21600 0 QYZT} - {1837648800 25200 1 QYZST} - {1856397600 21600 0 QYZT} - {1869098400 25200 1 QYZST} - {1887847200 21600 0 QYZT} - {1901152800 25200 1 QYZST} - {1919296800 21600 0 QYZT} - {1932602400 25200 1 QYZST} - {1950746400 21600 0 QYZT} - {1964052000 25200 1 QYZST} - {1982800800 21600 0 QYZT} - {1995501600 25200 1 QYZST} - {2014250400 21600 0 QYZT} - {2026951200 25200 1 QYZST} - {2045700000 21600 0 QYZT} - {2058400800 25200 1 QYZST} - {2077149600 21600 0 QYZT} - {2090455200 25200 1 QYZST} - {2108599200 21600 0 QYZT} - {2121904800 25200 1 QYZST} - {2140048800 21600 0 QYZT} - {2153354400 25200 1 QYZST} - {2172103200 21600 0 QYZT} - {2184804000 25200 1 QYZST} - {2203552800 21600 0 QYZT} - {2216253600 25200 1 QYZST} - {2235002400 21600 0 QYZT} - {2248308000 25200 1 QYZST} - {2266452000 21600 0 QYZT} - {2279757600 25200 1 QYZST} - {2297901600 21600 0 QYZT} - {2311207200 25200 1 QYZST} - {2329351200 21600 0 QYZT} - {2342656800 25200 1 QYZST} - {2361405600 21600 0 QYZT} - {2374106400 25200 1 QYZST} - {2392855200 21600 0 QYZT} - {2405556000 25200 1 QYZST} - {2424304800 21600 0 QYZT} - {2437610400 25200 1 QYZST} - {2455754400 21600 0 QYZT} - {2469060000 25200 1 QYZST} - {2487204000 21600 0 QYZT} - {2500509600 25200 1 QYZST} - {2519258400 21600 0 QYZT} - {2531959200 25200 1 QYZST} - {2550708000 21600 0 QYZT} - {2563408800 25200 1 QYZST} - {2582157600 21600 0 QYZT} - {2595463200 25200 1 QYZST} - {2613607200 21600 0 QYZT} - {2626912800 25200 1 QYZST} - {2645056800 21600 0 QYZT} - {2658362400 25200 1 QYZST} - {2676506400 21600 0 QYZT} - {2689812000 25200 1 QYZST} - {2708560800 21600 0 QYZT} - {2721261600 25200 1 QYZST} - {2740010400 21600 0 QYZT} - {2752711200 25200 1 QYZST} - {2771460000 21600 0 QYZT} - {2784765600 25200 1 QYZST} - {2802909600 21600 0 QYZT} - {2816215200 25200 1 QYZST} - {2834359200 21600 0 QYZT} - {2847664800 25200 1 QYZST} - {2866413600 21600 0 QYZT} - {2879114400 25200 1 QYZST} - {2897863200 21600 0 QYZT} - {2910564000 25200 1 QYZST} - {2929312800 21600 0 QYZT} - {2942013600 25200 1 QYZST} - {2960762400 21600 0 QYZT} - {2974068000 25200 1 QYZST} - {2992212000 21600 0 QYZT} - {3005517600 25200 1 QYZST} - {3023661600 21600 0 QYZT} - {3036967200 25200 1 QYZST} - {3055716000 21600 0 QYZT} - {3068416800 25200 1 QYZST} - {3087165600 21600 0 QYZT} - {3099866400 25200 1 QYZST} - {3118615200 21600 0 QYZT} - {3131920800 25200 1 QYZST} - {3150064800 21600 0 QYZT} - {3163370400 25200 1 QYZST} - {3181514400 21600 0 QYZT} - {3194820000 25200 1 QYZST} - {3212964000 21600 0 QYZT} - {3226269600 25200 1 QYZST} - {3245018400 21600 0 QYZT} - {3257719200 25200 1 QYZST} - {3276468000 21600 0 QYZT} - {3289168800 25200 1 QYZST} - {3307917600 21600 0 QYZT} - {3321223200 25200 1 QYZST} - {3339367200 21600 0 QYZT} - {3352672800 25200 1 QYZST} - {3370816800 21600 0 QYZT} - {3384122400 25200 1 QYZST} - {3402871200 21600 0 QYZT} - {3415572000 25200 1 QYZST} - {3434320800 21600 0 QYZT} - {3447021600 25200 1 QYZST} - {3465770400 21600 0 QYZT} - {3479076000 25200 1 QYZST} - {3497220000 21600 0 QYZT} - {3510525600 25200 1 QYZST} - {3528669600 21600 0 QYZT} - {3541975200 25200 1 QYZST} - {3560119200 21600 0 QYZT} - {3573424800 25200 1 QYZST} - {3592173600 21600 0 QYZT} - {3604874400 25200 1 QYZST} - {3623623200 21600 0 QYZT} - {3636324000 25200 1 QYZST} - {3655072800 21600 0 QYZT} - {3668378400 25200 1 QYZST} - {3686522400 21600 0 QYZT} - {3699828000 25200 1 QYZST} - {3717972000 21600 0 QYZT} - {3731277600 25200 1 QYZST} - {3750026400 21600 0 QYZT} - {3762727200 25200 1 QYZST} - {3781476000 21600 0 QYZT} - {3794176800 25200 1 QYZST} - {3812925600 21600 0 QYZT} - {3825626400 25200 1 QYZST} - {3844375200 21600 0 QYZT} - {3857680800 25200 1 QYZST} - {3875824800 21600 0 QYZT} - {3889130400 25200 1 QYZST} - {3907274400 21600 0 QYZT} - {3920580000 25200 1 QYZST} - {3939328800 21600 0 QYZT} - {3952029600 25200 1 QYZST} - {3970778400 21600 0 QYZT} - {3983479200 25200 1 QYZST} - {4002228000 21600 0 QYZT} - {4015533600 25200 1 QYZST} - {4033677600 21600 0 QYZT} - {4046983200 25200 1 QYZST} - {4065127200 21600 0 QYZT} - {4078432800 25200 1 QYZST} - {4096576800 21600 0 QYZT} + {1110823200 21600 0 QYZT} } Index: library/tzdata/Asia/Tehran ================================================================== --- library/tzdata/Asia/Tehran +++ library/tzdata/Asia/Tehran @@ -78,12 +78,12 @@ {1663788600 12600 0 IRST} {1679430600 16200 1 IRDT} {1695324600 12600 0 IRST} {1710966600 16200 1 IRDT} {1726860600 12600 0 IRST} - {1742502600 16200 1 IRDT} - {1758396600 12600 0 IRST} + {1742589000 16200 1 IRDT} + {1758483000 12600 0 IRST} {1774125000 16200 1 IRDT} {1790019000 12600 0 IRST} {1805661000 16200 1 IRDT} {1821555000 12600 0 IRST} {1837197000 16200 1 IRDT} Index: library/tzdata/Asia/Tokyo ================================================================== --- library/tzdata/Asia/Tokyo +++ library/tzdata/Asia/Tokyo @@ -3,6 +3,14 @@ set TZData(:Asia/Tokyo) { {-9223372036854775808 33539 0 LMT} {-2587712400 32400 0 JST} {-2335251600 32400 0 CJT} {-1009875600 32400 0 JST} + {-683794800 36000 1 JDT} + {-672393600 32400 0 JST} + {-654764400 36000 1 JDT} + {-640944000 32400 0 JST} + {-620290800 36000 1 JDT} + {-609494400 32400 0 JST} + {-588841200 36000 1 JDT} + {-578044800 32400 0 JST} } Index: library/tzdata/Australia/Adelaide ================================================================== --- library/tzdata/Australia/Adelaide +++ library/tzdata/Australia/Adelaide @@ -80,11 +80,11 @@ {1067133600 37800 1 CST} {1080439200 34200 0 CST} {1099188000 37800 1 CST} {1111888800 34200 0 CST} {1130637600 37800 1 CST} - {1143338400 34200 0 CST} + {1143943200 34200 0 CST} {1162087200 37800 1 CST} {1174788000 34200 0 CST} {1193536800 37800 1 CST} {1206842400 34200 0 CST} {1224986400 37800 1 CST} Index: library/tzdata/Australia/Broken_Hill ================================================================== --- library/tzdata/Australia/Broken_Hill +++ library/tzdata/Australia/Broken_Hill @@ -82,11 +82,11 @@ {1067133600 37800 1 CST} {1080439200 34200 0 CST} {1099188000 37800 1 CST} {1111888800 34200 0 CST} {1130637600 37800 1 CST} - {1143338400 34200 0 CST} + {1143943200 34200 0 CST} {1162087200 37800 1 CST} {1174788000 34200 0 CST} {1193536800 37800 1 CST} {1206842400 34200 0 CST} {1224986400 37800 1 CST} ADDED library/tzdata/Australia/Currie Index: library/tzdata/Australia/Currie ================================================================== --- /dev/null +++ library/tzdata/Australia/Currie @@ -0,0 +1,273 @@ +# created by ../tools/tclZIC.tcl - do not edit + +set TZData(:Australia/Currie) { + {-9223372036854775808 34528 0 LMT} + {-2345794528 36000 0 EST} + {-1680508800 39600 1 EST} + {-1669892400 39600 0 EST} + {-1665392400 36000 0 EST} + {-883641600 39600 1 EST} + {-876128400 36000 0 EST} + {-860400000 39600 1 EST} + {-844678800 36000 0 EST} + {-828345600 39600 1 EST} + {-813229200 36000 0 EST} + {47138400 36000 0 EST} + {57722400 39600 1 EST} + {68004000 36000 0 EST} + {89172000 39600 1 EST} + {100058400 36000 0 EST} + {120621600 39600 1 EST} + {131508000 36000 0 EST} + {152071200 39600 1 EST} + {162957600 36000 0 EST} + {183520800 39600 1 EST} + {195012000 36000 0 EST} + {215575200 39600 1 EST} + {226461600 36000 0 EST} + {247024800 39600 1 EST} + {257911200 36000 0 EST} + {278474400 39600 1 EST} + {289360800 36000 0 EST} + {309924000 39600 1 EST} + {320810400 36000 0 EST} + {341373600 39600 1 EST} + {352260000 36000 0 EST} + {372823200 39600 1 EST} + {386128800 36000 0 EST} + {404877600 39600 1 EST} + {417578400 36000 0 EST} + {436327200 39600 1 EST} + {447213600 36000 0 EST} + {467776800 39600 1 EST} + {478663200 36000 0 EST} + {499226400 39600 1 EST} + {510112800 36000 0 EST} + {530071200 39600 1 EST} + {542772000 36000 0 EST} + {562125600 39600 1 EST} + {574826400 36000 0 EST} + {594180000 39600 1 EST} + {606276000 36000 0 EST} + {625629600 39600 1 EST} + {637725600 36000 0 EST} + {657079200 39600 1 EST} + {670384800 36000 0 EST} + {686714400 39600 1 EST} + {701834400 36000 0 EST} + {718164000 39600 1 EST} + {733284000 36000 0 EST} + {749613600 39600 1 EST} + {764733600 36000 0 EST} + {781063200 39600 1 EST} + {796183200 36000 0 EST} + {812512800 39600 1 EST} + {828237600 36000 0 EST} + {844567200 39600 1 EST} + {859687200 36000 0 EST} + {876016800 39600 1 EST} + {891136800 36000 0 EST} + {907466400 39600 1 EST} + {922586400 36000 0 EST} + {938916000 39600 1 EST} + {954036000 36000 0 EST} + {967341600 39600 1 EST} + {985485600 36000 0 EST} + {1002420000 39600 1 EST} + {1017540000 36000 0 EST} + {1033869600 39600 1 EST} + {1048989600 36000 0 EST} + {1065319200 39600 1 EST} + {1080439200 36000 0 EST} + {1096768800 39600 1 EST} + {1111888800 36000 0 EST} + {1128218400 39600 1 EST} + {1143943200 36000 0 EST} + {1159668000 39600 1 EST} + {1174788000 36000 0 EST} + {1191722400 39600 1 EST} + {1206842400 36000 0 EST} + {1223172000 39600 1 EST} + {1238292000 36000 0 EST} + {1254621600 39600 1 EST} + {1269741600 36000 0 EST} + {1286071200 39600 1 EST} + {1301191200 36000 0 EST} + {1317520800 39600 1 EST} + {1332640800 36000 0 EST} + {1349575200 39600 1 EST} + {1364695200 36000 0 EST} + {1381024800 39600 1 EST} + {1396144800 36000 0 EST} + {1412474400 39600 1 EST} + {1427594400 36000 0 EST} + {1443924000 39600 1 EST} + {1459044000 36000 0 EST} + {1475373600 39600 1 EST} + {1490493600 36000 0 EST} + {1506823200 39600 1 EST} + {1521943200 36000 0 EST} + {1538877600 39600 1 EST} + {1553997600 36000 0 EST} + {1570327200 39600 1 EST} + {1585447200 36000 0 EST} + {1601776800 39600 1 EST} + {1616896800 36000 0 EST} + {1633226400 39600 1 EST} + {1648346400 36000 0 EST} + {1664676000 39600 1 EST} + {1679796000 36000 0 EST} + {1696125600 39600 1 EST} + {1711850400 36000 0 EST} + {1728180000 39600 1 EST} + {1743300000 36000 0 EST} + {1759629600 39600 1 EST} + {1774749600 36000 0 EST} + {1791079200 39600 1 EST} + {1806199200 36000 0 EST} + {1822528800 39600 1 EST} + {1837648800 36000 0 EST} + {1853978400 39600 1 EST} + {1869098400 36000 0 EST} + {1886032800 39600 1 EST} + {1901152800 36000 0 EST} + {1917482400 39600 1 EST} + {1932602400 36000 0 EST} + {1948932000 39600 1 EST} + {1964052000 36000 0 EST} + {1980381600 39600 1 EST} + {1995501600 36000 0 EST} + {2011831200 39600 1 EST} + {2026951200 36000 0 EST} + {2043280800 39600 1 EST} + {2058400800 36000 0 EST} + {2075335200 39600 1 EST} + {2090455200 36000 0 EST} + {2106784800 39600 1 EST} + {2121904800 36000 0 EST} + {2138234400 39600 1 EST} + {2153354400 36000 0 EST} + {2169684000 39600 1 EST} + {2184804000 36000 0 EST} + {2201133600 39600 1 EST} + {2216253600 36000 0 EST} + {2233188000 39600 1 EST} + {2248308000 36000 0 EST} + {2264637600 39600 1 EST} + {2279757600 36000 0 EST} + {2296087200 39600 1 EST} + {2311207200 36000 0 EST} + {2327536800 39600 1 EST} + {2342656800 36000 0 EST} + {2358986400 39600 1 EST} + {2374106400 36000 0 EST} + {2390436000 39600 1 EST} + {2405556000 36000 0 EST} + {2422490400 39600 1 EST} + {2437610400 36000 0 EST} + {2453940000 39600 1 EST} + {2469060000 36000 0 EST} + {2485389600 39600 1 EST} + {2500509600 36000 0 EST} + {2516839200 39600 1 EST} + {2531959200 36000 0 EST} + {2548288800 39600 1 EST} + {2563408800 36000 0 EST} + {2579738400 39600 1 EST} + {2595463200 36000 0 EST} + {2611792800 39600 1 EST} + {2626912800 36000 0 EST} + {2643242400 39600 1 EST} + {2658362400 36000 0 EST} + {2674692000 39600 1 EST} + {2689812000 36000 0 EST} + {2706141600 39600 1 EST} + {2721261600 36000 0 EST} + {2737591200 39600 1 EST} + {2752711200 36000 0 EST} + {2769645600 39600 1 EST} + {2784765600 36000 0 EST} + {2801095200 39600 1 EST} + {2816215200 36000 0 EST} + {2832544800 39600 1 EST} + {2847664800 36000 0 EST} + {2863994400 39600 1 EST} + {2879114400 36000 0 EST} + {2895444000 39600 1 EST} + {2910564000 36000 0 EST} + {2926893600 39600 1 EST} + {2942013600 36000 0 EST} + {2958948000 39600 1 EST} + {2974068000 36000 0 EST} + {2990397600 39600 1 EST} + {3005517600 36000 0 EST} + {3021847200 39600 1 EST} + {3036967200 36000 0 EST} + {3053296800 39600 1 EST} + {3068416800 36000 0 EST} + {3084746400 39600 1 EST} + {3099866400 36000 0 EST} + {3116800800 39600 1 EST} + {3131920800 36000 0 EST} + {3148250400 39600 1 EST} + {3163370400 36000 0 EST} + {3179700000 39600 1 EST} + {3194820000 36000 0 EST} + {3211149600 39600 1 EST} + {3226269600 36000 0 EST} + {3242599200 39600 1 EST} + {3257719200 36000 0 EST} + {3274048800 39600 1 EST} + {3289168800 36000 0 EST} + {3306103200 39600 1 EST} + {3321223200 36000 0 EST} + {3337552800 39600 1 EST} + {3352672800 36000 0 EST} + {3369002400 39600 1 EST} + {3384122400 36000 0 EST} + {3400452000 39600 1 EST} + {3415572000 36000 0 EST} + {3431901600 39600 1 EST} + {3447021600 36000 0 EST} + {3463351200 39600 1 EST} + {3479076000 36000 0 EST} + {3495405600 39600 1 EST} + {3510525600 36000 0 EST} + {3526855200 39600 1 EST} + {3541975200 36000 0 EST} + {3558304800 39600 1 EST} + {3573424800 36000 0 EST} + {3589754400 39600 1 EST} + {3604874400 36000 0 EST} + {3621204000 39600 1 EST} + {3636324000 36000 0 EST} + {3653258400 39600 1 EST} + {3668378400 36000 0 EST} + {3684708000 39600 1 EST} + {3699828000 36000 0 EST} + {3716157600 39600 1 EST} + {3731277600 36000 0 EST} + {3747607200 39600 1 EST} + {3762727200 36000 0 EST} + {3779056800 39600 1 EST} + {3794176800 36000 0 EST} + {3810506400 39600 1 EST} + {3825626400 36000 0 EST} + {3842560800 39600 1 EST} + {3857680800 36000 0 EST} + {3874010400 39600 1 EST} + {3889130400 36000 0 EST} + {3905460000 39600 1 EST} + {3920580000 36000 0 EST} + {3936909600 39600 1 EST} + {3952029600 36000 0 EST} + {3968359200 39600 1 EST} + {3983479200 36000 0 EST} + {4000413600 39600 1 EST} + {4015533600 36000 0 EST} + {4031863200 39600 1 EST} + {4046983200 36000 0 EST} + {4063312800 39600 1 EST} + {4078432800 36000 0 EST} + {4094762400 39600 1 EST} +} Index: library/tzdata/Australia/Hobart ================================================================== --- library/tzdata/Australia/Hobart +++ library/tzdata/Australia/Hobart @@ -88,11 +88,11 @@ {1065319200 39600 1 EST} {1080439200 36000 0 EST} {1096768800 39600 1 EST} {1111888800 36000 0 EST} {1128218400 39600 1 EST} - {1143338400 36000 0 EST} + {1143943200 36000 0 EST} {1159668000 39600 1 EST} {1174788000 36000 0 EST} {1191722400 39600 1 EST} {1206842400 36000 0 EST} {1223172000 39600 1 EST} Index: library/tzdata/Australia/Lord_Howe ================================================================== --- library/tzdata/Australia/Lord_Howe +++ library/tzdata/Australia/Lord_Howe @@ -51,11 +51,11 @@ {1067095800 39600 1 LHST} {1080399600 37800 0 LHST} {1099150200 39600 1 LHST} {1111849200 37800 0 LHST} {1130599800 39600 1 LHST} - {1143298800 37800 0 LHST} + {1143903600 37800 0 LHST} {1162049400 39600 1 LHST} {1174748400 37800 0 LHST} {1193499000 39600 1 LHST} {1206802800 37800 0 LHST} {1224948600 39600 1 LHST} Index: library/tzdata/Australia/Melbourne ================================================================== --- library/tzdata/Australia/Melbourne +++ library/tzdata/Australia/Melbourne @@ -79,11 +79,11 @@ {1067133600 39600 1 EST} {1080439200 36000 0 EST} {1099188000 39600 1 EST} {1111888800 36000 0 EST} {1130637600 39600 1 EST} - {1143338400 36000 0 EST} + {1143943200 36000 0 EST} {1162087200 39600 1 EST} {1174788000 36000 0 EST} {1193536800 39600 1 EST} {1206842400 36000 0 EST} {1224986400 39600 1 EST} Index: library/tzdata/Australia/Sydney ================================================================== --- library/tzdata/Australia/Sydney +++ library/tzdata/Australia/Sydney @@ -79,11 +79,11 @@ {1067133600 39600 1 EST} {1080439200 36000 0 EST} {1099188000 39600 1 EST} {1111888800 36000 0 EST} {1130637600 39600 1 EST} - {1143338400 36000 0 EST} + {1143943200 36000 0 EST} {1162087200 39600 1 EST} {1174788000 36000 0 EST} {1193536800 39600 1 EST} {1206842400 36000 0 EST} {1224986400 39600 1 EST} Index: library/tzdata/Brazil/Acre ================================================================== --- library/tzdata/Brazil/Acre +++ library/tzdata/Brazil/Acre @@ -1,5 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Porto_Acre)]} { - LoadTimeZoneFile America/Porto_Acre +if {![info exists TZData(America/Rio_Branco)]} { + LoadTimeZoneFile America/Rio_Branco } -set TZData(:Brazil/Acre) $TZData(:America/Porto_Acre) +set TZData(:Brazil/Acre) $TZData(:America/Rio_Branco) Index: library/tzdata/EST ================================================================== --- library/tzdata/EST +++ library/tzdata/EST @@ -1,5 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Indianapolis)]} { - LoadTimeZoneFile America/Indianapolis +if {![info exists TZData(America/Panama)]} { + LoadTimeZoneFile America/Panama } -set TZData(:EST) $TZData(:America/Indianapolis) +set TZData(:EST) $TZData(:America/Panama) Index: library/tzdata/Europe/Belfast ================================================================== --- library/tzdata/Europe/Belfast +++ library/tzdata/Europe/Belfast @@ -1,372 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit - -set TZData(:Europe/Belfast) { - {-9223372036854775808 -1420 0 LMT} - {-2821649780 -1521 0 DMT} - {-1691962479 2079 1 IST} - {-1680472800 0 0 GMT} - {-1664143200 3600 1 BST} - {-1650146400 0 0 GMT} - {-1633903200 3600 1 BST} - {-1617487200 0 0 GMT} - {-1601848800 3600 1 BST} - {-1586037600 0 0 GMT} - {-1570399200 3600 1 BST} - {-1552168800 0 0 GMT} - {-1538344800 3600 1 BST} - {-1522533600 0 0 GMT} - {-1507500000 3600 1 BST} - {-1490565600 0 0 GMT} - {-1473631200 3600 1 BST} - {-1460930400 0 0 GMT} - {-1442786400 3600 1 BST} - {-1428876000 0 0 GMT} - {-1410732000 3600 1 BST} - {-1396216800 0 0 GMT} - {-1379282400 3600 1 BST} - {-1364767200 0 0 GMT} - {-1348437600 3600 1 BST} - {-1333317600 0 0 GMT} - {-1315778400 3600 1 BST} - {-1301263200 0 0 GMT} - {-1284328800 3600 1 BST} - {-1269813600 0 0 GMT} - {-1253484000 3600 1 BST} - {-1238364000 0 0 GMT} - {-1221429600 3600 1 BST} - {-1206914400 0 0 GMT} - {-1189980000 3600 1 BST} - {-1175464800 0 0 GMT} - {-1159135200 3600 1 BST} - {-1143410400 0 0 GMT} - {-1126476000 3600 1 BST} - {-1111960800 0 0 GMT} - {-1095631200 3600 1 BST} - {-1080511200 0 0 GMT} - {-1063576800 3600 1 BST} - {-1049061600 0 0 GMT} - {-1032127200 3600 1 BST} - {-1017612000 0 0 GMT} - {-1001282400 3600 1 BST} - {-986162400 0 0 GMT} - {-969228000 3600 1 BST} - {-950479200 0 0 GMT} - {-942012000 3600 1 BST} - {-904518000 7200 1 BDST} - {-896050800 3600 1 BST} - {-875487600 7200 1 BDST} - {-864601200 3600 1 BST} - {-844038000 7200 1 BDST} - {-832546800 3600 1 BST} - {-812588400 7200 1 BDST} - {-798073200 3600 1 BST} - {-781052400 7200 1 BDST} - {-772066800 3600 1 BST} - {-764805600 0 0 GMT} - {-748476000 3600 1 BST} - {-733356000 0 0 GMT} - {-719445600 3600 1 BST} - {-717030000 7200 1 BDST} - {-706748400 3600 1 BST} - {-699487200 0 0 GMT} - {-687996000 3600 1 BST} - {-668037600 0 0 GMT} - {-654732000 3600 1 BST} - {-636588000 0 0 GMT} - {-622072800 3600 1 BST} - {-605743200 0 0 GMT} - {-590623200 3600 1 BST} - {-574293600 0 0 GMT} - {-558568800 3600 1 BST} - {-542239200 0 0 GMT} - {-527119200 3600 1 BST} - {-512604000 0 0 GMT} - {-496274400 3600 1 BST} - {-481154400 0 0 GMT} - {-464220000 3600 1 BST} - {-449704800 0 0 GMT} - {-432165600 3600 1 BST} - {-417650400 0 0 GMT} - {-401320800 3600 1 BST} - {-386200800 0 0 GMT} - {-369266400 3600 1 BST} - {-354751200 0 0 GMT} - {-337816800 3600 1 BST} - {-323301600 0 0 GMT} - {-306972000 3600 1 BST} - {-291852000 0 0 GMT} - {-276732000 3600 1 BST} - {-257983200 0 0 GMT} - {-245282400 3600 1 BST} - {-226533600 0 0 GMT} - {-213228000 3600 1 BST} - {-195084000 0 0 GMT} - {-182383200 3600 1 BST} - {-163634400 0 0 GMT} - {-150933600 3600 1 BST} - {-132184800 0 0 GMT} - {-119484000 3600 1 BST} - {-100735200 0 0 GMT} - {-88034400 3600 1 BST} - {-68680800 0 0 GMT} - {-59004000 3600 1 BST} - {-37238400 3600 0 BST} - {57722400 0 0 GMT} - {69818400 3600 1 BST} - {89172000 0 0 GMT} - {101268000 3600 1 BST} - {120621600 0 0 GMT} - {132717600 3600 1 BST} - {152071200 0 0 GMT} - {164167200 3600 1 BST} - {183520800 0 0 GMT} - {196221600 3600 1 BST} - {214970400 0 0 GMT} - {227671200 3600 1 BST} - {246420000 0 0 GMT} - {259120800 3600 1 BST} - {278474400 0 0 GMT} - {290570400 3600 1 BST} - {309924000 0 0 GMT} - {322020000 3600 1 BST} - {341373600 0 0 GMT} - {354675600 3600 1 BST} - {372819600 0 0 GMT} - {386125200 3600 1 BST} - {404269200 0 0 GMT} - {417574800 3600 1 BST} - {435718800 0 0 GMT} - {449024400 3600 1 BST} - {467773200 0 0 GMT} - {481078800 3600 1 BST} - {499222800 0 0 GMT} - {512528400 3600 1 BST} - {530672400 0 0 GMT} - {543978000 3600 1 BST} - {562122000 0 0 GMT} - {575427600 3600 1 BST} - {593571600 0 0 GMT} - {606877200 3600 1 BST} - {625626000 0 0 GMT} - {638326800 3600 1 BST} - {657075600 0 0 GMT} - {670381200 3600 1 BST} - {688525200 0 0 GMT} - {701830800 3600 1 BST} - {719974800 0 0 GMT} - {733280400 3600 1 BST} - {751424400 0 0 GMT} - {764730000 3600 1 BST} - {782874000 0 0 GMT} - {796179600 3600 1 BST} - {814323600 0 0 GMT} - {820454400 0 0 GMT} - {828234000 3600 1 BST} - {846378000 0 0 GMT} - {859683600 3600 1 BST} - {877827600 0 0 GMT} - {891133200 3600 1 BST} - {909277200 0 0 GMT} - {922582800 3600 1 BST} - {941331600 0 0 GMT} - {954032400 3600 1 BST} - {972781200 0 0 GMT} - {985482000 3600 1 BST} - {1004230800 0 0 GMT} - {1017536400 3600 1 BST} - {1035680400 0 0 GMT} - {1048986000 3600 1 BST} - {1067130000 0 0 GMT} - {1080435600 3600 1 BST} - {1099184400 0 0 GMT} - {1111885200 3600 1 BST} - {1130634000 0 0 GMT} - {1143334800 3600 1 BST} - {1162083600 0 0 GMT} - {1174784400 3600 1 BST} - {1193533200 0 0 GMT} - {1206838800 3600 1 BST} - {1224982800 0 0 GMT} - {1238288400 3600 1 BST} - {1256432400 0 0 GMT} - {1269738000 3600 1 BST} - {1288486800 0 0 GMT} - {1301187600 3600 1 BST} - {1319936400 0 0 GMT} - {1332637200 3600 1 BST} - {1351386000 0 0 GMT} - {1364691600 3600 1 BST} - {1382835600 0 0 GMT} - {1396141200 3600 1 BST} - {1414285200 0 0 GMT} - {1427590800 3600 1 BST} - {1445734800 0 0 GMT} - {1459040400 3600 1 BST} - {1477789200 0 0 GMT} - {1490490000 3600 1 BST} - {1509238800 0 0 GMT} - {1521939600 3600 1 BST} - {1540688400 0 0 GMT} - {1553994000 3600 1 BST} - {1572138000 0 0 GMT} - {1585443600 3600 1 BST} - {1603587600 0 0 GMT} - {1616893200 3600 1 BST} - {1635642000 0 0 GMT} - {1648342800 3600 1 BST} - {1667091600 0 0 GMT} - {1679792400 3600 1 BST} - {1698541200 0 0 GMT} - {1711846800 3600 1 BST} - {1729990800 0 0 GMT} - {1743296400 3600 1 BST} - {1761440400 0 0 GMT} - {1774746000 3600 1 BST} - {1792890000 0 0 GMT} - {1806195600 3600 1 BST} - {1824944400 0 0 GMT} - {1837645200 3600 1 BST} - {1856394000 0 0 GMT} - {1869094800 3600 1 BST} - {1887843600 0 0 GMT} - {1901149200 3600 1 BST} - {1919293200 0 0 GMT} - {1932598800 3600 1 BST} - {1950742800 0 0 GMT} - {1964048400 3600 1 BST} - {1982797200 0 0 GMT} - {1995498000 3600 1 BST} - {2014246800 0 0 GMT} - {2026947600 3600 1 BST} - {2045696400 0 0 GMT} - {2058397200 3600 1 BST} - {2077146000 0 0 GMT} - {2090451600 3600 1 BST} - {2108595600 0 0 GMT} - {2121901200 3600 1 BST} - {2140045200 0 0 GMT} - {2153350800 3600 1 BST} - {2172099600 0 0 GMT} - {2184800400 3600 1 BST} - {2203549200 0 0 GMT} - {2216250000 3600 1 BST} - {2234998800 0 0 GMT} - {2248304400 3600 1 BST} - {2266448400 0 0 GMT} - {2279754000 3600 1 BST} - {2297898000 0 0 GMT} - {2311203600 3600 1 BST} - {2329347600 0 0 GMT} - {2342653200 3600 1 BST} - {2361402000 0 0 GMT} - {2374102800 3600 1 BST} - {2392851600 0 0 GMT} - {2405552400 3600 1 BST} - {2424301200 0 0 GMT} - {2437606800 3600 1 BST} - {2455750800 0 0 GMT} - {2469056400 3600 1 BST} - {2487200400 0 0 GMT} - {2500506000 3600 1 BST} - {2519254800 0 0 GMT} - {2531955600 3600 1 BST} - {2550704400 0 0 GMT} - {2563405200 3600 1 BST} - {2582154000 0 0 GMT} - {2595459600 3600 1 BST} - {2613603600 0 0 GMT} - {2626909200 3600 1 BST} - {2645053200 0 0 GMT} - {2658358800 3600 1 BST} - {2676502800 0 0 GMT} - {2689808400 3600 1 BST} - {2708557200 0 0 GMT} - {2721258000 3600 1 BST} - {2740006800 0 0 GMT} - {2752707600 3600 1 BST} - {2771456400 0 0 GMT} - {2784762000 3600 1 BST} - {2802906000 0 0 GMT} - {2816211600 3600 1 BST} - {2834355600 0 0 GMT} - {2847661200 3600 1 BST} - {2866410000 0 0 GMT} - {2879110800 3600 1 BST} - {2897859600 0 0 GMT} - {2910560400 3600 1 BST} - {2929309200 0 0 GMT} - {2942010000 3600 1 BST} - {2960758800 0 0 GMT} - {2974064400 3600 1 BST} - {2992208400 0 0 GMT} - {3005514000 3600 1 BST} - {3023658000 0 0 GMT} - {3036963600 3600 1 BST} - {3055712400 0 0 GMT} - {3068413200 3600 1 BST} - {3087162000 0 0 GMT} - {3099862800 3600 1 BST} - {3118611600 0 0 GMT} - {3131917200 3600 1 BST} - {3150061200 0 0 GMT} - {3163366800 3600 1 BST} - {3181510800 0 0 GMT} - {3194816400 3600 1 BST} - {3212960400 0 0 GMT} - {3226266000 3600 1 BST} - {3245014800 0 0 GMT} - {3257715600 3600 1 BST} - {3276464400 0 0 GMT} - {3289165200 3600 1 BST} - {3307914000 0 0 GMT} - {3321219600 3600 1 BST} - {3339363600 0 0 GMT} - {3352669200 3600 1 BST} - {3370813200 0 0 GMT} - {3384118800 3600 1 BST} - {3402867600 0 0 GMT} - {3415568400 3600 1 BST} - {3434317200 0 0 GMT} - {3447018000 3600 1 BST} - {3465766800 0 0 GMT} - {3479072400 3600 1 BST} - {3497216400 0 0 GMT} - {3510522000 3600 1 BST} - {3528666000 0 0 GMT} - {3541971600 3600 1 BST} - {3560115600 0 0 GMT} - {3573421200 3600 1 BST} - {3592170000 0 0 GMT} - {3604870800 3600 1 BST} - {3623619600 0 0 GMT} - {3636320400 3600 1 BST} - {3655069200 0 0 GMT} - {3668374800 3600 1 BST} - {3686518800 0 0 GMT} - {3699824400 3600 1 BST} - {3717968400 0 0 GMT} - {3731274000 3600 1 BST} - {3750022800 0 0 GMT} - {3762723600 3600 1 BST} - {3781472400 0 0 GMT} - {3794173200 3600 1 BST} - {3812922000 0 0 GMT} - {3825622800 3600 1 BST} - {3844371600 0 0 GMT} - {3857677200 3600 1 BST} - {3875821200 0 0 GMT} - {3889126800 3600 1 BST} - {3907270800 0 0 GMT} - {3920576400 3600 1 BST} - {3939325200 0 0 GMT} - {3952026000 3600 1 BST} - {3970774800 0 0 GMT} - {3983475600 3600 1 BST} - {4002224400 0 0 GMT} - {4015530000 3600 1 BST} - {4033674000 0 0 GMT} - {4046979600 3600 1 BST} - {4065123600 0 0 GMT} - {4078429200 3600 1 BST} - {4096573200 0 0 GMT} -} +if {![info exists TZData(Europe/London)]} { + LoadTimeZoneFile Europe/London +} +set TZData(:Europe/Belfast) $TZData(:Europe/London) Index: library/tzdata/Europe/Copenhagen ================================================================== --- library/tzdata/Europe/Copenhagen +++ library/tzdata/Europe/Copenhagen @@ -1,11 +1,11 @@ # created by ../tools/tclZIC.tcl - do not edit set TZData(:Europe/Copenhagen) { {-9223372036854775808 3020 0 LMT} {-2524524620 3020 0 CMT} - {-2390518220 3600 0 CET} + {-2398294220 3600 0 CET} {-1692496800 7200 1 CEST} {-1680490800 3600 0 CET} {-935110800 7200 1 CEST} {-857253600 3600 0 CET} {-844552800 7200 1 CEST} Index: library/tzdata/Europe/Warsaw ================================================================== --- library/tzdata/Europe/Warsaw +++ library/tzdata/Europe/Warsaw @@ -19,16 +19,18 @@ {-812498400 7200 1 CEST} {-796870800 3600 0 CET} {-796604400 3600 0 CET} {-778726800 7200 1 CEST} {-762660000 3600 0 CET} - {-748486800 7200 1 CEST} - {-735876000 3600 0 CET} - {-715222800 7200 1 CEST} - {-701920800 3600 0 CET} - {-684982800 7200 1 CEST} - {-670471200 3600 0 CET} + {-748483200 7200 1 CEST} + {-733269600 3600 0 CET} + {-715212000 7200 1 CEST} + {-701906400 3600 0 CET} + {-684972000 7200 1 CEST} + {-670456800 3600 0 CET} + {-654127200 7200 1 CEST} + {-639007200 3600 0 CET} {-397090800 7200 1 CEST} {-386809200 3600 0 CET} {-371084400 7200 1 CEST} {-355359600 3600 0 CET} {-334191600 7200 1 CEST} @@ -41,11 +43,11 @@ {-228956400 3600 0 CET} {-208393200 7200 1 CEST} {-197506800 3600 0 CET} {-176338800 7200 1 CEST} {-166057200 3600 0 CET} - {228873600 3600 0 CET} + {220921200 3600 0 CET} {228877200 7200 1 CEST} {243997200 3600 0 CET} {260326800 7200 1 CEST} {276051600 3600 0 CET} {291776400 7200 1 CEST} @@ -64,10 +66,11 @@ {496803600 3600 0 CET} {512528400 7200 1 CEST} {528253200 3600 0 CET} {543978000 7200 1 CEST} {559702800 3600 0 CET} + {567990000 3600 0 CET} {575427600 7200 1 CEST} {591152400 3600 0 CET} {606877200 7200 1 CEST} {622602000 3600 0 CET} {638326800 7200 1 CEST} @@ -86,11 +89,10 @@ {846378000 3600 0 CET} {859683600 7200 1 CEST} {877827600 3600 0 CET} {891133200 7200 1 CEST} {909277200 3600 0 CET} - {915145200 3600 0 CET} {922582800 7200 1 CEST} {941331600 3600 0 CET} {954032400 7200 1 CEST} {972781200 3600 0 CET} {985482000 7200 1 CEST} Index: library/tzdata/GMT+0 ================================================================== --- library/tzdata/GMT+0 +++ library/tzdata/GMT+0 @@ -1,5 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(Etc/GMT+0)]} { - LoadTimeZoneFile Etc/GMT+0 +if {![info exists TZData(Etc/GMT)]} { + LoadTimeZoneFile Etc/GMT } -set TZData(:GMT+0) $TZData(:Etc/GMT+0) +set TZData(:GMT+0) $TZData(:Etc/GMT) Index: library/tzdata/GMT-0 ================================================================== --- library/tzdata/GMT-0 +++ library/tzdata/GMT-0 @@ -1,5 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(Etc/GMT-0)]} { - LoadTimeZoneFile Etc/GMT-0 +if {![info exists TZData(Etc/GMT)]} { + LoadTimeZoneFile Etc/GMT } -set TZData(:GMT-0) $TZData(:Etc/GMT-0) +set TZData(:GMT-0) $TZData(:Etc/GMT) Index: library/tzdata/GMT0 ================================================================== --- library/tzdata/GMT0 +++ library/tzdata/GMT0 @@ -1,5 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(Etc/GMT0)]} { - LoadTimeZoneFile Etc/GMT0 +if {![info exists TZData(Etc/GMT)]} { + LoadTimeZoneFile Etc/GMT } -set TZData(:GMT0) $TZData(:Etc/GMT0) +set TZData(:GMT0) $TZData(:Etc/GMT) Index: library/tzdata/Greenwich ================================================================== --- library/tzdata/Greenwich +++ library/tzdata/Greenwich @@ -1,5 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(Etc/Greenwich)]} { - LoadTimeZoneFile Etc/Greenwich +if {![info exists TZData(Etc/GMT)]} { + LoadTimeZoneFile Etc/GMT } -set TZData(:Greenwich) $TZData(:Etc/Greenwich) +set TZData(:Greenwich) $TZData(:Etc/GMT) Index: library/tzdata/Indian/Chagos ================================================================== --- library/tzdata/Indian/Chagos +++ library/tzdata/Indian/Chagos @@ -1,6 +1,7 @@ # created by ../tools/tclZIC.tcl - do not edit set TZData(:Indian/Chagos) { - {-9223372036854775808 18000 0 IOT} + {-9223372036854775808 17380 0 LMT} + {-1988167780 18000 0 IOT} {820436400 21600 0 IOT} } Index: library/tzdata/Indian/Cocos ================================================================== --- library/tzdata/Indian/Cocos +++ library/tzdata/Indian/Cocos @@ -1,5 +1,6 @@ # created by ../tools/tclZIC.tcl - do not edit set TZData(:Indian/Cocos) { - {-9223372036854775808 23400 0 CCT} + {-9223372036854775808 23260 0 LMT} + {-2209012060 23400 0 CCT} } Index: library/tzdata/Navajo ================================================================== --- library/tzdata/Navajo +++ library/tzdata/Navajo @@ -1,5 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Shiprock)]} { - LoadTimeZoneFile America/Shiprock +if {![info exists TZData(America/Denver)]} { + LoadTimeZoneFile America/Denver } -set TZData(:Navajo) $TZData(:America/Shiprock) +set TZData(:Navajo) $TZData(:America/Denver) Index: library/tzdata/Pacific/Yap ================================================================== --- library/tzdata/Pacific/Yap +++ library/tzdata/Pacific/Yap @@ -1,7 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit - -set TZData(:Pacific/Yap) { - {-9223372036854775808 33152 0 LMT} - {-2177485952 32400 0 YAPT} - {-7981200 36000 0 YAPT} +if {![info exists TZData(Pacific/Truk)]} { + LoadTimeZoneFile Pacific/Truk } +set TZData(:Pacific/Yap) $TZData(:Pacific/Truk) Index: library/tzdata/US/East-Indiana ================================================================== --- library/tzdata/US/East-Indiana +++ library/tzdata/US/East-Indiana @@ -1,5 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Indianapolis)]} { - LoadTimeZoneFile America/Indianapolis +if {![info exists TZData(America/Indiana/Indianapolis)]} { + LoadTimeZoneFile America/Indiana/Indianapolis } -set TZData(:US/East-Indiana) $TZData(:America/Indianapolis) +set TZData(:US/East-Indiana) $TZData(:America/Indiana/Indianapolis) Index: library/tzdata/Universal ================================================================== --- library/tzdata/Universal +++ library/tzdata/Universal @@ -1,5 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(Etc/Universal)]} { - LoadTimeZoneFile Etc/Universal +if {![info exists TZData(Etc/UTC)]} { + LoadTimeZoneFile Etc/UTC } -set TZData(:Universal) $TZData(:Etc/Universal) +set TZData(:Universal) $TZData(:Etc/UTC) Index: library/tzdata/Zulu ================================================================== --- library/tzdata/Zulu +++ library/tzdata/Zulu @@ -1,5 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(Etc/Zulu)]} { - LoadTimeZoneFile Etc/Zulu +if {![info exists TZData(Etc/UTC)]} { + LoadTimeZoneFile Etc/UTC } -set TZData(:Zulu) $TZData(:Etc/Zulu) +set TZData(:Zulu) $TZData(:Etc/UTC) Index: library/word.tcl ================================================================== --- library/word.tcl +++ library/word.tcl @@ -8,16 +8,16 @@ # Copyright (c) 1998 by Scritpics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: word.tcl,v 1.7 2002/11/01 00:28:51 andreas_kupries Exp $ +# RCS: @(#) $Id: word.tcl,v 1.7.6.1 2005/08/02 18:16:15 dgp Exp $ # The following variables are used to determine which characters are # interpreted as white space. -if {[string equal $::tcl_platform(platform) "windows"]} { +if {$::tcl_platform(platform) eq "windows"} { # Windows style - any but a unicode space char set tcl_wordchars "\\S" set tcl_nonwordchars "\\s" } else { # Motif style - any unicode word char (number, letter, or underscore) @@ -56,11 +56,11 @@ # str - String to search. # start - Index into string specifying starting point. proc tcl_wordBreakBefore {str start} { global tcl_nonwordchars tcl_wordchars - if {[string equal $start end]} { + if {$start eq "end"} { set start [string length $str] } if {[regexp -indices "^.*($tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars)" [string range $str 0 $start] result]} { return [lindex $result 1] } @@ -118,15 +118,15 @@ # str - String to search. # start - Index into string specifying starting point. proc tcl_startOfPreviousWord {str start} { global tcl_nonwordchars tcl_wordchars - if {[string equal $start end]} { + if {$start eq "end"} { set start [string length $str] } if {[regexp -indices \ "$tcl_nonwordchars*($tcl_wordchars+)$tcl_nonwordchars*\$" \ [string range $str 0 [expr {$start - 1}]] result word]} { return [lindex $word 0] } return -1 } ADDED libtommath/bn.pdf Index: libtommath/bn.pdf ================================================================== --- /dev/null +++ libtommath/bn.pdf cannot compute difference between binary files ADDED libtommath/bn.tex Index: libtommath/bn.tex ================================================================== --- /dev/null +++ libtommath/bn.tex @@ -0,0 +1,1835 @@ +\documentclass[b5paper]{book} +\usepackage{hyperref} +\usepackage{makeidx} +\usepackage{amssymb} +\usepackage{color} +\usepackage{alltt} +\usepackage{graphicx} +\usepackage{layout} +\def\union{\cup} +\def\intersect{\cap} +\def\getsrandom{\stackrel{\rm R}{\gets}} +\def\cross{\times} +\def\cat{\hspace{0.5em} \| \hspace{0.5em}} +\def\catn{$\|$} +\def\divides{\hspace{0.3em} | \hspace{0.3em}} +\def\nequiv{\not\equiv} +\def\approx{\raisebox{0.2ex}{\mbox{\small $\sim$}}} +\def\lcm{{\rm lcm}} +\def\gcd{{\rm gcd}} +\def\log{{\rm log}} +\def\ord{{\rm ord}} +\def\abs{{\mathit abs}} +\def\rep{{\mathit rep}} +\def\mod{{\mathit\ mod\ }} +\renewcommand{\pmod}[1]{\ ({\rm mod\ }{#1})} +\newcommand{\floor}[1]{\left\lfloor{#1}\right\rfloor} +\newcommand{\ceil}[1]{\left\lceil{#1}\right\rceil} +\def\Or{{\rm\ or\ }} +\def\And{{\rm\ and\ }} +\def\iff{\hspace{1em}\Longleftrightarrow\hspace{1em}} +\def\implies{\Rightarrow} +\def\undefined{{\rm ``undefined"}} +\def\Proof{\vspace{1ex}\noindent {\bf Proof:}\hspace{1em}} +\let\oldphi\phi +\def\phi{\varphi} +\def\Pr{{\rm Pr}} +\newcommand{\str}[1]{{\mathbf{#1}}} +\def\F{{\mathbb F}} +\def\N{{\mathbb N}} +\def\Z{{\mathbb Z}} +\def\R{{\mathbb R}} +\def\C{{\mathbb C}} +\def\Q{{\mathbb Q}} +\definecolor{DGray}{gray}{0.5} +\newcommand{\emailaddr}[1]{\mbox{$<${#1}$>$}} +\def\twiddle{\raisebox{0.3ex}{\mbox{\tiny $\sim$}}} +\def\gap{\vspace{0.5ex}} +\makeindex +\begin{document} +\frontmatter +\pagestyle{empty} +\title{LibTomMath User Manual \\ v0.36} +\author{Tom St Denis \\ tomstdenis@iahu.ca} +\maketitle +This text, the library and the accompanying textbook are all hereby placed in the public domain. This book has been +formatted for B5 [176x250] paper using the \LaTeX{} {\em book} macro package. + +\vspace{10cm} + +\begin{flushright}Open Source. Open Academia. Open Minds. + +\mbox{ } + +Tom St Denis, + +Ontario, Canada +\end{flushright} + +\tableofcontents +\listoffigures +\mainmatter +\pagestyle{headings} +\chapter{Introduction} +\section{What is LibTomMath?} +LibTomMath is a library of source code which provides a series of efficient and carefully written functions for manipulating +large integer numbers. It was written in portable ISO C source code so that it will build on any platform with a conforming +C compiler. + +In a nutshell the library was written from scratch with verbose comments to help instruct computer science students how +to implement ``bignum'' math. However, the resulting code has proven to be very useful. It has been used by numerous +universities, commercial and open source software developers. It has been used on a variety of platforms ranging from +Linux and Windows based x86 to ARM based Gameboys and PPC based MacOS machines. + +\section{License} +As of the v0.25 the library source code has been placed in the public domain with every new release. As of the v0.28 +release the textbook ``Implementing Multiple Precision Arithmetic'' has been placed in the public domain with every new +release as well. This textbook is meant to compliment the project by providing a more solid walkthrough of the development +algorithms used in the library. + +Since both\footnote{Note that the MPI files under mtest/ are copyrighted by Michael Fromberger. They are not required to use LibTomMath.} are in the +public domain everyone is entitled to do with them as they see fit. + +\section{Building LibTomMath} + +LibTomMath is meant to be very ``GCC friendly'' as it comes with a makefile well suited for GCC. However, the library will +also build in MSVC, Borland C out of the box. For any other ISO C compiler a makefile will have to be made by the end +developer. + +\subsection{Static Libraries} +To build as a static library for GCC issue the following +\begin{alltt} +make +\end{alltt} + +command. This will build the library and archive the object files in ``libtommath.a''. Now you link against +that and include ``tommath.h'' within your programs. Alternatively to build with MSVC issue the following +\begin{alltt} +nmake -f makefile.msvc +\end{alltt} + +This will build the library and archive the object files in ``tommath.lib''. This has been tested with MSVC +version 6.00 with service pack 5. + +\subsection{Shared Libraries} +To build as a shared library for GCC issue the following +\begin{alltt} +make -f makefile.shared +\end{alltt} +This requires the ``libtool'' package (common on most Linux/BSD systems). It will build LibTomMath as both shared +and static then install (by default) into /usr/lib as well as install the header files in /usr/include. The shared +library (resource) will be called ``libtommath.la'' while the static library called ``libtommath.a''. Generally +you use libtool to link your application against the shared object. + +There is limited support for making a ``DLL'' in windows via the ``makefile.cygwin\_dll'' makefile. It requires +Cygwin to work with since it requires the auto-export/import functionality. The resulting DLL and import library +``libtommath.dll.a'' can be used to link LibTomMath dynamically to any Windows program using Cygwin. + +\subsection{Testing} +To build the library and the test harness type + +\begin{alltt} +make test +\end{alltt} + +This will build the library, ``test'' and ``mtest/mtest''. The ``test'' program will accept test vectors and verify the +results. ``mtest/mtest'' will generate test vectors using the MPI library by Michael Fromberger\footnote{A copy of MPI +is included in the package}. Simply pipe mtest into test using + +\begin{alltt} +mtest/mtest | test +\end{alltt} + +If you do not have a ``/dev/urandom'' style RNG source you will have to write your own PRNG and simply pipe that into +mtest. For example, if your PRNG program is called ``myprng'' simply invoke + +\begin{alltt} +myprng | mtest/mtest | test +\end{alltt} + +This will output a row of numbers that are increasing. Each column is a different test (such as addition, multiplication, etc) +that is being performed. The numbers represent how many times the test was invoked. If an error is detected the program +will exit with a dump of the relevent numbers it was working with. + +\section{Build Configuration} +LibTomMath can configured at build time in three phases we shall call ``depends'', ``tweaks'' and ``trims''. +Each phase changes how the library is built and they are applied one after another respectively. + +To make the system more powerful you can tweak the build process. Classes are defined in the file +``tommath\_superclass.h''. By default, the symbol ``LTM\_ALL'' shall be defined which simply +instructs the system to build all of the functions. This is how LibTomMath used to be packaged. This will give you +access to every function LibTomMath offers. + +However, there are cases where such a build is not optional. For instance, you want to perform RSA operations. You +don't need the vast majority of the library to perform these operations. Aside from LTM\_ALL there is +another pre--defined class ``SC\_RSA\_1'' which works in conjunction with the RSA from LibTomCrypt. Additional +classes can be defined base on the need of the user. + +\subsection{Build Depends} +In the file tommath\_class.h you will see a large list of C ``defines'' followed by a series of ``ifdefs'' +which further define symbols. All of the symbols (technically they're macros $\ldots$) represent a given C source +file. For instance, BN\_MP\_ADD\_C represents the file ``bn\_mp\_add.c''. When a define has been enabled the +function in the respective file will be compiled and linked into the library. Accordingly when the define +is absent the file will not be compiled and not contribute any size to the library. + +You will also note that the header tommath\_class.h is actually recursively included (it includes itself twice). +This is to help resolve as many dependencies as possible. In the last pass the symbol LTM\_LAST will be defined. +This is useful for ``trims''. + +\subsection{Build Tweaks} +A tweak is an algorithm ``alternative''. For example, to provide tradeoffs (usually between size and space). +They can be enabled at any pass of the configuration phase. + +\begin{small} +\begin{center} +\begin{tabular}{|l|l|} +\hline \textbf{Define} & \textbf{Purpose} \\ +\hline BN\_MP\_DIV\_SMALL & Enables a slower, smaller and equally \\ + & functional mp\_div() function \\ +\hline +\end{tabular} +\end{center} +\end{small} + +\subsection{Build Trims} +A trim is a manner of removing functionality from a function that is not required. For instance, to perform +RSA cryptography you only require exponentiation with odd moduli so even moduli support can be safely removed. +Build trims are meant to be defined on the last pass of the configuration which means they are to be defined +only if LTM\_LAST has been defined. + +\subsubsection{Moduli Related} +\begin{small} +\begin{center} +\begin{tabular}{|l|l|} +\hline \textbf{Restriction} & \textbf{Undefine} \\ +\hline Exponentiation with odd moduli only & BN\_S\_MP\_EXPTMOD\_C \\ + & BN\_MP\_REDUCE\_C \\ + & BN\_MP\_REDUCE\_SETUP\_C \\ + & BN\_S\_MP\_MUL\_HIGH\_DIGS\_C \\ + & BN\_FAST\_S\_MP\_MUL\_HIGH\_DIGS\_C \\ +\hline Exponentiation with random odd moduli & (The above plus the following) \\ + & BN\_MP\_REDUCE\_2K\_C \\ + & BN\_MP\_REDUCE\_2K\_SETUP\_C \\ + & BN\_MP\_REDUCE\_IS\_2K\_C \\ + & BN\_MP\_DR\_IS\_MODULUS\_C \\ + & BN\_MP\_DR\_REDUCE\_C \\ + & BN\_MP\_DR\_SETUP\_C \\ +\hline Modular inverse odd moduli only & BN\_MP\_INVMOD\_SLOW\_C \\ +\hline Modular inverse (both, smaller/slower) & BN\_FAST\_MP\_INVMOD\_C \\ +\hline +\end{tabular} +\end{center} +\end{small} + +\subsubsection{Operand Size Related} +\begin{small} +\begin{center} +\begin{tabular}{|l|l|} +\hline \textbf{Restriction} & \textbf{Undefine} \\ +\hline Moduli $\le 2560$ bits & BN\_MP\_MONTGOMERY\_REDUCE\_C \\ + & BN\_S\_MP\_MUL\_DIGS\_C \\ + & BN\_S\_MP\_MUL\_HIGH\_DIGS\_C \\ + & BN\_S\_MP\_SQR\_C \\ +\hline Polynomial Schmolynomial & BN\_MP\_KARATSUBA\_MUL\_C \\ + & BN\_MP\_KARATSUBA\_SQR\_C \\ + & BN\_MP\_TOOM\_MUL\_C \\ + & BN\_MP\_TOOM\_SQR\_C \\ + +\hline +\end{tabular} +\end{center} +\end{small} + + +\section{Purpose of LibTomMath} +Unlike GNU MP (GMP) Library, LIP, OpenSSL or various other commercial kits (Miracl), LibTomMath was not written with +bleeding edge performance in mind. First and foremost LibTomMath was written to be entirely open. Not only is the +source code public domain (unlike various other GPL/etc licensed code), not only is the code freely downloadable but the +source code is also accessible for computer science students attempting to learn ``BigNum'' or multiple precision +arithmetic techniques. + +LibTomMath was written to be an instructive collection of source code. This is why there are many comments, only one +function per source file and often I use a ``middle-road'' approach where I don't cut corners for an extra 2\% speed +increase. + +Source code alone cannot really teach how the algorithms work which is why I also wrote a textbook that accompanies +the library (beat that!). + +So you may be thinking ``should I use LibTomMath?'' and the answer is a definite maybe. Let me tabulate what I think +are the pros and cons of LibTomMath by comparing it to the math routines from GnuPG\footnote{GnuPG v1.2.3 versus LibTomMath v0.28}. + +\newpage\begin{figure}[here] +\begin{small} +\begin{center} +\begin{tabular}{|l|c|c|l|} +\hline \textbf{Criteria} & \textbf{Pro} & \textbf{Con} & \textbf{Notes} \\ +\hline Few lines of code per file & X & & GnuPG $ = 300.9$, LibTomMath $ = 71.97$ \\ +\hline Commented function prototypes & X && GnuPG function names are cryptic. \\ +\hline Speed && X & LibTomMath is slower. \\ +\hline Totally free & X & & GPL has unfavourable restrictions.\\ +\hline Large function base & X & & GnuPG is barebones. \\ +\hline Five modular reduction algorithms & X & & Faster modular exponentiation for a variety of moduli. \\ +\hline Portable & X & & GnuPG requires configuration to build. \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{LibTomMath Valuation} +\end{figure} + +It may seem odd to compare LibTomMath to GnuPG since the math in GnuPG is only a small portion of the entire application. +However, LibTomMath was written with cryptography in mind. It provides essentially all of the functions a cryptosystem +would require when working with large integers. + +So it may feel tempting to just rip the math code out of GnuPG (or GnuMP where it was taken from originally) in your +own application but I think there are reasons not to. While LibTomMath is slower than libraries such as GnuMP it is +not normally significantly slower. On x86 machines the difference is normally a factor of two when performing modular +exponentiations. It depends largely on the processor, compiler and the moduli being used. + +Essentially the only time you wouldn't use LibTomMath is when blazing speed is the primary concern. However, +on the other side of the coin LibTomMath offers you a totally free (public domain) well structured math library +that is very flexible, complete and performs well in resource contrained environments. Fast RSA for example can +be performed with as little as 8KB of ram for data (again depending on build options). + +\chapter{Getting Started with LibTomMath} +\section{Building Programs} +In order to use LibTomMath you must include ``tommath.h'' and link against the appropriate library file (typically +libtommath.a). There is no library initialization required and the entire library is thread safe. + +\section{Return Codes} +There are three possible return codes a function may return. + +\index{MP\_OKAY}\index{MP\_YES}\index{MP\_NO}\index{MP\_VAL}\index{MP\_MEM} +\begin{figure}[here!] +\begin{center} +\begin{small} +\begin{tabular}{|l|l|} +\hline \textbf{Code} & \textbf{Meaning} \\ +\hline MP\_OKAY & The function succeeded. \\ +\hline MP\_VAL & The function input was invalid. \\ +\hline MP\_MEM & Heap memory exhausted. \\ +\hline &\\ +\hline MP\_YES & Response is yes. \\ +\hline MP\_NO & Response is no. \\ +\hline +\end{tabular} +\end{small} +\end{center} +\caption{Return Codes} +\end{figure} + +The last two codes listed are not actually ``return'ed'' by a function. They are placed in an integer (the caller must +provide the address of an integer it can store to) which the caller can access. To convert one of the three return codes +to a string use the following function. + +\index{mp\_error\_to\_string} +\begin{alltt} +char *mp_error_to_string(int code); +\end{alltt} + +This will return a pointer to a string which describes the given error code. It will not work for the return codes +MP\_YES and MP\_NO. + +\section{Data Types} +The basic ``multiple precision integer'' type is known as the ``mp\_int'' within LibTomMath. This data type is used to +organize all of the data required to manipulate the integer it represents. Within LibTomMath it has been prototyped +as the following. + +\index{mp\_int} +\begin{alltt} +typedef struct \{ + int used, alloc, sign; + mp_digit *dp; +\} mp_int; +\end{alltt} + +Where ``mp\_digit'' is a data type that represents individual digits of the integer. By default, an mp\_digit is the +ISO C ``unsigned long'' data type and each digit is $28-$bits long. The mp\_digit type can be configured to suit other +platforms by defining the appropriate macros. + +All LTM functions that use the mp\_int type will expect a pointer to mp\_int structure. You must allocate memory to +hold the structure itself by yourself (whether off stack or heap it doesn't matter). The very first thing that must be +done to use an mp\_int is that it must be initialized. + +\section{Function Organization} + +The arithmetic functions of the library are all organized to have the same style prototype. That is source operands +are passed on the left and the destination is on the right. For instance, + +\begin{alltt} +mp_add(&a, &b, &c); /* c = a + b */ +mp_mul(&a, &a, &c); /* c = a * a */ +mp_div(&a, &b, &c, &d); /* c = [a/b], d = a mod b */ +\end{alltt} + +Another feature of the way the functions have been implemented is that source operands can be destination operands as well. +For instance, + +\begin{alltt} +mp_add(&a, &b, &b); /* b = a + b */ +mp_div(&a, &b, &a, &c); /* a = [a/b], c = a mod b */ +\end{alltt} + +This allows operands to be re-used which can make programming simpler. + +\section{Initialization} +\subsection{Single Initialization} +A single mp\_int can be initialized with the ``mp\_init'' function. + +\index{mp\_init} +\begin{alltt} +int mp_init (mp_int * a); +\end{alltt} + +This function expects a pointer to an mp\_int structure and will initialize the members of the structure so the mp\_int +represents the default integer which is zero. If the functions returns MP\_OKAY then the mp\_int is ready to be used +by the other LibTomMath functions. + +\begin{small} \begin{alltt} +int main(void) +\{ + mp_int number; + int result; + + if ((result = mp_init(&number)) != MP_OKAY) \{ + printf("Error initializing the number. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* use the number */ + + return EXIT_SUCCESS; +\} +\end{alltt} \end{small} + +\subsection{Single Free} +When you are finished with an mp\_int it is ideal to return the heap it used back to the system. The following function +provides this functionality. + +\index{mp\_clear} +\begin{alltt} +void mp_clear (mp_int * a); +\end{alltt} + +The function expects a pointer to a previously initialized mp\_int structure and frees the heap it uses. It sets the +pointer\footnote{The ``dp'' member.} within the mp\_int to \textbf{NULL} which is used to prevent double free situations. +Is is legal to call mp\_clear() twice on the same mp\_int in a row. + +\begin{small} \begin{alltt} +int main(void) +\{ + mp_int number; + int result; + + if ((result = mp_init(&number)) != MP_OKAY) \{ + printf("Error initializing the number. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* use the number */ + + /* We're done with it. */ + mp_clear(&number); + + return EXIT_SUCCESS; +\} +\end{alltt} \end{small} + +\subsection{Multiple Initializations} +Certain algorithms require more than one large integer. In these instances it is ideal to initialize all of the mp\_int +variables in an ``all or nothing'' fashion. That is, they are either all initialized successfully or they are all +not initialized. + +The mp\_init\_multi() function provides this functionality. + +\index{mp\_init\_multi} \index{mp\_clear\_multi} +\begin{alltt} +int mp_init_multi(mp_int *mp, ...); +\end{alltt} + +It accepts a \textbf{NULL} terminated list of pointers to mp\_int structures. It will attempt to initialize them all +at once. If the function returns MP\_OKAY then all of the mp\_int variables are ready to use, otherwise none of them +are available for use. A complementary mp\_clear\_multi() function allows multiple mp\_int variables to be free'd +from the heap at the same time. + +\begin{small} \begin{alltt} +int main(void) +\{ + mp_int num1, num2, num3; + int result; + + if ((result = mp_init_multi(&num1, + &num2, + &num3, NULL)) != MP\_OKAY) \{ + printf("Error initializing the numbers. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* use the numbers */ + + /* We're done with them. */ + mp_clear_multi(&num1, &num2, &num3, NULL); + + return EXIT_SUCCESS; +\} +\end{alltt} \end{small} + +\subsection{Other Initializers} +To initialized and make a copy of an mp\_int the mp\_init\_copy() function has been provided. + +\index{mp\_init\_copy} +\begin{alltt} +int mp_init_copy (mp_int * a, mp_int * b); +\end{alltt} + +This function will initialize $a$ and make it a copy of $b$ if all goes well. + +\begin{small} \begin{alltt} +int main(void) +\{ + mp_int num1, num2; + int result; + + /* initialize and do work on num1 ... */ + + /* We want a copy of num1 in num2 now */ + if ((result = mp_init_copy(&num2, &num1)) != MP_OKAY) \{ + printf("Error initializing the copy. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* now num2 is ready and contains a copy of num1 */ + + /* We're done with them. */ + mp_clear_multi(&num1, &num2, NULL); + + return EXIT_SUCCESS; +\} +\end{alltt} \end{small} + +Another less common initializer is mp\_init\_size() which allows the user to initialize an mp\_int with a given +default number of digits. By default, all initializers allocate \textbf{MP\_PREC} digits. This function lets +you override this behaviour. + +\index{mp\_init\_size} +\begin{alltt} +int mp_init_size (mp_int * a, int size); +\end{alltt} + +The $size$ parameter must be greater than zero. If the function succeeds the mp\_int $a$ will be initialized +to have $size$ digits (which are all initially zero). + +\begin{small} \begin{alltt} +int main(void) +\{ + mp_int number; + int result; + + /* we need a 60-digit number */ + if ((result = mp_init_size(&number, 60)) != MP_OKAY) \{ + printf("Error initializing the number. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* use the number */ + + return EXIT_SUCCESS; +\} +\end{alltt} \end{small} + +\section{Maintenance Functions} + +\subsection{Reducing Memory Usage} +When an mp\_int is in a state where it won't be changed again\footnote{A Diffie-Hellman modulus for instance.} excess +digits can be removed to return memory to the heap with the mp\_shrink() function. + +\index{mp\_shrink} +\begin{alltt} +int mp_shrink (mp_int * a); +\end{alltt} + +This will remove excess digits of the mp\_int $a$. If the operation fails the mp\_int should be intact without the +excess digits being removed. Note that you can use a shrunk mp\_int in further computations, however, such operations +will require heap operations which can be slow. It is not ideal to shrink mp\_int variables that you will further +modify in the system (unless you are seriously low on memory). + +\begin{small} \begin{alltt} +int main(void) +\{ + mp_int number; + int result; + + if ((result = mp_init(&number)) != MP_OKAY) \{ + printf("Error initializing the number. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* use the number [e.g. pre-computation] */ + + /* We're done with it for now. */ + if ((result = mp_shrink(&number)) != MP_OKAY) \{ + printf("Error shrinking the number. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* use it .... */ + + + /* we're done with it. */ + mp_clear(&number); + + return EXIT_SUCCESS; +\} +\end{alltt} \end{small} + +\subsection{Adding additional digits} + +Within the mp\_int structure are two parameters which control the limitations of the array of digits that represent +the integer the mp\_int is meant to equal. The \textit{used} parameter dictates how many digits are significant, that is, +contribute to the value of the mp\_int. The \textit{alloc} parameter dictates how many digits are currently available in +the array. If you need to perform an operation that requires more digits you will have to mp\_grow() the mp\_int to +your desired size. + +\index{mp\_grow} +\begin{alltt} +int mp_grow (mp_int * a, int size); +\end{alltt} + +This will grow the array of digits of $a$ to $size$. If the \textit{alloc} parameter is already bigger than +$size$ the function will not do anything. + +\begin{small} \begin{alltt} +int main(void) +\{ + mp_int number; + int result; + + if ((result = mp_init(&number)) != MP_OKAY) \{ + printf("Error initializing the number. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* use the number */ + + /* We need to add 20 digits to the number */ + if ((result = mp_grow(&number, number.alloc + 20)) != MP_OKAY) \{ + printf("Error growing the number. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + + /* use the number */ + + /* we're done with it. */ + mp_clear(&number); + + return EXIT_SUCCESS; +\} +\end{alltt} \end{small} + +\chapter{Basic Operations} +\section{Small Constants} +Setting mp\_ints to small constants is a relatively common operation. To accomodate these instances there are two +small constant assignment functions. The first function is used to set a single digit constant while the second sets +an ISO C style ``unsigned long'' constant. The reason for both functions is efficiency. Setting a single digit is quick but the +domain of a digit can change (it's always at least $0 \ldots 127$). + +\subsection{Single Digit} + +Setting a single digit can be accomplished with the following function. + +\index{mp\_set} +\begin{alltt} +void mp_set (mp_int * a, mp_digit b); +\end{alltt} + +This will zero the contents of $a$ and make it represent an integer equal to the value of $b$. Note that this +function has a return type of \textbf{void}. It cannot cause an error so it is safe to assume the function +succeeded. + +\begin{small} \begin{alltt} +int main(void) +\{ + mp_int number; + int result; + + if ((result = mp_init(&number)) != MP_OKAY) \{ + printf("Error initializing the number. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* set the number to 5 */ + mp_set(&number, 5); + + /* we're done with it. */ + mp_clear(&number); + + return EXIT_SUCCESS; +\} +\end{alltt} \end{small} + +\subsection{Long Constants} + +To set a constant that is the size of an ISO C ``unsigned long'' and larger than a single digit the following function +can be used. + +\index{mp\_set\_int} +\begin{alltt} +int mp_set_int (mp_int * a, unsigned long b); +\end{alltt} + +This will assign the value of the 32-bit variable $b$ to the mp\_int $a$. Unlike mp\_set() this function will always +accept a 32-bit input regardless of the size of a single digit. However, since the value may span several digits +this function can fail if it runs out of heap memory. + +To get the ``unsigned long'' copy of an mp\_int the following function can be used. + +\index{mp\_get\_int} +\begin{alltt} +unsigned long mp_get_int (mp_int * a); +\end{alltt} + +This will return the 32 least significant bits of the mp\_int $a$. + +\begin{small} \begin{alltt} +int main(void) +\{ + mp_int number; + int result; + + if ((result = mp_init(&number)) != MP_OKAY) \{ + printf("Error initializing the number. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* set the number to 654321 (note this is bigger than 127) */ + if ((result = mp_set_int(&number, 654321)) != MP_OKAY) \{ + printf("Error setting the value of the number. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + printf("number == \%lu", mp_get_int(&number)); + + /* we're done with it. */ + mp_clear(&number); + + return EXIT_SUCCESS; +\} +\end{alltt} \end{small} + +This should output the following if the program succeeds. + +\begin{alltt} +number == 654321 +\end{alltt} + +\subsection{Initialize and Setting Constants} +To both initialize and set small constants the following two functions are available. +\index{mp\_init\_set} \index{mp\_init\_set\_int} +\begin{alltt} +int mp_init_set (mp_int * a, mp_digit b); +int mp_init_set_int (mp_int * a, unsigned long b); +\end{alltt} + +Both functions work like the previous counterparts except they first mp\_init $a$ before setting the values. + +\begin{alltt} +int main(void) +\{ + mp_int number1, number2; + int result; + + /* initialize and set a single digit */ + if ((result = mp_init_set(&number1, 100)) != MP_OKAY) \{ + printf("Error setting number1: \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* initialize and set a long */ + if ((result = mp_init_set_int(&number2, 1023)) != MP_OKAY) \{ + printf("Error setting number2: \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* display */ + printf("Number1, Number2 == \%lu, \%lu", + mp_get_int(&number1), mp_get_int(&number2)); + + /* clear */ + mp_clear_multi(&number1, &number2, NULL); + + return EXIT_SUCCESS; +\} +\end{alltt} + +If this program succeeds it shall output. +\begin{alltt} +Number1, Number2 == 100, 1023 +\end{alltt} + +\section{Comparisons} + +Comparisons in LibTomMath are always performed in a ``left to right'' fashion. There are three possible return codes +for any comparison. + +\index{MP\_GT} \index{MP\_EQ} \index{MP\_LT} +\begin{figure}[here] +\begin{center} +\begin{tabular}{|c|c|} +\hline \textbf{Result Code} & \textbf{Meaning} \\ +\hline MP\_GT & $a > b$ \\ +\hline MP\_EQ & $a = b$ \\ +\hline MP\_LT & $a < b$ \\ +\hline +\end{tabular} +\end{center} +\caption{Comparison Codes for $a, b$} +\label{fig:CMP} +\end{figure} + +In figure \ref{fig:CMP} two integers $a$ and $b$ are being compared. In this case $a$ is said to be ``to the left'' of +$b$. + +\subsection{Unsigned comparison} + +An unsigned comparison considers only the digits themselves and not the associated \textit{sign} flag of the +mp\_int structures. This is analogous to an absolute comparison. The function mp\_cmp\_mag() will compare two +mp\_int variables based on their digits only. + +\index{mp\_cmp\_mag} +\begin{alltt} +int mp_cmp_mag(mp_int * a, mp_int * b); +\end{alltt} +This will compare $a$ to $b$ placing $a$ to the left of $b$. This function cannot fail and will return one of the +three compare codes listed in figure \ref{fig:CMP}. + +\begin{small} \begin{alltt} +int main(void) +\{ + mp_int number1, number2; + int result; + + if ((result = mp_init_multi(&number1, &number2, NULL)) != MP_OKAY) \{ + printf("Error initializing the numbers. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* set the number1 to 5 */ + mp_set(&number1, 5); + + /* set the number2 to -6 */ + mp_set(&number2, 6); + if ((result = mp_neg(&number2, &number2)) != MP_OKAY) \{ + printf("Error negating number2. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + switch(mp_cmp_mag(&number1, &number2)) \{ + case MP_GT: printf("|number1| > |number2|"); break; + case MP_EQ: printf("|number1| = |number2|"); break; + case MP_LT: printf("|number1| < |number2|"); break; + \} + + /* we're done with it. */ + mp_clear_multi(&number1, &number2, NULL); + + return EXIT_SUCCESS; +\} +\end{alltt} \end{small} + +If this program\footnote{This function uses the mp\_neg() function which is discussed in section \ref{sec:NEG}.} completes +successfully it should print the following. + +\begin{alltt} +|number1| < |number2| +\end{alltt} + +This is because $\vert -6 \vert = 6$ and obviously $5 < 6$. + +\subsection{Signed comparison} + +To compare two mp\_int variables based on their signed value the mp\_cmp() function is provided. + +\index{mp\_cmp} +\begin{alltt} +int mp_cmp(mp_int * a, mp_int * b); +\end{alltt} + +This will compare $a$ to the left of $b$. It will first compare the signs of the two mp\_int variables. If they +differ it will return immediately based on their signs. If the signs are equal then it will compare the digits +individually. This function will return one of the compare conditions codes listed in figure \ref{fig:CMP}. + +\begin{small} \begin{alltt} +int main(void) +\{ + mp_int number1, number2; + int result; + + if ((result = mp_init_multi(&number1, &number2, NULL)) != MP_OKAY) \{ + printf("Error initializing the numbers. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* set the number1 to 5 */ + mp_set(&number1, 5); + + /* set the number2 to -6 */ + mp_set(&number2, 6); + if ((result = mp_neg(&number2, &number2)) != MP_OKAY) \{ + printf("Error negating number2. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + switch(mp_cmp(&number1, &number2)) \{ + case MP_GT: printf("number1 > number2"); break; + case MP_EQ: printf("number1 = number2"); break; + case MP_LT: printf("number1 < number2"); break; + \} + + /* we're done with it. */ + mp_clear_multi(&number1, &number2, NULL); + + return EXIT_SUCCESS; +\} +\end{alltt} \end{small} + +If this program\footnote{This function uses the mp\_neg() function which is discussed in section \ref{sec:NEG}.} completes +successfully it should print the following. + +\begin{alltt} +number1 > number2 +\end{alltt} + +\subsection{Single Digit} + +To compare a single digit against an mp\_int the following function has been provided. + +\index{mp\_cmp\_d} +\begin{alltt} +int mp_cmp_d(mp_int * a, mp_digit b); +\end{alltt} + +This will compare $a$ to the left of $b$ using a signed comparison. Note that it will always treat $b$ as +positive. This function is rather handy when you have to compare against small values such as $1$ (which often +comes up in cryptography). The function cannot fail and will return one of the tree compare condition codes +listed in figure \ref{fig:CMP}. + + +\begin{small} \begin{alltt} +int main(void) +\{ + mp_int number; + int result; + + if ((result = mp_init(&number)) != MP_OKAY) \{ + printf("Error initializing the number. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* set the number to 5 */ + mp_set(&number, 5); + + switch(mp_cmp_d(&number, 7)) \{ + case MP_GT: printf("number > 7"); break; + case MP_EQ: printf("number = 7"); break; + case MP_LT: printf("number < 7"); break; + \} + + /* we're done with it. */ + mp_clear(&number); + + return EXIT_SUCCESS; +\} +\end{alltt} \end{small} + +If this program functions properly it will print out the following. + +\begin{alltt} +number < 7 +\end{alltt} + +\section{Logical Operations} + +Logical operations are operations that can be performed either with simple shifts or boolean operators such as +AND, XOR and OR directly. These operations are very quick. + +\subsection{Multiplication by two} + +Multiplications and divisions by any power of two can be performed with quick logical shifts either left or +right depending on the operation. + +When multiplying or dividing by two a special case routine can be used which are as follows. +\index{mp\_mul\_2} \index{mp\_div\_2} +\begin{alltt} +int mp_mul_2(mp_int * a, mp_int * b); +int mp_div_2(mp_int * a, mp_int * b); +\end{alltt} + +The former will assign twice $a$ to $b$ while the latter will assign half $a$ to $b$. These functions are fast +since the shift counts and maskes are hardcoded into the routines. + +\begin{small} \begin{alltt} +int main(void) +\{ + mp_int number; + int result; + + if ((result = mp_init(&number)) != MP_OKAY) \{ + printf("Error initializing the number. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* set the number to 5 */ + mp_set(&number, 5); + + /* multiply by two */ + if ((result = mp\_mul\_2(&number, &number)) != MP_OKAY) \{ + printf("Error multiplying the number. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + switch(mp_cmp_d(&number, 7)) \{ + case MP_GT: printf("2*number > 7"); break; + case MP_EQ: printf("2*number = 7"); break; + case MP_LT: printf("2*number < 7"); break; + \} + + /* now divide by two */ + if ((result = mp\_div\_2(&number, &number)) != MP_OKAY) \{ + printf("Error dividing the number. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + switch(mp_cmp_d(&number, 7)) \{ + case MP_GT: printf("2*number/2 > 7"); break; + case MP_EQ: printf("2*number/2 = 7"); break; + case MP_LT: printf("2*number/2 < 7"); break; + \} + + /* we're done with it. */ + mp_clear(&number); + + return EXIT_SUCCESS; +\} +\end{alltt} \end{small} + +If this program is successful it will print out the following text. + +\begin{alltt} +2*number > 7 +2*number/2 < 7 +\end{alltt} + +Since $10 > 7$ and $5 < 7$. To multiply by a power of two the following function can be used. + +\index{mp\_mul\_2d} +\begin{alltt} +int mp_mul_2d(mp_int * a, int b, mp_int * c); +\end{alltt} + +This will multiply $a$ by $2^b$ and store the result in ``c''. If the value of $b$ is less than or equal to +zero the function will copy $a$ to ``c'' without performing any further actions. + +To divide by a power of two use the following. + +\index{mp\_div\_2d} +\begin{alltt} +int mp_div_2d (mp_int * a, int b, mp_int * c, mp_int * d); +\end{alltt} +Which will divide $a$ by $2^b$, store the quotient in ``c'' and the remainder in ``d'. If $b \le 0$ then the +function simply copies $a$ over to ``c'' and zeroes $d$. The variable $d$ may be passed as a \textbf{NULL} +value to signal that the remainder is not desired. + +\subsection{Polynomial Basis Operations} + +Strictly speaking the organization of the integers within the mp\_int structures is what is known as a +``polynomial basis''. This simply means a field element is stored by divisions of a radix. For example, if +$f(x) = \sum_{i=0}^{k} y_ix^k$ for any vector $\vec y$ then the array of digits in $\vec y$ are said to be +the polynomial basis representation of $z$ if $f(\beta) = z$ for a given radix $\beta$. + +To multiply by the polynomial $g(x) = x$ all you have todo is shift the digits of the basis left one place. The +following function provides this operation. + +\index{mp\_lshd} +\begin{alltt} +int mp_lshd (mp_int * a, int b); +\end{alltt} + +This will multiply $a$ in place by $x^b$ which is equivalent to shifting the digits left $b$ places and inserting zeroes +in the least significant digits. Similarly to divide by a power of $x$ the following function is provided. + +\index{mp\_rshd} +\begin{alltt} +void mp_rshd (mp_int * a, int b) +\end{alltt} +This will divide $a$ in place by $x^b$ and discard the remainder. This function cannot fail as it performs the operations +in place and no new digits are required to complete it. + +\subsection{AND, OR and XOR Operations} + +While AND, OR and XOR operations are not typical ``bignum functions'' they can be useful in several instances. The +three functions are prototyped as follows. + +\index{mp\_or} \index{mp\_and} \index{mp\_xor} +\begin{alltt} +int mp_or (mp_int * a, mp_int * b, mp_int * c); +int mp_and (mp_int * a, mp_int * b, mp_int * c); +int mp_xor (mp_int * a, mp_int * b, mp_int * c); +\end{alltt} + +Which compute $c = a \odot b$ where $\odot$ is one of OR, AND or XOR. + +\section{Addition and Subtraction} + +To compute an addition or subtraction the following two functions can be used. + +\index{mp\_add} \index{mp\_sub} +\begin{alltt} +int mp_add (mp_int * a, mp_int * b, mp_int * c); +int mp_sub (mp_int * a, mp_int * b, mp_int * c) +\end{alltt} + +Which perform $c = a \odot b$ where $\odot$ is one of signed addition or subtraction. The operations are fully sign +aware. + +\section{Sign Manipulation} +\subsection{Negation} +\label{sec:NEG} +Simple integer negation can be performed with the following. + +\index{mp\_neg} +\begin{alltt} +int mp_neg (mp_int * a, mp_int * b); +\end{alltt} + +Which assigns $-a$ to $b$. + +\subsection{Absolute} +Simple integer absolutes can be performed with the following. + +\index{mp\_neg} +\begin{alltt} +int mp_abs (mp_int * a, mp_int * b); +\end{alltt} + +Which assigns $\vert a \vert$ to $b$. + +\section{Integer Division and Remainder} +To perform a complete and general integer division with remainder use the following function. + +\index{mp\_div} +\begin{alltt} +int mp_div (mp_int * a, mp_int * b, mp_int * c, mp_int * d); +\end{alltt} + +This divides $a$ by $b$ and stores the quotient in $c$ and $d$. The signed quotient is computed such that +$bc + d = a$. Note that either of $c$ or $d$ can be set to \textbf{NULL} if their value is not required. If +$b$ is zero the function returns \textbf{MP\_VAL}. + + +\chapter{Multiplication and Squaring} +\section{Multiplication} +A full signed integer multiplication can be performed with the following. +\index{mp\_mul} +\begin{alltt} +int mp_mul (mp_int * a, mp_int * b, mp_int * c); +\end{alltt} +Which assigns the full signed product $ab$ to $c$. This function actually breaks into one of four cases which are +specific multiplication routines optimized for given parameters. First there are the Toom-Cook multiplications which +should only be used with very large inputs. This is followed by the Karatsuba multiplications which are for moderate +sized inputs. Then followed by the Comba and baseline multipliers. + +Fortunately for the developer you don't really need to know this unless you really want to fine tune the system. mp\_mul() +will determine on its own\footnote{Some tweaking may be required.} what routine to use automatically when it is called. + +\begin{alltt} +int main(void) +\{ + mp_int number1, number2; + int result; + + /* Initialize the numbers */ + if ((result = mp_init_multi(&number1, + &number2, NULL)) != MP_OKAY) \{ + printf("Error initializing the numbers. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* set the terms */ + if ((result = mp_set_int(&number, 257)) != MP_OKAY) \{ + printf("Error setting number1. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + if ((result = mp_set_int(&number2, 1023)) != MP_OKAY) \{ + printf("Error setting number2. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* multiply them */ + if ((result = mp_mul(&number1, &number2, + &number1)) != MP_OKAY) \{ + printf("Error multiplying terms. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* display */ + printf("number1 * number2 == \%lu", mp_get_int(&number1)); + + /* free terms and return */ + mp_clear_multi(&number1, &number2, NULL); + + return EXIT_SUCCESS; +\} +\end{alltt} + +If this program succeeds it shall output the following. + +\begin{alltt} +number1 * number2 == 262911 +\end{alltt} + +\section{Squaring} +Since squaring can be performed faster than multiplication it is performed it's own function instead of just using +mp\_mul(). + +\index{mp\_sqr} +\begin{alltt} +int mp_sqr (mp_int * a, mp_int * b); +\end{alltt} + +Will square $a$ and store it in $b$. Like the case of multiplication there are four different squaring +algorithms all which can be called from mp\_sqr(). It is ideal to use mp\_sqr over mp\_mul when squaring terms because +of the speed difference. + +\section{Tuning Polynomial Basis Routines} + +Both of the Toom-Cook and Karatsuba multiplication algorithms are faster than the traditional $O(n^2)$ approach that +the Comba and baseline algorithms use. At $O(n^{1.464973})$ and $O(n^{1.584962})$ running times respectively they require +considerably less work. For example, a 10000-digit multiplication would take roughly 724,000 single precision +multiplications with Toom-Cook or 100,000,000 single precision multiplications with the standard Comba (a factor +of 138). + +So why not always use Karatsuba or Toom-Cook? The simple answer is that they have so much overhead that they're not +actually faster than Comba until you hit distinct ``cutoff'' points. For Karatsuba with the default configuration, +GCC 3.3.1 and an Athlon XP processor the cutoff point is roughly 110 digits (about 70 for the Intel P4). That is, at +110 digits Karatsuba and Comba multiplications just about break even and for 110+ digits Karatsuba is faster. + +Toom-Cook has incredible overhead and is probably only useful for very large inputs. So far no known cutoff points +exist and for the most part I just set the cutoff points very high to make sure they're not called. + +A demo program in the ``etc/'' directory of the project called ``tune.c'' can be used to find the cutoff points. This +can be built with GCC as follows + +\begin{alltt} +make XXX +\end{alltt} +Where ``XXX'' is one of the following entries from the table \ref{fig:tuning}. + +\begin{figure}[here] +\begin{center} +\begin{small} +\begin{tabular}{|l|l|} +\hline \textbf{Value of XXX} & \textbf{Meaning} \\ +\hline tune & Builds portable tuning application \\ +\hline tune86 & Builds x86 (pentium and up) program for COFF \\ +\hline tune86c & Builds x86 program for Cygwin \\ +\hline tune86l & Builds x86 program for Linux (ELF format) \\ +\hline +\end{tabular} +\end{small} +\end{center} +\caption{Build Names for Tuning Programs} +\label{fig:tuning} +\end{figure} + +When the program is running it will output a series of measurements for different cutoff points. It will first find +good Karatsuba squaring and multiplication points. Then it proceeds to find Toom-Cook points. Note that the Toom-Cook +tuning takes a very long time as the cutoff points are likely to be very high. + +\chapter{Modular Reduction} + +Modular reduction is process of taking the remainder of one quantity divided by another. Expressed +as (\ref{eqn:mod}) the modular reduction is equivalent to the remainder of $b$ divided by $c$. + +\begin{equation} +a \equiv b \mbox{ (mod }c\mbox{)} +\label{eqn:mod} +\end{equation} + +Of particular interest to cryptography are reductions where $b$ is limited to the range $0 \le b < c^2$ since particularly +fast reduction algorithms can be written for the limited range. + +Note that one of the four optimized reduction algorithms are automatically chosen in the modular exponentiation +algorithm mp\_exptmod when an appropriate modulus is detected. + +\section{Straight Division} +In order to effect an arbitrary modular reduction the following algorithm is provided. + +\index{mp\_mod} +\begin{alltt} +int mp_mod(mp_int *a, mp_int *b, mp_int *c); +\end{alltt} + +This reduces $a$ modulo $b$ and stores the result in $c$. The sign of $c$ shall agree with the sign +of $b$. This algorithm accepts an input $a$ of any range and is not limited by $0 \le a < b^2$. + +\section{Barrett Reduction} + +Barrett reduction is a generic optimized reduction algorithm that requires pre--computation to achieve +a decent speedup over straight division. First a $\mu$ value must be precomputed with the following function. + +\index{mp\_reduce\_setup} +\begin{alltt} +int mp_reduce_setup(mp_int *a, mp_int *b); +\end{alltt} + +Given a modulus in $b$ this produces the required $\mu$ value in $a$. For any given modulus this only has to +be computed once. Modular reduction can now be performed with the following. + +\index{mp\_reduce} +\begin{alltt} +int mp_reduce(mp_int *a, mp_int *b, mp_int *c); +\end{alltt} + +This will reduce $a$ in place modulo $b$ with the precomputed $\mu$ value in $c$. $a$ must be in the range +$0 \le a < b^2$. + +\begin{alltt} +int main(void) +\{ + mp_int a, b, c, mu; + int result; + + /* initialize a,b to desired values, mp_init mu, + * c and set c to 1...we want to compute a^3 mod b + */ + + /* get mu value */ + if ((result = mp_reduce_setup(&mu, b)) != MP_OKAY) \{ + printf("Error getting mu. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* square a to get c = a^2 */ + if ((result = mp_sqr(&a, &c)) != MP_OKAY) \{ + printf("Error squaring. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* now reduce `c' modulo b */ + if ((result = mp_reduce(&c, &b, &mu)) != MP_OKAY) \{ + printf("Error reducing. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* multiply a to get c = a^3 */ + if ((result = mp_mul(&a, &c, &c)) != MP_OKAY) \{ + printf("Error reducing. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* now reduce `c' modulo b */ + if ((result = mp_reduce(&c, &b, &mu)) != MP_OKAY) \{ + printf("Error reducing. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* c now equals a^3 mod b */ + + return EXIT_SUCCESS; +\} +\end{alltt} + +This program will calculate $a^3 \mbox{ mod }b$ if all the functions succeed. + +\section{Montgomery Reduction} + +Montgomery is a specialized reduction algorithm for any odd moduli. Like Barrett reduction a pre--computation +step is required. This is accomplished with the following. + +\index{mp\_montgomery\_setup} +\begin{alltt} +int mp_montgomery_setup(mp_int *a, mp_digit *mp); +\end{alltt} + +For the given odd moduli $a$ the precomputation value is placed in $mp$. The reduction is computed with the +following. + +\index{mp\_montgomery\_reduce} +\begin{alltt} +int mp_montgomery_reduce(mp_int *a, mp_int *m, mp_digit mp); +\end{alltt} +This reduces $a$ in place modulo $m$ with the pre--computed value $mp$. $a$ must be in the range +$0 \le a < b^2$. + +Montgomery reduction is faster than Barrett reduction for moduli smaller than the ``comba'' limit. With the default +setup for instance, the limit is $127$ digits ($3556$--bits). Note that this function is not limited to +$127$ digits just that it falls back to a baseline algorithm after that point. + +An important observation is that this reduction does not return $a \mbox{ mod }m$ but $aR^{-1} \mbox{ mod }m$ +where $R = \beta^n$, $n$ is the n number of digits in $m$ and $\beta$ is radix used (default is $2^{28}$). + +To quickly calculate $R$ the following function was provided. + +\index{mp\_montgomery\_calc\_normalization} +\begin{alltt} +int mp_montgomery_calc_normalization(mp_int *a, mp_int *b); +\end{alltt} +Which calculates $a = R$ for the odd moduli $b$ without using multiplication or division. + +The normal modus operandi for Montgomery reductions is to normalize the integers before entering the system. For +example, to calculate $a^3 \mbox { mod }b$ using Montgomery reduction the value of $a$ can be normalized by +multiplying it by $R$. Consider the following code snippet. + +\begin{alltt} +int main(void) +\{ + mp_int a, b, c, R; + mp_digit mp; + int result; + + /* initialize a,b to desired values, + * mp_init R, c and set c to 1.... + */ + + /* get normalization */ + if ((result = mp_montgomery_calc_normalization(&R, b)) != MP_OKAY) \{ + printf("Error getting norm. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* get mp value */ + if ((result = mp_montgomery_setup(&c, &mp)) != MP_OKAY) \{ + printf("Error setting up montgomery. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* normalize `a' so now a is equal to aR */ + if ((result = mp_mulmod(&a, &R, &b, &a)) != MP_OKAY) \{ + printf("Error computing aR. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* square a to get c = a^2R^2 */ + if ((result = mp_sqr(&a, &c)) != MP_OKAY) \{ + printf("Error squaring. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* now reduce `c' back down to c = a^2R^2 * R^-1 == a^2R */ + if ((result = mp_montgomery_reduce(&c, &b, mp)) != MP_OKAY) \{ + printf("Error reducing. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* multiply a to get c = a^3R^2 */ + if ((result = mp_mul(&a, &c, &c)) != MP_OKAY) \{ + printf("Error reducing. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* now reduce `c' back down to c = a^3R^2 * R^-1 == a^3R */ + if ((result = mp_montgomery_reduce(&c, &b, mp)) != MP_OKAY) \{ + printf("Error reducing. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* now reduce (again) `c' back down to c = a^3R * R^-1 == a^3 */ + if ((result = mp_montgomery_reduce(&c, &b, mp)) != MP_OKAY) \{ + printf("Error reducing. \%s", + mp_error_to_string(result)); + return EXIT_FAILURE; + \} + + /* c now equals a^3 mod b */ + + return EXIT_SUCCESS; +\} +\end{alltt} + +This particular example does not look too efficient but it demonstrates the point of the algorithm. By +normalizing the inputs the reduced results are always of the form $aR$ for some variable $a$. This allows +a single final reduction to correct for the normalization and the fast reduction used within the algorithm. + +For more details consider examining the file \textit{bn\_mp\_exptmod\_fast.c}. + +\section{Restricted Dimminished Radix} + +``Dimminished Radix'' reduction refers to reduction with respect to moduli that are ameniable to simple +digit shifting and small multiplications. In this case the ``restricted'' variant refers to moduli of the +form $\beta^k - p$ for some $k \ge 0$ and $0 < p < \beta$ where $\beta$ is the radix (default to $2^{28}$). + +As in the case of Montgomery reduction there is a pre--computation phase required for a given modulus. + +\index{mp\_dr\_setup} +\begin{alltt} +void mp_dr_setup(mp_int *a, mp_digit *d); +\end{alltt} + +This computes the value required for the modulus $a$ and stores it in $d$. This function cannot fail +and does not return any error codes. After the pre--computation a reduction can be performed with the +following. + +\index{mp\_dr\_reduce} +\begin{alltt} +int mp_dr_reduce(mp_int *a, mp_int *b, mp_digit mp); +\end{alltt} + +This reduces $a$ in place modulo $b$ with the pre--computed value $mp$. $b$ must be of a restricted +dimminished radix form and $a$ must be in the range $0 \le a < b^2$. Dimminished radix reductions are +much faster than both Barrett and Montgomery reductions as they have a much lower asymtotic running time. + +Since the moduli are restricted this algorithm is not particularly useful for something like Rabin, RSA or +BBS cryptographic purposes. This reduction algorithm is useful for Diffie-Hellman and ECC where fixed +primes are acceptable. + +Note that unlike Montgomery reduction there is no normalization process. The result of this function is +equal to the correct residue. + +\section{Unrestricted Dimminshed Radix} + +Unrestricted reductions work much like the restricted counterparts except in this case the moduli is of the +form $2^k - p$ for $0 < p < \beta$. In this sense the unrestricted reductions are more flexible as they +can be applied to a wider range of numbers. + +\index{mp\_reduce\_2k\_setup} +\begin{alltt} +int mp_reduce_2k_setup(mp_int *a, mp_digit *d); +\end{alltt} + +This will compute the required $d$ value for the given moduli $a$. + +\index{mp\_reduce\_2k} +\begin{alltt} +int mp_reduce_2k(mp_int *a, mp_int *n, mp_digit d); +\end{alltt} + +This will reduce $a$ in place modulo $n$ with the pre--computed value $d$. From my experience this routine is +slower than mp\_dr\_reduce but faster for most moduli sizes than the Montgomery reduction. + +\chapter{Exponentiation} +\section{Single Digit Exponentiation} +\index{mp\_expt\_d} +\begin{alltt} +int mp_expt_d (mp_int * a, mp_digit b, mp_int * c) +\end{alltt} +This computes $c = a^b$ using a simple binary left-to-right algorithm. It is faster than repeated multiplications by +$a$ for all values of $b$ greater than three. + +\section{Modular Exponentiation} +\index{mp\_exptmod} +\begin{alltt} +int mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y) +\end{alltt} +This computes $Y \equiv G^X \mbox{ (mod }P\mbox{)}$ using a variable width sliding window algorithm. This function +will automatically detect the fastest modular reduction technique to use during the operation. For negative values of +$X$ the operation is performed as $Y \equiv (G^{-1} \mbox{ mod }P)^{\vert X \vert} \mbox{ (mod }P\mbox{)}$ provided that +$gcd(G, P) = 1$. + +This function is actually a shell around the two internal exponentiation functions. This routine will automatically +detect when Barrett, Montgomery, Restricted and Unrestricted Dimminished Radix based exponentiation can be used. Generally +moduli of the a ``restricted dimminished radix'' form lead to the fastest modular exponentiations. Followed by Montgomery +and the other two algorithms. + +\section{Root Finding} +\index{mp\_n\_root} +\begin{alltt} +int mp_n_root (mp_int * a, mp_digit b, mp_int * c) +\end{alltt} +This computes $c = a^{1/b}$ such that $c^b \le a$ and $(c+1)^b > a$. The implementation of this function is not +ideal for values of $b$ greater than three. It will work but become very slow. So unless you are working with very small +numbers (less than 1000 bits) I'd avoid $b > 3$ situations. Will return a positive root only for even roots and return +a root with the sign of the input for odd roots. For example, performing $4^{1/2}$ will return $2$ whereas $(-8)^{1/3}$ +will return $-2$. + +This algorithm uses the ``Newton Approximation'' method and will converge on the correct root fairly quickly. Since +the algorithm requires raising $a$ to the power of $b$ it is not ideal to attempt to find roots for large +values of $b$. If particularly large roots are required then a factor method could be used instead. For example, +$a^{1/16}$ is equivalent to $\left (a^{1/4} \right)^{1/4}$ or simply +$\left ( \left ( \left ( a^{1/2} \right )^{1/2} \right )^{1/2} \right )^{1/2}$ + +\chapter{Prime Numbers} +\section{Trial Division} +\index{mp\_prime\_is\_divisible} +\begin{alltt} +int mp_prime_is_divisible (mp_int * a, int *result) +\end{alltt} +This will attempt to evenly divide $a$ by a list of primes\footnote{Default is the first 256 primes.} and store the +outcome in ``result''. That is if $result = 0$ then $a$ is not divisible by the primes, otherwise it is. Note that +if the function does not return \textbf{MP\_OKAY} the value in ``result'' should be considered undefined\footnote{Currently +the default is to set it to zero first.}. + +\section{Fermat Test} +\index{mp\_prime\_fermat} +\begin{alltt} +int mp_prime_fermat (mp_int * a, mp_int * b, int *result) +\end{alltt} +Performs a Fermat primality test to the base $b$. That is it computes $b^a \mbox{ mod }a$ and tests whether the value is +equal to $b$ or not. If the values are equal then $a$ is probably prime and $result$ is set to one. Otherwise $result$ +is set to zero. + +\section{Miller-Rabin Test} +\index{mp\_prime\_miller\_rabin} +\begin{alltt} +int mp_prime_miller_rabin (mp_int * a, mp_int * b, int *result) +\end{alltt} +Performs a Miller-Rabin test to the base $b$ of $a$. This test is much stronger than the Fermat test and is very hard to +fool (besides with Carmichael numbers). If $a$ passes the test (therefore is probably prime) $result$ is set to one. +Otherwise $result$ is set to zero. + +Note that is suggested that you use the Miller-Rabin test instead of the Fermat test since all of the failures of +Miller-Rabin are a subset of the failures of the Fermat test. + +\subsection{Required Number of Tests} +Generally to ensure a number is very likely to be prime you have to perform the Miller-Rabin with at least a half-dozen +or so unique bases. However, it has been proven that the probability of failure goes down as the size of the input goes up. +This is why a simple function has been provided to help out. + +\index{mp\_prime\_rabin\_miller\_trials} +\begin{alltt} +int mp_prime_rabin_miller_trials(int size) +\end{alltt} +This returns the number of trials required for a $2^{-96}$ (or lower) probability of failure for a given ``size'' expressed +in bits. This comes in handy specially since larger numbers are slower to test. For example, a 512-bit number would +require ten tests whereas a 1024-bit number would only require four tests. + +You should always still perform a trial division before a Miller-Rabin test though. + +\section{Primality Testing} +\index{mp\_prime\_is\_prime} +\begin{alltt} +int mp_prime_is_prime (mp_int * a, int t, int *result) +\end{alltt} +This will perform a trial division followed by $t$ rounds of Miller-Rabin tests on $a$ and store the result in $result$. +If $a$ passes all of the tests $result$ is set to one, otherwise it is set to zero. Note that $t$ is bounded by +$1 \le t < PRIME\_SIZE$ where $PRIME\_SIZE$ is the number of primes in the prime number table (by default this is $256$). + +\section{Next Prime} +\index{mp\_prime\_next\_prime} +\begin{alltt} +int mp_prime_next_prime(mp_int *a, int t, int bbs_style) +\end{alltt} +This finds the next prime after $a$ that passes mp\_prime\_is\_prime() with $t$ tests. Set $bbs\_style$ to one if you +want only the next prime congruent to $3 \mbox{ mod } 4$, otherwise set it to zero to find any next prime. + +\section{Random Primes} +\index{mp\_prime\_random} +\begin{alltt} +int mp_prime_random(mp_int *a, int t, int size, int bbs, + ltm_prime_callback cb, void *dat) +\end{alltt} +This will find a prime greater than $256^{size}$ which can be ``bbs\_style'' or not depending on $bbs$ and must pass +$t$ rounds of tests. The ``ltm\_prime\_callback'' is a typedef for + +\begin{alltt} +typedef int ltm_prime_callback(unsigned char *dst, int len, void *dat); +\end{alltt} + +Which is a function that must read $len$ bytes (and return the amount stored) into $dst$. The $dat$ variable is simply +copied from the original input. It can be used to pass RNG context data to the callback. The function +mp\_prime\_random() is more suitable for generating primes which must be secret (as in the case of RSA) since there +is no skew on the least significant bits. + +\textit{Note:} As of v0.30 of the LibTomMath library this function has been deprecated. It is still available +but users are encouraged to use the new mp\_prime\_random\_ex() function instead. + +\subsection{Extended Generation} +\index{mp\_prime\_random\_ex} +\begin{alltt} +int mp_prime_random_ex(mp_int *a, int t, + int size, int flags, + ltm_prime_callback cb, void *dat); +\end{alltt} +This will generate a prime in $a$ using $t$ tests of the primality testing algorithms. The variable $size$ +specifies the bit length of the prime desired. The variable $flags$ specifies one of several options available +(see fig. \ref{fig:primeopts}) which can be OR'ed together. The callback parameters are used as in +mp\_prime\_random(). + +\begin{figure}[here] +\begin{center} +\begin{small} +\begin{tabular}{|r|l|} +\hline \textbf{Flag} & \textbf{Meaning} \\ +\hline LTM\_PRIME\_BBS & Make the prime congruent to $3$ modulo $4$ \\ +\hline LTM\_PRIME\_SAFE & Make a prime $p$ such that $(p - 1)/2$ is also prime. \\ + & This option implies LTM\_PRIME\_BBS as well. \\ +\hline LTM\_PRIME\_2MSB\_OFF & Makes sure that the bit adjacent to the most significant bit \\ + & Is forced to zero. \\ +\hline LTM\_PRIME\_2MSB\_ON & Makes sure that the bit adjacent to the most significant bit \\ + & Is forced to one. \\ +\hline +\end{tabular} +\end{small} +\end{center} +\caption{Primality Generation Options} +\label{fig:primeopts} +\end{figure} + +\chapter{Input and Output} +\section{ASCII Conversions} +\subsection{To ASCII} +\index{mp\_toradix} +\begin{alltt} +int mp_toradix (mp_int * a, char *str, int radix); +\end{alltt} +This still store $a$ in ``str'' as a base-``radix'' string of ASCII chars. This function appends a NUL character +to terminate the string. Valid values of ``radix'' line in the range $[2, 64]$. To determine the size (exact) required +by the conversion before storing any data use the following function. + +\index{mp\_radix\_size} +\begin{alltt} +int mp_radix_size (mp_int * a, int radix, int *size) +\end{alltt} +This stores in ``size'' the number of characters (including space for the NUL terminator) required. Upon error this +function returns an error code and ``size'' will be zero. + +\subsection{From ASCII} +\index{mp\_read\_radix} +\begin{alltt} +int mp_read_radix (mp_int * a, char *str, int radix); +\end{alltt} +This will read the base-``radix'' NUL terminated string from ``str'' into $a$. It will stop reading when it reads a +character it does not recognize (which happens to include th NUL char... imagine that...). A single leading $-$ sign +can be used to denote a negative number. + +\section{Binary Conversions} + +Converting an mp\_int to and from binary is another keen idea. + +\index{mp\_unsigned\_bin\_size} +\begin{alltt} +int mp_unsigned_bin_size(mp_int *a); +\end{alltt} + +This will return the number of bytes (octets) required to store the unsigned copy of the integer $a$. + +\index{mp\_to\_unsigned\_bin} +\begin{alltt} +int mp_to_unsigned_bin(mp_int *a, unsigned char *b); +\end{alltt} +This will store $a$ into the buffer $b$ in big--endian format. Fortunately this is exactly what DER (or is it ASN?) +requires. It does not store the sign of the integer. + +\index{mp\_read\_unsigned\_bin} +\begin{alltt} +int mp_read_unsigned_bin(mp_int *a, unsigned char *b, int c); +\end{alltt} +This will read in an unsigned big--endian array of bytes (octets) from $b$ of length $c$ into $a$. The resulting +integer $a$ will always be positive. + +For those who acknowledge the existence of negative numbers (heretic!) there are ``signed'' versions of the +previous functions. + +\begin{alltt} +int mp_signed_bin_size(mp_int *a); +int mp_read_signed_bin(mp_int *a, unsigned char *b, int c); +int mp_to_signed_bin(mp_int *a, unsigned char *b); +\end{alltt} +They operate essentially the same as the unsigned copies except they prefix the data with zero or non--zero +byte depending on the sign. If the sign is zpos (e.g. not negative) the prefix is zero, otherwise the prefix +is non--zero. + +\chapter{Algebraic Functions} +\section{Extended Euclidean Algorithm} +\index{mp\_exteuclid} +\begin{alltt} +int mp_exteuclid(mp_int *a, mp_int *b, + mp_int *U1, mp_int *U2, mp_int *U3); +\end{alltt} + +This finds the triple U1/U2/U3 using the Extended Euclidean algorithm such that the following equation holds. + +\begin{equation} +a \cdot U1 + b \cdot U2 = U3 +\end{equation} + +Any of the U1/U2/U3 paramters can be set to \textbf{NULL} if they are not desired. + +\section{Greatest Common Divisor} +\index{mp\_gcd} +\begin{alltt} +int mp_gcd (mp_int * a, mp_int * b, mp_int * c) +\end{alltt} +This will compute the greatest common divisor of $a$ and $b$ and store it in $c$. + +\section{Least Common Multiple} +\index{mp\_lcm} +\begin{alltt} +int mp_lcm (mp_int * a, mp_int * b, mp_int * c) +\end{alltt} +This will compute the least common multiple of $a$ and $b$ and store it in $c$. + +\section{Jacobi Symbol} +\index{mp\_jacobi} +\begin{alltt} +int mp_jacobi (mp_int * a, mp_int * p, int *c) +\end{alltt} +This will compute the Jacobi symbol for $a$ with respect to $p$. If $p$ is prime this essentially computes the Legendre +symbol. The result is stored in $c$ and can take on one of three values $\lbrace -1, 0, 1 \rbrace$. If $p$ is prime +then the result will be $-1$ when $a$ is not a quadratic residue modulo $p$. The result will be $0$ if $a$ divides $p$ +and the result will be $1$ if $a$ is a quadratic residue modulo $p$. + +\section{Modular Inverse} +\index{mp\_invmod} +\begin{alltt} +int mp_invmod (mp_int * a, mp_int * b, mp_int * c) +\end{alltt} +Computes the multiplicative inverse of $a$ modulo $b$ and stores the result in $c$ such that $ac \equiv 1 \mbox{ (mod }b\mbox{)}$. + +\section{Single Digit Functions} + +For those using small numbers (\textit{snicker snicker}) there are several ``helper'' functions + +\index{mp\_add\_d} \index{mp\_sub\_d} \index{mp\_mul\_d} \index{mp\_div\_d} \index{mp\_mod\_d} +\begin{alltt} +int mp_add_d(mp_int *a, mp_digit b, mp_int *c); +int mp_sub_d(mp_int *a, mp_digit b, mp_int *c); +int mp_mul_d(mp_int *a, mp_digit b, mp_int *c); +int mp_div_d(mp_int *a, mp_digit b, mp_int *c, mp_digit *d); +int mp_mod_d(mp_int *a, mp_digit b, mp_digit *c); +\end{alltt} + +These work like the full mp\_int capable variants except the second parameter $b$ is a mp\_digit. These +functions fairly handy if you have to work with relatively small numbers since you will not have to allocate +an entire mp\_int to store a number like $1$ or $2$. + +\input{bn.ind} + +\end{document} ADDED libtommath/bn_error.c Index: libtommath/bn_error.c ================================================================== --- /dev/null +++ libtommath/bn_error.c @@ -0,0 +1,47 @@ +#include +#ifdef BN_ERROR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +static const struct { + int code; + char *msg; +} msgs[] = { + { MP_OKAY, "Successful" }, + { MP_MEM, "Out of heap" }, + { MP_VAL, "Value out of range" } +}; + +/* return a char * string for a given code */ +char *mp_error_to_string(int code) +{ + int x; + + /* scan the lookup table for the given message */ + for (x = 0; x < (int)(sizeof(msgs) / sizeof(msgs[0])); x++) { + if (msgs[x].code == code) { + return msgs[x].msg; + } + } + + /* generic reply for invalid code */ + return "Invalid error code"; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_error.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_fast_mp_invmod.c Index: libtommath/bn_fast_mp_invmod.c ================================================================== --- /dev/null +++ libtommath/bn_fast_mp_invmod.c @@ -0,0 +1,148 @@ +#include +#ifdef BN_FAST_MP_INVMOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* computes the modular inverse via binary extended euclidean algorithm, + * that is c = 1/a mod b + * + * Based on slow invmod except this is optimized for the case where b is + * odd as per HAC Note 14.64 on pp. 610 + */ +int fast_mp_invmod (mp_int * a, mp_int * b, mp_int * c) +{ + mp_int x, y, u, v, B, D; + int res, neg; + + /* 2. [modified] b must be odd */ + if (mp_iseven (b) == 1) { + return MP_VAL; + } + + /* init all our temps */ + if ((res = mp_init_multi(&x, &y, &u, &v, &B, &D, NULL)) != MP_OKAY) { + return res; + } + + /* x == modulus, y == value to invert */ + if ((res = mp_copy (b, &x)) != MP_OKAY) { + goto LBL_ERR; + } + + /* we need y = |a| */ + if ((res = mp_mod (a, b, &y)) != MP_OKAY) { + goto LBL_ERR; + } + + /* 3. u=x, v=y, A=1, B=0, C=0,D=1 */ + if ((res = mp_copy (&x, &u)) != MP_OKAY) { + goto LBL_ERR; + } + if ((res = mp_copy (&y, &v)) != MP_OKAY) { + goto LBL_ERR; + } + mp_set (&D, 1); + +top: + /* 4. while u is even do */ + while (mp_iseven (&u) == 1) { + /* 4.1 u = u/2 */ + if ((res = mp_div_2 (&u, &u)) != MP_OKAY) { + goto LBL_ERR; + } + /* 4.2 if B is odd then */ + if (mp_isodd (&B) == 1) { + if ((res = mp_sub (&B, &x, &B)) != MP_OKAY) { + goto LBL_ERR; + } + } + /* B = B/2 */ + if ((res = mp_div_2 (&B, &B)) != MP_OKAY) { + goto LBL_ERR; + } + } + + /* 5. while v is even do */ + while (mp_iseven (&v) == 1) { + /* 5.1 v = v/2 */ + if ((res = mp_div_2 (&v, &v)) != MP_OKAY) { + goto LBL_ERR; + } + /* 5.2 if D is odd then */ + if (mp_isodd (&D) == 1) { + /* D = (D-x)/2 */ + if ((res = mp_sub (&D, &x, &D)) != MP_OKAY) { + goto LBL_ERR; + } + } + /* D = D/2 */ + if ((res = mp_div_2 (&D, &D)) != MP_OKAY) { + goto LBL_ERR; + } + } + + /* 6. if u >= v then */ + if (mp_cmp (&u, &v) != MP_LT) { + /* u = u - v, B = B - D */ + if ((res = mp_sub (&u, &v, &u)) != MP_OKAY) { + goto LBL_ERR; + } + + if ((res = mp_sub (&B, &D, &B)) != MP_OKAY) { + goto LBL_ERR; + } + } else { + /* v - v - u, D = D - B */ + if ((res = mp_sub (&v, &u, &v)) != MP_OKAY) { + goto LBL_ERR; + } + + if ((res = mp_sub (&D, &B, &D)) != MP_OKAY) { + goto LBL_ERR; + } + } + + /* if not zero goto step 4 */ + if (mp_iszero (&u) == 0) { + goto top; + } + + /* now a = C, b = D, gcd == g*v */ + + /* if v != 1 then there is no inverse */ + if (mp_cmp_d (&v, 1) != MP_EQ) { + res = MP_VAL; + goto LBL_ERR; + } + + /* b is now the inverse */ + neg = a->sign; + while (D.sign == MP_NEG) { + if ((res = mp_add (&D, b, &D)) != MP_OKAY) { + goto LBL_ERR; + } + } + mp_exch (&D, c); + c->sign = neg; + res = MP_OKAY; + +LBL_ERR:mp_clear_multi (&x, &y, &u, &v, &B, &D, NULL); + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_fast_mp_invmod.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_fast_mp_montgomery_reduce.c Index: libtommath/bn_fast_mp_montgomery_reduce.c ================================================================== --- /dev/null +++ libtommath/bn_fast_mp_montgomery_reduce.c @@ -0,0 +1,172 @@ +#include +#ifdef BN_FAST_MP_MONTGOMERY_REDUCE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* computes xR**-1 == x (mod N) via Montgomery Reduction + * + * This is an optimized implementation of montgomery_reduce + * which uses the comba method to quickly calculate the columns of the + * reduction. + * + * Based on Algorithm 14.32 on pp.601 of HAC. +*/ +int fast_mp_montgomery_reduce (mp_int * x, mp_int * n, mp_digit rho) +{ + int ix, res, olduse; + mp_word W[MP_WARRAY]; + + /* get old used count */ + olduse = x->used; + + /* grow a as required */ + if (x->alloc < n->used + 1) { + if ((res = mp_grow (x, n->used + 1)) != MP_OKAY) { + return res; + } + } + + /* first we have to get the digits of the input into + * an array of double precision words W[...] + */ + { + register mp_word *_W; + register mp_digit *tmpx; + + /* alias for the W[] array */ + _W = W; + + /* alias for the digits of x*/ + tmpx = x->dp; + + /* copy the digits of a into W[0..a->used-1] */ + for (ix = 0; ix < x->used; ix++) { + *_W++ = *tmpx++; + } + + /* zero the high words of W[a->used..m->used*2] */ + for (; ix < n->used * 2 + 1; ix++) { + *_W++ = 0; + } + } + + /* now we proceed to zero successive digits + * from the least significant upwards + */ + for (ix = 0; ix < n->used; ix++) { + /* mu = ai * m' mod b + * + * We avoid a double precision multiplication (which isn't required) + * by casting the value down to a mp_digit. Note this requires + * that W[ix-1] have the carry cleared (see after the inner loop) + */ + register mp_digit mu; + mu = (mp_digit) (((W[ix] & MP_MASK) * rho) & MP_MASK); + + /* a = a + mu * m * b**i + * + * This is computed in place and on the fly. The multiplication + * by b**i is handled by offseting which columns the results + * are added to. + * + * Note the comba method normally doesn't handle carries in the + * inner loop In this case we fix the carry from the previous + * column since the Montgomery reduction requires digits of the + * result (so far) [see above] to work. This is + * handled by fixing up one carry after the inner loop. The + * carry fixups are done in order so after these loops the + * first m->used words of W[] have the carries fixed + */ + { + register int iy; + register mp_digit *tmpn; + register mp_word *_W; + + /* alias for the digits of the modulus */ + tmpn = n->dp; + + /* Alias for the columns set by an offset of ix */ + _W = W + ix; + + /* inner loop */ + for (iy = 0; iy < n->used; iy++) { + *_W++ += ((mp_word)mu) * ((mp_word)*tmpn++); + } + } + + /* now fix carry for next digit, W[ix+1] */ + W[ix + 1] += W[ix] >> ((mp_word) DIGIT_BIT); + } + + /* now we have to propagate the carries and + * shift the words downward [all those least + * significant digits we zeroed]. + */ + { + register mp_digit *tmpx; + register mp_word *_W, *_W1; + + /* nox fix rest of carries */ + + /* alias for current word */ + _W1 = W + ix; + + /* alias for next word, where the carry goes */ + _W = W + ++ix; + + for (; ix <= n->used * 2 + 1; ix++) { + *_W++ += *_W1++ >> ((mp_word) DIGIT_BIT); + } + + /* copy out, A = A/b**n + * + * The result is A/b**n but instead of converting from an + * array of mp_word to mp_digit than calling mp_rshd + * we just copy them in the right order + */ + + /* alias for destination word */ + tmpx = x->dp; + + /* alias for shifted double precision result */ + _W = W + n->used; + + for (ix = 0; ix < n->used + 1; ix++) { + *tmpx++ = (mp_digit)(*_W++ & ((mp_word) MP_MASK)); + } + + /* zero oldused digits, if the input a was larger than + * m->used+1 we'll have to clear the digits + */ + for (; ix < olduse; ix++) { + *tmpx++ = 0; + } + } + + /* set the max used and clamp */ + x->used = n->used + 1; + mp_clamp (x); + + /* if A >= m then A = A - m */ + if (mp_cmp_mag (x, n) != MP_LT) { + return s_mp_sub (x, n, x); + } + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_fast_mp_montgomery_reduce.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_fast_s_mp_mul_digs.c Index: libtommath/bn_fast_s_mp_mul_digs.c ================================================================== --- /dev/null +++ libtommath/bn_fast_s_mp_mul_digs.c @@ -0,0 +1,110 @@ +#include +#ifdef BN_FAST_S_MP_MUL_DIGS_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* Fast (comba) multiplier + * + * This is the fast column-array [comba] multiplier. It is + * designed to compute the columns of the product first + * then handle the carries afterwards. This has the effect + * of making the nested loops that compute the columns very + * simple and schedulable on super-scalar processors. + * + * This has been modified to produce a variable number of + * digits of output so if say only a half-product is required + * you don't have to compute the upper half (a feature + * required for fast Barrett reduction). + * + * Based on Algorithm 14.12 on pp.595 of HAC. + * + */ +int fast_s_mp_mul_digs (mp_int * a, mp_int * b, mp_int * c, int digs) +{ + int olduse, res, pa, ix, iz; + mp_digit W[MP_WARRAY]; + register mp_word _W; + + /* grow the destination as required */ + if (c->alloc < digs) { + if ((res = mp_grow (c, digs)) != MP_OKAY) { + return res; + } + } + + /* number of output digits to produce */ + pa = MIN(digs, a->used + b->used); + + /* clear the carry */ + _W = 0; + for (ix = 0; ix < pa; ix++) { + int tx, ty; + int iy; + mp_digit *tmpx, *tmpy; + + /* get offsets into the two bignums */ + ty = MIN(b->used-1, ix); + tx = ix - ty; + + /* setup temp aliases */ + tmpx = a->dp + tx; + tmpy = b->dp + ty; + + /* this is the number of times the loop will iterrate, essentially + while (tx++ < a->used && ty-- >= 0) { ... } + */ + iy = MIN(a->used-tx, ty+1); + + /* execute loop */ + for (iz = 0; iz < iy; ++iz) { + _W += ((mp_word)*tmpx++)*((mp_word)*tmpy--); + + } + + /* store term */ + W[ix] = ((mp_digit)_W) & MP_MASK; + + /* make next carry */ + _W = _W >> ((mp_word)DIGIT_BIT); + } + + /* store final carry */ + W[ix] = (mp_digit)(_W & MP_MASK); + + /* setup dest */ + olduse = c->used; + c->used = pa; + + { + register mp_digit *tmpc; + tmpc = c->dp; + for (ix = 0; ix < pa+1; ix++) { + /* now extract the previous digit [below the carry] */ + *tmpc++ = W[ix]; + } + + /* clear unused digits [that existed in the old copy of c] */ + for (; ix < olduse; ix++) { + *tmpc++ = 0; + } + } + mp_clamp (c); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_fast_s_mp_mul_digs.c,v $ */ +/* $Revision: 1.1.1.1.2.3 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_fast_s_mp_mul_high_digs.c Index: libtommath/bn_fast_s_mp_mul_high_digs.c ================================================================== --- /dev/null +++ libtommath/bn_fast_s_mp_mul_high_digs.c @@ -0,0 +1,101 @@ +#include +#ifdef BN_FAST_S_MP_MUL_HIGH_DIGS_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* this is a modified version of fast_s_mul_digs that only produces + * output digits *above* digs. See the comments for fast_s_mul_digs + * to see how it works. + * + * This is used in the Barrett reduction since for one of the multiplications + * only the higher digits were needed. This essentially halves the work. + * + * Based on Algorithm 14.12 on pp.595 of HAC. + */ +int fast_s_mp_mul_high_digs (mp_int * a, mp_int * b, mp_int * c, int digs) +{ + int olduse, res, pa, ix, iz; + mp_digit W[MP_WARRAY]; + mp_word _W; + + /* grow the destination as required */ + pa = a->used + b->used; + if (c->alloc < pa) { + if ((res = mp_grow (c, pa)) != MP_OKAY) { + return res; + } + } + + /* number of output digits to produce */ + pa = a->used + b->used; + _W = 0; + for (ix = digs; ix < pa; ix++) { + int tx, ty, iy; + mp_digit *tmpx, *tmpy; + + /* get offsets into the two bignums */ + ty = MIN(b->used-1, ix); + tx = ix - ty; + + /* setup temp aliases */ + tmpx = a->dp + tx; + tmpy = b->dp + ty; + + /* this is the number of times the loop will iterrate, essentially its + while (tx++ < a->used && ty-- >= 0) { ... } + */ + iy = MIN(a->used-tx, ty+1); + + /* execute loop */ + for (iz = 0; iz < iy; iz++) { + _W += ((mp_word)*tmpx++)*((mp_word)*tmpy--); + } + + /* store term */ + W[ix] = ((mp_digit)_W) & MP_MASK; + + /* make next carry */ + _W = _W >> ((mp_word)DIGIT_BIT); + } + + /* store final carry */ + W[ix] = (mp_digit)(_W & MP_MASK); + + /* setup dest */ + olduse = c->used; + c->used = pa; + + { + register mp_digit *tmpc; + + tmpc = c->dp + digs; + for (ix = digs; ix <= pa; ix++) { + /* now extract the previous digit [below the carry] */ + *tmpc++ = W[ix]; + } + + /* clear unused digits [that existed in the old copy of c] */ + for (; ix < olduse; ix++) { + *tmpc++ = 0; + } + } + mp_clamp (c); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_fast_s_mp_mul_high_digs.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_fast_s_mp_sqr.c Index: libtommath/bn_fast_s_mp_sqr.c ================================================================== --- /dev/null +++ libtommath/bn_fast_s_mp_sqr.c @@ -0,0 +1,114 @@ +#include +#ifdef BN_FAST_S_MP_SQR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* the jist of squaring... + * you do like mult except the offset of the tmpx [one that + * starts closer to zero] can't equal the offset of tmpy. + * So basically you set up iy like before then you min it with + * (ty-tx) so that it never happens. You double all those + * you add in the inner loop + +After that loop you do the squares and add them in. +*/ + +int fast_s_mp_sqr (mp_int * a, mp_int * b) +{ + int olduse, res, pa, ix, iz; + mp_digit W[MP_WARRAY], *tmpx; + mp_word W1; + + /* grow the destination as required */ + pa = a->used + a->used; + if (b->alloc < pa) { + if ((res = mp_grow (b, pa)) != MP_OKAY) { + return res; + } + } + + /* number of output digits to produce */ + W1 = 0; + for (ix = 0; ix < pa; ix++) { + int tx, ty, iy; + mp_word _W; + mp_digit *tmpy; + + /* clear counter */ + _W = 0; + + /* get offsets into the two bignums */ + ty = MIN(a->used-1, ix); + tx = ix - ty; + + /* setup temp aliases */ + tmpx = a->dp + tx; + tmpy = a->dp + ty; + + /* this is the number of times the loop will iterrate, essentially + while (tx++ < a->used && ty-- >= 0) { ... } + */ + iy = MIN(a->used-tx, ty+1); + + /* now for squaring tx can never equal ty + * we halve the distance since they approach at a rate of 2x + * and we have to round because odd cases need to be executed + */ + iy = MIN(iy, (ty-tx+1)>>1); + + /* execute loop */ + for (iz = 0; iz < iy; iz++) { + _W += ((mp_word)*tmpx++)*((mp_word)*tmpy--); + } + + /* double the inner product and add carry */ + _W = _W + _W + W1; + + /* even columns have the square term in them */ + if ((ix&1) == 0) { + _W += ((mp_word)a->dp[ix>>1])*((mp_word)a->dp[ix>>1]); + } + + /* store it */ + W[ix] = (mp_digit)(_W & MP_MASK); + + /* make next carry */ + W1 = _W >> ((mp_word)DIGIT_BIT); + } + + /* setup dest */ + olduse = b->used; + b->used = a->used+a->used; + + { + mp_digit *tmpb; + tmpb = b->dp; + for (ix = 0; ix < pa; ix++) { + *tmpb++ = W[ix] & MP_MASK; + } + + /* clear unused digits [that existed in the old copy of c] */ + for (; ix < olduse; ix++) { + *tmpb++ = 0; + } + } + mp_clamp (b); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_fast_s_mp_sqr.c,v $ */ +/* $Revision: 1.1.1.1.2.3 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_2expt.c Index: libtommath/bn_mp_2expt.c ================================================================== --- /dev/null +++ libtommath/bn_mp_2expt.c @@ -0,0 +1,48 @@ +#include +#ifdef BN_MP_2EXPT_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* computes a = 2**b + * + * Simple algorithm which zeroes the int, grows it then just sets one bit + * as required. + */ +int +mp_2expt (mp_int * a, int b) +{ + int res; + + /* zero a as per default */ + mp_zero (a); + + /* grow a to accomodate the single bit */ + if ((res = mp_grow (a, b / DIGIT_BIT + 1)) != MP_OKAY) { + return res; + } + + /* set the used count of where the bit will go */ + a->used = b / DIGIT_BIT + 1; + + /* put the single bit in its place */ + a->dp[b / DIGIT_BIT] = ((mp_digit)1) << (b % DIGIT_BIT); + + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_2expt.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_abs.c Index: libtommath/bn_mp_abs.c ================================================================== --- /dev/null +++ libtommath/bn_mp_abs.c @@ -0,0 +1,43 @@ +#include +#ifdef BN_MP_ABS_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* b = |a| + * + * Simple function copies the input and fixes the sign to positive + */ +int +mp_abs (mp_int * a, mp_int * b) +{ + int res; + + /* copy a to b */ + if (a != b) { + if ((res = mp_copy (a, b)) != MP_OKAY) { + return res; + } + } + + /* force the sign of b to positive */ + b->sign = MP_ZPOS; + + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_abs.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_add.c Index: libtommath/bn_mp_add.c ================================================================== --- /dev/null +++ libtommath/bn_mp_add.c @@ -0,0 +1,53 @@ +#include +#ifdef BN_MP_ADD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* high level addition (handles signs) */ +int mp_add (mp_int * a, mp_int * b, mp_int * c) +{ + int sa, sb, res; + + /* get sign of both inputs */ + sa = a->sign; + sb = b->sign; + + /* handle two cases, not four */ + if (sa == sb) { + /* both positive or both negative */ + /* add their magnitudes, copy the sign */ + c->sign = sa; + res = s_mp_add (a, b, c); + } else { + /* one positive, the other negative */ + /* subtract the one with the greater magnitude from */ + /* the one of the lesser magnitude. The result gets */ + /* the sign of the one with the greater magnitude. */ + if (mp_cmp_mag (a, b) == MP_LT) { + c->sign = sb; + res = s_mp_sub (b, a, c); + } else { + c->sign = sa; + res = s_mp_sub (a, b, c); + } + } + return res; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_add.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_add_d.c Index: libtommath/bn_mp_add_d.c ================================================================== --- /dev/null +++ libtommath/bn_mp_add_d.c @@ -0,0 +1,110 @@ +#include +#ifdef BN_MP_ADD_D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* single digit addition */ +int +mp_add_d (mp_int * a, mp_digit b, mp_int * c) +{ + int res, ix, oldused; + mp_digit *tmpa, *tmpc, mu; + + /* grow c as required */ + if (c->alloc < a->used + 1) { + if ((res = mp_grow(c, a->used + 1)) != MP_OKAY) { + return res; + } + } + + /* if a is negative and |a| >= b, call c = |a| - b */ + if (a->sign == MP_NEG && (a->used > 1 || a->dp[0] >= b)) { + /* temporarily fix sign of a */ + a->sign = MP_ZPOS; + + /* c = |a| - b */ + res = mp_sub_d(a, b, c); + + /* fix signs */ + a->sign = MP_NEG; + c->sign = (c->used) ? MP_NEG : MP_ZPOS; + + return res; + } + + /* old number of used digits in c */ + oldused = c->used; + + /* sign always positive */ + c->sign = MP_ZPOS; + + /* source alias */ + tmpa = a->dp; + + /* destination alias */ + tmpc = c->dp; + + /* if a is positive */ + if (a->sign == MP_ZPOS) { + /* add digit, after this we're propagating + * the carry. + */ + *tmpc = *tmpa++ + b; + mu = *tmpc >> DIGIT_BIT; + *tmpc++ &= MP_MASK; + + /* now handle rest of the digits */ + for (ix = 1; ix < a->used; ix++) { + *tmpc = *tmpa++ + mu; + mu = *tmpc >> DIGIT_BIT; + *tmpc++ &= MP_MASK; + } + /* set final carry */ + ix++; + *tmpc++ = mu; + + /* setup size */ + c->used = a->used + 1; + } else { + /* a was negative and |a| < b */ + c->used = 1; + + /* the result is a single digit */ + if (a->used == 1) { + *tmpc++ = b - a->dp[0]; + } else { + *tmpc++ = b; + } + + /* setup count so the clearing of oldused + * can fall through correctly + */ + ix = 1; + } + + /* now zero to oldused */ + while (ix++ < oldused) { + *tmpc++ = 0; + } + mp_clamp(c); + + return MP_OKAY; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_add_d.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_addmod.c Index: libtommath/bn_mp_addmod.c ================================================================== --- /dev/null +++ libtommath/bn_mp_addmod.c @@ -0,0 +1,41 @@ +#include +#ifdef BN_MP_ADDMOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* d = a + b (mod c) */ +int +mp_addmod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) +{ + int res; + mp_int t; + + if ((res = mp_init (&t)) != MP_OKAY) { + return res; + } + + if ((res = mp_add (a, b, &t)) != MP_OKAY) { + mp_clear (&t); + return res; + } + res = mp_mod (&t, c, d); + mp_clear (&t); + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_addmod.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_and.c Index: libtommath/bn_mp_and.c ================================================================== --- /dev/null +++ libtommath/bn_mp_and.c @@ -0,0 +1,57 @@ +#include +#ifdef BN_MP_AND_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* AND two ints together */ +int +mp_and (mp_int * a, mp_int * b, mp_int * c) +{ + int res, ix, px; + mp_int t, *x; + + if (a->used > b->used) { + if ((res = mp_init_copy (&t, a)) != MP_OKAY) { + return res; + } + px = b->used; + x = b; + } else { + if ((res = mp_init_copy (&t, b)) != MP_OKAY) { + return res; + } + px = a->used; + x = a; + } + + for (ix = 0; ix < px; ix++) { + t.dp[ix] &= x->dp[ix]; + } + + /* zero digits above the last from the smallest mp_int */ + for (; ix < t.used; ix++) { + t.dp[ix] = 0; + } + + mp_clamp (&t); + mp_exch (c, &t); + mp_clear (&t); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_and.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_clamp.c Index: libtommath/bn_mp_clamp.c ================================================================== --- /dev/null +++ libtommath/bn_mp_clamp.c @@ -0,0 +1,44 @@ +#include +#ifdef BN_MP_CLAMP_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* trim unused digits + * + * This is used to ensure that leading zero digits are + * trimed and the leading "used" digit will be non-zero + * Typically very fast. Also fixes the sign if there + * are no more leading digits + */ +void +mp_clamp (mp_int * a) +{ + /* decrease used while the most significant digit is + * zero. + */ + while (a->used > 0 && a->dp[a->used - 1] == 0) { + --(a->used); + } + + /* reset the sign flag if used == 0 */ + if (a->used == 0) { + a->sign = MP_ZPOS; + } +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_clamp.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_clear.c Index: libtommath/bn_mp_clear.c ================================================================== --- /dev/null +++ libtommath/bn_mp_clear.c @@ -0,0 +1,44 @@ +#include +#ifdef BN_MP_CLEAR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* clear one (frees) */ +void +mp_clear (mp_int * a) +{ + int i; + + /* only do anything if a hasn't been freed previously */ + if (a->dp != NULL) { + /* first zero the digits */ + for (i = 0; i < a->used; i++) { + a->dp[i] = 0; + } + + /* free ram */ + XFREE(a->dp); + + /* reset members to make debugging easier */ + a->dp = NULL; + a->alloc = a->used = 0; + a->sign = MP_ZPOS; + } +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_clear.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_clear_multi.c Index: libtommath/bn_mp_clear_multi.c ================================================================== --- /dev/null +++ libtommath/bn_mp_clear_multi.c @@ -0,0 +1,34 @@ +#include +#ifdef BN_MP_CLEAR_MULTI_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ +#include + +void mp_clear_multi(mp_int *mp, ...) +{ + mp_int* next_mp = mp; + va_list args; + va_start(args, mp); + while (next_mp != NULL) { + mp_clear(next_mp); + next_mp = va_arg(args, mp_int*); + } + va_end(args); +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_clear_multi.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_cmp.c Index: libtommath/bn_mp_cmp.c ================================================================== --- /dev/null +++ libtommath/bn_mp_cmp.c @@ -0,0 +1,43 @@ +#include +#ifdef BN_MP_CMP_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* compare two ints (signed)*/ +int +mp_cmp (mp_int * a, mp_int * b) +{ + /* compare based on sign */ + if (a->sign != b->sign) { + if (a->sign == MP_NEG) { + return MP_LT; + } else { + return MP_GT; + } + } + + /* compare digits */ + if (a->sign == MP_NEG) { + /* if negative compare opposite direction */ + return mp_cmp_mag(b, a); + } else { + return mp_cmp_mag(a, b); + } +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_cmp.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_cmp_d.c Index: libtommath/bn_mp_cmp_d.c ================================================================== --- /dev/null +++ libtommath/bn_mp_cmp_d.c @@ -0,0 +1,44 @@ +#include +#ifdef BN_MP_CMP_D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* compare a digit */ +int mp_cmp_d(mp_int * a, mp_digit b) +{ + /* compare based on sign */ + if (a->sign == MP_NEG) { + return MP_LT; + } + + /* compare based on magnitude */ + if (a->used > 1) { + return MP_GT; + } + + /* compare the only digit of a to b */ + if (a->dp[0] > b) { + return MP_GT; + } else if (a->dp[0] < b) { + return MP_LT; + } else { + return MP_EQ; + } +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_cmp_d.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_cmp_mag.c Index: libtommath/bn_mp_cmp_mag.c ================================================================== --- /dev/null +++ libtommath/bn_mp_cmp_mag.c @@ -0,0 +1,55 @@ +#include +#ifdef BN_MP_CMP_MAG_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* compare maginitude of two ints (unsigned) */ +int mp_cmp_mag (mp_int * a, mp_int * b) +{ + int n; + mp_digit *tmpa, *tmpb; + + /* compare based on # of non-zero digits */ + if (a->used > b->used) { + return MP_GT; + } + + if (a->used < b->used) { + return MP_LT; + } + + /* alias for a */ + tmpa = a->dp + (a->used - 1); + + /* alias for b */ + tmpb = b->dp + (a->used - 1); + + /* compare based on digits */ + for (n = 0; n < a->used; ++n, --tmpa, --tmpb) { + if (*tmpa > *tmpb) { + return MP_GT; + } + + if (*tmpa < *tmpb) { + return MP_LT; + } + } + return MP_EQ; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_cmp_mag.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_cnt_lsb.c Index: libtommath/bn_mp_cnt_lsb.c ================================================================== --- /dev/null +++ libtommath/bn_mp_cnt_lsb.c @@ -0,0 +1,53 @@ +#include +#ifdef BN_MP_CNT_LSB_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +static const int lnz[16] = { + 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0 +}; + +/* Counts the number of lsbs which are zero before the first zero bit */ +int mp_cnt_lsb(mp_int *a) +{ + int x; + mp_digit q, qq; + + /* easy out */ + if (mp_iszero(a) == 1) { + return 0; + } + + /* scan lower digits until non-zero */ + for (x = 0; x < a->used && a->dp[x] == 0; x++); + q = a->dp[x]; + x *= DIGIT_BIT; + + /* now scan this digit until a 1 is found */ + if ((q & 1) == 0) { + do { + qq = q & 15; + x += lnz[qq]; + q >>= 4; + } while (qq == 0); + } + return x; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_cnt_lsb.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_copy.c Index: libtommath/bn_mp_copy.c ================================================================== --- /dev/null +++ libtommath/bn_mp_copy.c @@ -0,0 +1,68 @@ +#include +#ifdef BN_MP_COPY_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* copy, b = a */ +int +mp_copy (mp_int * a, mp_int * b) +{ + int res, n; + + /* if dst == src do nothing */ + if (a == b) { + return MP_OKAY; + } + + /* grow dest */ + if (b->alloc < a->used) { + if ((res = mp_grow (b, a->used)) != MP_OKAY) { + return res; + } + } + + /* zero b and copy the parameters over */ + { + register mp_digit *tmpa, *tmpb; + + /* pointer aliases */ + + /* source */ + tmpa = a->dp; + + /* destination */ + tmpb = b->dp; + + /* copy all the digits */ + for (n = 0; n < a->used; n++) { + *tmpb++ = *tmpa++; + } + + /* clear high digits */ + for (; n < b->used; n++) { + *tmpb++ = 0; + } + } + + /* copy used count and sign */ + b->used = a->used; + b->sign = a->sign; + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_copy.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_count_bits.c Index: libtommath/bn_mp_count_bits.c ================================================================== --- /dev/null +++ libtommath/bn_mp_count_bits.c @@ -0,0 +1,45 @@ +#include +#ifdef BN_MP_COUNT_BITS_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* returns the number of bits in an int */ +int +mp_count_bits (mp_int * a) +{ + int r; + mp_digit q; + + /* shortcut */ + if (a->used == 0) { + return 0; + } + + /* get number of digits and add that */ + r = (a->used - 1) * DIGIT_BIT; + + /* take the last digit and count the bits in it */ + q = a->dp[a->used - 1]; + while (q > ((mp_digit) 0)) { + ++r; + q >>= ((mp_digit) 1); + } + return r; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_count_bits.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_div.c Index: libtommath/bn_mp_div.c ================================================================== --- /dev/null +++ libtommath/bn_mp_div.c @@ -0,0 +1,292 @@ +#include +#ifdef BN_MP_DIV_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +#ifdef BN_MP_DIV_SMALL + +/* slower bit-bang division... also smaller */ +int mp_div(mp_int * a, mp_int * b, mp_int * c, mp_int * d) +{ + mp_int ta, tb, tq, q; + int res, n, n2; + + /* is divisor zero ? */ + if (mp_iszero (b) == 1) { + return MP_VAL; + } + + /* if a < b then q=0, r = a */ + if (mp_cmp_mag (a, b) == MP_LT) { + if (d != NULL) { + res = mp_copy (a, d); + } else { + res = MP_OKAY; + } + if (c != NULL) { + mp_zero (c); + } + return res; + } + + /* init our temps */ + if ((res = mp_init_multi(&ta, &tb, &tq, &q, NULL) != MP_OKAY)) { + return res; + } + + + mp_set(&tq, 1); + n = mp_count_bits(a) - mp_count_bits(b); + if (((res = mp_abs(a, &ta)) != MP_OKAY) || + ((res = mp_abs(b, &tb)) != MP_OKAY) || + ((res = mp_mul_2d(&tb, n, &tb)) != MP_OKAY) || + ((res = mp_mul_2d(&tq, n, &tq)) != MP_OKAY)) { + goto LBL_ERR; + } + + while (n-- >= 0) { + if (mp_cmp(&tb, &ta) != MP_GT) { + if (((res = mp_sub(&ta, &tb, &ta)) != MP_OKAY) || + ((res = mp_add(&q, &tq, &q)) != MP_OKAY)) { + goto LBL_ERR; + } + } + if (((res = mp_div_2d(&tb, 1, &tb, NULL)) != MP_OKAY) || + ((res = mp_div_2d(&tq, 1, &tq, NULL)) != MP_OKAY)) { + goto LBL_ERR; + } + } + + /* now q == quotient and ta == remainder */ + n = a->sign; + n2 = (a->sign == b->sign ? MP_ZPOS : MP_NEG); + if (c != NULL) { + mp_exch(c, &q); + c->sign = (mp_iszero(c) == MP_YES) ? MP_ZPOS : n2; + } + if (d != NULL) { + mp_exch(d, &ta); + d->sign = (mp_iszero(d) == MP_YES) ? MP_ZPOS : n; + } +LBL_ERR: + mp_clear_multi(&ta, &tb, &tq, &q, NULL); + return res; +} + +#else + +/* integer signed division. + * c*b + d == a [e.g. a/b, c=quotient, d=remainder] + * HAC pp.598 Algorithm 14.20 + * + * Note that the description in HAC is horribly + * incomplete. For example, it doesn't consider + * the case where digits are removed from 'x' in + * the inner loop. It also doesn't consider the + * case that y has fewer than three digits, etc.. + * + * The overall algorithm is as described as + * 14.20 from HAC but fixed to treat these cases. +*/ +int mp_div (mp_int * a, mp_int * b, mp_int * c, mp_int * d) +{ + mp_int q, x, y, t1, t2; + int res, n, t, i, norm, neg; + + /* is divisor zero ? */ + if (mp_iszero (b) == 1) { + return MP_VAL; + } + + /* if a < b then q=0, r = a */ + if (mp_cmp_mag (a, b) == MP_LT) { + if (d != NULL) { + res = mp_copy (a, d); + } else { + res = MP_OKAY; + } + if (c != NULL) { + mp_zero (c); + } + return res; + } + + if ((res = mp_init_size (&q, a->used + 2)) != MP_OKAY) { + return res; + } + q.used = a->used + 2; + + if ((res = mp_init (&t1)) != MP_OKAY) { + goto LBL_Q; + } + + if ((res = mp_init (&t2)) != MP_OKAY) { + goto LBL_T1; + } + + if ((res = mp_init_copy (&x, a)) != MP_OKAY) { + goto LBL_T2; + } + + if ((res = mp_init_copy (&y, b)) != MP_OKAY) { + goto LBL_X; + } + + /* fix the sign */ + neg = (a->sign == b->sign) ? MP_ZPOS : MP_NEG; + x.sign = y.sign = MP_ZPOS; + + /* normalize both x and y, ensure that y >= b/2, [b == 2**DIGIT_BIT] */ + norm = mp_count_bits(&y) % DIGIT_BIT; + if (norm < (int)(DIGIT_BIT-1)) { + norm = (DIGIT_BIT-1) - norm; + if ((res = mp_mul_2d (&x, norm, &x)) != MP_OKAY) { + goto LBL_Y; + } + if ((res = mp_mul_2d (&y, norm, &y)) != MP_OKAY) { + goto LBL_Y; + } + } else { + norm = 0; + } + + /* note hac does 0 based, so if used==5 then its 0,1,2,3,4, e.g. use 4 */ + n = x.used - 1; + t = y.used - 1; + + /* while (x >= y*b**n-t) do { q[n-t] += 1; x -= y*b**{n-t} } */ + if ((res = mp_lshd (&y, n - t)) != MP_OKAY) { /* y = y*b**{n-t} */ + goto LBL_Y; + } + + while (mp_cmp (&x, &y) != MP_LT) { + ++(q.dp[n - t]); + if ((res = mp_sub (&x, &y, &x)) != MP_OKAY) { + goto LBL_Y; + } + } + + /* reset y by shifting it back down */ + mp_rshd (&y, n - t); + + /* step 3. for i from n down to (t + 1) */ + for (i = n; i >= (t + 1); i--) { + if (i > x.used) { + continue; + } + + /* step 3.1 if xi == yt then set q{i-t-1} to b-1, + * otherwise set q{i-t-1} to (xi*b + x{i-1})/yt */ + if (x.dp[i] == y.dp[t]) { + q.dp[i - t - 1] = ((((mp_digit)1) << DIGIT_BIT) - 1); + } else { + mp_word tmp; + tmp = ((mp_word) x.dp[i]) << ((mp_word) DIGIT_BIT); + tmp |= ((mp_word) x.dp[i - 1]); + tmp /= ((mp_word) y.dp[t]); + if (tmp > (mp_word) MP_MASK) + tmp = MP_MASK; + q.dp[i - t - 1] = (mp_digit) (tmp & (mp_word) (MP_MASK)); + } + + /* while (q{i-t-1} * (yt * b + y{t-1})) > + xi * b**2 + xi-1 * b + xi-2 + + do q{i-t-1} -= 1; + */ + q.dp[i - t - 1] = (q.dp[i - t - 1] + 1) & MP_MASK; + do { + q.dp[i - t - 1] = (q.dp[i - t - 1] - 1) & MP_MASK; + + /* find left hand */ + mp_zero (&t1); + t1.dp[0] = (t - 1 < 0) ? 0 : y.dp[t - 1]; + t1.dp[1] = y.dp[t]; + t1.used = 2; + if ((res = mp_mul_d (&t1, q.dp[i - t - 1], &t1)) != MP_OKAY) { + goto LBL_Y; + } + + /* find right hand */ + t2.dp[0] = (i - 2 < 0) ? 0 : x.dp[i - 2]; + t2.dp[1] = (i - 1 < 0) ? 0 : x.dp[i - 1]; + t2.dp[2] = x.dp[i]; + t2.used = 3; + } while (mp_cmp_mag(&t1, &t2) == MP_GT); + + /* step 3.3 x = x - q{i-t-1} * y * b**{i-t-1} */ + if ((res = mp_mul_d (&y, q.dp[i - t - 1], &t1)) != MP_OKAY) { + goto LBL_Y; + } + + if ((res = mp_lshd (&t1, i - t - 1)) != MP_OKAY) { + goto LBL_Y; + } + + if ((res = mp_sub (&x, &t1, &x)) != MP_OKAY) { + goto LBL_Y; + } + + /* if x < 0 then { x = x + y*b**{i-t-1}; q{i-t-1} -= 1; } */ + if (x.sign == MP_NEG) { + if ((res = mp_copy (&y, &t1)) != MP_OKAY) { + goto LBL_Y; + } + if ((res = mp_lshd (&t1, i - t - 1)) != MP_OKAY) { + goto LBL_Y; + } + if ((res = mp_add (&x, &t1, &x)) != MP_OKAY) { + goto LBL_Y; + } + + q.dp[i - t - 1] = (q.dp[i - t - 1] - 1UL) & MP_MASK; + } + } + + /* now q is the quotient and x is the remainder + * [which we have to normalize] + */ + + /* get sign before writing to c */ + x.sign = x.used == 0 ? MP_ZPOS : a->sign; + + if (c != NULL) { + mp_clamp (&q); + mp_exch (&q, c); + c->sign = neg; + } + + if (d != NULL) { + mp_div_2d (&x, norm, &x, NULL); + mp_exch (&x, d); + } + + res = MP_OKAY; + +LBL_Y:mp_clear (&y); +LBL_X:mp_clear (&x); +LBL_T2:mp_clear (&t2); +LBL_T1:mp_clear (&t1); +LBL_Q:mp_clear (&q); + return res; +} + +#endif + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_div.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_div_2.c Index: libtommath/bn_mp_div_2.c ================================================================== --- /dev/null +++ libtommath/bn_mp_div_2.c @@ -0,0 +1,68 @@ +#include +#ifdef BN_MP_DIV_2_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* b = a/2 */ +int mp_div_2(mp_int * a, mp_int * b) +{ + int x, res, oldused; + + /* copy */ + if (b->alloc < a->used) { + if ((res = mp_grow (b, a->used)) != MP_OKAY) { + return res; + } + } + + oldused = b->used; + b->used = a->used; + { + register mp_digit r, rr, *tmpa, *tmpb; + + /* source alias */ + tmpa = a->dp + b->used - 1; + + /* dest alias */ + tmpb = b->dp + b->used - 1; + + /* carry */ + r = 0; + for (x = b->used - 1; x >= 0; x--) { + /* get the carry for the next iteration */ + rr = *tmpa & 1; + + /* shift the current digit, add in carry and store */ + *tmpb-- = (*tmpa-- >> 1) | (r << (DIGIT_BIT - 1)); + + /* forward carry to next iteration */ + r = rr; + } + + /* zero excess digits */ + tmpb = b->dp + b->used; + for (x = b->used; x < oldused; x++) { + *tmpb++ = 0; + } + } + b->sign = a->sign; + mp_clamp (b); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_div_2.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_div_2d.c Index: libtommath/bn_mp_div_2d.c ================================================================== --- /dev/null +++ libtommath/bn_mp_div_2d.c @@ -0,0 +1,97 @@ +#include +#ifdef BN_MP_DIV_2D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* shift right by a certain bit count (store quotient in c, optional remainder in d) */ +int mp_div_2d (mp_int * a, int b, mp_int * c, mp_int * d) +{ + mp_digit D, r, rr; + int x, res; + mp_int t; + + + /* if the shift count is <= 0 then we do no work */ + if (b <= 0) { + res = mp_copy (a, c); + if (d != NULL) { + mp_zero (d); + } + return res; + } + + if ((res = mp_init (&t)) != MP_OKAY) { + return res; + } + + /* get the remainder */ + if (d != NULL) { + if ((res = mp_mod_2d (a, b, &t)) != MP_OKAY) { + mp_clear (&t); + return res; + } + } + + /* copy */ + if ((res = mp_copy (a, c)) != MP_OKAY) { + mp_clear (&t); + return res; + } + + /* shift by as many digits in the bit count */ + if (b >= (int)DIGIT_BIT) { + mp_rshd (c, b / DIGIT_BIT); + } + + /* shift any bit count < DIGIT_BIT */ + D = (mp_digit) (b % DIGIT_BIT); + if (D != 0) { + register mp_digit *tmpc, mask, shift; + + /* mask */ + mask = (((mp_digit)1) << D) - 1; + + /* shift for lsb */ + shift = DIGIT_BIT - D; + + /* alias */ + tmpc = c->dp + (c->used - 1); + + /* carry */ + r = 0; + for (x = c->used - 1; x >= 0; x--) { + /* get the lower bits of this word in a temp */ + rr = *tmpc & mask; + + /* shift the current word and mix in the carry bits from the previous word */ + *tmpc = (*tmpc >> D) | (r << shift); + --tmpc; + + /* set the carry to the carry bits of the current word found above */ + r = rr; + } + } + mp_clamp (c); + if (d != NULL) { + mp_exch (&t, d); + } + mp_clear (&t); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_div_2d.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_div_3.c Index: libtommath/bn_mp_div_3.c ================================================================== --- /dev/null +++ libtommath/bn_mp_div_3.c @@ -0,0 +1,79 @@ +#include +#ifdef BN_MP_DIV_3_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* divide by three (based on routine from MPI and the GMP manual) */ +int +mp_div_3 (mp_int * a, mp_int *c, mp_digit * d) +{ + mp_int q; + mp_word w, t; + mp_digit b; + int res, ix; + + /* b = 2**DIGIT_BIT / 3 */ + b = (((mp_word)1) << ((mp_word)DIGIT_BIT)) / ((mp_word)3); + + if ((res = mp_init_size(&q, a->used)) != MP_OKAY) { + return res; + } + + q.used = a->used; + q.sign = a->sign; + w = 0; + for (ix = a->used - 1; ix >= 0; ix--) { + w = (w << ((mp_word)DIGIT_BIT)) | ((mp_word)a->dp[ix]); + + if (w >= 3) { + /* multiply w by [1/3] */ + t = (w * ((mp_word)b)) >> ((mp_word)DIGIT_BIT); + + /* now subtract 3 * [w/3] from w, to get the remainder */ + w -= t+t+t; + + /* fixup the remainder as required since + * the optimization is not exact. + */ + while (w >= 3) { + t += 1; + w -= 3; + } + } else { + t = 0; + } + q.dp[ix] = (mp_digit)t; + } + + /* [optional] store the remainder */ + if (d != NULL) { + *d = (mp_digit)w; + } + + /* [optional] store the quotient */ + if (c != NULL) { + mp_clamp(&q); + mp_exch(&q, c); + } + mp_clear(&q); + + return res; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_div_3.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_div_d.c Index: libtommath/bn_mp_div_d.c ================================================================== --- /dev/null +++ libtommath/bn_mp_div_d.c @@ -0,0 +1,110 @@ +#include +#ifdef BN_MP_DIV_D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +static int s_is_power_of_two(mp_digit b, int *p) +{ + int x; + + for (x = 1; x < DIGIT_BIT; x++) { + if (b == (((mp_digit)1)<dp[0] & ((((mp_digit)1)<used)) != MP_OKAY) { + return res; + } + + q.used = a->used; + q.sign = a->sign; + w = 0; + for (ix = a->used - 1; ix >= 0; ix--) { + w = (w << ((mp_word)DIGIT_BIT)) | ((mp_word)a->dp[ix]); + + if (w >= b) { + t = (mp_digit)(w / b); + w -= ((mp_word)t) * ((mp_word)b); + } else { + t = 0; + } + q.dp[ix] = (mp_digit)t; + } + + if (d != NULL) { + *d = (mp_digit)w; + } + + if (c != NULL) { + mp_clamp(&q); + mp_exch(&q, c); + } + mp_clear(&q); + + return res; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_div_d.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_dr_is_modulus.c Index: libtommath/bn_mp_dr_is_modulus.c ================================================================== --- /dev/null +++ libtommath/bn_mp_dr_is_modulus.c @@ -0,0 +1,43 @@ +#include +#ifdef BN_MP_DR_IS_MODULUS_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* determines if a number is a valid DR modulus */ +int mp_dr_is_modulus(mp_int *a) +{ + int ix; + + /* must be at least two digits */ + if (a->used < 2) { + return 0; + } + + /* must be of the form b**k - a [a <= b] so all + * but the first digit must be equal to -1 (mod b). + */ + for (ix = 1; ix < a->used; ix++) { + if (a->dp[ix] != MP_MASK) { + return 0; + } + } + return 1; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_dr_is_modulus.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_dr_reduce.c Index: libtommath/bn_mp_dr_reduce.c ================================================================== --- /dev/null +++ libtommath/bn_mp_dr_reduce.c @@ -0,0 +1,94 @@ +#include +#ifdef BN_MP_DR_REDUCE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* reduce "x" in place modulo "n" using the Diminished Radix algorithm. + * + * Based on algorithm from the paper + * + * "Generating Efficient Primes for Discrete Log Cryptosystems" + * Chae Hoon Lim, Pil Joong Lee, + * POSTECH Information Research Laboratories + * + * The modulus must be of a special format [see manual] + * + * Has been modified to use algorithm 7.10 from the LTM book instead + * + * Input x must be in the range 0 <= x <= (n-1)**2 + */ +int +mp_dr_reduce (mp_int * x, mp_int * n, mp_digit k) +{ + int err, i, m; + mp_word r; + mp_digit mu, *tmpx1, *tmpx2; + + /* m = digits in modulus */ + m = n->used; + + /* ensure that "x" has at least 2m digits */ + if (x->alloc < m + m) { + if ((err = mp_grow (x, m + m)) != MP_OKAY) { + return err; + } + } + +/* top of loop, this is where the code resumes if + * another reduction pass is required. + */ +top: + /* aliases for digits */ + /* alias for lower half of x */ + tmpx1 = x->dp; + + /* alias for upper half of x, or x/B**m */ + tmpx2 = x->dp + m; + + /* set carry to zero */ + mu = 0; + + /* compute (x mod B**m) + k * [x/B**m] inline and inplace */ + for (i = 0; i < m; i++) { + r = ((mp_word)*tmpx2++) * ((mp_word)k) + *tmpx1 + mu; + *tmpx1++ = (mp_digit)(r & MP_MASK); + mu = (mp_digit)(r >> ((mp_word)DIGIT_BIT)); + } + + /* set final carry */ + *tmpx1++ = mu; + + /* zero words above m */ + for (i = m + 1; i < x->used; i++) { + *tmpx1++ = 0; + } + + /* clamp, sub and return */ + mp_clamp (x); + + /* if x >= n then subtract and reduce again + * Each successive "recursion" makes the input smaller and smaller. + */ + if (mp_cmp_mag (x, n) != MP_LT) { + s_mp_sub(x, n, x); + goto top; + } + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_dr_reduce.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_dr_setup.c Index: libtommath/bn_mp_dr_setup.c ================================================================== --- /dev/null +++ libtommath/bn_mp_dr_setup.c @@ -0,0 +1,32 @@ +#include +#ifdef BN_MP_DR_SETUP_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* determines the setup value */ +void mp_dr_setup(mp_int *a, mp_digit *d) +{ + /* the casts are required if DIGIT_BIT is one less than + * the number of bits in a mp_digit [e.g. DIGIT_BIT==31] + */ + *d = (mp_digit)((((mp_word)1) << ((mp_word)DIGIT_BIT)) - + ((mp_word)a->dp[0])); +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_dr_setup.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_exch.c Index: libtommath/bn_mp_exch.c ================================================================== --- /dev/null +++ libtommath/bn_mp_exch.c @@ -0,0 +1,34 @@ +#include +#ifdef BN_MP_EXCH_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* swap the elements of two integers, for cases where you can't simply swap the + * mp_int pointers around + */ +void +mp_exch (mp_int * a, mp_int * b) +{ + mp_int t; + + t = *a; + *a = *b; + *b = t; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_exch.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_expt_d.c Index: libtommath/bn_mp_expt_d.c ================================================================== --- /dev/null +++ libtommath/bn_mp_expt_d.c @@ -0,0 +1,57 @@ +#include +#ifdef BN_MP_EXPT_D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* calculate c = a**b using a square-multiply algorithm */ +int mp_expt_d (mp_int * a, mp_digit b, mp_int * c) +{ + int res, x; + mp_int g; + + if ((res = mp_init_copy (&g, a)) != MP_OKAY) { + return res; + } + + /* set initial result */ + mp_set (c, 1); + + for (x = 0; x < (int) DIGIT_BIT; x++) { + /* square */ + if ((res = mp_sqr (c, c)) != MP_OKAY) { + mp_clear (&g); + return res; + } + + /* if the bit is set multiply */ + if ((b & (mp_digit) (((mp_digit)1) << (DIGIT_BIT - 1))) != 0) { + if ((res = mp_mul (c, &g, c)) != MP_OKAY) { + mp_clear (&g); + return res; + } + } + + /* shift to next bit */ + b <<= 1; + } + + mp_clear (&g); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_expt_d.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_exptmod.c Index: libtommath/bn_mp_exptmod.c ================================================================== --- /dev/null +++ libtommath/bn_mp_exptmod.c @@ -0,0 +1,112 @@ +#include +#ifdef BN_MP_EXPTMOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + + +/* this is a shell function that calls either the normal or Montgomery + * exptmod functions. Originally the call to the montgomery code was + * embedded in the normal function but that wasted alot of stack space + * for nothing (since 99% of the time the Montgomery code would be called) + */ +int mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y) +{ + int dr; + + /* modulus P must be positive */ + if (P->sign == MP_NEG) { + return MP_VAL; + } + + /* if exponent X is negative we have to recurse */ + if (X->sign == MP_NEG) { +#ifdef BN_MP_INVMOD_C + mp_int tmpG, tmpX; + int err; + + /* first compute 1/G mod P */ + if ((err = mp_init(&tmpG)) != MP_OKAY) { + return err; + } + if ((err = mp_invmod(G, P, &tmpG)) != MP_OKAY) { + mp_clear(&tmpG); + return err; + } + + /* now get |X| */ + if ((err = mp_init(&tmpX)) != MP_OKAY) { + mp_clear(&tmpG); + return err; + } + if ((err = mp_abs(X, &tmpX)) != MP_OKAY) { + mp_clear_multi(&tmpG, &tmpX, NULL); + return err; + } + + /* and now compute (1/G)**|X| instead of G**X [X < 0] */ + err = mp_exptmod(&tmpG, &tmpX, P, Y); + mp_clear_multi(&tmpG, &tmpX, NULL); + return err; +#else + /* no invmod */ + return MP_VAL; +#endif + } + +/* modified diminished radix reduction */ +#if defined(BN_MP_REDUCE_IS_2K_L_C) && defined(BN_MP_REDUCE_2K_L_C) && defined(BN_S_MP_EXPTMOD_C) + if (mp_reduce_is_2k_l(P) == MP_YES) { + return s_mp_exptmod(G, X, P, Y, 1); + } +#endif + +#ifdef BN_MP_DR_IS_MODULUS_C + /* is it a DR modulus? */ + dr = mp_dr_is_modulus(P); +#else + /* default to no */ + dr = 0; +#endif + +#ifdef BN_MP_REDUCE_IS_2K_C + /* if not, is it a unrestricted DR modulus? */ + if (dr == 0) { + dr = mp_reduce_is_2k(P) << 1; + } +#endif + + /* if the modulus is odd or dr != 0 use the montgomery method */ +#ifdef BN_MP_EXPTMOD_FAST_C + if (mp_isodd (P) == 1 || dr != 0) { + return mp_exptmod_fast (G, X, P, Y, dr); + } else { +#endif +#ifdef BN_S_MP_EXPTMOD_C + /* otherwise use the generic Barrett reduction technique */ + return s_mp_exptmod (G, X, P, Y, 0); +#else + /* no exptmod for evens */ + return MP_VAL; +#endif +#ifdef BN_MP_EXPTMOD_FAST_C + } +#endif +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_exptmod.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_exptmod_fast.c Index: libtommath/bn_mp_exptmod_fast.c ================================================================== --- /dev/null +++ libtommath/bn_mp_exptmod_fast.c @@ -0,0 +1,321 @@ +#include +#ifdef BN_MP_EXPTMOD_FAST_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* computes Y == G**X mod P, HAC pp.616, Algorithm 14.85 + * + * Uses a left-to-right k-ary sliding window to compute the modular exponentiation. + * The value of k changes based on the size of the exponent. + * + * Uses Montgomery or Diminished Radix reduction [whichever appropriate] + */ + +#ifdef MP_LOW_MEM + #define TAB_SIZE 32 +#else + #define TAB_SIZE 256 +#endif + +int mp_exptmod_fast (mp_int * G, mp_int * X, mp_int * P, mp_int * Y, int redmode) +{ + mp_int M[TAB_SIZE], res; + mp_digit buf, mp; + int err, bitbuf, bitcpy, bitcnt, mode, digidx, x, y, winsize; + + /* use a pointer to the reduction algorithm. This allows us to use + * one of many reduction algorithms without modding the guts of + * the code with if statements everywhere. + */ + int (*redux)(mp_int*,mp_int*,mp_digit); + + /* find window size */ + x = mp_count_bits (X); + if (x <= 7) { + winsize = 2; + } else if (x <= 36) { + winsize = 3; + } else if (x <= 140) { + winsize = 4; + } else if (x <= 450) { + winsize = 5; + } else if (x <= 1303) { + winsize = 6; + } else if (x <= 3529) { + winsize = 7; + } else { + winsize = 8; + } + +#ifdef MP_LOW_MEM + if (winsize > 5) { + winsize = 5; + } +#endif + + /* init M array */ + /* init first cell */ + if ((err = mp_init(&M[1])) != MP_OKAY) { + return err; + } + + /* now init the second half of the array */ + for (x = 1<<(winsize-1); x < (1 << winsize); x++) { + if ((err = mp_init(&M[x])) != MP_OKAY) { + for (y = 1<<(winsize-1); y < x; y++) { + mp_clear (&M[y]); + } + mp_clear(&M[1]); + return err; + } + } + + /* determine and setup reduction code */ + if (redmode == 0) { +#ifdef BN_MP_MONTGOMERY_SETUP_C + /* now setup montgomery */ + if ((err = mp_montgomery_setup (P, &mp)) != MP_OKAY) { + goto LBL_M; + } +#else + err = MP_VAL; + goto LBL_M; +#endif + + /* automatically pick the comba one if available (saves quite a few calls/ifs) */ +#ifdef BN_FAST_MP_MONTGOMERY_REDUCE_C + if (((P->used * 2 + 1) < MP_WARRAY) && + P->used < (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) { + redux = fast_mp_montgomery_reduce; + } else +#endif + { +#ifdef BN_MP_MONTGOMERY_REDUCE_C + /* use slower baseline Montgomery method */ + redux = mp_montgomery_reduce; +#else + err = MP_VAL; + goto LBL_M; +#endif + } + } else if (redmode == 1) { +#if defined(BN_MP_DR_SETUP_C) && defined(BN_MP_DR_REDUCE_C) + /* setup DR reduction for moduli of the form B**k - b */ + mp_dr_setup(P, &mp); + redux = mp_dr_reduce; +#else + err = MP_VAL; + goto LBL_M; +#endif + } else { +#if defined(BN_MP_REDUCE_2K_SETUP_C) && defined(BN_MP_REDUCE_2K_C) + /* setup DR reduction for moduli of the form 2**k - b */ + if ((err = mp_reduce_2k_setup(P, &mp)) != MP_OKAY) { + goto LBL_M; + } + redux = mp_reduce_2k; +#else + err = MP_VAL; + goto LBL_M; +#endif + } + + /* setup result */ + if ((err = mp_init (&res)) != MP_OKAY) { + goto LBL_M; + } + + /* create M table + * + + * + * The first half of the table is not computed though accept for M[0] and M[1] + */ + + if (redmode == 0) { +#ifdef BN_MP_MONTGOMERY_CALC_NORMALIZATION_C + /* now we need R mod m */ + if ((err = mp_montgomery_calc_normalization (&res, P)) != MP_OKAY) { + goto LBL_RES; + } +#else + err = MP_VAL; + goto LBL_RES; +#endif + + /* now set M[1] to G * R mod m */ + if ((err = mp_mulmod (G, &res, P, &M[1])) != MP_OKAY) { + goto LBL_RES; + } + } else { + mp_set(&res, 1); + if ((err = mp_mod(G, P, &M[1])) != MP_OKAY) { + goto LBL_RES; + } + } + + /* compute the value at M[1<<(winsize-1)] by squaring M[1] (winsize-1) times */ + if ((err = mp_copy (&M[1], &M[1 << (winsize - 1)])) != MP_OKAY) { + goto LBL_RES; + } + + for (x = 0; x < (winsize - 1); x++) { + if ((err = mp_sqr (&M[1 << (winsize - 1)], &M[1 << (winsize - 1)])) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&M[1 << (winsize - 1)], P, mp)) != MP_OKAY) { + goto LBL_RES; + } + } + + /* create upper table */ + for (x = (1 << (winsize - 1)) + 1; x < (1 << winsize); x++) { + if ((err = mp_mul (&M[x - 1], &M[1], &M[x])) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&M[x], P, mp)) != MP_OKAY) { + goto LBL_RES; + } + } + + /* set initial mode and bit cnt */ + mode = 0; + bitcnt = 1; + buf = 0; + digidx = X->used - 1; + bitcpy = 0; + bitbuf = 0; + + for (;;) { + /* grab next digit as required */ + if (--bitcnt == 0) { + /* if digidx == -1 we are out of digits so break */ + if (digidx == -1) { + break; + } + /* read next digit and reset bitcnt */ + buf = X->dp[digidx--]; + bitcnt = (int)DIGIT_BIT; + } + + /* grab the next msb from the exponent */ + y = (mp_digit)(buf >> (DIGIT_BIT - 1)) & 1; + buf <<= (mp_digit)1; + + /* if the bit is zero and mode == 0 then we ignore it + * These represent the leading zero bits before the first 1 bit + * in the exponent. Technically this opt is not required but it + * does lower the # of trivial squaring/reductions used + */ + if (mode == 0 && y == 0) { + continue; + } + + /* if the bit is zero and mode == 1 then we square */ + if (mode == 1 && y == 0) { + if ((err = mp_sqr (&res, &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, mp)) != MP_OKAY) { + goto LBL_RES; + } + continue; + } + + /* else we add it to the window */ + bitbuf |= (y << (winsize - ++bitcpy)); + mode = 2; + + if (bitcpy == winsize) { + /* ok window is filled so square as required and multiply */ + /* square first */ + for (x = 0; x < winsize; x++) { + if ((err = mp_sqr (&res, &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, mp)) != MP_OKAY) { + goto LBL_RES; + } + } + + /* then multiply */ + if ((err = mp_mul (&res, &M[bitbuf], &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, mp)) != MP_OKAY) { + goto LBL_RES; + } + + /* empty window and reset */ + bitcpy = 0; + bitbuf = 0; + mode = 1; + } + } + + /* if bits remain then square/multiply */ + if (mode == 2 && bitcpy > 0) { + /* square then multiply if the bit is set */ + for (x = 0; x < bitcpy; x++) { + if ((err = mp_sqr (&res, &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, mp)) != MP_OKAY) { + goto LBL_RES; + } + + /* get next bit of the window */ + bitbuf <<= 1; + if ((bitbuf & (1 << winsize)) != 0) { + /* then multiply */ + if ((err = mp_mul (&res, &M[1], &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, mp)) != MP_OKAY) { + goto LBL_RES; + } + } + } + } + + if (redmode == 0) { + /* fixup result if Montgomery reduction is used + * recall that any value in a Montgomery system is + * actually multiplied by R mod n. So we have + * to reduce one more time to cancel out the factor + * of R. + */ + if ((err = redux(&res, P, mp)) != MP_OKAY) { + goto LBL_RES; + } + } + + /* swap res with Y */ + mp_exch (&res, Y); + err = MP_OKAY; +LBL_RES:mp_clear (&res); +LBL_M: + mp_clear(&M[1]); + for (x = 1<<(winsize-1); x < (1 << winsize); x++) { + mp_clear (&M[x]); + } + return err; +} +#endif + + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_exptmod_fast.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_exteuclid.c Index: libtommath/bn_mp_exteuclid.c ================================================================== --- /dev/null +++ libtommath/bn_mp_exteuclid.c @@ -0,0 +1,82 @@ +#include +#ifdef BN_MP_EXTEUCLID_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* Extended euclidean algorithm of (a, b) produces + a*u1 + b*u2 = u3 + */ +int mp_exteuclid(mp_int *a, mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3) +{ + mp_int u1,u2,u3,v1,v2,v3,t1,t2,t3,q,tmp; + int err; + + if ((err = mp_init_multi(&u1, &u2, &u3, &v1, &v2, &v3, &t1, &t2, &t3, &q, &tmp, NULL)) != MP_OKAY) { + return err; + } + + /* initialize, (u1,u2,u3) = (1,0,a) */ + mp_set(&u1, 1); + if ((err = mp_copy(a, &u3)) != MP_OKAY) { goto _ERR; } + + /* initialize, (v1,v2,v3) = (0,1,b) */ + mp_set(&v2, 1); + if ((err = mp_copy(b, &v3)) != MP_OKAY) { goto _ERR; } + + /* loop while v3 != 0 */ + while (mp_iszero(&v3) == MP_NO) { + /* q = u3/v3 */ + if ((err = mp_div(&u3, &v3, &q, NULL)) != MP_OKAY) { goto _ERR; } + + /* (t1,t2,t3) = (u1,u2,u3) - (v1,v2,v3)q */ + if ((err = mp_mul(&v1, &q, &tmp)) != MP_OKAY) { goto _ERR; } + if ((err = mp_sub(&u1, &tmp, &t1)) != MP_OKAY) { goto _ERR; } + if ((err = mp_mul(&v2, &q, &tmp)) != MP_OKAY) { goto _ERR; } + if ((err = mp_sub(&u2, &tmp, &t2)) != MP_OKAY) { goto _ERR; } + if ((err = mp_mul(&v3, &q, &tmp)) != MP_OKAY) { goto _ERR; } + if ((err = mp_sub(&u3, &tmp, &t3)) != MP_OKAY) { goto _ERR; } + + /* (u1,u2,u3) = (v1,v2,v3) */ + if ((err = mp_copy(&v1, &u1)) != MP_OKAY) { goto _ERR; } + if ((err = mp_copy(&v2, &u2)) != MP_OKAY) { goto _ERR; } + if ((err = mp_copy(&v3, &u3)) != MP_OKAY) { goto _ERR; } + + /* (v1,v2,v3) = (t1,t2,t3) */ + if ((err = mp_copy(&t1, &v1)) != MP_OKAY) { goto _ERR; } + if ((err = mp_copy(&t2, &v2)) != MP_OKAY) { goto _ERR; } + if ((err = mp_copy(&t3, &v3)) != MP_OKAY) { goto _ERR; } + } + + /* make sure U3 >= 0 */ + if (u3.sign == MP_NEG) { + mp_neg(&u1, &u1); + mp_neg(&u2, &u2); + mp_neg(&u3, &u3); + } + + /* copy result out */ + if (U1 != NULL) { mp_exch(U1, &u1); } + if (U2 != NULL) { mp_exch(U2, &u2); } + if (U3 != NULL) { mp_exch(U3, &u3); } + + err = MP_OKAY; +_ERR: mp_clear_multi(&u1, &u2, &u3, &v1, &v2, &v3, &t1, &t2, &t3, &q, &tmp, NULL); + return err; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_exteuclid.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_fread.c Index: libtommath/bn_mp_fread.c ================================================================== --- /dev/null +++ libtommath/bn_mp_fread.c @@ -0,0 +1,67 @@ +#include +#ifdef BN_MP_FREAD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* read a bigint from a file stream in ASCII */ +int mp_fread(mp_int *a, int radix, FILE *stream) +{ + int err, ch, neg, y; + + /* clear a */ + mp_zero(a); + + /* if first digit is - then set negative */ + ch = fgetc(stream); + if (ch == '-') { + neg = MP_NEG; + ch = fgetc(stream); + } else { + neg = MP_ZPOS; + } + + for (;;) { + /* find y in the radix map */ + for (y = 0; y < radix; y++) { + if (mp_s_rmap[y] == ch) { + break; + } + } + if (y == radix) { + break; + } + + /* shift up and add */ + if ((err = mp_mul_d(a, radix, a)) != MP_OKAY) { + return err; + } + if ((err = mp_add_d(a, y, a)) != MP_OKAY) { + return err; + } + + ch = fgetc(stream); + } + if (mp_cmp_d(a, 0) != MP_EQ) { + a->sign = neg; + } + + return MP_OKAY; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_fread.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_fwrite.c Index: libtommath/bn_mp_fwrite.c ================================================================== --- /dev/null +++ libtommath/bn_mp_fwrite.c @@ -0,0 +1,52 @@ +#include +#ifdef BN_MP_FWRITE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +int mp_fwrite(mp_int *a, int radix, FILE *stream) +{ + char *buf; + int err, len, x; + + if ((err = mp_radix_size(a, radix, &len)) != MP_OKAY) { + return err; + } + + buf = OPT_CAST(char) XMALLOC (len); + if (buf == NULL) { + return MP_MEM; + } + + if ((err = mp_toradix(a, buf, radix)) != MP_OKAY) { + XFREE (buf); + return err; + } + + for (x = 0; x < len; x++) { + if (fputc(buf[x], stream) == EOF) { + XFREE (buf); + return MP_VAL; + } + } + + XFREE (buf); + return MP_OKAY; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_fwrite.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_gcd.c Index: libtommath/bn_mp_gcd.c ================================================================== --- /dev/null +++ libtommath/bn_mp_gcd.c @@ -0,0 +1,113 @@ +#include +#ifdef BN_MP_GCD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* Greatest Common Divisor using the binary method */ +int mp_gcd (mp_int * a, mp_int * b, mp_int * c) +{ + mp_int u, v; + int k, u_lsb, v_lsb, res; + + /* either zero than gcd is the largest */ + if (mp_iszero (a) == 1 && mp_iszero (b) == 0) { + return mp_abs (b, c); + } + if (mp_iszero (a) == 0 && mp_iszero (b) == 1) { + return mp_abs (a, c); + } + + /* optimized. At this point if a == 0 then + * b must equal zero too + */ + if (mp_iszero (a) == 1) { + mp_zero(c); + return MP_OKAY; + } + + /* get copies of a and b we can modify */ + if ((res = mp_init_copy (&u, a)) != MP_OKAY) { + return res; + } + + if ((res = mp_init_copy (&v, b)) != MP_OKAY) { + goto LBL_U; + } + + /* must be positive for the remainder of the algorithm */ + u.sign = v.sign = MP_ZPOS; + + /* B1. Find the common power of two for u and v */ + u_lsb = mp_cnt_lsb(&u); + v_lsb = mp_cnt_lsb(&v); + k = MIN(u_lsb, v_lsb); + + if (k > 0) { + /* divide the power of two out */ + if ((res = mp_div_2d(&u, k, &u, NULL)) != MP_OKAY) { + goto LBL_V; + } + + if ((res = mp_div_2d(&v, k, &v, NULL)) != MP_OKAY) { + goto LBL_V; + } + } + + /* divide any remaining factors of two out */ + if (u_lsb != k) { + if ((res = mp_div_2d(&u, u_lsb - k, &u, NULL)) != MP_OKAY) { + goto LBL_V; + } + } + + if (v_lsb != k) { + if ((res = mp_div_2d(&v, v_lsb - k, &v, NULL)) != MP_OKAY) { + goto LBL_V; + } + } + + while (mp_iszero(&v) == 0) { + /* make sure v is the largest */ + if (mp_cmp_mag(&u, &v) == MP_GT) { + /* swap u and v to make sure v is >= u */ + mp_exch(&u, &v); + } + + /* subtract smallest from largest */ + if ((res = s_mp_sub(&v, &u, &v)) != MP_OKAY) { + goto LBL_V; + } + + /* Divide out all factors of two */ + if ((res = mp_div_2d(&v, mp_cnt_lsb(&v), &v, NULL)) != MP_OKAY) { + goto LBL_V; + } + } + + /* multiply by 2**k which we divided out at the beginning */ + if ((res = mp_mul_2d (&u, k, c)) != MP_OKAY) { + goto LBL_V; + } + c->sign = MP_ZPOS; + res = MP_OKAY; +LBL_V:mp_clear (&u); +LBL_U:mp_clear (&v); + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_gcd.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_get_int.c Index: libtommath/bn_mp_get_int.c ================================================================== --- /dev/null +++ libtommath/bn_mp_get_int.c @@ -0,0 +1,45 @@ +#include +#ifdef BN_MP_GET_INT_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* get the lower 32-bits of an mp_int */ +unsigned long mp_get_int(mp_int * a) +{ + int i; + unsigned long res; + + if (a->used == 0) { + return 0; + } + + /* get number of digits of the lsb we have to read */ + i = MIN(a->used,(int)((sizeof(unsigned long)*CHAR_BIT+DIGIT_BIT-1)/DIGIT_BIT))-1; + + /* get most significant digit of result */ + res = DIGIT(a,i); + + while (--i >= 0) { + res = (res << DIGIT_BIT) | DIGIT(a,i); + } + + /* force result to 32-bits always so it is consistent on non 32-bit platforms */ + return res & 0xFFFFFFFFUL; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_get_int.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_grow.c Index: libtommath/bn_mp_grow.c ================================================================== --- /dev/null +++ libtommath/bn_mp_grow.c @@ -0,0 +1,57 @@ +#include +#ifdef BN_MP_GROW_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* grow as required */ +int mp_grow (mp_int * a, int size) +{ + int i; + mp_digit *tmp; + + /* if the alloc size is smaller alloc more ram */ + if (a->alloc < size) { + /* ensure there are always at least MP_PREC digits extra on top */ + size += (MP_PREC * 2) - (size % MP_PREC); + + /* reallocate the array a->dp + * + * We store the return in a temporary variable + * in case the operation failed we don't want + * to overwrite the dp member of a. + */ + tmp = OPT_CAST(mp_digit) XREALLOC (a->dp, sizeof (mp_digit) * size); + if (tmp == NULL) { + /* reallocation failed but "a" is still valid [can be freed] */ + return MP_MEM; + } + + /* reallocation succeeded so set a->dp */ + a->dp = tmp; + + /* zero excess digits */ + i = a->alloc; + a->alloc = size; + for (; i < a->alloc; i++) { + a->dp[i] = 0; + } + } + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_grow.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_init.c Index: libtommath/bn_mp_init.c ================================================================== --- /dev/null +++ libtommath/bn_mp_init.c @@ -0,0 +1,46 @@ +#include +#ifdef BN_MP_INIT_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* init a new mp_int */ +int mp_init (mp_int * a) +{ + int i; + + /* allocate memory required and clear it */ + a->dp = OPT_CAST(mp_digit) XMALLOC (sizeof (mp_digit) * MP_PREC); + if (a->dp == NULL) { + return MP_MEM; + } + + /* set the digits to zero */ + for (i = 0; i < MP_PREC; i++) { + a->dp[i] = 0; + } + + /* set the used to zero, allocated digits to the default precision + * and sign to positive */ + a->used = 0; + a->alloc = MP_PREC; + a->sign = MP_ZPOS; + + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_init.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_init_copy.c Index: libtommath/bn_mp_init_copy.c ================================================================== --- /dev/null +++ libtommath/bn_mp_init_copy.c @@ -0,0 +1,32 @@ +#include +#ifdef BN_MP_INIT_COPY_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* creates "a" then copies b into it */ +int mp_init_copy (mp_int * a, mp_int * b) +{ + int res; + + if ((res = mp_init (a)) != MP_OKAY) { + return res; + } + return mp_copy (b, a); +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_init_copy.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_init_multi.c Index: libtommath/bn_mp_init_multi.c ================================================================== --- /dev/null +++ libtommath/bn_mp_init_multi.c @@ -0,0 +1,59 @@ +#include +#ifdef BN_MP_INIT_MULTI_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ +#include + +int mp_init_multi(mp_int *mp, ...) +{ + mp_err res = MP_OKAY; /* Assume ok until proven otherwise */ + int n = 0; /* Number of ok inits */ + mp_int* cur_arg = mp; + va_list args; + + va_start(args, mp); /* init args to next argument from caller */ + while (cur_arg != NULL) { + if (mp_init(cur_arg) != MP_OKAY) { + /* Oops - error! Back-track and mp_clear what we already + succeeded in init-ing, then return error. + */ + va_list clean_args; + + /* end the current list */ + va_end(args); + + /* now start cleaning up */ + cur_arg = mp; + va_start(clean_args, mp); + while (n--) { + mp_clear(cur_arg); + cur_arg = va_arg(clean_args, mp_int*); + } + va_end(clean_args); + res = MP_MEM; + break; + } + n++; + cur_arg = va_arg(args, mp_int*); + } + va_end(args); + return res; /* Assumed ok, if error flagged above. */ +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_init_multi.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_init_set.c Index: libtommath/bn_mp_init_set.c ================================================================== --- /dev/null +++ libtommath/bn_mp_init_set.c @@ -0,0 +1,32 @@ +#include +#ifdef BN_MP_INIT_SET_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* initialize and set a digit */ +int mp_init_set (mp_int * a, mp_digit b) +{ + int err; + if ((err = mp_init(a)) != MP_OKAY) { + return err; + } + mp_set(a, b); + return err; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_init_set.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_init_set_int.c Index: libtommath/bn_mp_init_set_int.c ================================================================== --- /dev/null +++ libtommath/bn_mp_init_set_int.c @@ -0,0 +1,31 @@ +#include +#ifdef BN_MP_INIT_SET_INT_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* initialize and set a digit */ +int mp_init_set_int (mp_int * a, unsigned long b) +{ + int err; + if ((err = mp_init(a)) != MP_OKAY) { + return err; + } + return mp_set_int(a, b); +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_init_set_int.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_init_size.c Index: libtommath/bn_mp_init_size.c ================================================================== --- /dev/null +++ libtommath/bn_mp_init_size.c @@ -0,0 +1,48 @@ +#include +#ifdef BN_MP_INIT_SIZE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* init an mp_init for a given size */ +int mp_init_size (mp_int * a, int size) +{ + int x; + + /* pad size so there are always extra digits */ + size += (MP_PREC * 2) - (size % MP_PREC); + + /* alloc mem */ + a->dp = OPT_CAST(mp_digit) XMALLOC (sizeof (mp_digit) * size); + if (a->dp == NULL) { + return MP_MEM; + } + + /* set the members */ + a->used = 0; + a->alloc = size; + a->sign = MP_ZPOS; + + /* zero the digits */ + for (x = 0; x < size; x++) { + a->dp[x] = 0; + } + + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_init_size.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_invmod.c Index: libtommath/bn_mp_invmod.c ================================================================== --- /dev/null +++ libtommath/bn_mp_invmod.c @@ -0,0 +1,43 @@ +#include +#ifdef BN_MP_INVMOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* hac 14.61, pp608 */ +int mp_invmod (mp_int * a, mp_int * b, mp_int * c) +{ + /* b cannot be negative */ + if (b->sign == MP_NEG || mp_iszero(b) == 1) { + return MP_VAL; + } + +#ifdef BN_FAST_MP_INVMOD_C + /* if the modulus is odd we can use a faster routine instead */ + if (mp_isodd (b) == 1) { + return fast_mp_invmod (a, b, c); + } +#endif + +#ifdef BN_MP_INVMOD_SLOW_C + return mp_invmod_slow(a, b, c); +#endif + + return MP_VAL; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_invmod.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_invmod_slow.c Index: libtommath/bn_mp_invmod_slow.c ================================================================== --- /dev/null +++ libtommath/bn_mp_invmod_slow.c @@ -0,0 +1,175 @@ +#include +#ifdef BN_MP_INVMOD_SLOW_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* hac 14.61, pp608 */ +int mp_invmod_slow (mp_int * a, mp_int * b, mp_int * c) +{ + mp_int x, y, u, v, A, B, C, D; + int res; + + /* b cannot be negative */ + if (b->sign == MP_NEG || mp_iszero(b) == 1) { + return MP_VAL; + } + + /* init temps */ + if ((res = mp_init_multi(&x, &y, &u, &v, + &A, &B, &C, &D, NULL)) != MP_OKAY) { + return res; + } + + /* x = a, y = b */ + if ((res = mp_mod(a, b, &x)) != MP_OKAY) { + goto LBL_ERR; + } + if ((res = mp_copy (b, &y)) != MP_OKAY) { + goto LBL_ERR; + } + + /* 2. [modified] if x,y are both even then return an error! */ + if (mp_iseven (&x) == 1 && mp_iseven (&y) == 1) { + res = MP_VAL; + goto LBL_ERR; + } + + /* 3. u=x, v=y, A=1, B=0, C=0,D=1 */ + if ((res = mp_copy (&x, &u)) != MP_OKAY) { + goto LBL_ERR; + } + if ((res = mp_copy (&y, &v)) != MP_OKAY) { + goto LBL_ERR; + } + mp_set (&A, 1); + mp_set (&D, 1); + +top: + /* 4. while u is even do */ + while (mp_iseven (&u) == 1) { + /* 4.1 u = u/2 */ + if ((res = mp_div_2 (&u, &u)) != MP_OKAY) { + goto LBL_ERR; + } + /* 4.2 if A or B is odd then */ + if (mp_isodd (&A) == 1 || mp_isodd (&B) == 1) { + /* A = (A+y)/2, B = (B-x)/2 */ + if ((res = mp_add (&A, &y, &A)) != MP_OKAY) { + goto LBL_ERR; + } + if ((res = mp_sub (&B, &x, &B)) != MP_OKAY) { + goto LBL_ERR; + } + } + /* A = A/2, B = B/2 */ + if ((res = mp_div_2 (&A, &A)) != MP_OKAY) { + goto LBL_ERR; + } + if ((res = mp_div_2 (&B, &B)) != MP_OKAY) { + goto LBL_ERR; + } + } + + /* 5. while v is even do */ + while (mp_iseven (&v) == 1) { + /* 5.1 v = v/2 */ + if ((res = mp_div_2 (&v, &v)) != MP_OKAY) { + goto LBL_ERR; + } + /* 5.2 if C or D is odd then */ + if (mp_isodd (&C) == 1 || mp_isodd (&D) == 1) { + /* C = (C+y)/2, D = (D-x)/2 */ + if ((res = mp_add (&C, &y, &C)) != MP_OKAY) { + goto LBL_ERR; + } + if ((res = mp_sub (&D, &x, &D)) != MP_OKAY) { + goto LBL_ERR; + } + } + /* C = C/2, D = D/2 */ + if ((res = mp_div_2 (&C, &C)) != MP_OKAY) { + goto LBL_ERR; + } + if ((res = mp_div_2 (&D, &D)) != MP_OKAY) { + goto LBL_ERR; + } + } + + /* 6. if u >= v then */ + if (mp_cmp (&u, &v) != MP_LT) { + /* u = u - v, A = A - C, B = B - D */ + if ((res = mp_sub (&u, &v, &u)) != MP_OKAY) { + goto LBL_ERR; + } + + if ((res = mp_sub (&A, &C, &A)) != MP_OKAY) { + goto LBL_ERR; + } + + if ((res = mp_sub (&B, &D, &B)) != MP_OKAY) { + goto LBL_ERR; + } + } else { + /* v - v - u, C = C - A, D = D - B */ + if ((res = mp_sub (&v, &u, &v)) != MP_OKAY) { + goto LBL_ERR; + } + + if ((res = mp_sub (&C, &A, &C)) != MP_OKAY) { + goto LBL_ERR; + } + + if ((res = mp_sub (&D, &B, &D)) != MP_OKAY) { + goto LBL_ERR; + } + } + + /* if not zero goto step 4 */ + if (mp_iszero (&u) == 0) + goto top; + + /* now a = C, b = D, gcd == g*v */ + + /* if v != 1 then there is no inverse */ + if (mp_cmp_d (&v, 1) != MP_EQ) { + res = MP_VAL; + goto LBL_ERR; + } + + /* if its too low */ + while (mp_cmp_d(&C, 0) == MP_LT) { + if ((res = mp_add(&C, b, &C)) != MP_OKAY) { + goto LBL_ERR; + } + } + + /* too big */ + while (mp_cmp_mag(&C, b) != MP_LT) { + if ((res = mp_sub(&C, b, &C)) != MP_OKAY) { + goto LBL_ERR; + } + } + + /* C is now the inverse */ + mp_exch (&C, c); + res = MP_OKAY; +LBL_ERR:mp_clear_multi (&x, &y, &u, &v, &A, &B, &C, &D, NULL); + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_invmod_slow.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_is_square.c Index: libtommath/bn_mp_is_square.c ================================================================== --- /dev/null +++ libtommath/bn_mp_is_square.c @@ -0,0 +1,109 @@ +#include +#ifdef BN_MP_IS_SQUARE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* Check if remainders are possible squares - fast exclude non-squares */ +static const char rem_128[128] = { + 0, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, + 0, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, + 1, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, + 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, + 0, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, + 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, + 1, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, + 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1 +}; + +static const char rem_105[105] = { + 0, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, + 0, 0, 1, 1, 1, 1, 0, 1, 1, 1, 0, 1, 1, 1, 1, + 0, 1, 1, 1, 1, 1, 0, 1, 1, 0, 1, 1, 1, 1, 1, + 1, 0, 1, 1, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, + 0, 1, 1, 1, 0, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, + 1, 1, 1, 1, 0, 1, 0, 1, 1, 0, 0, 1, 1, 1, 1, + 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1 +}; + +/* Store non-zero to ret if arg is square, and zero if not */ +int mp_is_square(mp_int *arg,int *ret) +{ + int res; + mp_digit c; + mp_int t; + unsigned long r; + + /* Default to Non-square :) */ + *ret = MP_NO; + + if (arg->sign == MP_NEG) { + return MP_VAL; + } + + /* digits used? (TSD) */ + if (arg->used == 0) { + return MP_OKAY; + } + + /* First check mod 128 (suppose that DIGIT_BIT is at least 7) */ + if (rem_128[127 & DIGIT(arg,0)] == 1) { + return MP_OKAY; + } + + /* Next check mod 105 (3*5*7) */ + if ((res = mp_mod_d(arg,105,&c)) != MP_OKAY) { + return res; + } + if (rem_105[c] == 1) { + return MP_OKAY; + } + + + if ((res = mp_init_set_int(&t,11L*13L*17L*19L*23L*29L*31L)) != MP_OKAY) { + return res; + } + if ((res = mp_mod(arg,&t,&t)) != MP_OKAY) { + goto ERR; + } + r = mp_get_int(&t); + /* Check for other prime modules, note it's not an ERROR but we must + * free "t" so the easiest way is to goto ERR. We know that res + * is already equal to MP_OKAY from the mp_mod call + */ + if ( (1L<<(r%11)) & 0x5C4L ) goto ERR; + if ( (1L<<(r%13)) & 0x9E4L ) goto ERR; + if ( (1L<<(r%17)) & 0x5CE8L ) goto ERR; + if ( (1L<<(r%19)) & 0x4F50CL ) goto ERR; + if ( (1L<<(r%23)) & 0x7ACCA0L ) goto ERR; + if ( (1L<<(r%29)) & 0xC2EDD0CL ) goto ERR; + if ( (1L<<(r%31)) & 0x6DE2B848L ) goto ERR; + + /* Final check - is sqr(sqrt(arg)) == arg ? */ + if ((res = mp_sqrt(arg,&t)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sqr(&t,&t)) != MP_OKAY) { + goto ERR; + } + + *ret = (mp_cmp_mag(&t,arg) == MP_EQ) ? MP_YES : MP_NO; +ERR:mp_clear(&t); + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_is_square.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_jacobi.c Index: libtommath/bn_mp_jacobi.c ================================================================== --- /dev/null +++ libtommath/bn_mp_jacobi.c @@ -0,0 +1,105 @@ +#include +#ifdef BN_MP_JACOBI_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* computes the jacobi c = (a | n) (or Legendre if n is prime) + * HAC pp. 73 Algorithm 2.149 + */ +int mp_jacobi (mp_int * a, mp_int * p, int *c) +{ + mp_int a1, p1; + int k, s, r, res; + mp_digit residue; + + /* if p <= 0 return MP_VAL */ + if (mp_cmp_d(p, 0) != MP_GT) { + return MP_VAL; + } + + /* step 1. if a == 0, return 0 */ + if (mp_iszero (a) == 1) { + *c = 0; + return MP_OKAY; + } + + /* step 2. if a == 1, return 1 */ + if (mp_cmp_d (a, 1) == MP_EQ) { + *c = 1; + return MP_OKAY; + } + + /* default */ + s = 0; + + /* step 3. write a = a1 * 2**k */ + if ((res = mp_init_copy (&a1, a)) != MP_OKAY) { + return res; + } + + if ((res = mp_init (&p1)) != MP_OKAY) { + goto LBL_A1; + } + + /* divide out larger power of two */ + k = mp_cnt_lsb(&a1); + if ((res = mp_div_2d(&a1, k, &a1, NULL)) != MP_OKAY) { + goto LBL_P1; + } + + /* step 4. if e is even set s=1 */ + if ((k & 1) == 0) { + s = 1; + } else { + /* else set s=1 if p = 1/7 (mod 8) or s=-1 if p = 3/5 (mod 8) */ + residue = p->dp[0] & 7; + + if (residue == 1 || residue == 7) { + s = 1; + } else if (residue == 3 || residue == 5) { + s = -1; + } + } + + /* step 5. if p == 3 (mod 4) *and* a1 == 3 (mod 4) then s = -s */ + if ( ((p->dp[0] & 3) == 3) && ((a1.dp[0] & 3) == 3)) { + s = -s; + } + + /* if a1 == 1 we're done */ + if (mp_cmp_d (&a1, 1) == MP_EQ) { + *c = s; + } else { + /* n1 = n mod a1 */ + if ((res = mp_mod (p, &a1, &p1)) != MP_OKAY) { + goto LBL_P1; + } + if ((res = mp_jacobi (&p1, &a1, &r)) != MP_OKAY) { + goto LBL_P1; + } + *c = s * r; + } + + /* done */ + res = MP_OKAY; +LBL_P1:mp_clear (&p1); +LBL_A1:mp_clear (&a1); + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_jacobi.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_karatsuba_mul.c Index: libtommath/bn_mp_karatsuba_mul.c ================================================================== --- /dev/null +++ libtommath/bn_mp_karatsuba_mul.c @@ -0,0 +1,167 @@ +#include +#ifdef BN_MP_KARATSUBA_MUL_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* c = |a| * |b| using Karatsuba Multiplication using + * three half size multiplications + * + * Let B represent the radix [e.g. 2**DIGIT_BIT] and + * let n represent half of the number of digits in + * the min(a,b) + * + * a = a1 * B**n + a0 + * b = b1 * B**n + b0 + * + * Then, a * b => + a1b1 * B**2n + ((a1 + a0)(b1 + b0) - (a0b0 + a1b1)) * B + a0b0 + * + * Note that a1b1 and a0b0 are used twice and only need to be + * computed once. So in total three half size (half # of + * digit) multiplications are performed, a0b0, a1b1 and + * (a1+b1)(a0+b0) + * + * Note that a multiplication of half the digits requires + * 1/4th the number of single precision multiplications so in + * total after one call 25% of the single precision multiplications + * are saved. Note also that the call to mp_mul can end up back + * in this function if the a0, a1, b0, or b1 are above the threshold. + * This is known as divide-and-conquer and leads to the famous + * O(N**lg(3)) or O(N**1.584) work which is asymptopically lower than + * the standard O(N**2) that the baseline/comba methods use. + * Generally though the overhead of this method doesn't pay off + * until a certain size (N ~ 80) is reached. + */ +int mp_karatsuba_mul (mp_int * a, mp_int * b, mp_int * c) +{ + mp_int x0, x1, y0, y1, t1, x0y0, x1y1; + int B, err; + + /* default the return code to an error */ + err = MP_MEM; + + /* min # of digits */ + B = MIN (a->used, b->used); + + /* now divide in two */ + B = B >> 1; + + /* init copy all the temps */ + if (mp_init_size (&x0, B) != MP_OKAY) + goto ERR; + if (mp_init_size (&x1, a->used - B) != MP_OKAY) + goto X0; + if (mp_init_size (&y0, B) != MP_OKAY) + goto X1; + if (mp_init_size (&y1, b->used - B) != MP_OKAY) + goto Y0; + + /* init temps */ + if (mp_init_size (&t1, B * 2) != MP_OKAY) + goto Y1; + if (mp_init_size (&x0y0, B * 2) != MP_OKAY) + goto T1; + if (mp_init_size (&x1y1, B * 2) != MP_OKAY) + goto X0Y0; + + /* now shift the digits */ + x0.used = y0.used = B; + x1.used = a->used - B; + y1.used = b->used - B; + + { + register int x; + register mp_digit *tmpa, *tmpb, *tmpx, *tmpy; + + /* we copy the digits directly instead of using higher level functions + * since we also need to shift the digits + */ + tmpa = a->dp; + tmpb = b->dp; + + tmpx = x0.dp; + tmpy = y0.dp; + for (x = 0; x < B; x++) { + *tmpx++ = *tmpa++; + *tmpy++ = *tmpb++; + } + + tmpx = x1.dp; + for (x = B; x < a->used; x++) { + *tmpx++ = *tmpa++; + } + + tmpy = y1.dp; + for (x = B; x < b->used; x++) { + *tmpy++ = *tmpb++; + } + } + + /* only need to clamp the lower words since by definition the + * upper words x1/y1 must have a known number of digits + */ + mp_clamp (&x0); + mp_clamp (&y0); + + /* now calc the products x0y0 and x1y1 */ + /* after this x0 is no longer required, free temp [x0==t2]! */ + if (mp_mul (&x0, &y0, &x0y0) != MP_OKAY) + goto X1Y1; /* x0y0 = x0*y0 */ + if (mp_mul (&x1, &y1, &x1y1) != MP_OKAY) + goto X1Y1; /* x1y1 = x1*y1 */ + + /* now calc x1+x0 and y1+y0 */ + if (s_mp_add (&x1, &x0, &t1) != MP_OKAY) + goto X1Y1; /* t1 = x1 - x0 */ + if (s_mp_add (&y1, &y0, &x0) != MP_OKAY) + goto X1Y1; /* t2 = y1 - y0 */ + if (mp_mul (&t1, &x0, &t1) != MP_OKAY) + goto X1Y1; /* t1 = (x1 + x0) * (y1 + y0) */ + + /* add x0y0 */ + if (mp_add (&x0y0, &x1y1, &x0) != MP_OKAY) + goto X1Y1; /* t2 = x0y0 + x1y1 */ + if (s_mp_sub (&t1, &x0, &t1) != MP_OKAY) + goto X1Y1; /* t1 = (x1+x0)*(y1+y0) - (x1y1 + x0y0) */ + + /* shift by B */ + if (mp_lshd (&t1, B) != MP_OKAY) + goto X1Y1; /* t1 = (x0y0 + x1y1 - (x1-x0)*(y1-y0))< +#ifdef BN_MP_KARATSUBA_SQR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* Karatsuba squaring, computes b = a*a using three + * half size squarings + * + * See comments of karatsuba_mul for details. It + * is essentially the same algorithm but merely + * tuned to perform recursive squarings. + */ +int mp_karatsuba_sqr (mp_int * a, mp_int * b) +{ + mp_int x0, x1, t1, t2, x0x0, x1x1; + int B, err; + + err = MP_MEM; + + /* min # of digits */ + B = a->used; + + /* now divide in two */ + B = B >> 1; + + /* init copy all the temps */ + if (mp_init_size (&x0, B) != MP_OKAY) + goto ERR; + if (mp_init_size (&x1, a->used - B) != MP_OKAY) + goto X0; + + /* init temps */ + if (mp_init_size (&t1, a->used * 2) != MP_OKAY) + goto X1; + if (mp_init_size (&t2, a->used * 2) != MP_OKAY) + goto T1; + if (mp_init_size (&x0x0, B * 2) != MP_OKAY) + goto T2; + if (mp_init_size (&x1x1, (a->used - B) * 2) != MP_OKAY) + goto X0X0; + + { + register int x; + register mp_digit *dst, *src; + + src = a->dp; + + /* now shift the digits */ + dst = x0.dp; + for (x = 0; x < B; x++) { + *dst++ = *src++; + } + + dst = x1.dp; + for (x = B; x < a->used; x++) { + *dst++ = *src++; + } + } + + x0.used = B; + x1.used = a->used - B; + + mp_clamp (&x0); + + /* now calc the products x0*x0 and x1*x1 */ + if (mp_sqr (&x0, &x0x0) != MP_OKAY) + goto X1X1; /* x0x0 = x0*x0 */ + if (mp_sqr (&x1, &x1x1) != MP_OKAY) + goto X1X1; /* x1x1 = x1*x1 */ + + /* now calc (x1+x0)**2 */ + if (s_mp_add (&x1, &x0, &t1) != MP_OKAY) + goto X1X1; /* t1 = x1 - x0 */ + if (mp_sqr (&t1, &t1) != MP_OKAY) + goto X1X1; /* t1 = (x1 - x0) * (x1 - x0) */ + + /* add x0y0 */ + if (s_mp_add (&x0x0, &x1x1, &t2) != MP_OKAY) + goto X1X1; /* t2 = x0x0 + x1x1 */ + if (s_mp_sub (&t1, &t2, &t1) != MP_OKAY) + goto X1X1; /* t1 = (x1+x0)**2 - (x0x0 + x1x1) */ + + /* shift by B */ + if (mp_lshd (&t1, B) != MP_OKAY) + goto X1X1; /* t1 = (x0x0 + x1x1 - (x1-x0)*(x1-x0))< +#ifdef BN_MP_LCM_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* computes least common multiple as |a*b|/(a, b) */ +int mp_lcm (mp_int * a, mp_int * b, mp_int * c) +{ + int res; + mp_int t1, t2; + + + if ((res = mp_init_multi (&t1, &t2, NULL)) != MP_OKAY) { + return res; + } + + /* t1 = get the GCD of the two inputs */ + if ((res = mp_gcd (a, b, &t1)) != MP_OKAY) { + goto LBL_T; + } + + /* divide the smallest by the GCD */ + if (mp_cmp_mag(a, b) == MP_LT) { + /* store quotient in t2 such that t2 * b is the LCM */ + if ((res = mp_div(a, &t1, &t2, NULL)) != MP_OKAY) { + goto LBL_T; + } + res = mp_mul(b, &t2, c); + } else { + /* store quotient in t2 such that t2 * a is the LCM */ + if ((res = mp_div(b, &t1, &t2, NULL)) != MP_OKAY) { + goto LBL_T; + } + res = mp_mul(a, &t2, c); + } + + /* fix the sign to positive */ + c->sign = MP_ZPOS; + +LBL_T: + mp_clear_multi (&t1, &t2, NULL); + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_lcm.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_lshd.c Index: libtommath/bn_mp_lshd.c ================================================================== --- /dev/null +++ libtommath/bn_mp_lshd.c @@ -0,0 +1,67 @@ +#include +#ifdef BN_MP_LSHD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* shift left a certain amount of digits */ +int mp_lshd (mp_int * a, int b) +{ + int x, res; + + /* if its less than zero return */ + if (b <= 0) { + return MP_OKAY; + } + + /* grow to fit the new digits */ + if (a->alloc < a->used + b) { + if ((res = mp_grow (a, a->used + b)) != MP_OKAY) { + return res; + } + } + + { + register mp_digit *top, *bottom; + + /* increment the used by the shift amount then copy upwards */ + a->used += b; + + /* top */ + top = a->dp + a->used - 1; + + /* base */ + bottom = a->dp + a->used - 1 - b; + + /* much like mp_rshd this is implemented using a sliding window + * except the window goes the otherway around. Copying from + * the bottom to the top. see bn_mp_rshd.c for more info. + */ + for (x = a->used - 1; x >= b; x--) { + *top-- = *bottom--; + } + + /* zero the lower digits */ + top = a->dp; + for (x = 0; x < b; x++) { + *top++ = 0; + } + } + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_lshd.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_mod.c Index: libtommath/bn_mp_mod.c ================================================================== --- /dev/null +++ libtommath/bn_mp_mod.c @@ -0,0 +1,48 @@ +#include +#ifdef BN_MP_MOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* c = a mod b, 0 <= c < b */ +int +mp_mod (mp_int * a, mp_int * b, mp_int * c) +{ + mp_int t; + int res; + + if ((res = mp_init (&t)) != MP_OKAY) { + return res; + } + + if ((res = mp_div (a, b, NULL, &t)) != MP_OKAY) { + mp_clear (&t); + return res; + } + + if (t.sign != b->sign) { + res = mp_add (b, &t, c); + } else { + res = MP_OKAY; + mp_exch (&t, c); + } + + mp_clear (&t); + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mod.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_mod_2d.c Index: libtommath/bn_mp_mod_2d.c ================================================================== --- /dev/null +++ libtommath/bn_mp_mod_2d.c @@ -0,0 +1,55 @@ +#include +#ifdef BN_MP_MOD_2D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* calc a value mod 2**b */ +int +mp_mod_2d (mp_int * a, int b, mp_int * c) +{ + int x, res; + + /* if b is <= 0 then zero the int */ + if (b <= 0) { + mp_zero (c); + return MP_OKAY; + } + + /* if the modulus is larger than the value than return */ + if (b >= (int) (a->used * DIGIT_BIT)) { + res = mp_copy (a, c); + return res; + } + + /* copy */ + if ((res = mp_copy (a, c)) != MP_OKAY) { + return res; + } + + /* zero digits above the last digit of the modulus */ + for (x = (b / DIGIT_BIT) + ((b % DIGIT_BIT) == 0 ? 0 : 1); x < c->used; x++) { + c->dp[x] = 0; + } + /* clear the digit that is not completely outside/inside the modulus */ + c->dp[b / DIGIT_BIT] &= + (mp_digit) ((((mp_digit) 1) << (((mp_digit) b) % DIGIT_BIT)) - ((mp_digit) 1)); + mp_clamp (c); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mod_2d.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_mod_d.c Index: libtommath/bn_mp_mod_d.c ================================================================== --- /dev/null +++ libtommath/bn_mp_mod_d.c @@ -0,0 +1,27 @@ +#include +#ifdef BN_MP_MOD_D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +int +mp_mod_d (mp_int * a, mp_digit b, mp_digit * c) +{ + return mp_div_d(a, b, NULL, c); +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mod_d.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_montgomery_calc_normalization.c Index: libtommath/bn_mp_montgomery_calc_normalization.c ================================================================== --- /dev/null +++ libtommath/bn_mp_montgomery_calc_normalization.c @@ -0,0 +1,59 @@ +#include +#ifdef BN_MP_MONTGOMERY_CALC_NORMALIZATION_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* + * shifts with subtractions when the result is greater than b. + * + * The method is slightly modified to shift B unconditionally upto just under + * the leading bit of b. This saves alot of multiple precision shifting. + */ +int mp_montgomery_calc_normalization (mp_int * a, mp_int * b) +{ + int x, bits, res; + + /* how many bits of last digit does b use */ + bits = mp_count_bits (b) % DIGIT_BIT; + + if (b->used > 1) { + if ((res = mp_2expt (a, (b->used - 1) * DIGIT_BIT + bits - 1)) != MP_OKAY) { + return res; + } + } else { + mp_set(a, 1); + bits = 1; + } + + + /* now compute C = A * B mod b */ + for (x = bits - 1; x < (int)DIGIT_BIT; x++) { + if ((res = mp_mul_2 (a, a)) != MP_OKAY) { + return res; + } + if (mp_cmp_mag (a, b) != MP_LT) { + if ((res = s_mp_sub (a, b, a)) != MP_OKAY) { + return res; + } + } + } + + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_montgomery_calc_normalization.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_montgomery_reduce.c Index: libtommath/bn_mp_montgomery_reduce.c ================================================================== --- /dev/null +++ libtommath/bn_mp_montgomery_reduce.c @@ -0,0 +1,118 @@ +#include +#ifdef BN_MP_MONTGOMERY_REDUCE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* computes xR**-1 == x (mod N) via Montgomery Reduction */ +int +mp_montgomery_reduce (mp_int * x, mp_int * n, mp_digit rho) +{ + int ix, res, digs; + mp_digit mu; + + /* can the fast reduction [comba] method be used? + * + * Note that unlike in mul you're safely allowed *less* + * than the available columns [255 per default] since carries + * are fixed up in the inner loop. + */ + digs = n->used * 2 + 1; + if ((digs < MP_WARRAY) && + n->used < + (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) { + return fast_mp_montgomery_reduce (x, n, rho); + } + + /* grow the input as required */ + if (x->alloc < digs) { + if ((res = mp_grow (x, digs)) != MP_OKAY) { + return res; + } + } + x->used = digs; + + for (ix = 0; ix < n->used; ix++) { + /* mu = ai * rho mod b + * + * The value of rho must be precalculated via + * montgomery_setup() such that + * it equals -1/n0 mod b this allows the + * following inner loop to reduce the + * input one digit at a time + */ + mu = (mp_digit) (((mp_word)x->dp[ix]) * ((mp_word)rho) & MP_MASK); + + /* a = a + mu * m * b**i */ + { + register int iy; + register mp_digit *tmpn, *tmpx, u; + register mp_word r; + + /* alias for digits of the modulus */ + tmpn = n->dp; + + /* alias for the digits of x [the input] */ + tmpx = x->dp + ix; + + /* set the carry to zero */ + u = 0; + + /* Multiply and add in place */ + for (iy = 0; iy < n->used; iy++) { + /* compute product and sum */ + r = ((mp_word)mu) * ((mp_word)*tmpn++) + + ((mp_word) u) + ((mp_word) * tmpx); + + /* get carry */ + u = (mp_digit)(r >> ((mp_word) DIGIT_BIT)); + + /* fix digit */ + *tmpx++ = (mp_digit)(r & ((mp_word) MP_MASK)); + } + /* At this point the ix'th digit of x should be zero */ + + + /* propagate carries upwards as required*/ + while (u) { + *tmpx += u; + u = *tmpx >> DIGIT_BIT; + *tmpx++ &= MP_MASK; + } + } + } + + /* at this point the n.used'th least + * significant digits of x are all zero + * which means we can shift x to the + * right by n.used digits and the + * residue is unchanged. + */ + + /* x = x/b**n.used */ + mp_clamp(x); + mp_rshd (x, n->used); + + /* if x >= n then x = x - n */ + if (mp_cmp_mag (x, n) != MP_LT) { + return s_mp_sub (x, n, x); + } + + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_montgomery_reduce.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_montgomery_setup.c Index: libtommath/bn_mp_montgomery_setup.c ================================================================== --- /dev/null +++ libtommath/bn_mp_montgomery_setup.c @@ -0,0 +1,59 @@ +#include +#ifdef BN_MP_MONTGOMERY_SETUP_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* setups the montgomery reduction stuff */ +int +mp_montgomery_setup (mp_int * n, mp_digit * rho) +{ + mp_digit x, b; + +/* fast inversion mod 2**k + * + * Based on the fact that + * + * XA = 1 (mod 2**n) => (X(2-XA)) A = 1 (mod 2**2n) + * => 2*X*A - X*X*A*A = 1 + * => 2*(1) - (1) = 1 + */ + b = n->dp[0]; + + if ((b & 1) == 0) { + return MP_VAL; + } + + x = (((b + 2) & 4) << 1) + b; /* here x*a==1 mod 2**4 */ + x *= 2 - b * x; /* here x*a==1 mod 2**8 */ +#if !defined(MP_8BIT) + x *= 2 - b * x; /* here x*a==1 mod 2**16 */ +#endif +#if defined(MP_64BIT) || !(defined(MP_8BIT) || defined(MP_16BIT)) + x *= 2 - b * x; /* here x*a==1 mod 2**32 */ +#endif +#ifdef MP_64BIT + x *= 2 - b * x; /* here x*a==1 mod 2**64 */ +#endif + + /* rho = -1/m mod b */ + *rho = (((mp_word)1 << ((mp_word) DIGIT_BIT)) - x) & MP_MASK; + + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_montgomery_setup.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_mul.c Index: libtommath/bn_mp_mul.c ================================================================== --- /dev/null +++ libtommath/bn_mp_mul.c @@ -0,0 +1,66 @@ +#include +#ifdef BN_MP_MUL_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* high level multiplication (handles sign) */ +int mp_mul (mp_int * a, mp_int * b, mp_int * c) +{ + int res, neg; + neg = (a->sign == b->sign) ? MP_ZPOS : MP_NEG; + + /* use Toom-Cook? */ +#ifdef BN_MP_TOOM_MUL_C + if (MIN (a->used, b->used) >= TOOM_MUL_CUTOFF) { + res = mp_toom_mul(a, b, c); + } else +#endif +#ifdef BN_MP_KARATSUBA_MUL_C + /* use Karatsuba? */ + if (MIN (a->used, b->used) >= KARATSUBA_MUL_CUTOFF) { + res = mp_karatsuba_mul (a, b, c); + } else +#endif + { + /* can we use the fast multiplier? + * + * The fast multiplier can be used if the output will + * have less than MP_WARRAY digits and the number of + * digits won't affect carry propagation + */ + int digs = a->used + b->used + 1; + +#ifdef BN_FAST_S_MP_MUL_DIGS_C + if ((digs < MP_WARRAY) && + MIN(a->used, b->used) <= + (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) { + res = fast_s_mp_mul_digs (a, b, c, digs); + } else +#endif +#ifdef BN_S_MP_MUL_DIGS_C + res = s_mp_mul (a, b, c); /* uses s_mp_mul_digs */ +#else + res = MP_VAL; +#endif + + } + c->sign = (c->used > 0) ? neg : MP_ZPOS; + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mul.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_mul_2.c Index: libtommath/bn_mp_mul_2.c ================================================================== --- /dev/null +++ libtommath/bn_mp_mul_2.c @@ -0,0 +1,82 @@ +#include +#ifdef BN_MP_MUL_2_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* b = a*2 */ +int mp_mul_2(mp_int * a, mp_int * b) +{ + int x, res, oldused; + + /* grow to accomodate result */ + if (b->alloc < a->used + 1) { + if ((res = mp_grow (b, a->used + 1)) != MP_OKAY) { + return res; + } + } + + oldused = b->used; + b->used = a->used; + + { + register mp_digit r, rr, *tmpa, *tmpb; + + /* alias for source */ + tmpa = a->dp; + + /* alias for dest */ + tmpb = b->dp; + + /* carry */ + r = 0; + for (x = 0; x < a->used; x++) { + + /* get what will be the *next* carry bit from the + * MSB of the current digit + */ + rr = *tmpa >> ((mp_digit)(DIGIT_BIT - 1)); + + /* now shift up this digit, add in the carry [from the previous] */ + *tmpb++ = ((*tmpa++ << ((mp_digit)1)) | r) & MP_MASK; + + /* copy the carry that would be from the source + * digit into the next iteration + */ + r = rr; + } + + /* new leading digit? */ + if (r != 0) { + /* add a MSB which is always 1 at this point */ + *tmpb = 1; + ++(b->used); + } + + /* now zero any excess digits on the destination + * that we didn't write to + */ + tmpb = b->dp + b->used; + for (x = b->used; x < oldused; x++) { + *tmpb++ = 0; + } + } + b->sign = a->sign; + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mul_2.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_mul_2d.c Index: libtommath/bn_mp_mul_2d.c ================================================================== --- /dev/null +++ libtommath/bn_mp_mul_2d.c @@ -0,0 +1,85 @@ +#include +#ifdef BN_MP_MUL_2D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* shift left by a certain bit count */ +int mp_mul_2d (mp_int * a, int b, mp_int * c) +{ + mp_digit d; + int res; + + /* copy */ + if (a != c) { + if ((res = mp_copy (a, c)) != MP_OKAY) { + return res; + } + } + + if (c->alloc < (int)(c->used + b/DIGIT_BIT + 1)) { + if ((res = mp_grow (c, c->used + b / DIGIT_BIT + 1)) != MP_OKAY) { + return res; + } + } + + /* shift by as many digits in the bit count */ + if (b >= (int)DIGIT_BIT) { + if ((res = mp_lshd (c, b / DIGIT_BIT)) != MP_OKAY) { + return res; + } + } + + /* shift any bit count < DIGIT_BIT */ + d = (mp_digit) (b % DIGIT_BIT); + if (d != 0) { + register mp_digit *tmpc, shift, mask, r, rr; + register int x; + + /* bitmask for carries */ + mask = (((mp_digit)1) << d) - 1; + + /* shift for msbs */ + shift = DIGIT_BIT - d; + + /* alias */ + tmpc = c->dp; + + /* carry */ + r = 0; + for (x = 0; x < c->used; x++) { + /* get the higher bits of the current word */ + rr = (*tmpc >> shift) & mask; + + /* shift the current word and OR in the carry */ + *tmpc = ((*tmpc << d) | r) & MP_MASK; + ++tmpc; + + /* set the carry to the carry bits of the current word */ + r = rr; + } + + /* set final carry */ + if (r != 0) { + c->dp[(c->used)++] = r; + } + } + mp_clamp (c); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mul_2d.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_mul_d.c Index: libtommath/bn_mp_mul_d.c ================================================================== --- /dev/null +++ libtommath/bn_mp_mul_d.c @@ -0,0 +1,79 @@ +#include +#ifdef BN_MP_MUL_D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* multiply by a digit */ +int +mp_mul_d (mp_int * a, mp_digit b, mp_int * c) +{ + mp_digit u, *tmpa, *tmpc; + mp_word r; + int ix, res, olduse; + + /* make sure c is big enough to hold a*b */ + if (c->alloc < a->used + 1) { + if ((res = mp_grow (c, a->used + 1)) != MP_OKAY) { + return res; + } + } + + /* get the original destinations used count */ + olduse = c->used; + + /* set the sign */ + c->sign = a->sign; + + /* alias for a->dp [source] */ + tmpa = a->dp; + + /* alias for c->dp [dest] */ + tmpc = c->dp; + + /* zero carry */ + u = 0; + + /* compute columns */ + for (ix = 0; ix < a->used; ix++) { + /* compute product and carry sum for this term */ + r = ((mp_word) u) + ((mp_word)*tmpa++) * ((mp_word)b); + + /* mask off higher bits to get a single digit */ + *tmpc++ = (mp_digit) (r & ((mp_word) MP_MASK)); + + /* send carry into next iteration */ + u = (mp_digit) (r >> ((mp_word) DIGIT_BIT)); + } + + /* store final carry [if any] and increment ix offset */ + *tmpc++ = u; + ++ix; + + /* now zero digits above the top */ + while (ix++ < olduse) { + *tmpc++ = 0; + } + + /* set used count */ + c->used = a->used + 1; + mp_clamp(c); + + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mul_d.c,v $ */ +/* $Revision: 1.1.1.1.2.3 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_mulmod.c Index: libtommath/bn_mp_mulmod.c ================================================================== --- /dev/null +++ libtommath/bn_mp_mulmod.c @@ -0,0 +1,40 @@ +#include +#ifdef BN_MP_MULMOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* d = a * b (mod c) */ +int mp_mulmod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) +{ + int res; + mp_int t; + + if ((res = mp_init (&t)) != MP_OKAY) { + return res; + } + + if ((res = mp_mul (a, b, &t)) != MP_OKAY) { + mp_clear (&t); + return res; + } + res = mp_mod (&t, c, d); + mp_clear (&t); + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mulmod.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_n_root.c Index: libtommath/bn_mp_n_root.c ================================================================== --- /dev/null +++ libtommath/bn_mp_n_root.c @@ -0,0 +1,132 @@ +#include +#ifdef BN_MP_N_ROOT_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* find the n'th root of an integer + * + * Result found such that (c)**b <= a and (c+1)**b > a + * + * This algorithm uses Newton's approximation + * x[i+1] = x[i] - f(x[i])/f'(x[i]) + * which will find the root in log(N) time where + * each step involves a fair bit. This is not meant to + * find huge roots [square and cube, etc]. + */ +int mp_n_root (mp_int * a, mp_digit b, mp_int * c) +{ + mp_int t1, t2, t3; + int res, neg; + + /* input must be positive if b is even */ + if ((b & 1) == 0 && a->sign == MP_NEG) { + return MP_VAL; + } + + if ((res = mp_init (&t1)) != MP_OKAY) { + return res; + } + + if ((res = mp_init (&t2)) != MP_OKAY) { + goto LBL_T1; + } + + if ((res = mp_init (&t3)) != MP_OKAY) { + goto LBL_T2; + } + + /* if a is negative fudge the sign but keep track */ + neg = a->sign; + a->sign = MP_ZPOS; + + /* t2 = 2 */ + mp_set (&t2, 2); + + do { + /* t1 = t2 */ + if ((res = mp_copy (&t2, &t1)) != MP_OKAY) { + goto LBL_T3; + } + + /* t2 = t1 - ((t1**b - a) / (b * t1**(b-1))) */ + + /* t3 = t1**(b-1) */ + if ((res = mp_expt_d (&t1, b - 1, &t3)) != MP_OKAY) { + goto LBL_T3; + } + + /* numerator */ + /* t2 = t1**b */ + if ((res = mp_mul (&t3, &t1, &t2)) != MP_OKAY) { + goto LBL_T3; + } + + /* t2 = t1**b - a */ + if ((res = mp_sub (&t2, a, &t2)) != MP_OKAY) { + goto LBL_T3; + } + + /* denominator */ + /* t3 = t1**(b-1) * b */ + if ((res = mp_mul_d (&t3, b, &t3)) != MP_OKAY) { + goto LBL_T3; + } + + /* t3 = (t1**b - a)/(b * t1**(b-1)) */ + if ((res = mp_div (&t2, &t3, &t3, NULL)) != MP_OKAY) { + goto LBL_T3; + } + + if ((res = mp_sub (&t1, &t3, &t2)) != MP_OKAY) { + goto LBL_T3; + } + } while (mp_cmp (&t1, &t2) != MP_EQ); + + /* result can be off by a few so check */ + for (;;) { + if ((res = mp_expt_d (&t1, b, &t2)) != MP_OKAY) { + goto LBL_T3; + } + + if (mp_cmp (&t2, a) == MP_GT) { + if ((res = mp_sub_d (&t1, 1, &t1)) != MP_OKAY) { + goto LBL_T3; + } + } else { + break; + } + } + + /* reset the sign of a first */ + a->sign = neg; + + /* set the result */ + mp_exch (&t1, c); + + /* set the sign of the result */ + c->sign = neg; + + res = MP_OKAY; + +LBL_T3:mp_clear (&t3); +LBL_T2:mp_clear (&t2); +LBL_T1:mp_clear (&t1); + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_n_root.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_neg.c Index: libtommath/bn_mp_neg.c ================================================================== --- /dev/null +++ libtommath/bn_mp_neg.c @@ -0,0 +1,40 @@ +#include +#ifdef BN_MP_NEG_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* b = -a */ +int mp_neg (mp_int * a, mp_int * b) +{ + int res; + if (a != b) { + if ((res = mp_copy (a, b)) != MP_OKAY) { + return res; + } + } + + if (mp_iszero(b) != MP_YES) { + b->sign = (a->sign == MP_ZPOS) ? MP_NEG : MP_ZPOS; + } else { + b->sign = MP_ZPOS; + } + + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_neg.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_or.c Index: libtommath/bn_mp_or.c ================================================================== --- /dev/null +++ libtommath/bn_mp_or.c @@ -0,0 +1,50 @@ +#include +#ifdef BN_MP_OR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* OR two ints together */ +int mp_or (mp_int * a, mp_int * b, mp_int * c) +{ + int res, ix, px; + mp_int t, *x; + + if (a->used > b->used) { + if ((res = mp_init_copy (&t, a)) != MP_OKAY) { + return res; + } + px = b->used; + x = b; + } else { + if ((res = mp_init_copy (&t, b)) != MP_OKAY) { + return res; + } + px = a->used; + x = a; + } + + for (ix = 0; ix < px; ix++) { + t.dp[ix] |= x->dp[ix]; + } + mp_clamp (&t); + mp_exch (c, &t); + mp_clear (&t); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_or.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_prime_fermat.c Index: libtommath/bn_mp_prime_fermat.c ================================================================== --- /dev/null +++ libtommath/bn_mp_prime_fermat.c @@ -0,0 +1,62 @@ +#include +#ifdef BN_MP_PRIME_FERMAT_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* performs one Fermat test. + * + * If "a" were prime then b**a == b (mod a) since the order of + * the multiplicative sub-group would be phi(a) = a-1. That means + * it would be the same as b**(a mod (a-1)) == b**1 == b (mod a). + * + * Sets result to 1 if the congruence holds, or zero otherwise. + */ +int mp_prime_fermat (mp_int * a, mp_int * b, int *result) +{ + mp_int t; + int err; + + /* default to composite */ + *result = MP_NO; + + /* ensure b > 1 */ + if (mp_cmp_d(b, 1) != MP_GT) { + return MP_VAL; + } + + /* init t */ + if ((err = mp_init (&t)) != MP_OKAY) { + return err; + } + + /* compute t = b**a mod a */ + if ((err = mp_exptmod (b, a, a, &t)) != MP_OKAY) { + goto LBL_T; + } + + /* is it equal to b? */ + if (mp_cmp (&t, b) == MP_EQ) { + *result = MP_YES; + } + + err = MP_OKAY; +LBL_T:mp_clear (&t); + return err; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_fermat.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_prime_is_divisible.c Index: libtommath/bn_mp_prime_is_divisible.c ================================================================== --- /dev/null +++ libtommath/bn_mp_prime_is_divisible.c @@ -0,0 +1,50 @@ +#include +#ifdef BN_MP_PRIME_IS_DIVISIBLE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* determines if an integers is divisible by one + * of the first PRIME_SIZE primes or not + * + * sets result to 0 if not, 1 if yes + */ +int mp_prime_is_divisible (mp_int * a, int *result) +{ + int err, ix; + mp_digit res; + + /* default to not */ + *result = MP_NO; + + for (ix = 0; ix < PRIME_SIZE; ix++) { + /* what is a mod LBL_prime_tab[ix] */ + if ((err = mp_mod_d (a, ltm_prime_tab[ix], &res)) != MP_OKAY) { + return err; + } + + /* is the residue zero? */ + if (res == 0) { + *result = MP_YES; + return MP_OKAY; + } + } + + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_is_divisible.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_prime_is_prime.c Index: libtommath/bn_mp_prime_is_prime.c ================================================================== --- /dev/null +++ libtommath/bn_mp_prime_is_prime.c @@ -0,0 +1,83 @@ +#include +#ifdef BN_MP_PRIME_IS_PRIME_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* performs a variable number of rounds of Miller-Rabin + * + * Probability of error after t rounds is no more than + + * + * Sets result to 1 if probably prime, 0 otherwise + */ +int mp_prime_is_prime (mp_int * a, int t, int *result) +{ + mp_int b; + int ix, err, res; + + /* default to no */ + *result = MP_NO; + + /* valid value of t? */ + if (t <= 0 || t > PRIME_SIZE) { + return MP_VAL; + } + + /* is the input equal to one of the primes in the table? */ + for (ix = 0; ix < PRIME_SIZE; ix++) { + if (mp_cmp_d(a, ltm_prime_tab[ix]) == MP_EQ) { + *result = 1; + return MP_OKAY; + } + } + + /* first perform trial division */ + if ((err = mp_prime_is_divisible (a, &res)) != MP_OKAY) { + return err; + } + + /* return if it was trivially divisible */ + if (res == MP_YES) { + return MP_OKAY; + } + + /* now perform the miller-rabin rounds */ + if ((err = mp_init (&b)) != MP_OKAY) { + return err; + } + + for (ix = 0; ix < t; ix++) { + /* set the prime */ + mp_set (&b, ltm_prime_tab[ix]); + + if ((err = mp_prime_miller_rabin (a, &b, &res)) != MP_OKAY) { + goto LBL_B; + } + + if (res == MP_NO) { + goto LBL_B; + } + } + + /* passed the test */ + *result = MP_YES; +LBL_B:mp_clear (&b); + return err; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_is_prime.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_prime_miller_rabin.c Index: libtommath/bn_mp_prime_miller_rabin.c ================================================================== --- /dev/null +++ libtommath/bn_mp_prime_miller_rabin.c @@ -0,0 +1,103 @@ +#include +#ifdef BN_MP_PRIME_MILLER_RABIN_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* Miller-Rabin test of "a" to the base of "b" as described in + * HAC pp. 139 Algorithm 4.24 + * + * Sets result to 0 if definitely composite or 1 if probably prime. + * Randomly the chance of error is no more than 1/4 and often + * very much lower. + */ +int mp_prime_miller_rabin (mp_int * a, mp_int * b, int *result) +{ + mp_int n1, y, r; + int s, j, err; + + /* default */ + *result = MP_NO; + + /* ensure b > 1 */ + if (mp_cmp_d(b, 1) != MP_GT) { + return MP_VAL; + } + + /* get n1 = a - 1 */ + if ((err = mp_init_copy (&n1, a)) != MP_OKAY) { + return err; + } + if ((err = mp_sub_d (&n1, 1, &n1)) != MP_OKAY) { + goto LBL_N1; + } + + /* set 2**s * r = n1 */ + if ((err = mp_init_copy (&r, &n1)) != MP_OKAY) { + goto LBL_N1; + } + + /* count the number of least significant bits + * which are zero + */ + s = mp_cnt_lsb(&r); + + /* now divide n - 1 by 2**s */ + if ((err = mp_div_2d (&r, s, &r, NULL)) != MP_OKAY) { + goto LBL_R; + } + + /* compute y = b**r mod a */ + if ((err = mp_init (&y)) != MP_OKAY) { + goto LBL_R; + } + if ((err = mp_exptmod (b, &r, a, &y)) != MP_OKAY) { + goto LBL_Y; + } + + /* if y != 1 and y != n1 do */ + if (mp_cmp_d (&y, 1) != MP_EQ && mp_cmp (&y, &n1) != MP_EQ) { + j = 1; + /* while j <= s-1 and y != n1 */ + while ((j <= (s - 1)) && mp_cmp (&y, &n1) != MP_EQ) { + if ((err = mp_sqrmod (&y, a, &y)) != MP_OKAY) { + goto LBL_Y; + } + + /* if y == 1 then composite */ + if (mp_cmp_d (&y, 1) == MP_EQ) { + goto LBL_Y; + } + + ++j; + } + + /* if y != n1 then composite */ + if (mp_cmp (&y, &n1) != MP_EQ) { + goto LBL_Y; + } + } + + /* probably prime now */ + *result = MP_YES; +LBL_Y:mp_clear (&y); +LBL_R:mp_clear (&r); +LBL_N1:mp_clear (&n1); + return err; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_miller_rabin.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_prime_next_prime.c Index: libtommath/bn_mp_prime_next_prime.c ================================================================== --- /dev/null +++ libtommath/bn_mp_prime_next_prime.c @@ -0,0 +1,170 @@ +#include +#ifdef BN_MP_PRIME_NEXT_PRIME_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* finds the next prime after the number "a" using "t" trials + * of Miller-Rabin. + * + * bbs_style = 1 means the prime must be congruent to 3 mod 4 + */ +int mp_prime_next_prime(mp_int *a, int t, int bbs_style) +{ + int err, res, x, y; + mp_digit res_tab[PRIME_SIZE], step, kstep; + mp_int b; + + /* ensure t is valid */ + if (t <= 0 || t > PRIME_SIZE) { + return MP_VAL; + } + + /* force positive */ + a->sign = MP_ZPOS; + + /* simple algo if a is less than the largest prime in the table */ + if (mp_cmp_d(a, ltm_prime_tab[PRIME_SIZE-1]) == MP_LT) { + /* find which prime it is bigger than */ + for (x = PRIME_SIZE - 2; x >= 0; x--) { + if (mp_cmp_d(a, ltm_prime_tab[x]) != MP_LT) { + if (bbs_style == 1) { + /* ok we found a prime smaller or + * equal [so the next is larger] + * + * however, the prime must be + * congruent to 3 mod 4 + */ + if ((ltm_prime_tab[x + 1] & 3) != 3) { + /* scan upwards for a prime congruent to 3 mod 4 */ + for (y = x + 1; y < PRIME_SIZE; y++) { + if ((ltm_prime_tab[y] & 3) == 3) { + mp_set(a, ltm_prime_tab[y]); + return MP_OKAY; + } + } + } + } else { + mp_set(a, ltm_prime_tab[x + 1]); + return MP_OKAY; + } + } + } + /* at this point a maybe 1 */ + if (mp_cmp_d(a, 1) == MP_EQ) { + mp_set(a, 2); + return MP_OKAY; + } + /* fall through to the sieve */ + } + + /* generate a prime congruent to 3 mod 4 or 1/3 mod 4? */ + if (bbs_style == 1) { + kstep = 4; + } else { + kstep = 2; + } + + /* at this point we will use a combination of a sieve and Miller-Rabin */ + + if (bbs_style == 1) { + /* if a mod 4 != 3 subtract the correct value to make it so */ + if ((a->dp[0] & 3) != 3) { + if ((err = mp_sub_d(a, (a->dp[0] & 3) + 1, a)) != MP_OKAY) { return err; }; + } + } else { + if (mp_iseven(a) == 1) { + /* force odd */ + if ((err = mp_sub_d(a, 1, a)) != MP_OKAY) { + return err; + } + } + } + + /* generate the restable */ + for (x = 1; x < PRIME_SIZE; x++) { + if ((err = mp_mod_d(a, ltm_prime_tab[x], res_tab + x)) != MP_OKAY) { + return err; + } + } + + /* init temp used for Miller-Rabin Testing */ + if ((err = mp_init(&b)) != MP_OKAY) { + return err; + } + + for (;;) { + /* skip to the next non-trivially divisible candidate */ + step = 0; + do { + /* y == 1 if any residue was zero [e.g. cannot be prime] */ + y = 0; + + /* increase step to next candidate */ + step += kstep; + + /* compute the new residue without using division */ + for (x = 1; x < PRIME_SIZE; x++) { + /* add the step to each residue */ + res_tab[x] += kstep; + + /* subtract the modulus [instead of using division] */ + if (res_tab[x] >= ltm_prime_tab[x]) { + res_tab[x] -= ltm_prime_tab[x]; + } + + /* set flag if zero */ + if (res_tab[x] == 0) { + y = 1; + } + } + } while (y == 1 && step < ((((mp_digit)1)<= ((((mp_digit)1)< +#ifdef BN_MP_PRIME_RABIN_MILLER_TRIALS_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + + +static const struct { + int k, t; +} sizes[] = { +{ 128, 28 }, +{ 256, 16 }, +{ 384, 10 }, +{ 512, 7 }, +{ 640, 6 }, +{ 768, 5 }, +{ 896, 4 }, +{ 1024, 4 } +}; + +/* returns # of RM trials required for a given bit size */ +int mp_prime_rabin_miller_trials(int size) +{ + int x; + + for (x = 0; x < (int)(sizeof(sizes)/(sizeof(sizes[0]))); x++) { + if (sizes[x].k == size) { + return sizes[x].t; + } else if (sizes[x].k > size) { + return (x == 0) ? sizes[0].t : sizes[x - 1].t; + } + } + return sizes[x-1].t + 1; +} + + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_rabin_miller_trials.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_prime_random_ex.c Index: libtommath/bn_mp_prime_random_ex.c ================================================================== --- /dev/null +++ libtommath/bn_mp_prime_random_ex.c @@ -0,0 +1,125 @@ +#include +#ifdef BN_MP_PRIME_RANDOM_EX_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* makes a truly random prime of a given size (bits), + * + * Flags are as follows: + * + * LTM_PRIME_BBS - make prime congruent to 3 mod 4 + * LTM_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies LTM_PRIME_BBS) + * LTM_PRIME_2MSB_OFF - make the 2nd highest bit zero + * LTM_PRIME_2MSB_ON - make the 2nd highest bit one + * + * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can + * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself + * so it can be NULL + * + */ + +/* This is possibly the mother of all prime generation functions, muahahahahaha! */ +int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback cb, void *dat) +{ + unsigned char *tmp, maskAND, maskOR_msb, maskOR_lsb; + int res, err, bsize, maskOR_msb_offset; + + /* sanity check the input */ + if (size <= 1 || t <= 0) { + return MP_VAL; + } + + /* LTM_PRIME_SAFE implies LTM_PRIME_BBS */ + if (flags & LTM_PRIME_SAFE) { + flags |= LTM_PRIME_BBS; + } + + /* calc the byte size */ + bsize = (size>>3) + ((size&7)?1:0); + + /* we need a buffer of bsize bytes */ + tmp = OPT_CAST(unsigned char) XMALLOC(bsize); + if (tmp == NULL) { + return MP_MEM; + } + + /* calc the maskAND value for the MSbyte*/ + maskAND = ((size&7) == 0) ? 0xFF : (0xFF >> (8 - (size & 7))); + + /* calc the maskOR_msb */ + maskOR_msb = 0; + maskOR_msb_offset = ((size & 7) == 1) ? 1 : 0; + if (flags & LTM_PRIME_2MSB_ON) { + maskOR_msb |= 0x80 >> ((9 - size) & 7); + } + + /* get the maskOR_lsb */ + maskOR_lsb = 1; + if (flags & LTM_PRIME_BBS) { + maskOR_lsb |= 3; + } + + do { + /* read the bytes */ + if (cb(tmp, bsize, dat) != bsize) { + err = MP_VAL; + goto error; + } + + /* work over the MSbyte */ + tmp[0] &= maskAND; + tmp[0] |= 1 << ((size - 1) & 7); + + /* mix in the maskORs */ + tmp[maskOR_msb_offset] |= maskOR_msb; + tmp[bsize-1] |= maskOR_lsb; + + /* read it in */ + if ((err = mp_read_unsigned_bin(a, tmp, bsize)) != MP_OKAY) { goto error; } + + /* is it prime? */ + if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY) { goto error; } + if (res == MP_NO) { + continue; + } + + if (flags & LTM_PRIME_SAFE) { + /* see if (a-1)/2 is prime */ + if ((err = mp_sub_d(a, 1, a)) != MP_OKAY) { goto error; } + if ((err = mp_div_2(a, a)) != MP_OKAY) { goto error; } + + /* is it prime? */ + if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY) { goto error; } + } + } while (res == MP_NO); + + if (flags & LTM_PRIME_SAFE) { + /* restore a to the original value */ + if ((err = mp_mul_2(a, a)) != MP_OKAY) { goto error; } + if ((err = mp_add_d(a, 1, a)) != MP_OKAY) { goto error; } + } + + err = MP_OKAY; +error: + XFREE(tmp); + return err; +} + + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_random_ex.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_radix_size.c Index: libtommath/bn_mp_radix_size.c ================================================================== --- /dev/null +++ libtommath/bn_mp_radix_size.c @@ -0,0 +1,87 @@ +#include +#ifdef BN_MP_RADIX_SIZE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* returns size of ASCII reprensentation */ +int mp_radix_size (mp_int * a, int radix, int *size) +{ + int res, digs; + mp_int t; + mp_digit d; + + *size = 0; + + /* special case for binary */ + if (radix == 2) { + *size = mp_count_bits (a) + (a->sign == MP_NEG ? 1 : 0) + 1; + return MP_OKAY; + } + + /* make sure the radix is in range */ + if (radix < 2 || radix > 64) { + return MP_VAL; + } + + if (mp_iszero(a) == MP_YES) { + *size = 2; + return MP_OKAY; + } + + /* digs is the digit count */ + digs = 0; + + /* if it's negative add one for the sign */ + if (a->sign == MP_NEG) { + ++digs; + } + + /* init a copy of the input */ + if ((res = mp_init_copy (&t, a)) != MP_OKAY) { + return res; + } + + /* force temp to positive */ + t.sign = MP_ZPOS; + + /* fetch out all of the digits */ + while (mp_iszero (&t) == MP_NO) { + if ((res = mp_div_d (&t, (mp_digit) radix, &t, &d)) != MP_OKAY) { + mp_clear (&t); + return res; + } + ++digs; + } + mp_clear (&t); + + /* + * return digs + 1, the 1 is for the NULL byte that would be required. + * mp_toradix_n requires a minimum of 3 bytes, so never report less than + * that. + */ + + if ( digs >= 2 ) { + *size = digs + 1; + } else { + *size = 3; + } + return MP_OKAY; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_radix_size.c,v $ */ +/* $Revision: 1.1.1.1.2.3 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_radix_smap.c Index: libtommath/bn_mp_radix_smap.c ================================================================== --- /dev/null +++ libtommath/bn_mp_radix_smap.c @@ -0,0 +1,24 @@ +#include +#ifdef BN_MP_RADIX_SMAP_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* chars used in radix conversions */ +const char *mp_s_rmap = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+/"; +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_radix_smap.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_rand.c Index: libtommath/bn_mp_rand.c ================================================================== --- /dev/null +++ libtommath/bn_mp_rand.c @@ -0,0 +1,55 @@ +#include +#ifdef BN_MP_RAND_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* makes a pseudo-random int of a given size */ +int +mp_rand (mp_int * a, int digits) +{ + int res; + mp_digit d; + + mp_zero (a); + if (digits <= 0) { + return MP_OKAY; + } + + /* first place a random non-zero digit */ + do { + d = ((mp_digit) abs (rand ())) & MP_MASK; + } while (d == 0); + + if ((res = mp_add_d (a, d, a)) != MP_OKAY) { + return res; + } + + while (--digits > 0) { + if ((res = mp_lshd (a, 1)) != MP_OKAY) { + return res; + } + + if ((res = mp_add_d (a, ((mp_digit) abs (rand ())), a)) != MP_OKAY) { + return res; + } + } + + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_rand.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_read_radix.c Index: libtommath/bn_mp_read_radix.c ================================================================== --- /dev/null +++ libtommath/bn_mp_read_radix.c @@ -0,0 +1,89 @@ +#include +#ifdef BN_MP_READ_RADIX_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* read a string [ASCII] in a given radix */ +int mp_read_radix (mp_int * a, const char *str, int radix) +{ + int y, res, neg; + char ch; + + /* make sure the radix is ok */ + if (radix < 2 || radix > 64) { + return MP_VAL; + } + + /* if the leading digit is a + * minus set the sign to negative. + */ + if (*str == '-') { + ++str; + neg = MP_NEG; + } else { + neg = MP_ZPOS; + } + + /* set the integer to the default of zero */ + mp_zero (a); + + /* process each digit of the string */ + while (*str) { + /* if the radix < 36 the conversion is case insensitive + * this allows numbers like 1AB and 1ab to represent the same value + * [e.g. in hex] + */ + ch = (char) ((radix < 36) ? toupper (*str) : *str); + for (y = 0; y < 64; y++) { + if (ch == mp_s_rmap[y]) { + break; + } + } + + /* if the char was found in the map + * and is less than the given radix add it + * to the number, otherwise exit the loop. + */ + if (y < radix) { + if ((res = mp_mul_d (a, (mp_digit) radix, a)) != MP_OKAY) { + return res; + } + if ((res = mp_add_d (a, (mp_digit) y, a)) != MP_OKAY) { + return res; + } + } else { + break; + } + ++str; + } + + /* if an illegal character was found, fail. */ + + if ( *str != '\0' ) { + mp_zero( a ); + return MP_VAL; + } + + /* set the sign only if a != 0 */ + if (mp_iszero(a) != 1) { + a->sign = neg; + } + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_read_radix.c,v $ */ +/* $Revision: 1.1.1.1.2.3 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_read_signed_bin.c Index: libtommath/bn_mp_read_signed_bin.c ================================================================== --- /dev/null +++ libtommath/bn_mp_read_signed_bin.c @@ -0,0 +1,41 @@ +#include +#ifdef BN_MP_READ_SIGNED_BIN_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* read signed bin, big endian, first byte is 0==positive or 1==negative */ +int mp_read_signed_bin (mp_int * a, const unsigned char *b, int c) +{ + int res; + + /* read magnitude */ + if ((res = mp_read_unsigned_bin (a, b + 1, c - 1)) != MP_OKAY) { + return res; + } + + /* first byte is 0 for positive, non-zero for negative */ + if (b[0] == 0) { + a->sign = MP_ZPOS; + } else { + a->sign = MP_NEG; + } + + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_read_signed_bin.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_read_unsigned_bin.c Index: libtommath/bn_mp_read_unsigned_bin.c ================================================================== --- /dev/null +++ libtommath/bn_mp_read_unsigned_bin.c @@ -0,0 +1,55 @@ +#include +#ifdef BN_MP_READ_UNSIGNED_BIN_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* reads a unsigned char array, assumes the msb is stored first [big endian] */ +int mp_read_unsigned_bin (mp_int * a, const unsigned char *b, int c) +{ + int res; + + /* make sure there are at least two digits */ + if (a->alloc < 2) { + if ((res = mp_grow(a, 2)) != MP_OKAY) { + return res; + } + } + + /* zero the int */ + mp_zero (a); + + /* read the bytes in */ + while (c-- > 0) { + if ((res = mp_mul_2d (a, 8, a)) != MP_OKAY) { + return res; + } + +#ifndef MP_8BIT + a->dp[0] |= *b++; + a->used += 1; +#else + a->dp[0] = (*b & MP_MASK); + a->dp[1] |= ((*b++ >> 7U) & 1); + a->used += 2; +#endif + } + mp_clamp (a); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_read_unsigned_bin.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_reduce.c Index: libtommath/bn_mp_reduce.c ================================================================== --- /dev/null +++ libtommath/bn_mp_reduce.c @@ -0,0 +1,100 @@ +#include +#ifdef BN_MP_REDUCE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* reduces x mod m, assumes 0 < x < m**2, mu is + * precomputed via mp_reduce_setup. + * From HAC pp.604 Algorithm 14.42 + */ +int mp_reduce (mp_int * x, mp_int * m, mp_int * mu) +{ + mp_int q; + int res, um = m->used; + + /* q = x */ + if ((res = mp_init_copy (&q, x)) != MP_OKAY) { + return res; + } + + /* q1 = x / b**(k-1) */ + mp_rshd (&q, um - 1); + + /* according to HAC this optimization is ok */ + if (((unsigned long) um) > (((mp_digit)1) << (DIGIT_BIT - 1))) { + if ((res = mp_mul (&q, mu, &q)) != MP_OKAY) { + goto CLEANUP; + } + } else { +#ifdef BN_S_MP_MUL_HIGH_DIGS_C + if ((res = s_mp_mul_high_digs (&q, mu, &q, um)) != MP_OKAY) { + goto CLEANUP; + } +#elif defined(BN_FAST_S_MP_MUL_HIGH_DIGS_C) + if ((res = fast_s_mp_mul_high_digs (&q, mu, &q, um)) != MP_OKAY) { + goto CLEANUP; + } +#else + { + res = MP_VAL; + goto CLEANUP; + } +#endif + } + + /* q3 = q2 / b**(k+1) */ + mp_rshd (&q, um + 1); + + /* x = x mod b**(k+1), quick (no division) */ + if ((res = mp_mod_2d (x, DIGIT_BIT * (um + 1), x)) != MP_OKAY) { + goto CLEANUP; + } + + /* q = q * m mod b**(k+1), quick (no division) */ + if ((res = s_mp_mul_digs (&q, m, &q, um + 1)) != MP_OKAY) { + goto CLEANUP; + } + + /* x = x - q */ + if ((res = mp_sub (x, &q, x)) != MP_OKAY) { + goto CLEANUP; + } + + /* If x < 0, add b**(k+1) to it */ + if (mp_cmp_d (x, 0) == MP_LT) { + mp_set (&q, 1); + if ((res = mp_lshd (&q, um + 1)) != MP_OKAY) + goto CLEANUP; + if ((res = mp_add (x, &q, x)) != MP_OKAY) + goto CLEANUP; + } + + /* Back off if it's too big */ + while (mp_cmp (x, m) != MP_LT) { + if ((res = s_mp_sub (x, m, x)) != MP_OKAY) { + goto CLEANUP; + } + } + +CLEANUP: + mp_clear (&q); + + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_reduce_2k.c Index: libtommath/bn_mp_reduce_2k.c ================================================================== --- /dev/null +++ libtommath/bn_mp_reduce_2k.c @@ -0,0 +1,61 @@ +#include +#ifdef BN_MP_REDUCE_2K_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* reduces a modulo n where n is of the form 2**p - d */ +int mp_reduce_2k(mp_int *a, mp_int *n, mp_digit d) +{ + mp_int q; + int p, res; + + if ((res = mp_init(&q)) != MP_OKAY) { + return res; + } + + p = mp_count_bits(n); +top: + /* q = a/2**p, a = a mod 2**p */ + if ((res = mp_div_2d(a, p, &q, a)) != MP_OKAY) { + goto ERR; + } + + if (d != 1) { + /* q = q * d */ + if ((res = mp_mul_d(&q, d, &q)) != MP_OKAY) { + goto ERR; + } + } + + /* a = a + q */ + if ((res = s_mp_add(a, &q, a)) != MP_OKAY) { + goto ERR; + } + + if (mp_cmp_mag(a, n) != MP_LT) { + s_mp_sub(a, n, a); + goto top; + } + +ERR: + mp_clear(&q); + return res; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_2k.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_reduce_2k_l.c Index: libtommath/bn_mp_reduce_2k_l.c ================================================================== --- /dev/null +++ libtommath/bn_mp_reduce_2k_l.c @@ -0,0 +1,62 @@ +#include +#ifdef BN_MP_REDUCE_2K_L_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* reduces a modulo n where n is of the form 2**p - d + This differs from reduce_2k since "d" can be larger + than a single digit. +*/ +int mp_reduce_2k_l(mp_int *a, mp_int *n, mp_int *d) +{ + mp_int q; + int p, res; + + if ((res = mp_init(&q)) != MP_OKAY) { + return res; + } + + p = mp_count_bits(n); +top: + /* q = a/2**p, a = a mod 2**p */ + if ((res = mp_div_2d(a, p, &q, a)) != MP_OKAY) { + goto ERR; + } + + /* q = q * d */ + if ((res = mp_mul(&q, d, &q)) != MP_OKAY) { + goto ERR; + } + + /* a = a + q */ + if ((res = s_mp_add(a, &q, a)) != MP_OKAY) { + goto ERR; + } + + if (mp_cmp_mag(a, n) != MP_LT) { + s_mp_sub(a, n, a); + goto top; + } + +ERR: + mp_clear(&q); + return res; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_2k_l.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_reduce_2k_setup.c Index: libtommath/bn_mp_reduce_2k_setup.c ================================================================== --- /dev/null +++ libtommath/bn_mp_reduce_2k_setup.c @@ -0,0 +1,47 @@ +#include +#ifdef BN_MP_REDUCE_2K_SETUP_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* determines the setup value */ +int mp_reduce_2k_setup(mp_int *a, mp_digit *d) +{ + int res, p; + mp_int tmp; + + if ((res = mp_init(&tmp)) != MP_OKAY) { + return res; + } + + p = mp_count_bits(a); + if ((res = mp_2expt(&tmp, p)) != MP_OKAY) { + mp_clear(&tmp); + return res; + } + + if ((res = s_mp_sub(&tmp, a, &tmp)) != MP_OKAY) { + mp_clear(&tmp); + return res; + } + + *d = tmp.dp[0]; + mp_clear(&tmp); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_2k_setup.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_reduce_2k_setup_l.c Index: libtommath/bn_mp_reduce_2k_setup_l.c ================================================================== --- /dev/null +++ libtommath/bn_mp_reduce_2k_setup_l.c @@ -0,0 +1,44 @@ +#include +#ifdef BN_MP_REDUCE_2K_SETUP_L_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* determines the setup value */ +int mp_reduce_2k_setup_l(mp_int *a, mp_int *d) +{ + int res; + mp_int tmp; + + if ((res = mp_init(&tmp)) != MP_OKAY) { + return res; + } + + if ((res = mp_2expt(&tmp, mp_count_bits(a))) != MP_OKAY) { + goto ERR; + } + + if ((res = s_mp_sub(&tmp, a, d)) != MP_OKAY) { + goto ERR; + } + +ERR: + mp_clear(&tmp); + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_2k_setup_l.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_reduce_is_2k.c Index: libtommath/bn_mp_reduce_is_2k.c ================================================================== --- /dev/null +++ libtommath/bn_mp_reduce_is_2k.c @@ -0,0 +1,52 @@ +#include +#ifdef BN_MP_REDUCE_IS_2K_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* determines if mp_reduce_2k can be used */ +int mp_reduce_is_2k(mp_int *a) +{ + int ix, iy, iw; + mp_digit iz; + + if (a->used == 0) { + return MP_NO; + } else if (a->used == 1) { + return MP_YES; + } else if (a->used > 1) { + iy = mp_count_bits(a); + iz = 1; + iw = 1; + + /* Test every bit from the second digit up, must be 1 */ + for (ix = DIGIT_BIT; ix < iy; ix++) { + if ((a->dp[iw] & iz) == 0) { + return MP_NO; + } + iz <<= 1; + if (iz > (mp_digit)MP_MASK) { + ++iw; + iz = 1; + } + } + } + return MP_YES; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_is_2k.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_reduce_is_2k_l.c Index: libtommath/bn_mp_reduce_is_2k_l.c ================================================================== --- /dev/null +++ libtommath/bn_mp_reduce_is_2k_l.c @@ -0,0 +1,44 @@ +#include +#ifdef BN_MP_REDUCE_IS_2K_L_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* determines if reduce_2k_l can be used */ +int mp_reduce_is_2k_l(mp_int *a) +{ + int ix, iy; + + if (a->used == 0) { + return MP_NO; + } else if (a->used == 1) { + return MP_YES; + } else if (a->used > 1) { + /* if more than half of the digits are -1 we're sold */ + for (iy = ix = 0; ix < a->used; ix++) { + if (a->dp[ix] == MP_MASK) { + ++iy; + } + } + return (iy >= (a->used/2)) ? MP_YES : MP_NO; + + } + return MP_NO; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_is_2k_l.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_reduce_setup.c Index: libtommath/bn_mp_reduce_setup.c ================================================================== --- /dev/null +++ libtommath/bn_mp_reduce_setup.c @@ -0,0 +1,34 @@ +#include +#ifdef BN_MP_REDUCE_SETUP_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* pre-calculate the value required for Barrett reduction + * For a given modulus "b" it calulates the value required in "a" + */ +int mp_reduce_setup (mp_int * a, mp_int * b) +{ + int res; + + if ((res = mp_2expt (a, b->used * 2 * DIGIT_BIT)) != MP_OKAY) { + return res; + } + return mp_div (a, b, a, NULL); +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_setup.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_rshd.c Index: libtommath/bn_mp_rshd.c ================================================================== --- /dev/null +++ libtommath/bn_mp_rshd.c @@ -0,0 +1,72 @@ +#include +#ifdef BN_MP_RSHD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* shift right a certain amount of digits */ +void mp_rshd (mp_int * a, int b) +{ + int x; + + /* if b <= 0 then ignore it */ + if (b <= 0) { + return; + } + + /* if b > used then simply zero it and return */ + if (a->used <= b) { + mp_zero (a); + return; + } + + { + register mp_digit *bottom, *top; + + /* shift the digits down */ + + /* bottom */ + bottom = a->dp; + + /* top [offset into digits] */ + top = a->dp + b; + + /* this is implemented as a sliding window where + * the window is b-digits long and digits from + * the top of the window are copied to the bottom + * + * e.g. + + b-2 | b-1 | b0 | b1 | b2 | ... | bb | ----> + /\ | ----> + \-------------------/ ----> + */ + for (x = 0; x < (a->used - b); x++) { + *bottom++ = *top++; + } + + /* zero the top digits */ + for (; x < a->used; x++) { + *bottom++ = 0; + } + } + + /* remove excess digits */ + a->used -= b; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_rshd.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_set.c Index: libtommath/bn_mp_set.c ================================================================== --- /dev/null +++ libtommath/bn_mp_set.c @@ -0,0 +1,29 @@ +#include +#ifdef BN_MP_SET_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* set to a digit */ +void mp_set (mp_int * a, mp_digit b) +{ + mp_zero (a); + a->dp[0] = b & MP_MASK; + a->used = (a->dp[0] != 0) ? 1 : 0; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_set.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_set_int.c Index: libtommath/bn_mp_set_int.c ================================================================== --- /dev/null +++ libtommath/bn_mp_set_int.c @@ -0,0 +1,48 @@ +#include +#ifdef BN_MP_SET_INT_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* set a 32-bit const */ +int mp_set_int (mp_int * a, unsigned long b) +{ + int x, res; + + mp_zero (a); + + /* set four bits at a time */ + for (x = 0; x < 8; x++) { + /* shift the number up four bits */ + if ((res = mp_mul_2d (a, 4, a)) != MP_OKAY) { + return res; + } + + /* OR in the top four bits of the source */ + a->dp[0] |= (b >> 28) & 15; + + /* shift the source up to the next four bits */ + b <<= 4; + + /* ensure that digits are not clamped off */ + a->used += 1; + } + mp_clamp (a); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_set_int.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_shrink.c Index: libtommath/bn_mp_shrink.c ================================================================== --- /dev/null +++ libtommath/bn_mp_shrink.c @@ -0,0 +1,35 @@ +#include +#ifdef BN_MP_SHRINK_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* shrink a bignum */ +int mp_shrink (mp_int * a) +{ + mp_digit *tmp; + if (a->alloc != a->used && a->used > 0) { + if ((tmp = OPT_CAST(mp_digit) XREALLOC (a->dp, sizeof (mp_digit) * a->used)) == NULL) { + return MP_MEM; + } + a->dp = tmp; + a->alloc = a->used; + } + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_shrink.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_signed_bin_size.c Index: libtommath/bn_mp_signed_bin_size.c ================================================================== --- /dev/null +++ libtommath/bn_mp_signed_bin_size.c @@ -0,0 +1,27 @@ +#include +#ifdef BN_MP_SIGNED_BIN_SIZE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* get the size for an signed equivalent */ +int mp_signed_bin_size (mp_int * a) +{ + return 1 + mp_unsigned_bin_size (a); +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_signed_bin_size.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_sqr.c Index: libtommath/bn_mp_sqr.c ================================================================== --- /dev/null +++ libtommath/bn_mp_sqr.c @@ -0,0 +1,58 @@ +#include +#ifdef BN_MP_SQR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* computes b = a*a */ +int +mp_sqr (mp_int * a, mp_int * b) +{ + int res; + +#ifdef BN_MP_TOOM_SQR_C + /* use Toom-Cook? */ + if (a->used >= TOOM_SQR_CUTOFF) { + res = mp_toom_sqr(a, b); + /* Karatsuba? */ + } else +#endif +#ifdef BN_MP_KARATSUBA_SQR_C +if (a->used >= KARATSUBA_SQR_CUTOFF) { + res = mp_karatsuba_sqr (a, b); + } else +#endif + { +#ifdef BN_FAST_S_MP_SQR_C + /* can we use the fast comba multiplier? */ + if ((a->used * 2 + 1) < MP_WARRAY && + a->used < + (1 << (sizeof(mp_word) * CHAR_BIT - 2*DIGIT_BIT - 1))) { + res = fast_s_mp_sqr (a, b); + } else +#endif +#ifdef BN_S_MP_SQR_C + res = s_mp_sqr (a, b); +#else + res = MP_VAL; +#endif + } + b->sign = MP_ZPOS; + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_sqr.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_sqrmod.c Index: libtommath/bn_mp_sqrmod.c ================================================================== --- /dev/null +++ libtommath/bn_mp_sqrmod.c @@ -0,0 +1,41 @@ +#include +#ifdef BN_MP_SQRMOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* c = a * a (mod b) */ +int +mp_sqrmod (mp_int * a, mp_int * b, mp_int * c) +{ + int res; + mp_int t; + + if ((res = mp_init (&t)) != MP_OKAY) { + return res; + } + + if ((res = mp_sqr (a, &t)) != MP_OKAY) { + mp_clear (&t); + return res; + } + res = mp_mod (&t, b, c); + mp_clear (&t); + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_sqrmod.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_sqrt.c Index: libtommath/bn_mp_sqrt.c ================================================================== --- /dev/null +++ libtommath/bn_mp_sqrt.c @@ -0,0 +1,81 @@ +#include +#ifdef BN_MP_SQRT_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* this function is less generic than mp_n_root, simpler and faster */ +int mp_sqrt(mp_int *arg, mp_int *ret) +{ + int res; + mp_int t1,t2; + + /* must be positive */ + if (arg->sign == MP_NEG) { + return MP_VAL; + } + + /* easy out */ + if (mp_iszero(arg) == MP_YES) { + mp_zero(ret); + return MP_OKAY; + } + + if ((res = mp_init_copy(&t1, arg)) != MP_OKAY) { + return res; + } + + if ((res = mp_init(&t2)) != MP_OKAY) { + goto E2; + } + + /* First approx. (not very bad for large arg) */ + mp_rshd (&t1,t1.used/2); + + /* t1 > 0 */ + if ((res = mp_div(arg,&t1,&t2,NULL)) != MP_OKAY) { + goto E1; + } + if ((res = mp_add(&t1,&t2,&t1)) != MP_OKAY) { + goto E1; + } + if ((res = mp_div_2(&t1,&t1)) != MP_OKAY) { + goto E1; + } + /* And now t1 > sqrt(arg) */ + do { + if ((res = mp_div(arg,&t1,&t2,NULL)) != MP_OKAY) { + goto E1; + } + if ((res = mp_add(&t1,&t2,&t1)) != MP_OKAY) { + goto E1; + } + if ((res = mp_div_2(&t1,&t1)) != MP_OKAY) { + goto E1; + } + /* t1 >= sqrt(arg) >= t2 at this point */ + } while (mp_cmp_mag(&t1,&t2) == MP_GT); + + mp_exch(&t1,ret); + +E1: mp_clear(&t2); +E2: mp_clear(&t1); + return res; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_sqrt.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_sub.c Index: libtommath/bn_mp_sub.c ================================================================== --- /dev/null +++ libtommath/bn_mp_sub.c @@ -0,0 +1,59 @@ +#include +#ifdef BN_MP_SUB_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* high level subtraction (handles signs) */ +int +mp_sub (mp_int * a, mp_int * b, mp_int * c) +{ + int sa, sb, res; + + sa = a->sign; + sb = b->sign; + + if (sa != sb) { + /* subtract a negative from a positive, OR */ + /* subtract a positive from a negative. */ + /* In either case, ADD their magnitudes, */ + /* and use the sign of the first number. */ + c->sign = sa; + res = s_mp_add (a, b, c); + } else { + /* subtract a positive from a positive, OR */ + /* subtract a negative from a negative. */ + /* First, take the difference between their */ + /* magnitudes, then... */ + if (mp_cmp_mag (a, b) != MP_LT) { + /* Copy the sign from the first */ + c->sign = sa; + /* The first has a larger or equal magnitude */ + res = s_mp_sub (a, b, c); + } else { + /* The result has the *opposite* sign from */ + /* the first number. */ + c->sign = (sa == MP_ZPOS) ? MP_NEG : MP_ZPOS; + /* The second has a larger magnitude */ + res = s_mp_sub (b, a, c); + } + } + return res; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_sub.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_sub_d.c Index: libtommath/bn_mp_sub_d.c ================================================================== --- /dev/null +++ libtommath/bn_mp_sub_d.c @@ -0,0 +1,89 @@ +#include +#ifdef BN_MP_SUB_D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* single digit subtraction */ +int +mp_sub_d (mp_int * a, mp_digit b, mp_int * c) +{ + mp_digit *tmpa, *tmpc, mu; + int res, ix, oldused; + + /* grow c as required */ + if (c->alloc < a->used + 1) { + if ((res = mp_grow(c, a->used + 1)) != MP_OKAY) { + return res; + } + } + + /* if a is negative just do an unsigned + * addition [with fudged signs] + */ + if (a->sign == MP_NEG) { + a->sign = MP_ZPOS; + res = mp_add_d(a, b, c); + a->sign = c->sign = MP_NEG; + return res; + } + + /* setup regs */ + oldused = c->used; + tmpa = a->dp; + tmpc = c->dp; + + /* if a <= b simply fix the single digit */ + if ((a->used == 1 && a->dp[0] <= b) || a->used == 0) { + if (a->used == 1) { + *tmpc++ = b - *tmpa; + } else { + *tmpc++ = b; + } + ix = 1; + + /* negative/1digit */ + c->sign = MP_NEG; + c->used = 1; + } else { + /* positive/size */ + c->sign = MP_ZPOS; + c->used = a->used; + + /* subtract first digit */ + *tmpc = *tmpa++ - b; + mu = *tmpc >> (sizeof(mp_digit) * CHAR_BIT - 1); + *tmpc++ &= MP_MASK; + + /* handle rest of the digits */ + for (ix = 1; ix < a->used; ix++) { + *tmpc = *tmpa++ - mu; + mu = *tmpc >> (sizeof(mp_digit) * CHAR_BIT - 1); + *tmpc++ &= MP_MASK; + } + } + + /* zero excess digits */ + while (ix++ < oldused) { + *tmpc++ = 0; + } + mp_clamp(c); + return MP_OKAY; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_sub_d.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:53 $ */ ADDED libtommath/bn_mp_submod.c Index: libtommath/bn_mp_submod.c ================================================================== --- /dev/null +++ libtommath/bn_mp_submod.c @@ -0,0 +1,42 @@ +#include +#ifdef BN_MP_SUBMOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* d = a - b (mod c) */ +int +mp_submod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) +{ + int res; + mp_int t; + + + if ((res = mp_init (&t)) != MP_OKAY) { + return res; + } + + if ((res = mp_sub (a, b, &t)) != MP_OKAY) { + mp_clear (&t); + return res; + } + res = mp_mod (&t, c, d); + mp_clear (&t); + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_submod.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/bn_mp_to_signed_bin.c Index: libtommath/bn_mp_to_signed_bin.c ================================================================== --- /dev/null +++ libtommath/bn_mp_to_signed_bin.c @@ -0,0 +1,33 @@ +#include +#ifdef BN_MP_TO_SIGNED_BIN_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* store in signed [big endian] format */ +int mp_to_signed_bin (mp_int * a, unsigned char *b) +{ + int res; + + if ((res = mp_to_unsigned_bin (a, b + 1)) != MP_OKAY) { + return res; + } + b[0] = (unsigned char) ((a->sign == MP_ZPOS) ? 0 : 1); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_to_signed_bin.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/bn_mp_to_signed_bin_n.c Index: libtommath/bn_mp_to_signed_bin_n.c ================================================================== --- /dev/null +++ libtommath/bn_mp_to_signed_bin_n.c @@ -0,0 +1,31 @@ +#include +#ifdef BN_MP_TO_SIGNED_BIN_N_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* store in signed [big endian] format */ +int mp_to_signed_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen) +{ + if (*outlen < (unsigned long)mp_signed_bin_size(a)) { + return MP_VAL; + } + *outlen = mp_signed_bin_size(a); + return mp_to_signed_bin(a, b); +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_to_signed_bin_n.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/bn_mp_to_unsigned_bin.c Index: libtommath/bn_mp_to_unsigned_bin.c ================================================================== --- /dev/null +++ libtommath/bn_mp_to_unsigned_bin.c @@ -0,0 +1,48 @@ +#include +#ifdef BN_MP_TO_UNSIGNED_BIN_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* store in unsigned [big endian] format */ +int mp_to_unsigned_bin (mp_int * a, unsigned char *b) +{ + int x, res; + mp_int t; + + if ((res = mp_init_copy (&t, a)) != MP_OKAY) { + return res; + } + + x = 0; + while (mp_iszero (&t) == 0) { +#ifndef MP_8BIT + b[x++] = (unsigned char) (t.dp[0] & 255); +#else + b[x++] = (unsigned char) (t.dp[0] | ((t.dp[1] & 0x01) << 7)); +#endif + if ((res = mp_div_2d (&t, 8, &t, NULL)) != MP_OKAY) { + mp_clear (&t); + return res; + } + } + bn_reverse (b, x); + mp_clear (&t); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_to_unsigned_bin.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/bn_mp_to_unsigned_bin_n.c Index: libtommath/bn_mp_to_unsigned_bin_n.c ================================================================== --- /dev/null +++ libtommath/bn_mp_to_unsigned_bin_n.c @@ -0,0 +1,31 @@ +#include +#ifdef BN_MP_TO_UNSIGNED_BIN_N_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* store in unsigned [big endian] format */ +int mp_to_unsigned_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen) +{ + if (*outlen < (unsigned long)mp_unsigned_bin_size(a)) { + return MP_VAL; + } + *outlen = mp_unsigned_bin_size(a); + return mp_to_unsigned_bin(a, b); +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_to_unsigned_bin_n.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/bn_mp_toom_mul.c Index: libtommath/bn_mp_toom_mul.c ================================================================== --- /dev/null +++ libtommath/bn_mp_toom_mul.c @@ -0,0 +1,284 @@ +#include +#ifdef BN_MP_TOOM_MUL_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* multiplication using the Toom-Cook 3-way algorithm + * + * Much more complicated than Karatsuba but has a lower + * asymptotic running time of O(N**1.464). This algorithm is + * only particularly useful on VERY large inputs + * (we're talking 1000s of digits here...). +*/ +int mp_toom_mul(mp_int *a, mp_int *b, mp_int *c) +{ + mp_int w0, w1, w2, w3, w4, tmp1, tmp2, a0, a1, a2, b0, b1, b2; + int res, B; + + /* init temps */ + if ((res = mp_init_multi(&w0, &w1, &w2, &w3, &w4, + &a0, &a1, &a2, &b0, &b1, + &b2, &tmp1, &tmp2, NULL)) != MP_OKAY) { + return res; + } + + /* B */ + B = MIN(a->used, b->used) / 3; + + /* a = a2 * B**2 + a1 * B + a0 */ + if ((res = mp_mod_2d(a, DIGIT_BIT * B, &a0)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_copy(a, &a1)) != MP_OKAY) { + goto ERR; + } + mp_rshd(&a1, B); + mp_mod_2d(&a1, DIGIT_BIT * B, &a1); + + if ((res = mp_copy(a, &a2)) != MP_OKAY) { + goto ERR; + } + mp_rshd(&a2, B*2); + + /* b = b2 * B**2 + b1 * B + b0 */ + if ((res = mp_mod_2d(b, DIGIT_BIT * B, &b0)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_copy(b, &b1)) != MP_OKAY) { + goto ERR; + } + mp_rshd(&b1, B); + mp_mod_2d(&b1, DIGIT_BIT * B, &b1); + + if ((res = mp_copy(b, &b2)) != MP_OKAY) { + goto ERR; + } + mp_rshd(&b2, B*2); + + /* w0 = a0*b0 */ + if ((res = mp_mul(&a0, &b0, &w0)) != MP_OKAY) { + goto ERR; + } + + /* w4 = a2 * b2 */ + if ((res = mp_mul(&a2, &b2, &w4)) != MP_OKAY) { + goto ERR; + } + + /* w1 = (a2 + 2(a1 + 2a0))(b2 + 2(b1 + 2b0)) */ + if ((res = mp_mul_2(&a0, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a2, &tmp1)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_mul_2(&b0, &tmp2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp2, &b1, &tmp2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_mul_2(&tmp2, &tmp2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp2, &b2, &tmp2)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_mul(&tmp1, &tmp2, &w1)) != MP_OKAY) { + goto ERR; + } + + /* w3 = (a0 + 2(a1 + 2a2))(b0 + 2(b1 + 2b2)) */ + if ((res = mp_mul_2(&a2, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_mul_2(&b2, &tmp2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp2, &b1, &tmp2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_mul_2(&tmp2, &tmp2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp2, &b0, &tmp2)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_mul(&tmp1, &tmp2, &w3)) != MP_OKAY) { + goto ERR; + } + + + /* w2 = (a2 + a1 + a0)(b2 + b1 + b0) */ + if ((res = mp_add(&a2, &a1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&b2, &b1, &tmp2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp2, &b0, &tmp2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_mul(&tmp1, &tmp2, &w2)) != MP_OKAY) { + goto ERR; + } + + /* now solve the matrix + + 0 0 0 0 1 + 1 2 4 8 16 + 1 1 1 1 1 + 16 8 4 2 1 + 1 0 0 0 0 + + using 12 subtractions, 4 shifts, + 2 small divisions and 1 small multiplication + */ + + /* r1 - r4 */ + if ((res = mp_sub(&w1, &w4, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3 - r0 */ + if ((res = mp_sub(&w3, &w0, &w3)) != MP_OKAY) { + goto ERR; + } + /* r1/2 */ + if ((res = mp_div_2(&w1, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3/2 */ + if ((res = mp_div_2(&w3, &w3)) != MP_OKAY) { + goto ERR; + } + /* r2 - r0 - r4 */ + if ((res = mp_sub(&w2, &w0, &w2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w2, &w4, &w2)) != MP_OKAY) { + goto ERR; + } + /* r1 - r2 */ + if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3 - r2 */ + if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) { + goto ERR; + } + /* r1 - 8r0 */ + if ((res = mp_mul_2d(&w0, 3, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w1, &tmp1, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3 - 8r4 */ + if ((res = mp_mul_2d(&w4, 3, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w3, &tmp1, &w3)) != MP_OKAY) { + goto ERR; + } + /* 3r2 - r1 - r3 */ + if ((res = mp_mul_d(&w2, 3, &w2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w2, &w1, &w2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w2, &w3, &w2)) != MP_OKAY) { + goto ERR; + } + /* r1 - r2 */ + if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3 - r2 */ + if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) { + goto ERR; + } + /* r1/3 */ + if ((res = mp_div_3(&w1, &w1, NULL)) != MP_OKAY) { + goto ERR; + } + /* r3/3 */ + if ((res = mp_div_3(&w3, &w3, NULL)) != MP_OKAY) { + goto ERR; + } + + /* at this point shift W[n] by B*n */ + if ((res = mp_lshd(&w1, 1*B)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_lshd(&w2, 2*B)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_lshd(&w3, 3*B)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_lshd(&w4, 4*B)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_add(&w0, &w1, c)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&w2, &w3, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&w4, &tmp1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, c, c)) != MP_OKAY) { + goto ERR; + } + +ERR: + mp_clear_multi(&w0, &w1, &w2, &w3, &w4, + &a0, &a1, &a2, &b0, &b1, + &b2, &tmp1, &tmp2, NULL); + return res; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_toom_mul.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/bn_mp_toom_sqr.c Index: libtommath/bn_mp_toom_sqr.c ================================================================== --- /dev/null +++ libtommath/bn_mp_toom_sqr.c @@ -0,0 +1,226 @@ +#include +#ifdef BN_MP_TOOM_SQR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* squaring using Toom-Cook 3-way algorithm */ +int +mp_toom_sqr(mp_int *a, mp_int *b) +{ + mp_int w0, w1, w2, w3, w4, tmp1, a0, a1, a2; + int res, B; + + /* init temps */ + if ((res = mp_init_multi(&w0, &w1, &w2, &w3, &w4, &a0, &a1, &a2, &tmp1, NULL)) != MP_OKAY) { + return res; + } + + /* B */ + B = a->used / 3; + + /* a = a2 * B**2 + a1 * B + a0 */ + if ((res = mp_mod_2d(a, DIGIT_BIT * B, &a0)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_copy(a, &a1)) != MP_OKAY) { + goto ERR; + } + mp_rshd(&a1, B); + mp_mod_2d(&a1, DIGIT_BIT * B, &a1); + + if ((res = mp_copy(a, &a2)) != MP_OKAY) { + goto ERR; + } + mp_rshd(&a2, B*2); + + /* w0 = a0*a0 */ + if ((res = mp_sqr(&a0, &w0)) != MP_OKAY) { + goto ERR; + } + + /* w4 = a2 * a2 */ + if ((res = mp_sqr(&a2, &w4)) != MP_OKAY) { + goto ERR; + } + + /* w1 = (a2 + 2(a1 + 2a0))**2 */ + if ((res = mp_mul_2(&a0, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a2, &tmp1)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_sqr(&tmp1, &w1)) != MP_OKAY) { + goto ERR; + } + + /* w3 = (a0 + 2(a1 + 2a2))**2 */ + if ((res = mp_mul_2(&a2, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_sqr(&tmp1, &w3)) != MP_OKAY) { + goto ERR; + } + + + /* w2 = (a2 + a1 + a0)**2 */ + if ((res = mp_add(&a2, &a1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sqr(&tmp1, &w2)) != MP_OKAY) { + goto ERR; + } + + /* now solve the matrix + + 0 0 0 0 1 + 1 2 4 8 16 + 1 1 1 1 1 + 16 8 4 2 1 + 1 0 0 0 0 + + using 12 subtractions, 4 shifts, 2 small divisions and 1 small multiplication. + */ + + /* r1 - r4 */ + if ((res = mp_sub(&w1, &w4, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3 - r0 */ + if ((res = mp_sub(&w3, &w0, &w3)) != MP_OKAY) { + goto ERR; + } + /* r1/2 */ + if ((res = mp_div_2(&w1, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3/2 */ + if ((res = mp_div_2(&w3, &w3)) != MP_OKAY) { + goto ERR; + } + /* r2 - r0 - r4 */ + if ((res = mp_sub(&w2, &w0, &w2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w2, &w4, &w2)) != MP_OKAY) { + goto ERR; + } + /* r1 - r2 */ + if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3 - r2 */ + if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) { + goto ERR; + } + /* r1 - 8r0 */ + if ((res = mp_mul_2d(&w0, 3, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w1, &tmp1, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3 - 8r4 */ + if ((res = mp_mul_2d(&w4, 3, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w3, &tmp1, &w3)) != MP_OKAY) { + goto ERR; + } + /* 3r2 - r1 - r3 */ + if ((res = mp_mul_d(&w2, 3, &w2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w2, &w1, &w2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w2, &w3, &w2)) != MP_OKAY) { + goto ERR; + } + /* r1 - r2 */ + if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3 - r2 */ + if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) { + goto ERR; + } + /* r1/3 */ + if ((res = mp_div_3(&w1, &w1, NULL)) != MP_OKAY) { + goto ERR; + } + /* r3/3 */ + if ((res = mp_div_3(&w3, &w3, NULL)) != MP_OKAY) { + goto ERR; + } + + /* at this point shift W[n] by B*n */ + if ((res = mp_lshd(&w1, 1*B)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_lshd(&w2, 2*B)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_lshd(&w3, 3*B)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_lshd(&w4, 4*B)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_add(&w0, &w1, b)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&w2, &w3, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&w4, &tmp1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, b, b)) != MP_OKAY) { + goto ERR; + } + +ERR: + mp_clear_multi(&w0, &w1, &w2, &w3, &w4, &a0, &a1, &a2, &tmp1, NULL); + return res; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_toom_sqr.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/bn_mp_toradix.c Index: libtommath/bn_mp_toradix.c ================================================================== --- /dev/null +++ libtommath/bn_mp_toradix.c @@ -0,0 +1,75 @@ +#include +#ifdef BN_MP_TORADIX_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* stores a bignum as a ASCII string in a given radix (2..64) */ +int mp_toradix (mp_int * a, char *str, int radix) +{ + int res, digs; + mp_int t; + mp_digit d; + char *_s = str; + + /* check range of the radix */ + if (radix < 2 || radix > 64) { + return MP_VAL; + } + + /* quick out if its zero */ + if (mp_iszero(a) == 1) { + *str++ = '0'; + *str = '\0'; + return MP_OKAY; + } + + if ((res = mp_init_copy (&t, a)) != MP_OKAY) { + return res; + } + + /* if it is negative output a - */ + if (t.sign == MP_NEG) { + ++_s; + *str++ = '-'; + t.sign = MP_ZPOS; + } + + digs = 0; + while (mp_iszero (&t) == 0) { + if ((res = mp_div_d (&t, (mp_digit) radix, &t, &d)) != MP_OKAY) { + mp_clear (&t); + return res; + } + *str++ = mp_s_rmap[d]; + ++digs; + } + + /* reverse the digits of the string. In this case _s points + * to the first digit [exluding the sign] of the number] + */ + bn_reverse ((unsigned char *)_s, digs); + + /* append a NULL so the string is properly terminated */ + *str = '\0'; + + mp_clear (&t); + return MP_OKAY; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_toradix.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/bn_mp_toradix_n.c Index: libtommath/bn_mp_toradix_n.c ================================================================== --- /dev/null +++ libtommath/bn_mp_toradix_n.c @@ -0,0 +1,89 @@ +#include +#ifdef BN_MP_TORADIX_N_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* stores a bignum as a ASCII string in a given radix (2..64) + * + * Stores upto maxlen-1 chars and always a NULL byte + */ +int mp_toradix_n(mp_int * a, char *str, int radix, int maxlen) +{ + int res, digs; + mp_int t; + mp_digit d; + char *_s = str; + + /* check range of the maxlen, radix */ + if (maxlen < 3 || radix < 2 || radix > 64) { + return MP_VAL; + } + + /* quick out if its zero */ + if (mp_iszero(a) == 1) { + *str++ = '0'; + *str = '\0'; + return MP_OKAY; + } + + if ((res = mp_init_copy (&t, a)) != MP_OKAY) { + return res; + } + + /* if it is negative output a - */ + if (t.sign == MP_NEG) { + /* we have to reverse our digits later... but not the - sign!! */ + ++_s; + + /* store the flag and mark the number as positive */ + *str++ = '-'; + t.sign = MP_ZPOS; + + /* subtract a char */ + --maxlen; + } + + digs = 0; + while (mp_iszero (&t) == 0) { + if ((res = mp_div_d (&t, (mp_digit) radix, &t, &d)) != MP_OKAY) { + mp_clear (&t); + return res; + } + *str++ = mp_s_rmap[d]; + ++digs; + + if (--maxlen == 1) { + /* no more room */ + break; + } + } + + /* reverse the digits of the string. In this case _s points + * to the first digit [exluding the sign] of the number] + */ + bn_reverse ((unsigned char *)_s, digs); + + /* append a NULL so the string is properly terminated */ + *str = '\0'; + + mp_clear (&t); + return MP_OKAY; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_toradix_n.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/bn_mp_unsigned_bin_size.c Index: libtommath/bn_mp_unsigned_bin_size.c ================================================================== --- /dev/null +++ libtommath/bn_mp_unsigned_bin_size.c @@ -0,0 +1,28 @@ +#include +#ifdef BN_MP_UNSIGNED_BIN_SIZE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* get the size for an unsigned equivalent */ +int mp_unsigned_bin_size (mp_int * a) +{ + int size = mp_count_bits (a); + return (size / 8 + ((size & 7) != 0 ? 1 : 0)); +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_unsigned_bin_size.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/bn_mp_xor.c Index: libtommath/bn_mp_xor.c ================================================================== --- /dev/null +++ libtommath/bn_mp_xor.c @@ -0,0 +1,51 @@ +#include +#ifdef BN_MP_XOR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* XOR two ints together */ +int +mp_xor (mp_int * a, mp_int * b, mp_int * c) +{ + int res, ix, px; + mp_int t, *x; + + if (a->used > b->used) { + if ((res = mp_init_copy (&t, a)) != MP_OKAY) { + return res; + } + px = b->used; + x = b; + } else { + if ((res = mp_init_copy (&t, b)) != MP_OKAY) { + return res; + } + px = a->used; + x = a; + } + + for (ix = 0; ix < px; ix++) { + t.dp[ix] ^= x->dp[ix]; + } + mp_clamp (&t); + mp_exch (c, &t); + mp_clear (&t); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_xor.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/bn_mp_zero.c Index: libtommath/bn_mp_zero.c ================================================================== --- /dev/null +++ libtommath/bn_mp_zero.c @@ -0,0 +1,36 @@ +#include +#ifdef BN_MP_ZERO_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* set to zero */ +void mp_zero (mp_int * a) +{ + int n; + mp_digit *tmp; + + a->sign = MP_ZPOS; + a->used = 0; + + tmp = a->dp; + for (n = 0; n < a->alloc; n++) { + *tmp++ = 0; + } +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_zero.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/bn_prime_tab.c Index: libtommath/bn_prime_tab.c ================================================================== --- /dev/null +++ libtommath/bn_prime_tab.c @@ -0,0 +1,61 @@ +#include +#ifdef BN_PRIME_TAB_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ +const mp_digit ltm_prime_tab[] = { + 0x0002, 0x0003, 0x0005, 0x0007, 0x000B, 0x000D, 0x0011, 0x0013, + 0x0017, 0x001D, 0x001F, 0x0025, 0x0029, 0x002B, 0x002F, 0x0035, + 0x003B, 0x003D, 0x0043, 0x0047, 0x0049, 0x004F, 0x0053, 0x0059, + 0x0061, 0x0065, 0x0067, 0x006B, 0x006D, 0x0071, 0x007F, +#ifndef MP_8BIT + 0x0083, + 0x0089, 0x008B, 0x0095, 0x0097, 0x009D, 0x00A3, 0x00A7, 0x00AD, + 0x00B3, 0x00B5, 0x00BF, 0x00C1, 0x00C5, 0x00C7, 0x00D3, 0x00DF, + 0x00E3, 0x00E5, 0x00E9, 0x00EF, 0x00F1, 0x00FB, 0x0101, 0x0107, + 0x010D, 0x010F, 0x0115, 0x0119, 0x011B, 0x0125, 0x0133, 0x0137, + + 0x0139, 0x013D, 0x014B, 0x0151, 0x015B, 0x015D, 0x0161, 0x0167, + 0x016F, 0x0175, 0x017B, 0x017F, 0x0185, 0x018D, 0x0191, 0x0199, + 0x01A3, 0x01A5, 0x01AF, 0x01B1, 0x01B7, 0x01BB, 0x01C1, 0x01C9, + 0x01CD, 0x01CF, 0x01D3, 0x01DF, 0x01E7, 0x01EB, 0x01F3, 0x01F7, + 0x01FD, 0x0209, 0x020B, 0x021D, 0x0223, 0x022D, 0x0233, 0x0239, + 0x023B, 0x0241, 0x024B, 0x0251, 0x0257, 0x0259, 0x025F, 0x0265, + 0x0269, 0x026B, 0x0277, 0x0281, 0x0283, 0x0287, 0x028D, 0x0293, + 0x0295, 0x02A1, 0x02A5, 0x02AB, 0x02B3, 0x02BD, 0x02C5, 0x02CF, + + 0x02D7, 0x02DD, 0x02E3, 0x02E7, 0x02EF, 0x02F5, 0x02F9, 0x0301, + 0x0305, 0x0313, 0x031D, 0x0329, 0x032B, 0x0335, 0x0337, 0x033B, + 0x033D, 0x0347, 0x0355, 0x0359, 0x035B, 0x035F, 0x036D, 0x0371, + 0x0373, 0x0377, 0x038B, 0x038F, 0x0397, 0x03A1, 0x03A9, 0x03AD, + 0x03B3, 0x03B9, 0x03C7, 0x03CB, 0x03D1, 0x03D7, 0x03DF, 0x03E5, + 0x03F1, 0x03F5, 0x03FB, 0x03FD, 0x0407, 0x0409, 0x040F, 0x0419, + 0x041B, 0x0425, 0x0427, 0x042D, 0x043F, 0x0443, 0x0445, 0x0449, + 0x044F, 0x0455, 0x045D, 0x0463, 0x0469, 0x047F, 0x0481, 0x048B, + + 0x0493, 0x049D, 0x04A3, 0x04A9, 0x04B1, 0x04BD, 0x04C1, 0x04C7, + 0x04CD, 0x04CF, 0x04D5, 0x04E1, 0x04EB, 0x04FD, 0x04FF, 0x0503, + 0x0509, 0x050B, 0x0511, 0x0515, 0x0517, 0x051B, 0x0527, 0x0529, + 0x052F, 0x0551, 0x0557, 0x055D, 0x0565, 0x0577, 0x0581, 0x058F, + 0x0593, 0x0595, 0x0599, 0x059F, 0x05A7, 0x05AB, 0x05AD, 0x05B3, + 0x05BF, 0x05C9, 0x05CB, 0x05CF, 0x05D1, 0x05D5, 0x05DB, 0x05E7, + 0x05F3, 0x05FB, 0x0607, 0x060D, 0x0611, 0x0617, 0x061F, 0x0623, + 0x062B, 0x062F, 0x063D, 0x0641, 0x0647, 0x0649, 0x064D, 0x0653 +#endif +}; +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_prime_tab.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/bn_reverse.c Index: libtommath/bn_reverse.c ================================================================== --- /dev/null +++ libtommath/bn_reverse.c @@ -0,0 +1,39 @@ +#include +#ifdef BN_REVERSE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* reverse an array, used for radix code */ +void +bn_reverse (unsigned char *s, int len) +{ + int ix, iy; + unsigned char t; + + ix = 0; + iy = len - 1; + while (ix < iy) { + t = s[ix]; + s[ix] = s[iy]; + s[iy] = t; + ++ix; + --iy; + } +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_reverse.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/bn_s_mp_add.c Index: libtommath/bn_s_mp_add.c ================================================================== --- /dev/null +++ libtommath/bn_s_mp_add.c @@ -0,0 +1,109 @@ +#include +#ifdef BN_S_MP_ADD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* low level addition, based on HAC pp.594, Algorithm 14.7 */ +int +s_mp_add (mp_int * a, mp_int * b, mp_int * c) +{ + mp_int *x; + int olduse, res, min, max; + + /* find sizes, we let |a| <= |b| which means we have to sort + * them. "x" will point to the input with the most digits + */ + if (a->used > b->used) { + min = b->used; + max = a->used; + x = a; + } else { + min = a->used; + max = b->used; + x = b; + } + + /* init result */ + if (c->alloc < max + 1) { + if ((res = mp_grow (c, max + 1)) != MP_OKAY) { + return res; + } + } + + /* get old used digit count and set new one */ + olduse = c->used; + c->used = max + 1; + + { + register mp_digit u, *tmpa, *tmpb, *tmpc; + register int i; + + /* alias for digit pointers */ + + /* first input */ + tmpa = a->dp; + + /* second input */ + tmpb = b->dp; + + /* destination */ + tmpc = c->dp; + + /* zero the carry */ + u = 0; + for (i = 0; i < min; i++) { + /* Compute the sum at one digit, T[i] = A[i] + B[i] + U */ + *tmpc = *tmpa++ + *tmpb++ + u; + + /* U = carry bit of T[i] */ + u = *tmpc >> ((mp_digit)DIGIT_BIT); + + /* take away carry bit from T[i] */ + *tmpc++ &= MP_MASK; + } + + /* now copy higher words if any, that is in A+B + * if A or B has more digits add those in + */ + if (min != max) { + for (; i < max; i++) { + /* T[i] = X[i] + U */ + *tmpc = x->dp[i] + u; + + /* U = carry bit of T[i] */ + u = *tmpc >> ((mp_digit)DIGIT_BIT); + + /* take away carry bit from T[i] */ + *tmpc++ &= MP_MASK; + } + } + + /* add carry */ + *tmpc++ = u; + + /* clear digits above oldused */ + for (i = c->used; i < olduse; i++) { + *tmpc++ = 0; + } + } + + mp_clamp (c); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_s_mp_add.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/bn_s_mp_exptmod.c Index: libtommath/bn_s_mp_exptmod.c ================================================================== --- /dev/null +++ libtommath/bn_s_mp_exptmod.c @@ -0,0 +1,252 @@ +#include +#ifdef BN_S_MP_EXPTMOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ +#ifdef MP_LOW_MEM + #define TAB_SIZE 32 +#else + #define TAB_SIZE 256 +#endif + +int s_mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y, int redmode) +{ + mp_int M[TAB_SIZE], res, mu; + mp_digit buf; + int err, bitbuf, bitcpy, bitcnt, mode, digidx, x, y, winsize; + int (*redux)(mp_int*,mp_int*,mp_int*); + + /* find window size */ + x = mp_count_bits (X); + if (x <= 7) { + winsize = 2; + } else if (x <= 36) { + winsize = 3; + } else if (x <= 140) { + winsize = 4; + } else if (x <= 450) { + winsize = 5; + } else if (x <= 1303) { + winsize = 6; + } else if (x <= 3529) { + winsize = 7; + } else { + winsize = 8; + } + +#ifdef MP_LOW_MEM + if (winsize > 5) { + winsize = 5; + } +#endif + + /* init M array */ + /* init first cell */ + if ((err = mp_init(&M[1])) != MP_OKAY) { + return err; + } + + /* now init the second half of the array */ + for (x = 1<<(winsize-1); x < (1 << winsize); x++) { + if ((err = mp_init(&M[x])) != MP_OKAY) { + for (y = 1<<(winsize-1); y < x; y++) { + mp_clear (&M[y]); + } + mp_clear(&M[1]); + return err; + } + } + + /* create mu, used for Barrett reduction */ + if ((err = mp_init (&mu)) != MP_OKAY) { + goto LBL_M; + } + + if (redmode == 0) { + if ((err = mp_reduce_setup (&mu, P)) != MP_OKAY) { + goto LBL_MU; + } + redux = mp_reduce; + } else { + if ((err = mp_reduce_2k_setup_l (P, &mu)) != MP_OKAY) { + goto LBL_MU; + } + redux = mp_reduce_2k_l; + } + + /* create M table + * + * The M table contains powers of the base, + * e.g. M[x] = G**x mod P + * + * The first half of the table is not + * computed though accept for M[0] and M[1] + */ + if ((err = mp_mod (G, P, &M[1])) != MP_OKAY) { + goto LBL_MU; + } + + /* compute the value at M[1<<(winsize-1)] by squaring + * M[1] (winsize-1) times + */ + if ((err = mp_copy (&M[1], &M[1 << (winsize - 1)])) != MP_OKAY) { + goto LBL_MU; + } + + for (x = 0; x < (winsize - 1); x++) { + /* square it */ + if ((err = mp_sqr (&M[1 << (winsize - 1)], + &M[1 << (winsize - 1)])) != MP_OKAY) { + goto LBL_MU; + } + + /* reduce modulo P */ + if ((err = redux (&M[1 << (winsize - 1)], P, &mu)) != MP_OKAY) { + goto LBL_MU; + } + } + + /* create upper table, that is M[x] = M[x-1] * M[1] (mod P) + * for x = (2**(winsize - 1) + 1) to (2**winsize - 1) + */ + for (x = (1 << (winsize - 1)) + 1; x < (1 << winsize); x++) { + if ((err = mp_mul (&M[x - 1], &M[1], &M[x])) != MP_OKAY) { + goto LBL_MU; + } + if ((err = redux (&M[x], P, &mu)) != MP_OKAY) { + goto LBL_MU; + } + } + + /* setup result */ + if ((err = mp_init (&res)) != MP_OKAY) { + goto LBL_MU; + } + mp_set (&res, 1); + + /* set initial mode and bit cnt */ + mode = 0; + bitcnt = 1; + buf = 0; + digidx = X->used - 1; + bitcpy = 0; + bitbuf = 0; + + for (;;) { + /* grab next digit as required */ + if (--bitcnt == 0) { + /* if digidx == -1 we are out of digits */ + if (digidx == -1) { + break; + } + /* read next digit and reset the bitcnt */ + buf = X->dp[digidx--]; + bitcnt = (int) DIGIT_BIT; + } + + /* grab the next msb from the exponent */ + y = (buf >> (mp_digit)(DIGIT_BIT - 1)) & 1; + buf <<= (mp_digit)1; + + /* if the bit is zero and mode == 0 then we ignore it + * These represent the leading zero bits before the first 1 bit + * in the exponent. Technically this opt is not required but it + * does lower the # of trivial squaring/reductions used + */ + if (mode == 0 && y == 0) { + continue; + } + + /* if the bit is zero and mode == 1 then we square */ + if (mode == 1 && y == 0) { + if ((err = mp_sqr (&res, &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, &mu)) != MP_OKAY) { + goto LBL_RES; + } + continue; + } + + /* else we add it to the window */ + bitbuf |= (y << (winsize - ++bitcpy)); + mode = 2; + + if (bitcpy == winsize) { + /* ok window is filled so square as required and multiply */ + /* square first */ + for (x = 0; x < winsize; x++) { + if ((err = mp_sqr (&res, &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, &mu)) != MP_OKAY) { + goto LBL_RES; + } + } + + /* then multiply */ + if ((err = mp_mul (&res, &M[bitbuf], &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, &mu)) != MP_OKAY) { + goto LBL_RES; + } + + /* empty window and reset */ + bitcpy = 0; + bitbuf = 0; + mode = 1; + } + } + + /* if bits remain then square/multiply */ + if (mode == 2 && bitcpy > 0) { + /* square then multiply if the bit is set */ + for (x = 0; x < bitcpy; x++) { + if ((err = mp_sqr (&res, &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, &mu)) != MP_OKAY) { + goto LBL_RES; + } + + bitbuf <<= 1; + if ((bitbuf & (1 << winsize)) != 0) { + /* then multiply */ + if ((err = mp_mul (&res, &M[1], &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, &mu)) != MP_OKAY) { + goto LBL_RES; + } + } + } + } + + mp_exch (&res, Y); + err = MP_OKAY; +LBL_RES:mp_clear (&res); +LBL_MU:mp_clear (&mu); +LBL_M: + mp_clear(&M[1]); + for (x = 1<<(winsize-1); x < (1 << winsize); x++) { + mp_clear (&M[x]); + } + return err; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_s_mp_exptmod.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/bn_s_mp_mul_digs.c Index: libtommath/bn_s_mp_mul_digs.c ================================================================== --- /dev/null +++ libtommath/bn_s_mp_mul_digs.c @@ -0,0 +1,90 @@ +#include +#ifdef BN_S_MP_MUL_DIGS_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* multiplies |a| * |b| and only computes upto digs digits of result + * HAC pp. 595, Algorithm 14.12 Modified so you can control how + * many digits of output are created. + */ +int s_mp_mul_digs (mp_int * a, mp_int * b, mp_int * c, int digs) +{ + mp_int t; + int res, pa, pb, ix, iy; + mp_digit u; + mp_word r; + mp_digit tmpx, *tmpt, *tmpy; + + /* can we use the fast multiplier? */ + if (((digs) < MP_WARRAY) && + MIN (a->used, b->used) < + (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) { + return fast_s_mp_mul_digs (a, b, c, digs); + } + + if ((res = mp_init_size (&t, digs)) != MP_OKAY) { + return res; + } + t.used = digs; + + /* compute the digits of the product directly */ + pa = a->used; + for (ix = 0; ix < pa; ix++) { + /* set the carry to zero */ + u = 0; + + /* limit ourselves to making digs digits of output */ + pb = MIN (b->used, digs - ix); + + /* setup some aliases */ + /* copy of the digit from a used within the nested loop */ + tmpx = a->dp[ix]; + + /* an alias for the destination shifted ix places */ + tmpt = t.dp + ix; + + /* an alias for the digits of b */ + tmpy = b->dp; + + /* compute the columns of the output and propagate the carry */ + for (iy = 0; iy < pb; iy++) { + /* compute the column as a mp_word */ + r = ((mp_word)*tmpt) + + ((mp_word)tmpx) * ((mp_word)*tmpy++) + + ((mp_word) u); + + /* the new column is the lower part of the result */ + *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK)); + + /* get the carry word from the result */ + u = (mp_digit) (r >> ((mp_word) DIGIT_BIT)); + } + /* set carry if it is placed below digs */ + if (ix + iy < digs) { + *tmpt = u; + } + } + + mp_clamp (&t); + mp_exch (&t, c); + + mp_clear (&t); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_s_mp_mul_digs.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/bn_s_mp_mul_high_digs.c Index: libtommath/bn_s_mp_mul_high_digs.c ================================================================== --- /dev/null +++ libtommath/bn_s_mp_mul_high_digs.c @@ -0,0 +1,81 @@ +#include +#ifdef BN_S_MP_MUL_HIGH_DIGS_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* multiplies |a| * |b| and does not compute the lower digs digits + * [meant to get the higher part of the product] + */ +int +s_mp_mul_high_digs (mp_int * a, mp_int * b, mp_int * c, int digs) +{ + mp_int t; + int res, pa, pb, ix, iy; + mp_digit u; + mp_word r; + mp_digit tmpx, *tmpt, *tmpy; + + /* can we use the fast multiplier? */ +#ifdef BN_FAST_S_MP_MUL_HIGH_DIGS_C + if (((a->used + b->used + 1) < MP_WARRAY) + && MIN (a->used, b->used) < (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) { + return fast_s_mp_mul_high_digs (a, b, c, digs); + } +#endif + + if ((res = mp_init_size (&t, a->used + b->used + 1)) != MP_OKAY) { + return res; + } + t.used = a->used + b->used + 1; + + pa = a->used; + pb = b->used; + for (ix = 0; ix < pa; ix++) { + /* clear the carry */ + u = 0; + + /* left hand side of A[ix] * B[iy] */ + tmpx = a->dp[ix]; + + /* alias to the address of where the digits will be stored */ + tmpt = &(t.dp[digs]); + + /* alias for where to read the right hand side from */ + tmpy = b->dp + (digs - ix); + + for (iy = digs - ix; iy < pb; iy++) { + /* calculate the double precision result */ + r = ((mp_word)*tmpt) + + ((mp_word)tmpx) * ((mp_word)*tmpy++) + + ((mp_word) u); + + /* get the lower part */ + *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK)); + + /* carry the carry */ + u = (mp_digit) (r >> ((mp_word) DIGIT_BIT)); + } + *tmpt = u; + } + mp_clamp (&t); + mp_exch (&t, c); + mp_clear (&t); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_s_mp_mul_high_digs.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/bn_s_mp_sqr.c Index: libtommath/bn_s_mp_sqr.c ================================================================== --- /dev/null +++ libtommath/bn_s_mp_sqr.c @@ -0,0 +1,84 @@ +#include +#ifdef BN_S_MP_SQR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* low level squaring, b = a*a, HAC pp.596-597, Algorithm 14.16 */ +int s_mp_sqr (mp_int * a, mp_int * b) +{ + mp_int t; + int res, ix, iy, pa; + mp_word r; + mp_digit u, tmpx, *tmpt; + + pa = a->used; + if ((res = mp_init_size (&t, 2*pa + 1)) != MP_OKAY) { + return res; + } + + /* default used is maximum possible size */ + t.used = 2*pa + 1; + + for (ix = 0; ix < pa; ix++) { + /* first calculate the digit at 2*ix */ + /* calculate double precision result */ + r = ((mp_word) t.dp[2*ix]) + + ((mp_word)a->dp[ix])*((mp_word)a->dp[ix]); + + /* store lower part in result */ + t.dp[ix+ix] = (mp_digit) (r & ((mp_word) MP_MASK)); + + /* get the carry */ + u = (mp_digit)(r >> ((mp_word) DIGIT_BIT)); + + /* left hand side of A[ix] * A[iy] */ + tmpx = a->dp[ix]; + + /* alias for where to store the results */ + tmpt = t.dp + (2*ix + 1); + + for (iy = ix + 1; iy < pa; iy++) { + /* first calculate the product */ + r = ((mp_word)tmpx) * ((mp_word)a->dp[iy]); + + /* now calculate the double precision result, note we use + * addition instead of *2 since it's easier to optimize + */ + r = ((mp_word) *tmpt) + r + r + ((mp_word) u); + + /* store lower part */ + *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK)); + + /* get carry */ + u = (mp_digit)(r >> ((mp_word) DIGIT_BIT)); + } + /* propagate upwards */ + while (u != ((mp_digit) 0)) { + r = ((mp_word) *tmpt) + ((mp_word) u); + *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK)); + u = (mp_digit)(r >> ((mp_word) DIGIT_BIT)); + } + } + + mp_clamp (&t); + mp_exch (&t, b); + mp_clear (&t); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_s_mp_sqr.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/bn_s_mp_sub.c Index: libtommath/bn_s_mp_sub.c ================================================================== --- /dev/null +++ libtommath/bn_s_mp_sub.c @@ -0,0 +1,89 @@ +#include +#ifdef BN_S_MP_SUB_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* low level subtraction (assumes |a| > |b|), HAC pp.595 Algorithm 14.9 */ +int +s_mp_sub (mp_int * a, mp_int * b, mp_int * c) +{ + int olduse, res, min, max; + + /* find sizes */ + min = b->used; + max = a->used; + + /* init result */ + if (c->alloc < max) { + if ((res = mp_grow (c, max)) != MP_OKAY) { + return res; + } + } + olduse = c->used; + c->used = max; + + { + register mp_digit u, *tmpa, *tmpb, *tmpc; + register int i; + + /* alias for digit pointers */ + tmpa = a->dp; + tmpb = b->dp; + tmpc = c->dp; + + /* set carry to zero */ + u = 0; + for (i = 0; i < min; i++) { + /* T[i] = A[i] - B[i] - U */ + *tmpc = *tmpa++ - *tmpb++ - u; + + /* U = carry bit of T[i] + * Note this saves performing an AND operation since + * if a carry does occur it will propagate all the way to the + * MSB. As a result a single shift is enough to get the carry + */ + u = *tmpc >> ((mp_digit)(CHAR_BIT * sizeof (mp_digit) - 1)); + + /* Clear carry from T[i] */ + *tmpc++ &= MP_MASK; + } + + /* now copy higher words if any, e.g. if A has more digits than B */ + for (; i < max; i++) { + /* T[i] = A[i] - U */ + *tmpc = *tmpa++ - u; + + /* U = carry bit of T[i] */ + u = *tmpc >> ((mp_digit)(CHAR_BIT * sizeof (mp_digit) - 1)); + + /* Clear carry from T[i] */ + *tmpc++ &= MP_MASK; + } + + /* clear digits above used (since we may not have grown result above) */ + for (i = c->used; i < olduse; i++) { + *tmpc++ = 0; + } + } + + mp_clamp (c); + return MP_OKAY; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_s_mp_sub.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/bncore.c Index: libtommath/bncore.c ================================================================== --- /dev/null +++ libtommath/bncore.c @@ -0,0 +1,36 @@ +#include +#ifdef BNCORE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* Known optimal configurations + + CPU /Compiler /MUL CUTOFF/SQR CUTOFF +------------------------------------------------------------- + Intel P4 Northwood /GCC v3.4.1 / 88/ 128/LTM 0.32 ;-) + AMD Athlon64 /GCC v3.4.4 / 80/ 120/LTM 0.35 + +*/ + +int KARATSUBA_MUL_CUTOFF = 80, /* Min. number of digits before Karatsuba multiplication is used. */ + KARATSUBA_SQR_CUTOFF = 120, /* Min. number of digits before Karatsuba squaring is used. */ + + TOOM_MUL_CUTOFF = 350, /* no optimal values of these are known yet so set em high */ + TOOM_SQR_CUTOFF = 400; +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bncore.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/booker.pl Index: libtommath/booker.pl ================================================================== --- /dev/null +++ libtommath/booker.pl @@ -0,0 +1,265 @@ +#!/bin/perl +# +#Used to prepare the book "tommath.src" for LaTeX by pre-processing it into a .tex file +# +#Essentially you write the "tommath.src" as normal LaTex except where you want code snippets you put +# +#EXAM,file +# +#This preprocessor will then open "file" and insert it as a verbatim copy. +# +#Tom St Denis + +#get graphics type +if (shift =~ /PDF/) { + $graph = ""; +} else { + $graph = ".ps"; +} + +open(IN,"tommath.tex") or die "Can't open destination file"; + +print "Scanning for sections\n"; +$chapter = $section = $subsection = 0; +$x = 0; +while () { + print "."; + if (!(++$x % 80)) { print "\n"; } + #update the headings + if (~($_ =~ /\*/)) { + if ($_ =~ /\\chapter{.+}/) { + ++$chapter; + $section = $subsection = 0; + } elsif ($_ =~ /\\section{.+}/) { + ++$section; + $subsection = 0; + } elsif ($_ =~ /\\subsection{.+}/) { + ++$subsection; + } + } + + if ($_ =~ m/MARK/) { + @m = split(",",$_); + chomp(@m[1]); + $index1{@m[1]} = $chapter; + $index2{@m[1]} = $section; + $index3{@m[1]} = $subsection; + } +} +close(IN); + +open(IN,") { + ++$readline; + ++$srcline; + + if ($_ =~ m/MARK/) { + } elsif ($_ =~ m/EXAM/ || $_ =~ m/LIST/) { + if ($_ =~ m/EXAM/) { + $skipheader = 1; + } else { + $skipheader = 0; + } + + # EXAM,file + chomp($_); + @m = split(",",$_); + open(SRC,"<$m[1]") or die "Error:$srcline:Can't open source file $m[1]"; + + print "$srcline:Inserting $m[1]:"; + + $line = 0; + $tmp = $m[1]; + $tmp =~ s/_/"\\_"/ge; + print OUT "\\vspace{+3mm}\\begin{small}\n\\hspace{-5.1mm}{\\bf File}: $tmp\n\\vspace{-3mm}\n\\begin{alltt}\n"; + $wroteline += 5; + + if ($skipheader == 1) { + # scan till next end of comment, e.g. skip license + while () { + $text[$line++] = $_; + last if ($_ =~ /math\.libtomcrypt\.org/); + } + ; + } + + $inline = 0; + while () { + next if ($_ =~ /\$Source/); + next if ($_ =~ /\$Revision/); + next if ($_ =~ /\$Date/); + $text[$line++] = $_; + ++$inline; + chomp($_); + $_ =~ s/\t/" "/ge; + $_ =~ s/{/"^{"/ge; + $_ =~ s/}/"^}"/ge; + $_ =~ s/\\/'\symbol{92}'/ge; + $_ =~ s/\^/"\\"/ge; + + printf OUT ("%03d ", $line); + for ($x = 0; $x < length($_); $x++) { + print OUT chr(vec($_, $x, 8)); + if ($x == 75) { + print OUT "\n "; + ++$wroteline; + } + } + print OUT "\n"; + ++$wroteline; + } + $totlines = $line; + print OUT "\\end{alltt}\n\\end{small}\n"; + close(SRC); + print "$inline lines\n"; + $wroteline += 2; + } elsif ($_ =~ m/@\d+,.+@/) { + # line contains [number,text] + # e.g. @14,for (ix = 0)@ + $txt = $_; + while ($txt =~ m/@\d+,.+@/) { + @m = split("@",$txt); # splits into text, one, two + @parms = split(",",$m[1]); # splits one,two into two elements + + # now search from $parms[0] down for $parms[1] + $found1 = 0; + $found2 = 0; + for ($i = $parms[0]; $i < $totlines && $found1 == 0; $i++) { + if ($text[$i] =~ m/\Q$parms[1]\E/) { + $foundline1 = $i + 1; + $found1 = 1; + } + } + + # now search backwards + for ($i = $parms[0] - 1; $i >= 0 && $found2 == 0; $i--) { + if ($text[$i] =~ m/\Q$parms[1]\E/) { + $foundline2 = $i + 1; + $found2 = 1; + } + } + + # now use the closest match or the first if tied + if ($found1 == 1 && $found2 == 0) { + $found = 1; + $foundline = $foundline1; + } elsif ($found1 == 0 && $found2 == 1) { + $found = 1; + $foundline = $foundline2; + } elsif ($found1 == 1 && $found2 == 1) { + $found = 1; + if (($foundline1 - $parms[0]) <= ($parms[0] - $foundline2)) { + $foundline = $foundline1; + } else { + $foundline = $foundline2; + } + } else { + $found = 0; + } + + # if found replace + if ($found == 1) { + $delta = $parms[0] - $foundline; + print "Found replacement tag for \"$parms[1]\" on line $srcline which refers to line $foundline (delta $delta)\n"; + $_ =~ s/@\Q$m[1]\E@/$foundline/; + } else { + print "ERROR: The tag \"$parms[1]\" on line $srcline was not found in the most recently parsed source!\n"; + } + + # remake the rest of the line + $cnt = @m; + $txt = ""; + for ($i = 2; $i < $cnt; $i++) { + $txt = $txt . $m[$i] . "@"; + } + } + print OUT $_; + ++$wroteline; + } elsif ($_ =~ /~.+~/) { + # line contains a ~text~ pair used to refer to indexing :-) + $txt = $_; + while ($txt =~ /~.+~/) { + @m = split("~", $txt); + + # word is the second position + $word = @m[1]; + $a = $index1{$word}; + $b = $index2{$word}; + $c = $index3{$word}; + + # if chapter (a) is zero it wasn't found + if ($a == 0) { + print "ERROR: the tag \"$word\" on line $srcline was not found previously marked.\n"; + } else { + # format the tag as x, x.y or x.y.z depending on the values + $str = $a; + $str = $str . ".$b" if ($b != 0); + $str = $str . ".$c" if ($c != 0); + + if ($b == 0 && $c == 0) { + # its a chapter + if ($a <= 10) { + if ($a == 1) { + $str = "chapter one"; + } elsif ($a == 2) { + $str = "chapter two"; + } elsif ($a == 3) { + $str = "chapter three"; + } elsif ($a == 4) { + $str = "chapter four"; + } elsif ($a == 5) { + $str = "chapter five"; + } elsif ($a == 6) { + $str = "chapter six"; + } elsif ($a == 7) { + $str = "chapter seven"; + } elsif ($a == 8) { + $str = "chapter eight"; + } elsif ($a == 9) { + $str = "chapter nine"; + } elsif ($a == 2) { + $str = "chapter ten"; + } + } else { + $str = "chapter " . $str; + } + } else { + $str = "section " . $str if ($b != 0 && $c == 0); + $str = "sub-section " . $str if ($b != 0 && $c != 0); + } + + #substitute + $_ =~ s/~\Q$word\E~/$str/; + + print "Found replacement tag for marker \"$word\" on line $srcline which refers to $str\n"; + } + + # remake rest of the line + $cnt = @m; + $txt = ""; + for ($i = 2; $i < $cnt; $i++) { + $txt = $txt . $m[$i] . "~"; + } + } + print OUT $_; + ++$wroteline; + } elsif ($_ =~ m/FIGU/) { + # FIGU,file,caption + chomp($_); + @m = split(",", $_); + print OUT "\\begin{center}\n\\begin{figure}[here]\n\\includegraphics{pics/$m[1]$graph}\n"; + print OUT "\\caption{$m[2]}\n\\label{pic:$m[1]}\n\\end{figure}\n\\end{center}\n"; + $wroteline += 4; + } else { + print OUT $_; + ++$wroteline; + } +} +print "Read $readline lines, wrote $wroteline lines\n"; + +close (OUT); +close (IN); ADDED libtommath/callgraph.txt Index: libtommath/callgraph.txt ================================================================== --- /dev/null +++ libtommath/callgraph.txt @@ -0,0 +1,11913 @@ +BN_PRIME_TAB_C + + +BN_MP_SQRT_C ++--->BN_MP_N_ROOT_C +| +--->BN_MP_INIT_C +| +--->BN_MP_SET_C +| | +--->BN_MP_ZERO_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_EXPT_D_C +| | +--->BN_MP_INIT_COPY_C +| | +--->BN_MP_SQR_C +| | | +--->BN_MP_TOOM_SQR_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_MUL_2_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_2_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_3_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLEAR_MULTI_C +| | | | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_KARATSUBA_SQR_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLEAR_C +| | | +--->BN_FAST_S_MP_SQR_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SQR_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_CLEAR_C +| | +--->BN_MP_MUL_C +| | | +--->BN_MP_TOOM_MUL_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_MUL_2_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_2_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_3_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLEAR_MULTI_C +| | | +--->BN_MP_KARATSUBA_MUL_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_MUL_DIGS_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| +--->BN_MP_MUL_C +| | +--->BN_MP_TOOM_MUL_C +| | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_MUL_2_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_2_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MUL_2D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MUL_D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_3_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLEAR_MULTI_C +| | | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_KARATSUBA_MUL_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_S_MP_MUL_DIGS_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_C +| +--->BN_MP_SUB_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_MUL_D_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_DIV_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_COUNT_BITS_C +| | +--->BN_MP_ABS_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2D_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_MULTI_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_INIT_COPY_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_CMP_C +| | +--->BN_MP_CMP_MAG_C +| +--->BN_MP_SUB_D_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_D_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_ZERO_C ++--->BN_MP_INIT_COPY_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C ++--->BN_MP_RSHD_C ++--->BN_MP_DIV_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_INIT_MULTI_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_SET_C +| +--->BN_MP_COUNT_BITS_C +| +--->BN_MP_ABS_C +| +--->BN_MP_MUL_2D_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_LSHD_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_C +| +--->BN_MP_SUB_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_ADD_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_DIV_2D_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLEAR_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| +--->BN_MP_EXCH_C +| +--->BN_MP_CLEAR_MULTI_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_INIT_SIZE_C +| +--->BN_MP_LSHD_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_MUL_D_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_ADD_C +| +--->BN_S_MP_ADD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C ++--->BN_MP_DIV_2_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_CMP_MAG_C ++--->BN_MP_EXCH_C ++--->BN_MP_CLEAR_C + + +BN_MP_CMP_D_C + + +BN_MP_EXCH_C + + +BN_MP_IS_SQUARE_C ++--->BN_MP_MOD_D_C +| +--->BN_MP_DIV_D_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_DIV_2D_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_INIT_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_DIV_3_C +| | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_INIT_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_INIT_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C ++--->BN_MP_INIT_SET_INT_C +| +--->BN_MP_INIT_C +| +--->BN_MP_SET_INT_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLAMP_C ++--->BN_MP_MOD_C +| +--->BN_MP_INIT_C +| +--->BN_MP_DIV_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_SET_C +| | +--->BN_MP_COUNT_BITS_C +| | +--->BN_MP_ABS_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2D_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_MULTI_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_INIT_COPY_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_CLEAR_C +| +--->BN_MP_ADD_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C ++--->BN_MP_GET_INT_C ++--->BN_MP_SQRT_C +| +--->BN_MP_N_ROOT_C +| | +--->BN_MP_INIT_C +| | +--->BN_MP_SET_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_EXPT_D_C +| | | +--->BN_MP_INIT_COPY_C +| | | +--->BN_MP_SQR_C +| | | | +--->BN_MP_TOOM_SQR_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | | +--->BN_MP_CLEAR_C +| | | | | +--->BN_MP_MOD_2D_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_MUL_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_3_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | | +--->BN_MP_CLEAR_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLEAR_MULTI_C +| | | | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_KARATSUBA_SQR_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_FAST_S_MP_SQR_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_SQR_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_MUL_C +| | | | +--->BN_MP_TOOM_MUL_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_MOD_2D_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_MUL_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_3_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLEAR_MULTI_C +| | | | +--->BN_MP_KARATSUBA_MUL_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_MUL_DIGS_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | +--->BN_MP_MUL_C +| | | +--->BN_MP_TOOM_MUL_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_MUL_2_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_2_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_3_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLEAR_MULTI_C +| | | | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_KARATSUBA_MUL_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_CLEAR_C +| | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_MUL_DIGS_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_COUNT_BITS_C +| | | +--->BN_MP_ABS_C +| | | +--->BN_MP_MUL_2D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_2D_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_MULTI_C +| | | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_INIT_COPY_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_CMP_C +| | | +--->BN_MP_CMP_MAG_C +| | +--->BN_MP_SUB_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ADD_D_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_ZERO_C +| +--->BN_MP_INIT_COPY_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| +--->BN_MP_RSHD_C +| +--->BN_MP_DIV_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_SET_C +| | +--->BN_MP_COUNT_BITS_C +| | +--->BN_MP_ABS_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2D_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_MULTI_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_ADD_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_DIV_2_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_MP_EXCH_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_SQR_C +| +--->BN_MP_TOOM_SQR_C +| | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_INIT_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_RSHD_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_MUL_2_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_3_C +| | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_INIT_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLEAR_MULTI_C +| | | +--->BN_MP_CLEAR_C +| +--->BN_MP_KARATSUBA_SQR_C +| | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_INIT_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| | +--->BN_MP_ADD_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLEAR_C +| +--->BN_FAST_S_MP_SQR_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_S_MP_SQR_C +| | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_INIT_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C ++--->BN_MP_CMP_MAG_C ++--->BN_MP_CLEAR_C + + +BN_MP_NEG_C ++--->BN_MP_COPY_C +| +--->BN_MP_GROW_C + + +BN_MP_EXPTMOD_C ++--->BN_MP_INIT_C ++--->BN_MP_INVMOD_C +| +--->BN_FAST_MP_INVMOD_C +| | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_MOD_C +| | | +--->BN_MP_DIV_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_SET_C +| | | | +--->BN_MP_COUNT_BITS_C +| | | | +--->BN_MP_ABS_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_2D_C +| | | | | +--->BN_MP_MOD_2D_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CLEAR_C +| | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_CLEAR_MULTI_C +| | | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_INIT_COPY_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_SET_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_DIV_2_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_C +| | | +--->BN_MP_CMP_MAG_C +| | +--->BN_MP_CMP_D_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_MULTI_C +| | | +--->BN_MP_CLEAR_C +| +--->BN_MP_INVMOD_SLOW_C +| | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_MOD_C +| | | +--->BN_MP_DIV_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_SET_C +| | | | +--->BN_MP_COUNT_BITS_C +| | | | +--->BN_MP_ABS_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_2D_C +| | | | | +--->BN_MP_MOD_2D_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CLEAR_C +| | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_CLEAR_MULTI_C +| | | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_INIT_COPY_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_SET_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_DIV_2_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_C +| | | +--->BN_MP_CMP_MAG_C +| | +--->BN_MP_CMP_D_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_MULTI_C +| | | +--->BN_MP_CLEAR_C ++--->BN_MP_CLEAR_C ++--->BN_MP_ABS_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C ++--->BN_MP_CLEAR_MULTI_C ++--->BN_MP_REDUCE_IS_2K_L_C ++--->BN_S_MP_EXPTMOD_C +| +--->BN_MP_COUNT_BITS_C +| +--->BN_MP_REDUCE_SETUP_C +| | +--->BN_MP_2EXPT_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_DIV_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_SET_C +| | | +--->BN_MP_MUL_2D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_2D_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_INIT_COPY_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_MUL_D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_REDUCE_C +| | +--->BN_MP_INIT_COPY_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_RSHD_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_MUL_C +| | | +--->BN_MP_TOOM_MUL_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_MUL_2_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_2_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_3_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_KARATSUBA_MUL_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_MUL_DIGS_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | +--->BN_S_MP_MUL_HIGH_DIGS_C +| | | +--->BN_FAST_S_MP_MUL_HIGH_DIGS_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_FAST_S_MP_MUL_HIGH_DIGS_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_S_MP_MUL_DIGS_C +| | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_D_C +| | +--->BN_MP_SET_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_C +| | | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_REDUCE_2K_SETUP_L_C +| | +--->BN_MP_2EXPT_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_GROW_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_REDUCE_2K_L_C +| | +--->BN_MP_DIV_2D_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_MUL_C +| | | +--->BN_MP_TOOM_MUL_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_MUL_2_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_2_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_3_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_KARATSUBA_MUL_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_MUL_DIGS_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_MOD_C +| | +--->BN_MP_DIV_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_SET_C +| | | +--->BN_MP_MUL_2D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_2D_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_INIT_COPY_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_MUL_D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_SQR_C +| | +--->BN_MP_TOOM_SQR_C +| | | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_MUL_2_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_2_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MUL_2D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MUL_D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_3_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_KARATSUBA_SQR_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | +--->BN_FAST_S_MP_SQR_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_S_MP_SQR_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| +--->BN_MP_MUL_C +| | +--->BN_MP_TOOM_MUL_C +| | | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_MUL_2_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_2_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MUL_2D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MUL_D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_3_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_KARATSUBA_MUL_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_S_MP_MUL_DIGS_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| +--->BN_MP_SET_C +| | +--->BN_MP_ZERO_C +| +--->BN_MP_EXCH_C ++--->BN_MP_DR_IS_MODULUS_C ++--->BN_MP_REDUCE_IS_2K_C +| +--->BN_MP_REDUCE_2K_C +| | +--->BN_MP_COUNT_BITS_C +| | +--->BN_MP_DIV_2D_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_COUNT_BITS_C ++--->BN_MP_EXPTMOD_FAST_C +| +--->BN_MP_COUNT_BITS_C +| +--->BN_MP_MONTGOMERY_SETUP_C +| +--->BN_FAST_MP_MONTGOMERY_REDUCE_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_RSHD_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| +--->BN_MP_MONTGOMERY_REDUCE_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_RSHD_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| +--->BN_MP_DR_SETUP_C +| +--->BN_MP_DR_REDUCE_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| +--->BN_MP_REDUCE_2K_SETUP_C +| | +--->BN_MP_2EXPT_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_GROW_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_REDUCE_2K_C +| | +--->BN_MP_DIV_2D_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_MONTGOMERY_CALC_NORMALIZATION_C +| | +--->BN_MP_2EXPT_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_SET_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_MUL_2_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_MULMOD_C +| | +--->BN_MP_MUL_C +| | | +--->BN_MP_TOOM_MUL_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_MUL_2_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_2_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_3_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_KARATSUBA_MUL_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_MUL_DIGS_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | +--->BN_MP_MOD_C +| | | +--->BN_MP_DIV_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_SET_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_2D_C +| | | | | +--->BN_MP_MOD_2D_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_INIT_COPY_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| +--->BN_MP_SET_C +| | +--->BN_MP_ZERO_C +| +--->BN_MP_MOD_C +| | +--->BN_MP_DIV_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_MUL_2D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_2D_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_INIT_COPY_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_MUL_D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_SQR_C +| | +--->BN_MP_TOOM_SQR_C +| | | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_MUL_2_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_2_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MUL_2D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MUL_D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_3_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_KARATSUBA_SQR_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | +--->BN_FAST_S_MP_SQR_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_S_MP_SQR_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| +--->BN_MP_MUL_C +| | +--->BN_MP_TOOM_MUL_C +| | | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_MUL_2_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_2_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MUL_2D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MUL_D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_3_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_KARATSUBA_MUL_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_S_MP_MUL_DIGS_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| +--->BN_MP_EXCH_C + + +BN_MP_OR_C ++--->BN_MP_INIT_COPY_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C ++--->BN_MP_CLAMP_C ++--->BN_MP_EXCH_C ++--->BN_MP_CLEAR_C + + +BN_MP_ZERO_C + + +BN_MP_GROW_C + + +BN_MP_COUNT_BITS_C + + +BN_MP_PRIME_FERMAT_C ++--->BN_MP_CMP_D_C ++--->BN_MP_INIT_C ++--->BN_MP_EXPTMOD_C +| +--->BN_MP_INVMOD_C +| | +--->BN_FAST_MP_INVMOD_C +| | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_MOD_C +| | | | +--->BN_MP_DIV_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_SET_C +| | | | | +--->BN_MP_COUNT_BITS_C +| | | | | +--->BN_MP_ABS_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_2D_C +| | | | | | +--->BN_MP_MOD_2D_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CLEAR_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_CLEAR_MULTI_C +| | | | | | +--->BN_MP_CLEAR_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_INIT_COPY_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_SET_C +| | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_DIV_2_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_MULTI_C +| | | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_INVMOD_SLOW_C +| | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_MOD_C +| | | | +--->BN_MP_DIV_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_SET_C +| | | | | +--->BN_MP_COUNT_BITS_C +| | | | | +--->BN_MP_ABS_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_2D_C +| | | | | | +--->BN_MP_MOD_2D_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CLEAR_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_CLEAR_MULTI_C +| | | | | | +--->BN_MP_CLEAR_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_INIT_COPY_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_SET_C +| | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_DIV_2_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_MULTI_C +| | | | +--->BN_MP_CLEAR_C +| +--->BN_MP_CLEAR_C +| +--->BN_MP_ABS_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| +--->BN_MP_CLEAR_MULTI_C +| +--->BN_MP_REDUCE_IS_2K_L_C +| +--->BN_S_MP_EXPTMOD_C +| | +--->BN_MP_COUNT_BITS_C +| | +--->BN_MP_REDUCE_SETUP_C +| | | +--->BN_MP_2EXPT_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_DIV_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_SET_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_2D_C +| | | | | +--->BN_MP_MOD_2D_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_INIT_COPY_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_REDUCE_C +| | | +--->BN_MP_INIT_COPY_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_MUL_C +| | | | +--->BN_MP_TOOM_MUL_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_MOD_2D_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_COPY_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_MUL_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_3_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_KARATSUBA_MUL_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_MUL_DIGS_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | +--->BN_S_MP_MUL_HIGH_DIGS_C +| | | | +--->BN_FAST_S_MP_MUL_HIGH_DIGS_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_FAST_S_MP_MUL_HIGH_DIGS_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_MUL_DIGS_C +| | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SET_C +| | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_REDUCE_2K_SETUP_L_C +| | | +--->BN_MP_2EXPT_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_REDUCE_2K_L_C +| | | +--->BN_MP_DIV_2D_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_MUL_C +| | | | +--->BN_MP_TOOM_MUL_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_MOD_2D_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_COPY_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_MUL_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_3_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_KARATSUBA_MUL_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_MUL_DIGS_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MOD_C +| | | +--->BN_MP_DIV_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_SET_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_2D_C +| | | | | +--->BN_MP_MOD_2D_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_INIT_COPY_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_SQR_C +| | | +--->BN_MP_TOOM_SQR_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_MUL_2_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_2_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_3_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_KARATSUBA_SQR_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | +--->BN_FAST_S_MP_SQR_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SQR_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | +--->BN_MP_MUL_C +| | | +--->BN_MP_TOOM_MUL_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_MUL_2_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_2_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_3_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_KARATSUBA_MUL_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_MUL_DIGS_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | +--->BN_MP_SET_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_EXCH_C +| +--->BN_MP_DR_IS_MODULUS_C +| +--->BN_MP_REDUCE_IS_2K_C +| | +--->BN_MP_REDUCE_2K_C +| | | +--->BN_MP_COUNT_BITS_C +| | | +--->BN_MP_DIV_2D_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_MUL_D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_COUNT_BITS_C +| +--->BN_MP_EXPTMOD_FAST_C +| | +--->BN_MP_COUNT_BITS_C +| | +--->BN_MP_MONTGOMERY_SETUP_C +| | +--->BN_FAST_MP_MONTGOMERY_REDUCE_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | +--->BN_MP_MONTGOMERY_REDUCE_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | +--->BN_MP_DR_SETUP_C +| | +--->BN_MP_DR_REDUCE_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | +--->BN_MP_REDUCE_2K_SETUP_C +| | | +--->BN_MP_2EXPT_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_REDUCE_2K_C +| | | +--->BN_MP_DIV_2D_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_MUL_D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MONTGOMERY_CALC_NORMALIZATION_C +| | | +--->BN_MP_2EXPT_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_SET_C +| | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_MUL_2_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MULMOD_C +| | | +--->BN_MP_MUL_C +| | | | +--->BN_MP_TOOM_MUL_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_MOD_2D_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_COPY_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_MUL_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_3_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_KARATSUBA_MUL_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_MUL_DIGS_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_MOD_C +| | | | +--->BN_MP_DIV_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_SET_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_2D_C +| | | | | | +--->BN_MP_MOD_2D_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_INIT_COPY_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | +--->BN_MP_SET_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_MOD_C +| | | +--->BN_MP_DIV_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_2D_C +| | | | | +--->BN_MP_MOD_2D_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_INIT_COPY_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_SQR_C +| | | +--->BN_MP_TOOM_SQR_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_MUL_2_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_2_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_3_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_KARATSUBA_SQR_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | +--->BN_FAST_S_MP_SQR_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SQR_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | +--->BN_MP_MUL_C +| | | +--->BN_MP_TOOM_MUL_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_MUL_2_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_2_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_3_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_KARATSUBA_MUL_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_MUL_DIGS_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | +--->BN_MP_EXCH_C ++--->BN_MP_CMP_C +| +--->BN_MP_CMP_MAG_C ++--->BN_MP_CLEAR_C + + +BN_MP_SUBMOD_C ++--->BN_MP_INIT_C ++--->BN_MP_SUB_C +| +--->BN_S_MP_ADD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C ++--->BN_MP_CLEAR_C ++--->BN_MP_MOD_C +| +--->BN_MP_DIV_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_INIT_MULTI_C +| | +--->BN_MP_SET_C +| | +--->BN_MP_COUNT_BITS_C +| | +--->BN_MP_ABS_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2D_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_MULTI_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_INIT_COPY_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_ADD_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C + + +BN_MP_MOD_2D_C ++--->BN_MP_ZERO_C ++--->BN_MP_COPY_C +| +--->BN_MP_GROW_C ++--->BN_MP_CLAMP_C + + +BN_MP_TORADIX_N_C ++--->BN_MP_INIT_COPY_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C ++--->BN_MP_DIV_D_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_DIV_2D_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLEAR_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| +--->BN_MP_DIV_3_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_INIT_SIZE_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_CLEAR_C + + +BN_MP_CMP_C ++--->BN_MP_CMP_MAG_C + + +BNCORE_C + + +BN_MP_TORADIX_C ++--->BN_MP_INIT_COPY_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C ++--->BN_MP_DIV_D_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_DIV_2D_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLEAR_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| +--->BN_MP_DIV_3_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_INIT_SIZE_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_CLEAR_C + + +BN_MP_ADD_D_C ++--->BN_MP_GROW_C ++--->BN_MP_SUB_D_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_CLAMP_C + + +BN_MP_DIV_3_C ++--->BN_MP_INIT_SIZE_C +| +--->BN_MP_INIT_C ++--->BN_MP_CLAMP_C ++--->BN_MP_EXCH_C ++--->BN_MP_CLEAR_C + + +BN_FAST_S_MP_MUL_DIGS_C ++--->BN_MP_GROW_C ++--->BN_MP_CLAMP_C + + +BN_MP_SQRMOD_C ++--->BN_MP_INIT_C ++--->BN_MP_SQR_C +| +--->BN_MP_TOOM_SQR_C +| | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_RSHD_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_MUL_2_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_3_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLEAR_MULTI_C +| | | +--->BN_MP_CLEAR_C +| +--->BN_MP_KARATSUBA_SQR_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| | +--->BN_MP_ADD_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLEAR_C +| +--->BN_FAST_S_MP_SQR_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_S_MP_SQR_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C ++--->BN_MP_CLEAR_C ++--->BN_MP_MOD_C +| +--->BN_MP_DIV_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_INIT_MULTI_C +| | +--->BN_MP_SET_C +| | +--->BN_MP_COUNT_BITS_C +| | +--->BN_MP_ABS_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2D_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_MULTI_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_INIT_COPY_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_ADD_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C + + +BN_MP_INVMOD_C ++--->BN_FAST_MP_INVMOD_C +| +--->BN_MP_INIT_MULTI_C +| | +--->BN_MP_INIT_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_MOD_C +| | +--->BN_MP_INIT_C +| | +--->BN_MP_DIV_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_SET_C +| | | +--->BN_MP_COUNT_BITS_C +| | | +--->BN_MP_ABS_C +| | | +--->BN_MP_MUL_2D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_2D_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_MULTI_C +| | | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_INIT_COPY_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_MUL_D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_CLEAR_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| +--->BN_MP_SET_C +| | +--->BN_MP_ZERO_C +| +--->BN_MP_DIV_2_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_SUB_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_C +| | +--->BN_MP_CMP_MAG_C +| +--->BN_MP_CMP_D_C +| +--->BN_MP_ADD_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C +| +--->BN_MP_CLEAR_MULTI_C +| | +--->BN_MP_CLEAR_C ++--->BN_MP_INVMOD_SLOW_C +| +--->BN_MP_INIT_MULTI_C +| | +--->BN_MP_INIT_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_MOD_C +| | +--->BN_MP_INIT_C +| | +--->BN_MP_DIV_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_SET_C +| | | +--->BN_MP_COUNT_BITS_C +| | | +--->BN_MP_ABS_C +| | | +--->BN_MP_MUL_2D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_2D_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_MULTI_C +| | | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_INIT_COPY_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_MUL_D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_CLEAR_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_SET_C +| | +--->BN_MP_ZERO_C +| +--->BN_MP_DIV_2_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_ADD_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_SUB_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_C +| | +--->BN_MP_CMP_MAG_C +| +--->BN_MP_CMP_D_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_MP_EXCH_C +| +--->BN_MP_CLEAR_MULTI_C +| | +--->BN_MP_CLEAR_C + + +BN_MP_AND_C ++--->BN_MP_INIT_COPY_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C ++--->BN_MP_CLAMP_C ++--->BN_MP_EXCH_C ++--->BN_MP_CLEAR_C + + +BN_MP_MUL_D_C ++--->BN_MP_GROW_C ++--->BN_MP_CLAMP_C + + +BN_FAST_MP_INVMOD_C ++--->BN_MP_INIT_MULTI_C +| +--->BN_MP_INIT_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_COPY_C +| +--->BN_MP_GROW_C ++--->BN_MP_MOD_C +| +--->BN_MP_INIT_C +| +--->BN_MP_DIV_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_SET_C +| | +--->BN_MP_COUNT_BITS_C +| | +--->BN_MP_ABS_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2D_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_MULTI_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_INIT_COPY_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_CLEAR_C +| +--->BN_MP_ADD_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C ++--->BN_MP_SET_C +| +--->BN_MP_ZERO_C ++--->BN_MP_DIV_2_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_SUB_C +| +--->BN_S_MP_ADD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C ++--->BN_MP_CMP_C +| +--->BN_MP_CMP_MAG_C ++--->BN_MP_CMP_D_C ++--->BN_MP_ADD_C +| +--->BN_S_MP_ADD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C ++--->BN_MP_EXCH_C ++--->BN_MP_CLEAR_MULTI_C +| +--->BN_MP_CLEAR_C + + +BN_MP_FWRITE_C ++--->BN_MP_RADIX_SIZE_C +| +--->BN_MP_COUNT_BITS_C +| +--->BN_MP_INIT_COPY_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| +--->BN_MP_DIV_D_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_DIV_2D_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_DIV_3_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_TORADIX_C +| +--->BN_MP_INIT_COPY_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| +--->BN_MP_DIV_D_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_DIV_2D_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_DIV_3_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_CLEAR_C + + +BN_S_MP_SQR_C ++--->BN_MP_INIT_SIZE_C +| +--->BN_MP_INIT_C ++--->BN_MP_CLAMP_C ++--->BN_MP_EXCH_C ++--->BN_MP_CLEAR_C + + +BN_MP_N_ROOT_C ++--->BN_MP_INIT_C ++--->BN_MP_SET_C +| +--->BN_MP_ZERO_C ++--->BN_MP_COPY_C +| +--->BN_MP_GROW_C ++--->BN_MP_EXPT_D_C +| +--->BN_MP_INIT_COPY_C +| +--->BN_MP_SQR_C +| | +--->BN_MP_TOOM_SQR_C +| | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_MUL_2_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_2_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MUL_2D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MUL_D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_3_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLEAR_MULTI_C +| | | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_KARATSUBA_SQR_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_FAST_S_MP_SQR_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_S_MP_SQR_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_C +| +--->BN_MP_CLEAR_C +| +--->BN_MP_MUL_C +| | +--->BN_MP_TOOM_MUL_C +| | | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_MUL_2_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_2_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MUL_2D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MUL_D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_3_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLEAR_MULTI_C +| | +--->BN_MP_KARATSUBA_MUL_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_S_MP_MUL_DIGS_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C ++--->BN_MP_MUL_C +| +--->BN_MP_TOOM_MUL_C +| | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_RSHD_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_MUL_2_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_3_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLEAR_MULTI_C +| | | +--->BN_MP_CLEAR_C +| +--->BN_MP_KARATSUBA_MUL_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| | +--->BN_MP_CLEAR_C +| +--->BN_FAST_S_MP_MUL_DIGS_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_S_MP_MUL_DIGS_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C ++--->BN_MP_SUB_C +| +--->BN_S_MP_ADD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C ++--->BN_MP_MUL_D_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_DIV_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_MP_ZERO_C +| +--->BN_MP_INIT_MULTI_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_COUNT_BITS_C +| +--->BN_MP_ABS_C +| +--->BN_MP_MUL_2D_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_C +| +--->BN_MP_ADD_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_DIV_2D_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLEAR_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| +--->BN_MP_EXCH_C +| +--->BN_MP_CLEAR_MULTI_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_INIT_SIZE_C +| +--->BN_MP_INIT_COPY_C +| +--->BN_MP_LSHD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_RSHD_C +| +--->BN_MP_RSHD_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_CMP_C +| +--->BN_MP_CMP_MAG_C ++--->BN_MP_SUB_D_C +| +--->BN_MP_GROW_C +| +--->BN_MP_ADD_D_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_EXCH_C ++--->BN_MP_CLEAR_C + + +BN_MP_PRIME_RABIN_MILLER_TRIALS_C + + +BN_MP_RADIX_SIZE_C ++--->BN_MP_COUNT_BITS_C ++--->BN_MP_INIT_COPY_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C ++--->BN_MP_DIV_D_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_DIV_2D_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLEAR_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| +--->BN_MP_DIV_3_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_INIT_SIZE_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_CLEAR_C + + +BN_MP_READ_SIGNED_BIN_C ++--->BN_MP_READ_UNSIGNED_BIN_C +| +--->BN_MP_GROW_C +| +--->BN_MP_ZERO_C +| +--->BN_MP_MUL_2D_C +| | +--->BN_MP_COPY_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CLAMP_C + + +BN_MP_PRIME_RANDOM_EX_C ++--->BN_MP_READ_UNSIGNED_BIN_C +| +--->BN_MP_GROW_C +| +--->BN_MP_ZERO_C +| +--->BN_MP_MUL_2D_C +| | +--->BN_MP_COPY_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_PRIME_IS_PRIME_C +| +--->BN_MP_CMP_D_C +| +--->BN_MP_PRIME_IS_DIVISIBLE_C +| | +--->BN_MP_MOD_D_C +| | | +--->BN_MP_DIV_D_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_DIV_2D_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_INIT_C +| | | | | +--->BN_MP_MOD_2D_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CLEAR_C +| | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_DIV_3_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_INIT_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_INIT_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_CLEAR_C +| +--->BN_MP_INIT_C +| +--->BN_MP_SET_C +| | +--->BN_MP_ZERO_C +| +--->BN_MP_PRIME_MILLER_RABIN_C +| | +--->BN_MP_INIT_COPY_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_SUB_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ADD_D_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CNT_LSB_C +| | +--->BN_MP_DIV_2D_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_EXPTMOD_C +| | | +--->BN_MP_INVMOD_C +| | | | +--->BN_FAST_MP_INVMOD_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | | +--->BN_MP_CLEAR_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_MOD_C +| | | | | | +--->BN_MP_DIV_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | | | +--->BN_MP_COUNT_BITS_C +| | | | | | | +--->BN_MP_ABS_C +| | | | | | | +--->BN_MP_MUL_2D_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_LSHD_C +| | | | | | | | | +--->BN_MP_RSHD_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CMP_C +| | | | | | | +--->BN_MP_SUB_C +| | | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_ADD_C +| | | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_EXCH_C +| | | | | | | +--->BN_MP_CLEAR_MULTI_C +| | | | | | | | +--->BN_MP_CLEAR_C +| | | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_MUL_D_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CLEAR_C +| | | | | | +--->BN_MP_CLEAR_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_DIV_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_CLEAR_MULTI_C +| | | | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_INVMOD_SLOW_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | | +--->BN_MP_CLEAR_C +| | | | | +--->BN_MP_MOD_C +| | | | | | +--->BN_MP_DIV_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_MP_COPY_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | | | +--->BN_MP_COUNT_BITS_C +| | | | | | | +--->BN_MP_ABS_C +| | | | | | | +--->BN_MP_MUL_2D_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_LSHD_C +| | | | | | | | | +--->BN_MP_RSHD_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CMP_C +| | | | | | | +--->BN_MP_SUB_C +| | | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_ADD_C +| | | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_EXCH_C +| | | | | | | +--->BN_MP_CLEAR_MULTI_C +| | | | | | | | +--->BN_MP_CLEAR_C +| | | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_MUL_D_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CLEAR_C +| | | | | | +--->BN_MP_CLEAR_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_DIV_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_CLEAR_MULTI_C +| | | | | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_ABS_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLEAR_MULTI_C +| | | +--->BN_MP_REDUCE_IS_2K_L_C +| | | +--->BN_S_MP_EXPTMOD_C +| | | | +--->BN_MP_COUNT_BITS_C +| | | | +--->BN_MP_REDUCE_SETUP_C +| | | | | +--->BN_MP_2EXPT_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_DIV_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_MP_COPY_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_INIT_MULTI_C +| | | | | | +--->BN_MP_MUL_2D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_MUL_D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_REDUCE_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_MUL_C +| | | | | | +--->BN_MP_TOOM_MUL_C +| | | | | | | +--->BN_MP_INIT_MULTI_C +| | | | | | | +--->BN_MP_MOD_2D_C +| | | | | | | | +--->BN_MP_ZERO_C +| | | | | | | | +--->BN_MP_COPY_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_COPY_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_MUL_2_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_ADD_C +| | | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_SUB_C +| | | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_DIV_2_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_MUL_2D_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_LSHD_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_MUL_D_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_DIV_3_C +| | | | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | | +--->BN_MP_EXCH_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_KARATSUBA_MUL_C +| | | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_SUB_C +| | | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_ADD_C +| | | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_MUL_DIGS_C +| | | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_S_MP_MUL_HIGH_DIGS_C +| | | | | | +--->BN_FAST_S_MP_MUL_HIGH_DIGS_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_FAST_S_MP_MUL_HIGH_DIGS_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MOD_2D_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_COPY_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_MUL_DIGS_C +| | | | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_REDUCE_2K_SETUP_L_C +| | | | | +--->BN_MP_2EXPT_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_REDUCE_2K_L_C +| | | | | +--->BN_MP_MUL_C +| | | | | | +--->BN_MP_TOOM_MUL_C +| | | | | | | +--->BN_MP_INIT_MULTI_C +| | | | | | | +--->BN_MP_MOD_2D_C +| | | | | | | | +--->BN_MP_ZERO_C +| | | | | | | | +--->BN_MP_COPY_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_COPY_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | | | +--->BN_MP_ZERO_C +| | | | | | | +--->BN_MP_MUL_2_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_ADD_C +| | | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_SUB_C +| | | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_DIV_2_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_MUL_2D_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_LSHD_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_MUL_D_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_DIV_3_C +| | | | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | | +--->BN_MP_EXCH_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_KARATSUBA_MUL_C +| | | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_SUB_C +| | | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_ADD_C +| | | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_RSHD_C +| | | | | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_MUL_DIGS_C +| | | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MOD_C +| | | | | +--->BN_MP_DIV_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_MP_COPY_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_INIT_MULTI_C +| | | | | | +--->BN_MP_MUL_2D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_MUL_D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_SQR_C +| | | | | +--->BN_MP_TOOM_SQR_C +| | | | | | +--->BN_MP_INIT_MULTI_C +| | | | | | +--->BN_MP_MOD_2D_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_MUL_2_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_DIV_2_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_MUL_2D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_MUL_D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_DIV_3_C +| | | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_EXCH_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_KARATSUBA_SQR_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_FAST_S_MP_SQR_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_SQR_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_MUL_C +| | | | | +--->BN_MP_TOOM_MUL_C +| | | | | | +--->BN_MP_INIT_MULTI_C +| | | | | | +--->BN_MP_MOD_2D_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_MUL_2_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_DIV_2_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_MUL_2D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_MUL_D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_DIV_3_C +| | | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_EXCH_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_KARATSUBA_MUL_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_MUL_DIGS_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_DR_IS_MODULUS_C +| | | +--->BN_MP_REDUCE_IS_2K_C +| | | | +--->BN_MP_REDUCE_2K_C +| | | | | +--->BN_MP_COUNT_BITS_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_COUNT_BITS_C +| | | +--->BN_MP_EXPTMOD_FAST_C +| | | | +--->BN_MP_COUNT_BITS_C +| | | | +--->BN_MP_MONTGOMERY_SETUP_C +| | | | +--->BN_FAST_MP_MONTGOMERY_REDUCE_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_MONTGOMERY_REDUCE_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_DR_SETUP_C +| | | | +--->BN_MP_DR_REDUCE_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_REDUCE_2K_SETUP_C +| | | | | +--->BN_MP_2EXPT_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_REDUCE_2K_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MONTGOMERY_CALC_NORMALIZATION_C +| | | | | +--->BN_MP_2EXPT_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_MUL_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MULMOD_C +| | | | | +--->BN_MP_MUL_C +| | | | | | +--->BN_MP_TOOM_MUL_C +| | | | | | | +--->BN_MP_INIT_MULTI_C +| | | | | | | +--->BN_MP_MOD_2D_C +| | | | | | | | +--->BN_MP_ZERO_C +| | | | | | | | +--->BN_MP_COPY_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_COPY_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | | | +--->BN_MP_ZERO_C +| | | | | | | +--->BN_MP_MUL_2_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_ADD_C +| | | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_SUB_C +| | | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_DIV_2_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_MUL_2D_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_LSHD_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_MUL_D_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_DIV_3_C +| | | | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | | +--->BN_MP_EXCH_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_KARATSUBA_MUL_C +| | | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_SUB_C +| | | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_ADD_C +| | | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_RSHD_C +| | | | | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_MUL_DIGS_C +| | | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_MOD_C +| | | | | | +--->BN_MP_DIV_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_MP_COPY_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | | | +--->BN_MP_INIT_MULTI_C +| | | | | | | +--->BN_MP_MUL_2D_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_LSHD_C +| | | | | | | | | +--->BN_MP_RSHD_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CMP_C +| | | | | | | +--->BN_MP_SUB_C +| | | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_ADD_C +| | | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_EXCH_C +| | | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_MUL_D_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_MOD_C +| | | | | +--->BN_MP_DIV_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_MP_COPY_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_INIT_MULTI_C +| | | | | | +--->BN_MP_MUL_2D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_MUL_D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_SQR_C +| | | | | +--->BN_MP_TOOM_SQR_C +| | | | | | +--->BN_MP_INIT_MULTI_C +| | | | | | +--->BN_MP_MOD_2D_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_MUL_2_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_DIV_2_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_MUL_2D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_MUL_D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_DIV_3_C +| | | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_EXCH_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_KARATSUBA_SQR_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_FAST_S_MP_SQR_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_SQR_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_MUL_C +| | | | | +--->BN_MP_TOOM_MUL_C +| | | | | | +--->BN_MP_INIT_MULTI_C +| | | | | | +--->BN_MP_MOD_2D_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_MUL_2_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_DIV_2_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_MUL_2D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_MUL_D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_DIV_3_C +| | | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_EXCH_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_KARATSUBA_MUL_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_MUL_DIGS_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_EXCH_C +| | +--->BN_MP_CMP_C +| | | +--->BN_MP_CMP_MAG_C +| | +--->BN_MP_SQRMOD_C +| | | +--->BN_MP_SQR_C +| | | | +--->BN_MP_TOOM_SQR_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | | +--->BN_MP_CLEAR_C +| | | | | +--->BN_MP_MOD_2D_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_COPY_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_MUL_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_3_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | | +--->BN_MP_CLEAR_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLEAR_MULTI_C +| | | | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_KARATSUBA_SQR_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_FAST_S_MP_SQR_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_SQR_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_MOD_C +| | | | +--->BN_MP_DIV_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_COUNT_BITS_C +| | | | | +--->BN_MP_ABS_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_CLEAR_MULTI_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_SUB_D_C +| +--->BN_MP_GROW_C +| +--->BN_MP_ADD_D_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_DIV_2_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_MUL_2_C +| +--->BN_MP_GROW_C ++--->BN_MP_ADD_D_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C + + +BN_MP_KARATSUBA_SQR_C ++--->BN_MP_INIT_SIZE_C +| +--->BN_MP_INIT_C ++--->BN_MP_CLAMP_C ++--->BN_MP_SQR_C +| +--->BN_MP_TOOM_SQR_C +| | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_INIT_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_RSHD_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_MUL_2_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_DIV_2_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_DIV_3_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLEAR_MULTI_C +| | | +--->BN_MP_CLEAR_C +| +--->BN_FAST_S_MP_SQR_C +| | +--->BN_MP_GROW_C +| +--->BN_S_MP_SQR_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C ++--->BN_MP_SUB_C +| +--->BN_S_MP_ADD_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C ++--->BN_S_MP_ADD_C +| +--->BN_MP_GROW_C ++--->BN_MP_LSHD_C +| +--->BN_MP_GROW_C +| +--->BN_MP_RSHD_C +| | +--->BN_MP_ZERO_C ++--->BN_MP_ADD_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C ++--->BN_MP_CLEAR_C + + +BN_MP_INIT_COPY_C ++--->BN_MP_COPY_C +| +--->BN_MP_GROW_C + + +BN_MP_CLAMP_C + + +BN_MP_TOOM_SQR_C ++--->BN_MP_INIT_MULTI_C +| +--->BN_MP_INIT_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_MOD_2D_C +| +--->BN_MP_ZERO_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_COPY_C +| +--->BN_MP_GROW_C ++--->BN_MP_RSHD_C +| +--->BN_MP_ZERO_C ++--->BN_MP_SQR_C +| +--->BN_MP_KARATSUBA_SQR_C +| | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_INIT_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLEAR_C +| +--->BN_FAST_S_MP_SQR_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_S_MP_SQR_C +| | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_INIT_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C ++--->BN_MP_MUL_2_C +| +--->BN_MP_GROW_C ++--->BN_MP_ADD_C +| +--->BN_S_MP_ADD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C ++--->BN_MP_SUB_C +| +--->BN_S_MP_ADD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C ++--->BN_MP_DIV_2_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_MUL_2D_C +| +--->BN_MP_GROW_C +| +--->BN_MP_LSHD_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_MUL_D_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_DIV_3_C +| +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_INIT_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_LSHD_C +| +--->BN_MP_GROW_C ++--->BN_MP_CLEAR_MULTI_C +| +--->BN_MP_CLEAR_C + + +BN_MP_MOD_C ++--->BN_MP_INIT_C ++--->BN_MP_DIV_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_ZERO_C +| +--->BN_MP_INIT_MULTI_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_SET_C +| +--->BN_MP_COUNT_BITS_C +| +--->BN_MP_ABS_C +| +--->BN_MP_MUL_2D_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_C +| +--->BN_MP_SUB_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_ADD_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_DIV_2D_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLEAR_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| +--->BN_MP_EXCH_C +| +--->BN_MP_CLEAR_MULTI_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_INIT_SIZE_C +| +--->BN_MP_INIT_COPY_C +| +--->BN_MP_LSHD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_RSHD_C +| +--->BN_MP_RSHD_C +| +--->BN_MP_MUL_D_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_CLEAR_C ++--->BN_MP_ADD_C +| +--->BN_S_MP_ADD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C ++--->BN_MP_EXCH_C + + +BN_MP_INIT_C + + +BN_MP_TOOM_MUL_C ++--->BN_MP_INIT_MULTI_C +| +--->BN_MP_INIT_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_MOD_2D_C +| +--->BN_MP_ZERO_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_COPY_C +| +--->BN_MP_GROW_C ++--->BN_MP_RSHD_C +| +--->BN_MP_ZERO_C ++--->BN_MP_MUL_C +| +--->BN_MP_KARATSUBA_MUL_C +| | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_INIT_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLEAR_C +| +--->BN_FAST_S_MP_MUL_DIGS_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_S_MP_MUL_DIGS_C +| | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_INIT_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C ++--->BN_MP_MUL_2_C +| +--->BN_MP_GROW_C ++--->BN_MP_ADD_C +| +--->BN_S_MP_ADD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C ++--->BN_MP_SUB_C +| +--->BN_S_MP_ADD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C ++--->BN_MP_DIV_2_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_MUL_2D_C +| +--->BN_MP_GROW_C +| +--->BN_MP_LSHD_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_MUL_D_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_DIV_3_C +| +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_INIT_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_LSHD_C +| +--->BN_MP_GROW_C ++--->BN_MP_CLEAR_MULTI_C +| +--->BN_MP_CLEAR_C + + +BN_MP_PRIME_IS_PRIME_C ++--->BN_MP_CMP_D_C ++--->BN_MP_PRIME_IS_DIVISIBLE_C +| +--->BN_MP_MOD_D_C +| | +--->BN_MP_DIV_D_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_DIV_2D_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_INIT_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_DIV_3_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_INIT_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_INIT_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_C ++--->BN_MP_INIT_C ++--->BN_MP_SET_C +| +--->BN_MP_ZERO_C ++--->BN_MP_PRIME_MILLER_RABIN_C +| +--->BN_MP_INIT_COPY_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| +--->BN_MP_SUB_D_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_D_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CNT_LSB_C +| +--->BN_MP_DIV_2D_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLEAR_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| +--->BN_MP_EXPTMOD_C +| | +--->BN_MP_INVMOD_C +| | | +--->BN_FAST_MP_INVMOD_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_MOD_C +| | | | | +--->BN_MP_DIV_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_COUNT_BITS_C +| | | | | | +--->BN_MP_ABS_C +| | | | | | +--->BN_MP_MUL_2D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | | +--->BN_MP_CLEAR_MULTI_C +| | | | | | | +--->BN_MP_CLEAR_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_MUL_D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CLEAR_C +| | | | | +--->BN_MP_CLEAR_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_DIV_2_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_CLEAR_MULTI_C +| | | | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_INVMOD_SLOW_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_MOD_C +| | | | | +--->BN_MP_DIV_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_MP_COPY_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_COUNT_BITS_C +| | | | | | +--->BN_MP_ABS_C +| | | | | | +--->BN_MP_MUL_2D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | | +--->BN_MP_CLEAR_MULTI_C +| | | | | | | +--->BN_MP_CLEAR_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_MUL_D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CLEAR_C +| | | | | +--->BN_MP_CLEAR_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_DIV_2_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_CLEAR_MULTI_C +| | | | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_CLEAR_C +| | +--->BN_MP_ABS_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLEAR_MULTI_C +| | +--->BN_MP_REDUCE_IS_2K_L_C +| | +--->BN_S_MP_EXPTMOD_C +| | | +--->BN_MP_COUNT_BITS_C +| | | +--->BN_MP_REDUCE_SETUP_C +| | | | +--->BN_MP_2EXPT_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_DIV_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_REDUCE_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_MUL_C +| | | | | +--->BN_MP_TOOM_MUL_C +| | | | | | +--->BN_MP_INIT_MULTI_C +| | | | | | +--->BN_MP_MOD_2D_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | | | +--->BN_MP_COPY_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_COPY_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_MUL_2_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_DIV_2_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_MUL_2D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_MUL_D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_DIV_3_C +| | | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_EXCH_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_KARATSUBA_MUL_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_MUL_DIGS_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_S_MP_MUL_HIGH_DIGS_C +| | | | | +--->BN_FAST_S_MP_MUL_HIGH_DIGS_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_FAST_S_MP_MUL_HIGH_DIGS_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_MUL_DIGS_C +| | | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_REDUCE_2K_SETUP_L_C +| | | | +--->BN_MP_2EXPT_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_REDUCE_2K_L_C +| | | | +--->BN_MP_MUL_C +| | | | | +--->BN_MP_TOOM_MUL_C +| | | | | | +--->BN_MP_INIT_MULTI_C +| | | | | | +--->BN_MP_MOD_2D_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | | | +--->BN_MP_COPY_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_COPY_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_MUL_2_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_DIV_2_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_MUL_2D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_MUL_D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_DIV_3_C +| | | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_EXCH_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_KARATSUBA_MUL_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_MUL_DIGS_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MOD_C +| | | | +--->BN_MP_DIV_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_SQR_C +| | | | +--->BN_MP_TOOM_SQR_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_MOD_2D_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_MUL_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_3_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_KARATSUBA_SQR_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_FAST_S_MP_SQR_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_SQR_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_MUL_C +| | | | +--->BN_MP_TOOM_MUL_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_MOD_2D_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_MUL_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_3_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_KARATSUBA_MUL_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_MUL_DIGS_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_DR_IS_MODULUS_C +| | +--->BN_MP_REDUCE_IS_2K_C +| | | +--->BN_MP_REDUCE_2K_C +| | | | +--->BN_MP_COUNT_BITS_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_COUNT_BITS_C +| | +--->BN_MP_EXPTMOD_FAST_C +| | | +--->BN_MP_COUNT_BITS_C +| | | +--->BN_MP_MONTGOMERY_SETUP_C +| | | +--->BN_FAST_MP_MONTGOMERY_REDUCE_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_MONTGOMERY_REDUCE_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_DR_SETUP_C +| | | +--->BN_MP_DR_REDUCE_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_REDUCE_2K_SETUP_C +| | | | +--->BN_MP_2EXPT_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_REDUCE_2K_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MONTGOMERY_CALC_NORMALIZATION_C +| | | | +--->BN_MP_2EXPT_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_MUL_2_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MULMOD_C +| | | | +--->BN_MP_MUL_C +| | | | | +--->BN_MP_TOOM_MUL_C +| | | | | | +--->BN_MP_INIT_MULTI_C +| | | | | | +--->BN_MP_MOD_2D_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | | | +--->BN_MP_COPY_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_COPY_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_MUL_2_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_DIV_2_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_MUL_2D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_MUL_D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_DIV_3_C +| | | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_EXCH_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_KARATSUBA_MUL_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_MUL_DIGS_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_MOD_C +| | | | | +--->BN_MP_DIV_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_MP_COPY_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_INIT_MULTI_C +| | | | | | +--->BN_MP_MUL_2D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_MUL_D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_MOD_C +| | | | +--->BN_MP_DIV_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_SQR_C +| | | | +--->BN_MP_TOOM_SQR_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_MOD_2D_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_MUL_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_3_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_KARATSUBA_SQR_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_FAST_S_MP_SQR_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_SQR_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_MUL_C +| | | | +--->BN_MP_TOOM_MUL_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_MOD_2D_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_MUL_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_3_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_KARATSUBA_MUL_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_MUL_DIGS_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_EXCH_C +| +--->BN_MP_CMP_C +| | +--->BN_MP_CMP_MAG_C +| +--->BN_MP_SQRMOD_C +| | +--->BN_MP_SQR_C +| | | +--->BN_MP_TOOM_SQR_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_MUL_2_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_2_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_3_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLEAR_MULTI_C +| | | | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_KARATSUBA_SQR_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLEAR_C +| | | +--->BN_FAST_S_MP_SQR_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SQR_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_CLEAR_C +| | +--->BN_MP_MOD_C +| | | +--->BN_MP_DIV_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_COUNT_BITS_C +| | | | +--->BN_MP_ABS_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_CLEAR_MULTI_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_CLEAR_C + + +BN_MP_COPY_C ++--->BN_MP_GROW_C + + +BN_S_MP_SUB_C ++--->BN_MP_GROW_C ++--->BN_MP_CLAMP_C + + +BN_MP_READ_UNSIGNED_BIN_C ++--->BN_MP_GROW_C ++--->BN_MP_ZERO_C ++--->BN_MP_MUL_2D_C +| +--->BN_MP_COPY_C +| +--->BN_MP_LSHD_C +| | +--->BN_MP_RSHD_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_CLAMP_C + + +BN_MP_EXPTMOD_FAST_C ++--->BN_MP_COUNT_BITS_C ++--->BN_MP_INIT_C ++--->BN_MP_CLEAR_C ++--->BN_MP_MONTGOMERY_SETUP_C ++--->BN_FAST_MP_MONTGOMERY_REDUCE_C +| +--->BN_MP_GROW_C +| +--->BN_MP_RSHD_C +| | +--->BN_MP_ZERO_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C ++--->BN_MP_MONTGOMERY_REDUCE_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_RSHD_C +| | +--->BN_MP_ZERO_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C ++--->BN_MP_DR_SETUP_C ++--->BN_MP_DR_REDUCE_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C ++--->BN_MP_REDUCE_2K_SETUP_C +| +--->BN_MP_2EXPT_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_GROW_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C ++--->BN_MP_REDUCE_2K_C +| +--->BN_MP_DIV_2D_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| +--->BN_MP_MUL_D_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_S_MP_ADD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C ++--->BN_MP_MONTGOMERY_CALC_NORMALIZATION_C +| +--->BN_MP_2EXPT_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_SET_C +| | +--->BN_MP_ZERO_C +| +--->BN_MP_MUL_2_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C ++--->BN_MP_MULMOD_C +| +--->BN_MP_MUL_C +| | +--->BN_MP_TOOM_MUL_C +| | | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_MUL_2_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_2_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MUL_2D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MUL_D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_3_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLEAR_MULTI_C +| | +--->BN_MP_KARATSUBA_MUL_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_S_MP_MUL_DIGS_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| +--->BN_MP_MOD_C +| | +--->BN_MP_DIV_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_SET_C +| | | +--->BN_MP_ABS_C +| | | +--->BN_MP_MUL_2D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_2D_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_MULTI_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_INIT_COPY_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_MUL_D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C ++--->BN_MP_SET_C +| +--->BN_MP_ZERO_C ++--->BN_MP_MOD_C +| +--->BN_MP_DIV_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_INIT_MULTI_C +| | +--->BN_MP_ABS_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2D_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_MULTI_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_INIT_COPY_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_ADD_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C ++--->BN_MP_COPY_C +| +--->BN_MP_GROW_C ++--->BN_MP_SQR_C +| +--->BN_MP_TOOM_SQR_C +| | +--->BN_MP_INIT_MULTI_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_RSHD_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_MUL_2_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_3_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLEAR_MULTI_C +| +--->BN_MP_KARATSUBA_SQR_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| | +--->BN_MP_ADD_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| +--->BN_FAST_S_MP_SQR_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_S_MP_SQR_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C ++--->BN_MP_MUL_C +| +--->BN_MP_TOOM_MUL_C +| | +--->BN_MP_INIT_MULTI_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_RSHD_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_MUL_2_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_3_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLEAR_MULTI_C +| +--->BN_MP_KARATSUBA_MUL_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| +--->BN_FAST_S_MP_MUL_DIGS_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_S_MP_MUL_DIGS_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C ++--->BN_MP_EXCH_C + + +BN_MP_TO_UNSIGNED_BIN_C ++--->BN_MP_INIT_COPY_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C ++--->BN_MP_DIV_2D_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_ZERO_C +| +--->BN_MP_MOD_2D_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CLEAR_C +| +--->BN_MP_RSHD_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C ++--->BN_MP_CLEAR_C + + +BN_MP_SET_INT_C ++--->BN_MP_ZERO_C ++--->BN_MP_MUL_2D_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_GROW_C +| +--->BN_MP_LSHD_C +| | +--->BN_MP_RSHD_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_CLAMP_C + + +BN_MP_MOD_D_C ++--->BN_MP_DIV_D_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_DIV_2D_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_INIT_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLEAR_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| +--->BN_MP_DIV_3_C +| | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_INIT_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_INIT_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C +| +--->BN_MP_CLEAR_C + + +BN_MP_SQR_C ++--->BN_MP_TOOM_SQR_C +| +--->BN_MP_INIT_MULTI_C +| | +--->BN_MP_INIT_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_MOD_2D_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_RSHD_C +| | +--->BN_MP_ZERO_C +| +--->BN_MP_MUL_2_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_ADD_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_SUB_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_DIV_2_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_MUL_2D_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_LSHD_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_MUL_D_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_DIV_3_C +| | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_INIT_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_LSHD_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_CLEAR_MULTI_C +| | +--->BN_MP_CLEAR_C ++--->BN_MP_KARATSUBA_SQR_C +| +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_INIT_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_SUB_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| +--->BN_S_MP_ADD_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_LSHD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_RSHD_C +| | | +--->BN_MP_ZERO_C +| +--->BN_MP_ADD_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| +--->BN_MP_CLEAR_C ++--->BN_FAST_S_MP_SQR_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_S_MP_SQR_C +| +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_INIT_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C +| +--->BN_MP_CLEAR_C + + +BN_MP_MULMOD_C ++--->BN_MP_INIT_C ++--->BN_MP_MUL_C +| +--->BN_MP_TOOM_MUL_C +| | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_RSHD_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_MUL_2_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_3_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLEAR_MULTI_C +| | | +--->BN_MP_CLEAR_C +| +--->BN_MP_KARATSUBA_MUL_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| | +--->BN_MP_CLEAR_C +| +--->BN_FAST_S_MP_MUL_DIGS_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_S_MP_MUL_DIGS_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C ++--->BN_MP_CLEAR_C ++--->BN_MP_MOD_C +| +--->BN_MP_DIV_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_INIT_MULTI_C +| | +--->BN_MP_SET_C +| | +--->BN_MP_COUNT_BITS_C +| | +--->BN_MP_ABS_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2D_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_MULTI_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_INIT_COPY_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_ADD_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C + + +BN_MP_DIV_2D_C ++--->BN_MP_COPY_C +| +--->BN_MP_GROW_C ++--->BN_MP_ZERO_C ++--->BN_MP_INIT_C ++--->BN_MP_MOD_2D_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_CLEAR_C ++--->BN_MP_RSHD_C ++--->BN_MP_CLAMP_C ++--->BN_MP_EXCH_C + + +BN_S_MP_ADD_C ++--->BN_MP_GROW_C ++--->BN_MP_CLAMP_C + + +BN_FAST_S_MP_SQR_C ++--->BN_MP_GROW_C ++--->BN_MP_CLAMP_C + + +BN_S_MP_MUL_DIGS_C ++--->BN_FAST_S_MP_MUL_DIGS_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_INIT_SIZE_C +| +--->BN_MP_INIT_C ++--->BN_MP_CLAMP_C ++--->BN_MP_EXCH_C ++--->BN_MP_CLEAR_C + + +BN_MP_XOR_C ++--->BN_MP_INIT_COPY_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C ++--->BN_MP_CLAMP_C ++--->BN_MP_EXCH_C ++--->BN_MP_CLEAR_C + + +BN_MP_RADIX_SMAP_C + + +BN_MP_DR_IS_MODULUS_C + + +BN_MP_MONTGOMERY_CALC_NORMALIZATION_C ++--->BN_MP_COUNT_BITS_C ++--->BN_MP_2EXPT_C +| +--->BN_MP_ZERO_C +| +--->BN_MP_GROW_C ++--->BN_MP_SET_C +| +--->BN_MP_ZERO_C ++--->BN_MP_MUL_2_C +| +--->BN_MP_GROW_C ++--->BN_MP_CMP_MAG_C ++--->BN_S_MP_SUB_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C + + +BN_MP_SUB_C ++--->BN_S_MP_ADD_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_CMP_MAG_C ++--->BN_S_MP_SUB_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C + + +BN_MP_INIT_MULTI_C ++--->BN_MP_INIT_C ++--->BN_MP_CLEAR_C + + +BN_S_MP_MUL_HIGH_DIGS_C ++--->BN_FAST_S_MP_MUL_HIGH_DIGS_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_INIT_SIZE_C +| +--->BN_MP_INIT_C ++--->BN_MP_CLAMP_C ++--->BN_MP_EXCH_C ++--->BN_MP_CLEAR_C + + +BN_MP_PRIME_NEXT_PRIME_C ++--->BN_MP_CMP_D_C ++--->BN_MP_SET_C +| +--->BN_MP_ZERO_C ++--->BN_MP_SUB_D_C +| +--->BN_MP_GROW_C +| +--->BN_MP_ADD_D_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_MOD_D_C +| +--->BN_MP_DIV_D_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_DIV_2D_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_INIT_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_DIV_3_C +| | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_INIT_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_INIT_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C ++--->BN_MP_INIT_C ++--->BN_MP_ADD_D_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_PRIME_MILLER_RABIN_C +| +--->BN_MP_INIT_COPY_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| +--->BN_MP_CNT_LSB_C +| +--->BN_MP_DIV_2D_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLEAR_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| +--->BN_MP_EXPTMOD_C +| | +--->BN_MP_INVMOD_C +| | | +--->BN_FAST_MP_INVMOD_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_MOD_C +| | | | | +--->BN_MP_DIV_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_COUNT_BITS_C +| | | | | | +--->BN_MP_ABS_C +| | | | | | +--->BN_MP_MUL_2D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | | +--->BN_MP_CLEAR_MULTI_C +| | | | | | | +--->BN_MP_CLEAR_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_MUL_D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CLEAR_C +| | | | | +--->BN_MP_CLEAR_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_DIV_2_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_CLEAR_MULTI_C +| | | | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_INVMOD_SLOW_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_MOD_C +| | | | | +--->BN_MP_DIV_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_MP_COPY_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_COUNT_BITS_C +| | | | | | +--->BN_MP_ABS_C +| | | | | | +--->BN_MP_MUL_2D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | | +--->BN_MP_CLEAR_MULTI_C +| | | | | | | +--->BN_MP_CLEAR_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_MUL_D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CLEAR_C +| | | | | +--->BN_MP_CLEAR_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_DIV_2_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_CLEAR_MULTI_C +| | | | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_CLEAR_C +| | +--->BN_MP_ABS_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLEAR_MULTI_C +| | +--->BN_MP_REDUCE_IS_2K_L_C +| | +--->BN_S_MP_EXPTMOD_C +| | | +--->BN_MP_COUNT_BITS_C +| | | +--->BN_MP_REDUCE_SETUP_C +| | | | +--->BN_MP_2EXPT_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_DIV_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_REDUCE_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_MUL_C +| | | | | +--->BN_MP_TOOM_MUL_C +| | | | | | +--->BN_MP_INIT_MULTI_C +| | | | | | +--->BN_MP_MOD_2D_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | | | +--->BN_MP_COPY_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_COPY_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_MUL_2_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_DIV_2_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_MUL_2D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_MUL_D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_DIV_3_C +| | | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_EXCH_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_KARATSUBA_MUL_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_MUL_DIGS_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_S_MP_MUL_HIGH_DIGS_C +| | | | | +--->BN_FAST_S_MP_MUL_HIGH_DIGS_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_FAST_S_MP_MUL_HIGH_DIGS_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_MUL_DIGS_C +| | | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_REDUCE_2K_SETUP_L_C +| | | | +--->BN_MP_2EXPT_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_REDUCE_2K_L_C +| | | | +--->BN_MP_MUL_C +| | | | | +--->BN_MP_TOOM_MUL_C +| | | | | | +--->BN_MP_INIT_MULTI_C +| | | | | | +--->BN_MP_MOD_2D_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | | | +--->BN_MP_COPY_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_COPY_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_MUL_2_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_DIV_2_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_MUL_2D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_MUL_D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_DIV_3_C +| | | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_EXCH_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_KARATSUBA_MUL_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_MUL_DIGS_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MOD_C +| | | | +--->BN_MP_DIV_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_SQR_C +| | | | +--->BN_MP_TOOM_SQR_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_MOD_2D_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_MUL_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_3_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_KARATSUBA_SQR_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_FAST_S_MP_SQR_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_SQR_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_MUL_C +| | | | +--->BN_MP_TOOM_MUL_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_MOD_2D_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_MUL_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_3_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_KARATSUBA_MUL_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_MUL_DIGS_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_DR_IS_MODULUS_C +| | +--->BN_MP_REDUCE_IS_2K_C +| | | +--->BN_MP_REDUCE_2K_C +| | | | +--->BN_MP_COUNT_BITS_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_COUNT_BITS_C +| | +--->BN_MP_EXPTMOD_FAST_C +| | | +--->BN_MP_COUNT_BITS_C +| | | +--->BN_MP_MONTGOMERY_SETUP_C +| | | +--->BN_FAST_MP_MONTGOMERY_REDUCE_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_MONTGOMERY_REDUCE_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_DR_SETUP_C +| | | +--->BN_MP_DR_REDUCE_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_REDUCE_2K_SETUP_C +| | | | +--->BN_MP_2EXPT_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_REDUCE_2K_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MONTGOMERY_CALC_NORMALIZATION_C +| | | | +--->BN_MP_2EXPT_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_MUL_2_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MULMOD_C +| | | | +--->BN_MP_MUL_C +| | | | | +--->BN_MP_TOOM_MUL_C +| | | | | | +--->BN_MP_INIT_MULTI_C +| | | | | | +--->BN_MP_MOD_2D_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | | | +--->BN_MP_COPY_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_COPY_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_MUL_2_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_DIV_2_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_MUL_2D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_MUL_D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_DIV_3_C +| | | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_MP_EXCH_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_KARATSUBA_MUL_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_MUL_DIGS_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_MOD_C +| | | | | +--->BN_MP_DIV_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_MP_COPY_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_INIT_MULTI_C +| | | | | | +--->BN_MP_MUL_2D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_LSHD_C +| | | | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_C +| | | | | | +--->BN_MP_SUB_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_ADD_C +| | | | | | | +--->BN_S_MP_ADD_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | | +--->BN_S_MP_SUB_C +| | | | | | | | +--->BN_MP_GROW_C +| | | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_MUL_D_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_MOD_C +| | | | +--->BN_MP_DIV_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_SQR_C +| | | | +--->BN_MP_TOOM_SQR_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_MOD_2D_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_MUL_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_3_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_KARATSUBA_SQR_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_FAST_S_MP_SQR_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_SQR_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_MUL_C +| | | | +--->BN_MP_TOOM_MUL_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_MOD_2D_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_MUL_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_3_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_KARATSUBA_MUL_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_MUL_DIGS_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_EXCH_C +| +--->BN_MP_CMP_C +| | +--->BN_MP_CMP_MAG_C +| +--->BN_MP_SQRMOD_C +| | +--->BN_MP_SQR_C +| | | +--->BN_MP_TOOM_SQR_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_MUL_2_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_2_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_3_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLEAR_MULTI_C +| | | | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_KARATSUBA_SQR_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLEAR_C +| | | +--->BN_FAST_S_MP_SQR_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SQR_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_CLEAR_C +| | +--->BN_MP_MOD_C +| | | +--->BN_MP_DIV_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_COUNT_BITS_C +| | | | +--->BN_MP_ABS_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_CLEAR_MULTI_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_CLEAR_C + + +BN_MP_SIGNED_BIN_SIZE_C ++--->BN_MP_UNSIGNED_BIN_SIZE_C +| +--->BN_MP_COUNT_BITS_C + + +BN_MP_INVMOD_SLOW_C ++--->BN_MP_INIT_MULTI_C +| +--->BN_MP_INIT_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_MOD_C +| +--->BN_MP_INIT_C +| +--->BN_MP_DIV_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_SET_C +| | +--->BN_MP_COUNT_BITS_C +| | +--->BN_MP_ABS_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2D_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_MULTI_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_INIT_COPY_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_CLEAR_C +| +--->BN_MP_ADD_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C ++--->BN_MP_COPY_C +| +--->BN_MP_GROW_C ++--->BN_MP_SET_C +| +--->BN_MP_ZERO_C ++--->BN_MP_DIV_2_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_ADD_C +| +--->BN_S_MP_ADD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C ++--->BN_MP_SUB_C +| +--->BN_S_MP_ADD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C ++--->BN_MP_CMP_C +| +--->BN_MP_CMP_MAG_C ++--->BN_MP_CMP_D_C ++--->BN_MP_CMP_MAG_C ++--->BN_MP_EXCH_C ++--->BN_MP_CLEAR_MULTI_C +| +--->BN_MP_CLEAR_C + + +BN_MP_LCM_C ++--->BN_MP_INIT_MULTI_C +| +--->BN_MP_INIT_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_GCD_C +| +--->BN_MP_ABS_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| +--->BN_MP_ZERO_C +| +--->BN_MP_INIT_COPY_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| +--->BN_MP_CNT_LSB_C +| +--->BN_MP_DIV_2D_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLEAR_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_MP_EXCH_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_MUL_2D_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_CMP_MAG_C ++--->BN_MP_DIV_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_ZERO_C +| +--->BN_MP_SET_C +| +--->BN_MP_COUNT_BITS_C +| +--->BN_MP_ABS_C +| +--->BN_MP_MUL_2D_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_C +| +--->BN_MP_SUB_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_ADD_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_DIV_2D_C +| | +--->BN_MP_INIT_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLEAR_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| +--->BN_MP_EXCH_C +| +--->BN_MP_CLEAR_MULTI_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_INIT_C +| +--->BN_MP_INIT_C +| +--->BN_MP_INIT_COPY_C +| +--->BN_MP_LSHD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_RSHD_C +| +--->BN_MP_RSHD_C +| +--->BN_MP_MUL_D_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_MUL_C +| +--->BN_MP_TOOM_MUL_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_RSHD_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_MUL_2_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_3_C +| | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_INIT_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLEAR_MULTI_C +| | | +--->BN_MP_CLEAR_C +| +--->BN_MP_KARATSUBA_MUL_C +| | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_INIT_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| | +--->BN_MP_CLEAR_C +| +--->BN_FAST_S_MP_MUL_DIGS_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_S_MP_MUL_DIGS_C +| | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_INIT_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C ++--->BN_MP_CLEAR_MULTI_C +| +--->BN_MP_CLEAR_C + + +BN_MP_REDUCE_2K_L_C ++--->BN_MP_INIT_C ++--->BN_MP_COUNT_BITS_C ++--->BN_MP_DIV_2D_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_ZERO_C +| +--->BN_MP_MOD_2D_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CLEAR_C +| +--->BN_MP_RSHD_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C ++--->BN_MP_MUL_C +| +--->BN_MP_TOOM_MUL_C +| | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_RSHD_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_MUL_2_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_3_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLEAR_MULTI_C +| | | +--->BN_MP_CLEAR_C +| +--->BN_MP_KARATSUBA_MUL_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| | +--->BN_MP_CLEAR_C +| +--->BN_FAST_S_MP_MUL_DIGS_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_S_MP_MUL_DIGS_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C ++--->BN_S_MP_ADD_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_CMP_MAG_C ++--->BN_S_MP_SUB_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_CLEAR_C + + +BN_REVERSE_C + + +BN_MP_PRIME_IS_DIVISIBLE_C ++--->BN_MP_MOD_D_C +| +--->BN_MP_DIV_D_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_DIV_2D_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_INIT_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_DIV_3_C +| | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_INIT_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_INIT_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C + + +BN_MP_SET_C ++--->BN_MP_ZERO_C + + +BN_MP_GCD_C ++--->BN_MP_ABS_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C ++--->BN_MP_ZERO_C ++--->BN_MP_INIT_COPY_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C ++--->BN_MP_CNT_LSB_C ++--->BN_MP_DIV_2D_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_MOD_2D_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CLEAR_C +| +--->BN_MP_RSHD_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C ++--->BN_MP_CMP_MAG_C ++--->BN_MP_EXCH_C ++--->BN_S_MP_SUB_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_MUL_2D_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_GROW_C +| +--->BN_MP_LSHD_C +| | +--->BN_MP_RSHD_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_CLEAR_C + + +BN_MP_REDUCE_2K_SETUP_L_C ++--->BN_MP_INIT_C ++--->BN_MP_2EXPT_C +| +--->BN_MP_ZERO_C +| +--->BN_MP_GROW_C ++--->BN_MP_COUNT_BITS_C ++--->BN_S_MP_SUB_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_CLEAR_C + + +BN_MP_READ_RADIX_C ++--->BN_MP_ZERO_C ++--->BN_MP_MUL_D_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_ADD_D_C +| +--->BN_MP_GROW_C +| +--->BN_MP_SUB_D_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CLAMP_C + + +BN_FAST_S_MP_MUL_HIGH_DIGS_C ++--->BN_MP_GROW_C ++--->BN_MP_CLAMP_C + + +BN_FAST_MP_MONTGOMERY_REDUCE_C ++--->BN_MP_GROW_C ++--->BN_MP_RSHD_C +| +--->BN_MP_ZERO_C ++--->BN_MP_CLAMP_C ++--->BN_MP_CMP_MAG_C ++--->BN_S_MP_SUB_C + + +BN_MP_DIV_D_C ++--->BN_MP_COPY_C +| +--->BN_MP_GROW_C ++--->BN_MP_DIV_2D_C +| +--->BN_MP_ZERO_C +| +--->BN_MP_INIT_C +| +--->BN_MP_MOD_2D_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CLEAR_C +| +--->BN_MP_RSHD_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C ++--->BN_MP_DIV_3_C +| +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_INIT_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_INIT_SIZE_C +| +--->BN_MP_INIT_C ++--->BN_MP_CLAMP_C ++--->BN_MP_EXCH_C ++--->BN_MP_CLEAR_C + + +BN_MP_REDUCE_2K_SETUP_C ++--->BN_MP_INIT_C ++--->BN_MP_COUNT_BITS_C ++--->BN_MP_2EXPT_C +| +--->BN_MP_ZERO_C +| +--->BN_MP_GROW_C ++--->BN_MP_CLEAR_C ++--->BN_S_MP_SUB_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C + + +BN_MP_INIT_SET_C ++--->BN_MP_INIT_C ++--->BN_MP_SET_C +| +--->BN_MP_ZERO_C + + +BN_MP_REDUCE_2K_C ++--->BN_MP_INIT_C ++--->BN_MP_COUNT_BITS_C ++--->BN_MP_DIV_2D_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_ZERO_C +| +--->BN_MP_MOD_2D_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CLEAR_C +| +--->BN_MP_RSHD_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C ++--->BN_MP_MUL_D_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_S_MP_ADD_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_CMP_MAG_C ++--->BN_S_MP_SUB_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_CLEAR_C + + +BN_ERROR_C + + +BN_MP_EXPT_D_C ++--->BN_MP_INIT_COPY_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C ++--->BN_MP_SET_C +| +--->BN_MP_ZERO_C ++--->BN_MP_SQR_C +| +--->BN_MP_TOOM_SQR_C +| | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_RSHD_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_MUL_2_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_3_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLEAR_MULTI_C +| | | +--->BN_MP_CLEAR_C +| +--->BN_MP_KARATSUBA_SQR_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| | +--->BN_MP_ADD_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLEAR_C +| +--->BN_FAST_S_MP_SQR_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_S_MP_SQR_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C ++--->BN_MP_CLEAR_C ++--->BN_MP_MUL_C +| +--->BN_MP_TOOM_MUL_C +| | +--->BN_MP_INIT_MULTI_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_RSHD_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_MUL_2_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_3_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLEAR_MULTI_C +| +--->BN_MP_KARATSUBA_MUL_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| +--->BN_FAST_S_MP_MUL_DIGS_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_S_MP_MUL_DIGS_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C + + +BN_S_MP_EXPTMOD_C ++--->BN_MP_COUNT_BITS_C ++--->BN_MP_INIT_C ++--->BN_MP_CLEAR_C ++--->BN_MP_REDUCE_SETUP_C +| +--->BN_MP_2EXPT_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_DIV_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_INIT_MULTI_C +| | +--->BN_MP_SET_C +| | +--->BN_MP_ABS_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2D_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_MULTI_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_INIT_COPY_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLAMP_C ++--->BN_MP_REDUCE_C +| +--->BN_MP_INIT_COPY_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| +--->BN_MP_RSHD_C +| | +--->BN_MP_ZERO_C +| +--->BN_MP_MUL_C +| | +--->BN_MP_TOOM_MUL_C +| | | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_MUL_2_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_2_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MUL_2D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MUL_D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_3_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLEAR_MULTI_C +| | +--->BN_MP_KARATSUBA_MUL_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_S_MP_MUL_DIGS_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| +--->BN_S_MP_MUL_HIGH_DIGS_C +| | +--->BN_FAST_S_MP_MUL_HIGH_DIGS_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| +--->BN_FAST_S_MP_MUL_HIGH_DIGS_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_MOD_2D_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_S_MP_MUL_DIGS_C +| | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| +--->BN_MP_SUB_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_D_C +| +--->BN_MP_SET_C +| | +--->BN_MP_ZERO_C +| +--->BN_MP_LSHD_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_ADD_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_C +| | +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C ++--->BN_MP_REDUCE_2K_SETUP_L_C +| +--->BN_MP_2EXPT_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_GROW_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C ++--->BN_MP_REDUCE_2K_L_C +| +--->BN_MP_DIV_2D_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| +--->BN_MP_MUL_C +| | +--->BN_MP_TOOM_MUL_C +| | | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_MUL_2_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_2_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MUL_2D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MUL_D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_3_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLEAR_MULTI_C +| | +--->BN_MP_KARATSUBA_MUL_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_S_MP_MUL_DIGS_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| +--->BN_S_MP_ADD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C ++--->BN_MP_MOD_C +| +--->BN_MP_DIV_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_INIT_MULTI_C +| | +--->BN_MP_SET_C +| | +--->BN_MP_ABS_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2D_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_MULTI_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_INIT_COPY_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_ADD_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C ++--->BN_MP_COPY_C +| +--->BN_MP_GROW_C ++--->BN_MP_SQR_C +| +--->BN_MP_TOOM_SQR_C +| | +--->BN_MP_INIT_MULTI_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_RSHD_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_MUL_2_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_3_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLEAR_MULTI_C +| +--->BN_MP_KARATSUBA_SQR_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| | +--->BN_MP_ADD_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| +--->BN_FAST_S_MP_SQR_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_S_MP_SQR_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C ++--->BN_MP_MUL_C +| +--->BN_MP_TOOM_MUL_C +| | +--->BN_MP_INIT_MULTI_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_RSHD_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_MUL_2_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_3_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLEAR_MULTI_C +| +--->BN_MP_KARATSUBA_MUL_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| +--->BN_FAST_S_MP_MUL_DIGS_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_S_MP_MUL_DIGS_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C ++--->BN_MP_SET_C +| +--->BN_MP_ZERO_C ++--->BN_MP_EXCH_C + + +BN_MP_ABS_C ++--->BN_MP_COPY_C +| +--->BN_MP_GROW_C + + +BN_MP_INIT_SET_INT_C ++--->BN_MP_INIT_C ++--->BN_MP_SET_INT_C +| +--->BN_MP_ZERO_C +| +--->BN_MP_MUL_2D_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CLAMP_C + + +BN_MP_SUB_D_C ++--->BN_MP_GROW_C ++--->BN_MP_ADD_D_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_CLAMP_C + + +BN_MP_TO_SIGNED_BIN_C ++--->BN_MP_TO_UNSIGNED_BIN_C +| +--->BN_MP_INIT_COPY_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| +--->BN_MP_DIV_2D_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLEAR_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| +--->BN_MP_CLEAR_C + + +BN_MP_DIV_2_C ++--->BN_MP_GROW_C ++--->BN_MP_CLAMP_C + + +BN_MP_REDUCE_IS_2K_C ++--->BN_MP_REDUCE_2K_C +| +--->BN_MP_INIT_C +| +--->BN_MP_COUNT_BITS_C +| +--->BN_MP_DIV_2D_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLEAR_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| +--->BN_MP_MUL_D_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_S_MP_ADD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_COUNT_BITS_C + + +BN_MP_INIT_SIZE_C ++--->BN_MP_INIT_C + + +BN_MP_DIV_C ++--->BN_MP_CMP_MAG_C ++--->BN_MP_COPY_C +| +--->BN_MP_GROW_C ++--->BN_MP_ZERO_C ++--->BN_MP_INIT_MULTI_C +| +--->BN_MP_INIT_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_SET_C ++--->BN_MP_COUNT_BITS_C ++--->BN_MP_ABS_C ++--->BN_MP_MUL_2D_C +| +--->BN_MP_GROW_C +| +--->BN_MP_LSHD_C +| | +--->BN_MP_RSHD_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_CMP_C ++--->BN_MP_SUB_C +| +--->BN_S_MP_ADD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C ++--->BN_MP_ADD_C +| +--->BN_S_MP_ADD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C ++--->BN_MP_DIV_2D_C +| +--->BN_MP_INIT_C +| +--->BN_MP_MOD_2D_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CLEAR_C +| +--->BN_MP_RSHD_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C ++--->BN_MP_EXCH_C ++--->BN_MP_CLEAR_MULTI_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_INIT_SIZE_C +| +--->BN_MP_INIT_C ++--->BN_MP_INIT_C ++--->BN_MP_INIT_COPY_C ++--->BN_MP_LSHD_C +| +--->BN_MP_GROW_C +| +--->BN_MP_RSHD_C ++--->BN_MP_RSHD_C ++--->BN_MP_MUL_D_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_CLAMP_C ++--->BN_MP_CLEAR_C + + +BN_MP_CLEAR_C + + +BN_MP_MONTGOMERY_REDUCE_C ++--->BN_FAST_MP_MONTGOMERY_REDUCE_C +| +--->BN_MP_GROW_C +| +--->BN_MP_RSHD_C +| | +--->BN_MP_ZERO_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C ++--->BN_MP_GROW_C ++--->BN_MP_CLAMP_C ++--->BN_MP_RSHD_C +| +--->BN_MP_ZERO_C ++--->BN_MP_CMP_MAG_C ++--->BN_S_MP_SUB_C + + +BN_MP_MUL_2_C ++--->BN_MP_GROW_C + + +BN_MP_UNSIGNED_BIN_SIZE_C ++--->BN_MP_COUNT_BITS_C + + +BN_MP_ADDMOD_C ++--->BN_MP_INIT_C ++--->BN_MP_ADD_C +| +--->BN_S_MP_ADD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C ++--->BN_MP_CLEAR_C ++--->BN_MP_MOD_C +| +--->BN_MP_DIV_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_INIT_MULTI_C +| | +--->BN_MP_SET_C +| | +--->BN_MP_COUNT_BITS_C +| | +--->BN_MP_ABS_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2D_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_MULTI_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_INIT_COPY_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C + + +BN_MP_ADD_C ++--->BN_S_MP_ADD_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_CMP_MAG_C ++--->BN_S_MP_SUB_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C + + +BN_MP_TO_SIGNED_BIN_N_C ++--->BN_MP_SIGNED_BIN_SIZE_C +| +--->BN_MP_UNSIGNED_BIN_SIZE_C +| | +--->BN_MP_COUNT_BITS_C ++--->BN_MP_TO_SIGNED_BIN_C +| +--->BN_MP_TO_UNSIGNED_BIN_C +| | +--->BN_MP_INIT_COPY_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_DIV_2D_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C + + +BN_MP_REDUCE_IS_2K_L_C + + +BN_MP_RAND_C ++--->BN_MP_ZERO_C ++--->BN_MP_ADD_D_C +| +--->BN_MP_GROW_C +| +--->BN_MP_SUB_D_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_LSHD_C +| +--->BN_MP_GROW_C +| +--->BN_MP_RSHD_C + + +BN_MP_CNT_LSB_C + + +BN_MP_2EXPT_C ++--->BN_MP_ZERO_C ++--->BN_MP_GROW_C + + +BN_MP_RSHD_C ++--->BN_MP_ZERO_C + + +BN_MP_SHRINK_C + + +BN_MP_TO_UNSIGNED_BIN_N_C ++--->BN_MP_UNSIGNED_BIN_SIZE_C +| +--->BN_MP_COUNT_BITS_C ++--->BN_MP_TO_UNSIGNED_BIN_C +| +--->BN_MP_INIT_COPY_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| +--->BN_MP_DIV_2D_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLEAR_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| +--->BN_MP_CLEAR_C + + +BN_MP_REDUCE_C ++--->BN_MP_REDUCE_SETUP_C +| +--->BN_MP_2EXPT_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_DIV_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_INIT_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_SET_C +| | +--->BN_MP_COUNT_BITS_C +| | +--->BN_MP_ABS_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2D_C +| | | +--->BN_MP_INIT_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_MULTI_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_INIT_C +| | +--->BN_MP_INIT_C +| | +--->BN_MP_INIT_COPY_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLEAR_C ++--->BN_MP_INIT_COPY_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C ++--->BN_MP_RSHD_C +| +--->BN_MP_ZERO_C ++--->BN_MP_MUL_C +| +--->BN_MP_TOOM_MUL_C +| | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_MUL_2_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_3_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLEAR_MULTI_C +| | | +--->BN_MP_CLEAR_C +| +--->BN_MP_KARATSUBA_MUL_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLEAR_C +| +--->BN_FAST_S_MP_MUL_DIGS_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_S_MP_MUL_DIGS_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C ++--->BN_S_MP_MUL_HIGH_DIGS_C +| +--->BN_FAST_S_MP_MUL_HIGH_DIGS_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_INIT_SIZE_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C +| +--->BN_MP_CLEAR_C ++--->BN_FAST_S_MP_MUL_HIGH_DIGS_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_MOD_2D_C +| +--->BN_MP_ZERO_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_S_MP_MUL_DIGS_C +| +--->BN_FAST_S_MP_MUL_DIGS_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_INIT_SIZE_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_SUB_C +| +--->BN_S_MP_ADD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C ++--->BN_MP_CMP_D_C ++--->BN_MP_SET_C +| +--->BN_MP_ZERO_C ++--->BN_MP_LSHD_C +| +--->BN_MP_GROW_C ++--->BN_MP_ADD_C +| +--->BN_S_MP_ADD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C ++--->BN_MP_CMP_C +| +--->BN_MP_CMP_MAG_C ++--->BN_S_MP_SUB_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_CLEAR_C + + +BN_MP_MUL_2D_C ++--->BN_MP_COPY_C +| +--->BN_MP_GROW_C ++--->BN_MP_GROW_C ++--->BN_MP_LSHD_C +| +--->BN_MP_RSHD_C +| | +--->BN_MP_ZERO_C ++--->BN_MP_CLAMP_C + + +BN_MP_GET_INT_C + + +BN_MP_JACOBI_C ++--->BN_MP_CMP_D_C ++--->BN_MP_INIT_COPY_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C ++--->BN_MP_CNT_LSB_C ++--->BN_MP_DIV_2D_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_ZERO_C +| +--->BN_MP_MOD_2D_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CLEAR_C +| +--->BN_MP_RSHD_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C ++--->BN_MP_MOD_C +| +--->BN_MP_DIV_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_SET_C +| | +--->BN_MP_COUNT_BITS_C +| | +--->BN_MP_ABS_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_MULTI_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_CLEAR_C +| +--->BN_MP_ADD_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C ++--->BN_MP_CLEAR_C + + +BN_MP_CLEAR_MULTI_C ++--->BN_MP_CLEAR_C + + +BN_MP_MUL_C ++--->BN_MP_TOOM_MUL_C +| +--->BN_MP_INIT_MULTI_C +| | +--->BN_MP_INIT_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_MOD_2D_C +| | +--->BN_MP_ZERO_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_RSHD_C +| | +--->BN_MP_ZERO_C +| +--->BN_MP_MUL_2_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_ADD_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_SUB_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_DIV_2_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_MUL_2D_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_LSHD_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_MUL_D_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_DIV_3_C +| | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_INIT_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_LSHD_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_CLEAR_MULTI_C +| | +--->BN_MP_CLEAR_C ++--->BN_MP_KARATSUBA_MUL_C +| +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_INIT_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_SUB_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| +--->BN_MP_ADD_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_CMP_MAG_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| +--->BN_MP_LSHD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_RSHD_C +| | | +--->BN_MP_ZERO_C +| +--->BN_MP_CLEAR_C ++--->BN_FAST_S_MP_MUL_DIGS_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_S_MP_MUL_DIGS_C +| +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_INIT_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C +| +--->BN_MP_CLEAR_C + + +BN_MP_EXTEUCLID_C ++--->BN_MP_INIT_MULTI_C +| +--->BN_MP_INIT_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_SET_C +| +--->BN_MP_ZERO_C ++--->BN_MP_COPY_C +| +--->BN_MP_GROW_C ++--->BN_MP_DIV_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_MP_ZERO_C +| +--->BN_MP_COUNT_BITS_C +| +--->BN_MP_ABS_C +| +--->BN_MP_MUL_2D_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_C +| +--->BN_MP_SUB_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_ADD_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_DIV_2D_C +| | +--->BN_MP_INIT_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLEAR_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| +--->BN_MP_EXCH_C +| +--->BN_MP_CLEAR_MULTI_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_INIT_C +| +--->BN_MP_INIT_C +| +--->BN_MP_INIT_COPY_C +| +--->BN_MP_LSHD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_RSHD_C +| +--->BN_MP_RSHD_C +| +--->BN_MP_MUL_D_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_CLEAR_C ++--->BN_MP_MUL_C +| +--->BN_MP_TOOM_MUL_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_RSHD_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_MUL_2_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_3_C +| | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_INIT_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLEAR_MULTI_C +| | | +--->BN_MP_CLEAR_C +| +--->BN_MP_KARATSUBA_MUL_C +| | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_INIT_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| | +--->BN_MP_CLEAR_C +| +--->BN_FAST_S_MP_MUL_DIGS_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_S_MP_MUL_DIGS_C +| | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_INIT_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C ++--->BN_MP_SUB_C +| +--->BN_S_MP_ADD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C ++--->BN_MP_NEG_C ++--->BN_MP_EXCH_C ++--->BN_MP_CLEAR_MULTI_C +| +--->BN_MP_CLEAR_C + + +BN_MP_DR_REDUCE_C ++--->BN_MP_GROW_C ++--->BN_MP_CLAMP_C ++--->BN_MP_CMP_MAG_C ++--->BN_S_MP_SUB_C + + +BN_MP_FREAD_C ++--->BN_MP_ZERO_C ++--->BN_MP_MUL_D_C +| +--->BN_MP_GROW_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_ADD_D_C +| +--->BN_MP_GROW_C +| +--->BN_MP_SUB_D_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_CMP_D_C + + +BN_MP_REDUCE_SETUP_C ++--->BN_MP_2EXPT_C +| +--->BN_MP_ZERO_C +| +--->BN_MP_GROW_C ++--->BN_MP_DIV_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_ZERO_C +| +--->BN_MP_INIT_MULTI_C +| | +--->BN_MP_INIT_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_SET_C +| +--->BN_MP_COUNT_BITS_C +| +--->BN_MP_ABS_C +| +--->BN_MP_MUL_2D_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CMP_C +| +--->BN_MP_SUB_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_ADD_C +| | +--->BN_S_MP_ADD_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_S_MP_SUB_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| +--->BN_MP_DIV_2D_C +| | +--->BN_MP_INIT_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_CLEAR_C +| | +--->BN_MP_RSHD_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| +--->BN_MP_EXCH_C +| +--->BN_MP_CLEAR_MULTI_C +| | +--->BN_MP_CLEAR_C +| +--->BN_MP_INIT_SIZE_C +| | +--->BN_MP_INIT_C +| +--->BN_MP_INIT_C +| +--->BN_MP_INIT_COPY_C +| +--->BN_MP_LSHD_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_RSHD_C +| +--->BN_MP_RSHD_C +| +--->BN_MP_MUL_D_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_CLEAR_C + + +BN_MP_MONTGOMERY_SETUP_C + + +BN_MP_KARATSUBA_MUL_C ++--->BN_MP_MUL_C +| +--->BN_MP_TOOM_MUL_C +| | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_INIT_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_MOD_2D_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_RSHD_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_MUL_2_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_SUB_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_2_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_2D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MUL_D_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_DIV_3_C +| | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_INIT_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_LSHD_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_CLEAR_MULTI_C +| | | +--->BN_MP_CLEAR_C +| +--->BN_FAST_S_MP_MUL_DIGS_C +| | +--->BN_MP_GROW_C +| | +--->BN_MP_CLAMP_C +| +--->BN_S_MP_MUL_DIGS_C +| | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_INIT_C +| | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C +| | +--->BN_MP_CLEAR_C ++--->BN_MP_INIT_SIZE_C +| +--->BN_MP_INIT_C ++--->BN_MP_CLAMP_C ++--->BN_MP_SUB_C +| +--->BN_S_MP_ADD_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C ++--->BN_MP_ADD_C +| +--->BN_S_MP_ADD_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_CMP_MAG_C +| +--->BN_S_MP_SUB_C +| | +--->BN_MP_GROW_C ++--->BN_MP_LSHD_C +| +--->BN_MP_GROW_C +| +--->BN_MP_RSHD_C +| | +--->BN_MP_ZERO_C ++--->BN_MP_CLEAR_C + + +BN_MP_LSHD_C ++--->BN_MP_GROW_C ++--->BN_MP_RSHD_C +| +--->BN_MP_ZERO_C + + +BN_MP_PRIME_MILLER_RABIN_C ++--->BN_MP_CMP_D_C ++--->BN_MP_INIT_COPY_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C ++--->BN_MP_SUB_D_C +| +--->BN_MP_GROW_C +| +--->BN_MP_ADD_D_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CLAMP_C ++--->BN_MP_CNT_LSB_C ++--->BN_MP_DIV_2D_C +| +--->BN_MP_COPY_C +| | +--->BN_MP_GROW_C +| +--->BN_MP_ZERO_C +| +--->BN_MP_MOD_2D_C +| | +--->BN_MP_CLAMP_C +| +--->BN_MP_CLEAR_C +| +--->BN_MP_RSHD_C +| +--->BN_MP_CLAMP_C +| +--->BN_MP_EXCH_C ++--->BN_MP_EXPTMOD_C +| +--->BN_MP_INVMOD_C +| | +--->BN_FAST_MP_INVMOD_C +| | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_MOD_C +| | | | +--->BN_MP_DIV_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_SET_C +| | | | | +--->BN_MP_COUNT_BITS_C +| | | | | +--->BN_MP_ABS_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_CLEAR_MULTI_C +| | | | | | +--->BN_MP_CLEAR_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_SET_C +| | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_DIV_2_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_MULTI_C +| | | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_INVMOD_SLOW_C +| | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_MOD_C +| | | | +--->BN_MP_DIV_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_SET_C +| | | | | +--->BN_MP_COUNT_BITS_C +| | | | | +--->BN_MP_ABS_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_CLEAR_MULTI_C +| | | | | | +--->BN_MP_CLEAR_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_CLEAR_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_SET_C +| | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_DIV_2_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_MULTI_C +| | | | +--->BN_MP_CLEAR_C +| +--->BN_MP_CLEAR_C +| +--->BN_MP_ABS_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| +--->BN_MP_CLEAR_MULTI_C +| +--->BN_MP_REDUCE_IS_2K_L_C +| +--->BN_S_MP_EXPTMOD_C +| | +--->BN_MP_COUNT_BITS_C +| | +--->BN_MP_REDUCE_SETUP_C +| | | +--->BN_MP_2EXPT_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_DIV_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_SET_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_REDUCE_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_MUL_C +| | | | +--->BN_MP_TOOM_MUL_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_MOD_2D_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_COPY_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_MUL_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_3_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_KARATSUBA_MUL_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_MUL_DIGS_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | +--->BN_S_MP_MUL_HIGH_DIGS_C +| | | | +--->BN_FAST_S_MP_MUL_HIGH_DIGS_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_FAST_S_MP_MUL_HIGH_DIGS_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_MUL_DIGS_C +| | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SET_C +| | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_REDUCE_2K_SETUP_L_C +| | | +--->BN_MP_2EXPT_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_REDUCE_2K_L_C +| | | +--->BN_MP_MUL_C +| | | | +--->BN_MP_TOOM_MUL_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_MOD_2D_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_COPY_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_MUL_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_3_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_KARATSUBA_MUL_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_MUL_DIGS_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MOD_C +| | | +--->BN_MP_DIV_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_SET_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_SQR_C +| | | +--->BN_MP_TOOM_SQR_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_MUL_2_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_2_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_3_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_KARATSUBA_SQR_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | +--->BN_FAST_S_MP_SQR_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SQR_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | +--->BN_MP_MUL_C +| | | +--->BN_MP_TOOM_MUL_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_MUL_2_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_2_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_3_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_KARATSUBA_MUL_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_MUL_DIGS_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | +--->BN_MP_SET_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_EXCH_C +| +--->BN_MP_DR_IS_MODULUS_C +| +--->BN_MP_REDUCE_IS_2K_C +| | +--->BN_MP_REDUCE_2K_C +| | | +--->BN_MP_COUNT_BITS_C +| | | +--->BN_MP_MUL_D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_COUNT_BITS_C +| +--->BN_MP_EXPTMOD_FAST_C +| | +--->BN_MP_COUNT_BITS_C +| | +--->BN_MP_MONTGOMERY_SETUP_C +| | +--->BN_FAST_MP_MONTGOMERY_REDUCE_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | +--->BN_MP_MONTGOMERY_REDUCE_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | +--->BN_MP_DR_SETUP_C +| | +--->BN_MP_DR_REDUCE_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | +--->BN_MP_REDUCE_2K_SETUP_C +| | | +--->BN_MP_2EXPT_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_REDUCE_2K_C +| | | +--->BN_MP_MUL_D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MONTGOMERY_CALC_NORMALIZATION_C +| | | +--->BN_MP_2EXPT_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_SET_C +| | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_MUL_2_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_MULMOD_C +| | | +--->BN_MP_MUL_C +| | | | +--->BN_MP_TOOM_MUL_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_MOD_2D_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | | +--->BN_MP_COPY_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_MUL_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_2_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_DIV_3_C +| | | | | | +--->BN_MP_INIT_SIZE_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_KARATSUBA_MUL_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CMP_MAG_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_MUL_DIGS_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_MOD_C +| | | | +--->BN_MP_DIV_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_MP_COPY_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_INIT_MULTI_C +| | | | | +--->BN_MP_SET_C +| | | | | +--->BN_MP_MUL_2D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_LSHD_C +| | | | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_C +| | | | | +--->BN_MP_SUB_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_ADD_C +| | | | | | +--->BN_S_MP_ADD_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | | +--->BN_S_MP_SUB_C +| | | | | | | +--->BN_MP_GROW_C +| | | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_MUL_D_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | +--->BN_MP_SET_C +| | | +--->BN_MP_ZERO_C +| | +--->BN_MP_MOD_C +| | | +--->BN_MP_DIV_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | +--->BN_MP_COPY_C +| | | +--->BN_MP_GROW_C +| | +--->BN_MP_SQR_C +| | | +--->BN_MP_TOOM_SQR_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_MUL_2_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_2_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_3_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_KARATSUBA_SQR_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | +--->BN_FAST_S_MP_SQR_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_SQR_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | +--->BN_MP_MUL_C +| | | +--->BN_MP_TOOM_MUL_C +| | | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_MOD_2D_C +| | | | | +--->BN_MP_ZERO_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_MUL_2_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_2_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_2D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_MUL_D_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_DIV_3_C +| | | | | +--->BN_MP_INIT_SIZE_C +| | | | | +--->BN_MP_CLAMP_C +| | | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_KARATSUBA_MUL_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_SUB_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_ADD_C +| | | | | +--->BN_S_MP_ADD_C +| | | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CMP_MAG_C +| | | | | +--->BN_S_MP_SUB_C +| | | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_RSHD_C +| | | | | | +--->BN_MP_ZERO_C +| | | +--->BN_FAST_S_MP_MUL_DIGS_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_S_MP_MUL_DIGS_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | +--->BN_MP_EXCH_C ++--->BN_MP_CMP_C +| +--->BN_MP_CMP_MAG_C ++--->BN_MP_SQRMOD_C +| +--->BN_MP_SQR_C +| | +--->BN_MP_TOOM_SQR_C +| | | +--->BN_MP_INIT_MULTI_C +| | | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_MOD_2D_C +| | | | +--->BN_MP_ZERO_C +| | | | +--->BN_MP_COPY_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_MUL_2_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_2_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MUL_2D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_MUL_D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_DIV_3_C +| | | | +--->BN_MP_INIT_SIZE_C +| | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_MP_EXCH_C +| | | | +--->BN_MP_CLEAR_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLEAR_MULTI_C +| | | | +--->BN_MP_CLEAR_C +| | +--->BN_MP_KARATSUBA_SQR_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_RSHD_C +| | | | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_MP_CMP_MAG_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLEAR_C +| | +--->BN_FAST_S_MP_SQR_C +| | | +--->BN_MP_GROW_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_S_MP_SQR_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_C +| +--->BN_MP_CLEAR_C +| +--->BN_MP_MOD_C +| | +--->BN_MP_DIV_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_MP_COPY_C +| | | | +--->BN_MP_GROW_C +| | | +--->BN_MP_ZERO_C +| | | +--->BN_MP_INIT_MULTI_C +| | | +--->BN_MP_SET_C +| | | +--->BN_MP_COUNT_BITS_C +| | | +--->BN_MP_ABS_C +| | | +--->BN_MP_MUL_2D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_LSHD_C +| | | | | +--->BN_MP_RSHD_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_SUB_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_ADD_C +| | | | +--->BN_S_MP_ADD_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | | +--->BN_S_MP_SUB_C +| | | | | +--->BN_MP_GROW_C +| | | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_EXCH_C +| | | +--->BN_MP_CLEAR_MULTI_C +| | | +--->BN_MP_INIT_SIZE_C +| | | +--->BN_MP_LSHD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_RSHD_C +| | | +--->BN_MP_MUL_D_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_ADD_C +| | | +--->BN_S_MP_ADD_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | | +--->BN_MP_CMP_MAG_C +| | | +--->BN_S_MP_SUB_C +| | | | +--->BN_MP_GROW_C +| | | | +--->BN_MP_CLAMP_C +| | +--->BN_MP_EXCH_C ++--->BN_MP_CLEAR_C + + +BN_MP_DR_SETUP_C + + +BN_MP_CMP_MAG_C + + ADDED libtommath/changes.txt Index: libtommath/changes.txt ================================================================== --- /dev/null +++ libtommath/changes.txt @@ -0,0 +1,372 @@ +August 1st, 2005 +v0.36 -- LTM_PRIME_2MSB_ON was fixed and the "OFF" flag was removed. + -- [Peter LaDow] found a typo in the XREALLOC macro + -- [Peter LaDow] pointed out that mp_read_(un)signed_bin should have "const" on the input + -- Ported LTC patch to fix the prime_random_ex() function to get the bitsize correct [and the maskOR flags] + -- Kevin Kenny pointed out a stray // + -- David Hulton pointed out a typo in the textbook [mp_montgomery_setup() pseudo-code] + -- Neal Hamilton (Elliptic Semiconductor) pointed out that my Karatsuba notation was backwards and that I could use + unsigned operations in the routine. + -- Paul Schmidt pointed out a linking error in mp_exptmod() when BN_S_MP_EXPTMOD_C is undefined (and another for read_radix) + -- Updated makefiles to be way more flexible + +March 12th, 2005 +v0.35 -- Stupid XOR function missing line again... oops. + -- Fixed bug in invmod not handling negative inputs correctly [Wolfgang Ehrhardt] + -- Made exteuclid always give positive u3 output...[ Wolfgang Ehrhardt ] + -- [Wolfgang Ehrhardt] Suggested a fix for mp_reduce() which avoided underruns. ;-) + -- mp_rand() would emit one too many digits and it was possible to get a 0 out of it ... oops + -- Added montgomery to the testing to make sure it handles 1..10 digit moduli correctly + -- Fixed bug in comba that would lead to possible erroneous outputs when "pa < digs" + -- Fixed bug in mp_toradix_size for "0" [Kevin Kenny] + -- Updated chapters 1-5 of the textbook ;-) It now talks about the new comba code! + +February 12th, 2005 +v0.34 -- Fixed two more small errors in mp_prime_random_ex() + -- Fixed overflow in mp_mul_d() [Kevin Kenny] + -- Added mp_to_(un)signed_bin_n() functions which do bounds checking for ya [and report the size] + -- Added "large" diminished radix support. Speeds up things like DSA where the moduli is of the form 2^k - P for some P < 2^(k/2) or so + Actually is faster than Montgomery on my AMD64 (and probably much faster on a P4) + -- Updated the manual a bit + -- Ok so I haven't done the textbook work yet... My current freelance gig has landed me in France till the + end of Feb/05. Once I get back I'll have tons of free time and I plan to go to town on the book. + As of this release the API will freeze. At least until the book catches up with all the changes. I welcome + bug reports but new algorithms will have to wait. + +December 23rd, 2004 +v0.33 -- Fixed "small" variant for mp_div() which would munge with negative dividends... + -- Fixed bug in mp_prime_random_ex() which would set the most significant byte to zero when + no special flags were set + -- Fixed overflow [minor] bug in fast_s_mp_sqr() + -- Made the makefiles easier to configure the group/user that ltm will install as + -- Fixed "final carry" bug in comba multipliers. (Volkan Ceylan) + -- Matt Johnston pointed out a missing semi-colon in mp_exptmod + +October 29th, 2004 +v0.32 -- Added "makefile.shared" for shared object support + -- Added more to the build options/configs in the manual + -- Started the Depends framework, wrote dep.pl to scan deps and + produce "callgraph.txt" ;-) + -- Wrote SC_RSA_1 which will enable close to the minimum required to perform + RSA on 32-bit [or 64-bit] platforms with LibTomCrypt + -- Merged in the small/slower mp_div replacement. You can now toggle which + you want to use as your mp_div() at build time. Saves roughly 8KB or so. + -- Renamed a few files and changed some comments to make depends system work better. + (No changes to function names) + -- Merged in new Combas that perform 2 reads per inner loop instead of the older + 3reads/2writes per inner loop of the old code. Really though if you want speed + learn to use TomsFastMath ;-) + +August 9th, 2004 +v0.31 -- "profiled" builds now :-) new timings for Intel Northwoods + -- Added "pretty" build target + -- Update mp_init() to actually assign 0's instead of relying on calloc() + -- "Wolfgang Ehrhardt" found a bug in mp_mul() where if + you multiply a negative by zero you get negative zero as the result. Oops. + -- J Harper from PeerSec let me toy with his AMD64 and I got 60-bit digits working properly + [this also means that I fixed a bug where if sizeof(int) < sizeof(mp_digit) it would bug] + +April 11th, 2004 +v0.30 -- Added "mp_toradix_n" which stores upto "n-1" least significant digits of an mp_int + -- Johan Lindh sent a patch so MSVC wouldn't whine about redefining malloc [in weird dll modes] + -- Henrik Goldman spotted a missing OPT_CAST in mp_fwrite() + -- Tuned tommath.h so that when MP_LOW_MEM is defined MP_PREC shall be reduced. + [I also allow MP_PREC to be externally defined now] + -- Sped up mp_cnt_lsb() by using a 4x4 table [e.g. 4x speedup] + -- Added mp_prime_random_ex() which is a more versatile prime generator accurate to + exact bit lengths (unlike the deprecated but still available mp_prime_random() which + is only accurate to byte lengths). See the new LTM_PRIME_* flags ;-) + -- Alex Polushin contributed an optimized mp_sqrt() as well as mp_get_int() and mp_is_square(). + I've cleaned them all up to be a little more consistent [along with one bug fix] for this release. + -- Added mp_init_set and mp_init_set_int to initialize and set small constants with one function + call. + -- Removed /etclib directory [um LibTomPoly deprecates this]. + -- Fixed mp_mod() so the sign of the result agrees with the sign of the modulus. + ++ N.B. My semester is almost up so expect updates to the textbook to be posted to the libtomcrypt.org + website. + +Jan 25th, 2004 +v0.29 ++ Note: "Henrik" from the v0.28 changelog refers to Henrik Goldman ;-) + -- Added fix to mp_shrink to prevent a realloc when used == 0 [e.g. realloc zero bytes???] + -- Made the mp_prime_rabin_miller_trials() function internal table smaller and also + set the minimum number of tests to two (sounds a bit safer). + -- Added a mp_exteuclid() which computes the extended euclidean algorithm. + -- Fixed a memory leak in s_mp_exptmod() [called when Barrett reduction is to be used] which would arise + if a multiplication or subsequent reduction failed [would not free the temp result]. + -- Made an API change to mp_radix_size(). It now returns an error code and stores the required size + through an "int star" passed to it. + +Dec 24th, 2003 +v0.28 -- Henrik Goldman suggested I add casts to the montomgery code [stores into mu...] so compilers wouldn't + spew [erroneous] diagnostics... fixed. + -- Henrik Goldman also spotted two typos. One in mp_radix_size() and another in mp_toradix(). + -- Added fix to mp_shrink() to avoid a memory leak. + -- Added mp_prime_random() which requires a callback to make truly random primes of a given nature + (idea from chat with Niels Ferguson at Crypto'03) + -- Picked up a second wind. I'm filled with Gooo. Mission Gooo! + -- Removed divisions from mp_reduce_is_2k() + -- Sped up mp_div_d() [general case] to use only one division per digit instead of two. + -- Added the heap macros from LTC to LTM. Now you can easily [by editing four lines of tommath.h] + change the name of the heap functions used in LTM [also compatible with LTC via MPI mode] + -- Added bn_prime_rabin_miller_trials() which gives the number of Rabin-Miller trials to achieve + a failure rate of less than 2^-96 + -- fixed bug in fast_mp_invmod(). The initial testing logic was wrong. An invalid input is not when + "a" and "b" are even it's when "b" is even [the algo is for odd moduli only]. + -- Started a new manual [finally]. It is incomplete and will be finished as time goes on. I had to stop + adding full demos around half way in chapter three so I could at least get a good portion of the + manual done. If you really need help using the library you can always email me! + -- My Textbook is now included as part of the package [all Public Domain] + +Sept 19th, 2003 +v0.27 -- Removed changes.txt~ which was made by accident since "kate" decided it was + a good time to re-enable backups... [kde is fun!] + -- In mp_grow() "a->dp" is not overwritten by realloc call [re: memory leak] + Now if mp_grow() fails the mp_int is still valid and can be cleared via + mp_clear() to reclaim the memory. + -- Henrik Goldman found a buffer overflow bug in mp_add_d(). Fixed. + -- Cleaned up mp_mul_d() to be much easier to read and follow. + +Aug 29th, 2003 +v0.26 -- Fixed typo that caused warning with GCC 3.2 + -- Martin Marcel noticed a bug in mp_neg() that allowed negative zeroes. + Also, Martin is the fellow who noted the bugs in mp_gcd() of 0.24/0.25. + -- Martin Marcel noticed an optimization [and slight bug] in mp_lcm(). + -- Added fix to mp_read_unsigned_bin to prevent a buffer overflow. + -- Beefed up the comments in the baseline multipliers [and montgomery] + -- Added "mont" demo to the makefile.msvc in etc/ + -- Optimized sign compares in mp_cmp from 4 to 2 cases. + +Aug 4th, 2003 +v0.25 -- Fix to mp_gcd again... oops (0,-a) == (-a, 0) == a + -- Fix to mp_clear which didn't reset the sign [Greg Rose] + -- Added mp_error_to_string() to convert return codes to strings. [Greg Rose] + -- Optimized fast_mp_invmod() to do the test for invalid inputs [both even] + first so temps don't have to be initialized if it's going to fail. + -- Optimized mp_gcd() by removing mp_div_2d calls for when one of the inputs + is odd. + -- Tons of new comments, some indentation fixups, etc. + -- mp_jacobi() returns MP_VAL if the modulus is less than or equal to zero. + -- fixed two typos in the header of each file :-) + -- LibTomMath is officially Public Domain [see LICENSE] + +July 15th, 2003 +v0.24 -- Optimized mp_add_d and mp_sub_d to not allocate temporary variables + -- Fixed mp_gcd() so the gcd of 0,0 is 0. Allows the gcd operation to be chained + e.g. (0,0,a) == a [instead of 1] + -- Should be one of the last release for a while. Working on LibTomMath book now. + -- optimized the pprime demo [/etc/pprime.c] to first make a huge table of single + digit primes then it reads them randomly instead of randomly choosing/testing single + digit primes. + +July 12th, 2003 +v0.23 -- Optimized mp_prime_next_prime() to not use mp_mod [via is_divisible()] in each + iteration. Instead now a smaller table is kept of the residues which can be updated + without division. + -- Fixed a bug in next_prime() where an input of zero would be treated as odd and + have two added to it [to move to the next odd]. + -- fixed a bug in prime_fermat() and prime_miller_rabin() which allowed the base + to be negative, zero or one. Normally the test is only valid if the base is + greater than one. + -- changed the next_prime() prototype to accept a new parameter "bbs_style" which + will find the next prime congruent to 3 mod 4. The default [bbs_style==0] will + make primes which are either congruent to 1 or 3 mod 4. + -- fixed mp_read_unsigned_bin() so that it doesn't include both code for + the case DIGIT_BIT < 8 and >= 8 + -- optimized div_d() to easy out on division by 1 [or if a == 0] and use + logical shifts if the divisor is a power of two. + -- the default DIGIT_BIT type was not int for non-default builds. Fixed. + +July 2nd, 2003 +v0.22 -- Fixed up mp_invmod so the result is properly in range now [was always congruent to the inverse...] + -- Fixed up s_mp_exptmod and mp_exptmod_fast so the lower half of the pre-computed table isn't allocated + which makes the algorithm use half as much ram. + -- Fixed the install script not to make the book :-) [which isn't included anyways] + -- added mp_cnt_lsb() which counts how many of the lsbs are zero + -- optimized mp_gcd() to use the new mp_cnt_lsb() to replace multiple divisions by two by a single division. + -- applied similar optimization to mp_prime_miller_rabin(). + -- Fixed a bug in both mp_invmod() and fast_mp_invmod() which tested for odd + via "mp_iseven() == 0" which is not valid [since zero is not even either]. + +June 19th, 2003 +v0.21 -- Fixed bug in mp_mul_d which would not handle sign correctly [would not always forward it] + -- Removed the #line lines from gen.pl [was in violation of ISO C] + +June 8th, 2003 +v0.20 -- Removed the book from the package. Added the TDCAL license document. + -- This release is officially pure-bred TDCAL again [last officially TDCAL based release was v0.16] + +June 6th, 2003 +v0.19 -- Fixed a bug in mp_montgomery_reduce() which was introduced when I tweaked mp_rshd() in the previous release. + Essentially the digits were not trimmed before the compare which cause a subtraction to occur all the time. + -- Fixed up etc/tune.c a bit to stop testing new cutoffs after 16 failures [to find more optimal points]. + Brute force ho! + + +May 29th, 2003 +v0.18 -- Fixed a bug in s_mp_sqr which would handle carries properly just not very elegantly. + (e.g. correct result, just bad looking code) + -- Fixed bug in mp_sqr which still had a 512 constant instead of MP_WARRAY + -- Added Toom-Cook multipliers [needs tuning!] + -- Added efficient divide by 3 algorithm mp_div_3 + -- Re-wrote mp_div_d to be faster than calling mp_div + -- Added in a donated BCC makefile and a single page LTM poster (ahalhabsi@sbcglobal.net) + -- Added mp_reduce_2k which reduces an input modulo n = 2**p - k for any single digit k + -- Made the exptmod system be aware of the 2k reduction algorithms. + -- Rewrote mp_dr_reduce to be smaller, simpler and easier to understand. + +May 17th, 2003 +v0.17 -- Benjamin Goldberg submitted optimized mp_add and mp_sub routines. A new gen.pl as well + as several smaller suggestions. Thanks! + -- removed call to mp_cmp in inner loop of mp_div and put mp_cmp_mag in its place :-) + -- Fixed bug in mp_exptmod that would cause it to fail for odd moduli when DIGIT_BIT != 28 + -- mp_exptmod now also returns errors if the modulus is negative and will handle negative exponents + -- mp_prime_is_prime will now return true if the input is one of the primes in the prime table + -- Damian M Gryski (dgryski@uwaterloo.ca) found a index out of bounds error in the + mp_fast_s_mp_mul_high_digs function which didn't come up before. (fixed) + -- Refactored the DR reduction code so there is only one function per file. + -- Fixed bug in the mp_mul() which would erroneously avoid the faster multiplier [comba] when it was + allowed. The bug would not cause the incorrect value to be produced just less efficient (fixed) + -- Fixed similar bug in the Montgomery reduction code. + -- Added tons of (mp_digit) casts so the 7/15/28/31 bit digit code will work flawlessly out of the box. + Also added limited support for 64-bit machines with a 60-bit digit. Both thanks to Tom Wu (tom@arcot.com) + -- Added new comments here and there, cleaned up some code [style stuff] + -- Fixed a lingering typo in mp_exptmod* that would set bitcnt to zero then one. Very silly stuff :-) + -- Fixed up mp_exptmod_fast so it would set "redux" to the comba Montgomery reduction if allowed. This + saves quite a few calls and if statements. + -- Added etc/mont.c a test of the Montgomery reduction [assuming all else works :-| ] + -- Fixed up etc/tune.c to use a wider test range [more appropriate] also added a x86 based addition which + uses RDTSC for high precision timing. + -- Updated demo/demo.c to remove MPI stuff [won't work anyways], made the tests run for 2 seconds each so its + not so insanely slow. Also made the output space delimited [and fixed up various errors] + -- Added logs directory, logs/graph.dem which will use gnuplot to make a series of PNG files + that go with the pre-made index.html. You have to build [via make timing] and run ltmtest first in the + root of the package. + -- Fixed a bug in mp_sub and mp_add where "-a - -a" or "-a + a" would produce -0 as the result [obviously invalid]. + -- Fixed a bug in mp_rshd. If the count == a.used it should zero/return [instead of shifting] + -- Fixed a "off-by-one" bug in mp_mul2d. The initial size check on alloc would be off by one if the residue + shifting caused a carry. + -- Fixed a bug where s_mp_mul_digs() would not call the Comba based routine if allowed. This made Barrett reduction + slower than it had to be. + +Mar 29th, 2003 +v0.16 -- Sped up mp_div by making normalization one shift call + -- Sped up mp_mul_2d/mp_div_2d by aliasing pointers :-) + -- Cleaned up mp_gcd to use the macros for odd/even detection + -- Added comments here and there, mostly there but occasionally here too. + +Mar 22nd, 2003 +v0.15 -- Added series of prime testing routines to lib + -- Fixed up etc/tune.c + -- Added DR reduction algorithm + -- Beefed up the manual more. + -- Fixed up demo/demo.c so it doesn't have so many warnings and it does the full series of + tests + -- Added "pre-gen" directory which will hold a "gen.pl"'ed copy of the entire lib [done at + zipup time so its always the latest] + -- Added conditional casts for C++ users [boo!] + +Mar 15th, 2003 +v0.14 -- Tons of manual updates + -- cleaned up the directory + -- added MSVC makefiles + -- source changes [that I don't recall] + -- Fixed up the lshd/rshd code to use pointer aliasing + -- Fixed up the mul_2d and div_2d to not call rshd/lshd unless needed + -- Fixed up etc/tune.c a tad + -- fixed up demo/demo.c to output comma-delimited results of timing + also fixed up timing demo to use a finer granularity for various functions + -- fixed up demo/demo.c testing to pause during testing so my Duron won't catch on fire + [stays around 31-35C during testing :-)] + +Feb 13th, 2003 +v0.13 -- tons of minor speed-ups in low level add, sub, mul_2 and div_2 which propagate + to other functions like mp_invmod, mp_div, etc... + -- Sped up mp_exptmod_fast by using new code to find R mod m [e.g. B^n mod m] + -- minor fixes + +Jan 17th, 2003 +v0.12 -- re-wrote the majority of the makefile so its more portable and will + install via "make install" on most *nix platforms + -- Re-packaged all the source as seperate files. Means the library a single + file packagage any more. Instead of just adding "bn.c" you have to add + libtommath.a + -- Renamed "bn.h" to "tommath.h" + -- Changes to the manual to reflect all of this + -- Used GNU Indent to clean up the source + +Jan 15th, 2003 +v0.11 -- More subtle fixes + -- Moved to gentoo linux [hurrah!] so made *nix specific fixes to the make process + -- Sped up the montgomery reduction code quite a bit + -- fixed up demo so when building timing for the x86 it assumes ELF format now + +Jan 9th, 2003 +v0.10 -- Pekka Riikonen suggested fixes to the radix conversion code. + -- Added baseline montgomery and comba montgomery reductions, sped up exptmods + [to a point, see bn.h for MONTGOMERY_EXPT_CUTOFF] + +Jan 6th, 2003 +v0.09 -- Updated the manual to reflect recent changes. :-) + -- Added Jacobi function (mp_jacobi) to supplement the number theory side of the lib + -- Added a Mersenne prime finder demo in ./etc/mersenne.c + +Jan 2nd, 2003 +v0.08 -- Sped up the multipliers by moving the inner loop variables into a smaller scope + -- Corrected a bunch of small "warnings" + -- Added more comments + -- Made "mtest" be able to use /dev/random, /dev/urandom or stdin for RNG data + -- Corrected some bugs where error messages were potentially ignored + -- add etc/pprime.c program which makes numbers which are provably prime. + +Jan 1st, 2003 +v0.07 -- Removed alot of heap operations from core functions to speed them up + -- Added a root finding function [and mp_sqrt macro like from MPI] + -- Added more to manual + +Dec 31st, 2002 +v0.06 -- Sped up the s_mp_add, s_mp_sub which inturn sped up mp_invmod, mp_exptmod, etc... + -- Cleaned up the header a bit more + +Dec 30th, 2002 +v0.05 -- Builds with MSVC out of the box + -- Fixed a bug in mp_invmod w.r.t. even moduli + -- Made mp_toradix and mp_read_radix use char instead of unsigned char arrays + -- Fixed up exptmod to use fewer multiplications + -- Fixed up mp_init_size to use only one heap operation + -- Note there is a slight "off-by-one" bug in the library somewhere + without the padding (see the source for comment) the library + crashes in libtomcrypt. Anyways a reasonable workaround is to pad the + numbers which will always correct it since as the numbers grow the padding + will still be beyond the end of the number + -- Added more to the manual + +Dec 29th, 2002 +v0.04 -- Fixed a memory leak in mp_to_unsigned_bin + -- optimized invmod code + -- Fixed bug in mp_div + -- use exchange instead of copy for results + -- added a bit more to the manual + +Dec 27th, 2002 +v0.03 -- Sped up s_mp_mul_high_digs by not computing the carries of the lower digits + -- Fixed a bug where mp_set_int wouldn't zero the value first and set the used member. + -- fixed a bug in s_mp_mul_high_digs where the limit placed on the result digits was not calculated properly + -- fixed bugs in add/sub/mul/sqr_mod functions where if the modulus and dest were the same it wouldn't work + -- fixed a bug in mp_mod and mp_mod_d concerning negative inputs + -- mp_mul_d didn't preserve sign + -- Many many many many fixes + -- Works in LibTomCrypt now :-) + -- Added iterations to the timing demos... more accurate. + -- Tom needs a job. + +Dec 26th, 2002 +v0.02 -- Fixed a few "slips" in the manual. This is "LibTomMath" afterall :-) + -- Added mp_cmp_mag, mp_neg, mp_abs and mp_radix_size that were missing. + -- Sped up the fast [comba] multipliers more [yahoo!] + +Dec 25th,2002 +v0.01 -- Initial release. Gimme a break. + -- Todo list, + add details to manual [e.g. algorithms] + more comments in code + example programs ADDED libtommath/demo/demo.c Index: libtommath/demo/demo.c ================================================================== --- /dev/null +++ libtommath/demo/demo.c @@ -0,0 +1,740 @@ +#include + +#ifdef IOWNANATHLON +#include +#define SLEEP sleep(4) +#else +#define SLEEP +#endif + +#include "tommath.h" + +void ndraw(mp_int * a, char *name) +{ + char buf[16000]; + + printf("%s: ", name); + mp_toradix(a, buf, 10); + printf("%s\n", buf); +} + +static void draw(mp_int * a) +{ + ndraw(a, ""); +} + + +unsigned long lfsr = 0xAAAAAAAAUL; + +int lbit(void) +{ + if (lfsr & 0x80000000UL) { + lfsr = ((lfsr << 1) ^ 0x8000001BUL) & 0xFFFFFFFFUL; + return 1; + } else { + lfsr <<= 1; + return 0; + } +} + +int myrng(unsigned char *dst, int len, void *dat) +{ + int x; + + for (x = 0; x < len; x++) + dst[x] = rand() & 0xFF; + return len; +} + + + +char cmd[4096], buf[4096]; +int main(void) +{ + mp_int a, b, c, d, e, f; + unsigned long expt_n, add_n, sub_n, mul_n, div_n, sqr_n, mul2d_n, div2d_n, + gcd_n, lcm_n, inv_n, div2_n, mul2_n, add_d_n, sub_d_n, t; + unsigned rr; + int i, n, err, cnt, ix, old_kara_m, old_kara_s; + mp_digit mp; + + + mp_init(&a); + mp_init(&b); + mp_init(&c); + mp_init(&d); + mp_init(&e); + mp_init(&f); + + srand(time(NULL)); + +#if 0 + // test montgomery + printf("Testing montgomery...\n"); + for (i = 1; i < 10; i++) { + printf("Testing digit size: %d\n", i); + for (n = 0; n < 1000; n++) { + mp_rand(&a, i); + a.dp[0] |= 1; + + // let's see if R is right + mp_montgomery_calc_normalization(&b, &a); + mp_montgomery_setup(&a, &mp); + + // now test a random reduction + for (ix = 0; ix < 100; ix++) { + mp_rand(&c, 1 + abs(rand()) % (2*i)); + mp_copy(&c, &d); + mp_copy(&c, &e); + + mp_mod(&d, &a, &d); + mp_montgomery_reduce(&c, &a, mp); + mp_mulmod(&c, &b, &a, &c); + + if (mp_cmp(&c, &d) != MP_EQ) { +printf("d = e mod a, c = e MOD a\n"); +mp_todecimal(&a, buf); printf("a = %s\n", buf); +mp_todecimal(&e, buf); printf("e = %s\n", buf); +mp_todecimal(&d, buf); printf("d = %s\n", buf); +mp_todecimal(&c, buf); printf("c = %s\n", buf); +printf("compare no compare!\n"); exit(EXIT_FAILURE); } + } + } + } + printf("done\n"); + + // test mp_get_int + printf("Testing: mp_get_int\n"); + for (i = 0; i < 1000; ++i) { + t = ((unsigned long) rand() * rand() + 1) & 0xFFFFFFFF; + mp_set_int(&a, t); + if (t != mp_get_int(&a)) { + printf("mp_get_int() bad result!\n"); + return 1; + } + } + mp_set_int(&a, 0); + if (mp_get_int(&a) != 0) { + printf("mp_get_int() bad result!\n"); + return 1; + } + mp_set_int(&a, 0xffffffff); + if (mp_get_int(&a) != 0xffffffff) { + printf("mp_get_int() bad result!\n"); + return 1; + } + // test mp_sqrt + printf("Testing: mp_sqrt\n"); + for (i = 0; i < 1000; ++i) { + printf("%6d\r", i); + fflush(stdout); + n = (rand() & 15) + 1; + mp_rand(&a, n); + if (mp_sqrt(&a, &b) != MP_OKAY) { + printf("mp_sqrt() error!\n"); + return 1; + } + mp_n_root(&a, 2, &a); + if (mp_cmp_mag(&b, &a) != MP_EQ) { + printf("mp_sqrt() bad result!\n"); + return 1; + } + } + + printf("\nTesting: mp_is_square\n"); + for (i = 0; i < 1000; ++i) { + printf("%6d\r", i); + fflush(stdout); + + /* test mp_is_square false negatives */ + n = (rand() & 7) + 1; + mp_rand(&a, n); + mp_sqr(&a, &a); + if (mp_is_square(&a, &n) != MP_OKAY) { + printf("fn:mp_is_square() error!\n"); + return 1; + } + if (n == 0) { + printf("fn:mp_is_square() bad result!\n"); + return 1; + } + + /* test for false positives */ + mp_add_d(&a, 1, &a); + if (mp_is_square(&a, &n) != MP_OKAY) { + printf("fp:mp_is_square() error!\n"); + return 1; + } + if (n == 1) { + printf("fp:mp_is_square() bad result!\n"); + return 1; + } + + } + printf("\n\n"); + + /* test for size */ + for (ix = 10; ix < 128; ix++) { + printf("Testing (not safe-prime): %9d bits \r", ix); + fflush(stdout); + err = + mp_prime_random_ex(&a, 8, ix, + (rand() & 1) ? LTM_PRIME_2MSB_OFF : + LTM_PRIME_2MSB_ON, myrng, NULL); + if (err != MP_OKAY) { + printf("failed with err code %d\n", err); + return EXIT_FAILURE; + } + if (mp_count_bits(&a) != ix) { + printf("Prime is %d not %d bits!!!\n", mp_count_bits(&a), ix); + return EXIT_FAILURE; + } + } + + for (ix = 16; ix < 128; ix++) { + printf("Testing ( safe-prime): %9d bits \r", ix); + fflush(stdout); + err = + mp_prime_random_ex(&a, 8, ix, + ((rand() & 1) ? LTM_PRIME_2MSB_OFF : + LTM_PRIME_2MSB_ON) | LTM_PRIME_SAFE, myrng, + NULL); + if (err != MP_OKAY) { + printf("failed with err code %d\n", err); + return EXIT_FAILURE; + } + if (mp_count_bits(&a) != ix) { + printf("Prime is %d not %d bits!!!\n", mp_count_bits(&a), ix); + return EXIT_FAILURE; + } + /* let's see if it's really a safe prime */ + mp_sub_d(&a, 1, &a); + mp_div_2(&a, &a); + mp_prime_is_prime(&a, 8, &cnt); + if (cnt != MP_YES) { + printf("sub is not prime!\n"); + return EXIT_FAILURE; + } + } + + printf("\n\n"); + + mp_read_radix(&a, "123456", 10); + mp_toradix_n(&a, buf, 10, 3); + printf("a == %s\n", buf); + mp_toradix_n(&a, buf, 10, 4); + printf("a == %s\n", buf); + mp_toradix_n(&a, buf, 10, 30); + printf("a == %s\n", buf); + + +#if 0 + for (;;) { + fgets(buf, sizeof(buf), stdin); + mp_read_radix(&a, buf, 10); + mp_prime_next_prime(&a, 5, 1); + mp_toradix(&a, buf, 10); + printf("%s, %lu\n", buf, a.dp[0] & 3); + } +#endif + + /* test mp_cnt_lsb */ + printf("testing mp_cnt_lsb...\n"); + mp_set(&a, 1); + for (ix = 0; ix < 1024; ix++) { + if (mp_cnt_lsb(&a) != ix) { + printf("Failed at %d, %d\n", ix, mp_cnt_lsb(&a)); + return 0; + } + mp_mul_2(&a, &a); + } + +/* test mp_reduce_2k */ + printf("Testing mp_reduce_2k...\n"); + for (cnt = 3; cnt <= 128; ++cnt) { + mp_digit tmp; + + mp_2expt(&a, cnt); + mp_sub_d(&a, 2, &a); /* a = 2**cnt - 2 */ + + + printf("\nTesting %4d bits", cnt); + printf("(%d)", mp_reduce_is_2k(&a)); + mp_reduce_2k_setup(&a, &tmp); + printf("(%d)", tmp); + for (ix = 0; ix < 1000; ix++) { + if (!(ix & 127)) { + printf("."); + fflush(stdout); + } + mp_rand(&b, (cnt / DIGIT_BIT + 1) * 2); + mp_copy(&c, &b); + mp_mod(&c, &a, &c); + mp_reduce_2k(&b, &a, 2); + if (mp_cmp(&c, &b)) { + printf("FAILED\n"); + exit(0); + } + } + } + +/* test mp_div_3 */ + printf("Testing mp_div_3...\n"); + mp_set(&d, 3); + for (cnt = 0; cnt < 10000;) { + mp_digit r1, r2; + + if (!(++cnt & 127)) + printf("%9d\r", cnt); + mp_rand(&a, abs(rand()) % 128 + 1); + mp_div(&a, &d, &b, &e); + mp_div_3(&a, &c, &r2); + + if (mp_cmp(&b, &c) || mp_cmp_d(&e, r2)) { + printf("\n\nmp_div_3 => Failure\n"); + } + } + printf("\n\nPassed div_3 testing\n"); + +/* test the DR reduction */ + printf("testing mp_dr_reduce...\n"); + for (cnt = 2; cnt < 32; cnt++) { + printf("%d digit modulus\n", cnt); + mp_grow(&a, cnt); + mp_zero(&a); + for (ix = 1; ix < cnt; ix++) { + a.dp[ix] = MP_MASK; + } + a.used = cnt; + a.dp[0] = 3; + + mp_rand(&b, cnt - 1); + mp_copy(&b, &c); + + rr = 0; + do { + if (!(rr & 127)) { + printf("%9lu\r", rr); + fflush(stdout); + } + mp_sqr(&b, &b); + mp_add_d(&b, 1, &b); + mp_copy(&b, &c); + + mp_mod(&b, &a, &b); + mp_dr_reduce(&c, &a, (((mp_digit) 1) << DIGIT_BIT) - a.dp[0]); + + if (mp_cmp(&b, &c) != MP_EQ) { + printf("Failed on trial %lu\n", rr); + exit(-1); + + } + } while (++rr < 500); + printf("Passed DR test for %d digits\n", cnt); + } + +#endif + +/* test the mp_reduce_2k_l code */ +#if 0 +#if 0 +/* first load P with 2^1024 - 0x2A434 B9FDEC95 D8F9D550 FFFFFFFF FFFFFFFF */ + mp_2expt(&a, 1024); + mp_read_radix(&b, "2A434B9FDEC95D8F9D550FFFFFFFFFFFFFFFF", 16); + mp_sub(&a, &b, &a); +#elif 1 +/* p = 2^2048 - 0x1 00000000 00000000 00000000 00000000 4945DDBF 8EA2A91D 5776399B B83E188F */ + mp_2expt(&a, 2048); + mp_read_radix(&b, + "1000000000000000000000000000000004945DDBF8EA2A91D5776399BB83E188F", + 16); + mp_sub(&a, &b, &a); +#endif + + mp_todecimal(&a, buf); + printf("p==%s\n", buf); +/* now mp_reduce_is_2k_l() should return */ + if (mp_reduce_is_2k_l(&a) != 1) { + printf("mp_reduce_is_2k_l() return 0, should be 1\n"); + return EXIT_FAILURE; + } + mp_reduce_2k_setup_l(&a, &d); + /* now do a million square+1 to see if it varies */ + mp_rand(&b, 64); + mp_mod(&b, &a, &b); + mp_copy(&b, &c); + printf("testing mp_reduce_2k_l..."); + fflush(stdout); + for (cnt = 0; cnt < (1UL << 20); cnt++) { + mp_sqr(&b, &b); + mp_add_d(&b, 1, &b); + mp_reduce_2k_l(&b, &a, &d); + mp_sqr(&c, &c); + mp_add_d(&c, 1, &c); + mp_mod(&c, &a, &c); + if (mp_cmp(&b, &c) != MP_EQ) { + printf("mp_reduce_2k_l() failed at step %lu\n", cnt); + mp_tohex(&b, buf); + printf("b == %s\n", buf); + mp_tohex(&c, buf); + printf("c == %s\n", buf); + return EXIT_FAILURE; + } + } + printf("...Passed\n"); +#endif + + div2_n = mul2_n = inv_n = expt_n = lcm_n = gcd_n = add_n = + sub_n = mul_n = div_n = sqr_n = mul2d_n = div2d_n = cnt = add_d_n = + sub_d_n = 0; + + /* force KARA and TOOM to enable despite cutoffs */ + KARATSUBA_SQR_CUTOFF = KARATSUBA_MUL_CUTOFF = 8; + TOOM_SQR_CUTOFF = TOOM_MUL_CUTOFF = 16; + + for (;;) { + /* randomly clear and re-init one variable, this has the affect of triming the alloc space */ + switch (abs(rand()) % 7) { + case 0: + mp_clear(&a); + mp_init(&a); + break; + case 1: + mp_clear(&b); + mp_init(&b); + break; + case 2: + mp_clear(&c); + mp_init(&c); + break; + case 3: + mp_clear(&d); + mp_init(&d); + break; + case 4: + mp_clear(&e); + mp_init(&e); + break; + case 5: + mp_clear(&f); + mp_init(&f); + break; + case 6: + break; /* don't clear any */ + } + + + printf + ("%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu ", + add_n, sub_n, mul_n, div_n, sqr_n, mul2d_n, div2d_n, gcd_n, lcm_n, + expt_n, inv_n, div2_n, mul2_n, add_d_n, sub_d_n); + fgets(cmd, 4095, stdin); + cmd[strlen(cmd) - 1] = 0; + printf("%s ]\r", cmd); + fflush(stdout); + if (!strcmp(cmd, "mul2d")) { + ++mul2d_n; + fgets(buf, 4095, stdin); + mp_read_radix(&a, buf, 64); + fgets(buf, 4095, stdin); + sscanf(buf, "%d", &rr); + fgets(buf, 4095, stdin); + mp_read_radix(&b, buf, 64); + + mp_mul_2d(&a, rr, &a); + a.sign = b.sign; + if (mp_cmp(&a, &b) != MP_EQ) { + printf("mul2d failed, rr == %d\n", rr); + draw(&a); + draw(&b); + return 0; + } + } else if (!strcmp(cmd, "div2d")) { + ++div2d_n; + fgets(buf, 4095, stdin); + mp_read_radix(&a, buf, 64); + fgets(buf, 4095, stdin); + sscanf(buf, "%d", &rr); + fgets(buf, 4095, stdin); + mp_read_radix(&b, buf, 64); + + mp_div_2d(&a, rr, &a, &e); + a.sign = b.sign; + if (a.used == b.used && a.used == 0) { + a.sign = b.sign = MP_ZPOS; + } + if (mp_cmp(&a, &b) != MP_EQ) { + printf("div2d failed, rr == %d\n", rr); + draw(&a); + draw(&b); + return 0; + } + } else if (!strcmp(cmd, "add")) { + ++add_n; + fgets(buf, 4095, stdin); + mp_read_radix(&a, buf, 64); + fgets(buf, 4095, stdin); + mp_read_radix(&b, buf, 64); + fgets(buf, 4095, stdin); + mp_read_radix(&c, buf, 64); + mp_copy(&a, &d); + mp_add(&d, &b, &d); + if (mp_cmp(&c, &d) != MP_EQ) { + printf("add %lu failure!\n", add_n); + draw(&a); + draw(&b); + draw(&c); + draw(&d); + return 0; + } + + /* test the sign/unsigned storage functions */ + + rr = mp_signed_bin_size(&c); + mp_to_signed_bin(&c, (unsigned char *) cmd); + memset(cmd + rr, rand() & 255, sizeof(cmd) - rr); + mp_read_signed_bin(&d, (unsigned char *) cmd, rr); + if (mp_cmp(&c, &d) != MP_EQ) { + printf("mp_signed_bin failure!\n"); + draw(&c); + draw(&d); + return 0; + } + + + rr = mp_unsigned_bin_size(&c); + mp_to_unsigned_bin(&c, (unsigned char *) cmd); + memset(cmd + rr, rand() & 255, sizeof(cmd) - rr); + mp_read_unsigned_bin(&d, (unsigned char *) cmd, rr); + if (mp_cmp_mag(&c, &d) != MP_EQ) { + printf("mp_unsigned_bin failure!\n"); + draw(&c); + draw(&d); + return 0; + } + + } else if (!strcmp(cmd, "sub")) { + ++sub_n; + fgets(buf, 4095, stdin); + mp_read_radix(&a, buf, 64); + fgets(buf, 4095, stdin); + mp_read_radix(&b, buf, 64); + fgets(buf, 4095, stdin); + mp_read_radix(&c, buf, 64); + mp_copy(&a, &d); + mp_sub(&d, &b, &d); + if (mp_cmp(&c, &d) != MP_EQ) { + printf("sub %lu failure!\n", sub_n); + draw(&a); + draw(&b); + draw(&c); + draw(&d); + return 0; + } + } else if (!strcmp(cmd, "mul")) { + ++mul_n; + fgets(buf, 4095, stdin); + mp_read_radix(&a, buf, 64); + fgets(buf, 4095, stdin); + mp_read_radix(&b, buf, 64); + fgets(buf, 4095, stdin); + mp_read_radix(&c, buf, 64); + mp_copy(&a, &d); + mp_mul(&d, &b, &d); + if (mp_cmp(&c, &d) != MP_EQ) { + printf("mul %lu failure!\n", mul_n); + draw(&a); + draw(&b); + draw(&c); + draw(&d); + return 0; + } + } else if (!strcmp(cmd, "div")) { + ++div_n; + fgets(buf, 4095, stdin); + mp_read_radix(&a, buf, 64); + fgets(buf, 4095, stdin); + mp_read_radix(&b, buf, 64); + fgets(buf, 4095, stdin); + mp_read_radix(&c, buf, 64); + fgets(buf, 4095, stdin); + mp_read_radix(&d, buf, 64); + + mp_div(&a, &b, &e, &f); + if (mp_cmp(&c, &e) != MP_EQ || mp_cmp(&d, &f) != MP_EQ) { + printf("div %lu %d, %d, failure!\n", div_n, mp_cmp(&c, &e), + mp_cmp(&d, &f)); + draw(&a); + draw(&b); + draw(&c); + draw(&d); + draw(&e); + draw(&f); + return 0; + } + + } else if (!strcmp(cmd, "sqr")) { + ++sqr_n; + fgets(buf, 4095, stdin); + mp_read_radix(&a, buf, 64); + fgets(buf, 4095, stdin); + mp_read_radix(&b, buf, 64); + mp_copy(&a, &c); + mp_sqr(&c, &c); + if (mp_cmp(&b, &c) != MP_EQ) { + printf("sqr %lu failure!\n", sqr_n); + draw(&a); + draw(&b); + draw(&c); + return 0; + } + } else if (!strcmp(cmd, "gcd")) { + ++gcd_n; + fgets(buf, 4095, stdin); + mp_read_radix(&a, buf, 64); + fgets(buf, 4095, stdin); + mp_read_radix(&b, buf, 64); + fgets(buf, 4095, stdin); + mp_read_radix(&c, buf, 64); + mp_copy(&a, &d); + mp_gcd(&d, &b, &d); + d.sign = c.sign; + if (mp_cmp(&c, &d) != MP_EQ) { + printf("gcd %lu failure!\n", gcd_n); + draw(&a); + draw(&b); + draw(&c); + draw(&d); + return 0; + } + } else if (!strcmp(cmd, "lcm")) { + ++lcm_n; + fgets(buf, 4095, stdin); + mp_read_radix(&a, buf, 64); + fgets(buf, 4095, stdin); + mp_read_radix(&b, buf, 64); + fgets(buf, 4095, stdin); + mp_read_radix(&c, buf, 64); + mp_copy(&a, &d); + mp_lcm(&d, &b, &d); + d.sign = c.sign; + if (mp_cmp(&c, &d) != MP_EQ) { + printf("lcm %lu failure!\n", lcm_n); + draw(&a); + draw(&b); + draw(&c); + draw(&d); + return 0; + } + } else if (!strcmp(cmd, "expt")) { + ++expt_n; + fgets(buf, 4095, stdin); + mp_read_radix(&a, buf, 64); + fgets(buf, 4095, stdin); + mp_read_radix(&b, buf, 64); + fgets(buf, 4095, stdin); + mp_read_radix(&c, buf, 64); + fgets(buf, 4095, stdin); + mp_read_radix(&d, buf, 64); + mp_copy(&a, &e); + mp_exptmod(&e, &b, &c, &e); + if (mp_cmp(&d, &e) != MP_EQ) { + printf("expt %lu failure!\n", expt_n); + draw(&a); + draw(&b); + draw(&c); + draw(&d); + draw(&e); + return 0; + } + } else if (!strcmp(cmd, "invmod")) { + ++inv_n; + fgets(buf, 4095, stdin); + mp_read_radix(&a, buf, 64); + fgets(buf, 4095, stdin); + mp_read_radix(&b, buf, 64); + fgets(buf, 4095, stdin); + mp_read_radix(&c, buf, 64); + mp_invmod(&a, &b, &d); + mp_mulmod(&d, &a, &b, &e); + if (mp_cmp_d(&e, 1) != MP_EQ) { + printf("inv [wrong value from MPI?!] failure\n"); + draw(&a); + draw(&b); + draw(&c); + draw(&d); + mp_gcd(&a, &b, &e); + draw(&e); + return 0; + } + + } else if (!strcmp(cmd, "div2")) { + ++div2_n; + fgets(buf, 4095, stdin); + mp_read_radix(&a, buf, 64); + fgets(buf, 4095, stdin); + mp_read_radix(&b, buf, 64); + mp_div_2(&a, &c); + if (mp_cmp(&c, &b) != MP_EQ) { + printf("div_2 %lu failure\n", div2_n); + draw(&a); + draw(&b); + draw(&c); + return 0; + } + } else if (!strcmp(cmd, "mul2")) { + ++mul2_n; + fgets(buf, 4095, stdin); + mp_read_radix(&a, buf, 64); + fgets(buf, 4095, stdin); + mp_read_radix(&b, buf, 64); + mp_mul_2(&a, &c); + if (mp_cmp(&c, &b) != MP_EQ) { + printf("mul_2 %lu failure\n", mul2_n); + draw(&a); + draw(&b); + draw(&c); + return 0; + } + } else if (!strcmp(cmd, "add_d")) { + ++add_d_n; + fgets(buf, 4095, stdin); + mp_read_radix(&a, buf, 64); + fgets(buf, 4095, stdin); + sscanf(buf, "%d", &ix); + fgets(buf, 4095, stdin); + mp_read_radix(&b, buf, 64); + mp_add_d(&a, ix, &c); + if (mp_cmp(&b, &c) != MP_EQ) { + printf("add_d %lu failure\n", add_d_n); + draw(&a); + draw(&b); + draw(&c); + printf("d == %d\n", ix); + return 0; + } + } else if (!strcmp(cmd, "sub_d")) { + ++sub_d_n; + fgets(buf, 4095, stdin); + mp_read_radix(&a, buf, 64); + fgets(buf, 4095, stdin); + sscanf(buf, "%d", &ix); + fgets(buf, 4095, stdin); + mp_read_radix(&b, buf, 64); + mp_sub_d(&a, ix, &c); + if (mp_cmp(&b, &c) != MP_EQ) { + printf("sub_d %lu failure\n", sub_d_n); + draw(&a); + draw(&b); + draw(&c); + printf("d == %d\n", ix); + return 0; + } + } + } + return 0; +} + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/demo/demo.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/demo/timing.c Index: libtommath/demo/timing.c ================================================================== --- /dev/null +++ libtommath/demo/timing.c @@ -0,0 +1,319 @@ +#include +#include + +ulong64 _tt; + +#ifdef IOWNANATHLON +#include +#define SLEEP sleep(4) +#else +#define SLEEP +#endif + + +void ndraw(mp_int * a, char *name) +{ + char buf[4096]; + + printf("%s: ", name); + mp_toradix(a, buf, 64); + printf("%s\n", buf); +} + +static void draw(mp_int * a) +{ + ndraw(a, ""); +} + + +unsigned long lfsr = 0xAAAAAAAAUL; + +int lbit(void) +{ + if (lfsr & 0x80000000UL) { + lfsr = ((lfsr << 1) ^ 0x8000001BUL) & 0xFFFFFFFFUL; + return 1; + } else { + lfsr <<= 1; + return 0; + } +} + +/* RDTSC from Scott Duplichan */ +static ulong64 TIMFUNC(void) +{ +#if defined __GNUC__ +#if defined(__i386__) || defined(__x86_64__) + unsigned long long a; + __asm__ __volatile__("rdtsc\nmovl %%eax,%0\nmovl %%edx,4+%0\n":: + "m"(a):"%eax", "%edx"); + return a; +#else /* gcc-IA64 version */ + unsigned long result; + __asm__ __volatile__("mov %0=ar.itc":"=r"(result)::"memory"); + + while (__builtin_expect((int) result == -1, 0)) + __asm__ __volatile__("mov %0=ar.itc":"=r"(result)::"memory"); + + return result; +#endif + + // Microsoft and Intel Windows compilers +#elif defined _M_IX86 + __asm rdtsc +#elif defined _M_AMD64 + return __rdtsc(); +#elif defined _M_IA64 +#if defined __INTEL_COMPILER +#include +#endif + return __getReg(3116); +#else +#error need rdtsc function for this build +#endif +} + +#define DO(x) x; x; +//#define DO4(x) DO2(x); DO2(x); +//#define DO8(x) DO4(x); DO4(x); +//#define DO(x) DO8(x); DO8(x); + +int main(void) +{ + ulong64 tt, gg, CLK_PER_SEC; + FILE *log, *logb, *logc, *logd; + mp_int a, b, c, d, e, f; + int n, cnt, ix, old_kara_m, old_kara_s; + unsigned rr; + + mp_init(&a); + mp_init(&b); + mp_init(&c); + mp_init(&d); + mp_init(&e); + mp_init(&f); + + srand(time(NULL)); + + + /* temp. turn off TOOM */ + TOOM_MUL_CUTOFF = TOOM_SQR_CUTOFF = 100000; + + CLK_PER_SEC = TIMFUNC(); + sleep(1); + CLK_PER_SEC = TIMFUNC() - CLK_PER_SEC; + + printf("CLK_PER_SEC == %llu\n", CLK_PER_SEC); + goto exptmod; + log = fopen("logs/add.log", "w"); + for (cnt = 8; cnt <= 128; cnt += 8) { + SLEEP; + mp_rand(&a, cnt); + mp_rand(&b, cnt); + rr = 0; + tt = -1; + do { + gg = TIMFUNC(); + DO(mp_add(&a, &b, &c)); + gg = (TIMFUNC() - gg) >> 1; + if (tt > gg) + tt = gg; + } while (++rr < 100000); + printf("Adding\t\t%4d-bit => %9llu/sec, %9llu cycles\n", + mp_count_bits(&a), CLK_PER_SEC / tt, tt); + fprintf(log, "%d %9llu\n", cnt * DIGIT_BIT, tt); + fflush(log); + } + fclose(log); + + log = fopen("logs/sub.log", "w"); + for (cnt = 8; cnt <= 128; cnt += 8) { + SLEEP; + mp_rand(&a, cnt); + mp_rand(&b, cnt); + rr = 0; + tt = -1; + do { + gg = TIMFUNC(); + DO(mp_sub(&a, &b, &c)); + gg = (TIMFUNC() - gg) >> 1; + if (tt > gg) + tt = gg; + } while (++rr < 100000); + + printf("Subtracting\t\t%4d-bit => %9llu/sec, %9llu cycles\n", + mp_count_bits(&a), CLK_PER_SEC / tt, tt); + fprintf(log, "%d %9llu\n", cnt * DIGIT_BIT, tt); + fflush(log); + } + fclose(log); + + /* do mult/square twice, first without karatsuba and second with */ + multtest: + old_kara_m = KARATSUBA_MUL_CUTOFF; + old_kara_s = KARATSUBA_SQR_CUTOFF; + for (ix = 0; ix < 2; ix++) { + printf("With%s Karatsuba\n", (ix == 0) ? "out" : ""); + + KARATSUBA_MUL_CUTOFF = (ix == 0) ? 9999 : old_kara_m; + KARATSUBA_SQR_CUTOFF = (ix == 0) ? 9999 : old_kara_s; + + log = fopen((ix == 0) ? "logs/mult.log" : "logs/mult_kara.log", "w"); + for (cnt = 4; cnt <= 10240 / DIGIT_BIT; cnt += 2) { + SLEEP; + mp_rand(&a, cnt); + mp_rand(&b, cnt); + rr = 0; + tt = -1; + do { + gg = TIMFUNC(); + DO(mp_mul(&a, &b, &c)); + gg = (TIMFUNC() - gg) >> 1; + if (tt > gg) + tt = gg; + } while (++rr < 100); + printf("Multiplying\t%4d-bit => %9llu/sec, %9llu cycles\n", + mp_count_bits(&a), CLK_PER_SEC / tt, tt); + fprintf(log, "%d %9llu\n", mp_count_bits(&a), tt); + fflush(log); + } + fclose(log); + + log = fopen((ix == 0) ? "logs/sqr.log" : "logs/sqr_kara.log", "w"); + for (cnt = 4; cnt <= 10240 / DIGIT_BIT; cnt += 2) { + SLEEP; + mp_rand(&a, cnt); + rr = 0; + tt = -1; + do { + gg = TIMFUNC(); + DO(mp_sqr(&a, &b)); + gg = (TIMFUNC() - gg) >> 1; + if (tt > gg) + tt = gg; + } while (++rr < 100); + printf("Squaring\t%4d-bit => %9llu/sec, %9llu cycles\n", + mp_count_bits(&a), CLK_PER_SEC / tt, tt); + fprintf(log, "%d %9llu\n", mp_count_bits(&a), tt); + fflush(log); + } + fclose(log); + + } + exptmod: + + { + char *primes[] = { + /* 2K large moduli */ + "179769313486231590772930519078902473361797697894230657273430081157732675805500963132708477322407536021120113879871393357658789768814416622492847430639474124377767893424865485276302219601246094119453082952085005768838150682342462881473913110540827237163350510684586239334100047359817950870678242457666208137217", + "32317006071311007300714876688669951960444102669715484032130345427524655138867890893197201411522913463688717960921898019494119559150490921095088152386448283120630877367300996091750197750389652106796057638384067568276792218642619756161838094338476170470581645852036305042887575891541065808607552399123930385521914333389668342420684974786564569494856176035326322058077805659331026192708460314150258592864177116725943603718461857357598351152301645904403697613233287231227125684710820209725157101726931323469678542580656697935045997268352998638099733077152121140120031150424541696791951097529546801429027668869927491725169", + "1044388881413152506691752710716624382579964249047383780384233483283953907971557456848826811934997558340890106714439262837987573438185793607263236087851365277945956976543709998340361590134383718314428070011855946226376318839397712745672334684344586617496807908705803704071284048740118609114467977783598029006686938976881787785946905630190260940599579453432823469303026696443059025015972399867714215541693835559885291486318237914434496734087811872639496475100189041349008417061675093668333850551032972088269550769983616369411933015213796825837188091833656751221318492846368125550225998300412344784862595674492194617023806505913245610825731835380087608622102834270197698202313169017678006675195485079921636419370285375124784014907159135459982790513399611551794271106831134090584272884279791554849782954323534517065223269061394905987693002122963395687782878948440616007412945674919823050571642377154816321380631045902916136926708342856440730447899971901781465763473223850267253059899795996090799469201774624817718449867455659250178329070473119433165550807568221846571746373296884912819520317457002440926616910874148385078411929804522981857338977648103126085902995208257421855249796721729039744118165938433694823325696642096892124547425283", + /* 2K moduli mersenne primes */ + "6864797660130609714981900799081393217269435300143305409394463459185543183397656052122559640661454554977296311391480858037121987999716643812574028291115057151", + "531137992816767098689588206552468627329593117727031923199444138200403559860852242739162502265229285668889329486246501015346579337652707239409519978766587351943831270835393219031728127", + "10407932194664399081925240327364085538615262247266704805319112350403608059673360298012239441732324184842421613954281007791383566248323464908139906605677320762924129509389220345773183349661583550472959420547689811211693677147548478866962501384438260291732348885311160828538416585028255604666224831890918801847068222203140521026698435488732958028878050869736186900714720710555703168729087", + "1475979915214180235084898622737381736312066145333169775147771216478570297878078949377407337049389289382748507531496480477281264838760259191814463365330269540496961201113430156902396093989090226259326935025281409614983499388222831448598601834318536230923772641390209490231836446899608210795482963763094236630945410832793769905399982457186322944729636418890623372171723742105636440368218459649632948538696905872650486914434637457507280441823676813517852099348660847172579408422316678097670224011990280170474894487426924742108823536808485072502240519452587542875349976558572670229633962575212637477897785501552646522609988869914013540483809865681250419497686697771007", + "259117086013202627776246767922441530941818887553125427303974923161874019266586362086201209516800483406550695241733194177441689509238807017410377709597512042313066624082916353517952311186154862265604547691127595848775610568757931191017711408826252153849035830401185072116424747461823031471398340229288074545677907941037288235820705892351068433882986888616658650280927692080339605869308790500409503709875902119018371991620994002568935113136548829739112656797303241986517250116412703509705427773477972349821676443446668383119322540099648994051790241624056519054483690809616061625743042361721863339415852426431208737266591962061753535748892894599629195183082621860853400937932839420261866586142503251450773096274235376822938649407127700846077124211823080804139298087057504713825264571448379371125032081826126566649084251699453951887789613650248405739378594599444335231188280123660406262468609212150349937584782292237144339628858485938215738821232393687046160677362909315071", + "190797007524439073807468042969529173669356994749940177394741882673528979787005053706368049835514900244303495954950709725762186311224148828811920216904542206960744666169364221195289538436845390250168663932838805192055137154390912666527533007309292687539092257043362517857366624699975402375462954490293259233303137330643531556539739921926201438606439020075174723029056838272505051571967594608350063404495977660656269020823960825567012344189908927956646011998057988548630107637380993519826582389781888135705408653045219655801758081251164080554609057468028203308718724654081055323215860189611391296030471108443146745671967766308925858547271507311563765171008318248647110097614890313562856541784154881743146033909602737947385055355960331855614540900081456378659068370317267696980001187750995491090350108417050917991562167972281070161305972518044872048331306383715094854938415738549894606070722584737978176686422134354526989443028353644037187375385397838259511833166416134323695660367676897722287918773420968982326089026150031515424165462111337527431154890666327374921446276833564519776797633875503548665093914556482031482248883127023777039667707976559857333357013727342079099064400455741830654320379350833236245819348824064783585692924881021978332974949906122664421376034687815350484991", + + /* DR moduli */ + "14059105607947488696282932836518693308967803494693489478439861164411992439598399594747002144074658928593502845729752797260025831423419686528151609940203368612079", + "101745825697019260773923519755878567461315282017759829107608914364075275235254395622580447400994175578963163918967182013639660669771108475957692810857098847138903161308502419410142185759152435680068435915159402496058513611411688900243039", + "736335108039604595805923406147184530889923370574768772191969612422073040099331944991573923112581267542507986451953227192970402893063850485730703075899286013451337291468249027691733891486704001513279827771740183629161065194874727962517148100775228363421083691764065477590823919364012917984605619526140821797602431", + "38564998830736521417281865696453025806593491967131023221754800625044118265468851210705360385717536794615180260494208076605798671660719333199513807806252394423283413430106003596332513246682903994829528690198205120921557533726473585751382193953592127439965050261476810842071573684505878854588706623484573925925903505747545471088867712185004135201289273405614415899438276535626346098904241020877974002916168099951885406379295536200413493190419727789712076165162175783", + "542189391331696172661670440619180536749994166415993334151601745392193484590296600979602378676624808129613777993466242203025054573692562689251250471628358318743978285860720148446448885701001277560572526947619392551574490839286458454994488665744991822837769918095117129546414124448777033941223565831420390846864429504774477949153794689948747680362212954278693335653935890352619041936727463717926744868338358149568368643403037768649616778526013610493696186055899318268339432671541328195724261329606699831016666359440874843103020666106568222401047720269951530296879490444224546654729111504346660859907296364097126834834235287147", + "1487259134814709264092032648525971038895865645148901180585340454985524155135260217788758027400478312256339496385275012465661575576202252063145698732079880294664220579764848767704076761853197216563262660046602703973050798218246170835962005598561669706844469447435461092542265792444947706769615695252256130901271870341005768912974433684521436211263358097522726462083917939091760026658925757076733484173202927141441492573799914240222628795405623953109131594523623353044898339481494120112723445689647986475279242446083151413667587008191682564376412347964146113898565886683139407005941383669325997475076910488086663256335689181157957571445067490187939553165903773554290260531009121879044170766615232300936675369451260747671432073394867530820527479172464106442450727640226503746586340279816318821395210726268291535648506190714616083163403189943334431056876038286530365757187367147446004855912033137386225053275419626102417236133948503", + "1095121115716677802856811290392395128588168592409109494900178008967955253005183831872715423151551999734857184538199864469605657805519106717529655044054833197687459782636297255219742994736751541815269727940751860670268774903340296040006114013971309257028332849679096824800250742691718610670812374272414086863715763724622797509437062518082383056050144624962776302147890521249477060215148275163688301275847155316042279405557632639366066847442861422164832655874655824221577849928863023018366835675399949740429332468186340518172487073360822220449055340582568461568645259954873303616953776393853174845132081121976327462740354930744487429617202585015510744298530101547706821590188733515880733527449780963163909830077616357506845523215289297624086914545378511082534229620116563260168494523906566709418166011112754529766183554579321224940951177394088465596712620076240067370589036924024728375076210477267488679008016579588696191194060127319035195370137160936882402244399699172017835144537488486396906144217720028992863941288217185353914991583400421682751000603596655790990815525126154394344641336397793791497068253936771017031980867706707490224041075826337383538651825493679503771934836094655802776331664261631740148281763487765852746577808019633679", + + /* generic unrestricted moduli */ + "17933601194860113372237070562165128350027320072176844226673287945873370751245439587792371960615073855669274087805055507977323024886880985062002853331424203", + "2893527720709661239493896562339544088620375736490408468011883030469939904368086092336458298221245707898933583190713188177399401852627749210994595974791782790253946539043962213027074922559572312141181787434278708783207966459019479487", + "347743159439876626079252796797422223177535447388206607607181663903045907591201940478223621722118173270898487582987137708656414344685816179420855160986340457973820182883508387588163122354089264395604796675278966117567294812714812796820596564876450716066283126720010859041484786529056457896367683122960411136319", + "47266428956356393164697365098120418976400602706072312735924071745438532218237979333351774907308168340693326687317443721193266215155735814510792148768576498491199122744351399489453533553203833318691678263241941706256996197460424029012419012634671862283532342656309677173602509498417976091509154360039893165037637034737020327399910409885798185771003505320583967737293415979917317338985837385734747478364242020380416892056650841470869294527543597349250299539682430605173321029026555546832473048600327036845781970289288898317888427517364945316709081173840186150794397479045034008257793436817683392375274635794835245695887", + "436463808505957768574894870394349739623346440601945961161254440072143298152040105676491048248110146278752857839930515766167441407021501229924721335644557342265864606569000117714935185566842453630868849121480179691838399545644365571106757731317371758557990781880691336695584799313313687287468894148823761785582982549586183756806449017542622267874275103877481475534991201849912222670102069951687572917937634467778042874315463238062009202992087620963771759666448266532858079402669920025224220613419441069718482837399612644978839925207109870840278194042158748845445131729137117098529028886770063736487420613144045836803985635654192482395882603511950547826439092832800532152534003936926017612446606135655146445620623395788978726744728503058670046885876251527122350275750995227", + "11424167473351836398078306042624362277956429440521137061889702611766348760692206243140413411077394583180726863277012016602279290144126785129569474909173584789822341986742719230331946072730319555984484911716797058875905400999504305877245849119687509023232790273637466821052576859232452982061831009770786031785669030271542286603956118755585683996118896215213488875253101894663403069677745948305893849505434201763745232895780711972432011344857521691017896316861403206449421332243658855453435784006517202894181640562433575390821384210960117518650374602256601091379644034244332285065935413233557998331562749140202965844219336298970011513882564935538704289446968322281451907487362046511461221329799897350993370560697505809686438782036235372137015731304779072430260986460269894522159103008260495503005267165927542949439526272736586626709581721032189532726389643625590680105784844246152702670169304203783072275089194754889511973916207", + "1214855636816562637502584060163403830270705000634713483015101384881871978446801224798536155406895823305035467591632531067547890948695117172076954220727075688048751022421198712032848890056357845974246560748347918630050853933697792254955890439720297560693579400297062396904306270145886830719309296352765295712183040773146419022875165382778007040109957609739589875590885701126197906063620133954893216612678838507540777138437797705602453719559017633986486649523611975865005712371194067612263330335590526176087004421363598470302731349138773205901447704682181517904064735636518462452242791676541725292378925568296858010151852326316777511935037531017413910506921922450666933202278489024521263798482237150056835746454842662048692127173834433089016107854491097456725016327709663199738238442164843147132789153725513257167915555162094970853584447993125488607696008169807374736711297007473812256272245489405898470297178738029484459690836250560495461579533254473316340608217876781986188705928270735695752830825527963838355419762516246028680280988020401914551825487349990306976304093109384451438813251211051597392127491464898797406789175453067960072008590614886532333015881171367104445044718144312416815712216611576221546455968770801413440778423979", + NULL + }; + log = fopen("logs/expt.log", "w"); + logb = fopen("logs/expt_dr.log", "w"); + logc = fopen("logs/expt_2k.log", "w"); + logd = fopen("logs/expt_2kl.log", "w"); + for (n = 0; primes[n]; n++) { + SLEEP; + mp_read_radix(&a, primes[n], 10); + mp_zero(&b); + for (rr = 0; rr < (unsigned) mp_count_bits(&a); rr++) { + mp_mul_2(&b, &b); + b.dp[0] |= lbit(); + b.used += 1; + } + mp_sub_d(&a, 1, &c); + mp_mod(&b, &c, &b); + mp_set(&c, 3); + rr = 0; + tt = -1; + do { + gg = TIMFUNC(); + DO(mp_exptmod(&c, &b, &a, &d)); + gg = (TIMFUNC() - gg) >> 1; + if (tt > gg) + tt = gg; + } while (++rr < 10); + mp_sub_d(&a, 1, &e); + mp_sub(&e, &b, &b); + mp_exptmod(&c, &b, &a, &e); /* c^(p-1-b) mod a */ + mp_mulmod(&e, &d, &a, &d); /* c^b * c^(p-1-b) == c^p-1 == 1 */ + if (mp_cmp_d(&d, 1)) { + printf("Different (%d)!!!\n", mp_count_bits(&a)); + draw(&d); + exit(0); + } + printf("Exponentiating\t%4d-bit => %9llu/sec, %9llu cycles\n", + mp_count_bits(&a), CLK_PER_SEC / tt, tt); + fprintf(n < 4 ? logd : (n < 9) ? logc : (n < 16) ? logb : log, + "%d %9llu\n", mp_count_bits(&a), tt); + } + } + fclose(log); + fclose(logb); + fclose(logc); + fclose(logd); + + log = fopen("logs/invmod.log", "w"); + for (cnt = 4; cnt <= 128; cnt += 4) { + SLEEP; + mp_rand(&a, cnt); + mp_rand(&b, cnt); + + do { + mp_add_d(&b, 1, &b); + mp_gcd(&a, &b, &c); + } while (mp_cmp_d(&c, 1) != MP_EQ); + + rr = 0; + tt = -1; + do { + gg = TIMFUNC(); + DO(mp_invmod(&b, &a, &c)); + gg = (TIMFUNC() - gg) >> 1; + if (tt > gg) + tt = gg; + } while (++rr < 1000); + mp_mulmod(&b, &c, &a, &d); + if (mp_cmp_d(&d, 1) != MP_EQ) { + printf("Failed to invert\n"); + return 0; + } + printf("Inverting mod\t%4d-bit => %9llu/sec, %9llu cycles\n", + mp_count_bits(&a), CLK_PER_SEC / tt, tt); + fprintf(log, "%d %9llu\n", cnt * DIGIT_BIT, tt); + } + fclose(log); + + return 0; +} + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/demo/timing.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/dep.pl Index: libtommath/dep.pl ================================================================== --- /dev/null +++ libtommath/dep.pl @@ -0,0 +1,123 @@ +#!/usr/bin/perl +# +# Walk through source, add labels and make classes +# +#use strict; + +my %deplist; + +#open class file and write preamble +open(CLASS, ">tommath_class.h") or die "Couldn't open tommath_class.h for writing\n"; +print CLASS "#if !(defined(LTM1) && defined(LTM2) && defined(LTM3))\n#if defined(LTM2)\n#define LTM3\n#endif\n#if defined(LTM1)\n#define LTM2\n#endif\n#define LTM1\n\n#if defined(LTM_ALL)\n"; + +foreach my $filename (glob "bn*.c") { + my $define = $filename; + +print "Processing $filename\n"; + + # convert filename to upper case so we can use it as a define + $define =~ tr/[a-z]/[A-Z]/; + $define =~ tr/\./_/; + print CLASS "#define $define\n"; + + # now copy text and apply #ifdef as required + my $apply = 0; + open(SRC, "<$filename"); + open(OUT, ">tmp"); + + # first line will be the #ifdef + my $line = ; + if ($line =~ /include/) { + print OUT $line; + } else { + print OUT "#include \n#ifdef $define\n$line"; + $apply = 1; + } + while () { + if (!($_ =~ /tommath\.h/)) { + print OUT $_; + } + } + if ($apply == 1) { + print OUT "#endif\n"; + } + close SRC; + close OUT; + + unlink($filename); + rename("tmp", $filename); +} +print CLASS "#endif\n\n"; + +# now do classes + +foreach my $filename (glob "bn*.c") { + open(SRC, "<$filename") or die "Can't open source file!\n"; + + # convert filename to upper case so we can use it as a define + $filename =~ tr/[a-z]/[A-Z]/; + $filename =~ tr/\./_/; + + print CLASS "#if defined($filename)\n"; + my $list = $filename; + + # scan for mp_* and make classes + while () { + my $line = $_; + while ($line =~ m/(fast_)*(s_)*mp\_[a-z_0-9]*/) { + $line = $'; + # now $& is the match, we want to skip over LTM keywords like + # mp_int, mp_word, mp_digit + if (!($& eq "mp_digit") && !($& eq "mp_word") && !($& eq "mp_int")) { + my $a = $&; + $a =~ tr/[a-z]/[A-Z]/; + $a = "BN_" . $a . "_C"; + if (!($list =~ /$a/)) { + print CLASS " #define $a\n"; + } + $list = $list . "," . $a; + } + } + } + @deplist{$filename} = $list; + + print CLASS "#endif\n\n"; + close SRC; +} + +print CLASS "#ifdef LTM3\n#define LTM_LAST\n#endif\n#include \n#include \n#else\n#define LTM_LAST\n#endif\n"; +close CLASS; + +#now let's make a cool call graph... + +open(OUT,">callgraph.txt"); +$indent = 0; +foreach (keys %deplist) { + $list = ""; + draw_func(@deplist{$_}); + print OUT "\n\n"; +} +close(OUT); + +sub draw_func() +{ + my @funcs = split(",", $_[0]); + if ($list =~ /@funcs[0]/) { + return; + } else { + $list = $list . @funcs[0]; + } + if ($indent == 0) { } + elsif ($indent >= 1) { print OUT "| " x ($indent - 1) . "+--->"; } + print OUT @funcs[0] . "\n"; + shift @funcs; + my $temp = $list; + foreach my $i (@funcs) { + ++$indent; + draw_func(@deplist{$i}); + --$indent; + } + $list = $temp; +} + + ADDED libtommath/etc/2kprime.c Index: libtommath/etc/2kprime.c ================================================================== --- /dev/null +++ libtommath/etc/2kprime.c @@ -0,0 +1,84 @@ +/* Makes safe primes of a 2k nature */ +#include +#include + +int sizes[] = {256, 512, 768, 1024, 1536, 2048, 3072, 4096}; + +int main(void) +{ + char buf[2000]; + int x, y; + mp_int q, p; + FILE *out; + clock_t t1; + mp_digit z; + + mp_init_multi(&q, &p, NULL); + + out = fopen("2kprime.1", "w"); + for (x = 0; x < (int)(sizeof(sizes) / sizeof(sizes[0])); x++) { + top: + mp_2expt(&q, sizes[x]); + mp_add_d(&q, 3, &q); + z = -3; + + t1 = clock(); + for(;;) { + mp_sub_d(&q, 4, &q); + z += 4; + + if (z > MP_MASK) { + printf("No primes of size %d found\n", sizes[x]); + break; + } + + if (clock() - t1 > CLOCKS_PER_SEC) { + printf("."); fflush(stdout); +// sleep((clock() - t1 + CLOCKS_PER_SEC/2)/CLOCKS_PER_SEC); + t1 = clock(); + } + + /* quick test on q */ + mp_prime_is_prime(&q, 1, &y); + if (y == 0) { + continue; + } + + /* find (q-1)/2 */ + mp_sub_d(&q, 1, &p); + mp_div_2(&p, &p); + mp_prime_is_prime(&p, 3, &y); + if (y == 0) { + continue; + } + + /* test on q */ + mp_prime_is_prime(&q, 3, &y); + if (y == 0) { + continue; + } + + break; + } + + if (y == 0) { + ++sizes[x]; + goto top; + } + + mp_toradix(&q, buf, 10); + printf("\n\n%d-bits (k = %lu) = %s\n", sizes[x], z, buf); + fprintf(out, "%d-bits (k = %lu) = %s\n", sizes[x], z, buf); fflush(out); + } + + return 0; +} + + + + + + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/etc/2kprime.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/etc/drprime.c Index: libtommath/etc/drprime.c ================================================================== --- /dev/null +++ libtommath/etc/drprime.c @@ -0,0 +1,64 @@ +/* Makes safe primes of a DR nature */ +#include + +int sizes[] = { 1+256/DIGIT_BIT, 1+512/DIGIT_BIT, 1+768/DIGIT_BIT, 1+1024/DIGIT_BIT, 1+2048/DIGIT_BIT, 1+4096/DIGIT_BIT }; +int main(void) +{ + int res, x, y; + char buf[4096]; + FILE *out; + mp_int a, b; + + mp_init(&a); + mp_init(&b); + + out = fopen("drprimes.txt", "w"); + for (x = 0; x < (int)(sizeof(sizes)/sizeof(sizes[0])); x++) { + top: + printf("Seeking a %d-bit safe prime\n", sizes[x] * DIGIT_BIT); + mp_grow(&a, sizes[x]); + mp_zero(&a); + for (y = 1; y < sizes[x]; y++) { + a.dp[y] = MP_MASK; + } + + /* make a DR modulus */ + a.dp[0] = -1; + a.used = sizes[x]; + + /* now loop */ + res = 0; + for (;;) { + a.dp[0] += 4; + if (a.dp[0] >= MP_MASK) break; + mp_prime_is_prime(&a, 1, &res); + if (res == 0) continue; + printf("."); fflush(stdout); + mp_sub_d(&a, 1, &b); + mp_div_2(&b, &b); + mp_prime_is_prime(&b, 3, &res); + if (res == 0) continue; + mp_prime_is_prime(&a, 3, &res); + if (res == 1) break; + } + + if (res != 1) { + printf("Error not DR modulus\n"); sizes[x] += 1; goto top; + } else { + mp_toradix(&a, buf, 10); + printf("\n\np == %s\n\n", buf); + fprintf(out, "%d-bit prime:\np == %s\n\n", mp_count_bits(&a), buf); fflush(out); + } + } + fclose(out); + + mp_clear(&a); + mp_clear(&b); + + return 0; +} + + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/etc/drprime.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/etc/makefile.icc Index: libtommath/etc/makefile.icc ================================================================== --- /dev/null +++ libtommath/etc/makefile.icc @@ -0,0 +1,67 @@ +CC = icc + +CFLAGS += -I../ + +# optimize for SPEED +# +# -mcpu= can be pentium, pentiumpro (covers PII through PIII) or pentium4 +# -ax? specifies make code specifically for ? but compatible with IA-32 +# -x? specifies compile solely for ? [not specifically IA-32 compatible] +# +# where ? is +# K - PIII +# W - first P4 [Williamette] +# N - P4 Northwood +# P - P4 Prescott +# B - Blend of P4 and PM [mobile] +# +# Default to just generic max opts +CFLAGS += -O3 -xP -ip + +# default lib name (requires install with root) +# LIBNAME=-ltommath + +# libname when you can't install the lib with install +LIBNAME=../libtommath.a + +#provable primes +pprime: pprime.o + $(CC) pprime.o $(LIBNAME) -o pprime + +# portable [well requires clock()] tuning app +tune: tune.o + $(CC) tune.o $(LIBNAME) -o tune + +# same app but using RDTSC for higher precision [requires 80586+], coff based gcc installs [e.g. ming, cygwin, djgpp] +tune86: tune.c + nasm -f coff timer.asm + $(CC) -DX86_TIMER $(CFLAGS) tune.c timer.o $(LIBNAME) -o tune86 + +# for cygwin +tune86c: tune.c + nasm -f gnuwin32 timer.asm + $(CC) -DX86_TIMER $(CFLAGS) tune.c timer.o $(LIBNAME) -o tune86 + +#make tune86 for linux or any ELF format +tune86l: tune.c + nasm -f elf -DUSE_ELF timer.asm + $(CC) -DX86_TIMER $(CFLAGS) tune.c timer.o $(LIBNAME) -o tune86l + +# spits out mersenne primes +mersenne: mersenne.o + $(CC) mersenne.o $(LIBNAME) -o mersenne + +# fines DR safe primes for the given config +drprime: drprime.o + $(CC) drprime.o $(LIBNAME) -o drprime + +# fines 2k safe primes for the given config +2kprime: 2kprime.o + $(CC) 2kprime.o $(LIBNAME) -o 2kprime + +mont: mont.o + $(CC) mont.o $(LIBNAME) -o mont + + +clean: + rm -f *.log *.o *.obj *.exe pprime tune mersenne drprime tune86 tune86l mont 2kprime pprime.dat *.il ADDED libtommath/etc/mersenne.c Index: libtommath/etc/mersenne.c ================================================================== --- /dev/null +++ libtommath/etc/mersenne.c @@ -0,0 +1,144 @@ +/* Finds Mersenne primes using the Lucas-Lehmer test + * + * Tom St Denis, tomstdenis@iahu.ca + */ +#include +#include + +int +is_mersenne (long s, int *pp) +{ + mp_int n, u; + int res, k; + + *pp = 0; + + if ((res = mp_init (&n)) != MP_OKAY) { + return res; + } + + if ((res = mp_init (&u)) != MP_OKAY) { + goto LBL_N; + } + + /* n = 2^s - 1 */ + if ((res = mp_2expt(&n, s)) != MP_OKAY) { + goto LBL_MU; + } + if ((res = mp_sub_d (&n, 1, &n)) != MP_OKAY) { + goto LBL_MU; + } + + /* set u=4 */ + mp_set (&u, 4); + + /* for k=1 to s-2 do */ + for (k = 1; k <= s - 2; k++) { + /* u = u^2 - 2 mod n */ + if ((res = mp_sqr (&u, &u)) != MP_OKAY) { + goto LBL_MU; + } + if ((res = mp_sub_d (&u, 2, &u)) != MP_OKAY) { + goto LBL_MU; + } + + /* make sure u is positive */ + while (u.sign == MP_NEG) { + if ((res = mp_add (&u, &n, &u)) != MP_OKAY) { + goto LBL_MU; + } + } + + /* reduce */ + if ((res = mp_reduce_2k (&u, &n, 1)) != MP_OKAY) { + goto LBL_MU; + } + } + + /* if u == 0 then its prime */ + if (mp_iszero (&u) == 1) { + mp_prime_is_prime(&n, 8, pp); + if (*pp != 1) printf("FAILURE\n"); + } + + res = MP_OKAY; +LBL_MU:mp_clear (&u); +LBL_N:mp_clear (&n); + return res; +} + +/* square root of a long < 65536 */ +long +i_sqrt (long x) +{ + long x1, x2; + + x2 = 16; + do { + x1 = x2; + x2 = x1 - ((x1 * x1) - x) / (2 * x1); + } while (x1 != x2); + + if (x1 * x1 > x) { + --x1; + } + + return x1; +} + +/* is the long prime by brute force */ +int +isprime (long k) +{ + long y, z; + + y = i_sqrt (k); + for (z = 2; z <= y; z++) { + if ((k % z) == 0) + return 0; + } + return 1; +} + + +int +main (void) +{ + int pp; + long k; + clock_t tt; + + k = 3; + + for (;;) { + /* start time */ + tt = clock (); + + /* test if 2^k - 1 is prime */ + if (is_mersenne (k, &pp) != MP_OKAY) { + printf ("Whoa error\n"); + return -1; + } + + if (pp == 1) { + /* count time */ + tt = clock () - tt; + + /* display if prime */ + printf ("2^%-5ld - 1 is prime, test took %ld ticks\n", k, tt); + } + + /* goto next odd exponent */ + k += 2; + + /* but make sure its prime */ + while (isprime (k) == 0) { + k += 2; + } + } + return 0; +} + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/etc/mersenne.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/etc/mont.c Index: libtommath/etc/mont.c ================================================================== --- /dev/null +++ libtommath/etc/mont.c @@ -0,0 +1,50 @@ +/* tests the montgomery routines */ +#include + +int main(void) +{ + mp_int modulus, R, p, pp; + mp_digit mp; + long x, y; + + srand(time(NULL)); + mp_init_multi(&modulus, &R, &p, &pp, NULL); + + /* loop through various sizes */ + for (x = 4; x < 256; x++) { + printf("DIGITS == %3ld...", x); fflush(stdout); + + /* make up the odd modulus */ + mp_rand(&modulus, x); + modulus.dp[0] |= 1; + + /* now find the R value */ + mp_montgomery_calc_normalization(&R, &modulus); + mp_montgomery_setup(&modulus, &mp); + + /* now run through a bunch tests */ + for (y = 0; y < 1000; y++) { + mp_rand(&p, x/2); /* p = random */ + mp_mul(&p, &R, &pp); /* pp = R * p */ + mp_montgomery_reduce(&pp, &modulus, mp); + + /* should be equal to p */ + if (mp_cmp(&pp, &p) != MP_EQ) { + printf("FAILURE!\n"); + exit(-1); + } + } + printf("PASSED\n"); + } + + return 0; +} + + + + + + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/etc/mont.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/etc/pprime.c Index: libtommath/etc/pprime.c ================================================================== --- /dev/null +++ libtommath/etc/pprime.c @@ -0,0 +1,400 @@ +/* Generates provable primes + * + * See http://iahu.ca:8080/papers/pp.pdf for more info. + * + * Tom St Denis, tomstdenis@iahu.ca, http://tom.iahu.ca + */ +#include +#include "tommath.h" + +int n_prime; +FILE *primes; + +/* fast square root */ +static mp_digit +i_sqrt (mp_word x) +{ + mp_word x1, x2; + + x2 = x; + do { + x1 = x2; + x2 = x1 - ((x1 * x1) - x) / (2 * x1); + } while (x1 != x2); + + if (x1 * x1 > x) { + --x1; + } + + return x1; +} + + +/* generates a prime digit */ +static void gen_prime (void) +{ + mp_digit r, x, y, next; + FILE *out; + + out = fopen("pprime.dat", "wb"); + + /* write first set of primes */ + r = 3; fwrite(&r, 1, sizeof(mp_digit), out); + r = 5; fwrite(&r, 1, sizeof(mp_digit), out); + r = 7; fwrite(&r, 1, sizeof(mp_digit), out); + r = 11; fwrite(&r, 1, sizeof(mp_digit), out); + r = 13; fwrite(&r, 1, sizeof(mp_digit), out); + r = 17; fwrite(&r, 1, sizeof(mp_digit), out); + r = 19; fwrite(&r, 1, sizeof(mp_digit), out); + r = 23; fwrite(&r, 1, sizeof(mp_digit), out); + r = 29; fwrite(&r, 1, sizeof(mp_digit), out); + r = 31; fwrite(&r, 1, sizeof(mp_digit), out); + + /* get square root, since if 'r' is composite its factors must be < than this */ + y = i_sqrt (r); + next = (y + 1) * (y + 1); + + for (;;) { + do { + r += 2; /* next candidate */ + r &= MP_MASK; + if (r < 31) break; + + /* update sqrt ? */ + if (next <= r) { + ++y; + next = (y + 1) * (y + 1); + } + + /* loop if divisible by 3,5,7,11,13,17,19,23,29 */ + if ((r % 3) == 0) { + x = 0; + continue; + } + if ((r % 5) == 0) { + x = 0; + continue; + } + if ((r % 7) == 0) { + x = 0; + continue; + } + if ((r % 11) == 0) { + x = 0; + continue; + } + if ((r % 13) == 0) { + x = 0; + continue; + } + if ((r % 17) == 0) { + x = 0; + continue; + } + if ((r % 19) == 0) { + x = 0; + continue; + } + if ((r % 23) == 0) { + x = 0; + continue; + } + if ((r % 29) == 0) { + x = 0; + continue; + } + + /* now check if r is divisible by x + k={1,7,11,13,17,19,23,29} */ + for (x = 30; x <= y; x += 30) { + if ((r % (x + 1)) == 0) { + x = 0; + break; + } + if ((r % (x + 7)) == 0) { + x = 0; + break; + } + if ((r % (x + 11)) == 0) { + x = 0; + break; + } + if ((r % (x + 13)) == 0) { + x = 0; + break; + } + if ((r % (x + 17)) == 0) { + x = 0; + break; + } + if ((r % (x + 19)) == 0) { + x = 0; + break; + } + if ((r % (x + 23)) == 0) { + x = 0; + break; + } + if ((r % (x + 29)) == 0) { + x = 0; + break; + } + } + } while (x == 0); + if (r > 31) { fwrite(&r, 1, sizeof(mp_digit), out); printf("%9d\r", r); fflush(stdout); } + if (r < 31) break; + } + + fclose(out); +} + +void load_tab(void) +{ + primes = fopen("pprime.dat", "rb"); + if (primes == NULL) { + gen_prime(); + primes = fopen("pprime.dat", "rb"); + } + fseek(primes, 0, SEEK_END); + n_prime = ftell(primes) / sizeof(mp_digit); +} + +mp_digit prime_digit(void) +{ + int n; + mp_digit d; + + n = abs(rand()) % n_prime; + fseek(primes, n * sizeof(mp_digit), SEEK_SET); + fread(&d, 1, sizeof(mp_digit), primes); + return d; +} + + +/* makes a prime of at least k bits */ +int +pprime (int k, int li, mp_int * p, mp_int * q) +{ + mp_int a, b, c, n, x, y, z, v; + int res, ii; + static const mp_digit bases[] = { 2, 3, 5, 7, 11, 13, 17, 19 }; + + /* single digit ? */ + if (k <= (int) DIGIT_BIT) { + mp_set (p, prime_digit ()); + return MP_OKAY; + } + + if ((res = mp_init (&c)) != MP_OKAY) { + return res; + } + + if ((res = mp_init (&v)) != MP_OKAY) { + goto LBL_C; + } + + /* product of first 50 primes */ + if ((res = + mp_read_radix (&v, + "19078266889580195013601891820992757757219839668357012055907516904309700014933909014729740190", + 10)) != MP_OKAY) { + goto LBL_V; + } + + if ((res = mp_init (&a)) != MP_OKAY) { + goto LBL_V; + } + + /* set the prime */ + mp_set (&a, prime_digit ()); + + if ((res = mp_init (&b)) != MP_OKAY) { + goto LBL_A; + } + + if ((res = mp_init (&n)) != MP_OKAY) { + goto LBL_B; + } + + if ((res = mp_init (&x)) != MP_OKAY) { + goto LBL_N; + } + + if ((res = mp_init (&y)) != MP_OKAY) { + goto LBL_X; + } + + if ((res = mp_init (&z)) != MP_OKAY) { + goto LBL_Y; + } + + /* now loop making the single digit */ + while (mp_count_bits (&a) < k) { + fprintf (stderr, "prime has %4d bits left\r", k - mp_count_bits (&a)); + fflush (stderr); + top: + mp_set (&b, prime_digit ()); + + /* now compute z = a * b * 2 */ + if ((res = mp_mul (&a, &b, &z)) != MP_OKAY) { /* z = a * b */ + goto LBL_Z; + } + + if ((res = mp_copy (&z, &c)) != MP_OKAY) { /* c = a * b */ + goto LBL_Z; + } + + if ((res = mp_mul_2 (&z, &z)) != MP_OKAY) { /* z = 2 * a * b */ + goto LBL_Z; + } + + /* n = z + 1 */ + if ((res = mp_add_d (&z, 1, &n)) != MP_OKAY) { /* n = z + 1 */ + goto LBL_Z; + } + + /* check (n, v) == 1 */ + if ((res = mp_gcd (&n, &v, &y)) != MP_OKAY) { /* y = (n, v) */ + goto LBL_Z; + } + + if (mp_cmp_d (&y, 1) != MP_EQ) + goto top; + + /* now try base x=bases[ii] */ + for (ii = 0; ii < li; ii++) { + mp_set (&x, bases[ii]); + + /* compute x^a mod n */ + if ((res = mp_exptmod (&x, &a, &n, &y)) != MP_OKAY) { /* y = x^a mod n */ + goto LBL_Z; + } + + /* if y == 1 loop */ + if (mp_cmp_d (&y, 1) == MP_EQ) + continue; + + /* now x^2a mod n */ + if ((res = mp_sqrmod (&y, &n, &y)) != MP_OKAY) { /* y = x^2a mod n */ + goto LBL_Z; + } + + if (mp_cmp_d (&y, 1) == MP_EQ) + continue; + + /* compute x^b mod n */ + if ((res = mp_exptmod (&x, &b, &n, &y)) != MP_OKAY) { /* y = x^b mod n */ + goto LBL_Z; + } + + /* if y == 1 loop */ + if (mp_cmp_d (&y, 1) == MP_EQ) + continue; + + /* now x^2b mod n */ + if ((res = mp_sqrmod (&y, &n, &y)) != MP_OKAY) { /* y = x^2b mod n */ + goto LBL_Z; + } + + if (mp_cmp_d (&y, 1) == MP_EQ) + continue; + + /* compute x^c mod n == x^ab mod n */ + if ((res = mp_exptmod (&x, &c, &n, &y)) != MP_OKAY) { /* y = x^ab mod n */ + goto LBL_Z; + } + + /* if y == 1 loop */ + if (mp_cmp_d (&y, 1) == MP_EQ) + continue; + + /* now compute (x^c mod n)^2 */ + if ((res = mp_sqrmod (&y, &n, &y)) != MP_OKAY) { /* y = x^2ab mod n */ + goto LBL_Z; + } + + /* y should be 1 */ + if (mp_cmp_d (&y, 1) != MP_EQ) + continue; + break; + } + + /* no bases worked? */ + if (ii == li) + goto top; + +{ + char buf[4096]; + + mp_toradix(&n, buf, 10); + printf("Certificate of primality for:\n%s\n\n", buf); + mp_toradix(&a, buf, 10); + printf("A == \n%s\n\n", buf); + mp_toradix(&b, buf, 10); + printf("B == \n%s\n\nG == %d\n", buf, bases[ii]); + printf("----------------------------------------------------------------\n"); +} + + /* a = n */ + mp_copy (&n, &a); + } + + /* get q to be the order of the large prime subgroup */ + mp_sub_d (&n, 1, q); + mp_div_2 (q, q); + mp_div (q, &b, q, NULL); + + mp_exch (&n, p); + + res = MP_OKAY; +LBL_Z:mp_clear (&z); +LBL_Y:mp_clear (&y); +LBL_X:mp_clear (&x); +LBL_N:mp_clear (&n); +LBL_B:mp_clear (&b); +LBL_A:mp_clear (&a); +LBL_V:mp_clear (&v); +LBL_C:mp_clear (&c); + return res; +} + + +int +main (void) +{ + mp_int p, q; + char buf[4096]; + int k, li; + clock_t t1; + + srand (time (NULL)); + load_tab(); + + printf ("Enter # of bits: \n"); + fgets (buf, sizeof (buf), stdin); + sscanf (buf, "%d", &k); + + printf ("Enter number of bases to try (1 to 8):\n"); + fgets (buf, sizeof (buf), stdin); + sscanf (buf, "%d", &li); + + + mp_init (&p); + mp_init (&q); + + t1 = clock (); + pprime (k, li, &p, &q); + t1 = clock () - t1; + + printf ("\n\nTook %ld ticks, %d bits\n", t1, mp_count_bits (&p)); + + mp_toradix (&p, buf, 10); + printf ("P == %s\n", buf); + mp_toradix (&q, buf, 10); + printf ("Q == %s\n", buf); + + return 0; +} + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/etc/pprime.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/etc/timer.asm Index: libtommath/etc/timer.asm ================================================================== --- /dev/null +++ libtommath/etc/timer.asm @@ -0,0 +1,37 @@ +; x86 timer in NASM +; +; Tom St Denis, tomstdenis@iahu.ca +[bits 32] +[section .data] +time dd 0, 0 + +[section .text] + +%ifdef USE_ELF +[global t_start] +t_start: +%else +[global _t_start] +_t_start: +%endif + push edx + push eax + rdtsc + mov [time+0],edx + mov [time+4],eax + pop eax + pop edx + ret + +%ifdef USE_ELF +[global t_read] +t_read: +%else +[global _t_read] +_t_read: +%endif + rdtsc + sub eax,[time+4] + sbb edx,[time+0] + ret + ADDED libtommath/etc/tune.c Index: libtommath/etc/tune.c ================================================================== --- /dev/null +++ libtommath/etc/tune.c @@ -0,0 +1,142 @@ +/* Tune the Karatsuba parameters + * + * Tom St Denis, tomstdenis@iahu.ca + */ +#include +#include + +/* how many times todo each size mult. Depends on your computer. For slow computers + * this can be low like 5 or 10. For fast [re: Athlon] should be 25 - 50 or so + */ +#define TIMES (1UL<<14UL) + +/* RDTSC from Scott Duplichan */ +static ulong64 TIMFUNC (void) + { + #if defined __GNUC__ + #if defined(__i386__) || defined(__x86_64__) + unsigned long long a; + __asm__ __volatile__ ("rdtsc\nmovl %%eax,%0\nmovl %%edx,4+%0\n"::"m"(a):"%eax","%edx"); + return a; + #else /* gcc-IA64 version */ + unsigned long result; + __asm__ __volatile__("mov %0=ar.itc" : "=r"(result) :: "memory"); + while (__builtin_expect ((int) result == -1, 0)) + __asm__ __volatile__("mov %0=ar.itc" : "=r"(result) :: "memory"); + return result; + #endif + + // Microsoft and Intel Windows compilers + #elif defined _M_IX86 + __asm rdtsc + #elif defined _M_AMD64 + return __rdtsc (); + #elif defined _M_IA64 + #if defined __INTEL_COMPILER + #include + #endif + return __getReg (3116); + #else + #error need rdtsc function for this build + #endif + } + + +#ifndef X86_TIMER + +/* generic ISO C timer */ +ulong64 LBL_T; +void t_start(void) { LBL_T = TIMFUNC(); } +ulong64 t_read(void) { return TIMFUNC() - LBL_T; } + +#else +extern void t_start(void); +extern ulong64 t_read(void); +#endif + +ulong64 time_mult(int size, int s) +{ + unsigned long x; + mp_int a, b, c; + ulong64 t1; + + mp_init (&a); + mp_init (&b); + mp_init (&c); + + mp_rand (&a, size); + mp_rand (&b, size); + + if (s == 1) { + KARATSUBA_MUL_CUTOFF = size; + } else { + KARATSUBA_MUL_CUTOFF = 100000; + } + + t_start(); + for (x = 0; x < TIMES; x++) { + mp_mul(&a,&b,&c); + } + t1 = t_read(); + mp_clear (&a); + mp_clear (&b); + mp_clear (&c); + return t1; +} + +ulong64 time_sqr(int size, int s) +{ + unsigned long x; + mp_int a, b; + ulong64 t1; + + mp_init (&a); + mp_init (&b); + + mp_rand (&a, size); + + if (s == 1) { + KARATSUBA_SQR_CUTOFF = size; + } else { + KARATSUBA_SQR_CUTOFF = 100000; + } + + t_start(); + for (x = 0; x < TIMES; x++) { + mp_sqr(&a,&b); + } + t1 = t_read(); + mp_clear (&a); + mp_clear (&b); + return t1; +} + +int +main (void) +{ + ulong64 t1, t2; + int x, y; + + for (x = 8; ; x += 2) { + t1 = time_mult(x, 0); + t2 = time_mult(x, 1); + printf("%d: %9llu %9llu, %9llu\n", x, t1, t2, t2 - t1); + if (t2 < t1) break; + } + y = x; + + for (x = 8; ; x += 2) { + t1 = time_sqr(x, 0); + t2 = time_sqr(x, 1); + printf("%d: %9llu %9llu, %9llu\n", x, t1, t2, t2 - t1); + if (t2 < t1) break; + } + printf("KARATSUBA_MUL_CUTOFF = %d\n", y); + printf("KARATSUBA_SQR_CUTOFF = %d\n", x); + + return 0; +} + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/etc/tune.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/logs/README Index: libtommath/logs/README ================================================================== --- /dev/null +++ libtommath/logs/README @@ -0,0 +1,13 @@ +To use the pretty graphs you have to first build/run the ltmtest from the root directory of the package. +Todo this type + +make timing ; ltmtest + +in the root. It will run for a while [about ten minutes on most PCs] and produce a series of .log files in logs/. + +After doing that run "gnuplot graphs.dem" to make the PNGs. If you managed todo that all so far just open index.html to view +them all :-) + +Have fun + +Tom ADDED libtommath/logs/add.log Index: libtommath/logs/add.log ================================================================== --- /dev/null +++ libtommath/logs/add.log @@ -0,0 +1,16 @@ +480 87 +960 111 +1440 135 +1920 159 +2400 200 +2880 224 +3360 248 +3840 272 +4320 296 +4800 320 +5280 344 +5760 368 +6240 392 +6720 416 +7200 440 +7680 464 ADDED libtommath/logs/addsub.png Index: libtommath/logs/addsub.png ================================================================== --- /dev/null +++ libtommath/logs/addsub.png cannot compute difference between binary files ADDED libtommath/logs/expt.log Index: libtommath/logs/expt.log ================================================================== --- /dev/null +++ libtommath/logs/expt.log @@ -0,0 +1,7 @@ +513 1435869 +769 3544970 +1025 7791638 +2049 46902238 +2561 85334899 +3073 141451412 +4097 308770310 ADDED libtommath/logs/expt.png Index: libtommath/logs/expt.png ================================================================== --- /dev/null +++ libtommath/logs/expt.png cannot compute difference between binary files ADDED libtommath/logs/expt_2k.log Index: libtommath/logs/expt_2k.log ================================================================== --- /dev/null +++ libtommath/logs/expt_2k.log @@ -0,0 +1,5 @@ +607 2109225 +1279 10148314 +2203 34126877 +3217 82716424 +4253 161569606 ADDED libtommath/logs/expt_2kl.log Index: libtommath/logs/expt_2kl.log ================================================================== --- /dev/null +++ libtommath/logs/expt_2kl.log @@ -0,0 +1,4 @@ +1024 7705271 +2048 34286851 +4096 165207491 +521 1618631 ADDED libtommath/logs/expt_dr.log Index: libtommath/logs/expt_dr.log ================================================================== --- /dev/null +++ libtommath/logs/expt_dr.log @@ -0,0 +1,7 @@ +532 1928550 +784 3763908 +1036 7564221 +1540 16566059 +2072 32283784 +3080 79851565 +4116 157843530 ADDED libtommath/logs/index.html Index: libtommath/logs/index.html ================================================================== --- /dev/null +++ libtommath/logs/index.html @@ -0,0 +1,27 @@ + + +LibTomMath Log Plots + + + +

Addition and Subtraction

+
+
+ +

Multipliers

+
+
+ +

Exptmod

+
+
+ +

Modular Inverse

+
+
+ + + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/logs/index.html,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/logs/invmod.png Index: libtommath/logs/invmod.png ================================================================== --- /dev/null +++ libtommath/logs/invmod.png cannot compute difference between binary files ADDED libtommath/logs/mult.log Index: libtommath/logs/mult.log ================================================================== --- /dev/null +++ libtommath/logs/mult.log @@ -0,0 +1,84 @@ +271 555 +390 855 +508 1161 +631 1605 +749 2117 +871 2687 +991 3329 +1108 4084 +1231 4786 +1351 5624 +1470 6392 +1586 7364 +1710 8218 +1830 9255 +1951 10217 +2067 11461 +2191 12463 +2308 13677 +2430 14800 +2551 16232 +2671 17460 +2791 18899 +2902 20247 +3028 21902 +3151 23240 +3267 24927 +3391 26441 +3511 28277 +3631 29838 +3749 31751 +3869 33673 +3989 35431 +4111 37518 +4231 39426 +4349 41504 +4471 43567 +4591 45786 +4711 47876 +4831 50299 +4951 52427 +5071 54785 +5189 57241 +5307 59730 +5431 62194 +5551 64761 +5670 67322 +5789 70073 +5907 72663 +6030 75437 +6151 78242 +6268 81202 +6389 83948 +6509 86985 +6631 89903 +6747 93184 +6869 96044 +6991 99286 +7109 102395 +7229 105917 +7351 108940 +7470 112490 +7589 115702 +7711 119508 +7831 122632 +7951 126410 +8071 129808 +8190 133895 +8311 137146 +8431 141218 +8549 144732 +8667 149131 +8790 152462 +8911 156754 +9030 160479 +9149 165138 +9271 168601 +9391 173185 +9511 176988 +9627 181976 +9751 185539 +9870 190388 +9991 194335 +10110 199605 +10228 203298 ADDED libtommath/logs/mult.png Index: libtommath/logs/mult.png ================================================================== --- /dev/null +++ libtommath/logs/mult.png cannot compute difference between binary files ADDED libtommath/logs/mult_kara.log Index: libtommath/logs/mult_kara.log ================================================================== --- /dev/null +++ libtommath/logs/mult_kara.log @@ -0,0 +1,84 @@ +271 560 +391 870 +511 1159 +631 1605 +750 2111 +871 2737 +991 3361 +1111 4054 +1231 4778 +1351 5600 +1471 6404 +1591 7323 +1710 8255 +1831 9239 +1948 10257 +2070 11397 +2190 12531 +2308 13665 +2429 14870 +2550 16175 +2671 17539 +2787 18879 +2911 20350 +3031 21807 +3150 23415 +3270 24897 +3388 26567 +3511 28205 +3627 30076 +3751 31744 +3869 33657 +3991 35425 +4111 37522 +4229 39363 +4351 41503 +4470 43491 +4590 45827 +4711 47795 +4828 50166 +4951 52318 +5070 54911 +5191 57036 +5308 58237 +5431 60248 +5551 62678 +5671 64786 +5791 67294 +5908 69343 +6031 71607 +6151 74166 +6271 76590 +6391 78734 +6511 81175 +6631 83742 +6750 86403 +6868 88873 +6990 91150 +7110 94211 +7228 96922 +7351 99445 +7469 102216 +7589 104968 +7711 108113 +7827 110758 +7950 113714 +8071 116511 +8186 119643 +8310 122679 +8425 125581 +8551 128715 +8669 131778 +8788 135116 +8910 138138 +9031 141628 +9148 144754 +9268 148367 +9391 151551 +9511 155033 +9631 158652 +9751 162125 +9871 165248 +9988 168627 +10111 172427 +10231 176412 ADDED libtommath/logs/sqr.log Index: libtommath/logs/sqr.log ================================================================== --- /dev/null +++ libtommath/logs/sqr.log @@ -0,0 +1,84 @@ +265 562 +389 882 +509 1207 +631 1572 +750 1990 +859 2433 +991 2894 +1109 3555 +1230 4228 +1350 5018 +1471 5805 +1591 6579 +1709 7415 +1829 8329 +1949 9225 +2071 10139 +2188 11239 +2309 12178 +2431 13212 +2551 14294 +2671 15551 +2791 16512 +2911 17718 +3030 18876 +3150 20259 +3270 21374 +3391 22650 +3511 23948 +3631 25493 +3750 26756 +3870 28225 +3989 29705 +4110 31409 +4230 32834 +4351 34327 +4471 35818 +4591 37636 +4711 39228 +4830 40868 +4949 42393 +5070 44541 +5191 46269 +5310 48162 +5429 49728 +5548 51985 +5671 53948 +5791 55885 +5910 57584 +6031 60082 +6150 62239 +6270 64309 +6390 66014 +6511 68766 +6631 71012 +6750 73172 +6871 74952 +6991 77909 +7111 80371 +7231 82666 +7351 84531 +7469 87698 +7589 90318 +7711 225384 +7830 232428 +7950 240009 +8070 246522 +8190 253662 +8310 260961 +8431 269253 +8549 275743 +8671 283769 +8789 290811 +8911 300034 +9030 306873 +9149 315085 +9270 323944 +9390 332390 +9508 337519 +9631 348986 +9749 356904 +9871 367013 +9989 373831 +10108 381033 +10230 393475 ADDED libtommath/logs/sqr_kara.log Index: libtommath/logs/sqr_kara.log ================================================================== --- /dev/null +++ libtommath/logs/sqr_kara.log @@ -0,0 +1,84 @@ +271 560 +388 878 +511 1179 +629 1625 +751 1988 +871 2423 +989 2896 +1111 3561 +1231 4209 +1350 5015 +1470 5804 +1591 6556 +1709 7420 +1831 8263 +1951 9173 +2070 10153 +2191 11229 +2310 12167 +2431 13211 +2550 14309 +2671 15524 +2788 16525 +2910 17712 +3028 18822 +3148 20220 +3271 21343 +3391 22652 +3511 23944 +3630 25485 +3750 26778 +3868 28201 +3990 29653 +4111 31393 +4225 32841 +4350 34328 +4471 35786 +4590 37652 +4711 39245 +4830 40876 +4951 42433 +5068 44547 +5191 46321 +5311 48140 +5430 49727 +5550 52034 +5671 53954 +5791 55921 +5908 57597 +6031 60084 +6148 62226 +6270 64295 +6390 66045 +6511 68779 +6629 71003 +6751 73169 +6871 74992 +6991 77895 +7110 80376 +7231 82628 +7351 84468 +7470 87664 +7591 90284 +7711 91352 +7828 93995 +7950 96276 +8071 98691 +8190 101256 +8308 103631 +8431 105222 +8550 108343 +8671 110281 +8787 112764 +8911 115397 +9031 117690 +9151 120266 +9271 122715 +9391 124624 +9510 127937 +9630 130313 +9750 132914 +9871 136129 +9991 138517 +10108 141525 +10231 144225 ADDED libtommath/logs/sub.log Index: libtommath/logs/sub.log ================================================================== --- /dev/null +++ libtommath/logs/sub.log @@ -0,0 +1,16 @@ +480 94 +960 116 +1440 140 +1920 164 +2400 205 +2880 229 +3360 253 +3840 277 +4320 299 +4800 321 +5280 345 +5760 371 +6240 395 +6720 419 +7200 441 +7680 465 ADDED libtommath/makefile Index: libtommath/makefile ================================================================== --- /dev/null +++ libtommath/makefile @@ -0,0 +1,180 @@ +#Makefile for GCC +# +#Tom St Denis + +#version of library +VERSION=0.36 + +CFLAGS += -I./ -Wall -W -Wshadow -Wsign-compare + +ifndef IGNORE_SPEED + +#for speed +CFLAGS += -O3 -funroll-loops + +#for size +#CFLAGS += -Os + +#x86 optimizations [should be valid for any GCC install though] +CFLAGS += -fomit-frame-pointer + +#debug +#CFLAGS += -g3 + +endif + +#install as this user +ifndef INSTALL_GROUP + GROUP=wheel +else + GROUP=$(INSTALL_GROUP) +endif + +ifndef INSTALL_USER + USER=root +else + USER=$(INSTALL_USER) +endif + +default: libtommath.a + +#default files to install +ifndef LIBNAME + LIBNAME=libtommath.a +endif +HEADERS=tommath.h tommath_class.h tommath_superclass.h + +#LIBPATH-The directory for libtommath to be installed to. +#INCPATH-The directory to install the header files for libtommath. +#DATAPATH-The directory to install the pdf docs. +DESTDIR= +LIBPATH=/usr/lib +INCPATH=/usr/include +DATAPATH=/usr/share/doc/libtommath/pdf + +OBJECTS=bncore.o bn_mp_init.o bn_mp_clear.o bn_mp_exch.o bn_mp_grow.o bn_mp_shrink.o \ +bn_mp_clamp.o bn_mp_zero.o bn_mp_set.o bn_mp_set_int.o bn_mp_init_size.o bn_mp_copy.o \ +bn_mp_init_copy.o bn_mp_abs.o bn_mp_neg.o bn_mp_cmp_mag.o bn_mp_cmp.o bn_mp_cmp_d.o \ +bn_mp_rshd.o bn_mp_lshd.o bn_mp_mod_2d.o bn_mp_div_2d.o bn_mp_mul_2d.o bn_mp_div_2.o \ +bn_mp_mul_2.o bn_s_mp_add.o bn_s_mp_sub.o bn_fast_s_mp_mul_digs.o bn_s_mp_mul_digs.o \ +bn_fast_s_mp_mul_high_digs.o bn_s_mp_mul_high_digs.o bn_fast_s_mp_sqr.o bn_s_mp_sqr.o \ +bn_mp_add.o bn_mp_sub.o bn_mp_karatsuba_mul.o bn_mp_mul.o bn_mp_karatsuba_sqr.o \ +bn_mp_sqr.o bn_mp_div.o bn_mp_mod.o bn_mp_add_d.o bn_mp_sub_d.o bn_mp_mul_d.o \ +bn_mp_div_d.o bn_mp_mod_d.o bn_mp_expt_d.o bn_mp_addmod.o bn_mp_submod.o \ +bn_mp_mulmod.o bn_mp_sqrmod.o bn_mp_gcd.o bn_mp_lcm.o bn_fast_mp_invmod.o bn_mp_invmod.o \ +bn_mp_reduce.o bn_mp_montgomery_setup.o bn_fast_mp_montgomery_reduce.o bn_mp_montgomery_reduce.o \ +bn_mp_exptmod_fast.o bn_mp_exptmod.o bn_mp_2expt.o bn_mp_n_root.o bn_mp_jacobi.o bn_reverse.o \ +bn_mp_count_bits.o bn_mp_read_unsigned_bin.o bn_mp_read_signed_bin.o bn_mp_to_unsigned_bin.o \ +bn_mp_to_signed_bin.o bn_mp_unsigned_bin_size.o bn_mp_signed_bin_size.o \ +bn_mp_xor.o bn_mp_and.o bn_mp_or.o bn_mp_rand.o bn_mp_montgomery_calc_normalization.o \ +bn_mp_prime_is_divisible.o bn_prime_tab.o bn_mp_prime_fermat.o bn_mp_prime_miller_rabin.o \ +bn_mp_prime_is_prime.o bn_mp_prime_next_prime.o bn_mp_dr_reduce.o \ +bn_mp_dr_is_modulus.o bn_mp_dr_setup.o bn_mp_reduce_setup.o \ +bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_div_3.o bn_s_mp_exptmod.o \ +bn_mp_reduce_2k.o bn_mp_reduce_is_2k.o bn_mp_reduce_2k_setup.o \ +bn_mp_reduce_2k_l.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_2k_setup_l.o \ +bn_mp_radix_smap.o bn_mp_read_radix.o bn_mp_toradix.o bn_mp_radix_size.o \ +bn_mp_fread.o bn_mp_fwrite.o bn_mp_cnt_lsb.o bn_error.o \ +bn_mp_init_multi.o bn_mp_clear_multi.o bn_mp_exteuclid.o bn_mp_toradix_n.o \ +bn_mp_prime_random_ex.o bn_mp_get_int.o bn_mp_sqrt.o bn_mp_is_square.o bn_mp_init_set.o \ +bn_mp_init_set_int.o bn_mp_invmod_slow.o bn_mp_prime_rabin_miller_trials.o \ +bn_mp_to_signed_bin_n.o bn_mp_to_unsigned_bin_n.o + +$(LIBNAME): $(OBJECTS) + $(AR) $(ARFLAGS) $@ $(OBJECTS) + ranlib $@ + +#make a profiled library (takes a while!!!) +# +# This will build the library with profile generation +# then run the test demo and rebuild the library. +# +# So far I've seen improvements in the MP math +profiled: + make CFLAGS="$(CFLAGS) -fprofile-arcs -DTESTING" timing + ./ltmtest + rm -f *.a *.o ltmtest + make CFLAGS="$(CFLAGS) -fbranch-probabilities" + +#make a single object profiled library +profiled_single: + perl gen.pl + $(CC) $(CFLAGS) -fprofile-arcs -DTESTING -c mpi.c -o mpi.o + $(CC) $(CFLAGS) -DTESTING -DTIMER demo/timing.c mpi.o -o ltmtest + ./ltmtest + rm -f *.o ltmtest + $(CC) $(CFLAGS) -fbranch-probabilities -DTESTING -c mpi.c -o mpi.o + $(AR) $(ARFLAGS) $(LIBNAME) mpi.o + ranlib $(LIBNAME) + +install: $(LIBNAME) + install -d -g $(GROUP) -o $(USER) $(DESTDIR)$(LIBPATH) + install -d -g $(GROUP) -o $(USER) $(DESTDIR)$(INCPATH) + install -g $(GROUP) -o $(USER) $(LIBNAME) $(DESTDIR)$(LIBPATH) + install -g $(GROUP) -o $(USER) $(HEADERS) $(DESTDIR)$(INCPATH) + +test: $(LIBNAME) demo/demo.o + $(CC) $(CFLAGS) demo/demo.o $(LIBNAME) -o test + +mtest: test + cd mtest ; $(CC) $(CFLAGS) mtest.c -o mtest + +timing: $(LIBNAME) + $(CC) $(CFLAGS) -DTIMER demo/timing.c $(LIBNAME) -o ltmtest + +# makes the LTM book DVI file, requires tetex, perl and makeindex [part of tetex I think] +docdvi: tommath.src + cd pics ; make + echo "hello" > tommath.ind + perl booker.pl + latex tommath > /dev/null + latex tommath > /dev/null + makeindex tommath + latex tommath > /dev/null + +# poster, makes the single page PDF poster +poster: poster.tex + pdflatex poster + rm -f poster.aux poster.log + +# makes the LTM book PDF file, requires tetex, cleans up the LaTeX temp files +docs: docdvi + dvipdf tommath + rm -f tommath.log tommath.aux tommath.dvi tommath.idx tommath.toc tommath.lof tommath.ind tommath.ilg + cd pics ; make clean + +#LTM user manual +mandvi: bn.tex + echo "hello" > bn.ind + latex bn > /dev/null + latex bn > /dev/null + makeindex bn + latex bn > /dev/null + +#LTM user manual [pdf] +manual: mandvi + pdflatex bn >/dev/null + rm -f bn.aux bn.dvi bn.log bn.idx bn.lof bn.out bn.toc + +pretty: + perl pretty.build + +clean: + rm -f *.bat *.pdf *.o *.a *.obj *.lib *.exe *.dll etclib/*.o demo/demo.o test ltmtest mpitest mtest/mtest mtest/mtest.exe \ + *.idx *.toc *.log *.aux *.dvi *.lof *.ind *.ilg *.ps *.log *.s mpi.c *.da *.dyn *.dpi tommath.tex `find -type f | grep [~] | xargs` *.lo *.la + rm -rf .libs + cd etc ; make clean + cd pics ; make clean + +#zipup the project (take that!) +no_oops: clean + cd .. ; cvs commit + echo Scanning for scratch/dirty files + find . -type f | grep -v CVS | xargs -n 1 bash mess.sh + +zipup: clean manual poster docs + perl gen.pl ; mv mpi.c pre_gen/ ; \ + cd .. ; rm -rf ltm* libtommath-$(VERSION) ; mkdir libtommath-$(VERSION) ; \ + cp -R ./libtommath/* ./libtommath-$(VERSION)/ ; \ + tar -c libtommath-$(VERSION)/* | bzip2 -9vvc > ltm-$(VERSION).tar.bz2 ; \ + zip -9 -r ltm-$(VERSION).zip libtommath-$(VERSION)/* ADDED libtommath/makefile.bcc Index: libtommath/makefile.bcc ================================================================== --- /dev/null +++ libtommath/makefile.bcc @@ -0,0 +1,44 @@ +# +# Borland C++Builder Makefile (makefile.bcc) +# + + +LIB = tlib +CC = bcc32 +CFLAGS = -c -O2 -I. + +OBJECTS=bncore.obj bn_mp_init.obj bn_mp_clear.obj bn_mp_exch.obj bn_mp_grow.obj bn_mp_shrink.obj \ +bn_mp_clamp.obj bn_mp_zero.obj bn_mp_set.obj bn_mp_set_int.obj bn_mp_init_size.obj bn_mp_copy.obj \ +bn_mp_init_copy.obj bn_mp_abs.obj bn_mp_neg.obj bn_mp_cmp_mag.obj bn_mp_cmp.obj bn_mp_cmp_d.obj \ +bn_mp_rshd.obj bn_mp_lshd.obj bn_mp_mod_2d.obj bn_mp_div_2d.obj bn_mp_mul_2d.obj bn_mp_div_2.obj \ +bn_mp_mul_2.obj bn_s_mp_add.obj bn_s_mp_sub.obj bn_fast_s_mp_mul_digs.obj bn_s_mp_mul_digs.obj \ +bn_fast_s_mp_mul_high_digs.obj bn_s_mp_mul_high_digs.obj bn_fast_s_mp_sqr.obj bn_s_mp_sqr.obj \ +bn_mp_add.obj bn_mp_sub.obj bn_mp_karatsuba_mul.obj bn_mp_mul.obj bn_mp_karatsuba_sqr.obj \ +bn_mp_sqr.obj bn_mp_div.obj bn_mp_mod.obj bn_mp_add_d.obj bn_mp_sub_d.obj bn_mp_mul_d.obj \ +bn_mp_div_d.obj bn_mp_mod_d.obj bn_mp_expt_d.obj bn_mp_addmod.obj bn_mp_submod.obj \ +bn_mp_mulmod.obj bn_mp_sqrmod.obj bn_mp_gcd.obj bn_mp_lcm.obj bn_fast_mp_invmod.obj bn_mp_invmod.obj \ +bn_mp_reduce.obj bn_mp_montgomery_setup.obj bn_fast_mp_montgomery_reduce.obj bn_mp_montgomery_reduce.obj \ +bn_mp_exptmod_fast.obj bn_mp_exptmod.obj bn_mp_2expt.obj bn_mp_n_root.obj bn_mp_jacobi.obj bn_reverse.obj \ +bn_mp_count_bits.obj bn_mp_read_unsigned_bin.obj bn_mp_read_signed_bin.obj bn_mp_to_unsigned_bin.obj \ +bn_mp_to_signed_bin.obj bn_mp_unsigned_bin_size.obj bn_mp_signed_bin_size.obj \ +bn_mp_xor.obj bn_mp_and.obj bn_mp_or.obj bn_mp_rand.obj bn_mp_montgomery_calc_normalization.obj \ +bn_mp_prime_is_divisible.obj bn_prime_tab.obj bn_mp_prime_fermat.obj bn_mp_prime_miller_rabin.obj \ +bn_mp_prime_is_prime.obj bn_mp_prime_next_prime.obj bn_mp_dr_reduce.obj \ +bn_mp_dr_is_modulus.obj bn_mp_dr_setup.obj bn_mp_reduce_setup.obj \ +bn_mp_toom_mul.obj bn_mp_toom_sqr.obj bn_mp_div_3.obj bn_s_mp_exptmod.obj \ +bn_mp_reduce_2k.obj bn_mp_reduce_is_2k.obj bn_mp_reduce_2k_setup.obj \ +bn_mp_reduce_2k_l.obj bn_mp_reduce_is_2k_l.obj bn_mp_reduce_2k_setup_l.obj \ +bn_mp_radix_smap.obj bn_mp_read_radix.obj bn_mp_toradix.obj bn_mp_radix_size.obj \ +bn_mp_fread.obj bn_mp_fwrite.obj bn_mp_cnt_lsb.obj bn_error.obj \ +bn_mp_init_multi.obj bn_mp_clear_multi.obj bn_mp_exteuclid.obj bn_mp_toradix_n.obj \ +bn_mp_prime_random_ex.obj bn_mp_get_int.obj bn_mp_sqrt.obj bn_mp_is_square.obj \ +bn_mp_init_set.obj bn_mp_init_set_int.obj bn_mp_invmod_slow.obj bn_mp_prime_rabin_miller_trials.obj \ +bn_mp_to_signed_bin_n.obj bn_mp_to_unsigned_bin_n.obj + +TARGET = libtommath.lib + +$(TARGET): $(OBJECTS) + +.c.objbjbjbj: + $(CC) $(CFLAGS) $< + $(LIB) $(TARGET) -+$@ ADDED libtommath/makefile.cygwin_dll Index: libtommath/makefile.cygwin_dll ================================================================== --- /dev/null +++ libtommath/makefile.cygwin_dll @@ -0,0 +1,55 @@ +#Makefile for Cygwin-GCC +# +#This makefile will build a Windows DLL [doesn't require cygwin to run] in the file +#libtommath.dll. The import library is in libtommath.dll.a. Remember to add +#"-Wl,--enable-auto-import" to your client build to avoid the auto-import warnings +# +#Tom St Denis +CFLAGS += -I./ -Wall -W -Wshadow -O3 -funroll-loops -mno-cygwin + +#x86 optimizations [should be valid for any GCC install though] +CFLAGS += -fomit-frame-pointer + +default: windll + +OBJECTS=bncore.o bn_mp_init.o bn_mp_clear.o bn_mp_exch.o bn_mp_grow.o bn_mp_shrink.o \ +bn_mp_clamp.o bn_mp_zero.o bn_mp_set.o bn_mp_set_int.o bn_mp_init_size.o bn_mp_copy.o \ +bn_mp_init_copy.o bn_mp_abs.o bn_mp_neg.o bn_mp_cmp_mag.o bn_mp_cmp.o bn_mp_cmp_d.o \ +bn_mp_rshd.o bn_mp_lshd.o bn_mp_mod_2d.o bn_mp_div_2d.o bn_mp_mul_2d.o bn_mp_div_2.o \ +bn_mp_mul_2.o bn_s_mp_add.o bn_s_mp_sub.o bn_fast_s_mp_mul_digs.o bn_s_mp_mul_digs.o \ +bn_fast_s_mp_mul_high_digs.o bn_s_mp_mul_high_digs.o bn_fast_s_mp_sqr.o bn_s_mp_sqr.o \ +bn_mp_add.o bn_mp_sub.o bn_mp_karatsuba_mul.o bn_mp_mul.o bn_mp_karatsuba_sqr.o \ +bn_mp_sqr.o bn_mp_div.o bn_mp_mod.o bn_mp_add_d.o bn_mp_sub_d.o bn_mp_mul_d.o \ +bn_mp_div_d.o bn_mp_mod_d.o bn_mp_expt_d.o bn_mp_addmod.o bn_mp_submod.o \ +bn_mp_mulmod.o bn_mp_sqrmod.o bn_mp_gcd.o bn_mp_lcm.o bn_fast_mp_invmod.o bn_mp_invmod.o \ +bn_mp_reduce.o bn_mp_montgomery_setup.o bn_fast_mp_montgomery_reduce.o bn_mp_montgomery_reduce.o \ +bn_mp_exptmod_fast.o bn_mp_exptmod.o bn_mp_2expt.o bn_mp_n_root.o bn_mp_jacobi.o bn_reverse.o \ +bn_mp_count_bits.o bn_mp_read_unsigned_bin.o bn_mp_read_signed_bin.o bn_mp_to_unsigned_bin.o \ +bn_mp_to_signed_bin.o bn_mp_unsigned_bin_size.o bn_mp_signed_bin_size.o \ +bn_mp_xor.o bn_mp_and.o bn_mp_or.o bn_mp_rand.o bn_mp_montgomery_calc_normalization.o \ +bn_mp_prime_is_divisible.o bn_prime_tab.o bn_mp_prime_fermat.o bn_mp_prime_miller_rabin.o \ +bn_mp_prime_is_prime.o bn_mp_prime_next_prime.o bn_mp_dr_reduce.o \ +bn_mp_dr_is_modulus.o bn_mp_dr_setup.o bn_mp_reduce_setup.o \ +bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_div_3.o bn_s_mp_exptmod.o \ +bn_mp_reduce_2k.o bn_mp_reduce_is_2k.o bn_mp_reduce_2k_setup.o \ +bn_mp_reduce_2k_l.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_2k_setup_l.o \ +bn_mp_radix_smap.o bn_mp_read_radix.o bn_mp_toradix.o bn_mp_radix_size.o \ +bn_mp_fread.o bn_mp_fwrite.o bn_mp_cnt_lsb.o bn_error.o \ +bn_mp_init_multi.o bn_mp_clear_multi.o bn_mp_exteuclid.o bn_mp_toradix_n.o \ +bn_mp_prime_random_ex.o bn_mp_get_int.o bn_mp_sqrt.o bn_mp_is_square.o bn_mp_init_set.o \ +bn_mp_init_set_int.o bn_mp_invmod_slow.o bn_mp_prime_rabin_miller_trials.o \ +bn_mp_to_signed_bin_n.o bn_mp_to_unsigned_bin_n.o + +# make a Windows DLL via Cygwin +windll: $(OBJECTS) + gcc -mno-cygwin -mdll -o libtommath.dll -Wl,--out-implib=libtommath.dll.a -Wl,--export-all-symbols *.o + ranlib libtommath.dll.a + +# build the test program using the windows DLL +test: $(OBJECTS) windll + gcc $(CFLAGS) demo/demo.c libtommath.dll.a -Wl,--enable-auto-import -o test -s + cd mtest ; $(CC) -O3 -fomit-frame-pointer -funroll-loops mtest.c -o mtest -s + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/makefile.cygwin_dll,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/makefile.icc Index: libtommath/makefile.icc ================================================================== --- /dev/null +++ libtommath/makefile.icc @@ -0,0 +1,116 @@ +#Makefile for ICC +# +#Tom St Denis +CC=icc + +CFLAGS += -I./ + +# optimize for SPEED +# +# -mcpu= can be pentium, pentiumpro (covers PII through PIII) or pentium4 +# -ax? specifies make code specifically for ? but compatible with IA-32 +# -x? specifies compile solely for ? [not specifically IA-32 compatible] +# +# where ? is +# K - PIII +# W - first P4 [Williamette] +# N - P4 Northwood +# P - P4 Prescott +# B - Blend of P4 and PM [mobile] +# +# Default to just generic max opts +CFLAGS += -O3 -xP -ip + +#install as this user +USER=root +GROUP=root + +default: libtommath.a + +#default files to install +LIBNAME=libtommath.a +HEADERS=tommath.h + +#LIBPATH-The directory for libtomcrypt to be installed to. +#INCPATH-The directory to install the header files for libtommath. +#DATAPATH-The directory to install the pdf docs. +DESTDIR= +LIBPATH=/usr/lib +INCPATH=/usr/include +DATAPATH=/usr/share/doc/libtommath/pdf + +OBJECTS=bncore.o bn_mp_init.o bn_mp_clear.o bn_mp_exch.o bn_mp_grow.o bn_mp_shrink.o \ +bn_mp_clamp.o bn_mp_zero.o bn_mp_set.o bn_mp_set_int.o bn_mp_init_size.o bn_mp_copy.o \ +bn_mp_init_copy.o bn_mp_abs.o bn_mp_neg.o bn_mp_cmp_mag.o bn_mp_cmp.o bn_mp_cmp_d.o \ +bn_mp_rshd.o bn_mp_lshd.o bn_mp_mod_2d.o bn_mp_div_2d.o bn_mp_mul_2d.o bn_mp_div_2.o \ +bn_mp_mul_2.o bn_s_mp_add.o bn_s_mp_sub.o bn_fast_s_mp_mul_digs.o bn_s_mp_mul_digs.o \ +bn_fast_s_mp_mul_high_digs.o bn_s_mp_mul_high_digs.o bn_fast_s_mp_sqr.o bn_s_mp_sqr.o \ +bn_mp_add.o bn_mp_sub.o bn_mp_karatsuba_mul.o bn_mp_mul.o bn_mp_karatsuba_sqr.o \ +bn_mp_sqr.o bn_mp_div.o bn_mp_mod.o bn_mp_add_d.o bn_mp_sub_d.o bn_mp_mul_d.o \ +bn_mp_div_d.o bn_mp_mod_d.o bn_mp_expt_d.o bn_mp_addmod.o bn_mp_submod.o \ +bn_mp_mulmod.o bn_mp_sqrmod.o bn_mp_gcd.o bn_mp_lcm.o bn_fast_mp_invmod.o bn_mp_invmod.o \ +bn_mp_reduce.o bn_mp_montgomery_setup.o bn_fast_mp_montgomery_reduce.o bn_mp_montgomery_reduce.o \ +bn_mp_exptmod_fast.o bn_mp_exptmod.o bn_mp_2expt.o bn_mp_n_root.o bn_mp_jacobi.o bn_reverse.o \ +bn_mp_count_bits.o bn_mp_read_unsigned_bin.o bn_mp_read_signed_bin.o bn_mp_to_unsigned_bin.o \ +bn_mp_to_signed_bin.o bn_mp_unsigned_bin_size.o bn_mp_signed_bin_size.o \ +bn_mp_xor.o bn_mp_and.o bn_mp_or.o bn_mp_rand.o bn_mp_montgomery_calc_normalization.o \ +bn_mp_prime_is_divisible.o bn_prime_tab.o bn_mp_prime_fermat.o bn_mp_prime_miller_rabin.o \ +bn_mp_prime_is_prime.o bn_mp_prime_next_prime.o bn_mp_dr_reduce.o \ +bn_mp_dr_is_modulus.o bn_mp_dr_setup.o bn_mp_reduce_setup.o \ +bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_div_3.o bn_s_mp_exptmod.o \ +bn_mp_reduce_2k.o bn_mp_reduce_is_2k.o bn_mp_reduce_2k_setup.o \ +bn_mp_reduce_2k_l.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_2k_setup_l.o \ +bn_mp_radix_smap.o bn_mp_read_radix.o bn_mp_toradix.o bn_mp_radix_size.o \ +bn_mp_fread.o bn_mp_fwrite.o bn_mp_cnt_lsb.o bn_error.o \ +bn_mp_init_multi.o bn_mp_clear_multi.o bn_mp_exteuclid.o bn_mp_toradix_n.o \ +bn_mp_prime_random_ex.o bn_mp_get_int.o bn_mp_sqrt.o bn_mp_is_square.o bn_mp_init_set.o \ +bn_mp_init_set_int.o bn_mp_invmod_slow.o bn_mp_prime_rabin_miller_trials.o \ +bn_mp_to_signed_bin_n.o bn_mp_to_unsigned_bin_n.o + +libtommath.a: $(OBJECTS) + $(AR) $(ARFLAGS) libtommath.a $(OBJECTS) + ranlib libtommath.a + +#make a profiled library (takes a while!!!) +# +# This will build the library with profile generation +# then run the test demo and rebuild the library. +# +# So far I've seen improvements in the MP math +profiled: + make -f makefile.icc CFLAGS="$(CFLAGS) -prof_gen -DTESTING" timing + ./ltmtest + rm -f *.a *.o ltmtest + make -f makefile.icc CFLAGS="$(CFLAGS) -prof_use" + +#make a single object profiled library +profiled_single: + perl gen.pl + $(CC) $(CFLAGS) -prof_gen -DTESTING -c mpi.c -o mpi.o + $(CC) $(CFLAGS) -DTESTING -DTIMER demo/demo.c mpi.o -o ltmtest + ./ltmtest + rm -f *.o ltmtest + $(CC) $(CFLAGS) -prof_use -ip -DTESTING -c mpi.c -o mpi.o + $(AR) $(ARFLAGS) libtommath.a mpi.o + ranlib libtommath.a + +install: libtommath.a + install -d -g $(GROUP) -o $(USER) $(DESTDIR)$(LIBPATH) + install -d -g $(GROUP) -o $(USER) $(DESTDIR)$(INCPATH) + install -g $(GROUP) -o $(USER) $(LIBNAME) $(DESTDIR)$(LIBPATH) + install -g $(GROUP) -o $(USER) $(HEADERS) $(DESTDIR)$(INCPATH) + +test: libtommath.a demo/demo.o + $(CC) demo/demo.o libtommath.a -o test + +mtest: test + cd mtest ; $(CC) $(CFLAGS) mtest.c -o mtest + +timing: libtommath.a + $(CC) $(CFLAGS) -DTIMER demo/timing.c libtommath.a -o ltmtest + +clean: + rm -f *.bat *.pdf *.o *.a *.obj *.lib *.exe *.dll etclib/*.o demo/demo.o test ltmtest mpitest mtest/mtest mtest/mtest.exe \ + *.idx *.toc *.log *.aux *.dvi *.lof *.ind *.ilg *.ps *.log *.s mpi.c *.il etc/*.il *.dyn + cd etc ; make clean + cd pics ; make clean ADDED libtommath/makefile.msvc Index: libtommath/makefile.msvc ================================================================== --- /dev/null +++ libtommath/makefile.msvc @@ -0,0 +1,40 @@ +#MSVC Makefile +# +#Tom St Denis + +CFLAGS = /I. /Ox /DWIN32 /W3 /Fo$@ + +default: library + +OBJECTS=bncore.obj bn_mp_init.obj bn_mp_clear.obj bn_mp_exch.obj bn_mp_grow.obj bn_mp_shrink.obj \ +bn_mp_clamp.obj bn_mp_zero.obj bn_mp_set.obj bn_mp_set_int.obj bn_mp_init_size.obj bn_mp_copy.obj \ +bn_mp_init_copy.obj bn_mp_abs.obj bn_mp_neg.obj bn_mp_cmp_mag.obj bn_mp_cmp.obj bn_mp_cmp_d.obj \ +bn_mp_rshd.obj bn_mp_lshd.obj bn_mp_mod_2d.obj bn_mp_div_2d.obj bn_mp_mul_2d.obj bn_mp_div_2.obj \ +bn_mp_mul_2.obj bn_s_mp_add.obj bn_s_mp_sub.obj bn_fast_s_mp_mul_digs.obj bn_s_mp_mul_digs.obj \ +bn_fast_s_mp_mul_high_digs.obj bn_s_mp_mul_high_digs.obj bn_fast_s_mp_sqr.obj bn_s_mp_sqr.obj \ +bn_mp_add.obj bn_mp_sub.obj bn_mp_karatsuba_mul.obj bn_mp_mul.obj bn_mp_karatsuba_sqr.obj \ +bn_mp_sqr.obj bn_mp_div.obj bn_mp_mod.obj bn_mp_add_d.obj bn_mp_sub_d.obj bn_mp_mul_d.obj \ +bn_mp_div_d.obj bn_mp_mod_d.obj bn_mp_expt_d.obj bn_mp_addmod.obj bn_mp_submod.obj \ +bn_mp_mulmod.obj bn_mp_sqrmod.obj bn_mp_gcd.obj bn_mp_lcm.obj bn_fast_mp_invmod.obj bn_mp_invmod.obj \ +bn_mp_reduce.obj bn_mp_montgomery_setup.obj bn_fast_mp_montgomery_reduce.obj bn_mp_montgomery_reduce.obj \ +bn_mp_exptmod_fast.obj bn_mp_exptmod.obj bn_mp_2expt.obj bn_mp_n_root.obj bn_mp_jacobi.obj bn_reverse.obj \ +bn_mp_count_bits.obj bn_mp_read_unsigned_bin.obj bn_mp_read_signed_bin.obj bn_mp_to_unsigned_bin.obj \ +bn_mp_to_signed_bin.obj bn_mp_unsigned_bin_size.obj bn_mp_signed_bin_size.obj \ +bn_mp_xor.obj bn_mp_and.obj bn_mp_or.obj bn_mp_rand.obj bn_mp_montgomery_calc_normalization.obj \ +bn_mp_prime_is_divisible.obj bn_prime_tab.obj bn_mp_prime_fermat.obj bn_mp_prime_miller_rabin.obj \ +bn_mp_prime_is_prime.obj bn_mp_prime_next_prime.obj bn_mp_dr_reduce.obj \ +bn_mp_dr_is_modulus.obj bn_mp_dr_setup.obj bn_mp_reduce_setup.obj \ +bn_mp_toom_mul.obj bn_mp_toom_sqr.obj bn_mp_div_3.obj bn_s_mp_exptmod.obj \ +bn_mp_reduce_2k.obj bn_mp_reduce_is_2k.obj bn_mp_reduce_2k_setup.obj \ +bn_mp_reduce_2k_l.obj bn_mp_reduce_is_2k_l.obj bn_mp_reduce_2k_setup_l.obj \ +bn_mp_radix_smap.obj bn_mp_read_radix.obj bn_mp_toradix.obj bn_mp_radix_size.obj \ +bn_mp_fread.obj bn_mp_fwrite.obj bn_mp_cnt_lsb.obj bn_error.obj \ +bn_mp_init_multi.obj bn_mp_clear_multi.obj bn_mp_exteuclid.obj bn_mp_toradix_n.obj \ +bn_mp_prime_random_ex.obj bn_mp_get_int.obj bn_mp_sqrt.obj bn_mp_is_square.obj \ +bn_mp_init_set.obj bn_mp_init_set_int.obj bn_mp_invmod_slow.obj bn_mp_prime_rabin_miller_trials.obj \ +bn_mp_to_signed_bin_n.obj bn_mp_to_unsigned_bin_n.obj + +HEADERS=tommath.h tommath_class.h tommath_superclass.h + +library: $(OBJECTS) + lib /out:tommath.lib $(OBJECTS) ADDED libtommath/makefile.shared Index: libtommath/makefile.shared ================================================================== --- /dev/null +++ libtommath/makefile.shared @@ -0,0 +1,99 @@ +#Makefile for GCC +# +#Tom St Denis +VERSION=0:36 + +CC = libtool --mode=compile gcc + +CFLAGS += -I./ -Wall -W -Wshadow -Wsign-compare + +ifndef IGNORE_SPEED + +#for speed +CFLAGS += -O3 -funroll-loops + +#for size +#CFLAGS += -Os + +#x86 optimizations [should be valid for any GCC install though] +CFLAGS += -fomit-frame-pointer + +endif + +#install as this user +ifndef INSTALL_GROUP + GROUP=wheel +else + GROUP=$(INSTALL_GROUP) +endif + +ifndef INSTALL_USER + USER=root +else + USER=$(INSTALL_USER) +endif + +default: libtommath.la + +#default files to install +ifndef LIBNAME + LIBNAME=libtommath.la +endif +ifndef LIBNAME_S + LIBNAME_S=libtommath.a +endif +HEADERS=tommath.h tommath_class.h tommath_superclass.h + +#LIBPATH-The directory for libtommath to be installed to. +#INCPATH-The directory to install the header files for libtommath. +#DATAPATH-The directory to install the pdf docs. +DESTDIR= +LIBPATH=/usr/lib +INCPATH=/usr/include +DATAPATH=/usr/share/doc/libtommath/pdf + +OBJECTS=bncore.o bn_mp_init.o bn_mp_clear.o bn_mp_exch.o bn_mp_grow.o bn_mp_shrink.o \ +bn_mp_clamp.o bn_mp_zero.o bn_mp_set.o bn_mp_set_int.o bn_mp_init_size.o bn_mp_copy.o \ +bn_mp_init_copy.o bn_mp_abs.o bn_mp_neg.o bn_mp_cmp_mag.o bn_mp_cmp.o bn_mp_cmp_d.o \ +bn_mp_rshd.o bn_mp_lshd.o bn_mp_mod_2d.o bn_mp_div_2d.o bn_mp_mul_2d.o bn_mp_div_2.o \ +bn_mp_mul_2.o bn_s_mp_add.o bn_s_mp_sub.o bn_fast_s_mp_mul_digs.o bn_s_mp_mul_digs.o \ +bn_fast_s_mp_mul_high_digs.o bn_s_mp_mul_high_digs.o bn_fast_s_mp_sqr.o bn_s_mp_sqr.o \ +bn_mp_add.o bn_mp_sub.o bn_mp_karatsuba_mul.o bn_mp_mul.o bn_mp_karatsuba_sqr.o \ +bn_mp_sqr.o bn_mp_div.o bn_mp_mod.o bn_mp_add_d.o bn_mp_sub_d.o bn_mp_mul_d.o \ +bn_mp_div_d.o bn_mp_mod_d.o bn_mp_expt_d.o bn_mp_addmod.o bn_mp_submod.o \ +bn_mp_mulmod.o bn_mp_sqrmod.o bn_mp_gcd.o bn_mp_lcm.o bn_fast_mp_invmod.o bn_mp_invmod.o \ +bn_mp_reduce.o bn_mp_montgomery_setup.o bn_fast_mp_montgomery_reduce.o bn_mp_montgomery_reduce.o \ +bn_mp_exptmod_fast.o bn_mp_exptmod.o bn_mp_2expt.o bn_mp_n_root.o bn_mp_jacobi.o bn_reverse.o \ +bn_mp_count_bits.o bn_mp_read_unsigned_bin.o bn_mp_read_signed_bin.o bn_mp_to_unsigned_bin.o \ +bn_mp_to_signed_bin.o bn_mp_unsigned_bin_size.o bn_mp_signed_bin_size.o \ +bn_mp_xor.o bn_mp_and.o bn_mp_or.o bn_mp_rand.o bn_mp_montgomery_calc_normalization.o \ +bn_mp_prime_is_divisible.o bn_prime_tab.o bn_mp_prime_fermat.o bn_mp_prime_miller_rabin.o \ +bn_mp_prime_is_prime.o bn_mp_prime_next_prime.o bn_mp_dr_reduce.o \ +bn_mp_dr_is_modulus.o bn_mp_dr_setup.o bn_mp_reduce_setup.o \ +bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_div_3.o bn_s_mp_exptmod.o \ +bn_mp_reduce_2k.o bn_mp_reduce_is_2k.o bn_mp_reduce_2k_setup.o \ +bn_mp_reduce_2k_l.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_2k_setup_l.o \ +bn_mp_radix_smap.o bn_mp_read_radix.o bn_mp_toradix.o bn_mp_radix_size.o \ +bn_mp_fread.o bn_mp_fwrite.o bn_mp_cnt_lsb.o bn_error.o \ +bn_mp_init_multi.o bn_mp_clear_multi.o bn_mp_exteuclid.o bn_mp_toradix_n.o \ +bn_mp_prime_random_ex.o bn_mp_get_int.o bn_mp_sqrt.o bn_mp_is_square.o bn_mp_init_set.o \ +bn_mp_init_set_int.o bn_mp_invmod_slow.o bn_mp_prime_rabin_miller_trials.o \ +bn_mp_to_signed_bin_n.o bn_mp_to_unsigned_bin_n.o + +$(LIBNAME): $(OBJECTS) + libtool --mode=link gcc *.lo -o $(LIBNAME) -rpath $(LIBPATH) -version-info $(VERSION) + libtool --mode=link gcc *.o -o $(LIBNAME_S) + ranlib $(LIBNAME_S) + libtool --mode=install install -c $(LIBNAME) $(LIBPATH)/$@ + install -d -g $(GROUP) -o $(USER) $(DESTDIR)$(INCPATH) + install -g $(GROUP) -o $(USER) $(HEADERS) $(DESTDIR)$(INCPATH) + +test: $(LIBNAME) demo/demo.o + gcc $(CFLAGS) -c demo/demo.c -o demo/demo.o + libtool --mode=link gcc -o test demo/demo.o $(LIBNAME_S) + +mtest: test + cd mtest ; gcc $(CFLAGS) mtest.c -o mtest + +timing: $(LIBNAME) + gcc $(CFLAGS) -DTIMER demo/timing.c $(LIBNAME_S) -o ltmtest ADDED libtommath/mess.sh Index: libtommath/mess.sh ================================================================== --- /dev/null +++ libtommath/mess.sh @@ -0,0 +1,4 @@ +#!/bin/bash +if cvs log $1 >/dev/null 2>/dev/null; then exit 0; else echo "$1 shouldn't be here" ; exit 1; fi + + ADDED libtommath/mtest/logtab.h Index: libtommath/mtest/logtab.h ================================================================== --- /dev/null +++ libtommath/mtest/logtab.h @@ -0,0 +1,24 @@ +const float s_logv_2[] = { + 0.000000000, 0.000000000, 1.000000000, 0.630929754, /* 0 1 2 3 */ + 0.500000000, 0.430676558, 0.386852807, 0.356207187, /* 4 5 6 7 */ + 0.333333333, 0.315464877, 0.301029996, 0.289064826, /* 8 9 10 11 */ + 0.278942946, 0.270238154, 0.262649535, 0.255958025, /* 12 13 14 15 */ + 0.250000000, 0.244650542, 0.239812467, 0.235408913, /* 16 17 18 19 */ + 0.231378213, 0.227670249, 0.224243824, 0.221064729, /* 20 21 22 23 */ + 0.218104292, 0.215338279, 0.212746054, 0.210309918, /* 24 25 26 27 */ + 0.208014598, 0.205846832, 0.203795047, 0.201849087, /* 28 29 30 31 */ + 0.200000000, 0.198239863, 0.196561632, 0.194959022, /* 32 33 34 35 */ + 0.193426404, 0.191958720, 0.190551412, 0.189200360, /* 36 37 38 39 */ + 0.187901825, 0.186652411, 0.185449023, 0.184288833, /* 40 41 42 43 */ + 0.183169251, 0.182087900, 0.181042597, 0.180031327, /* 44 45 46 47 */ + 0.179052232, 0.178103594, 0.177183820, 0.176291434, /* 48 49 50 51 */ + 0.175425064, 0.174583430, 0.173765343, 0.172969690, /* 52 53 54 55 */ + 0.172195434, 0.171441601, 0.170707280, 0.169991616, /* 56 57 58 59 */ + 0.169293808, 0.168613099, 0.167948779, 0.167300179, /* 60 61 62 63 */ + 0.166666667 +}; + + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/mtest/logtab.h,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/mtest/mpi-config.h Index: libtommath/mtest/mpi-config.h ================================================================== --- /dev/null +++ libtommath/mtest/mpi-config.h @@ -0,0 +1,90 @@ +/* Default configuration for MPI library */ +/* $Id: mpi-config.h,v 1.1.1.1.2.1 2005/09/26 20:16:54 kennykb Exp $ */ + +#ifndef MPI_CONFIG_H_ +#define MPI_CONFIG_H_ + +/* + For boolean options, + 0 = no + 1 = yes + + Other options are documented individually. + + */ + +#ifndef MP_IOFUNC +#define MP_IOFUNC 0 /* include mp_print() ? */ +#endif + +#ifndef MP_MODARITH +#define MP_MODARITH 1 /* include modular arithmetic ? */ +#endif + +#ifndef MP_NUMTH +#define MP_NUMTH 1 /* include number theoretic functions? */ +#endif + +#ifndef MP_LOGTAB +#define MP_LOGTAB 1 /* use table of logs instead of log()? */ +#endif + +#ifndef MP_MEMSET +#define MP_MEMSET 1 /* use memset() to zero buffers? */ +#endif + +#ifndef MP_MEMCPY +#define MP_MEMCPY 1 /* use memcpy() to copy buffers? */ +#endif + +#ifndef MP_CRYPTO +#define MP_CRYPTO 1 /* erase memory on free? */ +#endif + +#ifndef MP_ARGCHK +/* + 0 = no parameter checks + 1 = runtime checks, continue execution and return an error to caller + 2 = assertions; dump core on parameter errors + */ +#define MP_ARGCHK 2 /* how to check input arguments */ +#endif + +#ifndef MP_DEBUG +#define MP_DEBUG 0 /* print diagnostic output? */ +#endif + +#ifndef MP_DEFPREC +#define MP_DEFPREC 64 /* default precision, in digits */ +#endif + +#ifndef MP_MACRO +#define MP_MACRO 1 /* use macros for frequent calls? */ +#endif + +#ifndef MP_SQUARE +#define MP_SQUARE 1 /* use separate squaring code? */ +#endif + +#ifndef MP_PTAB_SIZE +/* + When building mpprime.c, we build in a table of small prime + values to use for primality testing. The more you include, + the more space they take up. See primes.c for the possible + values (currently 16, 32, 64, 128, 256, and 6542) + */ +#define MP_PTAB_SIZE 128 /* how many built-in primes? */ +#endif + +#ifndef MP_COMPAT_MACROS +#define MP_COMPAT_MACROS 1 /* define compatibility macros? */ +#endif + +#endif /* ifndef MPI_CONFIG_H_ */ + + +/* crc==3287762869, version==2, Sat Feb 02 06:43:53 2002 */ + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/mtest/mpi-config.h,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/mtest/mpi-types.h Index: libtommath/mtest/mpi-types.h ================================================================== --- /dev/null +++ libtommath/mtest/mpi-types.h @@ -0,0 +1,20 @@ +/* Type definitions generated by 'types.pl' */ +typedef char mp_sign; +typedef unsigned short mp_digit; /* 2 byte type */ +typedef unsigned int mp_word; /* 4 byte type */ +typedef unsigned int mp_size; +typedef int mp_err; + +#define MP_DIGIT_BIT (CHAR_BIT*sizeof(mp_digit)) +#define MP_DIGIT_MAX USHRT_MAX +#define MP_WORD_BIT (CHAR_BIT*sizeof(mp_word)) +#define MP_WORD_MAX UINT_MAX + +#define MP_DIGIT_SIZE 2 +#define DIGIT_FMT "%04X" +#define RADIX (MP_DIGIT_MAX+1) + + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/mtest/mpi-types.h,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/mtest/mpi.c Index: libtommath/mtest/mpi.c ================================================================== --- /dev/null +++ libtommath/mtest/mpi.c @@ -0,0 +1,3985 @@ +/* + mpi.c + + by Michael J. Fromberger + Copyright (C) 1998 Michael J. Fromberger, All Rights Reserved + + Arbitrary precision integer arithmetic library + + $Id: mpi.c,v 1.1.1.1.2.1 2005/09/26 20:16:54 kennykb Exp $ + */ + +#include "mpi.h" +#include +#include +#include + +#if MP_DEBUG +#include + +#define DIAG(T,V) {fprintf(stderr,T);mp_print(V,stderr);fputc('\n',stderr);} +#else +#define DIAG(T,V) +#endif + +/* + If MP_LOGTAB is not defined, use the math library to compute the + logarithms on the fly. Otherwise, use the static table below. + Pick which works best for your system. + */ +#if MP_LOGTAB + +/* {{{ s_logv_2[] - log table for 2 in various bases */ + +/* + A table of the logs of 2 for various bases (the 0 and 1 entries of + this table are meaningless and should not be referenced). + + This table is used to compute output lengths for the mp_toradix() + function. Since a number n in radix r takes up about log_r(n) + digits, we estimate the output size by taking the least integer + greater than log_r(n), where: + + log_r(n) = log_2(n) * log_r(2) + + This table, therefore, is a table of log_r(2) for 2 <= r <= 36, + which are the output bases supported. + */ + +#include "logtab.h" + +/* }}} */ +#define LOG_V_2(R) s_logv_2[(R)] + +#else + +#include +#define LOG_V_2(R) (log(2.0)/log(R)) + +#endif + +/* Default precision for newly created mp_int's */ +static unsigned int s_mp_defprec = MP_DEFPREC; + +/* {{{ Digit arithmetic macros */ + +/* + When adding and multiplying digits, the results can be larger than + can be contained in an mp_digit. Thus, an mp_word is used. These + macros mask off the upper and lower digits of the mp_word (the + mp_word may be more than 2 mp_digits wide, but we only concern + ourselves with the low-order 2 mp_digits) + + If your mp_word DOES have more than 2 mp_digits, you need to + uncomment the first line, and comment out the second. + */ + +/* #define CARRYOUT(W) (((W)>>DIGIT_BIT)&MP_DIGIT_MAX) */ +#define CARRYOUT(W) ((W)>>DIGIT_BIT) +#define ACCUM(W) ((W)&MP_DIGIT_MAX) + +/* }}} */ + +/* {{{ Comparison constants */ + +#define MP_LT -1 +#define MP_EQ 0 +#define MP_GT 1 + +/* }}} */ + +/* {{{ Constant strings */ + +/* Constant strings returned by mp_strerror() */ +static const char *mp_err_string[] = { + "unknown result code", /* say what? */ + "boolean true", /* MP_OKAY, MP_YES */ + "boolean false", /* MP_NO */ + "out of memory", /* MP_MEM */ + "argument out of range", /* MP_RANGE */ + "invalid input parameter", /* MP_BADARG */ + "result is undefined" /* MP_UNDEF */ +}; + +/* Value to digit maps for radix conversion */ + +/* s_dmap_1 - standard digits and letters */ +static const char *s_dmap_1 = + "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+/"; + +#if 0 +/* s_dmap_2 - base64 ordering for digits */ +static const char *s_dmap_2 = + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"; +#endif + +/* }}} */ + +/* {{{ Static function declarations */ + +/* + If MP_MACRO is false, these will be defined as actual functions; + otherwise, suitable macro definitions will be used. This works + around the fact that ANSI C89 doesn't support an 'inline' keyword + (although I hear C9x will ... about bloody time). At present, the + macro definitions are identical to the function bodies, but they'll + expand in place, instead of generating a function call. + + I chose these particular functions to be made into macros because + some profiling showed they are called a lot on a typical workload, + and yet they are primarily housekeeping. + */ +#if MP_MACRO == 0 + void s_mp_setz(mp_digit *dp, mp_size count); /* zero digits */ + void s_mp_copy(mp_digit *sp, mp_digit *dp, mp_size count); /* copy */ + void *s_mp_alloc(size_t nb, size_t ni); /* general allocator */ + void s_mp_free(void *ptr); /* general free function */ +#else + + /* Even if these are defined as macros, we need to respect the settings + of the MP_MEMSET and MP_MEMCPY configuration options... + */ + #if MP_MEMSET == 0 + #define s_mp_setz(dp, count) \ + {int ix;for(ix=0;ix<(count);ix++)(dp)[ix]=0;} + #else + #define s_mp_setz(dp, count) memset(dp, 0, (count) * sizeof(mp_digit)) + #endif /* MP_MEMSET */ + + #if MP_MEMCPY == 0 + #define s_mp_copy(sp, dp, count) \ + {int ix;for(ix=0;ix<(count);ix++)(dp)[ix]=(sp)[ix];} + #else + #define s_mp_copy(sp, dp, count) memcpy(dp, sp, (count) * sizeof(mp_digit)) + #endif /* MP_MEMCPY */ + + #define s_mp_alloc(nb, ni) calloc(nb, ni) + #define s_mp_free(ptr) {if(ptr) free(ptr);} +#endif /* MP_MACRO */ + +mp_err s_mp_grow(mp_int *mp, mp_size min); /* increase allocated size */ +mp_err s_mp_pad(mp_int *mp, mp_size min); /* left pad with zeroes */ + +void s_mp_clamp(mp_int *mp); /* clip leading zeroes */ + +void s_mp_exch(mp_int *a, mp_int *b); /* swap a and b in place */ + +mp_err s_mp_lshd(mp_int *mp, mp_size p); /* left-shift by p digits */ +void s_mp_rshd(mp_int *mp, mp_size p); /* right-shift by p digits */ +void s_mp_div_2d(mp_int *mp, mp_digit d); /* divide by 2^d in place */ +void s_mp_mod_2d(mp_int *mp, mp_digit d); /* modulo 2^d in place */ +mp_err s_mp_mul_2d(mp_int *mp, mp_digit d); /* multiply by 2^d in place*/ +void s_mp_div_2(mp_int *mp); /* divide by 2 in place */ +mp_err s_mp_mul_2(mp_int *mp); /* multiply by 2 in place */ +mp_digit s_mp_norm(mp_int *a, mp_int *b); /* normalize for division */ +mp_err s_mp_add_d(mp_int *mp, mp_digit d); /* unsigned digit addition */ +mp_err s_mp_sub_d(mp_int *mp, mp_digit d); /* unsigned digit subtract */ +mp_err s_mp_mul_d(mp_int *mp, mp_digit d); /* unsigned digit multiply */ +mp_err s_mp_div_d(mp_int *mp, mp_digit d, mp_digit *r); + /* unsigned digit divide */ +mp_err s_mp_reduce(mp_int *x, mp_int *m, mp_int *mu); + /* Barrett reduction */ +mp_err s_mp_add(mp_int *a, mp_int *b); /* magnitude addition */ +mp_err s_mp_sub(mp_int *a, mp_int *b); /* magnitude subtract */ +mp_err s_mp_mul(mp_int *a, mp_int *b); /* magnitude multiply */ +#if 0 +void s_mp_kmul(mp_digit *a, mp_digit *b, mp_digit *out, mp_size len); + /* multiply buffers in place */ +#endif +#if MP_SQUARE +mp_err s_mp_sqr(mp_int *a); /* magnitude square */ +#else +#define s_mp_sqr(a) s_mp_mul(a, a) +#endif +mp_err s_mp_div(mp_int *a, mp_int *b); /* magnitude divide */ +mp_err s_mp_2expt(mp_int *a, mp_digit k); /* a = 2^k */ +int s_mp_cmp(mp_int *a, mp_int *b); /* magnitude comparison */ +int s_mp_cmp_d(mp_int *a, mp_digit d); /* magnitude digit compare */ +int s_mp_ispow2(mp_int *v); /* is v a power of 2? */ +int s_mp_ispow2d(mp_digit d); /* is d a power of 2? */ + +int s_mp_tovalue(char ch, int r); /* convert ch to value */ +char s_mp_todigit(int val, int r, int low); /* convert val to digit */ +int s_mp_outlen(int bits, int r); /* output length in bytes */ + +/* }}} */ + +/* {{{ Default precision manipulation */ + +unsigned int mp_get_prec(void) +{ + return s_mp_defprec; + +} /* end mp_get_prec() */ + +void mp_set_prec(unsigned int prec) +{ + if(prec == 0) + s_mp_defprec = MP_DEFPREC; + else + s_mp_defprec = prec; + +} /* end mp_set_prec() */ + +/* }}} */ + +/*------------------------------------------------------------------------*/ +/* {{{ mp_init(mp) */ + +/* + mp_init(mp) + + Initialize a new zero-valued mp_int. Returns MP_OKAY if successful, + MP_MEM if memory could not be allocated for the structure. + */ + +mp_err mp_init(mp_int *mp) +{ + return mp_init_size(mp, s_mp_defprec); + +} /* end mp_init() */ + +/* }}} */ + +/* {{{ mp_init_array(mp[], count) */ + +mp_err mp_init_array(mp_int mp[], int count) +{ + mp_err res; + int pos; + + ARGCHK(mp !=NULL && count > 0, MP_BADARG); + + for(pos = 0; pos < count; ++pos) { + if((res = mp_init(&mp[pos])) != MP_OKAY) + goto CLEANUP; + } + + return MP_OKAY; + + CLEANUP: + while(--pos >= 0) + mp_clear(&mp[pos]); + + return res; + +} /* end mp_init_array() */ + +/* }}} */ + +/* {{{ mp_init_size(mp, prec) */ + +/* + mp_init_size(mp, prec) + + Initialize a new zero-valued mp_int with at least the given + precision; returns MP_OKAY if successful, or MP_MEM if memory could + not be allocated for the structure. + */ + +mp_err mp_init_size(mp_int *mp, mp_size prec) +{ + ARGCHK(mp != NULL && prec > 0, MP_BADARG); + + if((DIGITS(mp) = s_mp_alloc(prec, sizeof(mp_digit))) == NULL) + return MP_MEM; + + SIGN(mp) = MP_ZPOS; + USED(mp) = 1; + ALLOC(mp) = prec; + + return MP_OKAY; + +} /* end mp_init_size() */ + +/* }}} */ + +/* {{{ mp_init_copy(mp, from) */ + +/* + mp_init_copy(mp, from) + + Initialize mp as an exact copy of from. Returns MP_OKAY if + successful, MP_MEM if memory could not be allocated for the new + structure. + */ + +mp_err mp_init_copy(mp_int *mp, mp_int *from) +{ + ARGCHK(mp != NULL && from != NULL, MP_BADARG); + + if(mp == from) + return MP_OKAY; + + if((DIGITS(mp) = s_mp_alloc(USED(from), sizeof(mp_digit))) == NULL) + return MP_MEM; + + s_mp_copy(DIGITS(from), DIGITS(mp), USED(from)); + USED(mp) = USED(from); + ALLOC(mp) = USED(from); + SIGN(mp) = SIGN(from); + + return MP_OKAY; + +} /* end mp_init_copy() */ + +/* }}} */ + +/* {{{ mp_copy(from, to) */ + +/* + mp_copy(from, to) + + Copies the mp_int 'from' to the mp_int 'to'. It is presumed that + 'to' has already been initialized (if not, use mp_init_copy() + instead). If 'from' and 'to' are identical, nothing happens. + */ + +mp_err mp_copy(mp_int *from, mp_int *to) +{ + ARGCHK(from != NULL && to != NULL, MP_BADARG); + + if(from == to) + return MP_OKAY; + + { /* copy */ + mp_digit *tmp; + + /* + If the allocated buffer in 'to' already has enough space to hold + all the used digits of 'from', we'll re-use it to avoid hitting + the memory allocater more than necessary; otherwise, we'd have + to grow anyway, so we just allocate a hunk and make the copy as + usual + */ + if(ALLOC(to) >= USED(from)) { + s_mp_setz(DIGITS(to) + USED(from), ALLOC(to) - USED(from)); + s_mp_copy(DIGITS(from), DIGITS(to), USED(from)); + + } else { + if((tmp = s_mp_alloc(USED(from), sizeof(mp_digit))) == NULL) + return MP_MEM; + + s_mp_copy(DIGITS(from), tmp, USED(from)); + + if(DIGITS(to) != NULL) { +#if MP_CRYPTO + s_mp_setz(DIGITS(to), ALLOC(to)); +#endif + s_mp_free(DIGITS(to)); + } + + DIGITS(to) = tmp; + ALLOC(to) = USED(from); + } + + /* Copy the precision and sign from the original */ + USED(to) = USED(from); + SIGN(to) = SIGN(from); + } /* end copy */ + + return MP_OKAY; + +} /* end mp_copy() */ + +/* }}} */ + +/* {{{ mp_exch(mp1, mp2) */ + +/* + mp_exch(mp1, mp2) + + Exchange mp1 and mp2 without allocating any intermediate memory + (well, unless you count the stack space needed for this call and the + locals it creates...). This cannot fail. + */ + +void mp_exch(mp_int *mp1, mp_int *mp2) +{ +#if MP_ARGCHK == 2 + assert(mp1 != NULL && mp2 != NULL); +#else + if(mp1 == NULL || mp2 == NULL) + return; +#endif + + s_mp_exch(mp1, mp2); + +} /* end mp_exch() */ + +/* }}} */ + +/* {{{ mp_clear(mp) */ + +/* + mp_clear(mp) + + Release the storage used by an mp_int, and void its fields so that + if someone calls mp_clear() again for the same int later, we won't + get tollchocked. + */ + +void mp_clear(mp_int *mp) +{ + if(mp == NULL) + return; + + if(DIGITS(mp) != NULL) { +#if MP_CRYPTO + s_mp_setz(DIGITS(mp), ALLOC(mp)); +#endif + s_mp_free(DIGITS(mp)); + DIGITS(mp) = NULL; + } + + USED(mp) = 0; + ALLOC(mp) = 0; + +} /* end mp_clear() */ + +/* }}} */ + +/* {{{ mp_clear_array(mp[], count) */ + +void mp_clear_array(mp_int mp[], int count) +{ + ARGCHK(mp != NULL && count > 0, MP_BADARG); + + while(--count >= 0) + mp_clear(&mp[count]); + +} /* end mp_clear_array() */ + +/* }}} */ + +/* {{{ mp_zero(mp) */ + +/* + mp_zero(mp) + + Set mp to zero. Does not change the allocated size of the structure, + and therefore cannot fail (except on a bad argument, which we ignore) + */ +void mp_zero(mp_int *mp) +{ + if(mp == NULL) + return; + + s_mp_setz(DIGITS(mp), ALLOC(mp)); + USED(mp) = 1; + SIGN(mp) = MP_ZPOS; + +} /* end mp_zero() */ + +/* }}} */ + +/* {{{ mp_set(mp, d) */ + +void mp_set(mp_int *mp, mp_digit d) +{ + if(mp == NULL) + return; + + mp_zero(mp); + DIGIT(mp, 0) = d; + +} /* end mp_set() */ + +/* }}} */ + +/* {{{ mp_set_int(mp, z) */ + +mp_err mp_set_int(mp_int *mp, long z) +{ + int ix; + unsigned long v = abs(z); + mp_err res; + + ARGCHK(mp != NULL, MP_BADARG); + + mp_zero(mp); + if(z == 0) + return MP_OKAY; /* shortcut for zero */ + + for(ix = sizeof(long) - 1; ix >= 0; ix--) { + + if((res = s_mp_mul_2d(mp, CHAR_BIT)) != MP_OKAY) + return res; + + res = s_mp_add_d(mp, + (mp_digit)((v >> (ix * CHAR_BIT)) & UCHAR_MAX)); + if(res != MP_OKAY) + return res; + + } + + if(z < 0) + SIGN(mp) = MP_NEG; + + return MP_OKAY; + +} /* end mp_set_int() */ + +/* }}} */ + +/*------------------------------------------------------------------------*/ +/* {{{ Digit arithmetic */ + +/* {{{ mp_add_d(a, d, b) */ + +/* + mp_add_d(a, d, b) + + Compute the sum b = a + d, for a single digit d. Respects the sign of + its primary addend (single digits are unsigned anyway). + */ + +mp_err mp_add_d(mp_int *a, mp_digit d, mp_int *b) +{ + mp_err res = MP_OKAY; + + ARGCHK(a != NULL && b != NULL, MP_BADARG); + + if((res = mp_copy(a, b)) != MP_OKAY) + return res; + + if(SIGN(b) == MP_ZPOS) { + res = s_mp_add_d(b, d); + } else if(s_mp_cmp_d(b, d) >= 0) { + res = s_mp_sub_d(b, d); + } else { + SIGN(b) = MP_ZPOS; + + DIGIT(b, 0) = d - DIGIT(b, 0); + } + + return res; + +} /* end mp_add_d() */ + +/* }}} */ + +/* {{{ mp_sub_d(a, d, b) */ + +/* + mp_sub_d(a, d, b) + + Compute the difference b = a - d, for a single digit d. Respects the + sign of its subtrahend (single digits are unsigned anyway). + */ + +mp_err mp_sub_d(mp_int *a, mp_digit d, mp_int *b) +{ + mp_err res; + + ARGCHK(a != NULL && b != NULL, MP_BADARG); + + if((res = mp_copy(a, b)) != MP_OKAY) + return res; + + if(SIGN(b) == MP_NEG) { + if((res = s_mp_add_d(b, d)) != MP_OKAY) + return res; + + } else if(s_mp_cmp_d(b, d) >= 0) { + if((res = s_mp_sub_d(b, d)) != MP_OKAY) + return res; + + } else { + mp_neg(b, b); + + DIGIT(b, 0) = d - DIGIT(b, 0); + SIGN(b) = MP_NEG; + } + + if(s_mp_cmp_d(b, 0) == 0) + SIGN(b) = MP_ZPOS; + + return MP_OKAY; + +} /* end mp_sub_d() */ + +/* }}} */ + +/* {{{ mp_mul_d(a, d, b) */ + +/* + mp_mul_d(a, d, b) + + Compute the product b = a * d, for a single digit d. Respects the sign + of its multiplicand (single digits are unsigned anyway) + */ + +mp_err mp_mul_d(mp_int *a, mp_digit d, mp_int *b) +{ + mp_err res; + + ARGCHK(a != NULL && b != NULL, MP_BADARG); + + if(d == 0) { + mp_zero(b); + return MP_OKAY; + } + + if((res = mp_copy(a, b)) != MP_OKAY) + return res; + + res = s_mp_mul_d(b, d); + + return res; + +} /* end mp_mul_d() */ + +/* }}} */ + +/* {{{ mp_mul_2(a, c) */ + +mp_err mp_mul_2(mp_int *a, mp_int *c) +{ + mp_err res; + + ARGCHK(a != NULL && c != NULL, MP_BADARG); + + if((res = mp_copy(a, c)) != MP_OKAY) + return res; + + return s_mp_mul_2(c); + +} /* end mp_mul_2() */ + +/* }}} */ + +/* {{{ mp_div_d(a, d, q, r) */ + +/* + mp_div_d(a, d, q, r) + + Compute the quotient q = a / d and remainder r = a mod d, for a + single digit d. Respects the sign of its divisor (single digits are + unsigned anyway). + */ + +mp_err mp_div_d(mp_int *a, mp_digit d, mp_int *q, mp_digit *r) +{ + mp_err res; + mp_digit rem; + int pow; + + ARGCHK(a != NULL, MP_BADARG); + + if(d == 0) + return MP_RANGE; + + /* Shortcut for powers of two ... */ + if((pow = s_mp_ispow2d(d)) >= 0) { + mp_digit mask; + + mask = (1 << pow) - 1; + rem = DIGIT(a, 0) & mask; + + if(q) { + mp_copy(a, q); + s_mp_div_2d(q, pow); + } + + if(r) + *r = rem; + + return MP_OKAY; + } + + /* + If the quotient is actually going to be returned, we'll try to + avoid hitting the memory allocator by copying the dividend into it + and doing the division there. This can't be any _worse_ than + always copying, and will sometimes be better (since it won't make + another copy) + + If it's not going to be returned, we need to allocate a temporary + to hold the quotient, which will just be discarded. + */ + if(q) { + if((res = mp_copy(a, q)) != MP_OKAY) + return res; + + res = s_mp_div_d(q, d, &rem); + if(s_mp_cmp_d(q, 0) == MP_EQ) + SIGN(q) = MP_ZPOS; + + } else { + mp_int qp; + + if((res = mp_init_copy(&qp, a)) != MP_OKAY) + return res; + + res = s_mp_div_d(&qp, d, &rem); + if(s_mp_cmp_d(&qp, 0) == 0) + SIGN(&qp) = MP_ZPOS; + + mp_clear(&qp); + } + + if(r) + *r = rem; + + return res; + +} /* end mp_div_d() */ + +/* }}} */ + +/* {{{ mp_div_2(a, c) */ + +/* + mp_div_2(a, c) + + Compute c = a / 2, disregarding the remainder. + */ + +mp_err mp_div_2(mp_int *a, mp_int *c) +{ + mp_err res; + + ARGCHK(a != NULL && c != NULL, MP_BADARG); + + if((res = mp_copy(a, c)) != MP_OKAY) + return res; + + s_mp_div_2(c); + + return MP_OKAY; + +} /* end mp_div_2() */ + +/* }}} */ + +/* {{{ mp_expt_d(a, d, b) */ + +mp_err mp_expt_d(mp_int *a, mp_digit d, mp_int *c) +{ + mp_int s, x; + mp_err res; + + ARGCHK(a != NULL && c != NULL, MP_BADARG); + + if((res = mp_init(&s)) != MP_OKAY) + return res; + if((res = mp_init_copy(&x, a)) != MP_OKAY) + goto X; + + DIGIT(&s, 0) = 1; + + while(d != 0) { + if(d & 1) { + if((res = s_mp_mul(&s, &x)) != MP_OKAY) + goto CLEANUP; + } + + d >>= 1; + + if((res = s_mp_sqr(&x)) != MP_OKAY) + goto CLEANUP; + } + + s_mp_exch(&s, c); + +CLEANUP: + mp_clear(&x); +X: + mp_clear(&s); + + return res; + +} /* end mp_expt_d() */ + +/* }}} */ + +/* }}} */ + +/*------------------------------------------------------------------------*/ +/* {{{ Full arithmetic */ + +/* {{{ mp_abs(a, b) */ + +/* + mp_abs(a, b) + + Compute b = |a|. 'a' and 'b' may be identical. + */ + +mp_err mp_abs(mp_int *a, mp_int *b) +{ + mp_err res; + + ARGCHK(a != NULL && b != NULL, MP_BADARG); + + if((res = mp_copy(a, b)) != MP_OKAY) + return res; + + SIGN(b) = MP_ZPOS; + + return MP_OKAY; + +} /* end mp_abs() */ + +/* }}} */ + +/* {{{ mp_neg(a, b) */ + +/* + mp_neg(a, b) + + Compute b = -a. 'a' and 'b' may be identical. + */ + +mp_err mp_neg(mp_int *a, mp_int *b) +{ + mp_err res; + + ARGCHK(a != NULL && b != NULL, MP_BADARG); + + if((res = mp_copy(a, b)) != MP_OKAY) + return res; + + if(s_mp_cmp_d(b, 0) == MP_EQ) + SIGN(b) = MP_ZPOS; + else + SIGN(b) = (SIGN(b) == MP_NEG) ? MP_ZPOS : MP_NEG; + + return MP_OKAY; + +} /* end mp_neg() */ + +/* }}} */ + +/* {{{ mp_add(a, b, c) */ + +/* + mp_add(a, b, c) + + Compute c = a + b. All parameters may be identical. + */ + +mp_err mp_add(mp_int *a, mp_int *b, mp_int *c) +{ + mp_err res; + int cmp; + + ARGCHK(a != NULL && b != NULL && c != NULL, MP_BADARG); + + if(SIGN(a) == SIGN(b)) { /* same sign: add values, keep sign */ + + /* Commutativity of addition lets us do this in either order, + so we avoid having to use a temporary even if the result + is supposed to replace the output + */ + if(c == b) { + if((res = s_mp_add(c, a)) != MP_OKAY) + return res; + } else { + if(c != a && (res = mp_copy(a, c)) != MP_OKAY) + return res; + + if((res = s_mp_add(c, b)) != MP_OKAY) + return res; + } + + } else if((cmp = s_mp_cmp(a, b)) > 0) { /* different sign: a > b */ + + /* If the output is going to be clobbered, we will use a temporary + variable; otherwise, we'll do it without touching the memory + allocator at all, if possible + */ + if(c == b) { + mp_int tmp; + + if((res = mp_init_copy(&tmp, a)) != MP_OKAY) + return res; + if((res = s_mp_sub(&tmp, b)) != MP_OKAY) { + mp_clear(&tmp); + return res; + } + + s_mp_exch(&tmp, c); + mp_clear(&tmp); + + } else { + + if(c != a && (res = mp_copy(a, c)) != MP_OKAY) + return res; + if((res = s_mp_sub(c, b)) != MP_OKAY) + return res; + + } + + } else if(cmp == 0) { /* different sign, a == b */ + + mp_zero(c); + return MP_OKAY; + + } else { /* different sign: a < b */ + + /* See above... */ + if(c == a) { + mp_int tmp; + + if((res = mp_init_copy(&tmp, b)) != MP_OKAY) + return res; + if((res = s_mp_sub(&tmp, a)) != MP_OKAY) { + mp_clear(&tmp); + return res; + } + + s_mp_exch(&tmp, c); + mp_clear(&tmp); + + } else { + + if(c != b && (res = mp_copy(b, c)) != MP_OKAY) + return res; + if((res = s_mp_sub(c, a)) != MP_OKAY) + return res; + + } + } + + if(USED(c) == 1 && DIGIT(c, 0) == 0) + SIGN(c) = MP_ZPOS; + + return MP_OKAY; + +} /* end mp_add() */ + +/* }}} */ + +/* {{{ mp_sub(a, b, c) */ + +/* + mp_sub(a, b, c) + + Compute c = a - b. All parameters may be identical. + */ + +mp_err mp_sub(mp_int *a, mp_int *b, mp_int *c) +{ + mp_err res; + int cmp; + + ARGCHK(a != NULL && b != NULL && c != NULL, MP_BADARG); + + if(SIGN(a) != SIGN(b)) { + if(c == a) { + if((res = s_mp_add(c, b)) != MP_OKAY) + return res; + } else { + if(c != b && ((res = mp_copy(b, c)) != MP_OKAY)) + return res; + if((res = s_mp_add(c, a)) != MP_OKAY) + return res; + SIGN(c) = SIGN(a); + } + + } else if((cmp = s_mp_cmp(a, b)) > 0) { /* Same sign, a > b */ + if(c == b) { + mp_int tmp; + + if((res = mp_init_copy(&tmp, a)) != MP_OKAY) + return res; + if((res = s_mp_sub(&tmp, b)) != MP_OKAY) { + mp_clear(&tmp); + return res; + } + s_mp_exch(&tmp, c); + mp_clear(&tmp); + + } else { + if(c != a && ((res = mp_copy(a, c)) != MP_OKAY)) + return res; + + if((res = s_mp_sub(c, b)) != MP_OKAY) + return res; + } + + } else if(cmp == 0) { /* Same sign, equal magnitude */ + mp_zero(c); + return MP_OKAY; + + } else { /* Same sign, b > a */ + if(c == a) { + mp_int tmp; + + if((res = mp_init_copy(&tmp, b)) != MP_OKAY) + return res; + + if((res = s_mp_sub(&tmp, a)) != MP_OKAY) { + mp_clear(&tmp); + return res; + } + s_mp_exch(&tmp, c); + mp_clear(&tmp); + + } else { + if(c != b && ((res = mp_copy(b, c)) != MP_OKAY)) + return res; + + if((res = s_mp_sub(c, a)) != MP_OKAY) + return res; + } + + SIGN(c) = !SIGN(b); + } + + if(USED(c) == 1 && DIGIT(c, 0) == 0) + SIGN(c) = MP_ZPOS; + + return MP_OKAY; + +} /* end mp_sub() */ + +/* }}} */ + +/* {{{ mp_mul(a, b, c) */ + +/* + mp_mul(a, b, c) + + Compute c = a * b. All parameters may be identical. + */ + +mp_err mp_mul(mp_int *a, mp_int *b, mp_int *c) +{ + mp_err res; + mp_sign sgn; + + ARGCHK(a != NULL && b != NULL && c != NULL, MP_BADARG); + + sgn = (SIGN(a) == SIGN(b)) ? MP_ZPOS : MP_NEG; + + if(c == b) { + if((res = s_mp_mul(c, a)) != MP_OKAY) + return res; + + } else { + if((res = mp_copy(a, c)) != MP_OKAY) + return res; + + if((res = s_mp_mul(c, b)) != MP_OKAY) + return res; + } + + if(sgn == MP_ZPOS || s_mp_cmp_d(c, 0) == MP_EQ) + SIGN(c) = MP_ZPOS; + else + SIGN(c) = sgn; + + return MP_OKAY; + +} /* end mp_mul() */ + +/* }}} */ + +/* {{{ mp_mul_2d(a, d, c) */ + +/* + mp_mul_2d(a, d, c) + + Compute c = a * 2^d. a may be the same as c. + */ + +mp_err mp_mul_2d(mp_int *a, mp_digit d, mp_int *c) +{ + mp_err res; + + ARGCHK(a != NULL && c != NULL, MP_BADARG); + + if((res = mp_copy(a, c)) != MP_OKAY) + return res; + + if(d == 0) + return MP_OKAY; + + return s_mp_mul_2d(c, d); + +} /* end mp_mul() */ + +/* }}} */ + +/* {{{ mp_sqr(a, b) */ + +#if MP_SQUARE +mp_err mp_sqr(mp_int *a, mp_int *b) +{ + mp_err res; + + ARGCHK(a != NULL && b != NULL, MP_BADARG); + + if((res = mp_copy(a, b)) != MP_OKAY) + return res; + + if((res = s_mp_sqr(b)) != MP_OKAY) + return res; + + SIGN(b) = MP_ZPOS; + + return MP_OKAY; + +} /* end mp_sqr() */ +#endif + +/* }}} */ + +/* {{{ mp_div(a, b, q, r) */ + +/* + mp_div(a, b, q, r) + + Compute q = a / b and r = a mod b. Input parameters may be re-used + as output parameters. If q or r is NULL, that portion of the + computation will be discarded (although it will still be computed) + + Pay no attention to the hacker behind the curtain. + */ + +mp_err mp_div(mp_int *a, mp_int *b, mp_int *q, mp_int *r) +{ + mp_err res; + mp_int qtmp, rtmp; + int cmp; + + ARGCHK(a != NULL && b != NULL, MP_BADARG); + + if(mp_cmp_z(b) == MP_EQ) + return MP_RANGE; + + /* If a <= b, we can compute the solution without division, and + avoid any memory allocation + */ + if((cmp = s_mp_cmp(a, b)) < 0) { + if(r) { + if((res = mp_copy(a, r)) != MP_OKAY) + return res; + } + + if(q) + mp_zero(q); + + return MP_OKAY; + + } else if(cmp == 0) { + + /* Set quotient to 1, with appropriate sign */ + if(q) { + int qneg = (SIGN(a) != SIGN(b)); + + mp_set(q, 1); + if(qneg) + SIGN(q) = MP_NEG; + } + + if(r) + mp_zero(r); + + return MP_OKAY; + } + + /* If we get here, it means we actually have to do some division */ + + /* Set up some temporaries... */ + if((res = mp_init_copy(&qtmp, a)) != MP_OKAY) + return res; + if((res = mp_init_copy(&rtmp, b)) != MP_OKAY) + goto CLEANUP; + + if((res = s_mp_div(&qtmp, &rtmp)) != MP_OKAY) + goto CLEANUP; + + /* Compute the signs for the output */ + SIGN(&rtmp) = SIGN(a); /* Sr = Sa */ + if(SIGN(a) == SIGN(b)) + SIGN(&qtmp) = MP_ZPOS; /* Sq = MP_ZPOS if Sa = Sb */ + else + SIGN(&qtmp) = MP_NEG; /* Sq = MP_NEG if Sa != Sb */ + + if(s_mp_cmp_d(&qtmp, 0) == MP_EQ) + SIGN(&qtmp) = MP_ZPOS; + if(s_mp_cmp_d(&rtmp, 0) == MP_EQ) + SIGN(&rtmp) = MP_ZPOS; + + /* Copy output, if it is needed */ + if(q) + s_mp_exch(&qtmp, q); + + if(r) + s_mp_exch(&rtmp, r); + +CLEANUP: + mp_clear(&rtmp); + mp_clear(&qtmp); + + return res; + +} /* end mp_div() */ + +/* }}} */ + +/* {{{ mp_div_2d(a, d, q, r) */ + +mp_err mp_div_2d(mp_int *a, mp_digit d, mp_int *q, mp_int *r) +{ + mp_err res; + + ARGCHK(a != NULL, MP_BADARG); + + if(q) { + if((res = mp_copy(a, q)) != MP_OKAY) + return res; + + s_mp_div_2d(q, d); + } + + if(r) { + if((res = mp_copy(a, r)) != MP_OKAY) + return res; + + s_mp_mod_2d(r, d); + } + + return MP_OKAY; + +} /* end mp_div_2d() */ + +/* }}} */ + +/* {{{ mp_expt(a, b, c) */ + +/* + mp_expt(a, b, c) + + Compute c = a ** b, that is, raise a to the b power. Uses a + standard iterative square-and-multiply technique. + */ + +mp_err mp_expt(mp_int *a, mp_int *b, mp_int *c) +{ + mp_int s, x; + mp_err res; + mp_digit d; + int dig, bit; + + ARGCHK(a != NULL && b != NULL && c != NULL, MP_BADARG); + + if(mp_cmp_z(b) < 0) + return MP_RANGE; + + if((res = mp_init(&s)) != MP_OKAY) + return res; + + mp_set(&s, 1); + + if((res = mp_init_copy(&x, a)) != MP_OKAY) + goto X; + + /* Loop over low-order digits in ascending order */ + for(dig = 0; dig < (USED(b) - 1); dig++) { + d = DIGIT(b, dig); + + /* Loop over bits of each non-maximal digit */ + for(bit = 0; bit < DIGIT_BIT; bit++) { + if(d & 1) { + if((res = s_mp_mul(&s, &x)) != MP_OKAY) + goto CLEANUP; + } + + d >>= 1; + + if((res = s_mp_sqr(&x)) != MP_OKAY) + goto CLEANUP; + } + } + + /* Consider now the last digit... */ + d = DIGIT(b, dig); + + while(d) { + if(d & 1) { + if((res = s_mp_mul(&s, &x)) != MP_OKAY) + goto CLEANUP; + } + + d >>= 1; + + if((res = s_mp_sqr(&x)) != MP_OKAY) + goto CLEANUP; + } + + if(mp_iseven(b)) + SIGN(&s) = SIGN(a); + + res = mp_copy(&s, c); + +CLEANUP: + mp_clear(&x); +X: + mp_clear(&s); + + return res; + +} /* end mp_expt() */ + +/* }}} */ + +/* {{{ mp_2expt(a, k) */ + +/* Compute a = 2^k */ + +mp_err mp_2expt(mp_int *a, mp_digit k) +{ + ARGCHK(a != NULL, MP_BADARG); + + return s_mp_2expt(a, k); + +} /* end mp_2expt() */ + +/* }}} */ + +/* {{{ mp_mod(a, m, c) */ + +/* + mp_mod(a, m, c) + + Compute c = a (mod m). Result will always be 0 <= c < m. + */ + +mp_err mp_mod(mp_int *a, mp_int *m, mp_int *c) +{ + mp_err res; + int mag; + + ARGCHK(a != NULL && m != NULL && c != NULL, MP_BADARG); + + if(SIGN(m) == MP_NEG) + return MP_RANGE; + + /* + If |a| > m, we need to divide to get the remainder and take the + absolute value. + + If |a| < m, we don't need to do any division, just copy and adjust + the sign (if a is negative). + + If |a| == m, we can simply set the result to zero. + + This order is intended to minimize the average path length of the + comparison chain on common workloads -- the most frequent cases are + that |a| != m, so we do those first. + */ + if((mag = s_mp_cmp(a, m)) > 0) { + if((res = mp_div(a, m, NULL, c)) != MP_OKAY) + return res; + + if(SIGN(c) == MP_NEG) { + if((res = mp_add(c, m, c)) != MP_OKAY) + return res; + } + + } else if(mag < 0) { + if((res = mp_copy(a, c)) != MP_OKAY) + return res; + + if(mp_cmp_z(a) < 0) { + if((res = mp_add(c, m, c)) != MP_OKAY) + return res; + + } + + } else { + mp_zero(c); + + } + + return MP_OKAY; + +} /* end mp_mod() */ + +/* }}} */ + +/* {{{ mp_mod_d(a, d, c) */ + +/* + mp_mod_d(a, d, c) + + Compute c = a (mod d). Result will always be 0 <= c < d + */ +mp_err mp_mod_d(mp_int *a, mp_digit d, mp_digit *c) +{ + mp_err res; + mp_digit rem; + + ARGCHK(a != NULL && c != NULL, MP_BADARG); + + if(s_mp_cmp_d(a, d) > 0) { + if((res = mp_div_d(a, d, NULL, &rem)) != MP_OKAY) + return res; + + } else { + if(SIGN(a) == MP_NEG) + rem = d - DIGIT(a, 0); + else + rem = DIGIT(a, 0); + } + + if(c) + *c = rem; + + return MP_OKAY; + +} /* end mp_mod_d() */ + +/* }}} */ + +/* {{{ mp_sqrt(a, b) */ + +/* + mp_sqrt(a, b) + + Compute the integer square root of a, and store the result in b. + Uses an integer-arithmetic version of Newton's iterative linear + approximation technique to determine this value; the result has the + following two properties: + + b^2 <= a + (b+1)^2 >= a + + It is a range error to pass a negative value. + */ +mp_err mp_sqrt(mp_int *a, mp_int *b) +{ + mp_int x, t; + mp_err res; + + ARGCHK(a != NULL && b != NULL, MP_BADARG); + + /* Cannot take square root of a negative value */ + if(SIGN(a) == MP_NEG) + return MP_RANGE; + + /* Special cases for zero and one, trivial */ + if(mp_cmp_d(a, 0) == MP_EQ || mp_cmp_d(a, 1) == MP_EQ) + return mp_copy(a, b); + + /* Initialize the temporaries we'll use below */ + if((res = mp_init_size(&t, USED(a))) != MP_OKAY) + return res; + + /* Compute an initial guess for the iteration as a itself */ + if((res = mp_init_copy(&x, a)) != MP_OKAY) + goto X; + +s_mp_rshd(&x, (USED(&x)/2)+1); +mp_add_d(&x, 1, &x); + + for(;;) { + /* t = (x * x) - a */ + mp_copy(&x, &t); /* can't fail, t is big enough for original x */ + if((res = mp_sqr(&t, &t)) != MP_OKAY || + (res = mp_sub(&t, a, &t)) != MP_OKAY) + goto CLEANUP; + + /* t = t / 2x */ + s_mp_mul_2(&x); + if((res = mp_div(&t, &x, &t, NULL)) != MP_OKAY) + goto CLEANUP; + s_mp_div_2(&x); + + /* Terminate the loop, if the quotient is zero */ + if(mp_cmp_z(&t) == MP_EQ) + break; + + /* x = x - t */ + if((res = mp_sub(&x, &t, &x)) != MP_OKAY) + goto CLEANUP; + + } + + /* Copy result to output parameter */ + mp_sub_d(&x, 1, &x); + s_mp_exch(&x, b); + + CLEANUP: + mp_clear(&x); + X: + mp_clear(&t); + + return res; + +} /* end mp_sqrt() */ + +/* }}} */ + +/* }}} */ + +/*------------------------------------------------------------------------*/ +/* {{{ Modular arithmetic */ + +#if MP_MODARITH +/* {{{ mp_addmod(a, b, m, c) */ + +/* + mp_addmod(a, b, m, c) + + Compute c = (a + b) mod m + */ + +mp_err mp_addmod(mp_int *a, mp_int *b, mp_int *m, mp_int *c) +{ + mp_err res; + + ARGCHK(a != NULL && b != NULL && m != NULL && c != NULL, MP_BADARG); + + if((res = mp_add(a, b, c)) != MP_OKAY) + return res; + if((res = mp_mod(c, m, c)) != MP_OKAY) + return res; + + return MP_OKAY; + +} + +/* }}} */ + +/* {{{ mp_submod(a, b, m, c) */ + +/* + mp_submod(a, b, m, c) + + Compute c = (a - b) mod m + */ + +mp_err mp_submod(mp_int *a, mp_int *b, mp_int *m, mp_int *c) +{ + mp_err res; + + ARGCHK(a != NULL && b != NULL && m != NULL && c != NULL, MP_BADARG); + + if((res = mp_sub(a, b, c)) != MP_OKAY) + return res; + if((res = mp_mod(c, m, c)) != MP_OKAY) + return res; + + return MP_OKAY; + +} + +/* }}} */ + +/* {{{ mp_mulmod(a, b, m, c) */ + +/* + mp_mulmod(a, b, m, c) + + Compute c = (a * b) mod m + */ + +mp_err mp_mulmod(mp_int *a, mp_int *b, mp_int *m, mp_int *c) +{ + mp_err res; + + ARGCHK(a != NULL && b != NULL && m != NULL && c != NULL, MP_BADARG); + + if((res = mp_mul(a, b, c)) != MP_OKAY) + return res; + if((res = mp_mod(c, m, c)) != MP_OKAY) + return res; + + return MP_OKAY; + +} + +/* }}} */ + +/* {{{ mp_sqrmod(a, m, c) */ + +#if MP_SQUARE +mp_err mp_sqrmod(mp_int *a, mp_int *m, mp_int *c) +{ + mp_err res; + + ARGCHK(a != NULL && m != NULL && c != NULL, MP_BADARG); + + if((res = mp_sqr(a, c)) != MP_OKAY) + return res; + if((res = mp_mod(c, m, c)) != MP_OKAY) + return res; + + return MP_OKAY; + +} /* end mp_sqrmod() */ +#endif + +/* }}} */ + +/* {{{ mp_exptmod(a, b, m, c) */ + +/* + mp_exptmod(a, b, m, c) + + Compute c = (a ** b) mod m. Uses a standard square-and-multiply + method with modular reductions at each step. (This is basically the + same code as mp_expt(), except for the addition of the reductions) + + The modular reductions are done using Barrett's algorithm (see + s_mp_reduce() below for details) + */ + +mp_err mp_exptmod(mp_int *a, mp_int *b, mp_int *m, mp_int *c) +{ + mp_int s, x, mu; + mp_err res; + mp_digit d, *db = DIGITS(b); + mp_size ub = USED(b); + int dig, bit; + + ARGCHK(a != NULL && b != NULL && c != NULL, MP_BADARG); + + if(mp_cmp_z(b) < 0 || mp_cmp_z(m) <= 0) + return MP_RANGE; + + if((res = mp_init(&s)) != MP_OKAY) + return res; + if((res = mp_init_copy(&x, a)) != MP_OKAY) + goto X; + if((res = mp_mod(&x, m, &x)) != MP_OKAY || + (res = mp_init(&mu)) != MP_OKAY) + goto MU; + + mp_set(&s, 1); + + /* mu = b^2k / m */ + s_mp_add_d(&mu, 1); + s_mp_lshd(&mu, 2 * USED(m)); + if((res = mp_div(&mu, m, &mu, NULL)) != MP_OKAY) + goto CLEANUP; + + /* Loop over digits of b in ascending order, except highest order */ + for(dig = 0; dig < (ub - 1); dig++) { + d = *db++; + + /* Loop over the bits of the lower-order digits */ + for(bit = 0; bit < DIGIT_BIT; bit++) { + if(d & 1) { + if((res = s_mp_mul(&s, &x)) != MP_OKAY) + goto CLEANUP; + if((res = s_mp_reduce(&s, m, &mu)) != MP_OKAY) + goto CLEANUP; + } + + d >>= 1; + + if((res = s_mp_sqr(&x)) != MP_OKAY) + goto CLEANUP; + if((res = s_mp_reduce(&x, m, &mu)) != MP_OKAY) + goto CLEANUP; + } + } + + /* Now do the last digit... */ + d = *db; + + while(d) { + if(d & 1) { + if((res = s_mp_mul(&s, &x)) != MP_OKAY) + goto CLEANUP; + if((res = s_mp_reduce(&s, m, &mu)) != MP_OKAY) + goto CLEANUP; + } + + d >>= 1; + + if((res = s_mp_sqr(&x)) != MP_OKAY) + goto CLEANUP; + if((res = s_mp_reduce(&x, m, &mu)) != MP_OKAY) + goto CLEANUP; + } + + s_mp_exch(&s, c); + + CLEANUP: + mp_clear(&mu); + MU: + mp_clear(&x); + X: + mp_clear(&s); + + return res; + +} /* end mp_exptmod() */ + +/* }}} */ + +/* {{{ mp_exptmod_d(a, d, m, c) */ + +mp_err mp_exptmod_d(mp_int *a, mp_digit d, mp_int *m, mp_int *c) +{ + mp_int s, x; + mp_err res; + + ARGCHK(a != NULL && c != NULL, MP_BADARG); + + if((res = mp_init(&s)) != MP_OKAY) + return res; + if((res = mp_init_copy(&x, a)) != MP_OKAY) + goto X; + + mp_set(&s, 1); + + while(d != 0) { + if(d & 1) { + if((res = s_mp_mul(&s, &x)) != MP_OKAY || + (res = mp_mod(&s, m, &s)) != MP_OKAY) + goto CLEANUP; + } + + d /= 2; + + if((res = s_mp_sqr(&x)) != MP_OKAY || + (res = mp_mod(&x, m, &x)) != MP_OKAY) + goto CLEANUP; + } + + s_mp_exch(&s, c); + +CLEANUP: + mp_clear(&x); +X: + mp_clear(&s); + + return res; + +} /* end mp_exptmod_d() */ + +/* }}} */ +#endif /* if MP_MODARITH */ + +/* }}} */ + +/*------------------------------------------------------------------------*/ +/* {{{ Comparison functions */ + +/* {{{ mp_cmp_z(a) */ + +/* + mp_cmp_z(a) + + Compare a <=> 0. Returns <0 if a<0, 0 if a=0, >0 if a>0. + */ + +int mp_cmp_z(mp_int *a) +{ + if(SIGN(a) == MP_NEG) + return MP_LT; + else if(USED(a) == 1 && DIGIT(a, 0) == 0) + return MP_EQ; + else + return MP_GT; + +} /* end mp_cmp_z() */ + +/* }}} */ + +/* {{{ mp_cmp_d(a, d) */ + +/* + mp_cmp_d(a, d) + + Compare a <=> d. Returns <0 if a0 if a>d + */ + +int mp_cmp_d(mp_int *a, mp_digit d) +{ + ARGCHK(a != NULL, MP_EQ); + + if(SIGN(a) == MP_NEG) + return MP_LT; + + return s_mp_cmp_d(a, d); + +} /* end mp_cmp_d() */ + +/* }}} */ + +/* {{{ mp_cmp(a, b) */ + +int mp_cmp(mp_int *a, mp_int *b) +{ + ARGCHK(a != NULL && b != NULL, MP_EQ); + + if(SIGN(a) == SIGN(b)) { + int mag; + + if((mag = s_mp_cmp(a, b)) == MP_EQ) + return MP_EQ; + + if(SIGN(a) == MP_ZPOS) + return mag; + else + return -mag; + + } else if(SIGN(a) == MP_ZPOS) { + return MP_GT; + } else { + return MP_LT; + } + +} /* end mp_cmp() */ + +/* }}} */ + +/* {{{ mp_cmp_mag(a, b) */ + +/* + mp_cmp_mag(a, b) + + Compares |a| <=> |b|, and returns an appropriate comparison result + */ + +int mp_cmp_mag(mp_int *a, mp_int *b) +{ + ARGCHK(a != NULL && b != NULL, MP_EQ); + + return s_mp_cmp(a, b); + +} /* end mp_cmp_mag() */ + +/* }}} */ + +/* {{{ mp_cmp_int(a, z) */ + +/* + This just converts z to an mp_int, and uses the existing comparison + routines. This is sort of inefficient, but it's not clear to me how + frequently this wil get used anyway. For small positive constants, + you can always use mp_cmp_d(), and for zero, there is mp_cmp_z(). + */ +int mp_cmp_int(mp_int *a, long z) +{ + mp_int tmp; + int out; + + ARGCHK(a != NULL, MP_EQ); + + mp_init(&tmp); mp_set_int(&tmp, z); + out = mp_cmp(a, &tmp); + mp_clear(&tmp); + + return out; + +} /* end mp_cmp_int() */ + +/* }}} */ + +/* {{{ mp_isodd(a) */ + +/* + mp_isodd(a) + + Returns a true (non-zero) value if a is odd, false (zero) otherwise. + */ +int mp_isodd(mp_int *a) +{ + ARGCHK(a != NULL, 0); + + return (DIGIT(a, 0) & 1); + +} /* end mp_isodd() */ + +/* }}} */ + +/* {{{ mp_iseven(a) */ + +int mp_iseven(mp_int *a) +{ + return !mp_isodd(a); + +} /* end mp_iseven() */ + +/* }}} */ + +/* }}} */ + +/*------------------------------------------------------------------------*/ +/* {{{ Number theoretic functions */ + +#if MP_NUMTH +/* {{{ mp_gcd(a, b, c) */ + +/* + Like the old mp_gcd() function, except computes the GCD using the + binary algorithm due to Josef Stein in 1961 (via Knuth). + */ +mp_err mp_gcd(mp_int *a, mp_int *b, mp_int *c) +{ + mp_err res; + mp_int u, v, t; + mp_size k = 0; + + ARGCHK(a != NULL && b != NULL && c != NULL, MP_BADARG); + + if(mp_cmp_z(a) == MP_EQ && mp_cmp_z(b) == MP_EQ) + return MP_RANGE; + if(mp_cmp_z(a) == MP_EQ) { + return mp_copy(b, c); + } else if(mp_cmp_z(b) == MP_EQ) { + return mp_copy(a, c); + } + + if((res = mp_init(&t)) != MP_OKAY) + return res; + if((res = mp_init_copy(&u, a)) != MP_OKAY) + goto U; + if((res = mp_init_copy(&v, b)) != MP_OKAY) + goto V; + + SIGN(&u) = MP_ZPOS; + SIGN(&v) = MP_ZPOS; + + /* Divide out common factors of 2 until at least 1 of a, b is even */ + while(mp_iseven(&u) && mp_iseven(&v)) { + s_mp_div_2(&u); + s_mp_div_2(&v); + ++k; + } + + /* Initialize t */ + if(mp_isodd(&u)) { + if((res = mp_copy(&v, &t)) != MP_OKAY) + goto CLEANUP; + + /* t = -v */ + if(SIGN(&v) == MP_ZPOS) + SIGN(&t) = MP_NEG; + else + SIGN(&t) = MP_ZPOS; + + } else { + if((res = mp_copy(&u, &t)) != MP_OKAY) + goto CLEANUP; + + } + + for(;;) { + while(mp_iseven(&t)) { + s_mp_div_2(&t); + } + + if(mp_cmp_z(&t) == MP_GT) { + if((res = mp_copy(&t, &u)) != MP_OKAY) + goto CLEANUP; + + } else { + if((res = mp_copy(&t, &v)) != MP_OKAY) + goto CLEANUP; + + /* v = -t */ + if(SIGN(&t) == MP_ZPOS) + SIGN(&v) = MP_NEG; + else + SIGN(&v) = MP_ZPOS; + } + + if((res = mp_sub(&u, &v, &t)) != MP_OKAY) + goto CLEANUP; + + if(s_mp_cmp_d(&t, 0) == MP_EQ) + break; + } + + s_mp_2expt(&v, k); /* v = 2^k */ + res = mp_mul(&u, &v, c); /* c = u * v */ + + CLEANUP: + mp_clear(&v); + V: + mp_clear(&u); + U: + mp_clear(&t); + + return res; + +} /* end mp_bgcd() */ + +/* }}} */ + +/* {{{ mp_lcm(a, b, c) */ + +/* We compute the least common multiple using the rule: + + ab = [a, b](a, b) + + ... by computing the product, and dividing out the gcd. + */ + +mp_err mp_lcm(mp_int *a, mp_int *b, mp_int *c) +{ + mp_int gcd, prod; + mp_err res; + + ARGCHK(a != NULL && b != NULL && c != NULL, MP_BADARG); + + /* Set up temporaries */ + if((res = mp_init(&gcd)) != MP_OKAY) + return res; + if((res = mp_init(&prod)) != MP_OKAY) + goto GCD; + + if((res = mp_mul(a, b, &prod)) != MP_OKAY) + goto CLEANUP; + if((res = mp_gcd(a, b, &gcd)) != MP_OKAY) + goto CLEANUP; + + res = mp_div(&prod, &gcd, c, NULL); + + CLEANUP: + mp_clear(&prod); + GCD: + mp_clear(&gcd); + + return res; + +} /* end mp_lcm() */ + +/* }}} */ + +/* {{{ mp_xgcd(a, b, g, x, y) */ + +/* + mp_xgcd(a, b, g, x, y) + + Compute g = (a, b) and values x and y satisfying Bezout's identity + (that is, ax + by = g). This uses the extended binary GCD algorithm + based on the Stein algorithm used for mp_gcd() + */ + +mp_err mp_xgcd(mp_int *a, mp_int *b, mp_int *g, mp_int *x, mp_int *y) +{ + mp_int gx, xc, yc, u, v, A, B, C, D; + mp_int *clean[9]; + mp_err res; + int last = -1; + + if(mp_cmp_z(b) == 0) + return MP_RANGE; + + /* Initialize all these variables we need */ + if((res = mp_init(&u)) != MP_OKAY) goto CLEANUP; + clean[++last] = &u; + if((res = mp_init(&v)) != MP_OKAY) goto CLEANUP; + clean[++last] = &v; + if((res = mp_init(&gx)) != MP_OKAY) goto CLEANUP; + clean[++last] = &gx; + if((res = mp_init(&A)) != MP_OKAY) goto CLEANUP; + clean[++last] = &A; + if((res = mp_init(&B)) != MP_OKAY) goto CLEANUP; + clean[++last] = &B; + if((res = mp_init(&C)) != MP_OKAY) goto CLEANUP; + clean[++last] = &C; + if((res = mp_init(&D)) != MP_OKAY) goto CLEANUP; + clean[++last] = &D; + if((res = mp_init_copy(&xc, a)) != MP_OKAY) goto CLEANUP; + clean[++last] = &xc; + mp_abs(&xc, &xc); + if((res = mp_init_copy(&yc, b)) != MP_OKAY) goto CLEANUP; + clean[++last] = &yc; + mp_abs(&yc, &yc); + + mp_set(&gx, 1); + + /* Divide by two until at least one of them is even */ + while(mp_iseven(&xc) && mp_iseven(&yc)) { + s_mp_div_2(&xc); + s_mp_div_2(&yc); + if((res = s_mp_mul_2(&gx)) != MP_OKAY) + goto CLEANUP; + } + + mp_copy(&xc, &u); + mp_copy(&yc, &v); + mp_set(&A, 1); mp_set(&D, 1); + + /* Loop through binary GCD algorithm */ + for(;;) { + while(mp_iseven(&u)) { + s_mp_div_2(&u); + + if(mp_iseven(&A) && mp_iseven(&B)) { + s_mp_div_2(&A); s_mp_div_2(&B); + } else { + if((res = mp_add(&A, &yc, &A)) != MP_OKAY) goto CLEANUP; + s_mp_div_2(&A); + if((res = mp_sub(&B, &xc, &B)) != MP_OKAY) goto CLEANUP; + s_mp_div_2(&B); + } + } + + while(mp_iseven(&v)) { + s_mp_div_2(&v); + + if(mp_iseven(&C) && mp_iseven(&D)) { + s_mp_div_2(&C); s_mp_div_2(&D); + } else { + if((res = mp_add(&C, &yc, &C)) != MP_OKAY) goto CLEANUP; + s_mp_div_2(&C); + if((res = mp_sub(&D, &xc, &D)) != MP_OKAY) goto CLEANUP; + s_mp_div_2(&D); + } + } + + if(mp_cmp(&u, &v) >= 0) { + if((res = mp_sub(&u, &v, &u)) != MP_OKAY) goto CLEANUP; + if((res = mp_sub(&A, &C, &A)) != MP_OKAY) goto CLEANUP; + if((res = mp_sub(&B, &D, &B)) != MP_OKAY) goto CLEANUP; + + } else { + if((res = mp_sub(&v, &u, &v)) != MP_OKAY) goto CLEANUP; + if((res = mp_sub(&C, &A, &C)) != MP_OKAY) goto CLEANUP; + if((res = mp_sub(&D, &B, &D)) != MP_OKAY) goto CLEANUP; + + } + + /* If we're done, copy results to output */ + if(mp_cmp_z(&u) == 0) { + if(x) + if((res = mp_copy(&C, x)) != MP_OKAY) goto CLEANUP; + + if(y) + if((res = mp_copy(&D, y)) != MP_OKAY) goto CLEANUP; + + if(g) + if((res = mp_mul(&gx, &v, g)) != MP_OKAY) goto CLEANUP; + + break; + } + } + + CLEANUP: + while(last >= 0) + mp_clear(clean[last--]); + + return res; + +} /* end mp_xgcd() */ + +/* }}} */ + +/* {{{ mp_invmod(a, m, c) */ + +/* + mp_invmod(a, m, c) + + Compute c = a^-1 (mod m), if there is an inverse for a (mod m). + This is equivalent to the question of whether (a, m) = 1. If not, + MP_UNDEF is returned, and there is no inverse. + */ + +mp_err mp_invmod(mp_int *a, mp_int *m, mp_int *c) +{ + mp_int g, x; + mp_err res; + + ARGCHK(a && m && c, MP_BADARG); + + if(mp_cmp_z(a) == 0 || mp_cmp_z(m) == 0) + return MP_RANGE; + + if((res = mp_init(&g)) != MP_OKAY) + return res; + if((res = mp_init(&x)) != MP_OKAY) + goto X; + + if((res = mp_xgcd(a, m, &g, &x, NULL)) != MP_OKAY) + goto CLEANUP; + + if(mp_cmp_d(&g, 1) != MP_EQ) { + res = MP_UNDEF; + goto CLEANUP; + } + + res = mp_mod(&x, m, c); + SIGN(c) = SIGN(a); + +CLEANUP: + mp_clear(&x); +X: + mp_clear(&g); + + return res; + +} /* end mp_invmod() */ + +/* }}} */ +#endif /* if MP_NUMTH */ + +/* }}} */ + +/*------------------------------------------------------------------------*/ +/* {{{ mp_print(mp, ofp) */ + +#if MP_IOFUNC +/* + mp_print(mp, ofp) + + Print a textual representation of the given mp_int on the output + stream 'ofp'. Output is generated using the internal radix. + */ + +void mp_print(mp_int *mp, FILE *ofp) +{ + int ix; + + if(mp == NULL || ofp == NULL) + return; + + fputc((SIGN(mp) == MP_NEG) ? '-' : '+', ofp); + + for(ix = USED(mp) - 1; ix >= 0; ix--) { + fprintf(ofp, DIGIT_FMT, DIGIT(mp, ix)); + } + +} /* end mp_print() */ + +#endif /* if MP_IOFUNC */ + +/* }}} */ + +/*------------------------------------------------------------------------*/ +/* {{{ More I/O Functions */ + +/* {{{ mp_read_signed_bin(mp, str, len) */ + +/* + mp_read_signed_bin(mp, str, len) + + Read in a raw value (base 256) into the given mp_int + */ + +mp_err mp_read_signed_bin(mp_int *mp, unsigned char *str, int len) +{ + mp_err res; + + ARGCHK(mp != NULL && str != NULL && len > 0, MP_BADARG); + + if((res = mp_read_unsigned_bin(mp, str + 1, len - 1)) == MP_OKAY) { + /* Get sign from first byte */ + if(str[0]) + SIGN(mp) = MP_NEG; + else + SIGN(mp) = MP_ZPOS; + } + + return res; + +} /* end mp_read_signed_bin() */ + +/* }}} */ + +/* {{{ mp_signed_bin_size(mp) */ + +int mp_signed_bin_size(mp_int *mp) +{ + ARGCHK(mp != NULL, 0); + + return mp_unsigned_bin_size(mp) + 1; + +} /* end mp_signed_bin_size() */ + +/* }}} */ + +/* {{{ mp_to_signed_bin(mp, str) */ + +mp_err mp_to_signed_bin(mp_int *mp, unsigned char *str) +{ + ARGCHK(mp != NULL && str != NULL, MP_BADARG); + + /* Caller responsible for allocating enough memory (use mp_raw_size(mp)) */ + str[0] = (char)SIGN(mp); + + return mp_to_unsigned_bin(mp, str + 1); + +} /* end mp_to_signed_bin() */ + +/* }}} */ + +/* {{{ mp_read_unsigned_bin(mp, str, len) */ + +/* + mp_read_unsigned_bin(mp, str, len) + + Read in an unsigned value (base 256) into the given mp_int + */ + +mp_err mp_read_unsigned_bin(mp_int *mp, unsigned char *str, int len) +{ + int ix; + mp_err res; + + ARGCHK(mp != NULL && str != NULL && len > 0, MP_BADARG); + + mp_zero(mp); + + for(ix = 0; ix < len; ix++) { + if((res = s_mp_mul_2d(mp, CHAR_BIT)) != MP_OKAY) + return res; + + if((res = mp_add_d(mp, str[ix], mp)) != MP_OKAY) + return res; + } + + return MP_OKAY; + +} /* end mp_read_unsigned_bin() */ + +/* }}} */ + +/* {{{ mp_unsigned_bin_size(mp) */ + +int mp_unsigned_bin_size(mp_int *mp) +{ + mp_digit topdig; + int count; + + ARGCHK(mp != NULL, 0); + + /* Special case for the value zero */ + if(USED(mp) == 1 && DIGIT(mp, 0) == 0) + return 1; + + count = (USED(mp) - 1) * sizeof(mp_digit); + topdig = DIGIT(mp, USED(mp) - 1); + + while(topdig != 0) { + ++count; + topdig >>= CHAR_BIT; + } + + return count; + +} /* end mp_unsigned_bin_size() */ + +/* }}} */ + +/* {{{ mp_to_unsigned_bin(mp, str) */ + +mp_err mp_to_unsigned_bin(mp_int *mp, unsigned char *str) +{ + mp_digit *dp, *end, d; + unsigned char *spos; + + ARGCHK(mp != NULL && str != NULL, MP_BADARG); + + dp = DIGITS(mp); + end = dp + USED(mp) - 1; + spos = str; + + /* Special case for zero, quick test */ + if(dp == end && *dp == 0) { + *str = '\0'; + return MP_OKAY; + } + + /* Generate digits in reverse order */ + while(dp < end) { + int ix; + + d = *dp; + for(ix = 0; ix < sizeof(mp_digit); ++ix) { + *spos = d & UCHAR_MAX; + d >>= CHAR_BIT; + ++spos; + } + + ++dp; + } + + /* Now handle last digit specially, high order zeroes are not written */ + d = *end; + while(d != 0) { + *spos = d & UCHAR_MAX; + d >>= CHAR_BIT; + ++spos; + } + + /* Reverse everything to get digits in the correct order */ + while(--spos > str) { + unsigned char t = *str; + *str = *spos; + *spos = t; + + ++str; + } + + return MP_OKAY; + +} /* end mp_to_unsigned_bin() */ + +/* }}} */ + +/* {{{ mp_count_bits(mp) */ + +int mp_count_bits(mp_int *mp) +{ + int len; + mp_digit d; + + ARGCHK(mp != NULL, MP_BADARG); + + len = DIGIT_BIT * (USED(mp) - 1); + d = DIGIT(mp, USED(mp) - 1); + + while(d != 0) { + ++len; + d >>= 1; + } + + return len; + +} /* end mp_count_bits() */ + +/* }}} */ + +/* {{{ mp_read_radix(mp, str, radix) */ + +/* + mp_read_radix(mp, str, radix) + + Read an integer from the given string, and set mp to the resulting + value. The input is presumed to be in base 10. Leading non-digit + characters are ignored, and the function reads until a non-digit + character or the end of the string. + */ + +mp_err mp_read_radix(mp_int *mp, unsigned char *str, int radix) +{ + int ix = 0, val = 0; + mp_err res; + mp_sign sig = MP_ZPOS; + + ARGCHK(mp != NULL && str != NULL && radix >= 2 && radix <= MAX_RADIX, + MP_BADARG); + + mp_zero(mp); + + /* Skip leading non-digit characters until a digit or '-' or '+' */ + while(str[ix] && + (s_mp_tovalue(str[ix], radix) < 0) && + str[ix] != '-' && + str[ix] != '+') { + ++ix; + } + + if(str[ix] == '-') { + sig = MP_NEG; + ++ix; + } else if(str[ix] == '+') { + sig = MP_ZPOS; /* this is the default anyway... */ + ++ix; + } + + while((val = s_mp_tovalue(str[ix], radix)) >= 0) { + if((res = s_mp_mul_d(mp, radix)) != MP_OKAY) + return res; + if((res = s_mp_add_d(mp, val)) != MP_OKAY) + return res; + ++ix; + } + + if(s_mp_cmp_d(mp, 0) == MP_EQ) + SIGN(mp) = MP_ZPOS; + else + SIGN(mp) = sig; + + return MP_OKAY; + +} /* end mp_read_radix() */ + +/* }}} */ + +/* {{{ mp_radix_size(mp, radix) */ + +int mp_radix_size(mp_int *mp, int radix) +{ + int len; + ARGCHK(mp != NULL, 0); + + len = s_mp_outlen(mp_count_bits(mp), radix) + 1; /* for NUL terminator */ + + if(mp_cmp_z(mp) < 0) + ++len; /* for sign */ + + return len; + +} /* end mp_radix_size() */ + +/* }}} */ + +/* {{{ mp_value_radix_size(num, qty, radix) */ + +/* num = number of digits + qty = number of bits per digit + radix = target base + + Return the number of digits in the specified radix that would be + needed to express 'num' digits of 'qty' bits each. + */ +int mp_value_radix_size(int num, int qty, int radix) +{ + ARGCHK(num >= 0 && qty > 0 && radix >= 2 && radix <= MAX_RADIX, 0); + + return s_mp_outlen(num * qty, radix); + +} /* end mp_value_radix_size() */ + +/* }}} */ + +/* {{{ mp_toradix(mp, str, radix) */ + +mp_err mp_toradix(mp_int *mp, unsigned char *str, int radix) +{ + int ix, pos = 0; + + ARGCHK(mp != NULL && str != NULL, MP_BADARG); + ARGCHK(radix > 1 && radix <= MAX_RADIX, MP_RANGE); + + if(mp_cmp_z(mp) == MP_EQ) { + str[0] = '0'; + str[1] = '\0'; + } else { + mp_err res; + mp_int tmp; + mp_sign sgn; + mp_digit rem, rdx = (mp_digit)radix; + char ch; + + if((res = mp_init_copy(&tmp, mp)) != MP_OKAY) + return res; + + /* Save sign for later, and take absolute value */ + sgn = SIGN(&tmp); SIGN(&tmp) = MP_ZPOS; + + /* Generate output digits in reverse order */ + while(mp_cmp_z(&tmp) != 0) { + if((res = s_mp_div_d(&tmp, rdx, &rem)) != MP_OKAY) { + mp_clear(&tmp); + return res; + } + + /* Generate digits, use capital letters */ + ch = s_mp_todigit(rem, radix, 0); + + str[pos++] = ch; + } + + /* Add - sign if original value was negative */ + if(sgn == MP_NEG) + str[pos++] = '-'; + + /* Add trailing NUL to end the string */ + str[pos--] = '\0'; + + /* Reverse the digits and sign indicator */ + ix = 0; + while(ix < pos) { + char tmp = str[ix]; + + str[ix] = str[pos]; + str[pos] = tmp; + ++ix; + --pos; + } + + mp_clear(&tmp); + } + + return MP_OKAY; + +} /* end mp_toradix() */ + +/* }}} */ + +/* {{{ mp_char2value(ch, r) */ + +int mp_char2value(char ch, int r) +{ + return s_mp_tovalue(ch, r); + +} /* end mp_tovalue() */ + +/* }}} */ + +/* }}} */ + +/* {{{ mp_strerror(ec) */ + +/* + mp_strerror(ec) + + Return a string describing the meaning of error code 'ec'. The + string returned is allocated in static memory, so the caller should + not attempt to modify or free the memory associated with this + string. + */ +const char *mp_strerror(mp_err ec) +{ + int aec = (ec < 0) ? -ec : ec; + + /* Code values are negative, so the senses of these comparisons + are accurate */ + if(ec < MP_LAST_CODE || ec > MP_OKAY) { + return mp_err_string[0]; /* unknown error code */ + } else { + return mp_err_string[aec + 1]; + } + +} /* end mp_strerror() */ + +/* }}} */ + +/*========================================================================*/ +/*------------------------------------------------------------------------*/ +/* Static function definitions (internal use only) */ + +/* {{{ Memory management */ + +/* {{{ s_mp_grow(mp, min) */ + +/* Make sure there are at least 'min' digits allocated to mp */ +mp_err s_mp_grow(mp_int *mp, mp_size min) +{ + if(min > ALLOC(mp)) { + mp_digit *tmp; + + /* Set min to next nearest default precision block size */ + min = ((min + (s_mp_defprec - 1)) / s_mp_defprec) * s_mp_defprec; + + if((tmp = s_mp_alloc(min, sizeof(mp_digit))) == NULL) + return MP_MEM; + + s_mp_copy(DIGITS(mp), tmp, USED(mp)); + +#if MP_CRYPTO + s_mp_setz(DIGITS(mp), ALLOC(mp)); +#endif + s_mp_free(DIGITS(mp)); + DIGITS(mp) = tmp; + ALLOC(mp) = min; + } + + return MP_OKAY; + +} /* end s_mp_grow() */ + +/* }}} */ + +/* {{{ s_mp_pad(mp, min) */ + +/* Make sure the used size of mp is at least 'min', growing if needed */ +mp_err s_mp_pad(mp_int *mp, mp_size min) +{ + if(min > USED(mp)) { + mp_err res; + + /* Make sure there is room to increase precision */ + if(min > ALLOC(mp) && (res = s_mp_grow(mp, min)) != MP_OKAY) + return res; + + /* Increase precision; should already be 0-filled */ + USED(mp) = min; + } + + return MP_OKAY; + +} /* end s_mp_pad() */ + +/* }}} */ + +/* {{{ s_mp_setz(dp, count) */ + +#if MP_MACRO == 0 +/* Set 'count' digits pointed to by dp to be zeroes */ +void s_mp_setz(mp_digit *dp, mp_size count) +{ +#if MP_MEMSET == 0 + int ix; + + for(ix = 0; ix < count; ix++) + dp[ix] = 0; +#else + memset(dp, 0, count * sizeof(mp_digit)); +#endif + +} /* end s_mp_setz() */ +#endif + +/* }}} */ + +/* {{{ s_mp_copy(sp, dp, count) */ + +#if MP_MACRO == 0 +/* Copy 'count' digits from sp to dp */ +void s_mp_copy(mp_digit *sp, mp_digit *dp, mp_size count) +{ +#if MP_MEMCPY == 0 + int ix; + + for(ix = 0; ix < count; ix++) + dp[ix] = sp[ix]; +#else + memcpy(dp, sp, count * sizeof(mp_digit)); +#endif + +} /* end s_mp_copy() */ +#endif + +/* }}} */ + +/* {{{ s_mp_alloc(nb, ni) */ + +#if MP_MACRO == 0 +/* Allocate ni records of nb bytes each, and return a pointer to that */ +void *s_mp_alloc(size_t nb, size_t ni) +{ + return calloc(nb, ni); + +} /* end s_mp_alloc() */ +#endif + +/* }}} */ + +/* {{{ s_mp_free(ptr) */ + +#if MP_MACRO == 0 +/* Free the memory pointed to by ptr */ +void s_mp_free(void *ptr) +{ + if(ptr) + free(ptr); + +} /* end s_mp_free() */ +#endif + +/* }}} */ + +/* {{{ s_mp_clamp(mp) */ + +/* Remove leading zeroes from the given value */ +void s_mp_clamp(mp_int *mp) +{ + mp_size du = USED(mp); + mp_digit *zp = DIGITS(mp) + du - 1; + + while(du > 1 && !*zp--) + --du; + + USED(mp) = du; + +} /* end s_mp_clamp() */ + + +/* }}} */ + +/* {{{ s_mp_exch(a, b) */ + +/* Exchange the data for a and b; (b, a) = (a, b) */ +void s_mp_exch(mp_int *a, mp_int *b) +{ + mp_int tmp; + + tmp = *a; + *a = *b; + *b = tmp; + +} /* end s_mp_exch() */ + +/* }}} */ + +/* }}} */ + +/* {{{ Arithmetic helpers */ + +/* {{{ s_mp_lshd(mp, p) */ + +/* + Shift mp leftward by p digits, growing if needed, and zero-filling + the in-shifted digits at the right end. This is a convenient + alternative to multiplication by powers of the radix + */ + +mp_err s_mp_lshd(mp_int *mp, mp_size p) +{ + mp_err res; + mp_size pos; + mp_digit *dp; + int ix; + + if(p == 0) + return MP_OKAY; + + if((res = s_mp_pad(mp, USED(mp) + p)) != MP_OKAY) + return res; + + pos = USED(mp) - 1; + dp = DIGITS(mp); + + /* Shift all the significant figures over as needed */ + for(ix = pos - p; ix >= 0; ix--) + dp[ix + p] = dp[ix]; + + /* Fill the bottom digits with zeroes */ + for(ix = 0; ix < p; ix++) + dp[ix] = 0; + + return MP_OKAY; + +} /* end s_mp_lshd() */ + +/* }}} */ + +/* {{{ s_mp_rshd(mp, p) */ + +/* + Shift mp rightward by p digits. Maintains the invariant that + digits above the precision are all zero. Digits shifted off the + end are lost. Cannot fail. + */ + +void s_mp_rshd(mp_int *mp, mp_size p) +{ + mp_size ix; + mp_digit *dp; + + if(p == 0) + return; + + /* Shortcut when all digits are to be shifted off */ + if(p >= USED(mp)) { + s_mp_setz(DIGITS(mp), ALLOC(mp)); + USED(mp) = 1; + SIGN(mp) = MP_ZPOS; + return; + } + + /* Shift all the significant figures over as needed */ + dp = DIGITS(mp); + for(ix = p; ix < USED(mp); ix++) + dp[ix - p] = dp[ix]; + + /* Fill the top digits with zeroes */ + ix -= p; + while(ix < USED(mp)) + dp[ix++] = 0; + + /* Strip off any leading zeroes */ + s_mp_clamp(mp); + +} /* end s_mp_rshd() */ + +/* }}} */ + +/* {{{ s_mp_div_2(mp) */ + +/* Divide by two -- take advantage of radix properties to do it fast */ +void s_mp_div_2(mp_int *mp) +{ + s_mp_div_2d(mp, 1); + +} /* end s_mp_div_2() */ + +/* }}} */ + +/* {{{ s_mp_mul_2(mp) */ + +mp_err s_mp_mul_2(mp_int *mp) +{ + int ix; + mp_digit kin = 0, kout, *dp = DIGITS(mp); + mp_err res; + + /* Shift digits leftward by 1 bit */ + for(ix = 0; ix < USED(mp); ix++) { + kout = (dp[ix] >> (DIGIT_BIT - 1)) & 1; + dp[ix] = (dp[ix] << 1) | kin; + + kin = kout; + } + + /* Deal with rollover from last digit */ + if(kin) { + if(ix >= ALLOC(mp)) { + if((res = s_mp_grow(mp, ALLOC(mp) + 1)) != MP_OKAY) + return res; + dp = DIGITS(mp); + } + + dp[ix] = kin; + USED(mp) += 1; + } + + return MP_OKAY; + +} /* end s_mp_mul_2() */ + +/* }}} */ + +/* {{{ s_mp_mod_2d(mp, d) */ + +/* + Remainder the integer by 2^d, where d is a number of bits. This + amounts to a bitwise AND of the value, and does not require the full + division code + */ +void s_mp_mod_2d(mp_int *mp, mp_digit d) +{ + unsigned int ndig = (d / DIGIT_BIT), nbit = (d % DIGIT_BIT); + unsigned int ix; + mp_digit dmask, *dp = DIGITS(mp); + + if(ndig >= USED(mp)) + return; + + /* Flush all the bits above 2^d in its digit */ + dmask = (1 << nbit) - 1; + dp[ndig] &= dmask; + + /* Flush all digits above the one with 2^d in it */ + for(ix = ndig + 1; ix < USED(mp); ix++) + dp[ix] = 0; + + s_mp_clamp(mp); + +} /* end s_mp_mod_2d() */ + +/* }}} */ + +/* {{{ s_mp_mul_2d(mp, d) */ + +/* + Multiply by the integer 2^d, where d is a number of bits. This + amounts to a bitwise shift of the value, and does not require the + full multiplication code. + */ +mp_err s_mp_mul_2d(mp_int *mp, mp_digit d) +{ + mp_err res; + mp_digit save, next, mask, *dp; + mp_size used; + int ix; + + if((res = s_mp_lshd(mp, d / DIGIT_BIT)) != MP_OKAY) + return res; + + dp = DIGITS(mp); used = USED(mp); + d %= DIGIT_BIT; + + mask = (1 << d) - 1; + + /* If the shift requires another digit, make sure we've got one to + work with */ + if((dp[used - 1] >> (DIGIT_BIT - d)) & mask) { + if((res = s_mp_grow(mp, used + 1)) != MP_OKAY) + return res; + dp = DIGITS(mp); + } + + /* Do the shifting... */ + save = 0; + for(ix = 0; ix < used; ix++) { + next = (dp[ix] >> (DIGIT_BIT - d)) & mask; + dp[ix] = (dp[ix] << d) | save; + save = next; + } + + /* If, at this point, we have a nonzero carryout into the next + digit, we'll increase the size by one digit, and store it... + */ + if(save) { + dp[used] = save; + USED(mp) += 1; + } + + s_mp_clamp(mp); + return MP_OKAY; + +} /* end s_mp_mul_2d() */ + +/* }}} */ + +/* {{{ s_mp_div_2d(mp, d) */ + +/* + Divide the integer by 2^d, where d is a number of bits. This + amounts to a bitwise shift of the value, and does not require the + full division code (used in Barrett reduction, see below) + */ +void s_mp_div_2d(mp_int *mp, mp_digit d) +{ + int ix; + mp_digit save, next, mask, *dp = DIGITS(mp); + + s_mp_rshd(mp, d / DIGIT_BIT); + d %= DIGIT_BIT; + + mask = (1 << d) - 1; + + save = 0; + for(ix = USED(mp) - 1; ix >= 0; ix--) { + next = dp[ix] & mask; + dp[ix] = (dp[ix] >> d) | (save << (DIGIT_BIT - d)); + save = next; + } + + s_mp_clamp(mp); + +} /* end s_mp_div_2d() */ + +/* }}} */ + +/* {{{ s_mp_norm(a, b) */ + +/* + s_mp_norm(a, b) + + Normalize a and b for division, where b is the divisor. In order + that we might make good guesses for quotient digits, we want the + leading digit of b to be at least half the radix, which we + accomplish by multiplying a and b by a constant. This constant is + returned (so that it can be divided back out of the remainder at the + end of the division process). + + We multiply by the smallest power of 2 that gives us a leading digit + at least half the radix. By choosing a power of 2, we simplify the + multiplication and division steps to simple shifts. + */ +mp_digit s_mp_norm(mp_int *a, mp_int *b) +{ + mp_digit t, d = 0; + + t = DIGIT(b, USED(b) - 1); + while(t < (RADIX / 2)) { + t <<= 1; + ++d; + } + + if(d != 0) { + s_mp_mul_2d(a, d); + s_mp_mul_2d(b, d); + } + + return d; + +} /* end s_mp_norm() */ + +/* }}} */ + +/* }}} */ + +/* {{{ Primitive digit arithmetic */ + +/* {{{ s_mp_add_d(mp, d) */ + +/* Add d to |mp| in place */ +mp_err s_mp_add_d(mp_int *mp, mp_digit d) /* unsigned digit addition */ +{ + mp_word w, k = 0; + mp_size ix = 1, used = USED(mp); + mp_digit *dp = DIGITS(mp); + + w = dp[0] + d; + dp[0] = ACCUM(w); + k = CARRYOUT(w); + + while(ix < used && k) { + w = dp[ix] + k; + dp[ix] = ACCUM(w); + k = CARRYOUT(w); + ++ix; + } + + if(k != 0) { + mp_err res; + + if((res = s_mp_pad(mp, USED(mp) + 1)) != MP_OKAY) + return res; + + DIGIT(mp, ix) = k; + } + + return MP_OKAY; + +} /* end s_mp_add_d() */ + +/* }}} */ + +/* {{{ s_mp_sub_d(mp, d) */ + +/* Subtract d from |mp| in place, assumes |mp| > d */ +mp_err s_mp_sub_d(mp_int *mp, mp_digit d) /* unsigned digit subtract */ +{ + mp_word w, b = 0; + mp_size ix = 1, used = USED(mp); + mp_digit *dp = DIGITS(mp); + + /* Compute initial subtraction */ + w = (RADIX + dp[0]) - d; + b = CARRYOUT(w) ? 0 : 1; + dp[0] = ACCUM(w); + + /* Propagate borrows leftward */ + while(b && ix < used) { + w = (RADIX + dp[ix]) - b; + b = CARRYOUT(w) ? 0 : 1; + dp[ix] = ACCUM(w); + ++ix; + } + + /* Remove leading zeroes */ + s_mp_clamp(mp); + + /* If we have a borrow out, it's a violation of the input invariant */ + if(b) + return MP_RANGE; + else + return MP_OKAY; + +} /* end s_mp_sub_d() */ + +/* }}} */ + +/* {{{ s_mp_mul_d(a, d) */ + +/* Compute a = a * d, single digit multiplication */ +mp_err s_mp_mul_d(mp_int *a, mp_digit d) +{ + mp_word w, k = 0; + mp_size ix, max; + mp_err res; + mp_digit *dp = DIGITS(a); + + /* + Single-digit multiplication will increase the precision of the + output by at most one digit. However, we can detect when this + will happen -- if the high-order digit of a, times d, gives a + two-digit result, then the precision of the result will increase; + otherwise it won't. We use this fact to avoid calling s_mp_pad() + unless absolutely necessary. + */ + max = USED(a); + w = dp[max - 1] * d; + if(CARRYOUT(w) != 0) { + if((res = s_mp_pad(a, max + 1)) != MP_OKAY) + return res; + dp = DIGITS(a); + } + + for(ix = 0; ix < max; ix++) { + w = (dp[ix] * d) + k; + dp[ix] = ACCUM(w); + k = CARRYOUT(w); + } + + /* If there is a precision increase, take care of it here; the above + test guarantees we have enough storage to do this safely. + */ + if(k) { + dp[max] = k; + USED(a) = max + 1; + } + + s_mp_clamp(a); + + return MP_OKAY; + +} /* end s_mp_mul_d() */ + +/* }}} */ + +/* {{{ s_mp_div_d(mp, d, r) */ + +/* + s_mp_div_d(mp, d, r) + + Compute the quotient mp = mp / d and remainder r = mp mod d, for a + single digit d. If r is null, the remainder will be discarded. + */ + +mp_err s_mp_div_d(mp_int *mp, mp_digit d, mp_digit *r) +{ + mp_word w = 0, t; + mp_int quot; + mp_err res; + mp_digit *dp = DIGITS(mp), *qp; + int ix; + + if(d == 0) + return MP_RANGE; + + /* Make room for the quotient */ + if((res = mp_init_size(", USED(mp))) != MP_OKAY) + return res; + + USED(") = USED(mp); /* so clamping will work below */ + qp = DIGITS("); + + /* Divide without subtraction */ + for(ix = USED(mp) - 1; ix >= 0; ix--) { + w = (w << DIGIT_BIT) | dp[ix]; + + if(w >= d) { + t = w / d; + w = w % d; + } else { + t = 0; + } + + qp[ix] = t; + } + + /* Deliver the remainder, if desired */ + if(r) + *r = w; + + s_mp_clamp("); + mp_exch(", mp); + mp_clear("); + + return MP_OKAY; + +} /* end s_mp_div_d() */ + +/* }}} */ + +/* }}} */ + +/* {{{ Primitive full arithmetic */ + +/* {{{ s_mp_add(a, b) */ + +/* Compute a = |a| + |b| */ +mp_err s_mp_add(mp_int *a, mp_int *b) /* magnitude addition */ +{ + mp_word w = 0; + mp_digit *pa, *pb; + mp_size ix, used = USED(b); + mp_err res; + + /* Make sure a has enough precision for the output value */ + if((used > USED(a)) && (res = s_mp_pad(a, used)) != MP_OKAY) + return res; + + /* + Add up all digits up to the precision of b. If b had initially + the same precision as a, or greater, we took care of it by the + padding step above, so there is no problem. If b had initially + less precision, we'll have to make sure the carry out is duly + propagated upward among the higher-order digits of the sum. + */ + pa = DIGITS(a); + pb = DIGITS(b); + for(ix = 0; ix < used; ++ix) { + w += *pa + *pb++; + *pa++ = ACCUM(w); + w = CARRYOUT(w); + } + + /* If we run out of 'b' digits before we're actually done, make + sure the carries get propagated upward... + */ + used = USED(a); + while(w && ix < used) { + w += *pa; + *pa++ = ACCUM(w); + w = CARRYOUT(w); + ++ix; + } + + /* If there's an overall carry out, increase precision and include + it. We could have done this initially, but why touch the memory + allocator unless we're sure we have to? + */ + if(w) { + if((res = s_mp_pad(a, used + 1)) != MP_OKAY) + return res; + + DIGIT(a, ix) = w; /* pa may not be valid after s_mp_pad() call */ + } + + return MP_OKAY; + +} /* end s_mp_add() */ + +/* }}} */ + +/* {{{ s_mp_sub(a, b) */ + +/* Compute a = |a| - |b|, assumes |a| >= |b| */ +mp_err s_mp_sub(mp_int *a, mp_int *b) /* magnitude subtract */ +{ + mp_word w = 0; + mp_digit *pa, *pb; + mp_size ix, used = USED(b); + + /* + Subtract and propagate borrow. Up to the precision of b, this + accounts for the digits of b; after that, we just make sure the + carries get to the right place. This saves having to pad b out to + the precision of a just to make the loops work right... + */ + pa = DIGITS(a); + pb = DIGITS(b); + + for(ix = 0; ix < used; ++ix) { + w = (RADIX + *pa) - w - *pb++; + *pa++ = ACCUM(w); + w = CARRYOUT(w) ? 0 : 1; + } + + used = USED(a); + while(ix < used) { + w = RADIX + *pa - w; + *pa++ = ACCUM(w); + w = CARRYOUT(w) ? 0 : 1; + ++ix; + } + + /* Clobber any leading zeroes we created */ + s_mp_clamp(a); + + /* + If there was a borrow out, then |b| > |a| in violation + of our input invariant. We've already done the work, + but we'll at least complain about it... + */ + if(w) + return MP_RANGE; + else + return MP_OKAY; + +} /* end s_mp_sub() */ + +/* }}} */ + +mp_err s_mp_reduce(mp_int *x, mp_int *m, mp_int *mu) +{ + mp_int q; + mp_err res; + mp_size um = USED(m); + + if((res = mp_init_copy(&q, x)) != MP_OKAY) + return res; + + s_mp_rshd(&q, um - 1); /* q1 = x / b^(k-1) */ + s_mp_mul(&q, mu); /* q2 = q1 * mu */ + s_mp_rshd(&q, um + 1); /* q3 = q2 / b^(k+1) */ + + /* x = x mod b^(k+1), quick (no division) */ + s_mp_mod_2d(x, (mp_digit)(DIGIT_BIT * (um + 1))); + + /* q = q * m mod b^(k+1), quick (no division), uses the short multiplier */ +#ifndef SHRT_MUL + s_mp_mul(&q, m); + s_mp_mod_2d(&q, (mp_digit)(DIGIT_BIT * (um + 1))); +#else + s_mp_mul_dig(&q, m, um + 1); +#endif + + /* x = x - q */ + if((res = mp_sub(x, &q, x)) != MP_OKAY) + goto CLEANUP; + + /* If x < 0, add b^(k+1) to it */ + if(mp_cmp_z(x) < 0) { + mp_set(&q, 1); + if((res = s_mp_lshd(&q, um + 1)) != MP_OKAY) + goto CLEANUP; + if((res = mp_add(x, &q, x)) != MP_OKAY) + goto CLEANUP; + } + + /* Back off if it's too big */ + while(mp_cmp(x, m) >= 0) { + if((res = s_mp_sub(x, m)) != MP_OKAY) + break; + } + + CLEANUP: + mp_clear(&q); + + return res; + +} /* end s_mp_reduce() */ + + + +/* {{{ s_mp_mul(a, b) */ + +/* Compute a = |a| * |b| */ +mp_err s_mp_mul(mp_int *a, mp_int *b) +{ + mp_word w, k = 0; + mp_int tmp; + mp_err res; + mp_size ix, jx, ua = USED(a), ub = USED(b); + mp_digit *pa, *pb, *pt, *pbt; + + if((res = mp_init_size(&tmp, ua + ub)) != MP_OKAY) + return res; + + /* This has the effect of left-padding with zeroes... */ + USED(&tmp) = ua + ub; + + /* We're going to need the base value each iteration */ + pbt = DIGITS(&tmp); + + /* Outer loop: Digits of b */ + + pb = DIGITS(b); + for(ix = 0; ix < ub; ++ix, ++pb) { + if(*pb == 0) + continue; + + /* Inner product: Digits of a */ + pa = DIGITS(a); + for(jx = 0; jx < ua; ++jx, ++pa) { + pt = pbt + ix + jx; + w = *pb * *pa + k + *pt; + *pt = ACCUM(w); + k = CARRYOUT(w); + } + + pbt[ix + jx] = k; + k = 0; + } + + s_mp_clamp(&tmp); + s_mp_exch(&tmp, a); + + mp_clear(&tmp); + + return MP_OKAY; + +} /* end s_mp_mul() */ + +/* }}} */ + +/* {{{ s_mp_kmul(a, b, out, len) */ + +#if 0 +void s_mp_kmul(mp_digit *a, mp_digit *b, mp_digit *out, mp_size len) +{ + mp_word w, k = 0; + mp_size ix, jx; + mp_digit *pa, *pt; + + for(ix = 0; ix < len; ++ix, ++b) { + if(*b == 0) + continue; + + pa = a; + for(jx = 0; jx < len; ++jx, ++pa) { + pt = out + ix + jx; + w = *b * *pa + k + *pt; + *pt = ACCUM(w); + k = CARRYOUT(w); + } + + out[ix + jx] = k; + k = 0; + } + +} /* end s_mp_kmul() */ +#endif + +/* }}} */ + +/* {{{ s_mp_sqr(a) */ + +/* + Computes the square of a, in place. This can be done more + efficiently than a general multiplication, because many of the + computation steps are redundant when squaring. The inner product + step is a bit more complicated, but we save a fair number of + iterations of the multiplication loop. + */ +#if MP_SQUARE +mp_err s_mp_sqr(mp_int *a) +{ + mp_word w, k = 0; + mp_int tmp; + mp_err res; + mp_size ix, jx, kx, used = USED(a); + mp_digit *pa1, *pa2, *pt, *pbt; + + if((res = mp_init_size(&tmp, 2 * used)) != MP_OKAY) + return res; + + /* Left-pad with zeroes */ + USED(&tmp) = 2 * used; + + /* We need the base value each time through the loop */ + pbt = DIGITS(&tmp); + + pa1 = DIGITS(a); + for(ix = 0; ix < used; ++ix, ++pa1) { + if(*pa1 == 0) + continue; + + w = DIGIT(&tmp, ix + ix) + (*pa1 * *pa1); + + pbt[ix + ix] = ACCUM(w); + k = CARRYOUT(w); + + /* + The inner product is computed as: + + (C, S) = t[i,j] + 2 a[i] a[j] + C + + This can overflow what can be represented in an mp_word, and + since C arithmetic does not provide any way to check for + overflow, we have to check explicitly for overflow conditions + before they happen. + */ + for(jx = ix + 1, pa2 = DIGITS(a) + jx; jx < used; ++jx, ++pa2) { + mp_word u = 0, v; + + /* Store this in a temporary to avoid indirections later */ + pt = pbt + ix + jx; + + /* Compute the multiplicative step */ + w = *pa1 * *pa2; + + /* If w is more than half MP_WORD_MAX, the doubling will + overflow, and we need to record a carry out into the next + word */ + u = (w >> (MP_WORD_BIT - 1)) & 1; + + /* Double what we've got, overflow will be ignored as defined + for C arithmetic (we've already noted if it is to occur) + */ + w *= 2; + + /* Compute the additive step */ + v = *pt + k; + + /* If we do not already have an overflow carry, check to see + if the addition will cause one, and set the carry out if so + */ + u |= ((MP_WORD_MAX - v) < w); + + /* Add in the rest, again ignoring overflow */ + w += v; + + /* Set the i,j digit of the output */ + *pt = ACCUM(w); + + /* Save carry information for the next iteration of the loop. + This is why k must be an mp_word, instead of an mp_digit */ + k = CARRYOUT(w) | (u << DIGIT_BIT); + + } /* for(jx ...) */ + + /* Set the last digit in the cycle and reset the carry */ + k = DIGIT(&tmp, ix + jx) + k; + pbt[ix + jx] = ACCUM(k); + k = CARRYOUT(k); + + /* If we are carrying out, propagate the carry to the next digit + in the output. This may cascade, so we have to be somewhat + circumspect -- but we will have enough precision in the output + that we won't overflow + */ + kx = 1; + while(k) { + k = pbt[ix + jx + kx] + 1; + pbt[ix + jx + kx] = ACCUM(k); + k = CARRYOUT(k); + ++kx; + } + } /* for(ix ...) */ + + s_mp_clamp(&tmp); + s_mp_exch(&tmp, a); + + mp_clear(&tmp); + + return MP_OKAY; + +} /* end s_mp_sqr() */ +#endif + +/* }}} */ + +/* {{{ s_mp_div(a, b) */ + +/* + s_mp_div(a, b) + + Compute a = a / b and b = a mod b. Assumes b > a. + */ + +mp_err s_mp_div(mp_int *a, mp_int *b) +{ + mp_int quot, rem, t; + mp_word q; + mp_err res; + mp_digit d; + int ix; + + if(mp_cmp_z(b) == 0) + return MP_RANGE; + + /* Shortcut if b is power of two */ + if((ix = s_mp_ispow2(b)) >= 0) { + mp_copy(a, b); /* need this for remainder */ + s_mp_div_2d(a, (mp_digit)ix); + s_mp_mod_2d(b, (mp_digit)ix); + + return MP_OKAY; + } + + /* Allocate space to store the quotient */ + if((res = mp_init_size(", USED(a))) != MP_OKAY) + return res; + + /* A working temporary for division */ + if((res = mp_init_size(&t, USED(a))) != MP_OKAY) + goto T; + + /* Allocate space for the remainder */ + if((res = mp_init_size(&rem, USED(a))) != MP_OKAY) + goto REM; + + /* Normalize to optimize guessing */ + d = s_mp_norm(a, b); + + /* Perform the division itself...woo! */ + ix = USED(a) - 1; + + while(ix >= 0) { + /* Find a partial substring of a which is at least b */ + while(s_mp_cmp(&rem, b) < 0 && ix >= 0) { + if((res = s_mp_lshd(&rem, 1)) != MP_OKAY) + goto CLEANUP; + + if((res = s_mp_lshd(", 1)) != MP_OKAY) + goto CLEANUP; + + DIGIT(&rem, 0) = DIGIT(a, ix); + s_mp_clamp(&rem); + --ix; + } + + /* If we didn't find one, we're finished dividing */ + if(s_mp_cmp(&rem, b) < 0) + break; + + /* Compute a guess for the next quotient digit */ + q = DIGIT(&rem, USED(&rem) - 1); + if(q <= DIGIT(b, USED(b) - 1) && USED(&rem) > 1) + q = (q << DIGIT_BIT) | DIGIT(&rem, USED(&rem) - 2); + + q /= DIGIT(b, USED(b) - 1); + + /* The guess can be as much as RADIX + 1 */ + if(q >= RADIX) + q = RADIX - 1; + + /* See what that multiplies out to */ + mp_copy(b, &t); + if((res = s_mp_mul_d(&t, q)) != MP_OKAY) + goto CLEANUP; + + /* + If it's too big, back it off. We should not have to do this + more than once, or, in rare cases, twice. Knuth describes a + method by which this could be reduced to a maximum of once, but + I didn't implement that here. + */ + while(s_mp_cmp(&t, &rem) > 0) { + --q; + s_mp_sub(&t, b); + } + + /* At this point, q should be the right next digit */ + if((res = s_mp_sub(&rem, &t)) != MP_OKAY) + goto CLEANUP; + + /* + Include the digit in the quotient. We allocated enough memory + for any quotient we could ever possibly get, so we should not + have to check for failures here + */ + DIGIT(", 0) = q; + } + + /* Denormalize remainder */ + if(d != 0) + s_mp_div_2d(&rem, d); + + s_mp_clamp("); + s_mp_clamp(&rem); + + /* Copy quotient back to output */ + s_mp_exch(", a); + + /* Copy remainder back to output */ + s_mp_exch(&rem, b); + +CLEANUP: + mp_clear(&rem); +REM: + mp_clear(&t); +T: + mp_clear("); + + return res; + +} /* end s_mp_div() */ + +/* }}} */ + +/* {{{ s_mp_2expt(a, k) */ + +mp_err s_mp_2expt(mp_int *a, mp_digit k) +{ + mp_err res; + mp_size dig, bit; + + dig = k / DIGIT_BIT; + bit = k % DIGIT_BIT; + + mp_zero(a); + if((res = s_mp_pad(a, dig + 1)) != MP_OKAY) + return res; + + DIGIT(a, dig) |= (1 << bit); + + return MP_OKAY; + +} /* end s_mp_2expt() */ + +/* }}} */ + + +/* }}} */ + +/* }}} */ + +/* {{{ Primitive comparisons */ + +/* {{{ s_mp_cmp(a, b) */ + +/* Compare |a| <=> |b|, return 0 if equal, <0 if a0 if a>b */ +int s_mp_cmp(mp_int *a, mp_int *b) +{ + mp_size ua = USED(a), ub = USED(b); + + if(ua > ub) + return MP_GT; + else if(ua < ub) + return MP_LT; + else { + int ix = ua - 1; + mp_digit *ap = DIGITS(a) + ix, *bp = DIGITS(b) + ix; + + while(ix >= 0) { + if(*ap > *bp) + return MP_GT; + else if(*ap < *bp) + return MP_LT; + + --ap; --bp; --ix; + } + + return MP_EQ; + } + +} /* end s_mp_cmp() */ + +/* }}} */ + +/* {{{ s_mp_cmp_d(a, d) */ + +/* Compare |a| <=> d, return 0 if equal, <0 if a0 if a>d */ +int s_mp_cmp_d(mp_int *a, mp_digit d) +{ + mp_size ua = USED(a); + mp_digit *ap = DIGITS(a); + + if(ua > 1) + return MP_GT; + + if(*ap < d) + return MP_LT; + else if(*ap > d) + return MP_GT; + else + return MP_EQ; + +} /* end s_mp_cmp_d() */ + +/* }}} */ + +/* {{{ s_mp_ispow2(v) */ + +/* + Returns -1 if the value is not a power of two; otherwise, it returns + k such that v = 2^k, i.e. lg(v). + */ +int s_mp_ispow2(mp_int *v) +{ + mp_digit d, *dp; + mp_size uv = USED(v); + int extra = 0, ix; + + d = DIGIT(v, uv - 1); /* most significant digit of v */ + + while(d && ((d & 1) == 0)) { + d >>= 1; + ++extra; + } + + if(d == 1) { + ix = uv - 2; + dp = DIGITS(v) + ix; + + while(ix >= 0) { + if(*dp) + return -1; /* not a power of two */ + + --dp; --ix; + } + + return ((uv - 1) * DIGIT_BIT) + extra; + } + + return -1; + +} /* end s_mp_ispow2() */ + +/* }}} */ + +/* {{{ s_mp_ispow2d(d) */ + +int s_mp_ispow2d(mp_digit d) +{ + int pow = 0; + + while((d & 1) == 0) { + ++pow; d >>= 1; + } + + if(d == 1) + return pow; + + return -1; + +} /* end s_mp_ispow2d() */ + +/* }}} */ + +/* }}} */ + +/* {{{ Primitive I/O helpers */ + +/* {{{ s_mp_tovalue(ch, r) */ + +/* + Convert the given character to its digit value, in the given radix. + If the given character is not understood in the given radix, -1 is + returned. Otherwise the digit's numeric value is returned. + + The results will be odd if you use a radix < 2 or > 62, you are + expected to know what you're up to. + */ +int s_mp_tovalue(char ch, int r) +{ + int val, xch; + + if(r > 36) + xch = ch; + else + xch = toupper(ch); + + if(isdigit(xch)) + val = xch - '0'; + else if(isupper(xch)) + val = xch - 'A' + 10; + else if(islower(xch)) + val = xch - 'a' + 36; + else if(xch == '+') + val = 62; + else if(xch == '/') + val = 63; + else + return -1; + + if(val < 0 || val >= r) + return -1; + + return val; + +} /* end s_mp_tovalue() */ + +/* }}} */ + +/* {{{ s_mp_todigit(val, r, low) */ + +/* + Convert val to a radix-r digit, if possible. If val is out of range + for r, returns zero. Otherwise, returns an ASCII character denoting + the value in the given radix. + + The results may be odd if you use a radix < 2 or > 64, you are + expected to know what you're doing. + */ + +char s_mp_todigit(int val, int r, int low) +{ + char ch; + + if(val < 0 || val >= r) + return 0; + + ch = s_dmap_1[val]; + + if(r <= 36 && low) + ch = tolower(ch); + + return ch; + +} /* end s_mp_todigit() */ + +/* }}} */ + +/* {{{ s_mp_outlen(bits, radix) */ + +/* + Return an estimate for how long a string is needed to hold a radix + r representation of a number with 'bits' significant bits. + + Does not include space for a sign or a NUL terminator. + */ +int s_mp_outlen(int bits, int r) +{ + return (int)((double)bits * LOG_V_2(r)); + +} /* end s_mp_outlen() */ + +/* }}} */ + +/* }}} */ + +/*------------------------------------------------------------------------*/ +/* HERE THERE BE DRAGONS */ +/* crc==4242132123, version==2, Sat Feb 02 06:43:52 2002 */ + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/mtest/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/mtest/mpi.h Index: libtommath/mtest/mpi.h ================================================================== --- /dev/null +++ libtommath/mtest/mpi.h @@ -0,0 +1,231 @@ +/* + mpi.h + + by Michael J. Fromberger + Copyright (C) 1998 Michael J. Fromberger, All Rights Reserved + + Arbitrary precision integer arithmetic library + + $Id: mpi.h,v 1.1.1.1.2.1 2005/09/26 20:16:54 kennykb Exp $ + */ + +#ifndef _H_MPI_ +#define _H_MPI_ + +#include "mpi-config.h" + +#define MP_LT -1 +#define MP_EQ 0 +#define MP_GT 1 + +#if MP_DEBUG +#undef MP_IOFUNC +#define MP_IOFUNC 1 +#endif + +#if MP_IOFUNC +#include +#include +#endif + +#include + +#define MP_NEG 1 +#define MP_ZPOS 0 + +/* Included for compatibility... */ +#define NEG MP_NEG +#define ZPOS MP_ZPOS + +#define MP_OKAY 0 /* no error, all is well */ +#define MP_YES 0 /* yes (boolean result) */ +#define MP_NO -1 /* no (boolean result) */ +#define MP_MEM -2 /* out of memory */ +#define MP_RANGE -3 /* argument out of range */ +#define MP_BADARG -4 /* invalid parameter */ +#define MP_UNDEF -5 /* answer is undefined */ +#define MP_LAST_CODE MP_UNDEF + +#include "mpi-types.h" + +/* Included for compatibility... */ +#define DIGIT_BIT MP_DIGIT_BIT +#define DIGIT_MAX MP_DIGIT_MAX + +/* Macros for accessing the mp_int internals */ +#define SIGN(MP) ((MP)->sign) +#define USED(MP) ((MP)->used) +#define ALLOC(MP) ((MP)->alloc) +#define DIGITS(MP) ((MP)->dp) +#define DIGIT(MP,N) (MP)->dp[(N)] + +#if MP_ARGCHK == 1 +#define ARGCHK(X,Y) {if(!(X)){return (Y);}} +#elif MP_ARGCHK == 2 +#include +#define ARGCHK(X,Y) assert(X) +#else +#define ARGCHK(X,Y) /* */ +#endif + +/* This defines the maximum I/O base (minimum is 2) */ +#define MAX_RADIX 64 + +typedef struct { + mp_sign sign; /* sign of this quantity */ + mp_size alloc; /* how many digits allocated */ + mp_size used; /* how many digits used */ + mp_digit *dp; /* the digits themselves */ +} mp_int; + +/*------------------------------------------------------------------------*/ +/* Default precision */ + +unsigned int mp_get_prec(void); +void mp_set_prec(unsigned int prec); + +/*------------------------------------------------------------------------*/ +/* Memory management */ + +mp_err mp_init(mp_int *mp); +mp_err mp_init_array(mp_int mp[], int count); +mp_err mp_init_size(mp_int *mp, mp_size prec); +mp_err mp_init_copy(mp_int *mp, mp_int *from); +mp_err mp_copy(mp_int *from, mp_int *to); +void mp_exch(mp_int *mp1, mp_int *mp2); +void mp_clear(mp_int *mp); +void mp_clear_array(mp_int mp[], int count); +void mp_zero(mp_int *mp); +void mp_set(mp_int *mp, mp_digit d); +mp_err mp_set_int(mp_int *mp, long z); +mp_err mp_shrink(mp_int *a); + + +/*------------------------------------------------------------------------*/ +/* Single digit arithmetic */ + +mp_err mp_add_d(mp_int *a, mp_digit d, mp_int *b); +mp_err mp_sub_d(mp_int *a, mp_digit d, mp_int *b); +mp_err mp_mul_d(mp_int *a, mp_digit d, mp_int *b); +mp_err mp_mul_2(mp_int *a, mp_int *c); +mp_err mp_div_d(mp_int *a, mp_digit d, mp_int *q, mp_digit *r); +mp_err mp_div_2(mp_int *a, mp_int *c); +mp_err mp_expt_d(mp_int *a, mp_digit d, mp_int *c); + +/*------------------------------------------------------------------------*/ +/* Sign manipulations */ + +mp_err mp_abs(mp_int *a, mp_int *b); +mp_err mp_neg(mp_int *a, mp_int *b); + +/*------------------------------------------------------------------------*/ +/* Full arithmetic */ + +mp_err mp_add(mp_int *a, mp_int *b, mp_int *c); +mp_err mp_sub(mp_int *a, mp_int *b, mp_int *c); +mp_err mp_mul(mp_int *a, mp_int *b, mp_int *c); +mp_err mp_mul_2d(mp_int *a, mp_digit d, mp_int *c); +#if MP_SQUARE +mp_err mp_sqr(mp_int *a, mp_int *b); +#else +#define mp_sqr(a, b) mp_mul(a, a, b) +#endif +mp_err mp_div(mp_int *a, mp_int *b, mp_int *q, mp_int *r); +mp_err mp_div_2d(mp_int *a, mp_digit d, mp_int *q, mp_int *r); +mp_err mp_expt(mp_int *a, mp_int *b, mp_int *c); +mp_err mp_2expt(mp_int *a, mp_digit k); +mp_err mp_sqrt(mp_int *a, mp_int *b); + +/*------------------------------------------------------------------------*/ +/* Modular arithmetic */ + +#if MP_MODARITH +mp_err mp_mod(mp_int *a, mp_int *m, mp_int *c); +mp_err mp_mod_d(mp_int *a, mp_digit d, mp_digit *c); +mp_err mp_addmod(mp_int *a, mp_int *b, mp_int *m, mp_int *c); +mp_err mp_submod(mp_int *a, mp_int *b, mp_int *m, mp_int *c); +mp_err mp_mulmod(mp_int *a, mp_int *b, mp_int *m, mp_int *c); +#if MP_SQUARE +mp_err mp_sqrmod(mp_int *a, mp_int *m, mp_int *c); +#else +#define mp_sqrmod(a, m, c) mp_mulmod(a, a, m, c) +#endif +mp_err mp_exptmod(mp_int *a, mp_int *b, mp_int *m, mp_int *c); +mp_err mp_exptmod_d(mp_int *a, mp_digit d, mp_int *m, mp_int *c); +#endif /* MP_MODARITH */ + +/*------------------------------------------------------------------------*/ +/* Comparisons */ + +int mp_cmp_z(mp_int *a); +int mp_cmp_d(mp_int *a, mp_digit d); +int mp_cmp(mp_int *a, mp_int *b); +int mp_cmp_mag(mp_int *a, mp_int *b); +int mp_cmp_int(mp_int *a, long z); +int mp_isodd(mp_int *a); +int mp_iseven(mp_int *a); + +/*------------------------------------------------------------------------*/ +/* Number theoretic */ + +#if MP_NUMTH +mp_err mp_gcd(mp_int *a, mp_int *b, mp_int *c); +mp_err mp_lcm(mp_int *a, mp_int *b, mp_int *c); +mp_err mp_xgcd(mp_int *a, mp_int *b, mp_int *g, mp_int *x, mp_int *y); +mp_err mp_invmod(mp_int *a, mp_int *m, mp_int *c); +#endif /* end MP_NUMTH */ + +/*------------------------------------------------------------------------*/ +/* Input and output */ + +#if MP_IOFUNC +void mp_print(mp_int *mp, FILE *ofp); +#endif /* end MP_IOFUNC */ + +/*------------------------------------------------------------------------*/ +/* Base conversion */ + +#define BITS 1 +#define BYTES CHAR_BIT + +mp_err mp_read_signed_bin(mp_int *mp, unsigned char *str, int len); +int mp_signed_bin_size(mp_int *mp); +mp_err mp_to_signed_bin(mp_int *mp, unsigned char *str); + +mp_err mp_read_unsigned_bin(mp_int *mp, unsigned char *str, int len); +int mp_unsigned_bin_size(mp_int *mp); +mp_err mp_to_unsigned_bin(mp_int *mp, unsigned char *str); + +int mp_count_bits(mp_int *mp); + +#if MP_COMPAT_MACROS +#define mp_read_raw(mp, str, len) mp_read_signed_bin((mp), (str), (len)) +#define mp_raw_size(mp) mp_signed_bin_size(mp) +#define mp_toraw(mp, str) mp_to_signed_bin((mp), (str)) +#define mp_read_mag(mp, str, len) mp_read_unsigned_bin((mp), (str), (len)) +#define mp_mag_size(mp) mp_unsigned_bin_size(mp) +#define mp_tomag(mp, str) mp_to_unsigned_bin((mp), (str)) +#endif + +mp_err mp_read_radix(mp_int *mp, unsigned char *str, int radix); +int mp_radix_size(mp_int *mp, int radix); +int mp_value_radix_size(int num, int qty, int radix); +mp_err mp_toradix(mp_int *mp, unsigned char *str, int radix); + +int mp_char2value(char ch, int r); + +#define mp_tobinary(M, S) mp_toradix((M), (S), 2) +#define mp_tooctal(M, S) mp_toradix((M), (S), 8) +#define mp_todecimal(M, S) mp_toradix((M), (S), 10) +#define mp_tohex(M, S) mp_toradix((M), (S), 16) + +/*------------------------------------------------------------------------*/ +/* Error strings */ + +const char *mp_strerror(mp_err ec); + +#endif /* end _H_MPI_ */ + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/mtest/mpi.h,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/mtest/mtest.c Index: libtommath/mtest/mtest.c ================================================================== --- /dev/null +++ libtommath/mtest/mtest.c @@ -0,0 +1,308 @@ +/* makes a bignum test harness with NUM tests per operation + * + * the output is made in the following format [one parameter per line] + +operation +operand1 +operand2 +[... operandN] +result1 +result2 +[... resultN] + +So for example "a * b mod n" would be + +mulmod +a +b +n +a*b mod n + +e.g. if a=3, b=4 n=11 then + +mulmod +3 +4 +11 +1 + + */ + +#ifdef MP_8BIT +#define THE_MASK 127 +#else +#define THE_MASK 32767 +#endif + +#include +#include +#include +#include "mpi.c" + +FILE *rng; + +void rand_num(mp_int *a) +{ + int n, size; + unsigned char buf[2048]; + + size = 1 + ((fgetc(rng)<<8) + fgetc(rng)) % 101; + buf[0] = (fgetc(rng)&1)?1:0; + fread(buf+1, 1, size, rng); + while (buf[1] == 0) buf[1] = fgetc(rng); + mp_read_raw(a, buf, 1+size); +} + +void rand_num2(mp_int *a) +{ + int n, size; + unsigned char buf[2048]; + + size = 10 + ((fgetc(rng)<<8) + fgetc(rng)) % 101; + buf[0] = (fgetc(rng)&1)?1:0; + fread(buf+1, 1, size, rng); + while (buf[1] == 0) buf[1] = fgetc(rng); + mp_read_raw(a, buf, 1+size); +} + +#define mp_to64(a, b) mp_toradix(a, b, 64) + +int main(void) +{ + int n, tmp; + mp_int a, b, c, d, e; + clock_t t1; + char buf[4096]; + + mp_init(&a); + mp_init(&b); + mp_init(&c); + mp_init(&d); + mp_init(&e); + + + /* initial (2^n - 1)^2 testing, makes sure the comba multiplier works [it has the new carry code] */ +/* + mp_set(&a, 1); + for (n = 1; n < 8192; n++) { + mp_mul(&a, &a, &c); + printf("mul\n"); + mp_to64(&a, buf); + printf("%s\n%s\n", buf, buf); + mp_to64(&c, buf); + printf("%s\n", buf); + + mp_add_d(&a, 1, &a); + mp_mul_2(&a, &a); + mp_sub_d(&a, 1, &a); + } +*/ + + rng = fopen("/dev/urandom", "rb"); + if (rng == NULL) { + rng = fopen("/dev/random", "rb"); + if (rng == NULL) { + fprintf(stderr, "\nWarning: stdin used as random source\n\n"); + rng = stdin; + } + } + + t1 = clock(); + for (;;) { +#if 0 + if (clock() - t1 > CLOCKS_PER_SEC) { + sleep(2); + t1 = clock(); + } +#endif + n = fgetc(rng) % 15; + + if (n == 0) { + /* add tests */ + rand_num(&a); + rand_num(&b); + mp_add(&a, &b, &c); + printf("add\n"); + mp_to64(&a, buf); + printf("%s\n", buf); + mp_to64(&b, buf); + printf("%s\n", buf); + mp_to64(&c, buf); + printf("%s\n", buf); + } else if (n == 1) { + /* sub tests */ + rand_num(&a); + rand_num(&b); + mp_sub(&a, &b, &c); + printf("sub\n"); + mp_to64(&a, buf); + printf("%s\n", buf); + mp_to64(&b, buf); + printf("%s\n", buf); + mp_to64(&c, buf); + printf("%s\n", buf); + } else if (n == 2) { + /* mul tests */ + rand_num(&a); + rand_num(&b); + mp_mul(&a, &b, &c); + printf("mul\n"); + mp_to64(&a, buf); + printf("%s\n", buf); + mp_to64(&b, buf); + printf("%s\n", buf); + mp_to64(&c, buf); + printf("%s\n", buf); + } else if (n == 3) { + /* div tests */ + rand_num(&a); + rand_num(&b); + mp_div(&a, &b, &c, &d); + printf("div\n"); + mp_to64(&a, buf); + printf("%s\n", buf); + mp_to64(&b, buf); + printf("%s\n", buf); + mp_to64(&c, buf); + printf("%s\n", buf); + mp_to64(&d, buf); + printf("%s\n", buf); + } else if (n == 4) { + /* sqr tests */ + rand_num(&a); + mp_sqr(&a, &b); + printf("sqr\n"); + mp_to64(&a, buf); + printf("%s\n", buf); + mp_to64(&b, buf); + printf("%s\n", buf); + } else if (n == 5) { + /* mul_2d test */ + rand_num(&a); + mp_copy(&a, &b); + n = fgetc(rng) & 63; + mp_mul_2d(&b, n, &b); + mp_to64(&a, buf); + printf("mul2d\n"); + printf("%s\n", buf); + printf("%d\n", n); + mp_to64(&b, buf); + printf("%s\n", buf); + } else if (n == 6) { + /* div_2d test */ + rand_num(&a); + mp_copy(&a, &b); + n = fgetc(rng) & 63; + mp_div_2d(&b, n, &b, NULL); + mp_to64(&a, buf); + printf("div2d\n"); + printf("%s\n", buf); + printf("%d\n", n); + mp_to64(&b, buf); + printf("%s\n", buf); + } else if (n == 7) { + /* gcd test */ + rand_num(&a); + rand_num(&b); + a.sign = MP_ZPOS; + b.sign = MP_ZPOS; + mp_gcd(&a, &b, &c); + printf("gcd\n"); + mp_to64(&a, buf); + printf("%s\n", buf); + mp_to64(&b, buf); + printf("%s\n", buf); + mp_to64(&c, buf); + printf("%s\n", buf); + } else if (n == 8) { + /* lcm test */ + rand_num(&a); + rand_num(&b); + a.sign = MP_ZPOS; + b.sign = MP_ZPOS; + mp_lcm(&a, &b, &c); + printf("lcm\n"); + mp_to64(&a, buf); + printf("%s\n", buf); + mp_to64(&b, buf); + printf("%s\n", buf); + mp_to64(&c, buf); + printf("%s\n", buf); + } else if (n == 9) { + /* exptmod test */ + rand_num2(&a); + rand_num2(&b); + rand_num2(&c); +// if (c.dp[0]&1) mp_add_d(&c, 1, &c); + a.sign = b.sign = c.sign = 0; + mp_exptmod(&a, &b, &c, &d); + printf("expt\n"); + mp_to64(&a, buf); + printf("%s\n", buf); + mp_to64(&b, buf); + printf("%s\n", buf); + mp_to64(&c, buf); + printf("%s\n", buf); + mp_to64(&d, buf); + printf("%s\n", buf); + } else if (n == 10) { + /* invmod test */ + rand_num2(&a); + rand_num2(&b); + b.sign = MP_ZPOS; + a.sign = MP_ZPOS; + mp_gcd(&a, &b, &c); + if (mp_cmp_d(&c, 1) != 0) continue; + if (mp_cmp_d(&b, 1) == 0) continue; + mp_invmod(&a, &b, &c); + printf("invmod\n"); + mp_to64(&a, buf); + printf("%s\n", buf); + mp_to64(&b, buf); + printf("%s\n", buf); + mp_to64(&c, buf); + printf("%s\n", buf); + } else if (n == 11) { + rand_num(&a); + mp_mul_2(&a, &a); + mp_div_2(&a, &b); + printf("div2\n"); + mp_to64(&a, buf); + printf("%s\n", buf); + mp_to64(&b, buf); + printf("%s\n", buf); + } else if (n == 12) { + rand_num2(&a); + mp_mul_2(&a, &b); + printf("mul2\n"); + mp_to64(&a, buf); + printf("%s\n", buf); + mp_to64(&b, buf); + printf("%s\n", buf); + } else if (n == 13) { + rand_num2(&a); + tmp = abs(rand()) & THE_MASK; + mp_add_d(&a, tmp, &b); + printf("add_d\n"); + mp_to64(&a, buf); + printf("%s\n%d\n", buf, tmp); + mp_to64(&b, buf); + printf("%s\n", buf); + } else if (n == 14) { + rand_num2(&a); + tmp = abs(rand()) & THE_MASK; + mp_sub_d(&a, tmp, &b); + printf("sub_d\n"); + mp_to64(&a, buf); + printf("%s\n%d\n", buf, tmp); + mp_to64(&b, buf); + printf("%s\n", buf); + } + } + fclose(rng); + return 0; +} + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/mtest/mtest.c,v $ */ +/* $Revision: 1.1.1.1.2.1 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/pics/expt_state.tif Index: libtommath/pics/expt_state.tif ================================================================== --- /dev/null +++ libtommath/pics/expt_state.tif cannot compute difference between binary files ADDED libtommath/pics/primality.tif Index: libtommath/pics/primality.tif ================================================================== --- /dev/null +++ libtommath/pics/primality.tif cannot compute difference between binary files ADDED libtommath/poster.pdf Index: libtommath/poster.pdf ================================================================== --- /dev/null +++ libtommath/poster.pdf cannot compute difference between binary files ADDED libtommath/pre_gen/mpi.c Index: libtommath/pre_gen/mpi.c ================================================================== --- /dev/null +++ libtommath/pre_gen/mpi.c @@ -0,0 +1,9519 @@ +/* Start: bn_error.c */ +#include +#ifdef BN_ERROR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +static const struct { + int code; + char *msg; +} msgs[] = { + { MP_OKAY, "Successful" }, + { MP_MEM, "Out of heap" }, + { MP_VAL, "Value out of range" } +}; + +/* return a char * string for a given code */ +char *mp_error_to_string(int code) +{ + int x; + + /* scan the lookup table for the given message */ + for (x = 0; x < (int)(sizeof(msgs) / sizeof(msgs[0])); x++) { + if (msgs[x].code == code) { + return msgs[x].msg; + } + } + + /* generic reply for invalid code */ + return "Invalid error code"; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_error.c */ + +/* Start: bn_fast_mp_invmod.c */ +#include +#ifdef BN_FAST_MP_INVMOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* computes the modular inverse via binary extended euclidean algorithm, + * that is c = 1/a mod b + * + * Based on slow invmod except this is optimized for the case where b is + * odd as per HAC Note 14.64 on pp. 610 + */ +int fast_mp_invmod (mp_int * a, mp_int * b, mp_int * c) +{ + mp_int x, y, u, v, B, D; + int res, neg; + + /* 2. [modified] b must be odd */ + if (mp_iseven (b) == 1) { + return MP_VAL; + } + + /* init all our temps */ + if ((res = mp_init_multi(&x, &y, &u, &v, &B, &D, NULL)) != MP_OKAY) { + return res; + } + + /* x == modulus, y == value to invert */ + if ((res = mp_copy (b, &x)) != MP_OKAY) { + goto LBL_ERR; + } + + /* we need y = |a| */ + if ((res = mp_mod (a, b, &y)) != MP_OKAY) { + goto LBL_ERR; + } + + /* 3. u=x, v=y, A=1, B=0, C=0,D=1 */ + if ((res = mp_copy (&x, &u)) != MP_OKAY) { + goto LBL_ERR; + } + if ((res = mp_copy (&y, &v)) != MP_OKAY) { + goto LBL_ERR; + } + mp_set (&D, 1); + +top: + /* 4. while u is even do */ + while (mp_iseven (&u) == 1) { + /* 4.1 u = u/2 */ + if ((res = mp_div_2 (&u, &u)) != MP_OKAY) { + goto LBL_ERR; + } + /* 4.2 if B is odd then */ + if (mp_isodd (&B) == 1) { + if ((res = mp_sub (&B, &x, &B)) != MP_OKAY) { + goto LBL_ERR; + } + } + /* B = B/2 */ + if ((res = mp_div_2 (&B, &B)) != MP_OKAY) { + goto LBL_ERR; + } + } + + /* 5. while v is even do */ + while (mp_iseven (&v) == 1) { + /* 5.1 v = v/2 */ + if ((res = mp_div_2 (&v, &v)) != MP_OKAY) { + goto LBL_ERR; + } + /* 5.2 if D is odd then */ + if (mp_isodd (&D) == 1) { + /* D = (D-x)/2 */ + if ((res = mp_sub (&D, &x, &D)) != MP_OKAY) { + goto LBL_ERR; + } + } + /* D = D/2 */ + if ((res = mp_div_2 (&D, &D)) != MP_OKAY) { + goto LBL_ERR; + } + } + + /* 6. if u >= v then */ + if (mp_cmp (&u, &v) != MP_LT) { + /* u = u - v, B = B - D */ + if ((res = mp_sub (&u, &v, &u)) != MP_OKAY) { + goto LBL_ERR; + } + + if ((res = mp_sub (&B, &D, &B)) != MP_OKAY) { + goto LBL_ERR; + } + } else { + /* v - v - u, D = D - B */ + if ((res = mp_sub (&v, &u, &v)) != MP_OKAY) { + goto LBL_ERR; + } + + if ((res = mp_sub (&D, &B, &D)) != MP_OKAY) { + goto LBL_ERR; + } + } + + /* if not zero goto step 4 */ + if (mp_iszero (&u) == 0) { + goto top; + } + + /* now a = C, b = D, gcd == g*v */ + + /* if v != 1 then there is no inverse */ + if (mp_cmp_d (&v, 1) != MP_EQ) { + res = MP_VAL; + goto LBL_ERR; + } + + /* b is now the inverse */ + neg = a->sign; + while (D.sign == MP_NEG) { + if ((res = mp_add (&D, b, &D)) != MP_OKAY) { + goto LBL_ERR; + } + } + mp_exch (&D, c); + c->sign = neg; + res = MP_OKAY; + +LBL_ERR:mp_clear_multi (&x, &y, &u, &v, &B, &D, NULL); + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_fast_mp_invmod.c */ + +/* Start: bn_fast_mp_montgomery_reduce.c */ +#include +#ifdef BN_FAST_MP_MONTGOMERY_REDUCE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* computes xR**-1 == x (mod N) via Montgomery Reduction + * + * This is an optimized implementation of montgomery_reduce + * which uses the comba method to quickly calculate the columns of the + * reduction. + * + * Based on Algorithm 14.32 on pp.601 of HAC. +*/ +int fast_mp_montgomery_reduce (mp_int * x, mp_int * n, mp_digit rho) +{ + int ix, res, olduse; + mp_word W[MP_WARRAY]; + + /* get old used count */ + olduse = x->used; + + /* grow a as required */ + if (x->alloc < n->used + 1) { + if ((res = mp_grow (x, n->used + 1)) != MP_OKAY) { + return res; + } + } + + /* first we have to get the digits of the input into + * an array of double precision words W[...] + */ + { + register mp_word *_W; + register mp_digit *tmpx; + + /* alias for the W[] array */ + _W = W; + + /* alias for the digits of x*/ + tmpx = x->dp; + + /* copy the digits of a into W[0..a->used-1] */ + for (ix = 0; ix < x->used; ix++) { + *_W++ = *tmpx++; + } + + /* zero the high words of W[a->used..m->used*2] */ + for (; ix < n->used * 2 + 1; ix++) { + *_W++ = 0; + } + } + + /* now we proceed to zero successive digits + * from the least significant upwards + */ + for (ix = 0; ix < n->used; ix++) { + /* mu = ai * m' mod b + * + * We avoid a double precision multiplication (which isn't required) + * by casting the value down to a mp_digit. Note this requires + * that W[ix-1] have the carry cleared (see after the inner loop) + */ + register mp_digit mu; + mu = (mp_digit) (((W[ix] & MP_MASK) * rho) & MP_MASK); + + /* a = a + mu * m * b**i + * + * This is computed in place and on the fly. The multiplication + * by b**i is handled by offseting which columns the results + * are added to. + * + * Note the comba method normally doesn't handle carries in the + * inner loop In this case we fix the carry from the previous + * column since the Montgomery reduction requires digits of the + * result (so far) [see above] to work. This is + * handled by fixing up one carry after the inner loop. The + * carry fixups are done in order so after these loops the + * first m->used words of W[] have the carries fixed + */ + { + register int iy; + register mp_digit *tmpn; + register mp_word *_W; + + /* alias for the digits of the modulus */ + tmpn = n->dp; + + /* Alias for the columns set by an offset of ix */ + _W = W + ix; + + /* inner loop */ + for (iy = 0; iy < n->used; iy++) { + *_W++ += ((mp_word)mu) * ((mp_word)*tmpn++); + } + } + + /* now fix carry for next digit, W[ix+1] */ + W[ix + 1] += W[ix] >> ((mp_word) DIGIT_BIT); + } + + /* now we have to propagate the carries and + * shift the words downward [all those least + * significant digits we zeroed]. + */ + { + register mp_digit *tmpx; + register mp_word *_W, *_W1; + + /* nox fix rest of carries */ + + /* alias for current word */ + _W1 = W + ix; + + /* alias for next word, where the carry goes */ + _W = W + ++ix; + + for (; ix <= n->used * 2 + 1; ix++) { + *_W++ += *_W1++ >> ((mp_word) DIGIT_BIT); + } + + /* copy out, A = A/b**n + * + * The result is A/b**n but instead of converting from an + * array of mp_word to mp_digit than calling mp_rshd + * we just copy them in the right order + */ + + /* alias for destination word */ + tmpx = x->dp; + + /* alias for shifted double precision result */ + _W = W + n->used; + + for (ix = 0; ix < n->used + 1; ix++) { + *tmpx++ = (mp_digit)(*_W++ & ((mp_word) MP_MASK)); + } + + /* zero oldused digits, if the input a was larger than + * m->used+1 we'll have to clear the digits + */ + for (; ix < olduse; ix++) { + *tmpx++ = 0; + } + } + + /* set the max used and clamp */ + x->used = n->used + 1; + mp_clamp (x); + + /* if A >= m then A = A - m */ + if (mp_cmp_mag (x, n) != MP_LT) { + return s_mp_sub (x, n, x); + } + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_fast_mp_montgomery_reduce.c */ + +/* Start: bn_fast_s_mp_mul_digs.c */ +#include +#ifdef BN_FAST_S_MP_MUL_DIGS_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* Fast (comba) multiplier + * + * This is the fast column-array [comba] multiplier. It is + * designed to compute the columns of the product first + * then handle the carries afterwards. This has the effect + * of making the nested loops that compute the columns very + * simple and schedulable on super-scalar processors. + * + * This has been modified to produce a variable number of + * digits of output so if say only a half-product is required + * you don't have to compute the upper half (a feature + * required for fast Barrett reduction). + * + * Based on Algorithm 14.12 on pp.595 of HAC. + * + */ +int fast_s_mp_mul_digs (mp_int * a, mp_int * b, mp_int * c, int digs) +{ + int olduse, res, pa, ix, iz; + mp_digit W[MP_WARRAY]; + register mp_word _W; + + /* grow the destination as required */ + if (c->alloc < digs) { + if ((res = mp_grow (c, digs)) != MP_OKAY) { + return res; + } + } + + /* number of output digits to produce */ + pa = MIN(digs, a->used + b->used); + + /* clear the carry */ + _W = 0; + for (ix = 0; ix < pa; ix++) { + int tx, ty; + int iy; + mp_digit *tmpx, *tmpy; + + /* get offsets into the two bignums */ + ty = MIN(b->used-1, ix); + tx = ix - ty; + + /* setup temp aliases */ + tmpx = a->dp + tx; + tmpy = b->dp + ty; + + /* this is the number of times the loop will iterrate, essentially + while (tx++ < a->used && ty-- >= 0) { ... } + */ + iy = MIN(a->used-tx, ty+1); + + /* execute loop */ + for (iz = 0; iz < iy; ++iz) { + _W += ((mp_word)*tmpx++)*((mp_word)*tmpy--); + + } + + /* store term */ + W[ix] = ((mp_digit)_W) & MP_MASK; + + /* make next carry */ + _W = _W >> ((mp_word)DIGIT_BIT); + } + + /* store final carry */ + W[ix] = (mp_digit)(_W & MP_MASK); + + /* setup dest */ + olduse = c->used; + c->used = pa; + + { + register mp_digit *tmpc; + tmpc = c->dp; + for (ix = 0; ix < pa+1; ix++) { + /* now extract the previous digit [below the carry] */ + *tmpc++ = W[ix]; + } + + /* clear unused digits [that existed in the old copy of c] */ + for (; ix < olduse; ix++) { + *tmpc++ = 0; + } + } + mp_clamp (c); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_fast_s_mp_mul_digs.c */ + +/* Start: bn_fast_s_mp_mul_high_digs.c */ +#include +#ifdef BN_FAST_S_MP_MUL_HIGH_DIGS_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* this is a modified version of fast_s_mul_digs that only produces + * output digits *above* digs. See the comments for fast_s_mul_digs + * to see how it works. + * + * This is used in the Barrett reduction since for one of the multiplications + * only the higher digits were needed. This essentially halves the work. + * + * Based on Algorithm 14.12 on pp.595 of HAC. + */ +int fast_s_mp_mul_high_digs (mp_int * a, mp_int * b, mp_int * c, int digs) +{ + int olduse, res, pa, ix, iz; + mp_digit W[MP_WARRAY]; + mp_word _W; + + /* grow the destination as required */ + pa = a->used + b->used; + if (c->alloc < pa) { + if ((res = mp_grow (c, pa)) != MP_OKAY) { + return res; + } + } + + /* number of output digits to produce */ + pa = a->used + b->used; + _W = 0; + for (ix = digs; ix < pa; ix++) { + int tx, ty, iy; + mp_digit *tmpx, *tmpy; + + /* get offsets into the two bignums */ + ty = MIN(b->used-1, ix); + tx = ix - ty; + + /* setup temp aliases */ + tmpx = a->dp + tx; + tmpy = b->dp + ty; + + /* this is the number of times the loop will iterrate, essentially its + while (tx++ < a->used && ty-- >= 0) { ... } + */ + iy = MIN(a->used-tx, ty+1); + + /* execute loop */ + for (iz = 0; iz < iy; iz++) { + _W += ((mp_word)*tmpx++)*((mp_word)*tmpy--); + } + + /* store term */ + W[ix] = ((mp_digit)_W) & MP_MASK; + + /* make next carry */ + _W = _W >> ((mp_word)DIGIT_BIT); + } + + /* store final carry */ + W[ix] = (mp_digit)(_W & MP_MASK); + + /* setup dest */ + olduse = c->used; + c->used = pa; + + { + register mp_digit *tmpc; + + tmpc = c->dp + digs; + for (ix = digs; ix <= pa; ix++) { + /* now extract the previous digit [below the carry] */ + *tmpc++ = W[ix]; + } + + /* clear unused digits [that existed in the old copy of c] */ + for (; ix < olduse; ix++) { + *tmpc++ = 0; + } + } + mp_clamp (c); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_fast_s_mp_mul_high_digs.c */ + +/* Start: bn_fast_s_mp_sqr.c */ +#include +#ifdef BN_FAST_S_MP_SQR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* the jist of squaring... + * you do like mult except the offset of the tmpx [one that + * starts closer to zero] can't equal the offset of tmpy. + * So basically you set up iy like before then you min it with + * (ty-tx) so that it never happens. You double all those + * you add in the inner loop + +After that loop you do the squares and add them in. +*/ + +int fast_s_mp_sqr (mp_int * a, mp_int * b) +{ + int olduse, res, pa, ix, iz; + mp_digit W[MP_WARRAY], *tmpx; + mp_word W1; + + /* grow the destination as required */ + pa = a->used + a->used; + if (b->alloc < pa) { + if ((res = mp_grow (b, pa)) != MP_OKAY) { + return res; + } + } + + /* number of output digits to produce */ + W1 = 0; + for (ix = 0; ix < pa; ix++) { + int tx, ty, iy; + mp_word _W; + mp_digit *tmpy; + + /* clear counter */ + _W = 0; + + /* get offsets into the two bignums */ + ty = MIN(a->used-1, ix); + tx = ix - ty; + + /* setup temp aliases */ + tmpx = a->dp + tx; + tmpy = a->dp + ty; + + /* this is the number of times the loop will iterrate, essentially + while (tx++ < a->used && ty-- >= 0) { ... } + */ + iy = MIN(a->used-tx, ty+1); + + /* now for squaring tx can never equal ty + * we halve the distance since they approach at a rate of 2x + * and we have to round because odd cases need to be executed + */ + iy = MIN(iy, (ty-tx+1)>>1); + + /* execute loop */ + for (iz = 0; iz < iy; iz++) { + _W += ((mp_word)*tmpx++)*((mp_word)*tmpy--); + } + + /* double the inner product and add carry */ + _W = _W + _W + W1; + + /* even columns have the square term in them */ + if ((ix&1) == 0) { + _W += ((mp_word)a->dp[ix>>1])*((mp_word)a->dp[ix>>1]); + } + + /* store it */ + W[ix] = (mp_digit)(_W & MP_MASK); + + /* make next carry */ + W1 = _W >> ((mp_word)DIGIT_BIT); + } + + /* setup dest */ + olduse = b->used; + b->used = a->used+a->used; + + { + mp_digit *tmpb; + tmpb = b->dp; + for (ix = 0; ix < pa; ix++) { + *tmpb++ = W[ix] & MP_MASK; + } + + /* clear unused digits [that existed in the old copy of c] */ + for (; ix < olduse; ix++) { + *tmpb++ = 0; + } + } + mp_clamp (b); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_fast_s_mp_sqr.c */ + +/* Start: bn_mp_2expt.c */ +#include +#ifdef BN_MP_2EXPT_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* computes a = 2**b + * + * Simple algorithm which zeroes the int, grows it then just sets one bit + * as required. + */ +int +mp_2expt (mp_int * a, int b) +{ + int res; + + /* zero a as per default */ + mp_zero (a); + + /* grow a to accomodate the single bit */ + if ((res = mp_grow (a, b / DIGIT_BIT + 1)) != MP_OKAY) { + return res; + } + + /* set the used count of where the bit will go */ + a->used = b / DIGIT_BIT + 1; + + /* put the single bit in its place */ + a->dp[b / DIGIT_BIT] = ((mp_digit)1) << (b % DIGIT_BIT); + + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_2expt.c */ + +/* Start: bn_mp_abs.c */ +#include +#ifdef BN_MP_ABS_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* b = |a| + * + * Simple function copies the input and fixes the sign to positive + */ +int +mp_abs (mp_int * a, mp_int * b) +{ + int res; + + /* copy a to b */ + if (a != b) { + if ((res = mp_copy (a, b)) != MP_OKAY) { + return res; + } + } + + /* force the sign of b to positive */ + b->sign = MP_ZPOS; + + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_abs.c */ + +/* Start: bn_mp_add.c */ +#include +#ifdef BN_MP_ADD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* high level addition (handles signs) */ +int mp_add (mp_int * a, mp_int * b, mp_int * c) +{ + int sa, sb, res; + + /* get sign of both inputs */ + sa = a->sign; + sb = b->sign; + + /* handle two cases, not four */ + if (sa == sb) { + /* both positive or both negative */ + /* add their magnitudes, copy the sign */ + c->sign = sa; + res = s_mp_add (a, b, c); + } else { + /* one positive, the other negative */ + /* subtract the one with the greater magnitude from */ + /* the one of the lesser magnitude. The result gets */ + /* the sign of the one with the greater magnitude. */ + if (mp_cmp_mag (a, b) == MP_LT) { + c->sign = sb; + res = s_mp_sub (b, a, c); + } else { + c->sign = sa; + res = s_mp_sub (a, b, c); + } + } + return res; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_add.c */ + +/* Start: bn_mp_add_d.c */ +#include +#ifdef BN_MP_ADD_D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* single digit addition */ +int +mp_add_d (mp_int * a, mp_digit b, mp_int * c) +{ + int res, ix, oldused; + mp_digit *tmpa, *tmpc, mu; + + /* grow c as required */ + if (c->alloc < a->used + 1) { + if ((res = mp_grow(c, a->used + 1)) != MP_OKAY) { + return res; + } + } + + /* if a is negative and |a| >= b, call c = |a| - b */ + if (a->sign == MP_NEG && (a->used > 1 || a->dp[0] >= b)) { + /* temporarily fix sign of a */ + a->sign = MP_ZPOS; + + /* c = |a| - b */ + res = mp_sub_d(a, b, c); + + /* fix sign */ + a->sign = c->sign = MP_NEG; + + return res; + } + + /* old number of used digits in c */ + oldused = c->used; + + /* sign always positive */ + c->sign = MP_ZPOS; + + /* source alias */ + tmpa = a->dp; + + /* destination alias */ + tmpc = c->dp; + + /* if a is positive */ + if (a->sign == MP_ZPOS) { + /* add digit, after this we're propagating + * the carry. + */ + *tmpc = *tmpa++ + b; + mu = *tmpc >> DIGIT_BIT; + *tmpc++ &= MP_MASK; + + /* now handle rest of the digits */ + for (ix = 1; ix < a->used; ix++) { + *tmpc = *tmpa++ + mu; + mu = *tmpc >> DIGIT_BIT; + *tmpc++ &= MP_MASK; + } + /* set final carry */ + ix++; + *tmpc++ = mu; + + /* setup size */ + c->used = a->used + 1; + } else { + /* a was negative and |a| < b */ + c->used = 1; + + /* the result is a single digit */ + if (a->used == 1) { + *tmpc++ = b - a->dp[0]; + } else { + *tmpc++ = b; + } + + /* setup count so the clearing of oldused + * can fall through correctly + */ + ix = 1; + } + + /* now zero to oldused */ + while (ix++ < oldused) { + *tmpc++ = 0; + } + mp_clamp(c); + + return MP_OKAY; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_add_d.c */ + +/* Start: bn_mp_addmod.c */ +#include +#ifdef BN_MP_ADDMOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* d = a + b (mod c) */ +int +mp_addmod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) +{ + int res; + mp_int t; + + if ((res = mp_init (&t)) != MP_OKAY) { + return res; + } + + if ((res = mp_add (a, b, &t)) != MP_OKAY) { + mp_clear (&t); + return res; + } + res = mp_mod (&t, c, d); + mp_clear (&t); + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_addmod.c */ + +/* Start: bn_mp_and.c */ +#include +#ifdef BN_MP_AND_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* AND two ints together */ +int +mp_and (mp_int * a, mp_int * b, mp_int * c) +{ + int res, ix, px; + mp_int t, *x; + + if (a->used > b->used) { + if ((res = mp_init_copy (&t, a)) != MP_OKAY) { + return res; + } + px = b->used; + x = b; + } else { + if ((res = mp_init_copy (&t, b)) != MP_OKAY) { + return res; + } + px = a->used; + x = a; + } + + for (ix = 0; ix < px; ix++) { + t.dp[ix] &= x->dp[ix]; + } + + /* zero digits above the last from the smallest mp_int */ + for (; ix < t.used; ix++) { + t.dp[ix] = 0; + } + + mp_clamp (&t); + mp_exch (c, &t); + mp_clear (&t); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_and.c */ + +/* Start: bn_mp_clamp.c */ +#include +#ifdef BN_MP_CLAMP_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* trim unused digits + * + * This is used to ensure that leading zero digits are + * trimed and the leading "used" digit will be non-zero + * Typically very fast. Also fixes the sign if there + * are no more leading digits + */ +void +mp_clamp (mp_int * a) +{ + /* decrease used while the most significant digit is + * zero. + */ + while (a->used > 0 && a->dp[a->used - 1] == 0) { + --(a->used); + } + + /* reset the sign flag if used == 0 */ + if (a->used == 0) { + a->sign = MP_ZPOS; + } +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_clamp.c */ + +/* Start: bn_mp_clear.c */ +#include +#ifdef BN_MP_CLEAR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* clear one (frees) */ +void +mp_clear (mp_int * a) +{ + int i; + + /* only do anything if a hasn't been freed previously */ + if (a->dp != NULL) { + /* first zero the digits */ + for (i = 0; i < a->used; i++) { + a->dp[i] = 0; + } + + /* free ram */ + XFREE(a->dp); + + /* reset members to make debugging easier */ + a->dp = NULL; + a->alloc = a->used = 0; + a->sign = MP_ZPOS; + } +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_clear.c */ + +/* Start: bn_mp_clear_multi.c */ +#include +#ifdef BN_MP_CLEAR_MULTI_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ +#include + +void mp_clear_multi(mp_int *mp, ...) +{ + mp_int* next_mp = mp; + va_list args; + va_start(args, mp); + while (next_mp != NULL) { + mp_clear(next_mp); + next_mp = va_arg(args, mp_int*); + } + va_end(args); +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_clear_multi.c */ + +/* Start: bn_mp_cmp.c */ +#include +#ifdef BN_MP_CMP_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* compare two ints (signed)*/ +int +mp_cmp (mp_int * a, mp_int * b) +{ + /* compare based on sign */ + if (a->sign != b->sign) { + if (a->sign == MP_NEG) { + return MP_LT; + } else { + return MP_GT; + } + } + + /* compare digits */ + if (a->sign == MP_NEG) { + /* if negative compare opposite direction */ + return mp_cmp_mag(b, a); + } else { + return mp_cmp_mag(a, b); + } +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_cmp.c */ + +/* Start: bn_mp_cmp_d.c */ +#include +#ifdef BN_MP_CMP_D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* compare a digit */ +int mp_cmp_d(mp_int * a, mp_digit b) +{ + /* compare based on sign */ + if (a->sign == MP_NEG) { + return MP_LT; + } + + /* compare based on magnitude */ + if (a->used > 1) { + return MP_GT; + } + + /* compare the only digit of a to b */ + if (a->dp[0] > b) { + return MP_GT; + } else if (a->dp[0] < b) { + return MP_LT; + } else { + return MP_EQ; + } +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_cmp_d.c */ + +/* Start: bn_mp_cmp_mag.c */ +#include +#ifdef BN_MP_CMP_MAG_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* compare maginitude of two ints (unsigned) */ +int mp_cmp_mag (mp_int * a, mp_int * b) +{ + int n; + mp_digit *tmpa, *tmpb; + + /* compare based on # of non-zero digits */ + if (a->used > b->used) { + return MP_GT; + } + + if (a->used < b->used) { + return MP_LT; + } + + /* alias for a */ + tmpa = a->dp + (a->used - 1); + + /* alias for b */ + tmpb = b->dp + (a->used - 1); + + /* compare based on digits */ + for (n = 0; n < a->used; ++n, --tmpa, --tmpb) { + if (*tmpa > *tmpb) { + return MP_GT; + } + + if (*tmpa < *tmpb) { + return MP_LT; + } + } + return MP_EQ; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_cmp_mag.c */ + +/* Start: bn_mp_cnt_lsb.c */ +#include +#ifdef BN_MP_CNT_LSB_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +static const int lnz[16] = { + 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0 +}; + +/* Counts the number of lsbs which are zero before the first zero bit */ +int mp_cnt_lsb(mp_int *a) +{ + int x; + mp_digit q, qq; + + /* easy out */ + if (mp_iszero(a) == 1) { + return 0; + } + + /* scan lower digits until non-zero */ + for (x = 0; x < a->used && a->dp[x] == 0; x++); + q = a->dp[x]; + x *= DIGIT_BIT; + + /* now scan this digit until a 1 is found */ + if ((q & 1) == 0) { + do { + qq = q & 15; + x += lnz[qq]; + q >>= 4; + } while (qq == 0); + } + return x; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_cnt_lsb.c */ + +/* Start: bn_mp_copy.c */ +#include +#ifdef BN_MP_COPY_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* copy, b = a */ +int +mp_copy (mp_int * a, mp_int * b) +{ + int res, n; + + /* if dst == src do nothing */ + if (a == b) { + return MP_OKAY; + } + + /* grow dest */ + if (b->alloc < a->used) { + if ((res = mp_grow (b, a->used)) != MP_OKAY) { + return res; + } + } + + /* zero b and copy the parameters over */ + { + register mp_digit *tmpa, *tmpb; + + /* pointer aliases */ + + /* source */ + tmpa = a->dp; + + /* destination */ + tmpb = b->dp; + + /* copy all the digits */ + for (n = 0; n < a->used; n++) { + *tmpb++ = *tmpa++; + } + + /* clear high digits */ + for (; n < b->used; n++) { + *tmpb++ = 0; + } + } + + /* copy used count and sign */ + b->used = a->used; + b->sign = a->sign; + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_copy.c */ + +/* Start: bn_mp_count_bits.c */ +#include +#ifdef BN_MP_COUNT_BITS_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* returns the number of bits in an int */ +int +mp_count_bits (mp_int * a) +{ + int r; + mp_digit q; + + /* shortcut */ + if (a->used == 0) { + return 0; + } + + /* get number of digits and add that */ + r = (a->used - 1) * DIGIT_BIT; + + /* take the last digit and count the bits in it */ + q = a->dp[a->used - 1]; + while (q > ((mp_digit) 0)) { + ++r; + q >>= ((mp_digit) 1); + } + return r; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_count_bits.c */ + +/* Start: bn_mp_div.c */ +#include +#ifdef BN_MP_DIV_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +#ifdef BN_MP_DIV_SMALL + +/* slower bit-bang division... also smaller */ +int mp_div(mp_int * a, mp_int * b, mp_int * c, mp_int * d) +{ + mp_int ta, tb, tq, q; + int res, n, n2; + + /* is divisor zero ? */ + if (mp_iszero (b) == 1) { + return MP_VAL; + } + + /* if a < b then q=0, r = a */ + if (mp_cmp_mag (a, b) == MP_LT) { + if (d != NULL) { + res = mp_copy (a, d); + } else { + res = MP_OKAY; + } + if (c != NULL) { + mp_zero (c); + } + return res; + } + + /* init our temps */ + if ((res = mp_init_multi(&ta, &tb, &tq, &q, NULL) != MP_OKAY)) { + return res; + } + + + mp_set(&tq, 1); + n = mp_count_bits(a) - mp_count_bits(b); + if (((res = mp_abs(a, &ta)) != MP_OKAY) || + ((res = mp_abs(b, &tb)) != MP_OKAY) || + ((res = mp_mul_2d(&tb, n, &tb)) != MP_OKAY) || + ((res = mp_mul_2d(&tq, n, &tq)) != MP_OKAY)) { + goto LBL_ERR; + } + + while (n-- >= 0) { + if (mp_cmp(&tb, &ta) != MP_GT) { + if (((res = mp_sub(&ta, &tb, &ta)) != MP_OKAY) || + ((res = mp_add(&q, &tq, &q)) != MP_OKAY)) { + goto LBL_ERR; + } + } + if (((res = mp_div_2d(&tb, 1, &tb, NULL)) != MP_OKAY) || + ((res = mp_div_2d(&tq, 1, &tq, NULL)) != MP_OKAY)) { + goto LBL_ERR; + } + } + + /* now q == quotient and ta == remainder */ + n = a->sign; + n2 = (a->sign == b->sign ? MP_ZPOS : MP_NEG); + if (c != NULL) { + mp_exch(c, &q); + c->sign = (mp_iszero(c) == MP_YES) ? MP_ZPOS : n2; + } + if (d != NULL) { + mp_exch(d, &ta); + d->sign = (mp_iszero(d) == MP_YES) ? MP_ZPOS : n; + } +LBL_ERR: + mp_clear_multi(&ta, &tb, &tq, &q, NULL); + return res; +} + +#else + +/* integer signed division. + * c*b + d == a [e.g. a/b, c=quotient, d=remainder] + * HAC pp.598 Algorithm 14.20 + * + * Note that the description in HAC is horribly + * incomplete. For example, it doesn't consider + * the case where digits are removed from 'x' in + * the inner loop. It also doesn't consider the + * case that y has fewer than three digits, etc.. + * + * The overall algorithm is as described as + * 14.20 from HAC but fixed to treat these cases. +*/ +int mp_div (mp_int * a, mp_int * b, mp_int * c, mp_int * d) +{ + mp_int q, x, y, t1, t2; + int res, n, t, i, norm, neg; + + /* is divisor zero ? */ + if (mp_iszero (b) == 1) { + return MP_VAL; + } + + /* if a < b then q=0, r = a */ + if (mp_cmp_mag (a, b) == MP_LT) { + if (d != NULL) { + res = mp_copy (a, d); + } else { + res = MP_OKAY; + } + if (c != NULL) { + mp_zero (c); + } + return res; + } + + if ((res = mp_init_size (&q, a->used + 2)) != MP_OKAY) { + return res; + } + q.used = a->used + 2; + + if ((res = mp_init (&t1)) != MP_OKAY) { + goto LBL_Q; + } + + if ((res = mp_init (&t2)) != MP_OKAY) { + goto LBL_T1; + } + + if ((res = mp_init_copy (&x, a)) != MP_OKAY) { + goto LBL_T2; + } + + if ((res = mp_init_copy (&y, b)) != MP_OKAY) { + goto LBL_X; + } + + /* fix the sign */ + neg = (a->sign == b->sign) ? MP_ZPOS : MP_NEG; + x.sign = y.sign = MP_ZPOS; + + /* normalize both x and y, ensure that y >= b/2, [b == 2**DIGIT_BIT] */ + norm = mp_count_bits(&y) % DIGIT_BIT; + if (norm < (int)(DIGIT_BIT-1)) { + norm = (DIGIT_BIT-1) - norm; + if ((res = mp_mul_2d (&x, norm, &x)) != MP_OKAY) { + goto LBL_Y; + } + if ((res = mp_mul_2d (&y, norm, &y)) != MP_OKAY) { + goto LBL_Y; + } + } else { + norm = 0; + } + + /* note hac does 0 based, so if used==5 then its 0,1,2,3,4, e.g. use 4 */ + n = x.used - 1; + t = y.used - 1; + + /* while (x >= y*b**n-t) do { q[n-t] += 1; x -= y*b**{n-t} } */ + if ((res = mp_lshd (&y, n - t)) != MP_OKAY) { /* y = y*b**{n-t} */ + goto LBL_Y; + } + + while (mp_cmp (&x, &y) != MP_LT) { + ++(q.dp[n - t]); + if ((res = mp_sub (&x, &y, &x)) != MP_OKAY) { + goto LBL_Y; + } + } + + /* reset y by shifting it back down */ + mp_rshd (&y, n - t); + + /* step 3. for i from n down to (t + 1) */ + for (i = n; i >= (t + 1); i--) { + if (i > x.used) { + continue; + } + + /* step 3.1 if xi == yt then set q{i-t-1} to b-1, + * otherwise set q{i-t-1} to (xi*b + x{i-1})/yt */ + if (x.dp[i] == y.dp[t]) { + q.dp[i - t - 1] = ((((mp_digit)1) << DIGIT_BIT) - 1); + } else { + mp_word tmp; + tmp = ((mp_word) x.dp[i]) << ((mp_word) DIGIT_BIT); + tmp |= ((mp_word) x.dp[i - 1]); + tmp /= ((mp_word) y.dp[t]); + if (tmp > (mp_word) MP_MASK) + tmp = MP_MASK; + q.dp[i - t - 1] = (mp_digit) (tmp & (mp_word) (MP_MASK)); + } + + /* while (q{i-t-1} * (yt * b + y{t-1})) > + xi * b**2 + xi-1 * b + xi-2 + + do q{i-t-1} -= 1; + */ + q.dp[i - t - 1] = (q.dp[i - t - 1] + 1) & MP_MASK; + do { + q.dp[i - t - 1] = (q.dp[i - t - 1] - 1) & MP_MASK; + + /* find left hand */ + mp_zero (&t1); + t1.dp[0] = (t - 1 < 0) ? 0 : y.dp[t - 1]; + t1.dp[1] = y.dp[t]; + t1.used = 2; + if ((res = mp_mul_d (&t1, q.dp[i - t - 1], &t1)) != MP_OKAY) { + goto LBL_Y; + } + + /* find right hand */ + t2.dp[0] = (i - 2 < 0) ? 0 : x.dp[i - 2]; + t2.dp[1] = (i - 1 < 0) ? 0 : x.dp[i - 1]; + t2.dp[2] = x.dp[i]; + t2.used = 3; + } while (mp_cmp_mag(&t1, &t2) == MP_GT); + + /* step 3.3 x = x - q{i-t-1} * y * b**{i-t-1} */ + if ((res = mp_mul_d (&y, q.dp[i - t - 1], &t1)) != MP_OKAY) { + goto LBL_Y; + } + + if ((res = mp_lshd (&t1, i - t - 1)) != MP_OKAY) { + goto LBL_Y; + } + + if ((res = mp_sub (&x, &t1, &x)) != MP_OKAY) { + goto LBL_Y; + } + + /* if x < 0 then { x = x + y*b**{i-t-1}; q{i-t-1} -= 1; } */ + if (x.sign == MP_NEG) { + if ((res = mp_copy (&y, &t1)) != MP_OKAY) { + goto LBL_Y; + } + if ((res = mp_lshd (&t1, i - t - 1)) != MP_OKAY) { + goto LBL_Y; + } + if ((res = mp_add (&x, &t1, &x)) != MP_OKAY) { + goto LBL_Y; + } + + q.dp[i - t - 1] = (q.dp[i - t - 1] - 1UL) & MP_MASK; + } + } + + /* now q is the quotient and x is the remainder + * [which we have to normalize] + */ + + /* get sign before writing to c */ + x.sign = x.used == 0 ? MP_ZPOS : a->sign; + + if (c != NULL) { + mp_clamp (&q); + mp_exch (&q, c); + c->sign = neg; + } + + if (d != NULL) { + mp_div_2d (&x, norm, &x, NULL); + mp_exch (&x, d); + } + + res = MP_OKAY; + +LBL_Y:mp_clear (&y); +LBL_X:mp_clear (&x); +LBL_T2:mp_clear (&t2); +LBL_T1:mp_clear (&t1); +LBL_Q:mp_clear (&q); + return res; +} + +#endif + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_div.c */ + +/* Start: bn_mp_div_2.c */ +#include +#ifdef BN_MP_DIV_2_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* b = a/2 */ +int mp_div_2(mp_int * a, mp_int * b) +{ + int x, res, oldused; + + /* copy */ + if (b->alloc < a->used) { + if ((res = mp_grow (b, a->used)) != MP_OKAY) { + return res; + } + } + + oldused = b->used; + b->used = a->used; + { + register mp_digit r, rr, *tmpa, *tmpb; + + /* source alias */ + tmpa = a->dp + b->used - 1; + + /* dest alias */ + tmpb = b->dp + b->used - 1; + + /* carry */ + r = 0; + for (x = b->used - 1; x >= 0; x--) { + /* get the carry for the next iteration */ + rr = *tmpa & 1; + + /* shift the current digit, add in carry and store */ + *tmpb-- = (*tmpa-- >> 1) | (r << (DIGIT_BIT - 1)); + + /* forward carry to next iteration */ + r = rr; + } + + /* zero excess digits */ + tmpb = b->dp + b->used; + for (x = b->used; x < oldused; x++) { + *tmpb++ = 0; + } + } + b->sign = a->sign; + mp_clamp (b); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_div_2.c */ + +/* Start: bn_mp_div_2d.c */ +#include +#ifdef BN_MP_DIV_2D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* shift right by a certain bit count (store quotient in c, optional remainder in d) */ +int mp_div_2d (mp_int * a, int b, mp_int * c, mp_int * d) +{ + mp_digit D, r, rr; + int x, res; + mp_int t; + + + /* if the shift count is <= 0 then we do no work */ + if (b <= 0) { + res = mp_copy (a, c); + if (d != NULL) { + mp_zero (d); + } + return res; + } + + if ((res = mp_init (&t)) != MP_OKAY) { + return res; + } + + /* get the remainder */ + if (d != NULL) { + if ((res = mp_mod_2d (a, b, &t)) != MP_OKAY) { + mp_clear (&t); + return res; + } + } + + /* copy */ + if ((res = mp_copy (a, c)) != MP_OKAY) { + mp_clear (&t); + return res; + } + + /* shift by as many digits in the bit count */ + if (b >= (int)DIGIT_BIT) { + mp_rshd (c, b / DIGIT_BIT); + } + + /* shift any bit count < DIGIT_BIT */ + D = (mp_digit) (b % DIGIT_BIT); + if (D != 0) { + register mp_digit *tmpc, mask, shift; + + /* mask */ + mask = (((mp_digit)1) << D) - 1; + + /* shift for lsb */ + shift = DIGIT_BIT - D; + + /* alias */ + tmpc = c->dp + (c->used - 1); + + /* carry */ + r = 0; + for (x = c->used - 1; x >= 0; x--) { + /* get the lower bits of this word in a temp */ + rr = *tmpc & mask; + + /* shift the current word and mix in the carry bits from the previous word */ + *tmpc = (*tmpc >> D) | (r << shift); + --tmpc; + + /* set the carry to the carry bits of the current word found above */ + r = rr; + } + } + mp_clamp (c); + if (d != NULL) { + mp_exch (&t, d); + } + mp_clear (&t); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_div_2d.c */ + +/* Start: bn_mp_div_3.c */ +#include +#ifdef BN_MP_DIV_3_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* divide by three (based on routine from MPI and the GMP manual) */ +int +mp_div_3 (mp_int * a, mp_int *c, mp_digit * d) +{ + mp_int q; + mp_word w, t; + mp_digit b; + int res, ix; + + /* b = 2**DIGIT_BIT / 3 */ + b = (((mp_word)1) << ((mp_word)DIGIT_BIT)) / ((mp_word)3); + + if ((res = mp_init_size(&q, a->used)) != MP_OKAY) { + return res; + } + + q.used = a->used; + q.sign = a->sign; + w = 0; + for (ix = a->used - 1; ix >= 0; ix--) { + w = (w << ((mp_word)DIGIT_BIT)) | ((mp_word)a->dp[ix]); + + if (w >= 3) { + /* multiply w by [1/3] */ + t = (w * ((mp_word)b)) >> ((mp_word)DIGIT_BIT); + + /* now subtract 3 * [w/3] from w, to get the remainder */ + w -= t+t+t; + + /* fixup the remainder as required since + * the optimization is not exact. + */ + while (w >= 3) { + t += 1; + w -= 3; + } + } else { + t = 0; + } + q.dp[ix] = (mp_digit)t; + } + + /* [optional] store the remainder */ + if (d != NULL) { + *d = (mp_digit)w; + } + + /* [optional] store the quotient */ + if (c != NULL) { + mp_clamp(&q); + mp_exch(&q, c); + } + mp_clear(&q); + + return res; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_div_3.c */ + +/* Start: bn_mp_div_d.c */ +#include +#ifdef BN_MP_DIV_D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +static int s_is_power_of_two(mp_digit b, int *p) +{ + int x; + + for (x = 1; x < DIGIT_BIT; x++) { + if (b == (((mp_digit)1)<dp[0] & ((((mp_digit)1)<used)) != MP_OKAY) { + return res; + } + + q.used = a->used; + q.sign = a->sign; + w = 0; + for (ix = a->used - 1; ix >= 0; ix--) { + w = (w << ((mp_word)DIGIT_BIT)) | ((mp_word)a->dp[ix]); + + if (w >= b) { + t = (mp_digit)(w / b); + w -= ((mp_word)t) * ((mp_word)b); + } else { + t = 0; + } + q.dp[ix] = (mp_digit)t; + } + + if (d != NULL) { + *d = (mp_digit)w; + } + + if (c != NULL) { + mp_clamp(&q); + mp_exch(&q, c); + } + mp_clear(&q); + + return res; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_div_d.c */ + +/* Start: bn_mp_dr_is_modulus.c */ +#include +#ifdef BN_MP_DR_IS_MODULUS_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* determines if a number is a valid DR modulus */ +int mp_dr_is_modulus(mp_int *a) +{ + int ix; + + /* must be at least two digits */ + if (a->used < 2) { + return 0; + } + + /* must be of the form b**k - a [a <= b] so all + * but the first digit must be equal to -1 (mod b). + */ + for (ix = 1; ix < a->used; ix++) { + if (a->dp[ix] != MP_MASK) { + return 0; + } + } + return 1; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_dr_is_modulus.c */ + +/* Start: bn_mp_dr_reduce.c */ +#include +#ifdef BN_MP_DR_REDUCE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* reduce "x" in place modulo "n" using the Diminished Radix algorithm. + * + * Based on algorithm from the paper + * + * "Generating Efficient Primes for Discrete Log Cryptosystems" + * Chae Hoon Lim, Pil Joong Lee, + * POSTECH Information Research Laboratories + * + * The modulus must be of a special format [see manual] + * + * Has been modified to use algorithm 7.10 from the LTM book instead + * + * Input x must be in the range 0 <= x <= (n-1)**2 + */ +int +mp_dr_reduce (mp_int * x, mp_int * n, mp_digit k) +{ + int err, i, m; + mp_word r; + mp_digit mu, *tmpx1, *tmpx2; + + /* m = digits in modulus */ + m = n->used; + + /* ensure that "x" has at least 2m digits */ + if (x->alloc < m + m) { + if ((err = mp_grow (x, m + m)) != MP_OKAY) { + return err; + } + } + +/* top of loop, this is where the code resumes if + * another reduction pass is required. + */ +top: + /* aliases for digits */ + /* alias for lower half of x */ + tmpx1 = x->dp; + + /* alias for upper half of x, or x/B**m */ + tmpx2 = x->dp + m; + + /* set carry to zero */ + mu = 0; + + /* compute (x mod B**m) + k * [x/B**m] inline and inplace */ + for (i = 0; i < m; i++) { + r = ((mp_word)*tmpx2++) * ((mp_word)k) + *tmpx1 + mu; + *tmpx1++ = (mp_digit)(r & MP_MASK); + mu = (mp_digit)(r >> ((mp_word)DIGIT_BIT)); + } + + /* set final carry */ + *tmpx1++ = mu; + + /* zero words above m */ + for (i = m + 1; i < x->used; i++) { + *tmpx1++ = 0; + } + + /* clamp, sub and return */ + mp_clamp (x); + + /* if x >= n then subtract and reduce again + * Each successive "recursion" makes the input smaller and smaller. + */ + if (mp_cmp_mag (x, n) != MP_LT) { + s_mp_sub(x, n, x); + goto top; + } + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_dr_reduce.c */ + +/* Start: bn_mp_dr_setup.c */ +#include +#ifdef BN_MP_DR_SETUP_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* determines the setup value */ +void mp_dr_setup(mp_int *a, mp_digit *d) +{ + /* the casts are required if DIGIT_BIT is one less than + * the number of bits in a mp_digit [e.g. DIGIT_BIT==31] + */ + *d = (mp_digit)((((mp_word)1) << ((mp_word)DIGIT_BIT)) - + ((mp_word)a->dp[0])); +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_dr_setup.c */ + +/* Start: bn_mp_exch.c */ +#include +#ifdef BN_MP_EXCH_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* swap the elements of two integers, for cases where you can't simply swap the + * mp_int pointers around + */ +void +mp_exch (mp_int * a, mp_int * b) +{ + mp_int t; + + t = *a; + *a = *b; + *b = t; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_exch.c */ + +/* Start: bn_mp_expt_d.c */ +#include +#ifdef BN_MP_EXPT_D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* calculate c = a**b using a square-multiply algorithm */ +int mp_expt_d (mp_int * a, mp_digit b, mp_int * c) +{ + int res, x; + mp_int g; + + if ((res = mp_init_copy (&g, a)) != MP_OKAY) { + return res; + } + + /* set initial result */ + mp_set (c, 1); + + for (x = 0; x < (int) DIGIT_BIT; x++) { + /* square */ + if ((res = mp_sqr (c, c)) != MP_OKAY) { + mp_clear (&g); + return res; + } + + /* if the bit is set multiply */ + if ((b & (mp_digit) (((mp_digit)1) << (DIGIT_BIT - 1))) != 0) { + if ((res = mp_mul (c, &g, c)) != MP_OKAY) { + mp_clear (&g); + return res; + } + } + + /* shift to next bit */ + b <<= 1; + } + + mp_clear (&g); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_expt_d.c */ + +/* Start: bn_mp_exptmod.c */ +#include +#ifdef BN_MP_EXPTMOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + + +/* this is a shell function that calls either the normal or Montgomery + * exptmod functions. Originally the call to the montgomery code was + * embedded in the normal function but that wasted alot of stack space + * for nothing (since 99% of the time the Montgomery code would be called) + */ +int mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y) +{ + int dr; + + /* modulus P must be positive */ + if (P->sign == MP_NEG) { + return MP_VAL; + } + + /* if exponent X is negative we have to recurse */ + if (X->sign == MP_NEG) { +#ifdef BN_MP_INVMOD_C + mp_int tmpG, tmpX; + int err; + + /* first compute 1/G mod P */ + if ((err = mp_init(&tmpG)) != MP_OKAY) { + return err; + } + if ((err = mp_invmod(G, P, &tmpG)) != MP_OKAY) { + mp_clear(&tmpG); + return err; + } + + /* now get |X| */ + if ((err = mp_init(&tmpX)) != MP_OKAY) { + mp_clear(&tmpG); + return err; + } + if ((err = mp_abs(X, &tmpX)) != MP_OKAY) { + mp_clear_multi(&tmpG, &tmpX, NULL); + return err; + } + + /* and now compute (1/G)**|X| instead of G**X [X < 0] */ + err = mp_exptmod(&tmpG, &tmpX, P, Y); + mp_clear_multi(&tmpG, &tmpX, NULL); + return err; +#else + /* no invmod */ + return MP_VAL; +#endif + } + +/* modified diminished radix reduction */ +#if defined(BN_MP_REDUCE_IS_2K_L_C) && defined(BN_MP_REDUCE_2K_L_C) && defined(BN_S_MP_EXPTMOD_C) + if (mp_reduce_is_2k_l(P) == MP_YES) { + return s_mp_exptmod(G, X, P, Y, 1); + } +#endif + +#ifdef BN_MP_DR_IS_MODULUS_C + /* is it a DR modulus? */ + dr = mp_dr_is_modulus(P); +#else + /* default to no */ + dr = 0; +#endif + +#ifdef BN_MP_REDUCE_IS_2K_C + /* if not, is it a unrestricted DR modulus? */ + if (dr == 0) { + dr = mp_reduce_is_2k(P) << 1; + } +#endif + + /* if the modulus is odd or dr != 0 use the montgomery method */ +#ifdef BN_MP_EXPTMOD_FAST_C + if (mp_isodd (P) == 1 || dr != 0) { + return mp_exptmod_fast (G, X, P, Y, dr); + } else { +#endif +#ifdef BN_S_MP_EXPTMOD_C + /* otherwise use the generic Barrett reduction technique */ + return s_mp_exptmod (G, X, P, Y, 0); +#else + /* no exptmod for evens */ + return MP_VAL; +#endif +#ifdef BN_MP_EXPTMOD_FAST_C + } +#endif +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_exptmod.c */ + +/* Start: bn_mp_exptmod_fast.c */ +#include +#ifdef BN_MP_EXPTMOD_FAST_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* computes Y == G**X mod P, HAC pp.616, Algorithm 14.85 + * + * Uses a left-to-right k-ary sliding window to compute the modular exponentiation. + * The value of k changes based on the size of the exponent. + * + * Uses Montgomery or Diminished Radix reduction [whichever appropriate] + */ + +#ifdef MP_LOW_MEM + #define TAB_SIZE 32 +#else + #define TAB_SIZE 256 +#endif + +int mp_exptmod_fast (mp_int * G, mp_int * X, mp_int * P, mp_int * Y, int redmode) +{ + mp_int M[TAB_SIZE], res; + mp_digit buf, mp; + int err, bitbuf, bitcpy, bitcnt, mode, digidx, x, y, winsize; + + /* use a pointer to the reduction algorithm. This allows us to use + * one of many reduction algorithms without modding the guts of + * the code with if statements everywhere. + */ + int (*redux)(mp_int*,mp_int*,mp_digit); + + /* find window size */ + x = mp_count_bits (X); + if (x <= 7) { + winsize = 2; + } else if (x <= 36) { + winsize = 3; + } else if (x <= 140) { + winsize = 4; + } else if (x <= 450) { + winsize = 5; + } else if (x <= 1303) { + winsize = 6; + } else if (x <= 3529) { + winsize = 7; + } else { + winsize = 8; + } + +#ifdef MP_LOW_MEM + if (winsize > 5) { + winsize = 5; + } +#endif + + /* init M array */ + /* init first cell */ + if ((err = mp_init(&M[1])) != MP_OKAY) { + return err; + } + + /* now init the second half of the array */ + for (x = 1<<(winsize-1); x < (1 << winsize); x++) { + if ((err = mp_init(&M[x])) != MP_OKAY) { + for (y = 1<<(winsize-1); y < x; y++) { + mp_clear (&M[y]); + } + mp_clear(&M[1]); + return err; + } + } + + /* determine and setup reduction code */ + if (redmode == 0) { +#ifdef BN_MP_MONTGOMERY_SETUP_C + /* now setup montgomery */ + if ((err = mp_montgomery_setup (P, &mp)) != MP_OKAY) { + goto LBL_M; + } +#else + err = MP_VAL; + goto LBL_M; +#endif + + /* automatically pick the comba one if available (saves quite a few calls/ifs) */ +#ifdef BN_FAST_MP_MONTGOMERY_REDUCE_C + if (((P->used * 2 + 1) < MP_WARRAY) && + P->used < (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) { + redux = fast_mp_montgomery_reduce; + } else +#endif + { +#ifdef BN_MP_MONTGOMERY_REDUCE_C + /* use slower baseline Montgomery method */ + redux = mp_montgomery_reduce; +#else + err = MP_VAL; + goto LBL_M; +#endif + } + } else if (redmode == 1) { +#if defined(BN_MP_DR_SETUP_C) && defined(BN_MP_DR_REDUCE_C) + /* setup DR reduction for moduli of the form B**k - b */ + mp_dr_setup(P, &mp); + redux = mp_dr_reduce; +#else + err = MP_VAL; + goto LBL_M; +#endif + } else { +#if defined(BN_MP_REDUCE_2K_SETUP_C) && defined(BN_MP_REDUCE_2K_C) + /* setup DR reduction for moduli of the form 2**k - b */ + if ((err = mp_reduce_2k_setup(P, &mp)) != MP_OKAY) { + goto LBL_M; + } + redux = mp_reduce_2k; +#else + err = MP_VAL; + goto LBL_M; +#endif + } + + /* setup result */ + if ((err = mp_init (&res)) != MP_OKAY) { + goto LBL_M; + } + + /* create M table + * + + * + * The first half of the table is not computed though accept for M[0] and M[1] + */ + + if (redmode == 0) { +#ifdef BN_MP_MONTGOMERY_CALC_NORMALIZATION_C + /* now we need R mod m */ + if ((err = mp_montgomery_calc_normalization (&res, P)) != MP_OKAY) { + goto LBL_RES; + } +#else + err = MP_VAL; + goto LBL_RES; +#endif + + /* now set M[1] to G * R mod m */ + if ((err = mp_mulmod (G, &res, P, &M[1])) != MP_OKAY) { + goto LBL_RES; + } + } else { + mp_set(&res, 1); + if ((err = mp_mod(G, P, &M[1])) != MP_OKAY) { + goto LBL_RES; + } + } + + /* compute the value at M[1<<(winsize-1)] by squaring M[1] (winsize-1) times */ + if ((err = mp_copy (&M[1], &M[1 << (winsize - 1)])) != MP_OKAY) { + goto LBL_RES; + } + + for (x = 0; x < (winsize - 1); x++) { + if ((err = mp_sqr (&M[1 << (winsize - 1)], &M[1 << (winsize - 1)])) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&M[1 << (winsize - 1)], P, mp)) != MP_OKAY) { + goto LBL_RES; + } + } + + /* create upper table */ + for (x = (1 << (winsize - 1)) + 1; x < (1 << winsize); x++) { + if ((err = mp_mul (&M[x - 1], &M[1], &M[x])) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&M[x], P, mp)) != MP_OKAY) { + goto LBL_RES; + } + } + + /* set initial mode and bit cnt */ + mode = 0; + bitcnt = 1; + buf = 0; + digidx = X->used - 1; + bitcpy = 0; + bitbuf = 0; + + for (;;) { + /* grab next digit as required */ + if (--bitcnt == 0) { + /* if digidx == -1 we are out of digits so break */ + if (digidx == -1) { + break; + } + /* read next digit and reset bitcnt */ + buf = X->dp[digidx--]; + bitcnt = (int)DIGIT_BIT; + } + + /* grab the next msb from the exponent */ + y = (mp_digit)(buf >> (DIGIT_BIT - 1)) & 1; + buf <<= (mp_digit)1; + + /* if the bit is zero and mode == 0 then we ignore it + * These represent the leading zero bits before the first 1 bit + * in the exponent. Technically this opt is not required but it + * does lower the # of trivial squaring/reductions used + */ + if (mode == 0 && y == 0) { + continue; + } + + /* if the bit is zero and mode == 1 then we square */ + if (mode == 1 && y == 0) { + if ((err = mp_sqr (&res, &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, mp)) != MP_OKAY) { + goto LBL_RES; + } + continue; + } + + /* else we add it to the window */ + bitbuf |= (y << (winsize - ++bitcpy)); + mode = 2; + + if (bitcpy == winsize) { + /* ok window is filled so square as required and multiply */ + /* square first */ + for (x = 0; x < winsize; x++) { + if ((err = mp_sqr (&res, &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, mp)) != MP_OKAY) { + goto LBL_RES; + } + } + + /* then multiply */ + if ((err = mp_mul (&res, &M[bitbuf], &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, mp)) != MP_OKAY) { + goto LBL_RES; + } + + /* empty window and reset */ + bitcpy = 0; + bitbuf = 0; + mode = 1; + } + } + + /* if bits remain then square/multiply */ + if (mode == 2 && bitcpy > 0) { + /* square then multiply if the bit is set */ + for (x = 0; x < bitcpy; x++) { + if ((err = mp_sqr (&res, &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, mp)) != MP_OKAY) { + goto LBL_RES; + } + + /* get next bit of the window */ + bitbuf <<= 1; + if ((bitbuf & (1 << winsize)) != 0) { + /* then multiply */ + if ((err = mp_mul (&res, &M[1], &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, mp)) != MP_OKAY) { + goto LBL_RES; + } + } + } + } + + if (redmode == 0) { + /* fixup result if Montgomery reduction is used + * recall that any value in a Montgomery system is + * actually multiplied by R mod n. So we have + * to reduce one more time to cancel out the factor + * of R. + */ + if ((err = redux(&res, P, mp)) != MP_OKAY) { + goto LBL_RES; + } + } + + /* swap res with Y */ + mp_exch (&res, Y); + err = MP_OKAY; +LBL_RES:mp_clear (&res); +LBL_M: + mp_clear(&M[1]); + for (x = 1<<(winsize-1); x < (1 << winsize); x++) { + mp_clear (&M[x]); + } + return err; +} +#endif + + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_exptmod_fast.c */ + +/* Start: bn_mp_exteuclid.c */ +#include +#ifdef BN_MP_EXTEUCLID_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* Extended euclidean algorithm of (a, b) produces + a*u1 + b*u2 = u3 + */ +int mp_exteuclid(mp_int *a, mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3) +{ + mp_int u1,u2,u3,v1,v2,v3,t1,t2,t3,q,tmp; + int err; + + if ((err = mp_init_multi(&u1, &u2, &u3, &v1, &v2, &v3, &t1, &t2, &t3, &q, &tmp, NULL)) != MP_OKAY) { + return err; + } + + /* initialize, (u1,u2,u3) = (1,0,a) */ + mp_set(&u1, 1); + if ((err = mp_copy(a, &u3)) != MP_OKAY) { goto _ERR; } + + /* initialize, (v1,v2,v3) = (0,1,b) */ + mp_set(&v2, 1); + if ((err = mp_copy(b, &v3)) != MP_OKAY) { goto _ERR; } + + /* loop while v3 != 0 */ + while (mp_iszero(&v3) == MP_NO) { + /* q = u3/v3 */ + if ((err = mp_div(&u3, &v3, &q, NULL)) != MP_OKAY) { goto _ERR; } + + /* (t1,t2,t3) = (u1,u2,u3) - (v1,v2,v3)q */ + if ((err = mp_mul(&v1, &q, &tmp)) != MP_OKAY) { goto _ERR; } + if ((err = mp_sub(&u1, &tmp, &t1)) != MP_OKAY) { goto _ERR; } + if ((err = mp_mul(&v2, &q, &tmp)) != MP_OKAY) { goto _ERR; } + if ((err = mp_sub(&u2, &tmp, &t2)) != MP_OKAY) { goto _ERR; } + if ((err = mp_mul(&v3, &q, &tmp)) != MP_OKAY) { goto _ERR; } + if ((err = mp_sub(&u3, &tmp, &t3)) != MP_OKAY) { goto _ERR; } + + /* (u1,u2,u3) = (v1,v2,v3) */ + if ((err = mp_copy(&v1, &u1)) != MP_OKAY) { goto _ERR; } + if ((err = mp_copy(&v2, &u2)) != MP_OKAY) { goto _ERR; } + if ((err = mp_copy(&v3, &u3)) != MP_OKAY) { goto _ERR; } + + /* (v1,v2,v3) = (t1,t2,t3) */ + if ((err = mp_copy(&t1, &v1)) != MP_OKAY) { goto _ERR; } + if ((err = mp_copy(&t2, &v2)) != MP_OKAY) { goto _ERR; } + if ((err = mp_copy(&t3, &v3)) != MP_OKAY) { goto _ERR; } + } + + /* make sure U3 >= 0 */ + if (u3.sign == MP_NEG) { + mp_neg(&u1, &u1); + mp_neg(&u2, &u2); + mp_neg(&u3, &u3); + } + + /* copy result out */ + if (U1 != NULL) { mp_exch(U1, &u1); } + if (U2 != NULL) { mp_exch(U2, &u2); } + if (U3 != NULL) { mp_exch(U3, &u3); } + + err = MP_OKAY; +_ERR: mp_clear_multi(&u1, &u2, &u3, &v1, &v2, &v3, &t1, &t2, &t3, &q, &tmp, NULL); + return err; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_exteuclid.c */ + +/* Start: bn_mp_fread.c */ +#include +#ifdef BN_MP_FREAD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* read a bigint from a file stream in ASCII */ +int mp_fread(mp_int *a, int radix, FILE *stream) +{ + int err, ch, neg, y; + + /* clear a */ + mp_zero(a); + + /* if first digit is - then set negative */ + ch = fgetc(stream); + if (ch == '-') { + neg = MP_NEG; + ch = fgetc(stream); + } else { + neg = MP_ZPOS; + } + + for (;;) { + /* find y in the radix map */ + for (y = 0; y < radix; y++) { + if (mp_s_rmap[y] == ch) { + break; + } + } + if (y == radix) { + break; + } + + /* shift up and add */ + if ((err = mp_mul_d(a, radix, a)) != MP_OKAY) { + return err; + } + if ((err = mp_add_d(a, y, a)) != MP_OKAY) { + return err; + } + + ch = fgetc(stream); + } + if (mp_cmp_d(a, 0) != MP_EQ) { + a->sign = neg; + } + + return MP_OKAY; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_fread.c */ + +/* Start: bn_mp_fwrite.c */ +#include +#ifdef BN_MP_FWRITE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +int mp_fwrite(mp_int *a, int radix, FILE *stream) +{ + char *buf; + int err, len, x; + + if ((err = mp_radix_size(a, radix, &len)) != MP_OKAY) { + return err; + } + + buf = OPT_CAST(char) XMALLOC (len); + if (buf == NULL) { + return MP_MEM; + } + + if ((err = mp_toradix(a, buf, radix)) != MP_OKAY) { + XFREE (buf); + return err; + } + + for (x = 0; x < len; x++) { + if (fputc(buf[x], stream) == EOF) { + XFREE (buf); + return MP_VAL; + } + } + + XFREE (buf); + return MP_OKAY; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_fwrite.c */ + +/* Start: bn_mp_gcd.c */ +#include +#ifdef BN_MP_GCD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* Greatest Common Divisor using the binary method */ +int mp_gcd (mp_int * a, mp_int * b, mp_int * c) +{ + mp_int u, v; + int k, u_lsb, v_lsb, res; + + /* either zero than gcd is the largest */ + if (mp_iszero (a) == 1 && mp_iszero (b) == 0) { + return mp_abs (b, c); + } + if (mp_iszero (a) == 0 && mp_iszero (b) == 1) { + return mp_abs (a, c); + } + + /* optimized. At this point if a == 0 then + * b must equal zero too + */ + if (mp_iszero (a) == 1) { + mp_zero(c); + return MP_OKAY; + } + + /* get copies of a and b we can modify */ + if ((res = mp_init_copy (&u, a)) != MP_OKAY) { + return res; + } + + if ((res = mp_init_copy (&v, b)) != MP_OKAY) { + goto LBL_U; + } + + /* must be positive for the remainder of the algorithm */ + u.sign = v.sign = MP_ZPOS; + + /* B1. Find the common power of two for u and v */ + u_lsb = mp_cnt_lsb(&u); + v_lsb = mp_cnt_lsb(&v); + k = MIN(u_lsb, v_lsb); + + if (k > 0) { + /* divide the power of two out */ + if ((res = mp_div_2d(&u, k, &u, NULL)) != MP_OKAY) { + goto LBL_V; + } + + if ((res = mp_div_2d(&v, k, &v, NULL)) != MP_OKAY) { + goto LBL_V; + } + } + + /* divide any remaining factors of two out */ + if (u_lsb != k) { + if ((res = mp_div_2d(&u, u_lsb - k, &u, NULL)) != MP_OKAY) { + goto LBL_V; + } + } + + if (v_lsb != k) { + if ((res = mp_div_2d(&v, v_lsb - k, &v, NULL)) != MP_OKAY) { + goto LBL_V; + } + } + + while (mp_iszero(&v) == 0) { + /* make sure v is the largest */ + if (mp_cmp_mag(&u, &v) == MP_GT) { + /* swap u and v to make sure v is >= u */ + mp_exch(&u, &v); + } + + /* subtract smallest from largest */ + if ((res = s_mp_sub(&v, &u, &v)) != MP_OKAY) { + goto LBL_V; + } + + /* Divide out all factors of two */ + if ((res = mp_div_2d(&v, mp_cnt_lsb(&v), &v, NULL)) != MP_OKAY) { + goto LBL_V; + } + } + + /* multiply by 2**k which we divided out at the beginning */ + if ((res = mp_mul_2d (&u, k, c)) != MP_OKAY) { + goto LBL_V; + } + c->sign = MP_ZPOS; + res = MP_OKAY; +LBL_V:mp_clear (&u); +LBL_U:mp_clear (&v); + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_gcd.c */ + +/* Start: bn_mp_get_int.c */ +#include +#ifdef BN_MP_GET_INT_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* get the lower 32-bits of an mp_int */ +unsigned long mp_get_int(mp_int * a) +{ + int i; + unsigned long res; + + if (a->used == 0) { + return 0; + } + + /* get number of digits of the lsb we have to read */ + i = MIN(a->used,(int)((sizeof(unsigned long)*CHAR_BIT+DIGIT_BIT-1)/DIGIT_BIT))-1; + + /* get most significant digit of result */ + res = DIGIT(a,i); + + while (--i >= 0) { + res = (res << DIGIT_BIT) | DIGIT(a,i); + } + + /* force result to 32-bits always so it is consistent on non 32-bit platforms */ + return res & 0xFFFFFFFFUL; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_get_int.c */ + +/* Start: bn_mp_grow.c */ +#include +#ifdef BN_MP_GROW_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* grow as required */ +int mp_grow (mp_int * a, int size) +{ + int i; + mp_digit *tmp; + + /* if the alloc size is smaller alloc more ram */ + if (a->alloc < size) { + /* ensure there are always at least MP_PREC digits extra on top */ + size += (MP_PREC * 2) - (size % MP_PREC); + + /* reallocate the array a->dp + * + * We store the return in a temporary variable + * in case the operation failed we don't want + * to overwrite the dp member of a. + */ + tmp = OPT_CAST(mp_digit) XREALLOC (a->dp, sizeof (mp_digit) * size); + if (tmp == NULL) { + /* reallocation failed but "a" is still valid [can be freed] */ + return MP_MEM; + } + + /* reallocation succeeded so set a->dp */ + a->dp = tmp; + + /* zero excess digits */ + i = a->alloc; + a->alloc = size; + for (; i < a->alloc; i++) { + a->dp[i] = 0; + } + } + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_grow.c */ + +/* Start: bn_mp_init.c */ +#include +#ifdef BN_MP_INIT_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* init a new mp_int */ +int mp_init (mp_int * a) +{ + int i; + + /* allocate memory required and clear it */ + a->dp = OPT_CAST(mp_digit) XMALLOC (sizeof (mp_digit) * MP_PREC); + if (a->dp == NULL) { + return MP_MEM; + } + + /* set the digits to zero */ + for (i = 0; i < MP_PREC; i++) { + a->dp[i] = 0; + } + + /* set the used to zero, allocated digits to the default precision + * and sign to positive */ + a->used = 0; + a->alloc = MP_PREC; + a->sign = MP_ZPOS; + + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_init.c */ + +/* Start: bn_mp_init_copy.c */ +#include +#ifdef BN_MP_INIT_COPY_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* creates "a" then copies b into it */ +int mp_init_copy (mp_int * a, mp_int * b) +{ + int res; + + if ((res = mp_init (a)) != MP_OKAY) { + return res; + } + return mp_copy (b, a); +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_init_copy.c */ + +/* Start: bn_mp_init_multi.c */ +#include +#ifdef BN_MP_INIT_MULTI_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ +#include + +int mp_init_multi(mp_int *mp, ...) +{ + mp_err res = MP_OKAY; /* Assume ok until proven otherwise */ + int n = 0; /* Number of ok inits */ + mp_int* cur_arg = mp; + va_list args; + + va_start(args, mp); /* init args to next argument from caller */ + while (cur_arg != NULL) { + if (mp_init(cur_arg) != MP_OKAY) { + /* Oops - error! Back-track and mp_clear what we already + succeeded in init-ing, then return error. + */ + va_list clean_args; + + /* end the current list */ + va_end(args); + + /* now start cleaning up */ + cur_arg = mp; + va_start(clean_args, mp); + while (n--) { + mp_clear(cur_arg); + cur_arg = va_arg(clean_args, mp_int*); + } + va_end(clean_args); + res = MP_MEM; + break; + } + n++; + cur_arg = va_arg(args, mp_int*); + } + va_end(args); + return res; /* Assumed ok, if error flagged above. */ +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_init_multi.c */ + +/* Start: bn_mp_init_set.c */ +#include +#ifdef BN_MP_INIT_SET_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* initialize and set a digit */ +int mp_init_set (mp_int * a, mp_digit b) +{ + int err; + if ((err = mp_init(a)) != MP_OKAY) { + return err; + } + mp_set(a, b); + return err; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_init_set.c */ + +/* Start: bn_mp_init_set_int.c */ +#include +#ifdef BN_MP_INIT_SET_INT_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* initialize and set a digit */ +int mp_init_set_int (mp_int * a, unsigned long b) +{ + int err; + if ((err = mp_init(a)) != MP_OKAY) { + return err; + } + return mp_set_int(a, b); +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_init_set_int.c */ + +/* Start: bn_mp_init_size.c */ +#include +#ifdef BN_MP_INIT_SIZE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* init an mp_init for a given size */ +int mp_init_size (mp_int * a, int size) +{ + int x; + + /* pad size so there are always extra digits */ + size += (MP_PREC * 2) - (size % MP_PREC); + + /* alloc mem */ + a->dp = OPT_CAST(mp_digit) XMALLOC (sizeof (mp_digit) * size); + if (a->dp == NULL) { + return MP_MEM; + } + + /* set the members */ + a->used = 0; + a->alloc = size; + a->sign = MP_ZPOS; + + /* zero the digits */ + for (x = 0; x < size; x++) { + a->dp[x] = 0; + } + + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_init_size.c */ + +/* Start: bn_mp_invmod.c */ +#include +#ifdef BN_MP_INVMOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* hac 14.61, pp608 */ +int mp_invmod (mp_int * a, mp_int * b, mp_int * c) +{ + /* b cannot be negative */ + if (b->sign == MP_NEG || mp_iszero(b) == 1) { + return MP_VAL; + } + +#ifdef BN_FAST_MP_INVMOD_C + /* if the modulus is odd we can use a faster routine instead */ + if (mp_isodd (b) == 1) { + return fast_mp_invmod (a, b, c); + } +#endif + +#ifdef BN_MP_INVMOD_SLOW_C + return mp_invmod_slow(a, b, c); +#endif + + return MP_VAL; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_invmod.c */ + +/* Start: bn_mp_invmod_slow.c */ +#include +#ifdef BN_MP_INVMOD_SLOW_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* hac 14.61, pp608 */ +int mp_invmod_slow (mp_int * a, mp_int * b, mp_int * c) +{ + mp_int x, y, u, v, A, B, C, D; + int res; + + /* b cannot be negative */ + if (b->sign == MP_NEG || mp_iszero(b) == 1) { + return MP_VAL; + } + + /* init temps */ + if ((res = mp_init_multi(&x, &y, &u, &v, + &A, &B, &C, &D, NULL)) != MP_OKAY) { + return res; + } + + /* x = a, y = b */ + if ((res = mp_mod(a, b, &x)) != MP_OKAY) { + goto LBL_ERR; + } + if ((res = mp_copy (b, &y)) != MP_OKAY) { + goto LBL_ERR; + } + + /* 2. [modified] if x,y are both even then return an error! */ + if (mp_iseven (&x) == 1 && mp_iseven (&y) == 1) { + res = MP_VAL; + goto LBL_ERR; + } + + /* 3. u=x, v=y, A=1, B=0, C=0,D=1 */ + if ((res = mp_copy (&x, &u)) != MP_OKAY) { + goto LBL_ERR; + } + if ((res = mp_copy (&y, &v)) != MP_OKAY) { + goto LBL_ERR; + } + mp_set (&A, 1); + mp_set (&D, 1); + +top: + /* 4. while u is even do */ + while (mp_iseven (&u) == 1) { + /* 4.1 u = u/2 */ + if ((res = mp_div_2 (&u, &u)) != MP_OKAY) { + goto LBL_ERR; + } + /* 4.2 if A or B is odd then */ + if (mp_isodd (&A) == 1 || mp_isodd (&B) == 1) { + /* A = (A+y)/2, B = (B-x)/2 */ + if ((res = mp_add (&A, &y, &A)) != MP_OKAY) { + goto LBL_ERR; + } + if ((res = mp_sub (&B, &x, &B)) != MP_OKAY) { + goto LBL_ERR; + } + } + /* A = A/2, B = B/2 */ + if ((res = mp_div_2 (&A, &A)) != MP_OKAY) { + goto LBL_ERR; + } + if ((res = mp_div_2 (&B, &B)) != MP_OKAY) { + goto LBL_ERR; + } + } + + /* 5. while v is even do */ + while (mp_iseven (&v) == 1) { + /* 5.1 v = v/2 */ + if ((res = mp_div_2 (&v, &v)) != MP_OKAY) { + goto LBL_ERR; + } + /* 5.2 if C or D is odd then */ + if (mp_isodd (&C) == 1 || mp_isodd (&D) == 1) { + /* C = (C+y)/2, D = (D-x)/2 */ + if ((res = mp_add (&C, &y, &C)) != MP_OKAY) { + goto LBL_ERR; + } + if ((res = mp_sub (&D, &x, &D)) != MP_OKAY) { + goto LBL_ERR; + } + } + /* C = C/2, D = D/2 */ + if ((res = mp_div_2 (&C, &C)) != MP_OKAY) { + goto LBL_ERR; + } + if ((res = mp_div_2 (&D, &D)) != MP_OKAY) { + goto LBL_ERR; + } + } + + /* 6. if u >= v then */ + if (mp_cmp (&u, &v) != MP_LT) { + /* u = u - v, A = A - C, B = B - D */ + if ((res = mp_sub (&u, &v, &u)) != MP_OKAY) { + goto LBL_ERR; + } + + if ((res = mp_sub (&A, &C, &A)) != MP_OKAY) { + goto LBL_ERR; + } + + if ((res = mp_sub (&B, &D, &B)) != MP_OKAY) { + goto LBL_ERR; + } + } else { + /* v - v - u, C = C - A, D = D - B */ + if ((res = mp_sub (&v, &u, &v)) != MP_OKAY) { + goto LBL_ERR; + } + + if ((res = mp_sub (&C, &A, &C)) != MP_OKAY) { + goto LBL_ERR; + } + + if ((res = mp_sub (&D, &B, &D)) != MP_OKAY) { + goto LBL_ERR; + } + } + + /* if not zero goto step 4 */ + if (mp_iszero (&u) == 0) + goto top; + + /* now a = C, b = D, gcd == g*v */ + + /* if v != 1 then there is no inverse */ + if (mp_cmp_d (&v, 1) != MP_EQ) { + res = MP_VAL; + goto LBL_ERR; + } + + /* if its too low */ + while (mp_cmp_d(&C, 0) == MP_LT) { + if ((res = mp_add(&C, b, &C)) != MP_OKAY) { + goto LBL_ERR; + } + } + + /* too big */ + while (mp_cmp_mag(&C, b) != MP_LT) { + if ((res = mp_sub(&C, b, &C)) != MP_OKAY) { + goto LBL_ERR; + } + } + + /* C is now the inverse */ + mp_exch (&C, c); + res = MP_OKAY; +LBL_ERR:mp_clear_multi (&x, &y, &u, &v, &A, &B, &C, &D, NULL); + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_invmod_slow.c */ + +/* Start: bn_mp_is_square.c */ +#include +#ifdef BN_MP_IS_SQUARE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* Check if remainders are possible squares - fast exclude non-squares */ +static const char rem_128[128] = { + 0, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, + 0, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, + 1, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, + 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, + 0, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, + 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, + 1, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, + 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1 +}; + +static const char rem_105[105] = { + 0, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, + 0, 0, 1, 1, 1, 1, 0, 1, 1, 1, 0, 1, 1, 1, 1, + 0, 1, 1, 1, 1, 1, 0, 1, 1, 0, 1, 1, 1, 1, 1, + 1, 0, 1, 1, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, + 0, 1, 1, 1, 0, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, + 1, 1, 1, 1, 0, 1, 0, 1, 1, 0, 0, 1, 1, 1, 1, + 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1 +}; + +/* Store non-zero to ret if arg is square, and zero if not */ +int mp_is_square(mp_int *arg,int *ret) +{ + int res; + mp_digit c; + mp_int t; + unsigned long r; + + /* Default to Non-square :) */ + *ret = MP_NO; + + if (arg->sign == MP_NEG) { + return MP_VAL; + } + + /* digits used? (TSD) */ + if (arg->used == 0) { + return MP_OKAY; + } + + /* First check mod 128 (suppose that DIGIT_BIT is at least 7) */ + if (rem_128[127 & DIGIT(arg,0)] == 1) { + return MP_OKAY; + } + + /* Next check mod 105 (3*5*7) */ + if ((res = mp_mod_d(arg,105,&c)) != MP_OKAY) { + return res; + } + if (rem_105[c] == 1) { + return MP_OKAY; + } + + + if ((res = mp_init_set_int(&t,11L*13L*17L*19L*23L*29L*31L)) != MP_OKAY) { + return res; + } + if ((res = mp_mod(arg,&t,&t)) != MP_OKAY) { + goto ERR; + } + r = mp_get_int(&t); + /* Check for other prime modules, note it's not an ERROR but we must + * free "t" so the easiest way is to goto ERR. We know that res + * is already equal to MP_OKAY from the mp_mod call + */ + if ( (1L<<(r%11)) & 0x5C4L ) goto ERR; + if ( (1L<<(r%13)) & 0x9E4L ) goto ERR; + if ( (1L<<(r%17)) & 0x5CE8L ) goto ERR; + if ( (1L<<(r%19)) & 0x4F50CL ) goto ERR; + if ( (1L<<(r%23)) & 0x7ACCA0L ) goto ERR; + if ( (1L<<(r%29)) & 0xC2EDD0CL ) goto ERR; + if ( (1L<<(r%31)) & 0x6DE2B848L ) goto ERR; + + /* Final check - is sqr(sqrt(arg)) == arg ? */ + if ((res = mp_sqrt(arg,&t)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sqr(&t,&t)) != MP_OKAY) { + goto ERR; + } + + *ret = (mp_cmp_mag(&t,arg) == MP_EQ) ? MP_YES : MP_NO; +ERR:mp_clear(&t); + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_is_square.c */ + +/* Start: bn_mp_jacobi.c */ +#include +#ifdef BN_MP_JACOBI_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* computes the jacobi c = (a | n) (or Legendre if n is prime) + * HAC pp. 73 Algorithm 2.149 + */ +int mp_jacobi (mp_int * a, mp_int * p, int *c) +{ + mp_int a1, p1; + int k, s, r, res; + mp_digit residue; + + /* if p <= 0 return MP_VAL */ + if (mp_cmp_d(p, 0) != MP_GT) { + return MP_VAL; + } + + /* step 1. if a == 0, return 0 */ + if (mp_iszero (a) == 1) { + *c = 0; + return MP_OKAY; + } + + /* step 2. if a == 1, return 1 */ + if (mp_cmp_d (a, 1) == MP_EQ) { + *c = 1; + return MP_OKAY; + } + + /* default */ + s = 0; + + /* step 3. write a = a1 * 2**k */ + if ((res = mp_init_copy (&a1, a)) != MP_OKAY) { + return res; + } + + if ((res = mp_init (&p1)) != MP_OKAY) { + goto LBL_A1; + } + + /* divide out larger power of two */ + k = mp_cnt_lsb(&a1); + if ((res = mp_div_2d(&a1, k, &a1, NULL)) != MP_OKAY) { + goto LBL_P1; + } + + /* step 4. if e is even set s=1 */ + if ((k & 1) == 0) { + s = 1; + } else { + /* else set s=1 if p = 1/7 (mod 8) or s=-1 if p = 3/5 (mod 8) */ + residue = p->dp[0] & 7; + + if (residue == 1 || residue == 7) { + s = 1; + } else if (residue == 3 || residue == 5) { + s = -1; + } + } + + /* step 5. if p == 3 (mod 4) *and* a1 == 3 (mod 4) then s = -s */ + if ( ((p->dp[0] & 3) == 3) && ((a1.dp[0] & 3) == 3)) { + s = -s; + } + + /* if a1 == 1 we're done */ + if (mp_cmp_d (&a1, 1) == MP_EQ) { + *c = s; + } else { + /* n1 = n mod a1 */ + if ((res = mp_mod (p, &a1, &p1)) != MP_OKAY) { + goto LBL_P1; + } + if ((res = mp_jacobi (&p1, &a1, &r)) != MP_OKAY) { + goto LBL_P1; + } + *c = s * r; + } + + /* done */ + res = MP_OKAY; +LBL_P1:mp_clear (&p1); +LBL_A1:mp_clear (&a1); + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_jacobi.c */ + +/* Start: bn_mp_karatsuba_mul.c */ +#include +#ifdef BN_MP_KARATSUBA_MUL_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* c = |a| * |b| using Karatsuba Multiplication using + * three half size multiplications + * + * Let B represent the radix [e.g. 2**DIGIT_BIT] and + * let n represent half of the number of digits in + * the min(a,b) + * + * a = a1 * B**n + a0 + * b = b1 * B**n + b0 + * + * Then, a * b => + a1b1 * B**2n + ((a1 + a0)(b1 + b0) - (a0b0 + a1b1)) * B + a0b0 + * + * Note that a1b1 and a0b0 are used twice and only need to be + * computed once. So in total three half size (half # of + * digit) multiplications are performed, a0b0, a1b1 and + * (a1+b1)(a0+b0) + * + * Note that a multiplication of half the digits requires + * 1/4th the number of single precision multiplications so in + * total after one call 25% of the single precision multiplications + * are saved. Note also that the call to mp_mul can end up back + * in this function if the a0, a1, b0, or b1 are above the threshold. + * This is known as divide-and-conquer and leads to the famous + * O(N**lg(3)) or O(N**1.584) work which is asymptopically lower than + * the standard O(N**2) that the baseline/comba methods use. + * Generally though the overhead of this method doesn't pay off + * until a certain size (N ~ 80) is reached. + */ +int mp_karatsuba_mul (mp_int * a, mp_int * b, mp_int * c) +{ + mp_int x0, x1, y0, y1, t1, x0y0, x1y1; + int B, err; + + /* default the return code to an error */ + err = MP_MEM; + + /* min # of digits */ + B = MIN (a->used, b->used); + + /* now divide in two */ + B = B >> 1; + + /* init copy all the temps */ + if (mp_init_size (&x0, B) != MP_OKAY) + goto ERR; + if (mp_init_size (&x1, a->used - B) != MP_OKAY) + goto X0; + if (mp_init_size (&y0, B) != MP_OKAY) + goto X1; + if (mp_init_size (&y1, b->used - B) != MP_OKAY) + goto Y0; + + /* init temps */ + if (mp_init_size (&t1, B * 2) != MP_OKAY) + goto Y1; + if (mp_init_size (&x0y0, B * 2) != MP_OKAY) + goto T1; + if (mp_init_size (&x1y1, B * 2) != MP_OKAY) + goto X0Y0; + + /* now shift the digits */ + x0.used = y0.used = B; + x1.used = a->used - B; + y1.used = b->used - B; + + { + register int x; + register mp_digit *tmpa, *tmpb, *tmpx, *tmpy; + + /* we copy the digits directly instead of using higher level functions + * since we also need to shift the digits + */ + tmpa = a->dp; + tmpb = b->dp; + + tmpx = x0.dp; + tmpy = y0.dp; + for (x = 0; x < B; x++) { + *tmpx++ = *tmpa++; + *tmpy++ = *tmpb++; + } + + tmpx = x1.dp; + for (x = B; x < a->used; x++) { + *tmpx++ = *tmpa++; + } + + tmpy = y1.dp; + for (x = B; x < b->used; x++) { + *tmpy++ = *tmpb++; + } + } + + /* only need to clamp the lower words since by definition the + * upper words x1/y1 must have a known number of digits + */ + mp_clamp (&x0); + mp_clamp (&y0); + + /* now calc the products x0y0 and x1y1 */ + /* after this x0 is no longer required, free temp [x0==t2]! */ + if (mp_mul (&x0, &y0, &x0y0) != MP_OKAY) + goto X1Y1; /* x0y0 = x0*y0 */ + if (mp_mul (&x1, &y1, &x1y1) != MP_OKAY) + goto X1Y1; /* x1y1 = x1*y1 */ + + /* now calc x1+x0 and y1+y0 */ + if (s_mp_add (&x1, &x0, &t1) != MP_OKAY) + goto X1Y1; /* t1 = x1 - x0 */ + if (s_mp_add (&y1, &y0, &x0) != MP_OKAY) + goto X1Y1; /* t2 = y1 - y0 */ + if (mp_mul (&t1, &x0, &t1) != MP_OKAY) + goto X1Y1; /* t1 = (x1 + x0) * (y1 + y0) */ + + /* add x0y0 */ + if (mp_add (&x0y0, &x1y1, &x0) != MP_OKAY) + goto X1Y1; /* t2 = x0y0 + x1y1 */ + if (s_mp_sub (&t1, &x0, &t1) != MP_OKAY) + goto X1Y1; /* t1 = (x1+x0)*(y1+y0) - (x1y1 + x0y0) */ + + /* shift by B */ + if (mp_lshd (&t1, B) != MP_OKAY) + goto X1Y1; /* t1 = (x0y0 + x1y1 - (x1-x0)*(y1-y0))< +#ifdef BN_MP_KARATSUBA_SQR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* Karatsuba squaring, computes b = a*a using three + * half size squarings + * + * See comments of karatsuba_mul for details. It + * is essentially the same algorithm but merely + * tuned to perform recursive squarings. + */ +int mp_karatsuba_sqr (mp_int * a, mp_int * b) +{ + mp_int x0, x1, t1, t2, x0x0, x1x1; + int B, err; + + err = MP_MEM; + + /* min # of digits */ + B = a->used; + + /* now divide in two */ + B = B >> 1; + + /* init copy all the temps */ + if (mp_init_size (&x0, B) != MP_OKAY) + goto ERR; + if (mp_init_size (&x1, a->used - B) != MP_OKAY) + goto X0; + + /* init temps */ + if (mp_init_size (&t1, a->used * 2) != MP_OKAY) + goto X1; + if (mp_init_size (&t2, a->used * 2) != MP_OKAY) + goto T1; + if (mp_init_size (&x0x0, B * 2) != MP_OKAY) + goto T2; + if (mp_init_size (&x1x1, (a->used - B) * 2) != MP_OKAY) + goto X0X0; + + { + register int x; + register mp_digit *dst, *src; + + src = a->dp; + + /* now shift the digits */ + dst = x0.dp; + for (x = 0; x < B; x++) { + *dst++ = *src++; + } + + dst = x1.dp; + for (x = B; x < a->used; x++) { + *dst++ = *src++; + } + } + + x0.used = B; + x1.used = a->used - B; + + mp_clamp (&x0); + + /* now calc the products x0*x0 and x1*x1 */ + if (mp_sqr (&x0, &x0x0) != MP_OKAY) + goto X1X1; /* x0x0 = x0*x0 */ + if (mp_sqr (&x1, &x1x1) != MP_OKAY) + goto X1X1; /* x1x1 = x1*x1 */ + + /* now calc (x1+x0)**2 */ + if (s_mp_add (&x1, &x0, &t1) != MP_OKAY) + goto X1X1; /* t1 = x1 - x0 */ + if (mp_sqr (&t1, &t1) != MP_OKAY) + goto X1X1; /* t1 = (x1 - x0) * (x1 - x0) */ + + /* add x0y0 */ + if (s_mp_add (&x0x0, &x1x1, &t2) != MP_OKAY) + goto X1X1; /* t2 = x0x0 + x1x1 */ + if (s_mp_sub (&t1, &t2, &t1) != MP_OKAY) + goto X1X1; /* t1 = (x1+x0)**2 - (x0x0 + x1x1) */ + + /* shift by B */ + if (mp_lshd (&t1, B) != MP_OKAY) + goto X1X1; /* t1 = (x0x0 + x1x1 - (x1-x0)*(x1-x0))< +#ifdef BN_MP_LCM_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* computes least common multiple as |a*b|/(a, b) */ +int mp_lcm (mp_int * a, mp_int * b, mp_int * c) +{ + int res; + mp_int t1, t2; + + + if ((res = mp_init_multi (&t1, &t2, NULL)) != MP_OKAY) { + return res; + } + + /* t1 = get the GCD of the two inputs */ + if ((res = mp_gcd (a, b, &t1)) != MP_OKAY) { + goto LBL_T; + } + + /* divide the smallest by the GCD */ + if (mp_cmp_mag(a, b) == MP_LT) { + /* store quotient in t2 such that t2 * b is the LCM */ + if ((res = mp_div(a, &t1, &t2, NULL)) != MP_OKAY) { + goto LBL_T; + } + res = mp_mul(b, &t2, c); + } else { + /* store quotient in t2 such that t2 * a is the LCM */ + if ((res = mp_div(b, &t1, &t2, NULL)) != MP_OKAY) { + goto LBL_T; + } + res = mp_mul(a, &t2, c); + } + + /* fix the sign to positive */ + c->sign = MP_ZPOS; + +LBL_T: + mp_clear_multi (&t1, &t2, NULL); + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_lcm.c */ + +/* Start: bn_mp_lshd.c */ +#include +#ifdef BN_MP_LSHD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* shift left a certain amount of digits */ +int mp_lshd (mp_int * a, int b) +{ + int x, res; + + /* if its less than zero return */ + if (b <= 0) { + return MP_OKAY; + } + + /* grow to fit the new digits */ + if (a->alloc < a->used + b) { + if ((res = mp_grow (a, a->used + b)) != MP_OKAY) { + return res; + } + } + + { + register mp_digit *top, *bottom; + + /* increment the used by the shift amount then copy upwards */ + a->used += b; + + /* top */ + top = a->dp + a->used - 1; + + /* base */ + bottom = a->dp + a->used - 1 - b; + + /* much like mp_rshd this is implemented using a sliding window + * except the window goes the otherway around. Copying from + * the bottom to the top. see bn_mp_rshd.c for more info. + */ + for (x = a->used - 1; x >= b; x--) { + *top-- = *bottom--; + } + + /* zero the lower digits */ + top = a->dp; + for (x = 0; x < b; x++) { + *top++ = 0; + } + } + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_lshd.c */ + +/* Start: bn_mp_mod.c */ +#include +#ifdef BN_MP_MOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* c = a mod b, 0 <= c < b */ +int +mp_mod (mp_int * a, mp_int * b, mp_int * c) +{ + mp_int t; + int res; + + if ((res = mp_init (&t)) != MP_OKAY) { + return res; + } + + if ((res = mp_div (a, b, NULL, &t)) != MP_OKAY) { + mp_clear (&t); + return res; + } + + if (t.sign != b->sign) { + res = mp_add (b, &t, c); + } else { + res = MP_OKAY; + mp_exch (&t, c); + } + + mp_clear (&t); + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_mod.c */ + +/* Start: bn_mp_mod_2d.c */ +#include +#ifdef BN_MP_MOD_2D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* calc a value mod 2**b */ +int +mp_mod_2d (mp_int * a, int b, mp_int * c) +{ + int x, res; + + /* if b is <= 0 then zero the int */ + if (b <= 0) { + mp_zero (c); + return MP_OKAY; + } + + /* if the modulus is larger than the value than return */ + if (b >= (int) (a->used * DIGIT_BIT)) { + res = mp_copy (a, c); + return res; + } + + /* copy */ + if ((res = mp_copy (a, c)) != MP_OKAY) { + return res; + } + + /* zero digits above the last digit of the modulus */ + for (x = (b / DIGIT_BIT) + ((b % DIGIT_BIT) == 0 ? 0 : 1); x < c->used; x++) { + c->dp[x] = 0; + } + /* clear the digit that is not completely outside/inside the modulus */ + c->dp[b / DIGIT_BIT] &= + (mp_digit) ((((mp_digit) 1) << (((mp_digit) b) % DIGIT_BIT)) - ((mp_digit) 1)); + mp_clamp (c); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_mod_2d.c */ + +/* Start: bn_mp_mod_d.c */ +#include +#ifdef BN_MP_MOD_D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +int +mp_mod_d (mp_int * a, mp_digit b, mp_digit * c) +{ + return mp_div_d(a, b, NULL, c); +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_mod_d.c */ + +/* Start: bn_mp_montgomery_calc_normalization.c */ +#include +#ifdef BN_MP_MONTGOMERY_CALC_NORMALIZATION_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* + * shifts with subtractions when the result is greater than b. + * + * The method is slightly modified to shift B unconditionally upto just under + * the leading bit of b. This saves alot of multiple precision shifting. + */ +int mp_montgomery_calc_normalization (mp_int * a, mp_int * b) +{ + int x, bits, res; + + /* how many bits of last digit does b use */ + bits = mp_count_bits (b) % DIGIT_BIT; + + if (b->used > 1) { + if ((res = mp_2expt (a, (b->used - 1) * DIGIT_BIT + bits - 1)) != MP_OKAY) { + return res; + } + } else { + mp_set(a, 1); + bits = 1; + } + + + /* now compute C = A * B mod b */ + for (x = bits - 1; x < (int)DIGIT_BIT; x++) { + if ((res = mp_mul_2 (a, a)) != MP_OKAY) { + return res; + } + if (mp_cmp_mag (a, b) != MP_LT) { + if ((res = s_mp_sub (a, b, a)) != MP_OKAY) { + return res; + } + } + } + + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_montgomery_calc_normalization.c */ + +/* Start: bn_mp_montgomery_reduce.c */ +#include +#ifdef BN_MP_MONTGOMERY_REDUCE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* computes xR**-1 == x (mod N) via Montgomery Reduction */ +int +mp_montgomery_reduce (mp_int * x, mp_int * n, mp_digit rho) +{ + int ix, res, digs; + mp_digit mu; + + /* can the fast reduction [comba] method be used? + * + * Note that unlike in mul you're safely allowed *less* + * than the available columns [255 per default] since carries + * are fixed up in the inner loop. + */ + digs = n->used * 2 + 1; + if ((digs < MP_WARRAY) && + n->used < + (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) { + return fast_mp_montgomery_reduce (x, n, rho); + } + + /* grow the input as required */ + if (x->alloc < digs) { + if ((res = mp_grow (x, digs)) != MP_OKAY) { + return res; + } + } + x->used = digs; + + for (ix = 0; ix < n->used; ix++) { + /* mu = ai * rho mod b + * + * The value of rho must be precalculated via + * montgomery_setup() such that + * it equals -1/n0 mod b this allows the + * following inner loop to reduce the + * input one digit at a time + */ + mu = (mp_digit) (((mp_word)x->dp[ix]) * ((mp_word)rho) & MP_MASK); + + /* a = a + mu * m * b**i */ + { + register int iy; + register mp_digit *tmpn, *tmpx, u; + register mp_word r; + + /* alias for digits of the modulus */ + tmpn = n->dp; + + /* alias for the digits of x [the input] */ + tmpx = x->dp + ix; + + /* set the carry to zero */ + u = 0; + + /* Multiply and add in place */ + for (iy = 0; iy < n->used; iy++) { + /* compute product and sum */ + r = ((mp_word)mu) * ((mp_word)*tmpn++) + + ((mp_word) u) + ((mp_word) * tmpx); + + /* get carry */ + u = (mp_digit)(r >> ((mp_word) DIGIT_BIT)); + + /* fix digit */ + *tmpx++ = (mp_digit)(r & ((mp_word) MP_MASK)); + } + /* At this point the ix'th digit of x should be zero */ + + + /* propagate carries upwards as required*/ + while (u) { + *tmpx += u; + u = *tmpx >> DIGIT_BIT; + *tmpx++ &= MP_MASK; + } + } + } + + /* at this point the n.used'th least + * significant digits of x are all zero + * which means we can shift x to the + * right by n.used digits and the + * residue is unchanged. + */ + + /* x = x/b**n.used */ + mp_clamp(x); + mp_rshd (x, n->used); + + /* if x >= n then x = x - n */ + if (mp_cmp_mag (x, n) != MP_LT) { + return s_mp_sub (x, n, x); + } + + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_montgomery_reduce.c */ + +/* Start: bn_mp_montgomery_setup.c */ +#include +#ifdef BN_MP_MONTGOMERY_SETUP_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* setups the montgomery reduction stuff */ +int +mp_montgomery_setup (mp_int * n, mp_digit * rho) +{ + mp_digit x, b; + +/* fast inversion mod 2**k + * + * Based on the fact that + * + * XA = 1 (mod 2**n) => (X(2-XA)) A = 1 (mod 2**2n) + * => 2*X*A - X*X*A*A = 1 + * => 2*(1) - (1) = 1 + */ + b = n->dp[0]; + + if ((b & 1) == 0) { + return MP_VAL; + } + + x = (((b + 2) & 4) << 1) + b; /* here x*a==1 mod 2**4 */ + x *= 2 - b * x; /* here x*a==1 mod 2**8 */ +#if !defined(MP_8BIT) + x *= 2 - b * x; /* here x*a==1 mod 2**16 */ +#endif +#if defined(MP_64BIT) || !(defined(MP_8BIT) || defined(MP_16BIT)) + x *= 2 - b * x; /* here x*a==1 mod 2**32 */ +#endif +#ifdef MP_64BIT + x *= 2 - b * x; /* here x*a==1 mod 2**64 */ +#endif + + /* rho = -1/m mod b */ + *rho = (((mp_word)1 << ((mp_word) DIGIT_BIT)) - x) & MP_MASK; + + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_montgomery_setup.c */ + +/* Start: bn_mp_mul.c */ +#include +#ifdef BN_MP_MUL_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* high level multiplication (handles sign) */ +int mp_mul (mp_int * a, mp_int * b, mp_int * c) +{ + int res, neg; + neg = (a->sign == b->sign) ? MP_ZPOS : MP_NEG; + + /* use Toom-Cook? */ +#ifdef BN_MP_TOOM_MUL_C + if (MIN (a->used, b->used) >= TOOM_MUL_CUTOFF) { + res = mp_toom_mul(a, b, c); + } else +#endif +#ifdef BN_MP_KARATSUBA_MUL_C + /* use Karatsuba? */ + if (MIN (a->used, b->used) >= KARATSUBA_MUL_CUTOFF) { + res = mp_karatsuba_mul (a, b, c); + } else +#endif + { + /* can we use the fast multiplier? + * + * The fast multiplier can be used if the output will + * have less than MP_WARRAY digits and the number of + * digits won't affect carry propagation + */ + int digs = a->used + b->used + 1; + +#ifdef BN_FAST_S_MP_MUL_DIGS_C + if ((digs < MP_WARRAY) && + MIN(a->used, b->used) <= + (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) { + res = fast_s_mp_mul_digs (a, b, c, digs); + } else +#endif +#ifdef BN_S_MP_MUL_DIGS_C + res = s_mp_mul (a, b, c); /* uses s_mp_mul_digs */ +#else + res = MP_VAL; +#endif + + } + c->sign = (c->used > 0) ? neg : MP_ZPOS; + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_mul.c */ + +/* Start: bn_mp_mul_2.c */ +#include +#ifdef BN_MP_MUL_2_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* b = a*2 */ +int mp_mul_2(mp_int * a, mp_int * b) +{ + int x, res, oldused; + + /* grow to accomodate result */ + if (b->alloc < a->used + 1) { + if ((res = mp_grow (b, a->used + 1)) != MP_OKAY) { + return res; + } + } + + oldused = b->used; + b->used = a->used; + + { + register mp_digit r, rr, *tmpa, *tmpb; + + /* alias for source */ + tmpa = a->dp; + + /* alias for dest */ + tmpb = b->dp; + + /* carry */ + r = 0; + for (x = 0; x < a->used; x++) { + + /* get what will be the *next* carry bit from the + * MSB of the current digit + */ + rr = *tmpa >> ((mp_digit)(DIGIT_BIT - 1)); + + /* now shift up this digit, add in the carry [from the previous] */ + *tmpb++ = ((*tmpa++ << ((mp_digit)1)) | r) & MP_MASK; + + /* copy the carry that would be from the source + * digit into the next iteration + */ + r = rr; + } + + /* new leading digit? */ + if (r != 0) { + /* add a MSB which is always 1 at this point */ + *tmpb = 1; + ++(b->used); + } + + /* now zero any excess digits on the destination + * that we didn't write to + */ + tmpb = b->dp + b->used; + for (x = b->used; x < oldused; x++) { + *tmpb++ = 0; + } + } + b->sign = a->sign; + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_mul_2.c */ + +/* Start: bn_mp_mul_2d.c */ +#include +#ifdef BN_MP_MUL_2D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* shift left by a certain bit count */ +int mp_mul_2d (mp_int * a, int b, mp_int * c) +{ + mp_digit d; + int res; + + /* copy */ + if (a != c) { + if ((res = mp_copy (a, c)) != MP_OKAY) { + return res; + } + } + + if (c->alloc < (int)(c->used + b/DIGIT_BIT + 1)) { + if ((res = mp_grow (c, c->used + b / DIGIT_BIT + 1)) != MP_OKAY) { + return res; + } + } + + /* shift by as many digits in the bit count */ + if (b >= (int)DIGIT_BIT) { + if ((res = mp_lshd (c, b / DIGIT_BIT)) != MP_OKAY) { + return res; + } + } + + /* shift any bit count < DIGIT_BIT */ + d = (mp_digit) (b % DIGIT_BIT); + if (d != 0) { + register mp_digit *tmpc, shift, mask, r, rr; + register int x; + + /* bitmask for carries */ + mask = (((mp_digit)1) << d) - 1; + + /* shift for msbs */ + shift = DIGIT_BIT - d; + + /* alias */ + tmpc = c->dp; + + /* carry */ + r = 0; + for (x = 0; x < c->used; x++) { + /* get the higher bits of the current word */ + rr = (*tmpc >> shift) & mask; + + /* shift the current word and OR in the carry */ + *tmpc = ((*tmpc << d) | r) & MP_MASK; + ++tmpc; + + /* set the carry to the carry bits of the current word */ + r = rr; + } + + /* set final carry */ + if (r != 0) { + c->dp[(c->used)++] = r; + } + } + mp_clamp (c); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_mul_2d.c */ + +/* Start: bn_mp_mul_d.c */ +#include +#ifdef BN_MP_MUL_D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* multiply by a digit */ +int +mp_mul_d (mp_int * a, mp_digit b, mp_int * c) +{ + mp_digit u, *tmpa, *tmpc; + mp_word r; + int ix, res, olduse; + + /* make sure c is big enough to hold a*b */ + if (c->alloc < a->used + 1) { + if ((res = mp_grow (c, a->used + 1)) != MP_OKAY) { + return res; + } + } + + /* get the original destinations used count */ + olduse = c->used; + + /* set the sign */ + c->sign = a->sign; + + /* alias for a->dp [source] */ + tmpa = a->dp; + + /* alias for c->dp [dest] */ + tmpc = c->dp; + + /* zero carry */ + u = 0; + + /* compute columns */ + for (ix = 0; ix < a->used; ix++) { + /* compute product and carry sum for this term */ + r = ((mp_word) u) + ((mp_word)*tmpa++) * ((mp_word)b); + + /* mask off higher bits to get a single digit */ + *tmpc++ = (mp_digit) (r & ((mp_word) MP_MASK)); + + /* send carry into next iteration */ + u = (mp_digit) (r >> ((mp_word) DIGIT_BIT)); + } + + /* store final carry [if any] and increment ix offset */ + *tmpc++ = u; + ++ix; + + /* now zero digits above the top */ + while (ix++ < olduse) { + *tmpc++ = 0; + } + + /* set used count */ + c->used = a->used + 1; + mp_clamp(c); + + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_mul_d.c */ + +/* Start: bn_mp_mulmod.c */ +#include +#ifdef BN_MP_MULMOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* d = a * b (mod c) */ +int mp_mulmod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) +{ + int res; + mp_int t; + + if ((res = mp_init (&t)) != MP_OKAY) { + return res; + } + + if ((res = mp_mul (a, b, &t)) != MP_OKAY) { + mp_clear (&t); + return res; + } + res = mp_mod (&t, c, d); + mp_clear (&t); + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_mulmod.c */ + +/* Start: bn_mp_n_root.c */ +#include +#ifdef BN_MP_N_ROOT_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* find the n'th root of an integer + * + * Result found such that (c)**b <= a and (c+1)**b > a + * + * This algorithm uses Newton's approximation + * x[i+1] = x[i] - f(x[i])/f'(x[i]) + * which will find the root in log(N) time where + * each step involves a fair bit. This is not meant to + * find huge roots [square and cube, etc]. + */ +int mp_n_root (mp_int * a, mp_digit b, mp_int * c) +{ + mp_int t1, t2, t3; + int res, neg; + + /* input must be positive if b is even */ + if ((b & 1) == 0 && a->sign == MP_NEG) { + return MP_VAL; + } + + if ((res = mp_init (&t1)) != MP_OKAY) { + return res; + } + + if ((res = mp_init (&t2)) != MP_OKAY) { + goto LBL_T1; + } + + if ((res = mp_init (&t3)) != MP_OKAY) { + goto LBL_T2; + } + + /* if a is negative fudge the sign but keep track */ + neg = a->sign; + a->sign = MP_ZPOS; + + /* t2 = 2 */ + mp_set (&t2, 2); + + do { + /* t1 = t2 */ + if ((res = mp_copy (&t2, &t1)) != MP_OKAY) { + goto LBL_T3; + } + + /* t2 = t1 - ((t1**b - a) / (b * t1**(b-1))) */ + + /* t3 = t1**(b-1) */ + if ((res = mp_expt_d (&t1, b - 1, &t3)) != MP_OKAY) { + goto LBL_T3; + } + + /* numerator */ + /* t2 = t1**b */ + if ((res = mp_mul (&t3, &t1, &t2)) != MP_OKAY) { + goto LBL_T3; + } + + /* t2 = t1**b - a */ + if ((res = mp_sub (&t2, a, &t2)) != MP_OKAY) { + goto LBL_T3; + } + + /* denominator */ + /* t3 = t1**(b-1) * b */ + if ((res = mp_mul_d (&t3, b, &t3)) != MP_OKAY) { + goto LBL_T3; + } + + /* t3 = (t1**b - a)/(b * t1**(b-1)) */ + if ((res = mp_div (&t2, &t3, &t3, NULL)) != MP_OKAY) { + goto LBL_T3; + } + + if ((res = mp_sub (&t1, &t3, &t2)) != MP_OKAY) { + goto LBL_T3; + } + } while (mp_cmp (&t1, &t2) != MP_EQ); + + /* result can be off by a few so check */ + for (;;) { + if ((res = mp_expt_d (&t1, b, &t2)) != MP_OKAY) { + goto LBL_T3; + } + + if (mp_cmp (&t2, a) == MP_GT) { + if ((res = mp_sub_d (&t1, 1, &t1)) != MP_OKAY) { + goto LBL_T3; + } + } else { + break; + } + } + + /* reset the sign of a first */ + a->sign = neg; + + /* set the result */ + mp_exch (&t1, c); + + /* set the sign of the result */ + c->sign = neg; + + res = MP_OKAY; + +LBL_T3:mp_clear (&t3); +LBL_T2:mp_clear (&t2); +LBL_T1:mp_clear (&t1); + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_n_root.c */ + +/* Start: bn_mp_neg.c */ +#include +#ifdef BN_MP_NEG_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* b = -a */ +int mp_neg (mp_int * a, mp_int * b) +{ + int res; + if (a != b) { + if ((res = mp_copy (a, b)) != MP_OKAY) { + return res; + } + } + + if (mp_iszero(b) != MP_YES) { + b->sign = (a->sign == MP_ZPOS) ? MP_NEG : MP_ZPOS; + } else { + b->sign = MP_ZPOS; + } + + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_neg.c */ + +/* Start: bn_mp_or.c */ +#include +#ifdef BN_MP_OR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* OR two ints together */ +int mp_or (mp_int * a, mp_int * b, mp_int * c) +{ + int res, ix, px; + mp_int t, *x; + + if (a->used > b->used) { + if ((res = mp_init_copy (&t, a)) != MP_OKAY) { + return res; + } + px = b->used; + x = b; + } else { + if ((res = mp_init_copy (&t, b)) != MP_OKAY) { + return res; + } + px = a->used; + x = a; + } + + for (ix = 0; ix < px; ix++) { + t.dp[ix] |= x->dp[ix]; + } + mp_clamp (&t); + mp_exch (c, &t); + mp_clear (&t); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_or.c */ + +/* Start: bn_mp_prime_fermat.c */ +#include +#ifdef BN_MP_PRIME_FERMAT_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* performs one Fermat test. + * + * If "a" were prime then b**a == b (mod a) since the order of + * the multiplicative sub-group would be phi(a) = a-1. That means + * it would be the same as b**(a mod (a-1)) == b**1 == b (mod a). + * + * Sets result to 1 if the congruence holds, or zero otherwise. + */ +int mp_prime_fermat (mp_int * a, mp_int * b, int *result) +{ + mp_int t; + int err; + + /* default to composite */ + *result = MP_NO; + + /* ensure b > 1 */ + if (mp_cmp_d(b, 1) != MP_GT) { + return MP_VAL; + } + + /* init t */ + if ((err = mp_init (&t)) != MP_OKAY) { + return err; + } + + /* compute t = b**a mod a */ + if ((err = mp_exptmod (b, a, a, &t)) != MP_OKAY) { + goto LBL_T; + } + + /* is it equal to b? */ + if (mp_cmp (&t, b) == MP_EQ) { + *result = MP_YES; + } + + err = MP_OKAY; +LBL_T:mp_clear (&t); + return err; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_prime_fermat.c */ + +/* Start: bn_mp_prime_is_divisible.c */ +#include +#ifdef BN_MP_PRIME_IS_DIVISIBLE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* determines if an integers is divisible by one + * of the first PRIME_SIZE primes or not + * + * sets result to 0 if not, 1 if yes + */ +int mp_prime_is_divisible (mp_int * a, int *result) +{ + int err, ix; + mp_digit res; + + /* default to not */ + *result = MP_NO; + + for (ix = 0; ix < PRIME_SIZE; ix++) { + /* what is a mod LBL_prime_tab[ix] */ + if ((err = mp_mod_d (a, ltm_prime_tab[ix], &res)) != MP_OKAY) { + return err; + } + + /* is the residue zero? */ + if (res == 0) { + *result = MP_YES; + return MP_OKAY; + } + } + + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_prime_is_divisible.c */ + +/* Start: bn_mp_prime_is_prime.c */ +#include +#ifdef BN_MP_PRIME_IS_PRIME_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* performs a variable number of rounds of Miller-Rabin + * + * Probability of error after t rounds is no more than + + * + * Sets result to 1 if probably prime, 0 otherwise + */ +int mp_prime_is_prime (mp_int * a, int t, int *result) +{ + mp_int b; + int ix, err, res; + + /* default to no */ + *result = MP_NO; + + /* valid value of t? */ + if (t <= 0 || t > PRIME_SIZE) { + return MP_VAL; + } + + /* is the input equal to one of the primes in the table? */ + for (ix = 0; ix < PRIME_SIZE; ix++) { + if (mp_cmp_d(a, ltm_prime_tab[ix]) == MP_EQ) { + *result = 1; + return MP_OKAY; + } + } + + /* first perform trial division */ + if ((err = mp_prime_is_divisible (a, &res)) != MP_OKAY) { + return err; + } + + /* return if it was trivially divisible */ + if (res == MP_YES) { + return MP_OKAY; + } + + /* now perform the miller-rabin rounds */ + if ((err = mp_init (&b)) != MP_OKAY) { + return err; + } + + for (ix = 0; ix < t; ix++) { + /* set the prime */ + mp_set (&b, ltm_prime_tab[ix]); + + if ((err = mp_prime_miller_rabin (a, &b, &res)) != MP_OKAY) { + goto LBL_B; + } + + if (res == MP_NO) { + goto LBL_B; + } + } + + /* passed the test */ + *result = MP_YES; +LBL_B:mp_clear (&b); + return err; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_prime_is_prime.c */ + +/* Start: bn_mp_prime_miller_rabin.c */ +#include +#ifdef BN_MP_PRIME_MILLER_RABIN_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* Miller-Rabin test of "a" to the base of "b" as described in + * HAC pp. 139 Algorithm 4.24 + * + * Sets result to 0 if definitely composite or 1 if probably prime. + * Randomly the chance of error is no more than 1/4 and often + * very much lower. + */ +int mp_prime_miller_rabin (mp_int * a, mp_int * b, int *result) +{ + mp_int n1, y, r; + int s, j, err; + + /* default */ + *result = MP_NO; + + /* ensure b > 1 */ + if (mp_cmp_d(b, 1) != MP_GT) { + return MP_VAL; + } + + /* get n1 = a - 1 */ + if ((err = mp_init_copy (&n1, a)) != MP_OKAY) { + return err; + } + if ((err = mp_sub_d (&n1, 1, &n1)) != MP_OKAY) { + goto LBL_N1; + } + + /* set 2**s * r = n1 */ + if ((err = mp_init_copy (&r, &n1)) != MP_OKAY) { + goto LBL_N1; + } + + /* count the number of least significant bits + * which are zero + */ + s = mp_cnt_lsb(&r); + + /* now divide n - 1 by 2**s */ + if ((err = mp_div_2d (&r, s, &r, NULL)) != MP_OKAY) { + goto LBL_R; + } + + /* compute y = b**r mod a */ + if ((err = mp_init (&y)) != MP_OKAY) { + goto LBL_R; + } + if ((err = mp_exptmod (b, &r, a, &y)) != MP_OKAY) { + goto LBL_Y; + } + + /* if y != 1 and y != n1 do */ + if (mp_cmp_d (&y, 1) != MP_EQ && mp_cmp (&y, &n1) != MP_EQ) { + j = 1; + /* while j <= s-1 and y != n1 */ + while ((j <= (s - 1)) && mp_cmp (&y, &n1) != MP_EQ) { + if ((err = mp_sqrmod (&y, a, &y)) != MP_OKAY) { + goto LBL_Y; + } + + /* if y == 1 then composite */ + if (mp_cmp_d (&y, 1) == MP_EQ) { + goto LBL_Y; + } + + ++j; + } + + /* if y != n1 then composite */ + if (mp_cmp (&y, &n1) != MP_EQ) { + goto LBL_Y; + } + } + + /* probably prime now */ + *result = MP_YES; +LBL_Y:mp_clear (&y); +LBL_R:mp_clear (&r); +LBL_N1:mp_clear (&n1); + return err; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_prime_miller_rabin.c */ + +/* Start: bn_mp_prime_next_prime.c */ +#include +#ifdef BN_MP_PRIME_NEXT_PRIME_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* finds the next prime after the number "a" using "t" trials + * of Miller-Rabin. + * + * bbs_style = 1 means the prime must be congruent to 3 mod 4 + */ +int mp_prime_next_prime(mp_int *a, int t, int bbs_style) +{ + int err, res, x, y; + mp_digit res_tab[PRIME_SIZE], step, kstep; + mp_int b; + + /* ensure t is valid */ + if (t <= 0 || t > PRIME_SIZE) { + return MP_VAL; + } + + /* force positive */ + a->sign = MP_ZPOS; + + /* simple algo if a is less than the largest prime in the table */ + if (mp_cmp_d(a, ltm_prime_tab[PRIME_SIZE-1]) == MP_LT) { + /* find which prime it is bigger than */ + for (x = PRIME_SIZE - 2; x >= 0; x--) { + if (mp_cmp_d(a, ltm_prime_tab[x]) != MP_LT) { + if (bbs_style == 1) { + /* ok we found a prime smaller or + * equal [so the next is larger] + * + * however, the prime must be + * congruent to 3 mod 4 + */ + if ((ltm_prime_tab[x + 1] & 3) != 3) { + /* scan upwards for a prime congruent to 3 mod 4 */ + for (y = x + 1; y < PRIME_SIZE; y++) { + if ((ltm_prime_tab[y] & 3) == 3) { + mp_set(a, ltm_prime_tab[y]); + return MP_OKAY; + } + } + } + } else { + mp_set(a, ltm_prime_tab[x + 1]); + return MP_OKAY; + } + } + } + /* at this point a maybe 1 */ + if (mp_cmp_d(a, 1) == MP_EQ) { + mp_set(a, 2); + return MP_OKAY; + } + /* fall through to the sieve */ + } + + /* generate a prime congruent to 3 mod 4 or 1/3 mod 4? */ + if (bbs_style == 1) { + kstep = 4; + } else { + kstep = 2; + } + + /* at this point we will use a combination of a sieve and Miller-Rabin */ + + if (bbs_style == 1) { + /* if a mod 4 != 3 subtract the correct value to make it so */ + if ((a->dp[0] & 3) != 3) { + if ((err = mp_sub_d(a, (a->dp[0] & 3) + 1, a)) != MP_OKAY) { return err; }; + } + } else { + if (mp_iseven(a) == 1) { + /* force odd */ + if ((err = mp_sub_d(a, 1, a)) != MP_OKAY) { + return err; + } + } + } + + /* generate the restable */ + for (x = 1; x < PRIME_SIZE; x++) { + if ((err = mp_mod_d(a, ltm_prime_tab[x], res_tab + x)) != MP_OKAY) { + return err; + } + } + + /* init temp used for Miller-Rabin Testing */ + if ((err = mp_init(&b)) != MP_OKAY) { + return err; + } + + for (;;) { + /* skip to the next non-trivially divisible candidate */ + step = 0; + do { + /* y == 1 if any residue was zero [e.g. cannot be prime] */ + y = 0; + + /* increase step to next candidate */ + step += kstep; + + /* compute the new residue without using division */ + for (x = 1; x < PRIME_SIZE; x++) { + /* add the step to each residue */ + res_tab[x] += kstep; + + /* subtract the modulus [instead of using division] */ + if (res_tab[x] >= ltm_prime_tab[x]) { + res_tab[x] -= ltm_prime_tab[x]; + } + + /* set flag if zero */ + if (res_tab[x] == 0) { + y = 1; + } + } + } while (y == 1 && step < ((((mp_digit)1)<= ((((mp_digit)1)< +#ifdef BN_MP_PRIME_RABIN_MILLER_TRIALS_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + + +static const struct { + int k, t; +} sizes[] = { +{ 128, 28 }, +{ 256, 16 }, +{ 384, 10 }, +{ 512, 7 }, +{ 640, 6 }, +{ 768, 5 }, +{ 896, 4 }, +{ 1024, 4 } +}; + +/* returns # of RM trials required for a given bit size */ +int mp_prime_rabin_miller_trials(int size) +{ + int x; + + for (x = 0; x < (int)(sizeof(sizes)/(sizeof(sizes[0]))); x++) { + if (sizes[x].k == size) { + return sizes[x].t; + } else if (sizes[x].k > size) { + return (x == 0) ? sizes[0].t : sizes[x - 1].t; + } + } + return sizes[x-1].t + 1; +} + + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_prime_rabin_miller_trials.c */ + +/* Start: bn_mp_prime_random_ex.c */ +#include +#ifdef BN_MP_PRIME_RANDOM_EX_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* makes a truly random prime of a given size (bits), + * + * Flags are as follows: + * + * LTM_PRIME_BBS - make prime congruent to 3 mod 4 + * LTM_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies LTM_PRIME_BBS) + * LTM_PRIME_2MSB_OFF - make the 2nd highest bit zero + * LTM_PRIME_2MSB_ON - make the 2nd highest bit one + * + * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can + * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself + * so it can be NULL + * + */ + +/* This is possibly the mother of all prime generation functions, muahahahahaha! */ +int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback cb, void *dat) +{ + unsigned char *tmp, maskAND, maskOR_msb, maskOR_lsb; + int res, err, bsize, maskOR_msb_offset; + + /* sanity check the input */ + if (size <= 1 || t <= 0) { + return MP_VAL; + } + + /* LTM_PRIME_SAFE implies LTM_PRIME_BBS */ + if (flags & LTM_PRIME_SAFE) { + flags |= LTM_PRIME_BBS; + } + + /* calc the byte size */ + bsize = (size>>3) + ((size&7)?1:0); + + /* we need a buffer of bsize bytes */ + tmp = OPT_CAST(unsigned char) XMALLOC(bsize); + if (tmp == NULL) { + return MP_MEM; + } + + /* calc the maskAND value for the MSbyte*/ + maskAND = ((size&7) == 0) ? 0xFF : (0xFF >> (8 - (size & 7))); + + /* calc the maskOR_msb */ + maskOR_msb = 0; + maskOR_msb_offset = ((size & 7) == 1) ? 1 : 0; + if (flags & LTM_PRIME_2MSB_ON) { + maskOR_msb |= 0x80 >> ((9 - size) & 7); + } + + /* get the maskOR_lsb */ + maskOR_lsb = 1; + if (flags & LTM_PRIME_BBS) { + maskOR_lsb |= 3; + } + + do { + /* read the bytes */ + if (cb(tmp, bsize, dat) != bsize) { + err = MP_VAL; + goto error; + } + + /* work over the MSbyte */ + tmp[0] &= maskAND; + tmp[0] |= 1 << ((size - 1) & 7); + + /* mix in the maskORs */ + tmp[maskOR_msb_offset] |= maskOR_msb; + tmp[bsize-1] |= maskOR_lsb; + + /* read it in */ + if ((err = mp_read_unsigned_bin(a, tmp, bsize)) != MP_OKAY) { goto error; } + + /* is it prime? */ + if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY) { goto error; } + if (res == MP_NO) { + continue; + } + + if (flags & LTM_PRIME_SAFE) { + /* see if (a-1)/2 is prime */ + if ((err = mp_sub_d(a, 1, a)) != MP_OKAY) { goto error; } + if ((err = mp_div_2(a, a)) != MP_OKAY) { goto error; } + + /* is it prime? */ + if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY) { goto error; } + } + } while (res == MP_NO); + + if (flags & LTM_PRIME_SAFE) { + /* restore a to the original value */ + if ((err = mp_mul_2(a, a)) != MP_OKAY) { goto error; } + if ((err = mp_add_d(a, 1, a)) != MP_OKAY) { goto error; } + } + + err = MP_OKAY; +error: + XFREE(tmp); + return err; +} + + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_prime_random_ex.c */ + +/* Start: bn_mp_radix_size.c */ +#include +#ifdef BN_MP_RADIX_SIZE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* returns size of ASCII reprensentation */ +int mp_radix_size (mp_int * a, int radix, int *size) +{ + int res, digs; + mp_int t; + mp_digit d; + + *size = 0; + + /* special case for binary */ + if (radix == 2) { + *size = mp_count_bits (a) + (a->sign == MP_NEG ? 1 : 0) + 1; + return MP_OKAY; + } + + /* make sure the radix is in range */ + if (radix < 2 || radix > 64) { + return MP_VAL; + } + + if (mp_iszero(a) == MP_YES) { + *size = 2; + return MP_OKAY; + } + + /* digs is the digit count */ + digs = 0; + + /* if it's negative add one for the sign */ + if (a->sign == MP_NEG) { + ++digs; + } + + /* init a copy of the input */ + if ((res = mp_init_copy (&t, a)) != MP_OKAY) { + return res; + } + + /* force temp to positive */ + t.sign = MP_ZPOS; + + /* fetch out all of the digits */ + while (mp_iszero (&t) == MP_NO) { + if ((res = mp_div_d (&t, (mp_digit) radix, &t, &d)) != MP_OKAY) { + mp_clear (&t); + return res; + } + ++digs; + } + mp_clear (&t); + + /* return digs + 1, the 1 is for the NULL byte that would be required. */ + *size = digs + 1; + return MP_OKAY; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_radix_size.c */ + +/* Start: bn_mp_radix_smap.c */ +#include +#ifdef BN_MP_RADIX_SMAP_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* chars used in radix conversions */ +const char *mp_s_rmap = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+/"; +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_radix_smap.c */ + +/* Start: bn_mp_rand.c */ +#include +#ifdef BN_MP_RAND_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* makes a pseudo-random int of a given size */ +int +mp_rand (mp_int * a, int digits) +{ + int res; + mp_digit d; + + mp_zero (a); + if (digits <= 0) { + return MP_OKAY; + } + + /* first place a random non-zero digit */ + do { + d = ((mp_digit) abs (rand ())) & MP_MASK; + } while (d == 0); + + if ((res = mp_add_d (a, d, a)) != MP_OKAY) { + return res; + } + + while (--digits > 0) { + if ((res = mp_lshd (a, 1)) != MP_OKAY) { + return res; + } + + if ((res = mp_add_d (a, ((mp_digit) abs (rand ())), a)) != MP_OKAY) { + return res; + } + } + + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_rand.c */ + +/* Start: bn_mp_read_radix.c */ +#include +#ifdef BN_MP_READ_RADIX_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* read a string [ASCII] in a given radix */ +int mp_read_radix (mp_int * a, const char *str, int radix) +{ + int y, res, neg; + char ch; + + /* make sure the radix is ok */ + if (radix < 2 || radix > 64) { + return MP_VAL; + } + + /* if the leading digit is a + * minus set the sign to negative. + */ + if (*str == '-') { + ++str; + neg = MP_NEG; + } else { + neg = MP_ZPOS; + } + + /* set the integer to the default of zero */ + mp_zero (a); + + /* process each digit of the string */ + while (*str) { + /* if the radix < 36 the conversion is case insensitive + * this allows numbers like 1AB and 1ab to represent the same value + * [e.g. in hex] + */ + ch = (char) ((radix < 36) ? toupper (*str) : *str); + for (y = 0; y < 64; y++) { + if (ch == mp_s_rmap[y]) { + break; + } + } + + /* if the char was found in the map + * and is less than the given radix add it + * to the number, otherwise exit the loop. + */ + if (y < radix) { + if ((res = mp_mul_d (a, (mp_digit) radix, a)) != MP_OKAY) { + return res; + } + if ((res = mp_add_d (a, (mp_digit) y, a)) != MP_OKAY) { + return res; + } + } else { + break; + } + ++str; + } + + /* set the sign only if a != 0 */ + if (mp_iszero(a) != 1) { + a->sign = neg; + } + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_read_radix.c */ + +/* Start: bn_mp_read_signed_bin.c */ +#include +#ifdef BN_MP_READ_SIGNED_BIN_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* read signed bin, big endian, first byte is 0==positive or 1==negative */ +int mp_read_signed_bin (mp_int * a, const unsigned char *b, int c) +{ + int res; + + /* read magnitude */ + if ((res = mp_read_unsigned_bin (a, b + 1, c - 1)) != MP_OKAY) { + return res; + } + + /* first byte is 0 for positive, non-zero for negative */ + if (b[0] == 0) { + a->sign = MP_ZPOS; + } else { + a->sign = MP_NEG; + } + + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_read_signed_bin.c */ + +/* Start: bn_mp_read_unsigned_bin.c */ +#include +#ifdef BN_MP_READ_UNSIGNED_BIN_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* reads a unsigned char array, assumes the msb is stored first [big endian] */ +int mp_read_unsigned_bin (mp_int * a, const unsigned char *b, int c) +{ + int res; + + /* make sure there are at least two digits */ + if (a->alloc < 2) { + if ((res = mp_grow(a, 2)) != MP_OKAY) { + return res; + } + } + + /* zero the int */ + mp_zero (a); + + /* read the bytes in */ + while (c-- > 0) { + if ((res = mp_mul_2d (a, 8, a)) != MP_OKAY) { + return res; + } + +#ifndef MP_8BIT + a->dp[0] |= *b++; + a->used += 1; +#else + a->dp[0] = (*b & MP_MASK); + a->dp[1] |= ((*b++ >> 7U) & 1); + a->used += 2; +#endif + } + mp_clamp (a); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_read_unsigned_bin.c */ + +/* Start: bn_mp_reduce.c */ +#include +#ifdef BN_MP_REDUCE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* reduces x mod m, assumes 0 < x < m**2, mu is + * precomputed via mp_reduce_setup. + * From HAC pp.604 Algorithm 14.42 + */ +int mp_reduce (mp_int * x, mp_int * m, mp_int * mu) +{ + mp_int q; + int res, um = m->used; + + /* q = x */ + if ((res = mp_init_copy (&q, x)) != MP_OKAY) { + return res; + } + + /* q1 = x / b**(k-1) */ + mp_rshd (&q, um - 1); + + /* according to HAC this optimization is ok */ + if (((unsigned long) um) > (((mp_digit)1) << (DIGIT_BIT - 1))) { + if ((res = mp_mul (&q, mu, &q)) != MP_OKAY) { + goto CLEANUP; + } + } else { +#ifdef BN_S_MP_MUL_HIGH_DIGS_C + if ((res = s_mp_mul_high_digs (&q, mu, &q, um)) != MP_OKAY) { + goto CLEANUP; + } +#elif defined(BN_FAST_S_MP_MUL_HIGH_DIGS_C) + if ((res = fast_s_mp_mul_high_digs (&q, mu, &q, um)) != MP_OKAY) { + goto CLEANUP; + } +#else + { + res = MP_VAL; + goto CLEANUP; + } +#endif + } + + /* q3 = q2 / b**(k+1) */ + mp_rshd (&q, um + 1); + + /* x = x mod b**(k+1), quick (no division) */ + if ((res = mp_mod_2d (x, DIGIT_BIT * (um + 1), x)) != MP_OKAY) { + goto CLEANUP; + } + + /* q = q * m mod b**(k+1), quick (no division) */ + if ((res = s_mp_mul_digs (&q, m, &q, um + 1)) != MP_OKAY) { + goto CLEANUP; + } + + /* x = x - q */ + if ((res = mp_sub (x, &q, x)) != MP_OKAY) { + goto CLEANUP; + } + + /* If x < 0, add b**(k+1) to it */ + if (mp_cmp_d (x, 0) == MP_LT) { + mp_set (&q, 1); + if ((res = mp_lshd (&q, um + 1)) != MP_OKAY) + goto CLEANUP; + if ((res = mp_add (x, &q, x)) != MP_OKAY) + goto CLEANUP; + } + + /* Back off if it's too big */ + while (mp_cmp (x, m) != MP_LT) { + if ((res = s_mp_sub (x, m, x)) != MP_OKAY) { + goto CLEANUP; + } + } + +CLEANUP: + mp_clear (&q); + + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_reduce.c */ + +/* Start: bn_mp_reduce_2k.c */ +#include +#ifdef BN_MP_REDUCE_2K_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* reduces a modulo n where n is of the form 2**p - d */ +int mp_reduce_2k(mp_int *a, mp_int *n, mp_digit d) +{ + mp_int q; + int p, res; + + if ((res = mp_init(&q)) != MP_OKAY) { + return res; + } + + p = mp_count_bits(n); +top: + /* q = a/2**p, a = a mod 2**p */ + if ((res = mp_div_2d(a, p, &q, a)) != MP_OKAY) { + goto ERR; + } + + if (d != 1) { + /* q = q * d */ + if ((res = mp_mul_d(&q, d, &q)) != MP_OKAY) { + goto ERR; + } + } + + /* a = a + q */ + if ((res = s_mp_add(a, &q, a)) != MP_OKAY) { + goto ERR; + } + + if (mp_cmp_mag(a, n) != MP_LT) { + s_mp_sub(a, n, a); + goto top; + } + +ERR: + mp_clear(&q); + return res; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_reduce_2k.c */ + +/* Start: bn_mp_reduce_2k_l.c */ +#include +#ifdef BN_MP_REDUCE_2K_L_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* reduces a modulo n where n is of the form 2**p - d + This differs from reduce_2k since "d" can be larger + than a single digit. +*/ +int mp_reduce_2k_l(mp_int *a, mp_int *n, mp_int *d) +{ + mp_int q; + int p, res; + + if ((res = mp_init(&q)) != MP_OKAY) { + return res; + } + + p = mp_count_bits(n); +top: + /* q = a/2**p, a = a mod 2**p */ + if ((res = mp_div_2d(a, p, &q, a)) != MP_OKAY) { + goto ERR; + } + + /* q = q * d */ + if ((res = mp_mul(&q, d, &q)) != MP_OKAY) { + goto ERR; + } + + /* a = a + q */ + if ((res = s_mp_add(a, &q, a)) != MP_OKAY) { + goto ERR; + } + + if (mp_cmp_mag(a, n) != MP_LT) { + s_mp_sub(a, n, a); + goto top; + } + +ERR: + mp_clear(&q); + return res; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_reduce_2k_l.c */ + +/* Start: bn_mp_reduce_2k_setup.c */ +#include +#ifdef BN_MP_REDUCE_2K_SETUP_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* determines the setup value */ +int mp_reduce_2k_setup(mp_int *a, mp_digit *d) +{ + int res, p; + mp_int tmp; + + if ((res = mp_init(&tmp)) != MP_OKAY) { + return res; + } + + p = mp_count_bits(a); + if ((res = mp_2expt(&tmp, p)) != MP_OKAY) { + mp_clear(&tmp); + return res; + } + + if ((res = s_mp_sub(&tmp, a, &tmp)) != MP_OKAY) { + mp_clear(&tmp); + return res; + } + + *d = tmp.dp[0]; + mp_clear(&tmp); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_reduce_2k_setup.c */ + +/* Start: bn_mp_reduce_2k_setup_l.c */ +#include +#ifdef BN_MP_REDUCE_2K_SETUP_L_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* determines the setup value */ +int mp_reduce_2k_setup_l(mp_int *a, mp_int *d) +{ + int res; + mp_int tmp; + + if ((res = mp_init(&tmp)) != MP_OKAY) { + return res; + } + + if ((res = mp_2expt(&tmp, mp_count_bits(a))) != MP_OKAY) { + goto ERR; + } + + if ((res = s_mp_sub(&tmp, a, d)) != MP_OKAY) { + goto ERR; + } + +ERR: + mp_clear(&tmp); + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_reduce_2k_setup_l.c */ + +/* Start: bn_mp_reduce_is_2k.c */ +#include +#ifdef BN_MP_REDUCE_IS_2K_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* determines if mp_reduce_2k can be used */ +int mp_reduce_is_2k(mp_int *a) +{ + int ix, iy, iw; + mp_digit iz; + + if (a->used == 0) { + return MP_NO; + } else if (a->used == 1) { + return MP_YES; + } else if (a->used > 1) { + iy = mp_count_bits(a); + iz = 1; + iw = 1; + + /* Test every bit from the second digit up, must be 1 */ + for (ix = DIGIT_BIT; ix < iy; ix++) { + if ((a->dp[iw] & iz) == 0) { + return MP_NO; + } + iz <<= 1; + if (iz > (mp_digit)MP_MASK) { + ++iw; + iz = 1; + } + } + } + return MP_YES; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_reduce_is_2k.c */ + +/* Start: bn_mp_reduce_is_2k_l.c */ +#include +#ifdef BN_MP_REDUCE_IS_2K_L_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* determines if reduce_2k_l can be used */ +int mp_reduce_is_2k_l(mp_int *a) +{ + int ix, iy; + + if (a->used == 0) { + return MP_NO; + } else if (a->used == 1) { + return MP_YES; + } else if (a->used > 1) { + /* if more than half of the digits are -1 we're sold */ + for (iy = ix = 0; ix < a->used; ix++) { + if (a->dp[ix] == MP_MASK) { + ++iy; + } + } + return (iy >= (a->used/2)) ? MP_YES : MP_NO; + + } + return MP_NO; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_reduce_is_2k_l.c */ + +/* Start: bn_mp_reduce_setup.c */ +#include +#ifdef BN_MP_REDUCE_SETUP_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* pre-calculate the value required for Barrett reduction + * For a given modulus "b" it calulates the value required in "a" + */ +int mp_reduce_setup (mp_int * a, mp_int * b) +{ + int res; + + if ((res = mp_2expt (a, b->used * 2 * DIGIT_BIT)) != MP_OKAY) { + return res; + } + return mp_div (a, b, a, NULL); +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_reduce_setup.c */ + +/* Start: bn_mp_rshd.c */ +#include +#ifdef BN_MP_RSHD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* shift right a certain amount of digits */ +void mp_rshd (mp_int * a, int b) +{ + int x; + + /* if b <= 0 then ignore it */ + if (b <= 0) { + return; + } + + /* if b > used then simply zero it and return */ + if (a->used <= b) { + mp_zero (a); + return; + } + + { + register mp_digit *bottom, *top; + + /* shift the digits down */ + + /* bottom */ + bottom = a->dp; + + /* top [offset into digits] */ + top = a->dp + b; + + /* this is implemented as a sliding window where + * the window is b-digits long and digits from + * the top of the window are copied to the bottom + * + * e.g. + + b-2 | b-1 | b0 | b1 | b2 | ... | bb | ----> + /\ | ----> + \-------------------/ ----> + */ + for (x = 0; x < (a->used - b); x++) { + *bottom++ = *top++; + } + + /* zero the top digits */ + for (; x < a->used; x++) { + *bottom++ = 0; + } + } + + /* remove excess digits */ + a->used -= b; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_rshd.c */ + +/* Start: bn_mp_set.c */ +#include +#ifdef BN_MP_SET_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* set to a digit */ +void mp_set (mp_int * a, mp_digit b) +{ + mp_zero (a); + a->dp[0] = b & MP_MASK; + a->used = (a->dp[0] != 0) ? 1 : 0; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_set.c */ + +/* Start: bn_mp_set_int.c */ +#include +#ifdef BN_MP_SET_INT_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* set a 32-bit const */ +int mp_set_int (mp_int * a, unsigned long b) +{ + int x, res; + + mp_zero (a); + + /* set four bits at a time */ + for (x = 0; x < 8; x++) { + /* shift the number up four bits */ + if ((res = mp_mul_2d (a, 4, a)) != MP_OKAY) { + return res; + } + + /* OR in the top four bits of the source */ + a->dp[0] |= (b >> 28) & 15; + + /* shift the source up to the next four bits */ + b <<= 4; + + /* ensure that digits are not clamped off */ + a->used += 1; + } + mp_clamp (a); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_set_int.c */ + +/* Start: bn_mp_shrink.c */ +#include +#ifdef BN_MP_SHRINK_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* shrink a bignum */ +int mp_shrink (mp_int * a) +{ + mp_digit *tmp; + if (a->alloc != a->used && a->used > 0) { + if ((tmp = OPT_CAST(mp_digit) XREALLOC (a->dp, sizeof (mp_digit) * a->used)) == NULL) { + return MP_MEM; + } + a->dp = tmp; + a->alloc = a->used; + } + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_shrink.c */ + +/* Start: bn_mp_signed_bin_size.c */ +#include +#ifdef BN_MP_SIGNED_BIN_SIZE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* get the size for an signed equivalent */ +int mp_signed_bin_size (mp_int * a) +{ + return 1 + mp_unsigned_bin_size (a); +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_signed_bin_size.c */ + +/* Start: bn_mp_sqr.c */ +#include +#ifdef BN_MP_SQR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* computes b = a*a */ +int +mp_sqr (mp_int * a, mp_int * b) +{ + int res; + +#ifdef BN_MP_TOOM_SQR_C + /* use Toom-Cook? */ + if (a->used >= TOOM_SQR_CUTOFF) { + res = mp_toom_sqr(a, b); + /* Karatsuba? */ + } else +#endif +#ifdef BN_MP_KARATSUBA_SQR_C +if (a->used >= KARATSUBA_SQR_CUTOFF) { + res = mp_karatsuba_sqr (a, b); + } else +#endif + { +#ifdef BN_FAST_S_MP_SQR_C + /* can we use the fast comba multiplier? */ + if ((a->used * 2 + 1) < MP_WARRAY && + a->used < + (1 << (sizeof(mp_word) * CHAR_BIT - 2*DIGIT_BIT - 1))) { + res = fast_s_mp_sqr (a, b); + } else +#endif +#ifdef BN_S_MP_SQR_C + res = s_mp_sqr (a, b); +#else + res = MP_VAL; +#endif + } + b->sign = MP_ZPOS; + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_sqr.c */ + +/* Start: bn_mp_sqrmod.c */ +#include +#ifdef BN_MP_SQRMOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* c = a * a (mod b) */ +int +mp_sqrmod (mp_int * a, mp_int * b, mp_int * c) +{ + int res; + mp_int t; + + if ((res = mp_init (&t)) != MP_OKAY) { + return res; + } + + if ((res = mp_sqr (a, &t)) != MP_OKAY) { + mp_clear (&t); + return res; + } + res = mp_mod (&t, b, c); + mp_clear (&t); + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_sqrmod.c */ + +/* Start: bn_mp_sqrt.c */ +#include +#ifdef BN_MP_SQRT_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* this function is less generic than mp_n_root, simpler and faster */ +int mp_sqrt(mp_int *arg, mp_int *ret) +{ + int res; + mp_int t1,t2; + + /* must be positive */ + if (arg->sign == MP_NEG) { + return MP_VAL; + } + + /* easy out */ + if (mp_iszero(arg) == MP_YES) { + mp_zero(ret); + return MP_OKAY; + } + + if ((res = mp_init_copy(&t1, arg)) != MP_OKAY) { + return res; + } + + if ((res = mp_init(&t2)) != MP_OKAY) { + goto E2; + } + + /* First approx. (not very bad for large arg) */ + mp_rshd (&t1,t1.used/2); + + /* t1 > 0 */ + if ((res = mp_div(arg,&t1,&t2,NULL)) != MP_OKAY) { + goto E1; + } + if ((res = mp_add(&t1,&t2,&t1)) != MP_OKAY) { + goto E1; + } + if ((res = mp_div_2(&t1,&t1)) != MP_OKAY) { + goto E1; + } + /* And now t1 > sqrt(arg) */ + do { + if ((res = mp_div(arg,&t1,&t2,NULL)) != MP_OKAY) { + goto E1; + } + if ((res = mp_add(&t1,&t2,&t1)) != MP_OKAY) { + goto E1; + } + if ((res = mp_div_2(&t1,&t1)) != MP_OKAY) { + goto E1; + } + /* t1 >= sqrt(arg) >= t2 at this point */ + } while (mp_cmp_mag(&t1,&t2) == MP_GT); + + mp_exch(&t1,ret); + +E1: mp_clear(&t2); +E2: mp_clear(&t1); + return res; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_sqrt.c */ + +/* Start: bn_mp_sub.c */ +#include +#ifdef BN_MP_SUB_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* high level subtraction (handles signs) */ +int +mp_sub (mp_int * a, mp_int * b, mp_int * c) +{ + int sa, sb, res; + + sa = a->sign; + sb = b->sign; + + if (sa != sb) { + /* subtract a negative from a positive, OR */ + /* subtract a positive from a negative. */ + /* In either case, ADD their magnitudes, */ + /* and use the sign of the first number. */ + c->sign = sa; + res = s_mp_add (a, b, c); + } else { + /* subtract a positive from a positive, OR */ + /* subtract a negative from a negative. */ + /* First, take the difference between their */ + /* magnitudes, then... */ + if (mp_cmp_mag (a, b) != MP_LT) { + /* Copy the sign from the first */ + c->sign = sa; + /* The first has a larger or equal magnitude */ + res = s_mp_sub (a, b, c); + } else { + /* The result has the *opposite* sign from */ + /* the first number. */ + c->sign = (sa == MP_ZPOS) ? MP_NEG : MP_ZPOS; + /* The second has a larger magnitude */ + res = s_mp_sub (b, a, c); + } + } + return res; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_sub.c */ + +/* Start: bn_mp_sub_d.c */ +#include +#ifdef BN_MP_SUB_D_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* single digit subtraction */ +int +mp_sub_d (mp_int * a, mp_digit b, mp_int * c) +{ + mp_digit *tmpa, *tmpc, mu; + int res, ix, oldused; + + /* grow c as required */ + if (c->alloc < a->used + 1) { + if ((res = mp_grow(c, a->used + 1)) != MP_OKAY) { + return res; + } + } + + /* if a is negative just do an unsigned + * addition [with fudged signs] + */ + if (a->sign == MP_NEG) { + a->sign = MP_ZPOS; + res = mp_add_d(a, b, c); + a->sign = c->sign = MP_NEG; + return res; + } + + /* setup regs */ + oldused = c->used; + tmpa = a->dp; + tmpc = c->dp; + + /* if a <= b simply fix the single digit */ + if ((a->used == 1 && a->dp[0] <= b) || a->used == 0) { + if (a->used == 1) { + *tmpc++ = b - *tmpa; + } else { + *tmpc++ = b; + } + ix = 1; + + /* negative/1digit */ + c->sign = MP_NEG; + c->used = 1; + } else { + /* positive/size */ + c->sign = MP_ZPOS; + c->used = a->used; + + /* subtract first digit */ + *tmpc = *tmpa++ - b; + mu = *tmpc >> (sizeof(mp_digit) * CHAR_BIT - 1); + *tmpc++ &= MP_MASK; + + /* handle rest of the digits */ + for (ix = 1; ix < a->used; ix++) { + *tmpc = *tmpa++ - mu; + mu = *tmpc >> (sizeof(mp_digit) * CHAR_BIT - 1); + *tmpc++ &= MP_MASK; + } + } + + /* zero excess digits */ + while (ix++ < oldused) { + *tmpc++ = 0; + } + mp_clamp(c); + return MP_OKAY; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_sub_d.c */ + +/* Start: bn_mp_submod.c */ +#include +#ifdef BN_MP_SUBMOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* d = a - b (mod c) */ +int +mp_submod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) +{ + int res; + mp_int t; + + + if ((res = mp_init (&t)) != MP_OKAY) { + return res; + } + + if ((res = mp_sub (a, b, &t)) != MP_OKAY) { + mp_clear (&t); + return res; + } + res = mp_mod (&t, c, d); + mp_clear (&t); + return res; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_submod.c */ + +/* Start: bn_mp_to_signed_bin.c */ +#include +#ifdef BN_MP_TO_SIGNED_BIN_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* store in signed [big endian] format */ +int mp_to_signed_bin (mp_int * a, unsigned char *b) +{ + int res; + + if ((res = mp_to_unsigned_bin (a, b + 1)) != MP_OKAY) { + return res; + } + b[0] = (unsigned char) ((a->sign == MP_ZPOS) ? 0 : 1); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_to_signed_bin.c */ + +/* Start: bn_mp_to_signed_bin_n.c */ +#include +#ifdef BN_MP_TO_SIGNED_BIN_N_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* store in signed [big endian] format */ +int mp_to_signed_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen) +{ + if (*outlen < (unsigned long)mp_signed_bin_size(a)) { + return MP_VAL; + } + *outlen = mp_signed_bin_size(a); + return mp_to_signed_bin(a, b); +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_to_signed_bin_n.c */ + +/* Start: bn_mp_to_unsigned_bin.c */ +#include +#ifdef BN_MP_TO_UNSIGNED_BIN_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* store in unsigned [big endian] format */ +int mp_to_unsigned_bin (mp_int * a, unsigned char *b) +{ + int x, res; + mp_int t; + + if ((res = mp_init_copy (&t, a)) != MP_OKAY) { + return res; + } + + x = 0; + while (mp_iszero (&t) == 0) { +#ifndef MP_8BIT + b[x++] = (unsigned char) (t.dp[0] & 255); +#else + b[x++] = (unsigned char) (t.dp[0] | ((t.dp[1] & 0x01) << 7)); +#endif + if ((res = mp_div_2d (&t, 8, &t, NULL)) != MP_OKAY) { + mp_clear (&t); + return res; + } + } + bn_reverse (b, x); + mp_clear (&t); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_to_unsigned_bin.c */ + +/* Start: bn_mp_to_unsigned_bin_n.c */ +#include +#ifdef BN_MP_TO_UNSIGNED_BIN_N_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* store in unsigned [big endian] format */ +int mp_to_unsigned_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen) +{ + if (*outlen < (unsigned long)mp_unsigned_bin_size(a)) { + return MP_VAL; + } + *outlen = mp_unsigned_bin_size(a); + return mp_to_unsigned_bin(a, b); +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_to_unsigned_bin_n.c */ + +/* Start: bn_mp_toom_mul.c */ +#include +#ifdef BN_MP_TOOM_MUL_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* multiplication using the Toom-Cook 3-way algorithm + * + * Much more complicated than Karatsuba but has a lower + * asymptotic running time of O(N**1.464). This algorithm is + * only particularly useful on VERY large inputs + * (we're talking 1000s of digits here...). +*/ +int mp_toom_mul(mp_int *a, mp_int *b, mp_int *c) +{ + mp_int w0, w1, w2, w3, w4, tmp1, tmp2, a0, a1, a2, b0, b1, b2; + int res, B; + + /* init temps */ + if ((res = mp_init_multi(&w0, &w1, &w2, &w3, &w4, + &a0, &a1, &a2, &b0, &b1, + &b2, &tmp1, &tmp2, NULL)) != MP_OKAY) { + return res; + } + + /* B */ + B = MIN(a->used, b->used) / 3; + + /* a = a2 * B**2 + a1 * B + a0 */ + if ((res = mp_mod_2d(a, DIGIT_BIT * B, &a0)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_copy(a, &a1)) != MP_OKAY) { + goto ERR; + } + mp_rshd(&a1, B); + mp_mod_2d(&a1, DIGIT_BIT * B, &a1); + + if ((res = mp_copy(a, &a2)) != MP_OKAY) { + goto ERR; + } + mp_rshd(&a2, B*2); + + /* b = b2 * B**2 + b1 * B + b0 */ + if ((res = mp_mod_2d(b, DIGIT_BIT * B, &b0)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_copy(b, &b1)) != MP_OKAY) { + goto ERR; + } + mp_rshd(&b1, B); + mp_mod_2d(&b1, DIGIT_BIT * B, &b1); + + if ((res = mp_copy(b, &b2)) != MP_OKAY) { + goto ERR; + } + mp_rshd(&b2, B*2); + + /* w0 = a0*b0 */ + if ((res = mp_mul(&a0, &b0, &w0)) != MP_OKAY) { + goto ERR; + } + + /* w4 = a2 * b2 */ + if ((res = mp_mul(&a2, &b2, &w4)) != MP_OKAY) { + goto ERR; + } + + /* w1 = (a2 + 2(a1 + 2a0))(b2 + 2(b1 + 2b0)) */ + if ((res = mp_mul_2(&a0, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a2, &tmp1)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_mul_2(&b0, &tmp2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp2, &b1, &tmp2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_mul_2(&tmp2, &tmp2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp2, &b2, &tmp2)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_mul(&tmp1, &tmp2, &w1)) != MP_OKAY) { + goto ERR; + } + + /* w3 = (a0 + 2(a1 + 2a2))(b0 + 2(b1 + 2b2)) */ + if ((res = mp_mul_2(&a2, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_mul_2(&b2, &tmp2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp2, &b1, &tmp2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_mul_2(&tmp2, &tmp2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp2, &b0, &tmp2)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_mul(&tmp1, &tmp2, &w3)) != MP_OKAY) { + goto ERR; + } + + + /* w2 = (a2 + a1 + a0)(b2 + b1 + b0) */ + if ((res = mp_add(&a2, &a1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&b2, &b1, &tmp2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp2, &b0, &tmp2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_mul(&tmp1, &tmp2, &w2)) != MP_OKAY) { + goto ERR; + } + + /* now solve the matrix + + 0 0 0 0 1 + 1 2 4 8 16 + 1 1 1 1 1 + 16 8 4 2 1 + 1 0 0 0 0 + + using 12 subtractions, 4 shifts, + 2 small divisions and 1 small multiplication + */ + + /* r1 - r4 */ + if ((res = mp_sub(&w1, &w4, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3 - r0 */ + if ((res = mp_sub(&w3, &w0, &w3)) != MP_OKAY) { + goto ERR; + } + /* r1/2 */ + if ((res = mp_div_2(&w1, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3/2 */ + if ((res = mp_div_2(&w3, &w3)) != MP_OKAY) { + goto ERR; + } + /* r2 - r0 - r4 */ + if ((res = mp_sub(&w2, &w0, &w2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w2, &w4, &w2)) != MP_OKAY) { + goto ERR; + } + /* r1 - r2 */ + if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3 - r2 */ + if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) { + goto ERR; + } + /* r1 - 8r0 */ + if ((res = mp_mul_2d(&w0, 3, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w1, &tmp1, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3 - 8r4 */ + if ((res = mp_mul_2d(&w4, 3, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w3, &tmp1, &w3)) != MP_OKAY) { + goto ERR; + } + /* 3r2 - r1 - r3 */ + if ((res = mp_mul_d(&w2, 3, &w2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w2, &w1, &w2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w2, &w3, &w2)) != MP_OKAY) { + goto ERR; + } + /* r1 - r2 */ + if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3 - r2 */ + if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) { + goto ERR; + } + /* r1/3 */ + if ((res = mp_div_3(&w1, &w1, NULL)) != MP_OKAY) { + goto ERR; + } + /* r3/3 */ + if ((res = mp_div_3(&w3, &w3, NULL)) != MP_OKAY) { + goto ERR; + } + + /* at this point shift W[n] by B*n */ + if ((res = mp_lshd(&w1, 1*B)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_lshd(&w2, 2*B)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_lshd(&w3, 3*B)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_lshd(&w4, 4*B)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_add(&w0, &w1, c)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&w2, &w3, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&w4, &tmp1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, c, c)) != MP_OKAY) { + goto ERR; + } + +ERR: + mp_clear_multi(&w0, &w1, &w2, &w3, &w4, + &a0, &a1, &a2, &b0, &b1, + &b2, &tmp1, &tmp2, NULL); + return res; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_toom_mul.c */ + +/* Start: bn_mp_toom_sqr.c */ +#include +#ifdef BN_MP_TOOM_SQR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* squaring using Toom-Cook 3-way algorithm */ +int +mp_toom_sqr(mp_int *a, mp_int *b) +{ + mp_int w0, w1, w2, w3, w4, tmp1, a0, a1, a2; + int res, B; + + /* init temps */ + if ((res = mp_init_multi(&w0, &w1, &w2, &w3, &w4, &a0, &a1, &a2, &tmp1, NULL)) != MP_OKAY) { + return res; + } + + /* B */ + B = a->used / 3; + + /* a = a2 * B**2 + a1 * B + a0 */ + if ((res = mp_mod_2d(a, DIGIT_BIT * B, &a0)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_copy(a, &a1)) != MP_OKAY) { + goto ERR; + } + mp_rshd(&a1, B); + mp_mod_2d(&a1, DIGIT_BIT * B, &a1); + + if ((res = mp_copy(a, &a2)) != MP_OKAY) { + goto ERR; + } + mp_rshd(&a2, B*2); + + /* w0 = a0*a0 */ + if ((res = mp_sqr(&a0, &w0)) != MP_OKAY) { + goto ERR; + } + + /* w4 = a2 * a2 */ + if ((res = mp_sqr(&a2, &w4)) != MP_OKAY) { + goto ERR; + } + + /* w1 = (a2 + 2(a1 + 2a0))**2 */ + if ((res = mp_mul_2(&a0, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a2, &tmp1)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_sqr(&tmp1, &w1)) != MP_OKAY) { + goto ERR; + } + + /* w3 = (a0 + 2(a1 + 2a2))**2 */ + if ((res = mp_mul_2(&a2, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_sqr(&tmp1, &w3)) != MP_OKAY) { + goto ERR; + } + + + /* w2 = (a2 + a1 + a0)**2 */ + if ((res = mp_add(&a2, &a1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sqr(&tmp1, &w2)) != MP_OKAY) { + goto ERR; + } + + /* now solve the matrix + + 0 0 0 0 1 + 1 2 4 8 16 + 1 1 1 1 1 + 16 8 4 2 1 + 1 0 0 0 0 + + using 12 subtractions, 4 shifts, 2 small divisions and 1 small multiplication. + */ + + /* r1 - r4 */ + if ((res = mp_sub(&w1, &w4, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3 - r0 */ + if ((res = mp_sub(&w3, &w0, &w3)) != MP_OKAY) { + goto ERR; + } + /* r1/2 */ + if ((res = mp_div_2(&w1, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3/2 */ + if ((res = mp_div_2(&w3, &w3)) != MP_OKAY) { + goto ERR; + } + /* r2 - r0 - r4 */ + if ((res = mp_sub(&w2, &w0, &w2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w2, &w4, &w2)) != MP_OKAY) { + goto ERR; + } + /* r1 - r2 */ + if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3 - r2 */ + if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) { + goto ERR; + } + /* r1 - 8r0 */ + if ((res = mp_mul_2d(&w0, 3, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w1, &tmp1, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3 - 8r4 */ + if ((res = mp_mul_2d(&w4, 3, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w3, &tmp1, &w3)) != MP_OKAY) { + goto ERR; + } + /* 3r2 - r1 - r3 */ + if ((res = mp_mul_d(&w2, 3, &w2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w2, &w1, &w2)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_sub(&w2, &w3, &w2)) != MP_OKAY) { + goto ERR; + } + /* r1 - r2 */ + if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) { + goto ERR; + } + /* r3 - r2 */ + if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) { + goto ERR; + } + /* r1/3 */ + if ((res = mp_div_3(&w1, &w1, NULL)) != MP_OKAY) { + goto ERR; + } + /* r3/3 */ + if ((res = mp_div_3(&w3, &w3, NULL)) != MP_OKAY) { + goto ERR; + } + + /* at this point shift W[n] by B*n */ + if ((res = mp_lshd(&w1, 1*B)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_lshd(&w2, 2*B)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_lshd(&w3, 3*B)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_lshd(&w4, 4*B)) != MP_OKAY) { + goto ERR; + } + + if ((res = mp_add(&w0, &w1, b)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&w2, &w3, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&w4, &tmp1, &tmp1)) != MP_OKAY) { + goto ERR; + } + if ((res = mp_add(&tmp1, b, b)) != MP_OKAY) { + goto ERR; + } + +ERR: + mp_clear_multi(&w0, &w1, &w2, &w3, &w4, &a0, &a1, &a2, &tmp1, NULL); + return res; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_toom_sqr.c */ + +/* Start: bn_mp_toradix.c */ +#include +#ifdef BN_MP_TORADIX_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* stores a bignum as a ASCII string in a given radix (2..64) */ +int mp_toradix (mp_int * a, char *str, int radix) +{ + int res, digs; + mp_int t; + mp_digit d; + char *_s = str; + + /* check range of the radix */ + if (radix < 2 || radix > 64) { + return MP_VAL; + } + + /* quick out if its zero */ + if (mp_iszero(a) == 1) { + *str++ = '0'; + *str = '\0'; + return MP_OKAY; + } + + if ((res = mp_init_copy (&t, a)) != MP_OKAY) { + return res; + } + + /* if it is negative output a - */ + if (t.sign == MP_NEG) { + ++_s; + *str++ = '-'; + t.sign = MP_ZPOS; + } + + digs = 0; + while (mp_iszero (&t) == 0) { + if ((res = mp_div_d (&t, (mp_digit) radix, &t, &d)) != MP_OKAY) { + mp_clear (&t); + return res; + } + *str++ = mp_s_rmap[d]; + ++digs; + } + + /* reverse the digits of the string. In this case _s points + * to the first digit [exluding the sign] of the number] + */ + bn_reverse ((unsigned char *)_s, digs); + + /* append a NULL so the string is properly terminated */ + *str = '\0'; + + mp_clear (&t); + return MP_OKAY; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_toradix.c */ + +/* Start: bn_mp_toradix_n.c */ +#include +#ifdef BN_MP_TORADIX_N_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* stores a bignum as a ASCII string in a given radix (2..64) + * + * Stores upto maxlen-1 chars and always a NULL byte + */ +int mp_toradix_n(mp_int * a, char *str, int radix, int maxlen) +{ + int res, digs; + mp_int t; + mp_digit d; + char *_s = str; + + /* check range of the maxlen, radix */ + if (maxlen < 3 || radix < 2 || radix > 64) { + return MP_VAL; + } + + /* quick out if its zero */ + if (mp_iszero(a) == 1) { + *str++ = '0'; + *str = '\0'; + return MP_OKAY; + } + + if ((res = mp_init_copy (&t, a)) != MP_OKAY) { + return res; + } + + /* if it is negative output a - */ + if (t.sign == MP_NEG) { + /* we have to reverse our digits later... but not the - sign!! */ + ++_s; + + /* store the flag and mark the number as positive */ + *str++ = '-'; + t.sign = MP_ZPOS; + + /* subtract a char */ + --maxlen; + } + + digs = 0; + while (mp_iszero (&t) == 0) { + if ((res = mp_div_d (&t, (mp_digit) radix, &t, &d)) != MP_OKAY) { + mp_clear (&t); + return res; + } + *str++ = mp_s_rmap[d]; + ++digs; + + if (--maxlen == 1) { + /* no more room */ + break; + } + } + + /* reverse the digits of the string. In this case _s points + * to the first digit [exluding the sign] of the number] + */ + bn_reverse ((unsigned char *)_s, digs); + + /* append a NULL so the string is properly terminated */ + *str = '\0'; + + mp_clear (&t); + return MP_OKAY; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_toradix_n.c */ + +/* Start: bn_mp_unsigned_bin_size.c */ +#include +#ifdef BN_MP_UNSIGNED_BIN_SIZE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* get the size for an unsigned equivalent */ +int mp_unsigned_bin_size (mp_int * a) +{ + int size = mp_count_bits (a); + return (size / 8 + ((size & 7) != 0 ? 1 : 0)); +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_unsigned_bin_size.c */ + +/* Start: bn_mp_xor.c */ +#include +#ifdef BN_MP_XOR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* XOR two ints together */ +int +mp_xor (mp_int * a, mp_int * b, mp_int * c) +{ + int res, ix, px; + mp_int t, *x; + + if (a->used > b->used) { + if ((res = mp_init_copy (&t, a)) != MP_OKAY) { + return res; + } + px = b->used; + x = b; + } else { + if ((res = mp_init_copy (&t, b)) != MP_OKAY) { + return res; + } + px = a->used; + x = a; + } + + for (ix = 0; ix < px; ix++) { + t.dp[ix] ^= x->dp[ix]; + } + mp_clamp (&t); + mp_exch (c, &t); + mp_clear (&t); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_xor.c */ + +/* Start: bn_mp_zero.c */ +#include +#ifdef BN_MP_ZERO_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* set to zero */ +void mp_zero (mp_int * a) +{ + int n; + mp_digit *tmp; + + a->sign = MP_ZPOS; + a->used = 0; + + tmp = a->dp; + for (n = 0; n < a->alloc; n++) { + *tmp++ = 0; + } +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_mp_zero.c */ + +/* Start: bn_prime_tab.c */ +#include +#ifdef BN_PRIME_TAB_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ +const mp_digit ltm_prime_tab[] = { + 0x0002, 0x0003, 0x0005, 0x0007, 0x000B, 0x000D, 0x0011, 0x0013, + 0x0017, 0x001D, 0x001F, 0x0025, 0x0029, 0x002B, 0x002F, 0x0035, + 0x003B, 0x003D, 0x0043, 0x0047, 0x0049, 0x004F, 0x0053, 0x0059, + 0x0061, 0x0065, 0x0067, 0x006B, 0x006D, 0x0071, 0x007F, +#ifndef MP_8BIT + 0x0083, + 0x0089, 0x008B, 0x0095, 0x0097, 0x009D, 0x00A3, 0x00A7, 0x00AD, + 0x00B3, 0x00B5, 0x00BF, 0x00C1, 0x00C5, 0x00C7, 0x00D3, 0x00DF, + 0x00E3, 0x00E5, 0x00E9, 0x00EF, 0x00F1, 0x00FB, 0x0101, 0x0107, + 0x010D, 0x010F, 0x0115, 0x0119, 0x011B, 0x0125, 0x0133, 0x0137, + + 0x0139, 0x013D, 0x014B, 0x0151, 0x015B, 0x015D, 0x0161, 0x0167, + 0x016F, 0x0175, 0x017B, 0x017F, 0x0185, 0x018D, 0x0191, 0x0199, + 0x01A3, 0x01A5, 0x01AF, 0x01B1, 0x01B7, 0x01BB, 0x01C1, 0x01C9, + 0x01CD, 0x01CF, 0x01D3, 0x01DF, 0x01E7, 0x01EB, 0x01F3, 0x01F7, + 0x01FD, 0x0209, 0x020B, 0x021D, 0x0223, 0x022D, 0x0233, 0x0239, + 0x023B, 0x0241, 0x024B, 0x0251, 0x0257, 0x0259, 0x025F, 0x0265, + 0x0269, 0x026B, 0x0277, 0x0281, 0x0283, 0x0287, 0x028D, 0x0293, + 0x0295, 0x02A1, 0x02A5, 0x02AB, 0x02B3, 0x02BD, 0x02C5, 0x02CF, + + 0x02D7, 0x02DD, 0x02E3, 0x02E7, 0x02EF, 0x02F5, 0x02F9, 0x0301, + 0x0305, 0x0313, 0x031D, 0x0329, 0x032B, 0x0335, 0x0337, 0x033B, + 0x033D, 0x0347, 0x0355, 0x0359, 0x035B, 0x035F, 0x036D, 0x0371, + 0x0373, 0x0377, 0x038B, 0x038F, 0x0397, 0x03A1, 0x03A9, 0x03AD, + 0x03B3, 0x03B9, 0x03C7, 0x03CB, 0x03D1, 0x03D7, 0x03DF, 0x03E5, + 0x03F1, 0x03F5, 0x03FB, 0x03FD, 0x0407, 0x0409, 0x040F, 0x0419, + 0x041B, 0x0425, 0x0427, 0x042D, 0x043F, 0x0443, 0x0445, 0x0449, + 0x044F, 0x0455, 0x045D, 0x0463, 0x0469, 0x047F, 0x0481, 0x048B, + + 0x0493, 0x049D, 0x04A3, 0x04A9, 0x04B1, 0x04BD, 0x04C1, 0x04C7, + 0x04CD, 0x04CF, 0x04D5, 0x04E1, 0x04EB, 0x04FD, 0x04FF, 0x0503, + 0x0509, 0x050B, 0x0511, 0x0515, 0x0517, 0x051B, 0x0527, 0x0529, + 0x052F, 0x0551, 0x0557, 0x055D, 0x0565, 0x0577, 0x0581, 0x058F, + 0x0593, 0x0595, 0x0599, 0x059F, 0x05A7, 0x05AB, 0x05AD, 0x05B3, + 0x05BF, 0x05C9, 0x05CB, 0x05CF, 0x05D1, 0x05D5, 0x05DB, 0x05E7, + 0x05F3, 0x05FB, 0x0607, 0x060D, 0x0611, 0x0617, 0x061F, 0x0623, + 0x062B, 0x062F, 0x063D, 0x0641, 0x0647, 0x0649, 0x064D, 0x0653 +#endif +}; +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_prime_tab.c */ + +/* Start: bn_reverse.c */ +#include +#ifdef BN_REVERSE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* reverse an array, used for radix code */ +void +bn_reverse (unsigned char *s, int len) +{ + int ix, iy; + unsigned char t; + + ix = 0; + iy = len - 1; + while (ix < iy) { + t = s[ix]; + s[ix] = s[iy]; + s[iy] = t; + ++ix; + --iy; + } +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_reverse.c */ + +/* Start: bn_s_mp_add.c */ +#include +#ifdef BN_S_MP_ADD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* low level addition, based on HAC pp.594, Algorithm 14.7 */ +int +s_mp_add (mp_int * a, mp_int * b, mp_int * c) +{ + mp_int *x; + int olduse, res, min, max; + + /* find sizes, we let |a| <= |b| which means we have to sort + * them. "x" will point to the input with the most digits + */ + if (a->used > b->used) { + min = b->used; + max = a->used; + x = a; + } else { + min = a->used; + max = b->used; + x = b; + } + + /* init result */ + if (c->alloc < max + 1) { + if ((res = mp_grow (c, max + 1)) != MP_OKAY) { + return res; + } + } + + /* get old used digit count and set new one */ + olduse = c->used; + c->used = max + 1; + + { + register mp_digit u, *tmpa, *tmpb, *tmpc; + register int i; + + /* alias for digit pointers */ + + /* first input */ + tmpa = a->dp; + + /* second input */ + tmpb = b->dp; + + /* destination */ + tmpc = c->dp; + + /* zero the carry */ + u = 0; + for (i = 0; i < min; i++) { + /* Compute the sum at one digit, T[i] = A[i] + B[i] + U */ + *tmpc = *tmpa++ + *tmpb++ + u; + + /* U = carry bit of T[i] */ + u = *tmpc >> ((mp_digit)DIGIT_BIT); + + /* take away carry bit from T[i] */ + *tmpc++ &= MP_MASK; + } + + /* now copy higher words if any, that is in A+B + * if A or B has more digits add those in + */ + if (min != max) { + for (; i < max; i++) { + /* T[i] = X[i] + U */ + *tmpc = x->dp[i] + u; + + /* U = carry bit of T[i] */ + u = *tmpc >> ((mp_digit)DIGIT_BIT); + + /* take away carry bit from T[i] */ + *tmpc++ &= MP_MASK; + } + } + + /* add carry */ + *tmpc++ = u; + + /* clear digits above oldused */ + for (i = c->used; i < olduse; i++) { + *tmpc++ = 0; + } + } + + mp_clamp (c); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_s_mp_add.c */ + +/* Start: bn_s_mp_exptmod.c */ +#include +#ifdef BN_S_MP_EXPTMOD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ +#ifdef MP_LOW_MEM + #define TAB_SIZE 32 +#else + #define TAB_SIZE 256 +#endif + +int s_mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y, int redmode) +{ + mp_int M[TAB_SIZE], res, mu; + mp_digit buf; + int err, bitbuf, bitcpy, bitcnt, mode, digidx, x, y, winsize; + int (*redux)(mp_int*,mp_int*,mp_int*); + + /* find window size */ + x = mp_count_bits (X); + if (x <= 7) { + winsize = 2; + } else if (x <= 36) { + winsize = 3; + } else if (x <= 140) { + winsize = 4; + } else if (x <= 450) { + winsize = 5; + } else if (x <= 1303) { + winsize = 6; + } else if (x <= 3529) { + winsize = 7; + } else { + winsize = 8; + } + +#ifdef MP_LOW_MEM + if (winsize > 5) { + winsize = 5; + } +#endif + + /* init M array */ + /* init first cell */ + if ((err = mp_init(&M[1])) != MP_OKAY) { + return err; + } + + /* now init the second half of the array */ + for (x = 1<<(winsize-1); x < (1 << winsize); x++) { + if ((err = mp_init(&M[x])) != MP_OKAY) { + for (y = 1<<(winsize-1); y < x; y++) { + mp_clear (&M[y]); + } + mp_clear(&M[1]); + return err; + } + } + + /* create mu, used for Barrett reduction */ + if ((err = mp_init (&mu)) != MP_OKAY) { + goto LBL_M; + } + + if (redmode == 0) { + if ((err = mp_reduce_setup (&mu, P)) != MP_OKAY) { + goto LBL_MU; + } + redux = mp_reduce; + } else { + if ((err = mp_reduce_2k_setup_l (P, &mu)) != MP_OKAY) { + goto LBL_MU; + } + redux = mp_reduce_2k_l; + } + + /* create M table + * + * The M table contains powers of the base, + * e.g. M[x] = G**x mod P + * + * The first half of the table is not + * computed though accept for M[0] and M[1] + */ + if ((err = mp_mod (G, P, &M[1])) != MP_OKAY) { + goto LBL_MU; + } + + /* compute the value at M[1<<(winsize-1)] by squaring + * M[1] (winsize-1) times + */ + if ((err = mp_copy (&M[1], &M[1 << (winsize - 1)])) != MP_OKAY) { + goto LBL_MU; + } + + for (x = 0; x < (winsize - 1); x++) { + /* square it */ + if ((err = mp_sqr (&M[1 << (winsize - 1)], + &M[1 << (winsize - 1)])) != MP_OKAY) { + goto LBL_MU; + } + + /* reduce modulo P */ + if ((err = redux (&M[1 << (winsize - 1)], P, &mu)) != MP_OKAY) { + goto LBL_MU; + } + } + + /* create upper table, that is M[x] = M[x-1] * M[1] (mod P) + * for x = (2**(winsize - 1) + 1) to (2**winsize - 1) + */ + for (x = (1 << (winsize - 1)) + 1; x < (1 << winsize); x++) { + if ((err = mp_mul (&M[x - 1], &M[1], &M[x])) != MP_OKAY) { + goto LBL_MU; + } + if ((err = redux (&M[x], P, &mu)) != MP_OKAY) { + goto LBL_MU; + } + } + + /* setup result */ + if ((err = mp_init (&res)) != MP_OKAY) { + goto LBL_MU; + } + mp_set (&res, 1); + + /* set initial mode and bit cnt */ + mode = 0; + bitcnt = 1; + buf = 0; + digidx = X->used - 1; + bitcpy = 0; + bitbuf = 0; + + for (;;) { + /* grab next digit as required */ + if (--bitcnt == 0) { + /* if digidx == -1 we are out of digits */ + if (digidx == -1) { + break; + } + /* read next digit and reset the bitcnt */ + buf = X->dp[digidx--]; + bitcnt = (int) DIGIT_BIT; + } + + /* grab the next msb from the exponent */ + y = (buf >> (mp_digit)(DIGIT_BIT - 1)) & 1; + buf <<= (mp_digit)1; + + /* if the bit is zero and mode == 0 then we ignore it + * These represent the leading zero bits before the first 1 bit + * in the exponent. Technically this opt is not required but it + * does lower the # of trivial squaring/reductions used + */ + if (mode == 0 && y == 0) { + continue; + } + + /* if the bit is zero and mode == 1 then we square */ + if (mode == 1 && y == 0) { + if ((err = mp_sqr (&res, &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, &mu)) != MP_OKAY) { + goto LBL_RES; + } + continue; + } + + /* else we add it to the window */ + bitbuf |= (y << (winsize - ++bitcpy)); + mode = 2; + + if (bitcpy == winsize) { + /* ok window is filled so square as required and multiply */ + /* square first */ + for (x = 0; x < winsize; x++) { + if ((err = mp_sqr (&res, &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, &mu)) != MP_OKAY) { + goto LBL_RES; + } + } + + /* then multiply */ + if ((err = mp_mul (&res, &M[bitbuf], &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, &mu)) != MP_OKAY) { + goto LBL_RES; + } + + /* empty window and reset */ + bitcpy = 0; + bitbuf = 0; + mode = 1; + } + } + + /* if bits remain then square/multiply */ + if (mode == 2 && bitcpy > 0) { + /* square then multiply if the bit is set */ + for (x = 0; x < bitcpy; x++) { + if ((err = mp_sqr (&res, &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, &mu)) != MP_OKAY) { + goto LBL_RES; + } + + bitbuf <<= 1; + if ((bitbuf & (1 << winsize)) != 0) { + /* then multiply */ + if ((err = mp_mul (&res, &M[1], &res)) != MP_OKAY) { + goto LBL_RES; + } + if ((err = redux (&res, P, &mu)) != MP_OKAY) { + goto LBL_RES; + } + } + } + } + + mp_exch (&res, Y); + err = MP_OKAY; +LBL_RES:mp_clear (&res); +LBL_MU:mp_clear (&mu); +LBL_M: + mp_clear(&M[1]); + for (x = 1<<(winsize-1); x < (1 << winsize); x++) { + mp_clear (&M[x]); + } + return err; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_s_mp_exptmod.c */ + +/* Start: bn_s_mp_mul_digs.c */ +#include +#ifdef BN_S_MP_MUL_DIGS_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* multiplies |a| * |b| and only computes upto digs digits of result + * HAC pp. 595, Algorithm 14.12 Modified so you can control how + * many digits of output are created. + */ +int s_mp_mul_digs (mp_int * a, mp_int * b, mp_int * c, int digs) +{ + mp_int t; + int res, pa, pb, ix, iy; + mp_digit u; + mp_word r; + mp_digit tmpx, *tmpt, *tmpy; + + /* can we use the fast multiplier? */ + if (((digs) < MP_WARRAY) && + MIN (a->used, b->used) < + (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) { + return fast_s_mp_mul_digs (a, b, c, digs); + } + + if ((res = mp_init_size (&t, digs)) != MP_OKAY) { + return res; + } + t.used = digs; + + /* compute the digits of the product directly */ + pa = a->used; + for (ix = 0; ix < pa; ix++) { + /* set the carry to zero */ + u = 0; + + /* limit ourselves to making digs digits of output */ + pb = MIN (b->used, digs - ix); + + /* setup some aliases */ + /* copy of the digit from a used within the nested loop */ + tmpx = a->dp[ix]; + + /* an alias for the destination shifted ix places */ + tmpt = t.dp + ix; + + /* an alias for the digits of b */ + tmpy = b->dp; + + /* compute the columns of the output and propagate the carry */ + for (iy = 0; iy < pb; iy++) { + /* compute the column as a mp_word */ + r = ((mp_word)*tmpt) + + ((mp_word)tmpx) * ((mp_word)*tmpy++) + + ((mp_word) u); + + /* the new column is the lower part of the result */ + *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK)); + + /* get the carry word from the result */ + u = (mp_digit) (r >> ((mp_word) DIGIT_BIT)); + } + /* set carry if it is placed below digs */ + if (ix + iy < digs) { + *tmpt = u; + } + } + + mp_clamp (&t); + mp_exch (&t, c); + + mp_clear (&t); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_s_mp_mul_digs.c */ + +/* Start: bn_s_mp_mul_high_digs.c */ +#include +#ifdef BN_S_MP_MUL_HIGH_DIGS_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* multiplies |a| * |b| and does not compute the lower digs digits + * [meant to get the higher part of the product] + */ +int +s_mp_mul_high_digs (mp_int * a, mp_int * b, mp_int * c, int digs) +{ + mp_int t; + int res, pa, pb, ix, iy; + mp_digit u; + mp_word r; + mp_digit tmpx, *tmpt, *tmpy; + + /* can we use the fast multiplier? */ +#ifdef BN_FAST_S_MP_MUL_HIGH_DIGS_C + if (((a->used + b->used + 1) < MP_WARRAY) + && MIN (a->used, b->used) < (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) { + return fast_s_mp_mul_high_digs (a, b, c, digs); + } +#endif + + if ((res = mp_init_size (&t, a->used + b->used + 1)) != MP_OKAY) { + return res; + } + t.used = a->used + b->used + 1; + + pa = a->used; + pb = b->used; + for (ix = 0; ix < pa; ix++) { + /* clear the carry */ + u = 0; + + /* left hand side of A[ix] * B[iy] */ + tmpx = a->dp[ix]; + + /* alias to the address of where the digits will be stored */ + tmpt = &(t.dp[digs]); + + /* alias for where to read the right hand side from */ + tmpy = b->dp + (digs - ix); + + for (iy = digs - ix; iy < pb; iy++) { + /* calculate the double precision result */ + r = ((mp_word)*tmpt) + + ((mp_word)tmpx) * ((mp_word)*tmpy++) + + ((mp_word) u); + + /* get the lower part */ + *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK)); + + /* carry the carry */ + u = (mp_digit) (r >> ((mp_word) DIGIT_BIT)); + } + *tmpt = u; + } + mp_clamp (&t); + mp_exch (&t, c); + mp_clear (&t); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_s_mp_mul_high_digs.c */ + +/* Start: bn_s_mp_sqr.c */ +#include +#ifdef BN_S_MP_SQR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* low level squaring, b = a*a, HAC pp.596-597, Algorithm 14.16 */ +int s_mp_sqr (mp_int * a, mp_int * b) +{ + mp_int t; + int res, ix, iy, pa; + mp_word r; + mp_digit u, tmpx, *tmpt; + + pa = a->used; + if ((res = mp_init_size (&t, 2*pa + 1)) != MP_OKAY) { + return res; + } + + /* default used is maximum possible size */ + t.used = 2*pa + 1; + + for (ix = 0; ix < pa; ix++) { + /* first calculate the digit at 2*ix */ + /* calculate double precision result */ + r = ((mp_word) t.dp[2*ix]) + + ((mp_word)a->dp[ix])*((mp_word)a->dp[ix]); + + /* store lower part in result */ + t.dp[ix+ix] = (mp_digit) (r & ((mp_word) MP_MASK)); + + /* get the carry */ + u = (mp_digit)(r >> ((mp_word) DIGIT_BIT)); + + /* left hand side of A[ix] * A[iy] */ + tmpx = a->dp[ix]; + + /* alias for where to store the results */ + tmpt = t.dp + (2*ix + 1); + + for (iy = ix + 1; iy < pa; iy++) { + /* first calculate the product */ + r = ((mp_word)tmpx) * ((mp_word)a->dp[iy]); + + /* now calculate the double precision result, note we use + * addition instead of *2 since it's easier to optimize + */ + r = ((mp_word) *tmpt) + r + r + ((mp_word) u); + + /* store lower part */ + *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK)); + + /* get carry */ + u = (mp_digit)(r >> ((mp_word) DIGIT_BIT)); + } + /* propagate upwards */ + while (u != ((mp_digit) 0)) { + r = ((mp_word) *tmpt) + ((mp_word) u); + *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK)); + u = (mp_digit)(r >> ((mp_word) DIGIT_BIT)); + } + } + + mp_clamp (&t); + mp_exch (&t, b); + mp_clear (&t); + return MP_OKAY; +} +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_s_mp_sqr.c */ + +/* Start: bn_s_mp_sub.c */ +#include +#ifdef BN_S_MP_SUB_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* low level subtraction (assumes |a| > |b|), HAC pp.595 Algorithm 14.9 */ +int +s_mp_sub (mp_int * a, mp_int * b, mp_int * c) +{ + int olduse, res, min, max; + + /* find sizes */ + min = b->used; + max = a->used; + + /* init result */ + if (c->alloc < max) { + if ((res = mp_grow (c, max)) != MP_OKAY) { + return res; + } + } + olduse = c->used; + c->used = max; + + { + register mp_digit u, *tmpa, *tmpb, *tmpc; + register int i; + + /* alias for digit pointers */ + tmpa = a->dp; + tmpb = b->dp; + tmpc = c->dp; + + /* set carry to zero */ + u = 0; + for (i = 0; i < min; i++) { + /* T[i] = A[i] - B[i] - U */ + *tmpc = *tmpa++ - *tmpb++ - u; + + /* U = carry bit of T[i] + * Note this saves performing an AND operation since + * if a carry does occur it will propagate all the way to the + * MSB. As a result a single shift is enough to get the carry + */ + u = *tmpc >> ((mp_digit)(CHAR_BIT * sizeof (mp_digit) - 1)); + + /* Clear carry from T[i] */ + *tmpc++ &= MP_MASK; + } + + /* now copy higher words if any, e.g. if A has more digits than B */ + for (; i < max; i++) { + /* T[i] = A[i] - U */ + *tmpc = *tmpa++ - u; + + /* U = carry bit of T[i] */ + u = *tmpc >> ((mp_digit)(CHAR_BIT * sizeof (mp_digit) - 1)); + + /* Clear carry from T[i] */ + *tmpc++ &= MP_MASK; + } + + /* clear digits above used (since we may not have grown result above) */ + for (i = c->used; i < olduse; i++) { + *tmpc++ = 0; + } + } + + mp_clamp (c); + return MP_OKAY; +} + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bn_s_mp_sub.c */ + +/* Start: bncore.c */ +#include +#ifdef BNCORE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ + +/* Known optimal configurations + + CPU /Compiler /MUL CUTOFF/SQR CUTOFF +------------------------------------------------------------- + Intel P4 Northwood /GCC v3.4.1 / 88/ 128/LTM 0.32 ;-) + AMD Athlon64 /GCC v3.4.4 / 80/ 120/LTM 0.35 + +*/ + +int KARATSUBA_MUL_CUTOFF = 80, /* Min. number of digits before Karatsuba multiplication is used. */ + KARATSUBA_SQR_CUTOFF = 120, /* Min. number of digits before Karatsuba squaring is used. */ + + TOOM_MUL_CUTOFF = 350, /* no optimal values of these are known yet so set em high */ + TOOM_SQR_CUTOFF = 400; +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ + +/* End: bncore.c */ + + +/* EOF */ ADDED libtommath/tombc/grammar.txt Index: libtommath/tombc/grammar.txt ================================================================== --- /dev/null +++ libtommath/tombc/grammar.txt @@ -0,0 +1,35 @@ +program := program statement | statement | empty +statement := { statement } | + identifier = numexpression; | + identifier[numexpression] = numexpression; | + function(expressionlist); | + for (identifer = numexpression; numexpression; identifier = numexpression) { statement } | + while (numexpression) { statement } | + if (numexpresion) { statement } elif | + break; | + continue; + +elif := else statement | empty +function := abs | countbits | exptmod | jacobi | print | isprime | nextprime | issquare | readinteger | exit +expressionlist := expressionlist, expression | expression + +// LR(1) !!!? +expression := string | numexpression +numexpression := cmpexpr && cmpexpr | cmpexpr \|\| cmpexpr | cmpexpr +cmpexpr := boolexpr < boolexpr | boolexpr > boolexpr | boolexpr == boolexpr | + boolexpr <= boolexpr | boolexpr >= boolexpr | boolexpr +boolexpr := shiftexpr & shiftexpr | shiftexpr ^ shiftexpr | shiftexpr \| shiftexpr | shiftexpr +shiftexpr := addsubexpr << addsubexpr | addsubexpr >> addsubexpr | addsubexpr +addsubexpr := mulexpr + mulexpr | mulexpr - mulexpr | mulexpr +mulexpr := expr * expr | expr / expr | expr % expr | expr +expr := -nexpr | nexpr +nexpr := integer | identifier | ( numexpression ) | identifier[numexpression] + +identifier := identifer digits | identifier alpha | alpha +alpha := a ... z | A ... Z +integer := hexnumber | digits +hexnumber := 0xhexdigits +hexdigits := hexdigits hexdigit | hexdigit +hexdigit := 0 ... 9 | a ... f | A ... F +digits := digits digit | digit +digit := 0 ... 9 ADDED libtommath/tommath.h Index: libtommath/tommath.h ================================================================== --- /dev/null +++ libtommath/tommath.h @@ -0,0 +1,584 @@ +/* LibTomMath, multiple-precision integer library -- Tom St Denis + * + * LibTomMath is a library that provides multiple-precision + * integer arithmetic as well as number theoretic functionality. + * + * The library was designed directly after the MPI library by + * Michael Fromberger but has been written from scratch with + * additional optimizations in place. + * + * The library is free for all purposes without any express + * guarantee it works. + * + * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org + */ +#ifndef BN_H_ +#define BN_H_ + +#include +#include +#include +#include +#include + +#include + +#ifndef MIN + #define MIN(x,y) ((x)<(y)?(x):(y)) +#endif + +#ifndef MAX + #define MAX(x,y) ((x)>(y)?(x):(y)) +#endif + +#ifdef __cplusplus +extern "C" { + +/* C++ compilers don't like assigning void * to mp_digit * */ +#define OPT_CAST(x) (x *) + +#else + +/* C on the other hand doesn't care */ +#define OPT_CAST(x) + +#endif + + +/* detect 64-bit mode if possible */ +#if defined(__x86_64__) + #if !(defined(MP_64BIT) && defined(MP_16BIT) && defined(MP_8BIT)) + #define MP_64BIT + #endif +#endif + +/* some default configurations. + * + * A "mp_digit" must be able to hold DIGIT_BIT + 1 bits + * A "mp_word" must be able to hold 2*DIGIT_BIT + 1 bits + * + * At the very least a mp_digit must be able to hold 7 bits + * [any size beyond that is ok provided it doesn't overflow the data type] + */ +#ifdef MP_8BIT + typedef unsigned char mp_digit; + typedef unsigned short mp_word; +#elif defined(MP_16BIT) + typedef unsigned short mp_digit; + typedef unsigned long mp_word; +#elif defined(MP_64BIT) + /* for GCC only on supported platforms */ +#ifndef CRYPT + typedef unsigned long long ulong64; + typedef signed long long long64; +#endif + + typedef unsigned long mp_digit; + typedef unsigned long mp_word __attribute__ ((mode(TI))); + + #define DIGIT_BIT 60 +#else + /* this is the default case, 28-bit digits */ + + /* this is to make porting into LibTomCrypt easier :-) */ +#ifndef CRYPT + #if defined(_MSC_VER) || defined(__BORLANDC__) + typedef unsigned __int64 ulong64; + typedef signed __int64 long64; + #else + typedef unsigned long long ulong64; + typedef signed long long long64; + #endif +#endif + + typedef unsigned long mp_digit; + typedef ulong64 mp_word; + +#ifdef MP_31BIT + /* this is an extension that uses 31-bit digits */ + #define DIGIT_BIT 31 +#else + /* default case is 28-bit digits, defines MP_28BIT as a handy macro to test */ + #define DIGIT_BIT 28 + #define MP_28BIT +#endif +#endif + +/* define heap macros */ +#ifndef CRYPT + /* default to libc stuff */ + #ifndef XMALLOC + #define XMALLOC malloc + #define XFREE free + #define XREALLOC realloc + #define XCALLOC calloc + #else + /* prototypes for our heap functions */ + extern void *XMALLOC(size_t n); + extern void *XREALLOC(void *p, size_t n); + extern void *XCALLOC(size_t n, size_t s); + extern void XFREE(void *p); + #endif +#endif + + +/* otherwise the bits per digit is calculated automatically from the size of a mp_digit */ +#ifndef DIGIT_BIT + #define DIGIT_BIT ((int)((CHAR_BIT * sizeof(mp_digit) - 1))) /* bits per digit */ +#endif + +#define MP_DIGIT_BIT DIGIT_BIT +#define MP_MASK ((((mp_digit)1)<<((mp_digit)DIGIT_BIT))-((mp_digit)1)) +#define MP_DIGIT_MAX MP_MASK + +/* equalities */ +#define MP_LT -1 /* less than */ +#define MP_EQ 0 /* equal to */ +#define MP_GT 1 /* greater than */ + +#define MP_ZPOS 0 /* positive integer */ +#define MP_NEG 1 /* negative */ + +#define MP_OKAY 0 /* ok result */ +#define MP_MEM -2 /* out of mem */ +#define MP_VAL -3 /* invalid input */ +#define MP_RANGE MP_VAL + +#define MP_YES 1 /* yes response */ +#define MP_NO 0 /* no response */ + +/* Primality generation flags */ +#define LTM_PRIME_BBS 0x0001 /* BBS style prime */ +#define LTM_PRIME_SAFE 0x0002 /* Safe prime (p-1)/2 == prime */ +#define LTM_PRIME_2MSB_ON 0x0008 /* force 2nd MSB to 1 */ + +typedef int mp_err; + +/* you'll have to tune these... */ +extern int KARATSUBA_MUL_CUTOFF, + KARATSUBA_SQR_CUTOFF, + TOOM_MUL_CUTOFF, + TOOM_SQR_CUTOFF; + +/* define this to use lower memory usage routines (exptmods mostly) */ +/* #define MP_LOW_MEM */ + +/* default precision */ +#ifndef MP_PREC + #ifndef MP_LOW_MEM + #define MP_PREC 32 /* default digits of precision */ + #else + #define MP_PREC 8 /* default digits of precision */ + #endif +#endif + +/* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */ +#define MP_WARRAY (1 << (sizeof(mp_word) * CHAR_BIT - 2 * DIGIT_BIT + 1)) + +/* the infamous mp_int structure */ +typedef struct { + int used, alloc, sign; + mp_digit *dp; +} mp_int; + +/* callback for mp_prime_random, should fill dst with random bytes and return how many read [upto len] */ +typedef int ltm_prime_callback(unsigned char *dst, int len, void *dat); + + +#define USED(m) ((m)->used) +#define DIGIT(m,k) ((m)->dp[(k)]) +#define SIGN(m) ((m)->sign) + +/* error code to char* string */ +char *mp_error_to_string(int code); + +/* ---> init and deinit bignum functions <--- */ +/* init a bignum */ +int mp_init(mp_int *a); + +/* free a bignum */ +void mp_clear(mp_int *a); + +/* init a null terminated series of arguments */ +int mp_init_multi(mp_int *mp, ...); + +/* clear a null terminated series of arguments */ +void mp_clear_multi(mp_int *mp, ...); + +/* exchange two ints */ +void mp_exch(mp_int *a, mp_int *b); + +/* shrink ram required for a bignum */ +int mp_shrink(mp_int *a); + +/* grow an int to a given size */ +int mp_grow(mp_int *a, int size); + +/* init to a given number of digits */ +int mp_init_size(mp_int *a, int size); + +/* ---> Basic Manipulations <--- */ +#define mp_iszero(a) (((a)->used == 0) ? MP_YES : MP_NO) +#define mp_iseven(a) (((a)->used == 0 || (((a)->dp[0] & 1) == 0)) ? MP_YES : MP_NO) +#define mp_isodd(a) (((a)->used > 0 && (((a)->dp[0] & 1) == 1)) ? MP_YES : MP_NO) + +/* set to zero */ +void mp_zero(mp_int *a); + +/* set to a digit */ +void mp_set(mp_int *a, mp_digit b); + +/* set a 32-bit const */ +int mp_set_int(mp_int *a, unsigned long b); + +/* get a 32-bit value */ +unsigned long mp_get_int(mp_int * a); + +/* initialize and set a digit */ +int mp_init_set (mp_int * a, mp_digit b); + +/* initialize and set 32-bit value */ +int mp_init_set_int (mp_int * a, unsigned long b); + +/* copy, b = a */ +int mp_copy(mp_int *a, mp_int *b); + +/* inits and copies, a = b */ +int mp_init_copy(mp_int *a, mp_int *b); + +/* trim unused digits */ +void mp_clamp(mp_int *a); + +/* ---> digit manipulation <--- */ + +/* right shift by "b" digits */ +void mp_rshd(mp_int *a, int b); + +/* left shift by "b" digits */ +int mp_lshd(mp_int *a, int b); + +/* c = a / 2**b */ +int mp_div_2d(mp_int *a, int b, mp_int *c, mp_int *d); + +/* b = a/2 */ +int mp_div_2(mp_int *a, mp_int *b); + +/* c = a * 2**b */ +int mp_mul_2d(mp_int *a, int b, mp_int *c); + +/* b = a*2 */ +int mp_mul_2(mp_int *a, mp_int *b); + +/* c = a mod 2**d */ +int mp_mod_2d(mp_int *a, int b, mp_int *c); + +/* computes a = 2**b */ +int mp_2expt(mp_int *a, int b); + +/* Counts the number of lsbs which are zero before the first zero bit */ +int mp_cnt_lsb(mp_int *a); + +/* I Love Earth! */ + +/* makes a pseudo-random int of a given size */ +int mp_rand(mp_int *a, int digits); + +/* ---> binary operations <--- */ +/* c = a XOR b */ +int mp_xor(mp_int *a, mp_int *b, mp_int *c); + +/* c = a OR b */ +int mp_or(mp_int *a, mp_int *b, mp_int *c); + +/* c = a AND b */ +int mp_and(mp_int *a, mp_int *b, mp_int *c); + +/* ---> Basic arithmetic <--- */ + +/* b = -a */ +int mp_neg(mp_int *a, mp_int *b); + +/* b = |a| */ +int mp_abs(mp_int *a, mp_int *b); + +/* compare a to b */ +int mp_cmp(mp_int *a, mp_int *b); + +/* compare |a| to |b| */ +int mp_cmp_mag(mp_int *a, mp_int *b); + +/* c = a + b */ +int mp_add(mp_int *a, mp_int *b, mp_int *c); + +/* c = a - b */ +int mp_sub(mp_int *a, mp_int *b, mp_int *c); + +/* c = a * b */ +int mp_mul(mp_int *a, mp_int *b, mp_int *c); + +/* b = a*a */ +int mp_sqr(mp_int *a, mp_int *b); + +/* a/b => cb + d == a */ +int mp_div(mp_int *a, mp_int *b, mp_int *c, mp_int *d); + +/* c = a mod b, 0 <= c < b */ +int mp_mod(mp_int *a, mp_int *b, mp_int *c); + +/* ---> single digit functions <--- */ + +/* compare against a single digit */ +int mp_cmp_d(mp_int *a, mp_digit b); + +/* c = a + b */ +int mp_add_d(mp_int *a, mp_digit b, mp_int *c); + +/* c = a - b */ +int mp_sub_d(mp_int *a, mp_digit b, mp_int *c); + +/* c = a * b */ +int mp_mul_d(mp_int *a, mp_digit b, mp_int *c); + +/* a/b => cb + d == a */ +int mp_div_d(mp_int *a, mp_digit b, mp_int *c, mp_digit *d); + +/* a/3 => 3c + d == a */ +int mp_div_3(mp_int *a, mp_int *c, mp_digit *d); + +/* c = a**b */ +int mp_expt_d(mp_int *a, mp_digit b, mp_int *c); + +/* c = a mod b, 0 <= c < b */ +int mp_mod_d(mp_int *a, mp_digit b, mp_digit *c); + +/* ---> number theory <--- */ + +/* d = a + b (mod c) */ +int mp_addmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); + +/* d = a - b (mod c) */ +int mp_submod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); + +/* d = a * b (mod c) */ +int mp_mulmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); + +/* c = a * a (mod b) */ +int mp_sqrmod(mp_int *a, mp_int *b, mp_int *c); + +/* c = 1/a (mod b) */ +int mp_invmod(mp_int *a, mp_int *b, mp_int *c); + +/* c = (a, b) */ +int mp_gcd(mp_int *a, mp_int *b, mp_int *c); + +/* produces value such that U1*a + U2*b = U3 */ +int mp_exteuclid(mp_int *a, mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3); + +/* c = [a, b] or (a*b)/(a, b) */ +int mp_lcm(mp_int *a, mp_int *b, mp_int *c); + +/* finds one of the b'th root of a, such that |c|**b <= |a| + * + * returns error if a < 0 and b is even + */ +int mp_n_root(mp_int *a, mp_digit b, mp_int *c); + +/* special sqrt algo */ +int mp_sqrt(mp_int *arg, mp_int *ret); + +/* is number a square? */ +int mp_is_square(mp_int *arg, int *ret); + +/* computes the jacobi c = (a | n) (or Legendre if b is prime) */ +int mp_jacobi(mp_int *a, mp_int *n, int *c); + +/* used to setup the Barrett reduction for a given modulus b */ +int mp_reduce_setup(mp_int *a, mp_int *b); + +/* Barrett Reduction, computes a (mod b) with a precomputed value c + * + * Assumes that 0 < a <= b*b, note if 0 > a > -(b*b) then you can merely + * compute the reduction as -1 * mp_reduce(mp_abs(a)) [pseudo code]. + */ +int mp_reduce(mp_int *a, mp_int *b, mp_int *c); + +/* setups the montgomery reduction */ +int mp_montgomery_setup(mp_int *a, mp_digit *mp); + +/* computes a = B**n mod b without division or multiplication useful for + * normalizing numbers in a Montgomery system. + */ +int mp_montgomery_calc_normalization(mp_int *a, mp_int *b); + +/* computes x/R == x (mod N) via Montgomery Reduction */ +int mp_montgomery_reduce(mp_int *a, mp_int *m, mp_digit mp); + +/* returns 1 if a is a valid DR modulus */ +int mp_dr_is_modulus(mp_int *a); + +/* sets the value of "d" required for mp_dr_reduce */ +void mp_dr_setup(mp_int *a, mp_digit *d); + +/* reduces a modulo b using the Diminished Radix method */ +int mp_dr_reduce(mp_int *a, mp_int *b, mp_digit mp); + +/* returns true if a can be reduced with mp_reduce_2k */ +int mp_reduce_is_2k(mp_int *a); + +/* determines k value for 2k reduction */ +int mp_reduce_2k_setup(mp_int *a, mp_digit *d); + +/* reduces a modulo b where b is of the form 2**p - k [0 <= a] */ +int mp_reduce_2k(mp_int *a, mp_int *n, mp_digit d); + +/* returns true if a can be reduced with mp_reduce_2k_l */ +int mp_reduce_is_2k_l(mp_int *a); + +/* determines k value for 2k reduction */ +int mp_reduce_2k_setup_l(mp_int *a, mp_int *d); + +/* reduces a modulo b where b is of the form 2**p - k [0 <= a] */ +int mp_reduce_2k_l(mp_int *a, mp_int *n, mp_int *d); + +/* d = a**b (mod c) */ +int mp_exptmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); + +/* ---> Primes <--- */ + +/* number of primes */ +#ifdef MP_8BIT + #define PRIME_SIZE 31 +#else + #define PRIME_SIZE 256 +#endif + +/* table of first PRIME_SIZE primes */ +extern const mp_digit ltm_prime_tab[]; + +/* result=1 if a is divisible by one of the first PRIME_SIZE primes */ +int mp_prime_is_divisible(mp_int *a, int *result); + +/* performs one Fermat test of "a" using base "b". + * Sets result to 0 if composite or 1 if probable prime + */ +int mp_prime_fermat(mp_int *a, mp_int *b, int *result); + +/* performs one Miller-Rabin test of "a" using base "b". + * Sets result to 0 if composite or 1 if probable prime + */ +int mp_prime_miller_rabin(mp_int *a, mp_int *b, int *result); + +/* This gives [for a given bit size] the number of trials required + * such that Miller-Rabin gives a prob of failure lower than 2^-96 + */ +int mp_prime_rabin_miller_trials(int size); + +/* performs t rounds of Miller-Rabin on "a" using the first + * t prime bases. Also performs an initial sieve of trial + * division. Determines if "a" is prime with probability + * of error no more than (1/4)**t. + * + * Sets result to 1 if probably prime, 0 otherwise + */ +int mp_prime_is_prime(mp_int *a, int t, int *result); + +/* finds the next prime after the number "a" using "t" trials + * of Miller-Rabin. + * + * bbs_style = 1 means the prime must be congruent to 3 mod 4 + */ +int mp_prime_next_prime(mp_int *a, int t, int bbs_style); + +/* makes a truly random prime of a given size (bytes), + * call with bbs = 1 if you want it to be congruent to 3 mod 4 + * + * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can + * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself + * so it can be NULL + * + * The prime generated will be larger than 2^(8*size). + */ +#define mp_prime_random(a, t, size, bbs, cb, dat) mp_prime_random_ex(a, t, ((size) * 8) + 1, (bbs==1)?LTM_PRIME_BBS:0, cb, dat) + +/* makes a truly random prime of a given size (bits), + * + * Flags are as follows: + * + * LTM_PRIME_BBS - make prime congruent to 3 mod 4 + * LTM_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies LTM_PRIME_BBS) + * LTM_PRIME_2MSB_OFF - make the 2nd highest bit zero + * LTM_PRIME_2MSB_ON - make the 2nd highest bit one + * + * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can + * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself + * so it can be NULL + * + */ +int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback cb, void *dat); + +/* ---> radix conversion <--- */ +int mp_count_bits(mp_int *a); + +int mp_unsigned_bin_size(mp_int *a); +int mp_read_unsigned_bin(mp_int *a, const unsigned char *b, int c); +int mp_to_unsigned_bin(mp_int *a, unsigned char *b); +int mp_to_unsigned_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen); + +int mp_signed_bin_size(mp_int *a); +int mp_read_signed_bin(mp_int *a, const unsigned char *b, int c); +int mp_to_signed_bin(mp_int *a, unsigned char *b); +int mp_to_signed_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen); + +int mp_read_radix(mp_int *a, const char *str, int radix); +int mp_toradix(mp_int *a, char *str, int radix); +int mp_toradix_n(mp_int * a, char *str, int radix, int maxlen); +int mp_radix_size(mp_int *a, int radix, int *size); + +int mp_fread(mp_int *a, int radix, FILE *stream); +int mp_fwrite(mp_int *a, int radix, FILE *stream); + +#define mp_read_raw(mp, str, len) mp_read_signed_bin((mp), (str), (len)) +#define mp_raw_size(mp) mp_signed_bin_size(mp) +#define mp_toraw(mp, str) mp_to_signed_bin((mp), (str)) +#define mp_read_mag(mp, str, len) mp_read_unsigned_bin((mp), (str), (len)) +#define mp_mag_size(mp) mp_unsigned_bin_size(mp) +#define mp_tomag(mp, str) mp_to_unsigned_bin((mp), (str)) + +#define mp_tobinary(M, S) mp_toradix((M), (S), 2) +#define mp_tooctal(M, S) mp_toradix((M), (S), 8) +#define mp_todecimal(M, S) mp_toradix((M), (S), 10) +#define mp_tohex(M, S) mp_toradix((M), (S), 16) + +/* lowlevel functions, do not call! */ +int s_mp_add(mp_int *a, mp_int *b, mp_int *c); +int s_mp_sub(mp_int *a, mp_int *b, mp_int *c); +#define s_mp_mul(a, b, c) s_mp_mul_digs(a, b, c, (a)->used + (b)->used + 1) +int fast_s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs); +int s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs); +int fast_s_mp_mul_high_digs(mp_int *a, mp_int *b, mp_int *c, int digs); +int s_mp_mul_high_digs(mp_int *a, mp_int *b, mp_int *c, int digs); +int fast_s_mp_sqr(mp_int *a, mp_int *b); +int s_mp_sqr(mp_int *a, mp_int *b); +int mp_karatsuba_mul(mp_int *a, mp_int *b, mp_int *c); +int mp_toom_mul(mp_int *a, mp_int *b, mp_int *c); +int mp_karatsuba_sqr(mp_int *a, mp_int *b); +int mp_toom_sqr(mp_int *a, mp_int *b); +int fast_mp_invmod(mp_int *a, mp_int *b, mp_int *c); +int mp_invmod_slow (mp_int * a, mp_int * b, mp_int * c); +int fast_mp_montgomery_reduce(mp_int *a, mp_int *m, mp_digit mp); +int mp_exptmod_fast(mp_int *G, mp_int *X, mp_int *P, mp_int *Y, int mode); +int s_mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y, int mode); +void bn_reverse(unsigned char *s, int len); + +extern const char *mp_s_rmap; + +#ifdef __cplusplus + } +#endif + +#endif + + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/tommath.h,v $ */ +/* $Revision: 1.1.1.1.2.4 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/tommath.pdf Index: libtommath/tommath.pdf ================================================================== --- /dev/null +++ libtommath/tommath.pdf cannot compute difference between binary files ADDED libtommath/tommath.src Index: libtommath/tommath.src ================================================================== --- /dev/null +++ libtommath/tommath.src @@ -0,0 +1,6352 @@ +\documentclass[b5paper]{book} +\usepackage{hyperref} +\usepackage{makeidx} +\usepackage{amssymb} +\usepackage{color} +\usepackage{alltt} +\usepackage{graphicx} +\usepackage{layout} +\def\union{\cup} +\def\intersect{\cap} +\def\getsrandom{\stackrel{\rm R}{\gets}} +\def\cross{\times} +\def\cat{\hspace{0.5em} \| \hspace{0.5em}} +\def\catn{$\|$} +\def\divides{\hspace{0.3em} | \hspace{0.3em}} +\def\nequiv{\not\equiv} +\def\approx{\raisebox{0.2ex}{\mbox{\small $\sim$}}} +\def\lcm{{\rm lcm}} +\def\gcd{{\rm gcd}} +\def\log{{\rm log}} +\def\ord{{\rm ord}} +\def\abs{{\mathit abs}} +\def\rep{{\mathit rep}} +\def\mod{{\mathit\ mod\ }} +\renewcommand{\pmod}[1]{\ ({\rm mod\ }{#1})} +\newcommand{\floor}[1]{\left\lfloor{#1}\right\rfloor} +\newcommand{\ceil}[1]{\left\lceil{#1}\right\rceil} +\def\Or{{\rm\ or\ }} +\def\And{{\rm\ and\ }} +\def\iff{\hspace{1em}\Longleftrightarrow\hspace{1em}} +\def\implies{\Rightarrow} +\def\undefined{{\rm ``undefined"}} +\def\Proof{\vspace{1ex}\noindent {\bf Proof:}\hspace{1em}} +\let\oldphi\phi +\def\phi{\varphi} +\def\Pr{{\rm Pr}} +\newcommand{\str}[1]{{\mathbf{#1}}} +\def\F{{\mathbb F}} +\def\N{{\mathbb N}} +\def\Z{{\mathbb Z}} +\def\R{{\mathbb R}} +\def\C{{\mathbb C}} +\def\Q{{\mathbb Q}} +\definecolor{DGray}{gray}{0.5} +\newcommand{\emailaddr}[1]{\mbox{$<${#1}$>$}} +\def\twiddle{\raisebox{0.3ex}{\mbox{\tiny $\sim$}}} +\def\gap{\vspace{0.5ex}} +\makeindex +\begin{document} +\frontmatter +\pagestyle{empty} +\title{Multi--Precision Math} +\author{\mbox{ +%\begin{small} +\begin{tabular}{c} +Tom St Denis \\ +Algonquin College \\ +\\ +Mads Rasmussen \\ +Open Communications Security \\ +\\ +Greg Rose \\ +QUALCOMM Australia \\ +\end{tabular} +%\end{small} +} +} +\maketitle +This text has been placed in the public domain. This text corresponds to the v0.36 release of the +LibTomMath project. + +\begin{alltt} +Tom St Denis +111 Banning Rd +Ottawa, Ontario +K2L 1C3 +Canada + +Phone: 1-613-836-3160 +Email: tomstdenis@iahu.ca +\end{alltt} + +This text is formatted to the international B5 paper size of 176mm wide by 250mm tall using the \LaTeX{} +{\em book} macro package and the Perl {\em booker} package. + +\tableofcontents +\listoffigures +\chapter*{Prefaces} +When I tell people about my LibTom projects and that I release them as public domain they are often puzzled. +They ask why I did it and especially why I continue to work on them for free. The best I can explain it is ``Because I can.'' +Which seems odd and perhaps too terse for adult conversation. I often qualify it with ``I am able, I am willing.'' which +perhaps explains it better. I am the first to admit there is not anything that special with what I have done. Perhaps +others can see that too and then we would have a society to be proud of. My LibTom projects are what I am doing to give +back to society in the form of tools and knowledge that can help others in their endeavours. + +I started writing this book because it was the most logical task to further my goal of open academia. The LibTomMath source +code itself was written to be easy to follow and learn from. There are times, however, where pure C source code does not +explain the algorithms properly. Hence this book. The book literally starts with the foundation of the library and works +itself outwards to the more complicated algorithms. The use of both pseudo--code and verbatim source code provides a duality +of ``theory'' and ``practice'' that the computer science students of the world shall appreciate. I never deviate too far +from relatively straightforward algebra and I hope that this book can be a valuable learning asset. + +This book and indeed much of the LibTom projects would not exist in their current form if it was not for a plethora +of kind people donating their time, resources and kind words to help support my work. Writing a text of significant +length (along with the source code) is a tiresome and lengthy process. Currently the LibTom project is four years old, +comprises of literally thousands of users and over 100,000 lines of source code, TeX and other material. People like Mads and Greg +were there at the beginning to encourage me to work well. It is amazing how timely validation from others can boost morale to +continue the project. Definitely my parents were there for me by providing room and board during the many months of work in 2003. + +To my many friends whom I have met through the years I thank you for the good times and the words of encouragement. I hope I +honour your kind gestures with this project. + +Open Source. Open Academia. Open Minds. + +\begin{flushright} Tom St Denis \end{flushright} + +\newpage +I found the opportunity to work with Tom appealing for several reasons, not only could I broaden my own horizons, but also +contribute to educate others facing the problem of having to handle big number mathematical calculations. + +This book is Tom's child and he has been caring and fostering the project ever since the beginning with a clear mind of +how he wanted the project to turn out. I have helped by proofreading the text and we have had several discussions about +the layout and language used. + +I hold a masters degree in cryptography from the University of Southern Denmark and have always been interested in the +practical aspects of cryptography. + +Having worked in the security consultancy business for several years in S\~{a}o Paulo, Brazil, I have been in touch with a +great deal of work in which multiple precision mathematics was needed. Understanding the possibilities for speeding up +multiple precision calculations is often very important since we deal with outdated machine architecture where modular +reductions, for example, become painfully slow. + +This text is for people who stop and wonder when first examining algorithms such as RSA for the first time and asks +themselves, ``You tell me this is only secure for large numbers, fine; but how do you implement these numbers?'' + +\begin{flushright} +Mads Rasmussen + +S\~{a}o Paulo - SP + +Brazil +\end{flushright} + +\newpage +It's all because I broke my leg. That just happened to be at about the same time that Tom asked for someone to review the section of the book about +Karatsuba multiplication. I was laid up, alone and immobile, and thought ``Why not?'' I vaguely knew what Karatsuba multiplication was, but not +really, so I thought I could help, learn, and stop myself from watching daytime cable TV, all at once. + +At the time of writing this, I've still not met Tom or Mads in meatspace. I've been following Tom's progress since his first splash on the +sci.crypt Usenet news group. I watched him go from a clueless newbie, to the cryptographic equivalent of a reformed smoker, to a real +contributor to the field, over a period of about two years. I've been impressed with his obvious intelligence, and astounded by his productivity. +Of course, he's young enough to be my own child, so he doesn't have my problems with staying awake. + +When I reviewed that single section of the book, in its very earliest form, I was very pleasantly surprised. So I decided to collaborate more fully, +and at least review all of it, and perhaps write some bits too. There's still a long way to go with it, and I have watched a number of close +friends go through the mill of publication, so I think that the way to go is longer than Tom thinks it is. Nevertheless, it's a good effort, +and I'm pleased to be involved with it. + +\begin{flushright} +Greg Rose, Sydney, Australia, June 2003. +\end{flushright} + +\mainmatter +\pagestyle{headings} +\chapter{Introduction} +\section{Multiple Precision Arithmetic} + +\subsection{What is Multiple Precision Arithmetic?} +When we think of long-hand arithmetic such as addition or multiplication we rarely consider the fact that we instinctively +raise or lower the precision of the numbers we are dealing with. For example, in decimal we almost immediate can +reason that $7$ times $6$ is $42$. However, $42$ has two digits of precision as opposed to one digit we started with. +Further multiplications of say $3$ result in a larger precision result $126$. In these few examples we have multiple +precisions for the numbers we are working with. Despite the various levels of precision a single subset\footnote{With the occasional optimization.} + of algorithms can be designed to accomodate them. + +By way of comparison a fixed or single precision operation would lose precision on various operations. For example, in +the decimal system with fixed precision $6 \cdot 7 = 2$. + +Essentially at the heart of computer based multiple precision arithmetic are the same long-hand algorithms taught in +schools to manually add, subtract, multiply and divide. + +\subsection{The Need for Multiple Precision Arithmetic} +The most prevalent need for multiple precision arithmetic, often referred to as ``bignum'' math, is within the implementation +of public-key cryptography algorithms. Algorithms such as RSA \cite{RSAREF} and Diffie-Hellman \cite{DHREF} require +integers of significant magnitude to resist known cryptanalytic attacks. For example, at the time of this writing a +typical RSA modulus would be at least greater than $10^{309}$. However, modern programming languages such as ISO C \cite{ISOC} and +Java \cite{JAVA} only provide instrinsic support for integers which are relatively small and single precision. + +\begin{figure}[!here] +\begin{center} +\begin{tabular}{|r|c|} +\hline \textbf{Data Type} & \textbf{Range} \\ +\hline char & $-128 \ldots 127$ \\ +\hline short & $-32768 \ldots 32767$ \\ +\hline long & $-2147483648 \ldots 2147483647$ \\ +\hline long long & $-9223372036854775808 \ldots 9223372036854775807$ \\ +\hline +\end{tabular} +\end{center} +\caption{Typical Data Types for the C Programming Language} +\label{fig:ISOC} +\end{figure} + +The largest data type guaranteed to be provided by the ISO C programming +language\footnote{As per the ISO C standard. However, each compiler vendor is allowed to augment the precision as they +see fit.} can only represent values up to $10^{19}$ as shown in figure \ref{fig:ISOC}. On its own the C language is +insufficient to accomodate the magnitude required for the problem at hand. An RSA modulus of magnitude $10^{19}$ could be +trivially factored\footnote{A Pollard-Rho factoring would take only $2^{16}$ time.} on the average desktop computer, +rendering any protocol based on the algorithm insecure. Multiple precision algorithms solve this very problem by +extending the range of representable integers while using single precision data types. + +Most advancements in fast multiple precision arithmetic stem from the need for faster and more efficient cryptographic +primitives. Faster modular reduction and exponentiation algorithms such as Barrett's algorithm, which have appeared in +various cryptographic journals, can render algorithms such as RSA and Diffie-Hellman more efficient. In fact, several +major companies such as RSA Security, Certicom and Entrust have built entire product lines on the implementation and +deployment of efficient algorithms. + +However, cryptography is not the only field of study that can benefit from fast multiple precision integer routines. +Another auxiliary use of multiple precision integers is high precision floating point data types. +The basic IEEE \cite{IEEE} standard floating point type is made up of an integer mantissa $q$, an exponent $e$ and a sign bit $s$. +Numbers are given in the form $n = q \cdot b^e \cdot -1^s$ where $b = 2$ is the most common base for IEEE. Since IEEE +floating point is meant to be implemented in hardware the precision of the mantissa is often fairly small +(\textit{23, 48 and 64 bits}). The mantissa is merely an integer and a multiple precision integer could be used to create +a mantissa of much larger precision than hardware alone can efficiently support. This approach could be useful where +scientific applications must minimize the total output error over long calculations. + +Yet another use for large integers is within arithmetic on polynomials of large characteristic (i.e. $GF(p)[x]$ for large $p$). +In fact the library discussed within this text has already been used to form a polynomial basis library\footnote{See \url{http://poly.libtomcrypt.org} for more details.}. + +\subsection{Benefits of Multiple Precision Arithmetic} +\index{precision} +The benefit of multiple precision representations over single or fixed precision representations is that +no precision is lost while representing the result of an operation which requires excess precision. For example, +the product of two $n$-bit integers requires at least $2n$ bits of precision to be represented faithfully. A multiple +precision algorithm would augment the precision of the destination to accomodate the result while a single precision system +would truncate excess bits to maintain a fixed level of precision. + +It is possible to implement algorithms which require large integers with fixed precision algorithms. For example, elliptic +curve cryptography (\textit{ECC}) is often implemented on smartcards by fixing the precision of the integers to the maximum +size the system will ever need. Such an approach can lead to vastly simpler algorithms which can accomodate the +integers required even if the host platform cannot natively accomodate them\footnote{For example, the average smartcard +processor has an 8 bit accumulator.}. However, as efficient as such an approach may be, the resulting source code is not +normally very flexible. It cannot, at runtime, accomodate inputs of higher magnitude than the designer anticipated. + +Multiple precision algorithms have the most overhead of any style of arithmetic. For the the most part the +overhead can be kept to a minimum with careful planning, but overall, it is not well suited for most memory starved +platforms. However, multiple precision algorithms do offer the most flexibility in terms of the magnitude of the +inputs. That is, the same algorithms based on multiple precision integers can accomodate any reasonable size input +without the designer's explicit forethought. This leads to lower cost of ownership for the code as it only has to +be written and tested once. + +\section{Purpose of This Text} +The purpose of this text is to instruct the reader regarding how to implement efficient multiple precision algorithms. +That is to not only explain a limited subset of the core theory behind the algorithms but also the various ``house keeping'' +elements that are neglected by authors of other texts on the subject. Several well reknowned texts \cite{TAOCPV2,HAC} +give considerably detailed explanations of the theoretical aspects of algorithms and often very little information +regarding the practical implementation aspects. + +In most cases how an algorithm is explained and how it is actually implemented are two very different concepts. For +example, the Handbook of Applied Cryptography (\textit{HAC}), algorithm 14.7 on page 594, gives a relatively simple +algorithm for performing multiple precision integer addition. However, the description lacks any discussion concerning +the fact that the two integer inputs may be of differing magnitudes. As a result the implementation is not as simple +as the text would lead people to believe. Similarly the division routine (\textit{algorithm 14.20, pp. 598}) does not +discuss how to handle sign or handle the dividend's decreasing magnitude in the main loop (\textit{step \#3}). + +Both texts also do not discuss several key optimal algorithms required such as ``Comba'' and Karatsuba multipliers +and fast modular inversion, which we consider practical oversights. These optimal algorithms are vital to achieve +any form of useful performance in non-trivial applications. + +To solve this problem the focus of this text is on the practical aspects of implementing a multiple precision integer +package. As a case study the ``LibTomMath''\footnote{Available at \url{http://math.libtomcrypt.org}} package is used +to demonstrate algorithms with real implementations\footnote{In the ISO C programming language.} that have been field +tested and work very well. The LibTomMath library is freely available on the Internet for all uses and this text +discusses a very large portion of the inner workings of the library. + +The algorithms that are presented will always include at least one ``pseudo-code'' description followed +by the actual C source code that implements the algorithm. The pseudo-code can be used to implement the same +algorithm in other programming languages as the reader sees fit. + +This text shall also serve as a walkthrough of the creation of multiple precision algorithms from scratch. Showing +the reader how the algorithms fit together as well as where to start on various taskings. + +\section{Discussion and Notation} +\subsection{Notation} +A multiple precision integer of $n$-digits shall be denoted as $x = (x_{n-1}, \ldots, x_1, x_0)_{ \beta }$ and represent +the integer $x \equiv \sum_{i=0}^{n-1} x_i\beta^i$. The elements of the array $x$ are said to be the radix $\beta$ digits +of the integer. For example, $x = (1,2,3)_{10}$ would represent the integer +$1\cdot 10^2 + 2\cdot10^1 + 3\cdot10^0 = 123$. + +\index{mp\_int} +The term ``mp\_int'' shall refer to a composite structure which contains the digits of the integer it represents, as well +as auxilary data required to manipulate the data. These additional members are discussed further in section +\ref{sec:MPINT}. For the purposes of this text a ``multiple precision integer'' and an ``mp\_int'' are assumed to be +synonymous. When an algorithm is specified to accept an mp\_int variable it is assumed the various auxliary data members +are present as well. An expression of the type \textit{variablename.item} implies that it should evaluate to the +member named ``item'' of the variable. For example, a string of characters may have a member ``length'' which would +evaluate to the number of characters in the string. If the string $a$ equals ``hello'' then it follows that +$a.length = 5$. + +For certain discussions more generic algorithms are presented to help the reader understand the final algorithm used +to solve a given problem. When an algorithm is described as accepting an integer input it is assumed the input is +a plain integer with no additional multiple-precision members. That is, algorithms that use integers as opposed to +mp\_ints as inputs do not concern themselves with the housekeeping operations required such as memory management. These +algorithms will be used to establish the relevant theory which will subsequently be used to describe a multiple +precision algorithm to solve the same problem. + +\subsection{Precision Notation} +The variable $\beta$ represents the radix of a single digit of a multiple precision integer and +must be of the form $q^p$ for $q, p \in \Z^+$. A single precision variable must be able to represent integers in +the range $0 \le x < q \beta$ while a double precision variable must be able to represent integers in the range +$0 \le x < q \beta^2$. The extra radix-$q$ factor allows additions and subtractions to proceed without truncation of the +carry. Since all modern computers are binary, it is assumed that $q$ is two. + +\index{mp\_digit} \index{mp\_word} +Within the source code that will be presented for each algorithm, the data type \textbf{mp\_digit} will represent +a single precision integer type, while, the data type \textbf{mp\_word} will represent a double precision integer type. In +several algorithms (notably the Comba routines) temporary results will be stored in arrays of double precision mp\_words. +For the purposes of this text $x_j$ will refer to the $j$'th digit of a single precision array and $\hat x_j$ will refer to +the $j$'th digit of a double precision array. Whenever an expression is to be assigned to a double precision +variable it is assumed that all single precision variables are promoted to double precision during the evaluation. +Expressions that are assigned to a single precision variable are truncated to fit within the precision of a single +precision data type. + +For example, if $\beta = 10^2$ a single precision data type may represent a value in the +range $0 \le x < 10^3$, while a double precision data type may represent a value in the range $0 \le x < 10^5$. Let +$a = 23$ and $b = 49$ represent two single precision variables. The single precision product shall be written +as $c \leftarrow a \cdot b$ while the double precision product shall be written as $\hat c \leftarrow a \cdot b$. +In this particular case, $\hat c = 1127$ and $c = 127$. The most significant digit of the product would not fit +in a single precision data type and as a result $c \ne \hat c$. + +\subsection{Algorithm Inputs and Outputs} +Within the algorithm descriptions all variables are assumed to be scalars of either single or double precision +as indicated. The only exception to this rule is when variables have been indicated to be of type mp\_int. This +distinction is important as scalars are often used as array indicies and various other counters. + +\subsection{Mathematical Expressions} +The $\lfloor \mbox{ } \rfloor$ brackets imply an expression truncated to an integer not greater than the expression +itself. For example, $\lfloor 5.7 \rfloor = 5$. Similarly the $\lceil \mbox{ } \rceil$ brackets imply an expression +rounded to an integer not less than the expression itself. For example, $\lceil 5.1 \rceil = 6$. Typically when +the $/$ division symbol is used the intention is to perform an integer division with truncation. For example, +$5/2 = 2$ which will often be written as $\lfloor 5/2 \rfloor = 2$ for clarity. When an expression is written as a +fraction a real value division is implied, for example ${5 \over 2} = 2.5$. + +The norm of a multiple precision integer, for example $\vert \vert x \vert \vert$, will be used to represent the number of digits in the representation +of the integer. For example, $\vert \vert 123 \vert \vert = 3$ and $\vert \vert 79452 \vert \vert = 5$. + +\subsection{Work Effort} +\index{big-Oh} +To measure the efficiency of the specified algorithms, a modified big-Oh notation is used. In this system all +single precision operations are considered to have the same cost\footnote{Except where explicitly noted.}. +That is a single precision addition, multiplication and division are assumed to take the same time to +complete. While this is generally not true in practice, it will simplify the discussions considerably. + +Some algorithms have slight advantages over others which is why some constants will not be removed in +the notation. For example, a normal baseline multiplication (section \ref{sec:basemult}) requires $O(n^2)$ work while a +baseline squaring (section \ref{sec:basesquare}) requires $O({{n^2 + n}\over 2})$ work. In standard big-Oh notation these +would both be said to be equivalent to $O(n^2)$. However, +in the context of the this text this is not the case as the magnitude of the inputs will typically be rather small. As a +result small constant factors in the work effort will make an observable difference in algorithm efficiency. + +All of the algorithms presented in this text have a polynomial time work level. That is, of the form +$O(n^k)$ for $n, k \in \Z^{+}$. This will help make useful comparisons in terms of the speed of the algorithms and how +various optimizations will help pay off in the long run. + +\section{Exercises} +Within the more advanced chapters a section will be set aside to give the reader some challenging exercises related to +the discussion at hand. These exercises are not designed to be prize winning problems, but instead to be thought +provoking. Wherever possible the problems are forward minded, stating problems that will be answered in subsequent +chapters. The reader is encouraged to finish the exercises as they appear to get a better understanding of the +subject material. + +That being said, the problems are designed to affirm knowledge of a particular subject matter. Students in particular +are encouraged to verify they can answer the problems correctly before moving on. + +Similar to the exercises of \cite[pp. ix]{TAOCPV2} these exercises are given a scoring system based on the difficulty of +the problem. However, unlike \cite{TAOCPV2} the problems do not get nearly as hard. The scoring of these +exercises ranges from one (the easiest) to five (the hardest). The following table sumarizes the +scoring system used. + +\begin{figure}[here] +\begin{center} +\begin{small} +\begin{tabular}{|c|l|} +\hline $\left [ 1 \right ]$ & An easy problem that should only take the reader a manner of \\ + & minutes to solve. Usually does not involve much computer time \\ + & to solve. \\ +\hline $\left [ 2 \right ]$ & An easy problem that involves a marginal amount of computer \\ + & time usage. Usually requires a program to be written to \\ + & solve the problem. \\ +\hline $\left [ 3 \right ]$ & A moderately hard problem that requires a non-trivial amount \\ + & of work. Usually involves trivial research and development of \\ + & new theory from the perspective of a student. \\ +\hline $\left [ 4 \right ]$ & A moderately hard problem that involves a non-trivial amount \\ + & of work and research, the solution to which will demonstrate \\ + & a higher mastery of the subject matter. \\ +\hline $\left [ 5 \right ]$ & A hard problem that involves concepts that are difficult for a \\ + & novice to solve. Solutions to these problems will demonstrate a \\ + & complete mastery of the given subject. \\ +\hline +\end{tabular} +\end{small} +\end{center} +\caption{Exercise Scoring System} +\end{figure} + +Problems at the first level are meant to be simple questions that the reader can answer quickly without programming a solution or +devising new theory. These problems are quick tests to see if the material is understood. Problems at the second level +are also designed to be easy but will require a program or algorithm to be implemented to arrive at the answer. These +two levels are essentially entry level questions. + +Problems at the third level are meant to be a bit more difficult than the first two levels. The answer is often +fairly obvious but arriving at an exacting solution requires some thought and skill. These problems will almost always +involve devising a new algorithm or implementing a variation of another algorithm previously presented. Readers who can +answer these questions will feel comfortable with the concepts behind the topic at hand. + +Problems at the fourth level are meant to be similar to those of the level three questions except they will require +additional research to be completed. The reader will most likely not know the answer right away, nor will the text provide +the exact details of the answer until a subsequent chapter. + +Problems at the fifth level are meant to be the hardest +problems relative to all the other problems in the chapter. People who can correctly answer fifth level problems have a +mastery of the subject matter at hand. + +Often problems will be tied together. The purpose of this is to start a chain of thought that will be discussed in future chapters. The reader +is encouraged to answer the follow-up problems and try to draw the relevance of problems. + +\section{Introduction to LibTomMath} + +\subsection{What is LibTomMath?} +LibTomMath is a free and open source multiple precision integer library written entirely in portable ISO C. By portable it +is meant that the library does not contain any code that is computer platform dependent or otherwise problematic to use on +any given platform. + +The library has been successfully tested under numerous operating systems including Unix\footnote{All of these +trademarks belong to their respective rightful owners.}, MacOS, Windows, Linux, PalmOS and on standalone hardware such +as the Gameboy Advance. The library is designed to contain enough functionality to be able to develop applications such +as public key cryptosystems and still maintain a relatively small footprint. + +\subsection{Goals of LibTomMath} + +Libraries which obtain the most efficiency are rarely written in a high level programming language such as C. However, +even though this library is written entirely in ISO C, considerable care has been taken to optimize the algorithm implementations within the +library. Specifically the code has been written to work well with the GNU C Compiler (\textit{GCC}) on both x86 and ARM +processors. Wherever possible, highly efficient algorithms, such as Karatsuba multiplication, sliding window +exponentiation and Montgomery reduction have been provided to make the library more efficient. + +Even with the nearly optimal and specialized algorithms that have been included the Application Programing Interface +(\textit{API}) has been kept as simple as possible. Often generic place holder routines will make use of specialized +algorithms automatically without the developer's specific attention. One such example is the generic multiplication +algorithm \textbf{mp\_mul()} which will automatically use Toom--Cook, Karatsuba, Comba or baseline multiplication +based on the magnitude of the inputs and the configuration of the library. + +Making LibTomMath as efficient as possible is not the only goal of the LibTomMath project. Ideally the library should +be source compatible with another popular library which makes it more attractive for developers to use. In this case the +MPI library was used as a API template for all the basic functions. MPI was chosen because it is another library that fits +in the same niche as LibTomMath. Even though LibTomMath uses MPI as the template for the function names and argument +passing conventions, it has been written from scratch by Tom St Denis. + +The project is also meant to act as a learning tool for students, the logic being that no easy-to-follow ``bignum'' +library exists which can be used to teach computer science students how to perform fast and reliable multiple precision +integer arithmetic. To this end the source code has been given quite a few comments and algorithm discussion points. + +\section{Choice of LibTomMath} +LibTomMath was chosen as the case study of this text not only because the author of both projects is one and the same but +for more worthy reasons. Other libraries such as GMP \cite{GMP}, MPI \cite{MPI}, LIP \cite{LIP} and OpenSSL +\cite{OPENSSL} have multiple precision integer arithmetic routines but would not be ideal for this text for +reasons that will be explained in the following sub-sections. + +\subsection{Code Base} +The LibTomMath code base is all portable ISO C source code. This means that there are no platform dependent conditional +segments of code littered throughout the source. This clean and uncluttered approach to the library means that a +developer can more readily discern the true intent of a given section of source code without trying to keep track of +what conditional code will be used. + +The code base of LibTomMath is well organized. Each function is in its own separate source code file +which allows the reader to find a given function very quickly. On average there are $76$ lines of code per source +file which makes the source very easily to follow. By comparison MPI and LIP are single file projects making code tracing +very hard. GMP has many conditional code segments which also hinder tracing. + +When compiled with GCC for the x86 processor and optimized for speed the entire library is approximately $100$KiB\footnote{The notation ``KiB'' means $2^{10}$ octets, similarly ``MiB'' means $2^{20}$ octets.} + which is fairly small compared to GMP (over $250$KiB). LibTomMath is slightly larger than MPI (which compiles to about +$50$KiB) but LibTomMath is also much faster and more complete than MPI. + +\subsection{API Simplicity} +LibTomMath is designed after the MPI library and shares the API design. Quite often programs that use MPI will build +with LibTomMath without change. The function names correlate directly to the action they perform. Almost all of the +functions share the same parameter passing convention. The learning curve is fairly shallow with the API provided +which is an extremely valuable benefit for the student and developer alike. + +The LIP library is an example of a library with an API that is awkward to work with. LIP uses function names that are often ``compressed'' to +illegible short hand. LibTomMath does not share this characteristic. + +The GMP library also does not return error codes. Instead it uses a POSIX.1 \cite{POSIX1} signal system where errors +are signaled to the host application. This happens to be the fastest approach but definitely not the most versatile. In +effect a math error (i.e. invalid input, heap error, etc) can cause a program to stop functioning which is definitely +undersireable in many situations. + +\subsection{Optimizations} +While LibTomMath is certainly not the fastest library (GMP often beats LibTomMath by a factor of two) it does +feature a set of optimal algorithms for tasks such as modular reduction, exponentiation, multiplication and squaring. GMP +and LIP also feature such optimizations while MPI only uses baseline algorithms with no optimizations. GMP lacks a few +of the additional modular reduction optimizations that LibTomMath features\footnote{At the time of this writing GMP +only had Barrett and Montgomery modular reduction algorithms.}. + +LibTomMath is almost always an order of magnitude faster than the MPI library at computationally expensive tasks such as modular +exponentiation. In the grand scheme of ``bignum'' libraries LibTomMath is faster than the average library and usually +slower than the best libraries such as GMP and OpenSSL by only a small factor. + +\subsection{Portability and Stability} +LibTomMath will build ``out of the box'' on any platform equipped with a modern version of the GNU C Compiler +(\textit{GCC}). This means that without changes the library will build without configuration or setting up any +variables. LIP and MPI will build ``out of the box'' as well but have numerous known bugs. Most notably the author of +MPI has recently stopped working on his library and LIP has long since been discontinued. + +GMP requires a configuration script to run and will not build out of the box. GMP and LibTomMath are still in active +development and are very stable across a variety of platforms. + +\subsection{Choice} +LibTomMath is a relatively compact, well documented, highly optimized and portable library which seems only natural for +the case study of this text. Various source files from the LibTomMath project will be included within the text. However, +the reader is encouraged to download their own copy of the library to actually be able to work with the library. + +\chapter{Getting Started} +\section{Library Basics} +The trick to writing any useful library of source code is to build a solid foundation and work outwards from it. First, +a problem along with allowable solution parameters should be identified and analyzed. In this particular case the +inability to accomodate multiple precision integers is the problem. Futhermore, the solution must be written +as portable source code that is reasonably efficient across several different computer platforms. + +After a foundation is formed the remainder of the library can be designed and implemented in a hierarchical fashion. +That is, to implement the lowest level dependencies first and work towards the most abstract functions last. For example, +before implementing a modular exponentiation algorithm one would implement a modular reduction algorithm. +By building outwards from a base foundation instead of using a parallel design methodology the resulting project is +highly modular. Being highly modular is a desirable property of any project as it often means the resulting product +has a small footprint and updates are easy to perform. + +Usually when I start a project I will begin with the header files. I define the data types I think I will need and +prototype the initial functions that are not dependent on other functions (within the library). After I +implement these base functions I prototype more dependent functions and implement them. The process repeats until +I implement all of the functions I require. For example, in the case of LibTomMath I implemented functions such as +mp\_init() well before I implemented mp\_mul() and even further before I implemented mp\_exptmod(). As an example as to +why this design works note that the Karatsuba and Toom-Cook multipliers were written \textit{after} the +dependent function mp\_exptmod() was written. Adding the new multiplication algorithms did not require changes to the +mp\_exptmod() function itself and lowered the total cost of ownership (\textit{so to speak}) and of development +for new algorithms. This methodology allows new algorithms to be tested in a complete framework with relative ease. + +FIGU,design_process,Design Flow of the First Few Original LibTomMath Functions. + +Only after the majority of the functions were in place did I pursue a less hierarchical approach to auditing and optimizing +the source code. For example, one day I may audit the multipliers and the next day the polynomial basis functions. + +It only makes sense to begin the text with the preliminary data types and support algorithms required as well. +This chapter discusses the core algorithms of the library which are the dependents for every other algorithm. + +\section{What is a Multiple Precision Integer?} +Recall that most programming languages, in particular ISO C \cite{ISOC}, only have fixed precision data types that on their own cannot +be used to represent values larger than their precision will allow. The purpose of multiple precision algorithms is +to use fixed precision data types to create and manipulate multiple precision integers which may represent values +that are very large. + +As a well known analogy, school children are taught how to form numbers larger than nine by prepending more radix ten digits. In the decimal system +the largest single digit value is $9$. However, by concatenating digits together larger numbers may be represented. Newly prepended digits +(\textit{to the left}) are said to be in a different power of ten column. That is, the number $123$ can be described as having a $1$ in the hundreds +column, $2$ in the tens column and $3$ in the ones column. Or more formally $123 = 1 \cdot 10^2 + 2 \cdot 10^1 + 3 \cdot 10^0$. Computer based +multiple precision arithmetic is essentially the same concept. Larger integers are represented by adjoining fixed +precision computer words with the exception that a different radix is used. + +What most people probably do not think about explicitly are the various other attributes that describe a multiple precision +integer. For example, the integer $154_{10}$ has two immediately obvious properties. First, the integer is positive, +that is the sign of this particular integer is positive as opposed to negative. Second, the integer has three digits in +its representation. There is an additional property that the integer posesses that does not concern pencil-and-paper +arithmetic. The third property is how many digits placeholders are available to hold the integer. + +The human analogy of this third property is ensuring there is enough space on the paper to write the integer. For example, +if one starts writing a large number too far to the right on a piece of paper they will have to erase it and move left. +Similarly, computer algorithms must maintain strict control over memory usage to ensure that the digits of an integer +will not exceed the allowed boundaries. These three properties make up what is known as a multiple precision +integer or mp\_int for short. + +\subsection{The mp\_int Structure} +\label{sec:MPINT} +The mp\_int structure is the ISO C based manifestation of what represents a multiple precision integer. The ISO C standard does not provide for +any such data type but it does provide for making composite data types known as structures. The following is the structure definition +used within LibTomMath. + +\index{mp\_int} +\begin{figure}[here] +\begin{center} +\begin{small} +%\begin{verbatim} +\begin{tabular}{|l|} +\hline +typedef struct \{ \\ +\hspace{3mm}int used, alloc, sign;\\ +\hspace{3mm}mp\_digit *dp;\\ +\} \textbf{mp\_int}; \\ +\hline +\end{tabular} +%\end{verbatim} +\end{small} +\caption{The mp\_int Structure} +\label{fig:mpint} +\end{center} +\end{figure} + +The mp\_int structure (fig. \ref{fig:mpint}) can be broken down as follows. + +\begin{enumerate} +\item The \textbf{used} parameter denotes how many digits of the array \textbf{dp} contain the digits used to represent +a given integer. The \textbf{used} count must be positive (or zero) and may not exceed the \textbf{alloc} count. + +\item The \textbf{alloc} parameter denotes how +many digits are available in the array to use by functions before it has to increase in size. When the \textbf{used} count +of a result would exceed the \textbf{alloc} count all of the algorithms will automatically increase the size of the +array to accommodate the precision of the result. + +\item The pointer \textbf{dp} points to a dynamically allocated array of digits that represent the given multiple +precision integer. It is padded with $(\textbf{alloc} - \textbf{used})$ zero digits. The array is maintained in a least +significant digit order. As a pencil and paper analogy the array is organized such that the right most digits are stored +first starting at the location indexed by zero\footnote{In C all arrays begin at zero.} in the array. For example, +if \textbf{dp} contains $\lbrace a, b, c, \ldots \rbrace$ where \textbf{dp}$_0 = a$, \textbf{dp}$_1 = b$, \textbf{dp}$_2 = c$, $\ldots$ then +it would represent the integer $a + b\beta + c\beta^2 + \ldots$ + +\index{MP\_ZPOS} \index{MP\_NEG} +\item The \textbf{sign} parameter denotes the sign as either zero/positive (\textbf{MP\_ZPOS}) or negative (\textbf{MP\_NEG}). +\end{enumerate} + +\subsubsection{Valid mp\_int Structures} +Several rules are placed on the state of an mp\_int structure and are assumed to be followed for reasons of efficiency. +The only exceptions are when the structure is passed to initialization functions such as mp\_init() and mp\_init\_copy(). + +\begin{enumerate} +\item The value of \textbf{alloc} may not be less than one. That is \textbf{dp} always points to a previously allocated +array of digits. +\item The value of \textbf{used} may not exceed \textbf{alloc} and must be greater than or equal to zero. +\item The value of \textbf{used} implies the digit at index $(used - 1)$ of the \textbf{dp} array is non-zero. That is, +leading zero digits in the most significant positions must be trimmed. + \begin{enumerate} + \item Digits in the \textbf{dp} array at and above the \textbf{used} location must be zero. + \end{enumerate} +\item The value of \textbf{sign} must be \textbf{MP\_ZPOS} if \textbf{used} is zero; +this represents the mp\_int value of zero. +\end{enumerate} + +\section{Argument Passing} +A convention of argument passing must be adopted early on in the development of any library. Making the function +prototypes consistent will help eliminate many headaches in the future as the library grows to significant complexity. +In LibTomMath the multiple precision integer functions accept parameters from left to right as pointers to mp\_int +structures. That means that the source (input) operands are placed on the left and the destination (output) on the right. +Consider the following examples. + +\begin{verbatim} + mp_mul(&a, &b, &c); /* c = a * b */ + mp_add(&a, &b, &a); /* a = a + b */ + mp_sqr(&a, &b); /* b = a * a */ +\end{verbatim} + +The left to right order is a fairly natural way to implement the functions since it lets the developer read aloud the +functions and make sense of them. For example, the first function would read ``multiply a and b and store in c''. + +Certain libraries (\textit{LIP by Lenstra for instance}) accept parameters the other way around, to mimic the order +of assignment expressions. That is, the destination (output) is on the left and arguments (inputs) are on the right. In +truth, it is entirely a matter of preference. In the case of LibTomMath the convention from the MPI library has been +adopted. + +Another very useful design consideration, provided for in LibTomMath, is whether to allow argument sources to also be a +destination. For example, the second example (\textit{mp\_add}) adds $a$ to $b$ and stores in $a$. This is an important +feature to implement since it allows the calling functions to cut down on the number of variables it must maintain. +However, to implement this feature specific care has to be given to ensure the destination is not modified before the +source is fully read. + +\section{Return Values} +A well implemented application, no matter what its purpose, should trap as many runtime errors as possible and return them +to the caller. By catching runtime errors a library can be guaranteed to prevent undefined behaviour. However, the end +developer can still manage to cause a library to crash. For example, by passing an invalid pointer an application may +fault by dereferencing memory not owned by the application. + +In the case of LibTomMath the only errors that are checked for are related to inappropriate inputs (division by zero for +instance) and memory allocation errors. It will not check that the mp\_int passed to any function is valid nor +will it check pointers for validity. Any function that can cause a runtime error will return an error code as an +\textbf{int} data type with one of the following values (fig \ref{fig:errcodes}). + +\index{MP\_OKAY} \index{MP\_VAL} \index{MP\_MEM} +\begin{figure}[here] +\begin{center} +\begin{tabular}{|l|l|} +\hline \textbf{Value} & \textbf{Meaning} \\ +\hline \textbf{MP\_OKAY} & The function was successful \\ +\hline \textbf{MP\_VAL} & One of the input value(s) was invalid \\ +\hline \textbf{MP\_MEM} & The function ran out of heap memory \\ +\hline +\end{tabular} +\end{center} +\caption{LibTomMath Error Codes} +\label{fig:errcodes} +\end{figure} + +When an error is detected within a function it should free any memory it allocated, often during the initialization of +temporary mp\_ints, and return as soon as possible. The goal is to leave the system in the same state it was when the +function was called. Error checking with this style of API is fairly simple. + +\begin{verbatim} + int err; + if ((err = mp_add(&a, &b, &c)) != MP_OKAY) { + printf("Error: %s\n", mp_error_to_string(err)); + exit(EXIT_FAILURE); + } +\end{verbatim} + +The GMP \cite{GMP} library uses C style \textit{signals} to flag errors which is of questionable use. Not all errors are fatal +and it was not deemed ideal by the author of LibTomMath to force developers to have signal handlers for such cases. + +\section{Initialization and Clearing} +The logical starting point when actually writing multiple precision integer functions is the initialization and +clearing of the mp\_int structures. These two algorithms will be used by the majority of the higher level algorithms. + +Given the basic mp\_int structure an initialization routine must first allocate memory to hold the digits of +the integer. Often it is optimal to allocate a sufficiently large pre-set number of digits even though +the initial integer will represent zero. If only a single digit were allocated quite a few subsequent re-allocations +would occur when operations are performed on the integers. There is a tradeoff between how many default digits to allocate +and how many re-allocations are tolerable. Obviously allocating an excessive amount of digits initially will waste +memory and become unmanageable. + +If the memory for the digits has been successfully allocated then the rest of the members of the structure must +be initialized. Since the initial state of an mp\_int is to represent the zero integer, the allocated digits must be set +to zero. The \textbf{used} count set to zero and \textbf{sign} set to \textbf{MP\_ZPOS}. + +\subsection{Initializing an mp\_int} +An mp\_int is said to be initialized if it is set to a valid, preferably default, state such that all of the members of the +structure are set to valid values. The mp\_init algorithm will perform such an action. + +\index{mp\_init} +\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_init}. \\ +\textbf{Input}. An mp\_int $a$ \\ +\textbf{Output}. Allocate memory and initialize $a$ to a known valid mp\_int state. \\ +\hline \\ +1. Allocate memory for \textbf{MP\_PREC} digits. \\ +2. If the allocation failed return(\textit{MP\_MEM}) \\ +3. for $n$ from $0$ to $MP\_PREC - 1$ do \\ +\hspace{3mm}3.1 $a_n \leftarrow 0$\\ +4. $a.sign \leftarrow MP\_ZPOS$\\ +5. $a.used \leftarrow 0$\\ +6. $a.alloc \leftarrow MP\_PREC$\\ +7. Return(\textit{MP\_OKAY})\\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_init} +\end{figure} + +\textbf{Algorithm mp\_init.} +The purpose of this function is to initialize an mp\_int structure so that the rest of the library can properly +manipulte it. It is assumed that the input may not have had any of its members previously initialized which is certainly +a valid assumption if the input resides on the stack. + +Before any of the members such as \textbf{sign}, \textbf{used} or \textbf{alloc} are initialized the memory for +the digits is allocated. If this fails the function returns before setting any of the other members. The \textbf{MP\_PREC} +name represents a constant\footnote{Defined in the ``tommath.h'' header file within LibTomMath.} +used to dictate the minimum precision of newly initialized mp\_int integers. Ideally, it is at least equal to the smallest +precision number you'll be working with. + +Allocating a block of digits at first instead of a single digit has the benefit of lowering the number of usually slow +heap operations later functions will have to perform in the future. If \textbf{MP\_PREC} is set correctly the slack +memory and the number of heap operations will be trivial. + +Once the allocation has been made the digits have to be set to zero as well as the \textbf{used}, \textbf{sign} and +\textbf{alloc} members initialized. This ensures that the mp\_int will always represent the default state of zero regardless +of the original condition of the input. + +\textbf{Remark.} +This function introduces the idiosyncrasy that all iterative loops, commonly initiated with the ``for'' keyword, iterate incrementally +when the ``to'' keyword is placed between two expressions. For example, ``for $a$ from $b$ to $c$ do'' means that +a subsequent expression (or body of expressions) are to be evaluated upto $c - b$ times so long as $b \le c$. In each +iteration the variable $a$ is substituted for a new integer that lies inclusively between $b$ and $c$. If $b > c$ occured +the loop would not iterate. By contrast if the ``downto'' keyword were used in place of ``to'' the loop would iterate +decrementally. + +EXAM,bn_mp_init.c + +One immediate observation of this initializtion function is that it does not return a pointer to a mp\_int structure. It +is assumed that the caller has already allocated memory for the mp\_int structure, typically on the application stack. The +call to mp\_init() is used only to initialize the members of the structure to a known default state. + +Here we see (line @23,XMALLOC@) the memory allocation is performed first. This allows us to exit cleanly and quickly +if there is an error. If the allocation fails the routine will return \textbf{MP\_MEM} to the caller to indicate there +was a memory error. The function XMALLOC is what actually allocates the memory. Technically XMALLOC is not a function +but a macro defined in ``tommath.h``. By default, XMALLOC will evaluate to malloc() which is the C library's built--in +memory allocation routine. + +In order to assure the mp\_int is in a known state the digits must be set to zero. On most platforms this could have been +accomplished by using calloc() instead of malloc(). However, to correctly initialize a integer type to a given value in a +portable fashion you have to actually assign the value. The for loop (line @28,for@) performs this required +operation. + +After the memory has been successfully initialized the remainder of the members are initialized +(lines @29,used@ through @31,sign@) to their respective default states. At this point the algorithm has succeeded and +a success code is returned to the calling function. If this function returns \textbf{MP\_OKAY} it is safe to assume the +mp\_int structure has been properly initialized and is safe to use with other functions within the library. + +\subsection{Clearing an mp\_int} +When an mp\_int is no longer required by the application, the memory that has been allocated for its digits must be +returned to the application's memory pool with the mp\_clear algorithm. + +\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_clear}. \\ +\textbf{Input}. An mp\_int $a$ \\ +\textbf{Output}. The memory for $a$ shall be deallocated. \\ +\hline \\ +1. If $a$ has been previously freed then return(\textit{MP\_OKAY}). \\ +2. for $n$ from 0 to $a.used - 1$ do \\ +\hspace{3mm}2.1 $a_n \leftarrow 0$ \\ +3. Free the memory allocated for the digits of $a$. \\ +4. $a.used \leftarrow 0$ \\ +5. $a.alloc \leftarrow 0$ \\ +6. $a.sign \leftarrow MP\_ZPOS$ \\ +7. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_clear} +\end{figure} + +\textbf{Algorithm mp\_clear.} +This algorithm accomplishes two goals. First, it clears the digits and the other mp\_int members. This ensures that +if a developer accidentally re-uses a cleared structure it is less likely to cause problems. The second goal +is to free the allocated memory. + +The logic behind the algorithm is extended by marking cleared mp\_int structures so that subsequent calls to this +algorithm will not try to free the memory multiple times. Cleared mp\_ints are detectable by having a pre-defined invalid +digit pointer \textbf{dp} setting. + +Once an mp\_int has been cleared the mp\_int structure is no longer in a valid state for any other algorithm +with the exception of algorithms mp\_init, mp\_init\_copy, mp\_init\_size and mp\_clear. + +EXAM,bn_mp_clear.c + +The algorithm only operates on the mp\_int if it hasn't been previously cleared. The if statement (line @23,a->dp != NULL@) +checks to see if the \textbf{dp} member is not \textbf{NULL}. If the mp\_int is a valid mp\_int then \textbf{dp} cannot be +\textbf{NULL} in which case the if statement will evaluate to true. + +The digits of the mp\_int are cleared by the for loop (line @25,for@) which assigns a zero to every digit. Similar to mp\_init() +the digits are assigned zero instead of using block memory operations (such as memset()) since this is more portable. + +The digits are deallocated off the heap via the XFREE macro. Similar to XMALLOC the XFREE macro actually evaluates to +a standard C library function. In this case the free() function. Since free() only deallocates the memory the pointer +still has to be reset to \textbf{NULL} manually (line @33,NULL@). + +Now that the digits have been cleared and deallocated the other members are set to their final values (lines @34,= 0@ and @35,ZPOS@). + +\section{Maintenance Algorithms} + +The previous sections describes how to initialize and clear an mp\_int structure. To further support operations +that are to be performed on mp\_int structures (such as addition and multiplication) the dependent algorithms must be +able to augment the precision of an mp\_int and +initialize mp\_ints with differing initial conditions. + +These algorithms complete the set of low level algorithms required to work with mp\_int structures in the higher level +algorithms such as addition, multiplication and modular exponentiation. + +\subsection{Augmenting an mp\_int's Precision} +When storing a value in an mp\_int structure, a sufficient number of digits must be available to accomodate the entire +result of an operation without loss of precision. Quite often the size of the array given by the \textbf{alloc} member +is large enough to simply increase the \textbf{used} digit count. However, when the size of the array is too small it +must be re-sized appropriately to accomodate the result. The mp\_grow algorithm will provide this functionality. + +\newpage\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_grow}. \\ +\textbf{Input}. An mp\_int $a$ and an integer $b$. \\ +\textbf{Output}. $a$ is expanded to accomodate $b$ digits. \\ +\hline \\ +1. if $a.alloc \ge b$ then return(\textit{MP\_OKAY}) \\ +2. $u \leftarrow b\mbox{ (mod }MP\_PREC\mbox{)}$ \\ +3. $v \leftarrow b + 2 \cdot MP\_PREC - u$ \\ +4. Re-allocate the array of digits $a$ to size $v$ \\ +5. If the allocation failed then return(\textit{MP\_MEM}). \\ +6. for n from a.alloc to $v - 1$ do \\ +\hspace{+3mm}6.1 $a_n \leftarrow 0$ \\ +7. $a.alloc \leftarrow v$ \\ +8. Return(\textit{MP\_OKAY}) \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_grow} +\end{figure} + +\textbf{Algorithm mp\_grow.} +It is ideal to prevent re-allocations from being performed if they are not required (step one). This is useful to +prevent mp\_ints from growing excessively in code that erroneously calls mp\_grow. + +The requested digit count is padded up to next multiple of \textbf{MP\_PREC} plus an additional \textbf{MP\_PREC} (steps two and three). +This helps prevent many trivial reallocations that would grow an mp\_int by trivially small values. + +It is assumed that the reallocation (step four) leaves the lower $a.alloc$ digits of the mp\_int intact. This is much +akin to how the \textit{realloc} function from the standard C library works. Since the newly allocated digits are +assumed to contain undefined values they are initially set to zero. + +EXAM,bn_mp_grow.c + +A quick optimization is to first determine if a memory re-allocation is required at all. The if statement (line @24,alloc@) checks +if the \textbf{alloc} member of the mp\_int is smaller than the requested digit count. If the count is not larger than \textbf{alloc} +the function skips the re-allocation part thus saving time. + +When a re-allocation is performed it is turned into an optimal request to save time in the future. The requested digit count is +padded upwards to 2nd multiple of \textbf{MP\_PREC} larger than \textbf{alloc} (line @25, size@). The XREALLOC function is used +to re-allocate the memory. As per the other functions XREALLOC is actually a macro which evaluates to realloc by default. The realloc +function leaves the base of the allocation intact which means the first \textbf{alloc} digits of the mp\_int are the same as before +the re-allocation. All that is left is to clear the newly allocated digits and return. + +Note that the re-allocation result is actually stored in a temporary pointer $tmp$. This is to allow this function to return +an error with a valid pointer. Earlier releases of the library stored the result of XREALLOC into the mp\_int $a$. That would +result in a memory leak if XREALLOC ever failed. + +\subsection{Initializing Variable Precision mp\_ints} +Occasionally the number of digits required will be known in advance of an initialization, based on, for example, the size +of input mp\_ints to a given algorithm. The purpose of algorithm mp\_init\_size is similar to mp\_init except that it +will allocate \textit{at least} a specified number of digits. + +\begin{figure}[here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_init\_size}. \\ +\textbf{Input}. An mp\_int $a$ and the requested number of digits $b$. \\ +\textbf{Output}. $a$ is initialized to hold at least $b$ digits. \\ +\hline \\ +1. $u \leftarrow b \mbox{ (mod }MP\_PREC\mbox{)}$ \\ +2. $v \leftarrow b + 2 \cdot MP\_PREC - u$ \\ +3. Allocate $v$ digits. \\ +4. for $n$ from $0$ to $v - 1$ do \\ +\hspace{3mm}4.1 $a_n \leftarrow 0$ \\ +5. $a.sign \leftarrow MP\_ZPOS$\\ +6. $a.used \leftarrow 0$\\ +7. $a.alloc \leftarrow v$\\ +8. Return(\textit{MP\_OKAY})\\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_init\_size} +\end{figure} + +\textbf{Algorithm mp\_init\_size.} +This algorithm will initialize an mp\_int structure $a$ like algorithm mp\_init with the exception that the number of +digits allocated can be controlled by the second input argument $b$. The input size is padded upwards so it is a +multiple of \textbf{MP\_PREC} plus an additional \textbf{MP\_PREC} digits. This padding is used to prevent trivial +allocations from becoming a bottleneck in the rest of the algorithms. + +Like algorithm mp\_init, the mp\_int structure is initialized to a default state representing the integer zero. This +particular algorithm is useful if it is known ahead of time the approximate size of the input. If the approximation is +correct no further memory re-allocations are required to work with the mp\_int. + +EXAM,bn_mp_init_size.c + +The number of digits $b$ requested is padded (line @22,MP_PREC@) by first augmenting it to the next multiple of +\textbf{MP\_PREC} and then adding \textbf{MP\_PREC} to the result. If the memory can be successfully allocated the +mp\_int is placed in a default state representing the integer zero. Otherwise, the error code \textbf{MP\_MEM} will be +returned (line @27,return@). + +The digits are allocated and set to zero at the same time with the calloc() function (line @25,XCALLOC@). The +\textbf{used} count is set to zero, the \textbf{alloc} count set to the padded digit count and the \textbf{sign} flag set +to \textbf{MP\_ZPOS} to achieve a default valid mp\_int state (lines @29,used@, @30,alloc@ and @31,sign@). If the function +returns succesfully then it is correct to assume that the mp\_int structure is in a valid state for the remainder of the +functions to work with. + +\subsection{Multiple Integer Initializations and Clearings} +Occasionally a function will require a series of mp\_int data types to be made available simultaneously. +The purpose of algorithm mp\_init\_multi is to initialize a variable length array of mp\_int structures in a single +statement. It is essentially a shortcut to multiple initializations. + +\newpage\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_init\_multi}. \\ +\textbf{Input}. Variable length array $V_k$ of mp\_int variables of length $k$. \\ +\textbf{Output}. The array is initialized such that each mp\_int of $V_k$ is ready to use. \\ +\hline \\ +1. for $n$ from 0 to $k - 1$ do \\ +\hspace{+3mm}1.1. Initialize the mp\_int $V_n$ (\textit{mp\_init}) \\ +\hspace{+3mm}1.2. If initialization failed then do \\ +\hspace{+6mm}1.2.1. for $j$ from $0$ to $n$ do \\ +\hspace{+9mm}1.2.1.1. Free the mp\_int $V_j$ (\textit{mp\_clear}) \\ +\hspace{+6mm}1.2.2. Return(\textit{MP\_MEM}) \\ +2. Return(\textit{MP\_OKAY}) \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_init\_multi} +\end{figure} + +\textbf{Algorithm mp\_init\_multi.} +The algorithm will initialize the array of mp\_int variables one at a time. If a runtime error has been detected +(\textit{step 1.2}) all of the previously initialized variables are cleared. The goal is an ``all or nothing'' +initialization which allows for quick recovery from runtime errors. + +EXAM,bn_mp_init_multi.c + +This function intializes a variable length list of mp\_int structure pointers. However, instead of having the mp\_int +structures in an actual C array they are simply passed as arguments to the function. This function makes use of the +``...'' argument syntax of the C programming language. The list is terminated with a final \textbf{NULL} argument +appended on the right. + +The function uses the ``stdarg.h'' \textit{va} functions to step portably through the arguments to the function. A count +$n$ of succesfully initialized mp\_int structures is maintained (line @47,n++@) such that if a failure does occur, +the algorithm can backtrack and free the previously initialized structures (lines @27,if@ to @46,}@). + + +\subsection{Clamping Excess Digits} +When a function anticipates a result will be $n$ digits it is simpler to assume this is true within the body of +the function instead of checking during the computation. For example, a multiplication of a $i$ digit number by a +$j$ digit produces a result of at most $i + j$ digits. It is entirely possible that the result is $i + j - 1$ +though, with no final carry into the last position. However, suppose the destination had to be first expanded +(\textit{via mp\_grow}) to accomodate $i + j - 1$ digits than further expanded to accomodate the final carry. +That would be a considerable waste of time since heap operations are relatively slow. + +The ideal solution is to always assume the result is $i + j$ and fix up the \textbf{used} count after the function +terminates. This way a single heap operation (\textit{at most}) is required. However, if the result was not checked +there would be an excess high order zero digit. + +For example, suppose the product of two integers was $x_n = (0x_{n-1}x_{n-2}...x_0)_{\beta}$. The leading zero digit +will not contribute to the precision of the result. In fact, through subsequent operations more leading zero digits would +accumulate to the point the size of the integer would be prohibitive. As a result even though the precision is very +low the representation is excessively large. + +The mp\_clamp algorithm is designed to solve this very problem. It will trim high-order zeros by decrementing the +\textbf{used} count until a non-zero most significant digit is found. Also in this system, zero is considered to be a +positive number which means that if the \textbf{used} count is decremented to zero, the sign must be set to +\textbf{MP\_ZPOS}. + +\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_clamp}. \\ +\textbf{Input}. An mp\_int $a$ \\ +\textbf{Output}. Any excess leading zero digits of $a$ are removed \\ +\hline \\ +1. while $a.used > 0$ and $a_{a.used - 1} = 0$ do \\ +\hspace{+3mm}1.1 $a.used \leftarrow a.used - 1$ \\ +2. if $a.used = 0$ then do \\ +\hspace{+3mm}2.1 $a.sign \leftarrow MP\_ZPOS$ \\ +\hline \\ +\end{tabular} +\end{center} +\caption{Algorithm mp\_clamp} +\end{figure} + +\textbf{Algorithm mp\_clamp.} +As can be expected this algorithm is very simple. The loop on step one is expected to iterate only once or twice at +the most. For example, this will happen in cases where there is not a carry to fill the last position. Step two fixes the sign for +when all of the digits are zero to ensure that the mp\_int is valid at all times. + +EXAM,bn_mp_clamp.c + +Note on line @27,while@ how to test for the \textbf{used} count is made on the left of the \&\& operator. In the C programming +language the terms to \&\& are evaluated left to right with a boolean short-circuit if any condition fails. This is +important since if the \textbf{used} is zero the test on the right would fetch below the array. That is obviously +undesirable. The parenthesis on line @28,a->used@ is used to make sure the \textbf{used} count is decremented and not +the pointer ``a''. + +\section*{Exercises} +\begin{tabular}{cl} +$\left [ 1 \right ]$ & Discuss the relevance of the \textbf{used} member of the mp\_int structure. \\ + & \\ +$\left [ 1 \right ]$ & Discuss the consequences of not using padding when performing allocations. \\ + & \\ +$\left [ 2 \right ]$ & Estimate an ideal value for \textbf{MP\_PREC} when performing 1024-bit RSA \\ + & encryption when $\beta = 2^{28}$. \\ + & \\ +$\left [ 1 \right ]$ & Discuss the relevance of the algorithm mp\_clamp. What does it prevent? \\ + & \\ +$\left [ 1 \right ]$ & Give an example of when the algorithm mp\_init\_copy might be useful. \\ + & \\ +\end{tabular} + + +%%% +% CHAPTER FOUR +%%% + +\chapter{Basic Operations} + +\section{Introduction} +In the previous chapter a series of low level algorithms were established that dealt with initializing and maintaining +mp\_int structures. This chapter will discuss another set of seemingly non-algebraic algorithms which will form the low +level basis of the entire library. While these algorithm are relatively trivial it is important to understand how they +work before proceeding since these algorithms will be used almost intrinsically in the following chapters. + +The algorithms in this chapter deal primarily with more ``programmer'' related tasks such as creating copies of +mp\_int structures, assigning small values to mp\_int structures and comparisons of the values mp\_int structures +represent. + +\section{Assigning Values to mp\_int Structures} +\subsection{Copying an mp\_int} +Assigning the value that a given mp\_int structure represents to another mp\_int structure shall be known as making +a copy for the purposes of this text. The copy of the mp\_int will be a separate entity that represents the same +value as the mp\_int it was copied from. The mp\_copy algorithm provides this functionality. + +\newpage\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_copy}. \\ +\textbf{Input}. An mp\_int $a$ and $b$. \\ +\textbf{Output}. Store a copy of $a$ in $b$. \\ +\hline \\ +1. If $b.alloc < a.used$ then grow $b$ to $a.used$ digits. (\textit{mp\_grow}) \\ +2. for $n$ from 0 to $a.used - 1$ do \\ +\hspace{3mm}2.1 $b_{n} \leftarrow a_{n}$ \\ +3. for $n$ from $a.used$ to $b.used - 1$ do \\ +\hspace{3mm}3.1 $b_{n} \leftarrow 0$ \\ +4. $b.used \leftarrow a.used$ \\ +5. $b.sign \leftarrow a.sign$ \\ +6. return(\textit{MP\_OKAY}) \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_copy} +\end{figure} + +\textbf{Algorithm mp\_copy.} +This algorithm copies the mp\_int $a$ such that upon succesful termination of the algorithm the mp\_int $b$ will +represent the same integer as the mp\_int $a$. The mp\_int $b$ shall be a complete and distinct copy of the +mp\_int $a$ meaing that the mp\_int $a$ can be modified and it shall not affect the value of the mp\_int $b$. + +If $b$ does not have enough room for the digits of $a$ it must first have its precision augmented via the mp\_grow +algorithm. The digits of $a$ are copied over the digits of $b$ and any excess digits of $b$ are set to zero (step two +and three). The \textbf{used} and \textbf{sign} members of $a$ are finally copied over the respective members of +$b$. + +\textbf{Remark.} This algorithm also introduces a new idiosyncrasy that will be used throughout the rest of the +text. The error return codes of other algorithms are not explicitly checked in the pseudo-code presented. For example, in +step one of the mp\_copy algorithm the return of mp\_grow is not explicitly checked to ensure it succeeded. Text space is +limited so it is assumed that if a algorithm fails it will clear all temporarily allocated mp\_ints and return +the error code itself. However, the C code presented will demonstrate all of the error handling logic required to +implement the pseudo-code. + +EXAM,bn_mp_copy.c + +Occasionally a dependent algorithm may copy an mp\_int effectively into itself such as when the input and output +mp\_int structures passed to a function are one and the same. For this case it is optimal to return immediately without +copying digits (line @24,a == b@). + +The mp\_int $b$ must have enough digits to accomodate the used digits of the mp\_int $a$. If $b.alloc$ is less than +$a.used$ the algorithm mp\_grow is used to augment the precision of $b$ (lines @29,alloc@ to @33,}@). In order to +simplify the inner loop that copies the digits from $a$ to $b$, two aliases $tmpa$ and $tmpb$ point directly at the digits +of the mp\_ints $a$ and $b$ respectively. These aliases (lines @42,tmpa@ and @45,tmpb@) allow the compiler to access the digits without first dereferencing the +mp\_int pointers and then subsequently the pointer to the digits. + +After the aliases are established the digits from $a$ are copied into $b$ (lines @48,for@ to @50,}@) and then the excess +digits of $b$ are set to zero (lines @53,for@ to @55,}@). Both ``for'' loops make use of the pointer aliases and in +fact the alias for $b$ is carried through into the second ``for'' loop to clear the excess digits. This optimization +allows the alias to stay in a machine register fairly easy between the two loops. + +\textbf{Remarks.} The use of pointer aliases is an implementation methodology first introduced in this function that will +be used considerably in other functions. Technically, a pointer alias is simply a short hand alias used to lower the +number of pointer dereferencing operations required to access data. For example, a for loop may resemble + +\begin{alltt} +for (x = 0; x < 100; x++) \{ + a->num[4]->dp[x] = 0; +\} +\end{alltt} + +This could be re-written using aliases as + +\begin{alltt} +mp_digit *tmpa; +a = a->num[4]->dp; +for (x = 0; x < 100; x++) \{ + *a++ = 0; +\} +\end{alltt} + +In this case an alias is used to access the +array of digits within an mp\_int structure directly. It may seem that a pointer alias is strictly not required +as a compiler may optimize out the redundant pointer operations. However, there are two dominant reasons to use aliases. + +The first reason is that most compilers will not effectively optimize pointer arithmetic. For example, some optimizations +may work for the Microsoft Visual C++ compiler (MSVC) and not for the GNU C Compiler (GCC). Also some optimizations may +work for GCC and not MSVC. As such it is ideal to find a common ground for as many compilers as possible. Pointer +aliases optimize the code considerably before the compiler even reads the source code which means the end compiled code +stands a better chance of being faster. + +The second reason is that pointer aliases often can make an algorithm simpler to read. Consider the first ``for'' +loop of the function mp\_copy() re-written to not use pointer aliases. + +\begin{alltt} + /* copy all the digits */ + for (n = 0; n < a->used; n++) \{ + b->dp[n] = a->dp[n]; + \} +\end{alltt} + +Whether this code is harder to read depends strongly on the individual. However, it is quantifiably slightly more +complicated as there are four variables within the statement instead of just two. + +\subsubsection{Nested Statements} +Another commonly used technique in the source routines is that certain sections of code are nested. This is used in +particular with the pointer aliases to highlight code phases. For example, a Comba multiplier (discussed in chapter six) +will typically have three different phases. First the temporaries are initialized, then the columns calculated and +finally the carries are propagated. In this example the middle column production phase will typically be nested as it +uses temporary variables and aliases the most. + +The nesting also simplies the source code as variables that are nested are only valid for their scope. As a result +the various temporary variables required do not propagate into other sections of code. + + +\subsection{Creating a Clone} +Another common operation is to make a local temporary copy of an mp\_int argument. To initialize an mp\_int +and then copy another existing mp\_int into the newly intialized mp\_int will be known as creating a clone. This is +useful within functions that need to modify an argument but do not wish to actually modify the original copy. The +mp\_init\_copy algorithm has been designed to help perform this task. + +\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_init\_copy}. \\ +\textbf{Input}. An mp\_int $a$ and $b$\\ +\textbf{Output}. $a$ is initialized to be a copy of $b$. \\ +\hline \\ +1. Init $a$. (\textit{mp\_init}) \\ +2. Copy $b$ to $a$. (\textit{mp\_copy}) \\ +3. Return the status of the copy operation. \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_init\_copy} +\end{figure} + +\textbf{Algorithm mp\_init\_copy.} +This algorithm will initialize an mp\_int variable and copy another previously initialized mp\_int variable into it. As +such this algorithm will perform two operations in one step. + +EXAM,bn_mp_init_copy.c + +This will initialize \textbf{a} and make it a verbatim copy of the contents of \textbf{b}. Note that +\textbf{a} will have its own memory allocated which means that \textbf{b} may be cleared after the call +and \textbf{a} will be left intact. + +\section{Zeroing an Integer} +Reseting an mp\_int to the default state is a common step in many algorithms. The mp\_zero algorithm will be the algorithm used to +perform this task. + +\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_zero}. \\ +\textbf{Input}. An mp\_int $a$ \\ +\textbf{Output}. Zero the contents of $a$ \\ +\hline \\ +1. $a.used \leftarrow 0$ \\ +2. $a.sign \leftarrow$ MP\_ZPOS \\ +3. for $n$ from 0 to $a.alloc - 1$ do \\ +\hspace{3mm}3.1 $a_n \leftarrow 0$ \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_zero} +\end{figure} + +\textbf{Algorithm mp\_zero.} +This algorithm simply resets a mp\_int to the default state. + +EXAM,bn_mp_zero.c + +After the function is completed, all of the digits are zeroed, the \textbf{used} count is zeroed and the +\textbf{sign} variable is set to \textbf{MP\_ZPOS}. + +\section{Sign Manipulation} +\subsection{Absolute Value} +With the mp\_int representation of an integer, calculating the absolute value is trivial. The mp\_abs algorithm will compute +the absolute value of an mp\_int. + +\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_abs}. \\ +\textbf{Input}. An mp\_int $a$ \\ +\textbf{Output}. Computes $b = \vert a \vert$ \\ +\hline \\ +1. Copy $a$ to $b$. (\textit{mp\_copy}) \\ +2. If the copy failed return(\textit{MP\_MEM}). \\ +3. $b.sign \leftarrow MP\_ZPOS$ \\ +4. Return(\textit{MP\_OKAY}) \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_abs} +\end{figure} + +\textbf{Algorithm mp\_abs.} +This algorithm computes the absolute of an mp\_int input. First it copies $a$ over $b$. This is an example of an +algorithm where the check in mp\_copy that determines if the source and destination are equal proves useful. This allows, +for instance, the developer to pass the same mp\_int as the source and destination to this function without addition +logic to handle it. + +EXAM,bn_mp_abs.c + +This fairly trivial algorithm first eliminates non--required duplications (line @27,a != b@) and then sets the +\textbf{sign} flag to \textbf{MP\_ZPOS}. + +\subsection{Integer Negation} +With the mp\_int representation of an integer, calculating the negation is also trivial. The mp\_neg algorithm will compute +the negative of an mp\_int input. + +\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_neg}. \\ +\textbf{Input}. An mp\_int $a$ \\ +\textbf{Output}. Computes $b = -a$ \\ +\hline \\ +1. Copy $a$ to $b$. (\textit{mp\_copy}) \\ +2. If the copy failed return(\textit{MP\_MEM}). \\ +3. If $a.used = 0$ then return(\textit{MP\_OKAY}). \\ +4. If $a.sign = MP\_ZPOS$ then do \\ +\hspace{3mm}4.1 $b.sign = MP\_NEG$. \\ +5. else do \\ +\hspace{3mm}5.1 $b.sign = MP\_ZPOS$. \\ +6. Return(\textit{MP\_OKAY}) \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_neg} +\end{figure} + +\textbf{Algorithm mp\_neg.} +This algorithm computes the negation of an input. First it copies $a$ over $b$. If $a$ has no used digits then +the algorithm returns immediately. Otherwise it flips the sign flag and stores the result in $b$. Note that if +$a$ had no digits then it must be positive by definition. Had step three been omitted then the algorithm would return +zero as negative. + +EXAM,bn_mp_neg.c + +Like mp\_abs() this function avoids non--required duplications (line @21,a != b@) and then sets the sign. We +have to make sure that only non--zero values get a \textbf{sign} of \textbf{MP\_NEG}. If the mp\_int is zero +than the \textbf{sign} is hard--coded to \textbf{MP\_ZPOS}. + +\section{Small Constants} +\subsection{Setting Small Constants} +Often a mp\_int must be set to a relatively small value such as $1$ or $2$. For these cases the mp\_set algorithm is useful. + +\newpage\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_set}. \\ +\textbf{Input}. An mp\_int $a$ and a digit $b$ \\ +\textbf{Output}. Make $a$ equivalent to $b$ \\ +\hline \\ +1. Zero $a$ (\textit{mp\_zero}). \\ +2. $a_0 \leftarrow b \mbox{ (mod }\beta\mbox{)}$ \\ +3. $a.used \leftarrow \left \lbrace \begin{array}{ll} + 1 & \mbox{if }a_0 > 0 \\ + 0 & \mbox{if }a_0 = 0 + \end{array} \right .$ \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_set} +\end{figure} + +\textbf{Algorithm mp\_set.} +This algorithm sets a mp\_int to a small single digit value. Step number 1 ensures that the integer is reset to the default state. The +single digit is set (\textit{modulo $\beta$}) and the \textbf{used} count is adjusted accordingly. + +EXAM,bn_mp_set.c + +First we zero (line @21,mp_zero@) the mp\_int to make sure that the other members are initialized for a +small positive constant. mp\_zero() ensures that the \textbf{sign} is positive and the \textbf{used} count +is zero. Next we set the digit and reduce it modulo $\beta$ (line @22,MP_MASK@). After this step we have to +check if the resulting digit is zero or not. If it is not then we set the \textbf{used} count to one, otherwise +to zero. + +We can quickly reduce modulo $\beta$ since it is of the form $2^k$ and a quick binary AND operation with +$2^k - 1$ will perform the same operation. + +One important limitation of this function is that it will only set one digit. The size of a digit is not fixed, meaning source that uses +this function should take that into account. Only trivially small constants can be set using this function. + +\subsection{Setting Large Constants} +To overcome the limitations of the mp\_set algorithm the mp\_set\_int algorithm is ideal. It accepts a ``long'' +data type as input and will always treat it as a 32-bit integer. + +\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_set\_int}. \\ +\textbf{Input}. An mp\_int $a$ and a ``long'' integer $b$ \\ +\textbf{Output}. Make $a$ equivalent to $b$ \\ +\hline \\ +1. Zero $a$ (\textit{mp\_zero}) \\ +2. for $n$ from 0 to 7 do \\ +\hspace{3mm}2.1 $a \leftarrow a \cdot 16$ (\textit{mp\_mul2d}) \\ +\hspace{3mm}2.2 $u \leftarrow \lfloor b / 2^{4(7 - n)} \rfloor \mbox{ (mod }16\mbox{)}$\\ +\hspace{3mm}2.3 $a_0 \leftarrow a_0 + u$ \\ +\hspace{3mm}2.4 $a.used \leftarrow a.used + 1$ \\ +3. Clamp excess used digits (\textit{mp\_clamp}) \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_set\_int} +\end{figure} + +\textbf{Algorithm mp\_set\_int.} +The algorithm performs eight iterations of a simple loop where in each iteration four bits from the source are added to the +mp\_int. Step 2.1 will multiply the current result by sixteen making room for four more bits in the less significant positions. In step 2.2 the +next four bits from the source are extracted and are added to the mp\_int. The \textbf{used} digit count is +incremented to reflect the addition. The \textbf{used} digit counter is incremented since if any of the leading digits were zero the mp\_int would have +zero digits used and the newly added four bits would be ignored. + +Excess zero digits are trimmed in steps 2.1 and 3 by using higher level algorithms mp\_mul2d and mp\_clamp. + +EXAM,bn_mp_set_int.c + +This function sets four bits of the number at a time to handle all practical \textbf{DIGIT\_BIT} sizes. The weird +addition on line @38,a->used@ ensures that the newly added in bits are added to the number of digits. While it may not +seem obvious as to why the digit counter does not grow exceedingly large it is because of the shift on line @27,mp_mul_2d@ +as well as the call to mp\_clamp() on line @40,mp_clamp@. Both functions will clamp excess leading digits which keeps +the number of used digits low. + +\section{Comparisons} +\subsection{Unsigned Comparisions} +Comparing a multiple precision integer is performed with the exact same algorithm used to compare two decimal numbers. For example, +to compare $1,234$ to $1,264$ the digits are extracted by their positions. That is we compare $1 \cdot 10^3 + 2 \cdot 10^2 + 3 \cdot 10^1 + 4 \cdot 10^0$ +to $1 \cdot 10^3 + 2 \cdot 10^2 + 6 \cdot 10^1 + 4 \cdot 10^0$ by comparing single digits at a time starting with the highest magnitude +positions. If any leading digit of one integer is greater than a digit in the same position of another integer then obviously it must be greater. + +The first comparision routine that will be developed is the unsigned magnitude compare which will perform a comparison based on the digits of two +mp\_int variables alone. It will ignore the sign of the two inputs. Such a function is useful when an absolute comparison is required or if the +signs are known to agree in advance. + +To facilitate working with the results of the comparison functions three constants are required. + +\begin{figure}[here] +\begin{center} +\begin{tabular}{|r|l|} +\hline \textbf{Constant} & \textbf{Meaning} \\ +\hline \textbf{MP\_GT} & Greater Than \\ +\hline \textbf{MP\_EQ} & Equal To \\ +\hline \textbf{MP\_LT} & Less Than \\ +\hline +\end{tabular} +\end{center} +\caption{Comparison Return Codes} +\end{figure} + +\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_cmp\_mag}. \\ +\textbf{Input}. Two mp\_ints $a$ and $b$. \\ +\textbf{Output}. Unsigned comparison results ($a$ to the left of $b$). \\ +\hline \\ +1. If $a.used > b.used$ then return(\textit{MP\_GT}) \\ +2. If $a.used < b.used$ then return(\textit{MP\_LT}) \\ +3. for n from $a.used - 1$ to 0 do \\ +\hspace{+3mm}3.1 if $a_n > b_n$ then return(\textit{MP\_GT}) \\ +\hspace{+3mm}3.2 if $a_n < b_n$ then return(\textit{MP\_LT}) \\ +4. Return(\textit{MP\_EQ}) \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_cmp\_mag} +\end{figure} + +\textbf{Algorithm mp\_cmp\_mag.} +By saying ``$a$ to the left of $b$'' it is meant that the comparison is with respect to $a$, that is if $a$ is greater than $b$ it will return +\textbf{MP\_GT} and similar with respect to when $a = b$ and $a < b$. The first two steps compare the number of digits used in both $a$ and $b$. +Obviously if the digit counts differ there would be an imaginary zero digit in the smaller number where the leading digit of the larger number is. +If both have the same number of digits than the actual digits themselves must be compared starting at the leading digit. + +By step three both inputs must have the same number of digits so its safe to start from either $a.used - 1$ or $b.used - 1$ and count down to +the zero'th digit. If after all of the digits have been compared, no difference is found, the algorithm returns \textbf{MP\_EQ}. + +EXAM,bn_mp_cmp_mag.c + +The two if statements (lines @24,if@ and @28,if@) compare the number of digits in the two inputs. These two are +performed before all of the digits are compared since it is a very cheap test to perform and can potentially save +considerable time. The implementation given is also not valid without those two statements. $b.alloc$ may be +smaller than $a.used$, meaning that undefined values will be read from $b$ past the end of the array of digits. + + + +\subsection{Signed Comparisons} +Comparing with sign considerations is also fairly critical in several routines (\textit{division for example}). Based on an unsigned magnitude +comparison a trivial signed comparison algorithm can be written. + +\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_cmp}. \\ +\textbf{Input}. Two mp\_ints $a$ and $b$ \\ +\textbf{Output}. Signed Comparison Results ($a$ to the left of $b$) \\ +\hline \\ +1. if $a.sign = MP\_NEG$ and $b.sign = MP\_ZPOS$ then return(\textit{MP\_LT}) \\ +2. if $a.sign = MP\_ZPOS$ and $b.sign = MP\_NEG$ then return(\textit{MP\_GT}) \\ +3. if $a.sign = MP\_NEG$ then \\ +\hspace{+3mm}3.1 Return the unsigned comparison of $b$ and $a$ (\textit{mp\_cmp\_mag}) \\ +4 Otherwise \\ +\hspace{+3mm}4.1 Return the unsigned comparison of $a$ and $b$ \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_cmp} +\end{figure} + +\textbf{Algorithm mp\_cmp.} +The first two steps compare the signs of the two inputs. If the signs do not agree then it can return right away with the appropriate +comparison code. When the signs are equal the digits of the inputs must be compared to determine the correct result. In step +three the unsigned comparision flips the order of the arguments since they are both negative. For instance, if $-a > -b$ then +$\vert a \vert < \vert b \vert$. Step number four will compare the two when they are both positive. + +EXAM,bn_mp_cmp.c + +The two if statements (lines @22,if@ and @26,if@) perform the initial sign comparison. If the signs are not the equal then which ever +has the positive sign is larger. The inputs are compared (line @30,if@) based on magnitudes. If the signs were both +negative then the unsigned comparison is performed in the opposite direction (line @31,mp_cmp_mag@). Otherwise, the signs are assumed to +be both positive and a forward direction unsigned comparison is performed. + +\section*{Exercises} +\begin{tabular}{cl} +$\left [ 2 \right ]$ & Modify algorithm mp\_set\_int to accept as input a variable length array of bits. \\ + & \\ +$\left [ 3 \right ]$ & Give the probability that algorithm mp\_cmp\_mag will have to compare $k$ digits \\ + & of two random digits (of equal magnitude) before a difference is found. \\ + & \\ +$\left [ 1 \right ]$ & Suggest a simple method to speed up the implementation of mp\_cmp\_mag based \\ + & on the observations made in the previous problem. \\ + & +\end{tabular} + +\chapter{Basic Arithmetic} +\section{Introduction} +At this point algorithms for initialization, clearing, zeroing, copying, comparing and setting small constants have been +established. The next logical set of algorithms to develop are addition, subtraction and digit shifting algorithms. These +algorithms make use of the lower level algorithms and are the cruicial building block for the multiplication algorithms. It is very important +that these algorithms are highly optimized. On their own they are simple $O(n)$ algorithms but they can be called from higher level algorithms +which easily places them at $O(n^2)$ or even $O(n^3)$ work levels. + +MARK,SHIFTS +All of the algorithms within this chapter make use of the logical bit shift operations denoted by $<<$ and $>>$ for left and right +logical shifts respectively. A logical shift is analogous to sliding the decimal point of radix-10 representations. For example, the real +number $0.9345$ is equivalent to $93.45\%$ which is found by sliding the the decimal two places to the right (\textit{multiplying by $\beta^2 = 10^2$}). +Algebraically a binary logical shift is equivalent to a division or multiplication by a power of two. +For example, $a << k = a \cdot 2^k$ while $a >> k = \lfloor a/2^k \rfloor$. + +One significant difference between a logical shift and the way decimals are shifted is that digits below the zero'th position are removed +from the number. For example, consider $1101_2 >> 1$ using decimal notation this would produce $110.1_2$. However, with a logical shift the +result is $110_2$. + +\section{Addition and Subtraction} +In common twos complement fixed precision arithmetic negative numbers are easily represented by subtraction from the modulus. For example, with 32-bit integers +$a - b\mbox{ (mod }2^{32}\mbox{)}$ is the same as $a + (2^{32} - b) \mbox{ (mod }2^{32}\mbox{)}$ since $2^{32} \equiv 0 \mbox{ (mod }2^{32}\mbox{)}$. +As a result subtraction can be performed with a trivial series of logical operations and an addition. + +However, in multiple precision arithmetic negative numbers are not represented in the same way. Instead a sign flag is used to keep track of the +sign of the integer. As a result signed addition and subtraction are actually implemented as conditional usage of lower level addition or +subtraction algorithms with the sign fixed up appropriately. + +The lower level algorithms will add or subtract integers without regard to the sign flag. That is they will add or subtract the magnitude of +the integers respectively. + +\subsection{Low Level Addition} +An unsigned addition of multiple precision integers is performed with the same long-hand algorithm used to add decimal numbers. That is to add the +trailing digits first and propagate the resulting carry upwards. Since this is a lower level algorithm the name will have a ``s\_'' prefix. +Historically that convention stems from the MPI library where ``s\_'' stood for static functions that were hidden from the developer entirely. + +\newpage +\begin{figure}[!here] +\begin{center} +\begin{small} +\begin{tabular}{l} +\hline Algorithm \textbf{s\_mp\_add}. \\ +\textbf{Input}. Two mp\_ints $a$ and $b$ \\ +\textbf{Output}. The unsigned addition $c = \vert a \vert + \vert b \vert$. \\ +\hline \\ +1. if $a.used > b.used$ then \\ +\hspace{+3mm}1.1 $min \leftarrow b.used$ \\ +\hspace{+3mm}1.2 $max \leftarrow a.used$ \\ +\hspace{+3mm}1.3 $x \leftarrow a$ \\ +2. else \\ +\hspace{+3mm}2.1 $min \leftarrow a.used$ \\ +\hspace{+3mm}2.2 $max \leftarrow b.used$ \\ +\hspace{+3mm}2.3 $x \leftarrow b$ \\ +3. If $c.alloc < max + 1$ then grow $c$ to hold at least $max + 1$ digits (\textit{mp\_grow}) \\ +4. $oldused \leftarrow c.used$ \\ +5. $c.used \leftarrow max + 1$ \\ +6. $u \leftarrow 0$ \\ +7. for $n$ from $0$ to $min - 1$ do \\ +\hspace{+3mm}7.1 $c_n \leftarrow a_n + b_n + u$ \\ +\hspace{+3mm}7.2 $u \leftarrow c_n >> lg(\beta)$ \\ +\hspace{+3mm}7.3 $c_n \leftarrow c_n \mbox{ (mod }\beta\mbox{)}$ \\ +8. if $min \ne max$ then do \\ +\hspace{+3mm}8.1 for $n$ from $min$ to $max - 1$ do \\ +\hspace{+6mm}8.1.1 $c_n \leftarrow x_n + u$ \\ +\hspace{+6mm}8.1.2 $u \leftarrow c_n >> lg(\beta)$ \\ +\hspace{+6mm}8.1.3 $c_n \leftarrow c_n \mbox{ (mod }\beta\mbox{)}$ \\ +9. $c_{max} \leftarrow u$ \\ +10. if $olduse > max$ then \\ +\hspace{+3mm}10.1 for $n$ from $max + 1$ to $oldused - 1$ do \\ +\hspace{+6mm}10.1.1 $c_n \leftarrow 0$ \\ +11. Clamp excess digits in $c$. (\textit{mp\_clamp}) \\ +12. Return(\textit{MP\_OKAY}) \\ +\hline +\end{tabular} +\end{small} +\end{center} +\caption{Algorithm s\_mp\_add} +\end{figure} + +\textbf{Algorithm s\_mp\_add.} +This algorithm is loosely based on algorithm 14.7 of HAC \cite[pp. 594]{HAC} but has been extended to allow the inputs to have different magnitudes. +Coincidentally the description of algorithm A in Knuth \cite[pp. 266]{TAOCPV2} shares the same deficiency as the algorithm from \cite{HAC}. Even the +MIX pseudo machine code presented by Knuth \cite[pp. 266-267]{TAOCPV2} is incapable of handling inputs which are of different magnitudes. + +The first thing that has to be accomplished is to sort out which of the two inputs is the largest. The addition logic +will simply add all of the smallest input to the largest input and store that first part of the result in the +destination. Then it will apply a simpler addition loop to excess digits of the larger input. + +The first two steps will handle sorting the inputs such that $min$ and $max$ hold the digit counts of the two +inputs. The variable $x$ will be an mp\_int alias for the largest input or the second input $b$ if they have the +same number of digits. After the inputs are sorted the destination $c$ is grown as required to accomodate the sum +of the two inputs. The original \textbf{used} count of $c$ is copied and set to the new used count. + +At this point the first addition loop will go through as many digit positions that both inputs have. The carry +variable $\mu$ is set to zero outside the loop. Inside the loop an ``addition'' step requires three statements to produce +one digit of the summand. First +two digits from $a$ and $b$ are added together along with the carry $\mu$. The carry of this step is extracted and stored +in $\mu$ and finally the digit of the result $c_n$ is truncated within the range $0 \le c_n < \beta$. + +Now all of the digit positions that both inputs have in common have been exhausted. If $min \ne max$ then $x$ is an alias +for one of the inputs that has more digits. A simplified addition loop is then used to essentially copy the remaining digits +and the carry to the destination. + +The final carry is stored in $c_{max}$ and digits above $max$ upto $oldused$ are zeroed which completes the addition. + + +EXAM,bn_s_mp_add.c + +We first sort (lines @27,if@ to @35,}@) the inputs based on magnitude and determine the $min$ and $max$ variables. +Note that $x$ is a pointer to an mp\_int assigned to the largest input, in effect it is a local alias. Next we +grow the destination (@37,init@ to @42,}@) ensure that it can accomodate the result of the addition. + +Similar to the implementation of mp\_copy this function uses the braced code and local aliases coding style. The three aliases that are on +lines @56,tmpa@, @59,tmpb@ and @62,tmpc@ represent the two inputs and destination variables respectively. These aliases are used to ensure the +compiler does not have to dereference $a$, $b$ or $c$ (respectively) to access the digits of the respective mp\_int. + +The initial carry $u$ will be cleared (line @65,u = 0@), note that $u$ is of type mp\_digit which ensures type +compatibility within the implementation. The initial addition (line @66,for@ to @75,}@) adds digits from +both inputs until the smallest input runs out of digits. Similarly the conditional addition loop +(line @81,for@ to @90,}@) adds the remaining digits from the larger of the two inputs. The addition is finished +with the final carry being stored in $tmpc$ (line @94,tmpc++@). Note the ``++'' operator within the same expression. +After line @94,tmpc++@, $tmpc$ will point to the $c.used$'th digit of the mp\_int $c$. This is useful +for the next loop (line @97,for@ to @99,}@) which set any old upper digits to zero. + +\subsection{Low Level Subtraction} +The low level unsigned subtraction algorithm is very similar to the low level unsigned addition algorithm. The principle difference is that the +unsigned subtraction algorithm requires the result to be positive. That is when computing $a - b$ the condition $\vert a \vert \ge \vert b\vert$ must +be met for this algorithm to function properly. Keep in mind this low level algorithm is not meant to be used in higher level algorithms directly. +This algorithm as will be shown can be used to create functional signed addition and subtraction algorithms. + +MARK,GAMMA + +For this algorithm a new variable is required to make the description simpler. Recall from section 1.3.1 that a mp\_digit must be able to represent +the range $0 \le x < 2\beta$ for the algorithms to work correctly. However, it is allowable that a mp\_digit represent a larger range of values. For +this algorithm we will assume that the variable $\gamma$ represents the number of bits available in a +mp\_digit (\textit{this implies $2^{\gamma} > \beta$}). + +For example, the default for LibTomMath is to use a ``unsigned long'' for the mp\_digit ``type'' while $\beta = 2^{28}$. In ISO C an ``unsigned long'' +data type must be able to represent $0 \le x < 2^{32}$ meaning that in this case $\gamma \ge 32$. + +\newpage\begin{figure}[!here] +\begin{center} +\begin{small} +\begin{tabular}{l} +\hline Algorithm \textbf{s\_mp\_sub}. \\ +\textbf{Input}. Two mp\_ints $a$ and $b$ ($\vert a \vert \ge \vert b \vert$) \\ +\textbf{Output}. The unsigned subtraction $c = \vert a \vert - \vert b \vert$. \\ +\hline \\ +1. $min \leftarrow b.used$ \\ +2. $max \leftarrow a.used$ \\ +3. If $c.alloc < max$ then grow $c$ to hold at least $max$ digits. (\textit{mp\_grow}) \\ +4. $oldused \leftarrow c.used$ \\ +5. $c.used \leftarrow max$ \\ +6. $u \leftarrow 0$ \\ +7. for $n$ from $0$ to $min - 1$ do \\ +\hspace{3mm}7.1 $c_n \leftarrow a_n - b_n - u$ \\ +\hspace{3mm}7.2 $u \leftarrow c_n >> (\gamma - 1)$ \\ +\hspace{3mm}7.3 $c_n \leftarrow c_n \mbox{ (mod }\beta\mbox{)}$ \\ +8. if $min < max$ then do \\ +\hspace{3mm}8.1 for $n$ from $min$ to $max - 1$ do \\ +\hspace{6mm}8.1.1 $c_n \leftarrow a_n - u$ \\ +\hspace{6mm}8.1.2 $u \leftarrow c_n >> (\gamma - 1)$ \\ +\hspace{6mm}8.1.3 $c_n \leftarrow c_n \mbox{ (mod }\beta\mbox{)}$ \\ +9. if $oldused > max$ then do \\ +\hspace{3mm}9.1 for $n$ from $max$ to $oldused - 1$ do \\ +\hspace{6mm}9.1.1 $c_n \leftarrow 0$ \\ +10. Clamp excess digits of $c$. (\textit{mp\_clamp}). \\ +11. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{small} +\end{center} +\caption{Algorithm s\_mp\_sub} +\end{figure} + +\textbf{Algorithm s\_mp\_sub.} +This algorithm performs the unsigned subtraction of two mp\_int variables under the restriction that the result must be positive. That is when +passing variables $a$ and $b$ the condition that $\vert a \vert \ge \vert b \vert$ must be met for the algorithm to function correctly. This +algorithm is loosely based on algorithm 14.9 \cite[pp. 595]{HAC} and is similar to algorithm S in \cite[pp. 267]{TAOCPV2} as well. As was the case +of the algorithm s\_mp\_add both other references lack discussion concerning various practical details such as when the inputs differ in magnitude. + +The initial sorting of the inputs is trivial in this algorithm since $a$ is guaranteed to have at least the same magnitude of $b$. Steps 1 and 2 +set the $min$ and $max$ variables. Unlike the addition routine there is guaranteed to be no carry which means that the final result can be at +most $max$ digits in length as opposed to $max + 1$. Similar to the addition algorithm the \textbf{used} count of $c$ is copied locally and +set to the maximal count for the operation. + +The subtraction loop that begins on step seven is essentially the same as the addition loop of algorithm s\_mp\_add except single precision +subtraction is used instead. Note the use of the $\gamma$ variable to extract the carry (\textit{also known as the borrow}) within the subtraction +loops. Under the assumption that two's complement single precision arithmetic is used this will successfully extract the desired carry. + +For example, consider subtracting $0101_2$ from $0100_2$ where $\gamma = 4$ and $\beta = 2$. The least significant bit will force a carry upwards to +the third bit which will be set to zero after the borrow. After the very first bit has been subtracted $4 - 1 \equiv 0011_2$ will remain, When the +third bit of $0101_2$ is subtracted from the result it will cause another carry. In this case though the carry will be forced to propagate all the +way to the most significant bit. + +Recall that $\beta < 2^{\gamma}$. This means that if a carry does occur just before the $lg(\beta)$'th bit it will propagate all the way to the most +significant bit. Thus, the high order bits of the mp\_digit that are not part of the actual digit will either be all zero, or all one. All that +is needed is a single zero or one bit for the carry. Therefore a single logical shift right by $\gamma - 1$ positions is sufficient to extract the +carry. This method of carry extraction may seem awkward but the reason for it becomes apparent when the implementation is discussed. + +If $b$ has a smaller magnitude than $a$ then step 9 will force the carry and copy operation to propagate through the larger input $a$ into $c$. Step +10 will ensure that any leading digits of $c$ above the $max$'th position are zeroed. + +EXAM,bn_s_mp_sub.c + +Like low level addition we ``sort'' the inputs. Except in this case the sorting is hardcoded +(lines @24,min@ and @25,max@). In reality the $min$ and $max$ variables are only aliases and are only +used to make the source code easier to read. Again the pointer alias optimization is used +within this algorithm. The aliases $tmpa$, $tmpb$ and $tmpc$ are initialized +(lines @42,tmpa@, @43,tmpb@ and @44,tmpc@) for $a$, $b$ and $c$ respectively. + +The first subtraction loop (lines @47,u = 0@ through @61,}@) subtract digits from both inputs until the smaller of +the two inputs has been exhausted. As remarked earlier there is an implementation reason for using the ``awkward'' +method of extracting the carry (line @57, >>@). The traditional method for extracting the carry would be to shift +by $lg(\beta)$ positions and logically AND the least significant bit. The AND operation is required because all of +the bits above the $\lg(\beta)$'th bit will be set to one after a carry occurs from subtraction. This carry +extraction requires two relatively cheap operations to extract the carry. The other method is to simply shift the +most significant bit to the least significant bit thus extracting the carry with a single cheap operation. This +optimization only works on twos compliment machines which is a safe assumption to make. + +If $a$ has a larger magnitude than $b$ an additional loop (lines @64,for@ through @73,}@) is required to propagate +the carry through $a$ and copy the result to $c$. + +\subsection{High Level Addition} +Now that both lower level addition and subtraction algorithms have been established an effective high level signed addition algorithm can be +established. This high level addition algorithm will be what other algorithms and developers will use to perform addition of mp\_int data +types. + +Recall from section 5.2 that an mp\_int represents an integer with an unsigned mantissa (\textit{the array of digits}) and a \textbf{sign} +flag. A high level addition is actually performed as a series of eight separate cases which can be optimized down to three unique cases. + +\begin{figure}[!here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_add}. \\ +\textbf{Input}. Two mp\_ints $a$ and $b$ \\ +\textbf{Output}. The signed addition $c = a + b$. \\ +\hline \\ +1. if $a.sign = b.sign$ then do \\ +\hspace{3mm}1.1 $c.sign \leftarrow a.sign$ \\ +\hspace{3mm}1.2 $c \leftarrow \vert a \vert + \vert b \vert$ (\textit{s\_mp\_add})\\ +2. else do \\ +\hspace{3mm}2.1 if $\vert a \vert < \vert b \vert$ then do (\textit{mp\_cmp\_mag}) \\ +\hspace{6mm}2.1.1 $c.sign \leftarrow b.sign$ \\ +\hspace{6mm}2.1.2 $c \leftarrow \vert b \vert - \vert a \vert$ (\textit{s\_mp\_sub}) \\ +\hspace{3mm}2.2 else do \\ +\hspace{6mm}2.2.1 $c.sign \leftarrow a.sign$ \\ +\hspace{6mm}2.2.2 $c \leftarrow \vert a \vert - \vert b \vert$ \\ +3. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_add} +\end{figure} + +\textbf{Algorithm mp\_add.} +This algorithm performs the signed addition of two mp\_int variables. There is no reference algorithm to draw upon from +either \cite{TAOCPV2} or \cite{HAC} since they both only provide unsigned operations. The algorithm is fairly +straightforward but restricted since subtraction can only produce positive results. + +\begin{figure}[here] +\begin{small} +\begin{center} +\begin{tabular}{|c|c|c|c|c|} +\hline \textbf{Sign of $a$} & \textbf{Sign of $b$} & \textbf{$\vert a \vert > \vert b \vert $} & \textbf{Unsigned Operation} & \textbf{Result Sign Flag} \\ +\hline $+$ & $+$ & Yes & $c = a + b$ & $a.sign$ \\ +\hline $+$ & $+$ & No & $c = a + b$ & $a.sign$ \\ +\hline $-$ & $-$ & Yes & $c = a + b$ & $a.sign$ \\ +\hline $-$ & $-$ & No & $c = a + b$ & $a.sign$ \\ +\hline &&&&\\ + +\hline $+$ & $-$ & No & $c = b - a$ & $b.sign$ \\ +\hline $-$ & $+$ & No & $c = b - a$ & $b.sign$ \\ + +\hline &&&&\\ + +\hline $+$ & $-$ & Yes & $c = a - b$ & $a.sign$ \\ +\hline $-$ & $+$ & Yes & $c = a - b$ & $a.sign$ \\ + +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Addition Guide Chart} +\label{fig:AddChart} +\end{figure} + +Figure~\ref{fig:AddChart} lists all of the eight possible input combinations and is sorted to show that only three +specific cases need to be handled. The return code of the unsigned operations at step 1.2, 2.1.2 and 2.2.2 are +forwarded to step three to check for errors. This simplifies the description of the algorithm considerably and best +follows how the implementation actually was achieved. + +Also note how the \textbf{sign} is set before the unsigned addition or subtraction is performed. Recall from the descriptions of algorithms +s\_mp\_add and s\_mp\_sub that the mp\_clamp function is used at the end to trim excess digits. The mp\_clamp algorithm will set the \textbf{sign} +to \textbf{MP\_ZPOS} when the \textbf{used} digit count reaches zero. + +For example, consider performing $-a + a$ with algorithm mp\_add. By the description of the algorithm the sign is set to \textbf{MP\_NEG} which would +produce a result of $-0$. However, since the sign is set first then the unsigned addition is performed the subsequent usage of algorithm mp\_clamp +within algorithm s\_mp\_add will force $-0$ to become $0$. + +EXAM,bn_mp_add.c + +The source code follows the algorithm fairly closely. The most notable new source code addition is the usage of the $res$ integer variable which +is used to pass result of the unsigned operations forward. Unlike in the algorithm, the variable $res$ is merely returned as is without +explicitly checking it and returning the constant \textbf{MP\_OKAY}. The observation is this algorithm will succeed or fail only if the lower +level functions do so. Returning their return code is sufficient. + +\subsection{High Level Subtraction} +The high level signed subtraction algorithm is essentially the same as the high level signed addition algorithm. + +\newpage\begin{figure}[!here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_sub}. \\ +\textbf{Input}. Two mp\_ints $a$ and $b$ \\ +\textbf{Output}. The signed subtraction $c = a - b$. \\ +\hline \\ +1. if $a.sign \ne b.sign$ then do \\ +\hspace{3mm}1.1 $c.sign \leftarrow a.sign$ \\ +\hspace{3mm}1.2 $c \leftarrow \vert a \vert + \vert b \vert$ (\textit{s\_mp\_add}) \\ +2. else do \\ +\hspace{3mm}2.1 if $\vert a \vert \ge \vert b \vert$ then do (\textit{mp\_cmp\_mag}) \\ +\hspace{6mm}2.1.1 $c.sign \leftarrow a.sign$ \\ +\hspace{6mm}2.1.2 $c \leftarrow \vert a \vert - \vert b \vert$ (\textit{s\_mp\_sub}) \\ +\hspace{3mm}2.2 else do \\ +\hspace{6mm}2.2.1 $c.sign \leftarrow \left \lbrace \begin{array}{ll} + MP\_ZPOS & \mbox{if }a.sign = MP\_NEG \\ + MP\_NEG & \mbox{otherwise} \\ + \end{array} \right .$ \\ +\hspace{6mm}2.2.2 $c \leftarrow \vert b \vert - \vert a \vert$ \\ +3. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_sub} +\end{figure} + +\textbf{Algorithm mp\_sub.} +This algorithm performs the signed subtraction of two inputs. Similar to algorithm mp\_add there is no reference in either \cite{TAOCPV2} or +\cite{HAC}. Also this algorithm is restricted by algorithm s\_mp\_sub. Chart \ref{fig:SubChart} lists the eight possible inputs and +the operations required. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{|c|c|c|c|c|} +\hline \textbf{Sign of $a$} & \textbf{Sign of $b$} & \textbf{$\vert a \vert \ge \vert b \vert $} & \textbf{Unsigned Operation} & \textbf{Result Sign Flag} \\ +\hline $+$ & $-$ & Yes & $c = a + b$ & $a.sign$ \\ +\hline $+$ & $-$ & No & $c = a + b$ & $a.sign$ \\ +\hline $-$ & $+$ & Yes & $c = a + b$ & $a.sign$ \\ +\hline $-$ & $+$ & No & $c = a + b$ & $a.sign$ \\ +\hline &&&& \\ +\hline $+$ & $+$ & Yes & $c = a - b$ & $a.sign$ \\ +\hline $-$ & $-$ & Yes & $c = a - b$ & $a.sign$ \\ +\hline &&&& \\ +\hline $+$ & $+$ & No & $c = b - a$ & $\mbox{opposite of }a.sign$ \\ +\hline $-$ & $-$ & No & $c = b - a$ & $\mbox{opposite of }a.sign$ \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Subtraction Guide Chart} +\label{fig:SubChart} +\end{figure} + +Similar to the case of algorithm mp\_add the \textbf{sign} is set first before the unsigned addition or subtraction. That is to prevent the +algorithm from producing $-a - -a = -0$ as a result. + +EXAM,bn_mp_sub.c + +Much like the implementation of algorithm mp\_add the variable $res$ is used to catch the return code of the unsigned addition or subtraction operations +and forward it to the end of the function. On line @38, != MP_LT@ the ``not equal to'' \textbf{MP\_LT} expression is used to emulate a +``greater than or equal to'' comparison. + +\section{Bit and Digit Shifting} +MARK,POLY +It is quite common to think of a multiple precision integer as a polynomial in $x$, that is $y = f(\beta)$ where $f(x) = \sum_{i=0}^{n-1} a_i x^i$. +This notation arises within discussion of Montgomery and Diminished Radix Reduction as well as Karatsuba multiplication and squaring. + +In order to facilitate operations on polynomials in $x$ as above a series of simple ``digit'' algorithms have to be established. That is to shift +the digits left or right as well to shift individual bits of the digits left and right. It is important to note that not all ``shift'' operations +are on radix-$\beta$ digits. + +\subsection{Multiplication by Two} + +In a binary system where the radix is a power of two multiplication by two not only arises often in other algorithms it is a fairly efficient +operation to perform. A single precision logical shift left is sufficient to multiply a single digit by two. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_mul\_2}. \\ +\textbf{Input}. One mp\_int $a$ \\ +\textbf{Output}. $b = 2a$. \\ +\hline \\ +1. If $b.alloc < a.used + 1$ then grow $b$ to hold $a.used + 1$ digits. (\textit{mp\_grow}) \\ +2. $oldused \leftarrow b.used$ \\ +3. $b.used \leftarrow a.used$ \\ +4. $r \leftarrow 0$ \\ +5. for $n$ from 0 to $a.used - 1$ do \\ +\hspace{3mm}5.1 $rr \leftarrow a_n >> (lg(\beta) - 1)$ \\ +\hspace{3mm}5.2 $b_n \leftarrow (a_n << 1) + r \mbox{ (mod }\beta\mbox{)}$ \\ +\hspace{3mm}5.3 $r \leftarrow rr$ \\ +6. If $r \ne 0$ then do \\ +\hspace{3mm}6.1 $b_{n + 1} \leftarrow r$ \\ +\hspace{3mm}6.2 $b.used \leftarrow b.used + 1$ \\ +7. If $b.used < oldused - 1$ then do \\ +\hspace{3mm}7.1 for $n$ from $b.used$ to $oldused - 1$ do \\ +\hspace{6mm}7.1.1 $b_n \leftarrow 0$ \\ +8. $b.sign \leftarrow a.sign$ \\ +9. Return(\textit{MP\_OKAY}).\\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_mul\_2} +\end{figure} + +\textbf{Algorithm mp\_mul\_2.} +This algorithm will quickly multiply a mp\_int by two provided $\beta$ is a power of two. Neither \cite{TAOCPV2} nor \cite{HAC} describe such +an algorithm despite the fact it arises often in other algorithms. The algorithm is setup much like the lower level algorithm s\_mp\_add since +it is for all intents and purposes equivalent to the operation $b = \vert a \vert + \vert a \vert$. + +Step 1 and 2 grow the input as required to accomodate the maximum number of \textbf{used} digits in the result. The initial \textbf{used} count +is set to $a.used$ at step 4. Only if there is a final carry will the \textbf{used} count require adjustment. + +Step 6 is an optimization implementation of the addition loop for this specific case. That is since the two values being added together +are the same there is no need to perform two reads from the digits of $a$. Step 6.1 performs a single precision shift on the current digit $a_n$ to +obtain what will be the carry for the next iteration. Step 6.2 calculates the $n$'th digit of the result as single precision shift of $a_n$ plus +the previous carry. Recall from ~SHIFTS~ that $a_n << 1$ is equivalent to $a_n \cdot 2$. An iteration of the addition loop is finished with +forwarding the carry to the next iteration. + +Step 7 takes care of any final carry by setting the $a.used$'th digit of the result to the carry and augmenting the \textbf{used} count of $b$. +Step 8 clears any leading digits of $b$ in case it originally had a larger magnitude than $a$. + +EXAM,bn_mp_mul_2.c + +This implementation is essentially an optimized implementation of s\_mp\_add for the case of doubling an input. The only noteworthy difference +is the use of the logical shift operator on line @52,<<@ to perform a single precision doubling. + +\subsection{Division by Two} +A division by two can just as easily be accomplished with a logical shift right as multiplication by two can be with a logical shift left. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_div\_2}. \\ +\textbf{Input}. One mp\_int $a$ \\ +\textbf{Output}. $b = a/2$. \\ +\hline \\ +1. If $b.alloc < a.used$ then grow $b$ to hold $a.used$ digits. (\textit{mp\_grow}) \\ +2. If the reallocation failed return(\textit{MP\_MEM}). \\ +3. $oldused \leftarrow b.used$ \\ +4. $b.used \leftarrow a.used$ \\ +5. $r \leftarrow 0$ \\ +6. for $n$ from $b.used - 1$ to $0$ do \\ +\hspace{3mm}6.1 $rr \leftarrow a_n \mbox{ (mod }2\mbox{)}$\\ +\hspace{3mm}6.2 $b_n \leftarrow (a_n >> 1) + (r << (lg(\beta) - 1)) \mbox{ (mod }\beta\mbox{)}$ \\ +\hspace{3mm}6.3 $r \leftarrow rr$ \\ +7. If $b.used < oldused - 1$ then do \\ +\hspace{3mm}7.1 for $n$ from $b.used$ to $oldused - 1$ do \\ +\hspace{6mm}7.1.1 $b_n \leftarrow 0$ \\ +8. $b.sign \leftarrow a.sign$ \\ +9. Clamp excess digits of $b$. (\textit{mp\_clamp}) \\ +10. Return(\textit{MP\_OKAY}).\\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_div\_2} +\end{figure} + +\textbf{Algorithm mp\_div\_2.} +This algorithm will divide an mp\_int by two using logical shifts to the right. Like mp\_mul\_2 it uses a modified low level addition +core as the basis of the algorithm. Unlike mp\_mul\_2 the shift operations work from the leading digit to the trailing digit. The algorithm +could be written to work from the trailing digit to the leading digit however, it would have to stop one short of $a.used - 1$ digits to prevent +reading past the end of the array of digits. + +Essentially the loop at step 6 is similar to that of mp\_mul\_2 except the logical shifts go in the opposite direction and the carry is at the +least significant bit not the most significant bit. + +EXAM,bn_mp_div_2.c + +\section{Polynomial Basis Operations} +Recall from ~POLY~ that any integer can be represented as a polynomial in $x$ as $y = f(\beta)$. Such a representation is also known as +the polynomial basis \cite[pp. 48]{ROSE}. Given such a notation a multiplication or division by $x$ amounts to shifting whole digits a single +place. The need for such operations arises in several other higher level algorithms such as Barrett and Montgomery reduction, integer +division and Karatsuba multiplication. + +Converting from an array of digits to polynomial basis is very simple. Consider the integer $y \equiv (a_2, a_1, a_0)_{\beta}$ and recall that +$y = \sum_{i=0}^{2} a_i \beta^i$. Simply replace $\beta$ with $x$ and the expression is in polynomial basis. For example, $f(x) = 8x + 9$ is the +polynomial basis representation for $89$ using radix ten. That is, $f(10) = 8(10) + 9 = 89$. + +\subsection{Multiplication by $x$} + +Given a polynomial in $x$ such as $f(x) = a_n x^n + a_{n-1} x^{n-1} + ... + a_0$ multiplying by $x$ amounts to shifting the coefficients up one +degree. In this case $f(x) \cdot x = a_n x^{n+1} + a_{n-1} x^n + ... + a_0 x$. From a scalar basis point of view multiplying by $x$ is equivalent to +multiplying by the integer $\beta$. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_lshd}. \\ +\textbf{Input}. One mp\_int $a$ and an integer $b$ \\ +\textbf{Output}. $a \leftarrow a \cdot \beta^b$ (equivalent to multiplication by $x^b$). \\ +\hline \\ +1. If $b \le 0$ then return(\textit{MP\_OKAY}). \\ +2. If $a.alloc < a.used + b$ then grow $a$ to at least $a.used + b$ digits. (\textit{mp\_grow}). \\ +3. If the reallocation failed return(\textit{MP\_MEM}). \\ +4. $a.used \leftarrow a.used + b$ \\ +5. $i \leftarrow a.used - 1$ \\ +6. $j \leftarrow a.used - 1 - b$ \\ +7. for $n$ from $a.used - 1$ to $b$ do \\ +\hspace{3mm}7.1 $a_{i} \leftarrow a_{j}$ \\ +\hspace{3mm}7.2 $i \leftarrow i - 1$ \\ +\hspace{3mm}7.3 $j \leftarrow j - 1$ \\ +8. for $n$ from 0 to $b - 1$ do \\ +\hspace{3mm}8.1 $a_n \leftarrow 0$ \\ +9. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_lshd} +\end{figure} + +\textbf{Algorithm mp\_lshd.} +This algorithm multiplies an mp\_int by the $b$'th power of $x$. This is equivalent to multiplying by $\beta^b$. The algorithm differs +from the other algorithms presented so far as it performs the operation in place instead storing the result in a separate location. The +motivation behind this change is due to the way this function is typically used. Algorithms such as mp\_add store the result in an optionally +different third mp\_int because the original inputs are often still required. Algorithm mp\_lshd (\textit{and similarly algorithm mp\_rshd}) is +typically used on values where the original value is no longer required. The algorithm will return success immediately if +$b \le 0$ since the rest of algorithm is only valid when $b > 0$. + +First the destination $a$ is grown as required to accomodate the result. The counters $i$ and $j$ are used to form a \textit{sliding window} over +the digits of $a$ of length $b$. The head of the sliding window is at $i$ (\textit{the leading digit}) and the tail at $j$ (\textit{the trailing digit}). +The loop on step 7 copies the digit from the tail to the head. In each iteration the window is moved down one digit. The last loop on +step 8 sets the lower $b$ digits to zero. + +\newpage +FIGU,sliding_window,Sliding Window Movement + +EXAM,bn_mp_lshd.c + +The if statement (line @24,if@) ensures that the $b$ variable is greater than zero since we do not interpret negative +shift counts properly. The \textbf{used} count is incremented by $b$ before the copy loop begins. This elminates +the need for an additional variable in the for loop. The variable $top$ (line @42,top@) is an alias +for the leading digit while $bottom$ (line @45,bottom@) is an alias for the trailing edge. The aliases form a +window of exactly $b$ digits over the input. + +\subsection{Division by $x$} + +Division by powers of $x$ is easily achieved by shifting the digits right and removing any that will end up to the right of the zero'th digit. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_rshd}. \\ +\textbf{Input}. One mp\_int $a$ and an integer $b$ \\ +\textbf{Output}. $a \leftarrow a / \beta^b$ (Divide by $x^b$). \\ +\hline \\ +1. If $b \le 0$ then return. \\ +2. If $a.used \le b$ then do \\ +\hspace{3mm}2.1 Zero $a$. (\textit{mp\_zero}). \\ +\hspace{3mm}2.2 Return. \\ +3. $i \leftarrow 0$ \\ +4. $j \leftarrow b$ \\ +5. for $n$ from 0 to $a.used - b - 1$ do \\ +\hspace{3mm}5.1 $a_i \leftarrow a_j$ \\ +\hspace{3mm}5.2 $i \leftarrow i + 1$ \\ +\hspace{3mm}5.3 $j \leftarrow j + 1$ \\ +6. for $n$ from $a.used - b$ to $a.used - 1$ do \\ +\hspace{3mm}6.1 $a_n \leftarrow 0$ \\ +7. $a.used \leftarrow a.used - b$ \\ +8. Return. \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_rshd} +\end{figure} + +\textbf{Algorithm mp\_rshd.} +This algorithm divides the input in place by the $b$'th power of $x$. It is analogous to dividing by a $\beta^b$ but much quicker since +it does not require single precision division. This algorithm does not actually return an error code as it cannot fail. + +If the input $b$ is less than one the algorithm quickly returns without performing any work. If the \textbf{used} count is less than or equal +to the shift count $b$ then it will simply zero the input and return. + +After the trivial cases of inputs have been handled the sliding window is setup. Much like the case of algorithm mp\_lshd a sliding window that +is $b$ digits wide is used to copy the digits. Unlike mp\_lshd the window slides in the opposite direction from the trailing to the leading digit. +Also the digits are copied from the leading to the trailing edge. + +Once the window copy is complete the upper digits must be zeroed and the \textbf{used} count decremented. + +EXAM,bn_mp_rshd.c + +The only noteworthy element of this routine is the lack of a return type since it cannot fail. Like mp\_lshd() we +form a sliding window except we copy in the other direction. After the window (line @59,for (;@) we then zero +the upper digits of the input to make sure the result is correct. + +\section{Powers of Two} + +Now that algorithms for moving single bits as well as whole digits exist algorithms for moving the ``in between'' distances are required. For +example, to quickly multiply by $2^k$ for any $k$ without using a full multiplier algorithm would prove useful. Instead of performing single +shifts $k$ times to achieve a multiplication by $2^{\pm k}$ a mixture of whole digit shifting and partial digit shifting is employed. + +\subsection{Multiplication by Power of Two} + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_mul\_2d}. \\ +\textbf{Input}. One mp\_int $a$ and an integer $b$ \\ +\textbf{Output}. $c \leftarrow a \cdot 2^b$. \\ +\hline \\ +1. $c \leftarrow a$. (\textit{mp\_copy}) \\ +2. If $c.alloc < c.used + \lfloor b / lg(\beta) \rfloor + 2$ then grow $c$ accordingly. \\ +3. If the reallocation failed return(\textit{MP\_MEM}). \\ +4. If $b \ge lg(\beta)$ then \\ +\hspace{3mm}4.1 $c \leftarrow c \cdot \beta^{\lfloor b / lg(\beta) \rfloor}$ (\textit{mp\_lshd}). \\ +\hspace{3mm}4.2 If step 4.1 failed return(\textit{MP\_MEM}). \\ +5. $d \leftarrow b \mbox{ (mod }lg(\beta)\mbox{)}$ \\ +6. If $d \ne 0$ then do \\ +\hspace{3mm}6.1 $mask \leftarrow 2^d$ \\ +\hspace{3mm}6.2 $r \leftarrow 0$ \\ +\hspace{3mm}6.3 for $n$ from $0$ to $c.used - 1$ do \\ +\hspace{6mm}6.3.1 $rr \leftarrow c_n >> (lg(\beta) - d) \mbox{ (mod }mask\mbox{)}$ \\ +\hspace{6mm}6.3.2 $c_n \leftarrow (c_n << d) + r \mbox{ (mod }\beta\mbox{)}$ \\ +\hspace{6mm}6.3.3 $r \leftarrow rr$ \\ +\hspace{3mm}6.4 If $r > 0$ then do \\ +\hspace{6mm}6.4.1 $c_{c.used} \leftarrow r$ \\ +\hspace{6mm}6.4.2 $c.used \leftarrow c.used + 1$ \\ +7. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_mul\_2d} +\end{figure} + +\textbf{Algorithm mp\_mul\_2d.} +This algorithm multiplies $a$ by $2^b$ and stores the result in $c$. The algorithm uses algorithm mp\_lshd and a derivative of algorithm mp\_mul\_2 to +quickly compute the product. + +First the algorithm will multiply $a$ by $x^{\lfloor b / lg(\beta) \rfloor}$ which will ensure that the remainder multiplicand is less than +$\beta$. For example, if $b = 37$ and $\beta = 2^{28}$ then this step will multiply by $x$ leaving a multiplication by $2^{37 - 28} = 2^{9}$ +left. + +After the digits have been shifted appropriately at most $lg(\beta) - 1$ shifts are left to perform. Step 5 calculates the number of remaining shifts +required. If it is non-zero a modified shift loop is used to calculate the remaining product. +Essentially the loop is a generic version of algorith mp\_mul2 designed to handle any shift count in the range $1 \le x < lg(\beta)$. The $mask$ +variable is used to extract the upper $d$ bits to form the carry for the next iteration. + +This algorithm is loosely measured as a $O(2n)$ algorithm which means that if the input is $n$-digits that it takes $2n$ ``time'' to +complete. It is possible to optimize this algorithm down to a $O(n)$ algorithm at a cost of making the algorithm slightly harder to follow. + +EXAM,bn_mp_mul_2d.c + +The shifting is performed in--place which means the first step (line @24,a != c@) is to copy the input to the +destination. We avoid calling mp\_copy() by making sure the mp\_ints are different. The destination then +has to be grown (line @31,grow@) to accomodate the result. + +If the shift count $b$ is larger than $lg(\beta)$ then a call to mp\_lshd() is used to handle all of the multiples +of $lg(\beta)$. Leaving only a remaining shift of $lg(\beta) - 1$ or fewer bits left. Inside the actual shift +loop (lines @45,if@ to @76,}@) we make use of pre--computed values $shift$ and $mask$. These are used to +extract the carry bit(s) to pass into the next iteration of the loop. The $r$ and $rr$ variables form a +chain between consecutive iterations to propagate the carry. + +\subsection{Division by Power of Two} + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_div\_2d}. \\ +\textbf{Input}. One mp\_int $a$ and an integer $b$ \\ +\textbf{Output}. $c \leftarrow \lfloor a / 2^b \rfloor, d \leftarrow a \mbox{ (mod }2^b\mbox{)}$. \\ +\hline \\ +1. If $b \le 0$ then do \\ +\hspace{3mm}1.1 $c \leftarrow a$ (\textit{mp\_copy}) \\ +\hspace{3mm}1.2 $d \leftarrow 0$ (\textit{mp\_zero}) \\ +\hspace{3mm}1.3 Return(\textit{MP\_OKAY}). \\ +2. $c \leftarrow a$ \\ +3. $d \leftarrow a \mbox{ (mod }2^b\mbox{)}$ (\textit{mp\_mod\_2d}) \\ +4. If $b \ge lg(\beta)$ then do \\ +\hspace{3mm}4.1 $c \leftarrow \lfloor c/\beta^{\lfloor b/lg(\beta) \rfloor} \rfloor$ (\textit{mp\_rshd}). \\ +5. $k \leftarrow b \mbox{ (mod }lg(\beta)\mbox{)}$ \\ +6. If $k \ne 0$ then do \\ +\hspace{3mm}6.1 $mask \leftarrow 2^k$ \\ +\hspace{3mm}6.2 $r \leftarrow 0$ \\ +\hspace{3mm}6.3 for $n$ from $c.used - 1$ to $0$ do \\ +\hspace{6mm}6.3.1 $rr \leftarrow c_n \mbox{ (mod }mask\mbox{)}$ \\ +\hspace{6mm}6.3.2 $c_n \leftarrow (c_n >> k) + (r << (lg(\beta) - k))$ \\ +\hspace{6mm}6.3.3 $r \leftarrow rr$ \\ +7. Clamp excess digits of $c$. (\textit{mp\_clamp}) \\ +8. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_div\_2d} +\end{figure} + +\textbf{Algorithm mp\_div\_2d.} +This algorithm will divide an input $a$ by $2^b$ and produce the quotient and remainder. The algorithm is designed much like algorithm +mp\_mul\_2d by first using whole digit shifts then single precision shifts. This algorithm will also produce the remainder of the division +by using algorithm mp\_mod\_2d. + +EXAM,bn_mp_div_2d.c + +The implementation of algorithm mp\_div\_2d is slightly different than the algorithm specifies. The remainder $d$ may be optionally +ignored by passing \textbf{NULL} as the pointer to the mp\_int variable. The temporary mp\_int variable $t$ is used to hold the +result of the remainder operation until the end. This allows $d$ and $a$ to represent the same mp\_int without modifying $a$ before +the quotient is obtained. + +The remainder of the source code is essentially the same as the source code for mp\_mul\_2d. The only significant difference is +the direction of the shifts. + +\subsection{Remainder of Division by Power of Two} + +The last algorithm in the series of polynomial basis power of two algorithms is calculating the remainder of division by $2^b$. This +algorithm benefits from the fact that in twos complement arithmetic $a \mbox{ (mod }2^b\mbox{)}$ is the same as $a$ AND $2^b - 1$. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_mod\_2d}. \\ +\textbf{Input}. One mp\_int $a$ and an integer $b$ \\ +\textbf{Output}. $c \leftarrow a \mbox{ (mod }2^b\mbox{)}$. \\ +\hline \\ +1. If $b \le 0$ then do \\ +\hspace{3mm}1.1 $c \leftarrow 0$ (\textit{mp\_zero}) \\ +\hspace{3mm}1.2 Return(\textit{MP\_OKAY}). \\ +2. If $b > a.used \cdot lg(\beta)$ then do \\ +\hspace{3mm}2.1 $c \leftarrow a$ (\textit{mp\_copy}) \\ +\hspace{3mm}2.2 Return the result of step 2.1. \\ +3. $c \leftarrow a$ \\ +4. If step 3 failed return(\textit{MP\_MEM}). \\ +5. for $n$ from $\lceil b / lg(\beta) \rceil$ to $c.used$ do \\ +\hspace{3mm}5.1 $c_n \leftarrow 0$ \\ +6. $k \leftarrow b \mbox{ (mod }lg(\beta)\mbox{)}$ \\ +7. $c_{\lfloor b / lg(\beta) \rfloor} \leftarrow c_{\lfloor b / lg(\beta) \rfloor} \mbox{ (mod }2^{k}\mbox{)}$. \\ +8. Clamp excess digits of $c$. (\textit{mp\_clamp}) \\ +9. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_mod\_2d} +\end{figure} + +\textbf{Algorithm mp\_mod\_2d.} +This algorithm will quickly calculate the value of $a \mbox{ (mod }2^b\mbox{)}$. First if $b$ is less than or equal to zero the +result is set to zero. If $b$ is greater than the number of bits in $a$ then it simply copies $a$ to $c$ and returns. Otherwise, $a$ +is copied to $b$, leading digits are removed and the remaining leading digit is trimed to the exact bit count. + +EXAM,bn_mp_mod_2d.c + +We first avoid cases of $b \le 0$ by simply mp\_zero()'ing the destination in such cases. Next if $2^b$ is larger +than the input we just mp\_copy() the input and return right away. After this point we know we must actually +perform some work to produce the remainder. + +Recalling that reducing modulo $2^k$ and a binary ``and'' with $2^k - 1$ are numerically equivalent we can quickly reduce +the number. First we zero any digits above the last digit in $2^b$ (line @41,for@). Next we reduce the +leading digit of both (line @45,&=@) and then mp\_clamp(). + +\section*{Exercises} +\begin{tabular}{cl} +$\left [ 3 \right ] $ & Devise an algorithm that performs $a \cdot 2^b$ for generic values of $b$ \\ + & in $O(n)$ time. \\ + &\\ +$\left [ 3 \right ] $ & Devise an efficient algorithm to multiply by small low hamming \\ + & weight values such as $3$, $5$ and $9$. Extend it to handle all values \\ + & upto $64$ with a hamming weight less than three. \\ + &\\ +$\left [ 2 \right ] $ & Modify the preceding algorithm to handle values of the form \\ + & $2^k - 1$ as well. \\ + &\\ +$\left [ 3 \right ] $ & Using only algorithms mp\_mul\_2, mp\_div\_2 and mp\_add create an \\ + & algorithm to multiply two integers in roughly $O(2n^2)$ time for \\ + & any $n$-bit input. Note that the time of addition is ignored in the \\ + & calculation. \\ + & \\ +$\left [ 5 \right ] $ & Improve the previous algorithm to have a working time of at most \\ + & $O \left (2^{(k-1)}n + \left ({2n^2 \over k} \right ) \right )$ for an appropriate choice of $k$. Again ignore \\ + & the cost of addition. \\ + & \\ +$\left [ 2 \right ] $ & Devise a chart to find optimal values of $k$ for the previous problem \\ + & for $n = 64 \ldots 1024$ in steps of $64$. \\ + & \\ +$\left [ 2 \right ] $ & Using only algorithms mp\_abs and mp\_sub devise another method for \\ + & calculating the result of a signed comparison. \\ + & +\end{tabular} + +\chapter{Multiplication and Squaring} +\section{The Multipliers} +For most number theoretic problems including certain public key cryptographic algorithms, the ``multipliers'' form the most important subset of +algorithms of any multiple precision integer package. The set of multiplier algorithms include integer multiplication, squaring and modular reduction +where in each of the algorithms single precision multiplication is the dominant operation performed. This chapter will discuss integer multiplication +and squaring, leaving modular reductions for the subsequent chapter. + +The importance of the multiplier algorithms is for the most part driven by the fact that certain popular public key algorithms are based on modular +exponentiation, that is computing $d \equiv a^b \mbox{ (mod }c\mbox{)}$ for some arbitrary choice of $a$, $b$, $c$ and $d$. During a modular +exponentiation the majority\footnote{Roughly speaking a modular exponentiation will spend about 40\% of the time performing modular reductions, +35\% of the time performing squaring and 25\% of the time performing multiplications.} of the processor time is spent performing single precision +multiplications. + +For centuries general purpose multiplication has required a lengthly $O(n^2)$ process, whereby each digit of one multiplicand has to be multiplied +against every digit of the other multiplicand. Traditional long-hand multiplication is based on this process; while the techniques can differ the +overall algorithm used is essentially the same. Only ``recently'' have faster algorithms been studied. First Karatsuba multiplication was discovered in +1962. This algorithm can multiply two numbers with considerably fewer single precision multiplications when compared to the long-hand approach. +This technique led to the discovery of polynomial basis algorithms (\textit{good reference?}) and subquently Fourier Transform based solutions. + +\section{Multiplication} +\subsection{The Baseline Multiplication} +\label{sec:basemult} +\index{baseline multiplication} +Computing the product of two integers in software can be achieved using a trivial adaptation of the standard $O(n^2)$ long-hand multiplication +algorithm that school children are taught. The algorithm is considered an $O(n^2)$ algorithm since for two $n$-digit inputs $n^2$ single precision +multiplications are required. More specifically for a $m$ and $n$ digit input $m \cdot n$ single precision multiplications are required. To +simplify most discussions, it will be assumed that the inputs have comparable number of digits. + +The ``baseline multiplication'' algorithm is designed to act as the ``catch-all'' algorithm, only to be used when the faster algorithms cannot be +used. This algorithm does not use any particularly interesting optimizations and should ideally be avoided if possible. One important +facet of this algorithm, is that it has been modified to only produce a certain amount of output digits as resolution. The importance of this +modification will become evident during the discussion of Barrett modular reduction. Recall that for a $n$ and $m$ digit input the product +will be at most $n + m$ digits. Therefore, this algorithm can be reduced to a full multiplier by having it produce $n + m$ digits of the product. + +Recall from ~GAMMA~ the definition of $\gamma$ as the number of bits in the type \textbf{mp\_digit}. We shall now extend the variable set to +include $\alpha$ which shall represent the number of bits in the type \textbf{mp\_word}. This implies that $2^{\alpha} > 2 \cdot \beta^2$. The +constant $\delta = 2^{\alpha - 2lg(\beta)}$ will represent the maximal weight of any column in a product (\textit{see ~COMBA~ for more information}). + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{s\_mp\_mul\_digs}. \\ +\textbf{Input}. mp\_int $a$, mp\_int $b$ and an integer $digs$ \\ +\textbf{Output}. $c \leftarrow \vert a \vert \cdot \vert b \vert \mbox{ (mod }\beta^{digs}\mbox{)}$. \\ +\hline \\ +1. If min$(a.used, b.used) < \delta$ then do \\ +\hspace{3mm}1.1 Calculate $c = \vert a \vert \cdot \vert b \vert$ by the Comba method (\textit{see algorithm~\ref{fig:COMBAMULT}}). \\ +\hspace{3mm}1.2 Return the result of step 1.1 \\ +\\ +Allocate and initialize a temporary mp\_int. \\ +2. Init $t$ to be of size $digs$ \\ +3. If step 2 failed return(\textit{MP\_MEM}). \\ +4. $t.used \leftarrow digs$ \\ +\\ +Compute the product. \\ +5. for $ix$ from $0$ to $a.used - 1$ do \\ +\hspace{3mm}5.1 $u \leftarrow 0$ \\ +\hspace{3mm}5.2 $pb \leftarrow \mbox{min}(b.used, digs - ix)$ \\ +\hspace{3mm}5.3 If $pb < 1$ then goto step 6. \\ +\hspace{3mm}5.4 for $iy$ from $0$ to $pb - 1$ do \\ +\hspace{6mm}5.4.1 $\hat r \leftarrow t_{iy + ix} + a_{ix} \cdot b_{iy} + u$ \\ +\hspace{6mm}5.4.2 $t_{iy + ix} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\ +\hspace{6mm}5.4.3 $u \leftarrow \lfloor \hat r / \beta \rfloor$ \\ +\hspace{3mm}5.5 if $ix + pb < digs$ then do \\ +\hspace{6mm}5.5.1 $t_{ix + pb} \leftarrow u$ \\ +6. Clamp excess digits of $t$. \\ +7. Swap $c$ with $t$ \\ +8. Clear $t$ \\ +9. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm s\_mp\_mul\_digs} +\end{figure} + +\textbf{Algorithm s\_mp\_mul\_digs.} +This algorithm computes the unsigned product of two inputs $a$ and $b$, limited to an output precision of $digs$ digits. While it may seem +a bit awkward to modify the function from its simple $O(n^2)$ description, the usefulness of partial multipliers will arise in a subsequent +algorithm. The algorithm is loosely based on algorithm 14.12 from \cite[pp. 595]{HAC} and is similar to Algorithm M of Knuth \cite[pp. 268]{TAOCPV2}. +Algorithm s\_mp\_mul\_digs differs from these cited references since it can produce a variable output precision regardless of the precision of the +inputs. + +The first thing this algorithm checks for is whether a Comba multiplier can be used instead. If the minimum digit count of either +input is less than $\delta$, then the Comba method may be used instead. After the Comba method is ruled out, the baseline algorithm begins. A +temporary mp\_int variable $t$ is used to hold the intermediate result of the product. This allows the algorithm to be used to +compute products when either $a = c$ or $b = c$ without overwriting the inputs. + +All of step 5 is the infamous $O(n^2)$ multiplication loop slightly modified to only produce upto $digs$ digits of output. The $pb$ variable +is given the count of digits to read from $b$ inside the nested loop. If $pb \le 1$ then no more output digits can be produced and the algorithm +will exit the loop. The best way to think of the loops are as a series of $pb \times 1$ multiplications. That is, in each pass of the +innermost loop $a_{ix}$ is multiplied against $b$ and the result is added (\textit{with an appropriate shift}) to $t$. + +For example, consider multiplying $576$ by $241$. That is equivalent to computing $10^0(1)(576) + 10^1(4)(576) + 10^2(2)(576)$ which is best +visualized in the following table. + +\begin{figure}[here] +\begin{center} +\begin{tabular}{|c|c|c|c|c|c|l|} +\hline && & 5 & 7 & 6 & \\ +\hline $\times$&& & 2 & 4 & 1 & \\ +\hline &&&&&&\\ + && & 5 & 7 & 6 & $10^0(1)(576)$ \\ + &2 & 3 & 6 & 1 & 6 & $10^1(4)(576) + 10^0(1)(576)$ \\ + 1 & 3 & 8 & 8 & 1 & 6 & $10^2(2)(576) + 10^1(4)(576) + 10^0(1)(576)$ \\ +\hline +\end{tabular} +\end{center} +\caption{Long-Hand Multiplication Diagram} +\end{figure} + +Each row of the product is added to the result after being shifted to the left (\textit{multiplied by a power of the radix}) by the appropriate +count. That is in pass $ix$ of the inner loop the product is added starting at the $ix$'th digit of the reult. + +Step 5.4.1 introduces the hat symbol (\textit{e.g. $\hat r$}) which represents a double precision variable. The multiplication on that step +is assumed to be a double wide output single precision multiplication. That is, two single precision variables are multiplied to produce a +double precision result. The step is somewhat optimized from a long-hand multiplication algorithm because the carry from the addition in step +5.4.1 is propagated through the nested loop. If the carry was not propagated immediately it would overflow the single precision digit +$t_{ix+iy}$ and the result would be lost. + +At step 5.5 the nested loop is finished and any carry that was left over should be forwarded. The carry does not have to be added to the $ix+pb$'th +digit since that digit is assumed to be zero at this point. However, if $ix + pb \ge digs$ the carry is not set as it would make the result +exceed the precision requested. + +EXAM,bn_s_mp_mul_digs.c + +First we determine (line @30,if@) if the Comba method can be used first since it's faster. The conditions for +sing the Comba routine are that min$(a.used, b.used) < \delta$ and the number of digits of output is less than +\textbf{MP\_WARRAY}. This new constant is used to control the stack usage in the Comba routines. By default it is +set to $\delta$ but can be reduced when memory is at a premium. + +If we cannot use the Comba method we proceed to setup the baseline routine. We allocate the the destination mp\_int +$t$ (line @36,init@) to the exact size of the output to avoid further re--allocations. At this point we now +begin the $O(n^2)$ loop. + +This implementation of multiplication has the caveat that it can be trimmed to only produce a variable number of +digits as output. In each iteration of the outer loop the $pb$ variable is set (line @48,MIN@) to the maximum +number of inner loop iterations. + +Inside the inner loop we calculate $\hat r$ as the mp\_word product of the two mp\_digits and the addition of the +carry from the previous iteration. A particularly important observation is that most modern optimizing +C compilers (GCC for instance) can recognize that a $N \times N \rightarrow 2N$ multiplication is all that +is required for the product. In x86 terms for example, this means using the MUL instruction. + +Each digit of the product is stored in turn (line @68,tmpt@) and the carry propagated (line @71,>>@) to the +next iteration. + +\subsection{Faster Multiplication by the ``Comba'' Method} +MARK,COMBA + +One of the huge drawbacks of the ``baseline'' algorithms is that at the $O(n^2)$ level the carry must be +computed and propagated upwards. This makes the nested loop very sequential and hard to unroll and implement +in parallel. The ``Comba'' \cite{COMBA} method is named after little known (\textit{in cryptographic venues}) Paul G. +Comba who described a method of implementing fast multipliers that do not require nested carry fixup operations. As an +interesting aside it seems that Paul Barrett describes a similar technique in his 1986 paper \cite{BARRETT} written +five years before. + +At the heart of the Comba technique is once again the long-hand algorithm. Except in this case a slight +twist is placed on how the columns of the result are produced. In the standard long-hand algorithm rows of products +are produced then added together to form the final result. In the baseline algorithm the columns are added together +after each iteration to get the result instantaneously. + +In the Comba algorithm the columns of the result are produced entirely independently of each other. That is at +the $O(n^2)$ level a simple multiplication and addition step is performed. The carries of the columns are propagated +after the nested loop to reduce the amount of work requiored. Succintly the first step of the algorithm is to compute +the product vector $\vec x$ as follows. + +\begin{equation} +\vec x_n = \sum_{i+j = n} a_ib_j, \forall n \in \lbrace 0, 1, 2, \ldots, i + j \rbrace +\end{equation} + +Where $\vec x_n$ is the $n'th$ column of the output vector. Consider the following example which computes the vector $\vec x$ for the multiplication +of $576$ and $241$. + +\newpage\begin{figure}[here] +\begin{small} +\begin{center} +\begin{tabular}{|c|c|c|c|c|c|} + \hline & & 5 & 7 & 6 & First Input\\ + \hline $\times$ & & 2 & 4 & 1 & Second Input\\ +\hline & & $1 \cdot 5 = 5$ & $1 \cdot 7 = 7$ & $1 \cdot 6 = 6$ & First pass \\ + & $4 \cdot 5 = 20$ & $4 \cdot 7+5=33$ & $4 \cdot 6+7=31$ & 6 & Second pass \\ + $2 \cdot 5 = 10$ & $2 \cdot 7 + 20 = 34$ & $2 \cdot 6+33=45$ & 31 & 6 & Third pass \\ +\hline 10 & 34 & 45 & 31 & 6 & Final Result \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Comba Multiplication Diagram} +\end{figure} + +At this point the vector $x = \left < 10, 34, 45, 31, 6 \right >$ is the result of the first step of the Comba multipler. +Now the columns must be fixed by propagating the carry upwards. The resultant vector will have one extra dimension over the input vector which is +congruent to adding a leading zero digit. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{Comba Fixup}. \\ +\textbf{Input}. Vector $\vec x$ of dimension $k$ \\ +\textbf{Output}. Vector $\vec x$ such that the carries have been propagated. \\ +\hline \\ +1. for $n$ from $0$ to $k - 1$ do \\ +\hspace{3mm}1.1 $\vec x_{n+1} \leftarrow \vec x_{n+1} + \lfloor \vec x_{n}/\beta \rfloor$ \\ +\hspace{3mm}1.2 $\vec x_{n} \leftarrow \vec x_{n} \mbox{ (mod }\beta\mbox{)}$ \\ +2. Return($\vec x$). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm Comba Fixup} +\end{figure} + +With that algorithm and $k = 5$ and $\beta = 10$ the following vector is produced $\vec x= \left < 1, 3, 8, 8, 1, 6 \right >$. In this case +$241 \cdot 576$ is in fact $138816$ and the procedure succeeded. If the algorithm is correct and as will be demonstrated shortly more +efficient than the baseline algorithm why not simply always use this algorithm? + +\subsubsection{Column Weight.} +At the nested $O(n^2)$ level the Comba method adds the product of two single precision variables to each column of the output +independently. A serious obstacle is if the carry is lost, due to lack of precision before the algorithm has a chance to fix +the carries. For example, in the multiplication of two three-digit numbers the third column of output will be the sum of +three single precision multiplications. If the precision of the accumulator for the output digits is less then $3 \cdot (\beta - 1)^2$ then +an overflow can occur and the carry information will be lost. For any $m$ and $n$ digit inputs the maximum weight of any column is +min$(m, n)$ which is fairly obvious. + +The maximum number of terms in any column of a product is known as the ``column weight'' and strictly governs when the algorithm can be used. Recall +from earlier that a double precision type has $\alpha$ bits of resolution and a single precision digit has $lg(\beta)$ bits of precision. Given these +two quantities we must not violate the following + +\begin{equation} +k \cdot \left (\beta - 1 \right )^2 < 2^{\alpha} +\end{equation} + +Which reduces to + +\begin{equation} +k \cdot \left ( \beta^2 - 2\beta + 1 \right ) < 2^{\alpha} +\end{equation} + +Let $\rho = lg(\beta)$ represent the number of bits in a single precision digit. By further re-arrangement of the equation the final solution is +found. + +\begin{equation} +k < {{2^{\alpha}} \over {\left (2^{2\rho} - 2^{\rho + 1} + 1 \right )}} +\end{equation} + +The defaults for LibTomMath are $\beta = 2^{28}$ and $\alpha = 2^{64}$ which means that $k$ is bounded by $k < 257$. In this configuration +the smaller input may not have more than $256$ digits if the Comba method is to be used. This is quite satisfactory for most applications since +$256$ digits would allow for numbers in the range of $0 \le x < 2^{7168}$ which, is much larger than most public key cryptographic algorithms require. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{fast\_s\_mp\_mul\_digs}. \\ +\textbf{Input}. mp\_int $a$, mp\_int $b$ and an integer $digs$ \\ +\textbf{Output}. $c \leftarrow \vert a \vert \cdot \vert b \vert \mbox{ (mod }\beta^{digs}\mbox{)}$. \\ +\hline \\ +Place an array of \textbf{MP\_WARRAY} single precision digits named $W$ on the stack. \\ +1. If $c.alloc < digs$ then grow $c$ to $digs$ digits. (\textit{mp\_grow}) \\ +2. If step 1 failed return(\textit{MP\_MEM}).\\ +\\ +3. $pa \leftarrow \mbox{MIN}(digs, a.used + b.used)$ \\ +\\ +4. $\_ \hat W \leftarrow 0$ \\ +5. for $ix$ from 0 to $pa - 1$ do \\ +\hspace{3mm}5.1 $ty \leftarrow \mbox{MIN}(b.used - 1, ix)$ \\ +\hspace{3mm}5.2 $tx \leftarrow ix - ty$ \\ +\hspace{3mm}5.3 $iy \leftarrow \mbox{MIN}(a.used - tx, ty + 1)$ \\ +\hspace{3mm}5.4 for $iz$ from 0 to $iy - 1$ do \\ +\hspace{6mm}5.4.1 $\_ \hat W \leftarrow \_ \hat W + a_{tx+iy}b_{ty-iy}$ \\ +\hspace{3mm}5.5 $W_{ix} \leftarrow \_ \hat W (\mbox{mod }\beta)$\\ +\hspace{3mm}5.6 $\_ \hat W \leftarrow \lfloor \_ \hat W / \beta \rfloor$ \\ +6. $W_{pa} \leftarrow \_ \hat W (\mbox{mod }\beta)$ \\ +\\ +7. $oldused \leftarrow c.used$ \\ +8. $c.used \leftarrow digs$ \\ +9. for $ix$ from $0$ to $pa$ do \\ +\hspace{3mm}9.1 $c_{ix} \leftarrow W_{ix}$ \\ +10. for $ix$ from $pa + 1$ to $oldused - 1$ do \\ +\hspace{3mm}10.1 $c_{ix} \leftarrow 0$ \\ +\\ +11. Clamp $c$. \\ +12. Return MP\_OKAY. \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm fast\_s\_mp\_mul\_digs} +\label{fig:COMBAMULT} +\end{figure} + +\textbf{Algorithm fast\_s\_mp\_mul\_digs.} +This algorithm performs the unsigned multiplication of $a$ and $b$ using the Comba method limited to $digs$ digits of precision. + +The outer loop of this algorithm is more complicated than that of the baseline multiplier. This is because on the inside of the +loop we want to produce one column per pass. This allows the accumulator $\_ \hat W$ to be placed in CPU registers and +reduce the memory bandwidth to two \textbf{mp\_digit} reads per iteration. + +The $ty$ variable is set to the minimum count of $ix$ or the number of digits in $b$. That way if $a$ has more digits than +$b$ this will be limited to $b.used - 1$. The $tx$ variable is set to the to the distance past $b.used$ the variable +$ix$ is. This is used for the immediately subsequent statement where we find $iy$. + +The variable $iy$ is the minimum digits we can read from either $a$ or $b$ before running out. Computing one column at a time +means we have to scan one integer upwards and the other downwards. $a$ starts at $tx$ and $b$ starts at $ty$. In each +pass we are producing the $ix$'th output column and we note that $tx + ty = ix$. As we move $tx$ upwards we have to +move $ty$ downards so the equality remains valid. The $iy$ variable is the number of iterations until +$tx \ge a.used$ or $ty < 0$ occurs. + +After every inner pass we store the lower half of the accumulator into $W_{ix}$ and then propagate the carry of the accumulator +into the next round by dividing $\_ \hat W$ by $\beta$. + +To measure the benefits of the Comba method over the baseline method consider the number of operations that are required. If the +cost in terms of time of a multiply and addition is $p$ and the cost of a carry propagation is $q$ then a baseline multiplication would require +$O \left ((p + q)n^2 \right )$ time to multiply two $n$-digit numbers. The Comba method requires only $O(pn^2 + qn)$ time, however in practice, +the speed increase is actually much more. With $O(n)$ space the algorithm can be reduced to $O(pn + qn)$ time by implementing the $n$ multiply +and addition operations in the nested loop in parallel. + +EXAM,bn_fast_s_mp_mul_digs.c + +As per the pseudo--code we first calculate $pa$ (line @47,MIN@) as the number of digits to output. Next we begin the outer loop +to produce the individual columns of the product. We use the two aliases $tmpx$ and $tmpy$ (lines @61,tmpx@, @62,tmpy@) to point +inside the two multiplicands quickly. + +The inner loop (lines @70,for@ to @72,}@) of this implementation is where the tradeoff come into play. Originally this comba +implementation was ``row--major'' which means it adds to each of the columns in each pass. After the outer loop it would then fix +the carries. This was very fast except it had an annoying drawback. You had to read a mp\_word and two mp\_digits and write +one mp\_word per iteration. On processors such as the Athlon XP and P4 this did not matter much since the cache bandwidth +is very high and it can keep the ALU fed with data. It did, however, matter on older and embedded cpus where cache is often +slower and also often doesn't exist. This new algorithm only performs two reads per iteration under the assumption that the +compiler has aliased $\_ \hat W$ to a CPU register. + +After the inner loop we store the current accumulator in $W$ and shift $\_ \hat W$ (lines @75,W[ix]@, @78,>>@) to forward it as +a carry for the next pass. After the outer loop we use the final carry (line @82,W[ix]@) as the last digit of the product. + +\subsection{Polynomial Basis Multiplication} +To break the $O(n^2)$ barrier in multiplication requires a completely different look at integer multiplication. In the following algorithms +the use of polynomial basis representation for two integers $a$ and $b$ as $f(x) = \sum_{i=0}^{n} a_i x^i$ and +$g(x) = \sum_{i=0}^{n} b_i x^i$ respectively, is required. In this system both $f(x)$ and $g(x)$ have $n + 1$ terms and are of the $n$'th degree. + +The product $a \cdot b \equiv f(x)g(x)$ is the polynomial $W(x) = \sum_{i=0}^{2n} w_i x^i$. The coefficients $w_i$ will +directly yield the desired product when $\beta$ is substituted for $x$. The direct solution to solve for the $2n + 1$ coefficients +requires $O(n^2)$ time and would in practice be slower than the Comba technique. + +However, numerical analysis theory indicates that only $2n + 1$ distinct points in $W(x)$ are required to determine the values of the $2n + 1$ unknown +coefficients. This means by finding $\zeta_y = W(y)$ for $2n + 1$ small values of $y$ the coefficients of $W(x)$ can be found with +Gaussian elimination. This technique is also occasionally refered to as the \textit{interpolation technique} (\textit{references please...}) since in +effect an interpolation based on $2n + 1$ points will yield a polynomial equivalent to $W(x)$. + +The coefficients of the polynomial $W(x)$ are unknown which makes finding $W(y)$ for any value of $y$ impossible. However, since +$W(x) = f(x)g(x)$ the equivalent $\zeta_y = f(y) g(y)$ can be used in its place. The benefit of this technique stems from the +fact that $f(y)$ and $g(y)$ are much smaller than either $a$ or $b$ respectively. As a result finding the $2n + 1$ relations required +by multiplying $f(y)g(y)$ involves multiplying integers that are much smaller than either of the inputs. + +When picking points to gather relations there are always three obvious points to choose, $y = 0, 1$ and $ \infty$. The $\zeta_0$ term +is simply the product $W(0) = w_0 = a_0 \cdot b_0$. The $\zeta_1$ term is the product +$W(1) = \left (\sum_{i = 0}^{n} a_i \right ) \left (\sum_{i = 0}^{n} b_i \right )$. The third point $\zeta_{\infty}$ is less obvious but rather +simple to explain. The $2n + 1$'th coefficient of $W(x)$ is numerically equivalent to the most significant column in an integer multiplication. +The point at $\infty$ is used symbolically to represent the most significant column, that is $W(\infty) = w_{2n} = a_nb_n$. Note that the +points at $y = 0$ and $\infty$ yield the coefficients $w_0$ and $w_{2n}$ directly. + +If more points are required they should be of small values and powers of two such as $2^q$ and the related \textit{mirror points} +$\left (2^q \right )^{2n} \cdot \zeta_{2^{-q}}$ for small values of $q$. The term ``mirror point'' stems from the fact that +$\left (2^q \right )^{2n} \cdot \zeta_{2^{-q}}$ can be calculated in the exact opposite fashion as $\zeta_{2^q}$. For +example, when $n = 2$ and $q = 1$ then following two equations are equivalent to the point $\zeta_{2}$ and its mirror. + +\begin{eqnarray} +\zeta_{2} = f(2)g(2) = (4a_2 + 2a_1 + a_0)(4b_2 + 2b_1 + b_0) \nonumber \\ +16 \cdot \zeta_{1 \over 2} = 4f({1\over 2}) \cdot 4g({1 \over 2}) = (a_2 + 2a_1 + 4a_0)(b_2 + 2b_1 + 4b_0) +\end{eqnarray} + +Using such points will allow the values of $f(y)$ and $g(y)$ to be independently calculated using only left shifts. For example, when $n = 2$ the +polynomial $f(2^q)$ is equal to $2^q((2^qa_2) + a_1) + a_0$. This technique of polynomial representation is known as Horner's method. + +As a general rule of the algorithm when the inputs are split into $n$ parts each there are $2n - 1$ multiplications. Each multiplication is of +multiplicands that have $n$ times fewer digits than the inputs. The asymptotic running time of this algorithm is +$O \left ( k^{lg_n(2n - 1)} \right )$ for $k$ digit inputs (\textit{assuming they have the same number of digits}). Figure~\ref{fig:exponent} +summarizes the exponents for various values of $n$. + +\begin{figure} +\begin{center} +\begin{tabular}{|c|c|c|} +\hline \textbf{Split into $n$ Parts} & \textbf{Exponent} & \textbf{Notes}\\ +\hline $2$ & $1.584962501$ & This is Karatsuba Multiplication. \\ +\hline $3$ & $1.464973520$ & This is Toom-Cook Multiplication. \\ +\hline $4$ & $1.403677461$ &\\ +\hline $5$ & $1.365212389$ &\\ +\hline $10$ & $1.278753601$ &\\ +\hline $100$ & $1.149426538$ &\\ +\hline $1000$ & $1.100270931$ &\\ +\hline $10000$ & $1.075252070$ &\\ +\hline +\end{tabular} +\end{center} +\caption{Asymptotic Running Time of Polynomial Basis Multiplication} +\label{fig:exponent} +\end{figure} + +At first it may seem like a good idea to choose $n = 1000$ since the exponent is approximately $1.1$. However, the overhead +of solving for the 2001 terms of $W(x)$ will certainly consume any savings the algorithm could offer for all but exceedingly large +numbers. + +\subsubsection{Cutoff Point} +The polynomial basis multiplication algorithms all require fewer single precision multiplications than a straight Comba approach. However, +the algorithms incur an overhead (\textit{at the $O(n)$ work level}) since they require a system of equations to be solved. This makes the +polynomial basis approach more costly to use with small inputs. + +Let $m$ represent the number of digits in the multiplicands (\textit{assume both multiplicands have the same number of digits}). There exists a +point $y$ such that when $m < y$ the polynomial basis algorithms are more costly than Comba, when $m = y$ they are roughly the same cost and +when $m > y$ the Comba methods are slower than the polynomial basis algorithms. + +The exact location of $y$ depends on several key architectural elements of the computer platform in question. + +\begin{enumerate} +\item The ratio of clock cycles for single precision multiplication versus other simpler operations such as addition, shifting, etc. For example +on the AMD Athlon the ratio is roughly $17 : 1$ while on the Intel P4 it is $29 : 1$. The higher the ratio in favour of multiplication the lower +the cutoff point $y$ will be. + +\item The complexity of the linear system of equations (\textit{for the coefficients of $W(x)$}) is. Generally speaking as the number of splits +grows the complexity grows substantially. Ideally solving the system will only involve addition, subtraction and shifting of integers. This +directly reflects on the ratio previous mentioned. + +\item To a lesser extent memory bandwidth and function call overheads. Provided the values are in the processor cache this is less of an +influence over the cutoff point. + +\end{enumerate} + +A clean cutoff point separation occurs when a point $y$ is found such that all of the cutoff point conditions are met. For example, if the point +is too low then there will be values of $m$ such that $m > y$ and the Comba method is still faster. Finding the cutoff points is fairly simple when +a high resolution timer is available. + +\subsection{Karatsuba Multiplication} +Karatsuba \cite{KARA} multiplication when originally proposed in 1962 was among the first set of algorithms to break the $O(n^2)$ barrier for +general purpose multiplication. Given two polynomial basis representations $f(x) = ax + b$ and $g(x) = cx + d$, Karatsuba proved with +light algebra \cite{KARAP} that the following polynomial is equivalent to multiplication of the two integers the polynomials represent. + +\begin{equation} +f(x) \cdot g(x) = acx^2 + ((a + b)(c + d) - (ac + bd))x + bd +\end{equation} + +Using the observation that $ac$ and $bd$ could be re-used only three half sized multiplications would be required to produce the product. Applying +this algorithm recursively, the work factor becomes $O(n^{lg(3)})$ which is substantially better than the work factor $O(n^2)$ of the Comba technique. It turns +out what Karatsuba did not know or at least did not publish was that this is simply polynomial basis multiplication with the points +$\zeta_0$, $\zeta_{\infty}$ and $\zeta_{1}$. Consider the resultant system of equations. + +\begin{center} +\begin{tabular}{rcrcrcrc} +$\zeta_{0}$ & $=$ & & & & & $w_0$ \\ +$\zeta_{1}$ & $=$ & $w_2$ & $+$ & $w_1$ & $+$ & $w_0$ \\ +$\zeta_{\infty}$ & $=$ & $w_2$ & & & & \\ +\end{tabular} +\end{center} + +By adding the first and last equation to the equation in the middle the term $w_1$ can be isolated and all three coefficients solved for. The simplicity +of this system of equations has made Karatsuba fairly popular. In fact the cutoff point is often fairly low\footnote{With LibTomMath 0.18 it is 70 and 109 digits for the Intel P4 and AMD Athlon respectively.} +making it an ideal algorithm to speed up certain public key cryptosystems such as RSA and Diffie-Hellman. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_karatsuba\_mul}. \\ +\textbf{Input}. mp\_int $a$ and mp\_int $b$ \\ +\textbf{Output}. $c \leftarrow \vert a \vert \cdot \vert b \vert$ \\ +\hline \\ +1. Init the following mp\_int variables: $x0$, $x1$, $y0$, $y1$, $t1$, $x0y0$, $x1y1$.\\ +2. If step 2 failed then return(\textit{MP\_MEM}). \\ +\\ +Split the input. e.g. $a = x1 \cdot \beta^B + x0$ \\ +3. $B \leftarrow \mbox{min}(a.used, b.used)/2$ \\ +4. $x0 \leftarrow a \mbox{ (mod }\beta^B\mbox{)}$ (\textit{mp\_mod\_2d}) \\ +5. $y0 \leftarrow b \mbox{ (mod }\beta^B\mbox{)}$ \\ +6. $x1 \leftarrow \lfloor a / \beta^B \rfloor$ (\textit{mp\_rshd}) \\ +7. $y1 \leftarrow \lfloor b / \beta^B \rfloor$ \\ +\\ +Calculate the three products. \\ +8. $x0y0 \leftarrow x0 \cdot y0$ (\textit{mp\_mul}) \\ +9. $x1y1 \leftarrow x1 \cdot y1$ \\ +10. $t1 \leftarrow x1 + x0$ (\textit{mp\_add}) \\ +11. $x0 \leftarrow y1 + y0$ \\ +12. $t1 \leftarrow t1 \cdot x0$ \\ +\\ +Calculate the middle term. \\ +13. $x0 \leftarrow x0y0 + x1y1$ \\ +14. $t1 \leftarrow t1 - x0$ (\textit{s\_mp\_sub}) \\ +\\ +Calculate the final product. \\ +15. $t1 \leftarrow t1 \cdot \beta^B$ (\textit{mp\_lshd}) \\ +16. $x1y1 \leftarrow x1y1 \cdot \beta^{2B}$ \\ +17. $t1 \leftarrow x0y0 + t1$ \\ +18. $c \leftarrow t1 + x1y1$ \\ +19. Clear all of the temporary variables. \\ +20. Return(\textit{MP\_OKAY}).\\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_karatsuba\_mul} +\end{figure} + +\textbf{Algorithm mp\_karatsuba\_mul.} +This algorithm computes the unsigned product of two inputs using the Karatsuba multiplication algorithm. It is loosely based on the description +from Knuth \cite[pp. 294-295]{TAOCPV2}. + +\index{radix point} +In order to split the two inputs into their respective halves, a suitable \textit{radix point} must be chosen. The radix point chosen must +be used for both of the inputs meaning that it must be smaller than the smallest input. Step 3 chooses the radix point $B$ as half of the +smallest input \textbf{used} count. After the radix point is chosen the inputs are split into lower and upper halves. Step 4 and 5 +compute the lower halves. Step 6 and 7 computer the upper halves. + +After the halves have been computed the three intermediate half-size products must be computed. Step 8 and 9 compute the trivial products +$x0 \cdot y0$ and $x1 \cdot y1$. The mp\_int $x0$ is used as a temporary variable after $x1 + x0$ has been computed. By using $x0$ instead +of an additional temporary variable, the algorithm can avoid an addition memory allocation operation. + +The remaining steps 13 through 18 compute the Karatsuba polynomial through a variety of digit shifting and addition operations. + +EXAM,bn_mp_karatsuba_mul.c + +The new coding element in this routine, not seen in previous routines, is the usage of goto statements. The conventional +wisdom is that goto statements should be avoided. This is generally true, however when every single function call can fail, it makes sense +to handle error recovery with a single piece of code. Lines @61,if@ to @75,if@ handle initializing all of the temporary variables +required. Note how each of the if statements goes to a different label in case of failure. This allows the routine to correctly free only +the temporaries that have been successfully allocated so far. + +The temporary variables are all initialized using the mp\_init\_size routine since they are expected to be large. This saves the +additional reallocation that would have been necessary. Also $x0$, $x1$, $y0$ and $y1$ have to be able to hold at least their respective +number of digits for the next section of code. + +The first algebraic portion of the algorithm is to split the two inputs into their halves. However, instead of using mp\_mod\_2d and mp\_rshd +to extract the halves, the respective code has been placed inline within the body of the function. To initialize the halves, the \textbf{used} and +\textbf{sign} members are copied first. The first for loop on line @98,for@ copies the lower halves. Since they are both the same magnitude it +is simpler to calculate both lower halves in a single loop. The for loop on lines @104,for@ and @109,for@ calculate the upper halves $x1$ and +$y1$ respectively. + +By inlining the calculation of the halves, the Karatsuba multiplier has a slightly lower overhead and can be used for smaller magnitude inputs. + +When line @152,err@ is reached, the algorithm has completed succesfully. The ``error status'' variable $err$ is set to \textbf{MP\_OKAY} so that +the same code that handles errors can be used to clear the temporary variables and return. + +\subsection{Toom-Cook $3$-Way Multiplication} +Toom-Cook $3$-Way \cite{TOOM} multiplication is essentially the polynomial basis algorithm for $n = 2$ except that the points are +chosen such that $\zeta$ is easy to compute and the resulting system of equations easy to reduce. Here, the points $\zeta_{0}$, +$16 \cdot \zeta_{1 \over 2}$, $\zeta_1$, $\zeta_2$ and $\zeta_{\infty}$ make up the five required points to solve for the coefficients +of the $W(x)$. + +With the five relations that Toom-Cook specifies, the following system of equations is formed. + +\begin{center} +\begin{tabular}{rcrcrcrcrcr} +$\zeta_0$ & $=$ & $0w_4$ & $+$ & $0w_3$ & $+$ & $0w_2$ & $+$ & $0w_1$ & $+$ & $1w_0$ \\ +$16 \cdot \zeta_{1 \over 2}$ & $=$ & $1w_4$ & $+$ & $2w_3$ & $+$ & $4w_2$ & $+$ & $8w_1$ & $+$ & $16w_0$ \\ +$\zeta_1$ & $=$ & $1w_4$ & $+$ & $1w_3$ & $+$ & $1w_2$ & $+$ & $1w_1$ & $+$ & $1w_0$ \\ +$\zeta_2$ & $=$ & $16w_4$ & $+$ & $8w_3$ & $+$ & $4w_2$ & $+$ & $2w_1$ & $+$ & $1w_0$ \\ +$\zeta_{\infty}$ & $=$ & $1w_4$ & $+$ & $0w_3$ & $+$ & $0w_2$ & $+$ & $0w_1$ & $+$ & $0w_0$ \\ +\end{tabular} +\end{center} + +A trivial solution to this matrix requires $12$ subtractions, two multiplications by a small power of two, two divisions by a small power +of two, two divisions by three and one multiplication by three. All of these $19$ sub-operations require less than quadratic time, meaning that +the algorithm can be faster than a baseline multiplication. However, the greater complexity of this algorithm places the cutoff point +(\textbf{TOOM\_MUL\_CUTOFF}) where Toom-Cook becomes more efficient much higher than the Karatsuba cutoff point. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_toom\_mul}. \\ +\textbf{Input}. mp\_int $a$ and mp\_int $b$ \\ +\textbf{Output}. $c \leftarrow a \cdot b $ \\ +\hline \\ +Split $a$ and $b$ into three pieces. E.g. $a = a_2 \beta^{2k} + a_1 \beta^{k} + a_0$ \\ +1. $k \leftarrow \lfloor \mbox{min}(a.used, b.used) / 3 \rfloor$ \\ +2. $a_0 \leftarrow a \mbox{ (mod }\beta^{k}\mbox{)}$ \\ +3. $a_1 \leftarrow \lfloor a / \beta^k \rfloor$, $a_1 \leftarrow a_1 \mbox{ (mod }\beta^{k}\mbox{)}$ \\ +4. $a_2 \leftarrow \lfloor a / \beta^{2k} \rfloor$, $a_2 \leftarrow a_2 \mbox{ (mod }\beta^{k}\mbox{)}$ \\ +5. $b_0 \leftarrow a \mbox{ (mod }\beta^{k}\mbox{)}$ \\ +6. $b_1 \leftarrow \lfloor a / \beta^k \rfloor$, $b_1 \leftarrow b_1 \mbox{ (mod }\beta^{k}\mbox{)}$ \\ +7. $b_2 \leftarrow \lfloor a / \beta^{2k} \rfloor$, $b_2 \leftarrow b_2 \mbox{ (mod }\beta^{k}\mbox{)}$ \\ +\\ +Find the five equations for $w_0, w_1, ..., w_4$. \\ +8. $w_0 \leftarrow a_0 \cdot b_0$ \\ +9. $w_4 \leftarrow a_2 \cdot b_2$ \\ +10. $tmp_1 \leftarrow 2 \cdot a_0$, $tmp_1 \leftarrow a_1 + tmp_1$, $tmp_1 \leftarrow 2 \cdot tmp_1$, $tmp_1 \leftarrow tmp_1 + a_2$ \\ +11. $tmp_2 \leftarrow 2 \cdot b_0$, $tmp_2 \leftarrow b_1 + tmp_2$, $tmp_2 \leftarrow 2 \cdot tmp_2$, $tmp_2 \leftarrow tmp_2 + b_2$ \\ +12. $w_1 \leftarrow tmp_1 \cdot tmp_2$ \\ +13. $tmp_1 \leftarrow 2 \cdot a_2$, $tmp_1 \leftarrow a_1 + tmp_1$, $tmp_1 \leftarrow 2 \cdot tmp_1$, $tmp_1 \leftarrow tmp_1 + a_0$ \\ +14. $tmp_2 \leftarrow 2 \cdot b_2$, $tmp_2 \leftarrow b_1 + tmp_2$, $tmp_2 \leftarrow 2 \cdot tmp_2$, $tmp_2 \leftarrow tmp_2 + b_0$ \\ +15. $w_3 \leftarrow tmp_1 \cdot tmp_2$ \\ +16. $tmp_1 \leftarrow a_0 + a_1$, $tmp_1 \leftarrow tmp_1 + a_2$, $tmp_2 \leftarrow b_0 + b_1$, $tmp_2 \leftarrow tmp_2 + b_2$ \\ +17. $w_2 \leftarrow tmp_1 \cdot tmp_2$ \\ +\\ +Continued on the next page.\\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_toom\_mul} +\end{figure} + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_toom\_mul} (continued). \\ +\textbf{Input}. mp\_int $a$ and mp\_int $b$ \\ +\textbf{Output}. $c \leftarrow a \cdot b $ \\ +\hline \\ +Now solve the system of equations. \\ +18. $w_1 \leftarrow w_4 - w_1$, $w_3 \leftarrow w_3 - w_0$ \\ +19. $w_1 \leftarrow \lfloor w_1 / 2 \rfloor$, $w_3 \leftarrow \lfloor w_3 / 2 \rfloor$ \\ +20. $w_2 \leftarrow w_2 - w_0$, $w_2 \leftarrow w_2 - w_4$ \\ +21. $w_1 \leftarrow w_1 - w_2$, $w_3 \leftarrow w_3 - w_2$ \\ +22. $tmp_1 \leftarrow 8 \cdot w_0$, $w_1 \leftarrow w_1 - tmp_1$, $tmp_1 \leftarrow 8 \cdot w_4$, $w_3 \leftarrow w_3 - tmp_1$ \\ +23. $w_2 \leftarrow 3 \cdot w_2$, $w_2 \leftarrow w_2 - w_1$, $w_2 \leftarrow w_2 - w_3$ \\ +24. $w_1 \leftarrow w_1 - w_2$, $w_3 \leftarrow w_3 - w_2$ \\ +25. $w_1 \leftarrow \lfloor w_1 / 3 \rfloor, w_3 \leftarrow \lfloor w_3 / 3 \rfloor$ \\ +\\ +Now substitute $\beta^k$ for $x$ by shifting $w_0, w_1, ..., w_4$. \\ +26. for $n$ from $1$ to $4$ do \\ +\hspace{3mm}26.1 $w_n \leftarrow w_n \cdot \beta^{nk}$ \\ +27. $c \leftarrow w_0 + w_1$, $c \leftarrow c + w_2$, $c \leftarrow c + w_3$, $c \leftarrow c + w_4$ \\ +28. Return(\textit{MP\_OKAY}) \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_toom\_mul (continued)} +\end{figure} + +\textbf{Algorithm mp\_toom\_mul.} +This algorithm computes the product of two mp\_int variables $a$ and $b$ using the Toom-Cook approach. Compared to the Karatsuba multiplication, this +algorithm has a lower asymptotic running time of approximately $O(n^{1.464})$ but at an obvious cost in overhead. In this +description, several statements have been compounded to save space. The intention is that the statements are executed from left to right across +any given step. + +The two inputs $a$ and $b$ are first split into three $k$-digit integers $a_0, a_1, a_2$ and $b_0, b_1, b_2$ respectively. From these smaller +integers the coefficients of the polynomial basis representations $f(x)$ and $g(x)$ are known and can be used to find the relations required. + +The first two relations $w_0$ and $w_4$ are the points $\zeta_{0}$ and $\zeta_{\infty}$ respectively. The relation $w_1, w_2$ and $w_3$ correspond +to the points $16 \cdot \zeta_{1 \over 2}, \zeta_{2}$ and $\zeta_{1}$ respectively. These are found using logical shifts to independently find +$f(y)$ and $g(y)$ which significantly speeds up the algorithm. + +After the five relations $w_0, w_1, \ldots, w_4$ have been computed, the system they represent must be solved in order for the unknown coefficients +$w_1, w_2$ and $w_3$ to be isolated. The steps 18 through 25 perform the system reduction required as previously described. Each step of +the reduction represents the comparable matrix operation that would be performed had this been performed by pencil. For example, step 18 indicates +that row $1$ must be subtracted from row $4$ and simultaneously row $0$ subtracted from row $3$. + +Once the coeffients have been isolated, the polynomial $W(x) = \sum_{i=0}^{2n} w_i x^i$ is known. By substituting $\beta^{k}$ for $x$, the integer +result $a \cdot b$ is produced. + +EXAM,bn_mp_toom_mul.c + +The first obvious thing to note is that this algorithm is complicated. The complexity is worth it if you are multiplying very +large numbers. For example, a 10,000 digit multiplication takes approximaly 99,282,205 fewer single precision multiplications with +Toom--Cook than a Comba or baseline approach (this is a savings of more than 99$\%$). For most ``crypto'' sized numbers this +algorithm is not practical as Karatsuba has a much lower cutoff point. + +First we split $a$ and $b$ into three roughly equal portions. This has been accomplished (lines @40,mod@ to @69,rshd@) with +combinations of mp\_rshd() and mp\_mod\_2d() function calls. At this point $a = a2 \cdot \beta^2 + a1 \cdot \beta + a0$ and similiarly +for $b$. + +Next we compute the five points $w0, w1, w2, w3$ and $w4$. Recall that $w0$ and $w4$ can be computed directly from the portions so +we get those out of the way first (lines @72,mul@ and @77,mul@). Next we compute $w1, w2$ and $w3$ using Horners method. + +After this point we solve for the actual values of $w1, w2$ and $w3$ by reducing the $5 \times 5$ system which is relatively +straight forward. + +\subsection{Signed Multiplication} +Now that algorithms to handle multiplications of every useful dimensions have been developed, a rather simple finishing touch is required. So far all +of the multiplication algorithms have been unsigned multiplications which leaves only a signed multiplication algorithm to be established. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_mul}. \\ +\textbf{Input}. mp\_int $a$ and mp\_int $b$ \\ +\textbf{Output}. $c \leftarrow a \cdot b$ \\ +\hline \\ +1. If $a.sign = b.sign$ then \\ +\hspace{3mm}1.1 $sign = MP\_ZPOS$ \\ +2. else \\ +\hspace{3mm}2.1 $sign = MP\_ZNEG$ \\ +3. If min$(a.used, b.used) \ge TOOM\_MUL\_CUTOFF$ then \\ +\hspace{3mm}3.1 $c \leftarrow a \cdot b$ using algorithm mp\_toom\_mul \\ +4. else if min$(a.used, b.used) \ge KARATSUBA\_MUL\_CUTOFF$ then \\ +\hspace{3mm}4.1 $c \leftarrow a \cdot b$ using algorithm mp\_karatsuba\_mul \\ +5. else \\ +\hspace{3mm}5.1 $digs \leftarrow a.used + b.used + 1$ \\ +\hspace{3mm}5.2 If $digs < MP\_ARRAY$ and min$(a.used, b.used) \le \delta$ then \\ +\hspace{6mm}5.2.1 $c \leftarrow a \cdot b \mbox{ (mod }\beta^{digs}\mbox{)}$ using algorithm fast\_s\_mp\_mul\_digs. \\ +\hspace{3mm}5.3 else \\ +\hspace{6mm}5.3.1 $c \leftarrow a \cdot b \mbox{ (mod }\beta^{digs}\mbox{)}$ using algorithm s\_mp\_mul\_digs. \\ +6. $c.sign \leftarrow sign$ \\ +7. Return the result of the unsigned multiplication performed. \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_mul} +\end{figure} + +\textbf{Algorithm mp\_mul.} +This algorithm performs the signed multiplication of two inputs. It will make use of any of the three unsigned multiplication algorithms +available when the input is of appropriate size. The \textbf{sign} of the result is not set until the end of the algorithm since algorithm +s\_mp\_mul\_digs will clear it. + +EXAM,bn_mp_mul.c + +The implementation is rather simplistic and is not particularly noteworthy. Line @22,?@ computes the sign of the result using the ``?'' +operator from the C programming language. Line @37,<<@ computes $\delta$ using the fact that $1 << k$ is equal to $2^k$. + +\section{Squaring} +\label{sec:basesquare} + +Squaring is a special case of multiplication where both multiplicands are equal. At first it may seem like there is no significant optimization +available but in fact there is. Consider the multiplication of $576$ against $241$. In total there will be nine single precision multiplications +performed which are $1\cdot 6$, $1 \cdot 7$, $1 \cdot 5$, $4 \cdot 6$, $4 \cdot 7$, $4 \cdot 5$, $2 \cdot 6$, $2 \cdot 7$ and $2 \cdot 5$. Now consider +the multiplication of $123$ against $123$. The nine products are $3 \cdot 3$, $3 \cdot 2$, $3 \cdot 1$, $2 \cdot 3$, $2 \cdot 2$, $2 \cdot 1$, +$1 \cdot 3$, $1 \cdot 2$ and $1 \cdot 1$. On closer inspection some of the products are equivalent. For example, $3 \cdot 2 = 2 \cdot 3$ +and $3 \cdot 1 = 1 \cdot 3$. + +For any $n$-digit input, there are ${{\left (n^2 + n \right)}\over 2}$ possible unique single precision multiplications required compared to the $n^2$ +required for multiplication. The following diagram gives an example of the operations required. + +\begin{figure}[here] +\begin{center} +\begin{tabular}{ccccc|c} +&&1&2&3&\\ +$\times$ &&1&2&3&\\ +\hline && $3 \cdot 1$ & $3 \cdot 2$ & $3 \cdot 3$ & Row 0\\ + & $2 \cdot 1$ & $2 \cdot 2$ & $2 \cdot 3$ && Row 1 \\ + $1 \cdot 1$ & $1 \cdot 2$ & $1 \cdot 3$ &&& Row 2 \\ +\end{tabular} +\end{center} +\caption{Squaring Optimization Diagram} +\end{figure} + +MARK,SQUARE +Starting from zero and numbering the columns from right to left a very simple pattern becomes obvious. For the purposes of this discussion let $x$ +represent the number being squared. The first observation is that in row $k$ the $2k$'th column of the product has a $\left (x_k \right)^2$ term in it. + +The second observation is that every column $j$ in row $k$ where $j \ne 2k$ is part of a double product. Every non-square term of a column will +appear twice hence the name ``double product''. Every odd column is made up entirely of double products. In fact every column is made up of double +products and at most one square (\textit{see the exercise section}). + +The third and final observation is that for row $k$ the first unique non-square term, that is, one that hasn't already appeared in an earlier row, +occurs at column $2k + 1$. For example, on row $1$ of the previous squaring, column one is part of the double product with column one from row zero. +Column two of row one is a square and column three is the first unique column. + +\subsection{The Baseline Squaring Algorithm} +The baseline squaring algorithm is meant to be a catch-all squaring algorithm. It will handle any of the input sizes that the faster routines +will not handle. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{s\_mp\_sqr}. \\ +\textbf{Input}. mp\_int $a$ \\ +\textbf{Output}. $b \leftarrow a^2$ \\ +\hline \\ +1. Init a temporary mp\_int of at least $2 \cdot a.used +1$ digits. (\textit{mp\_init\_size}) \\ +2. If step 1 failed return(\textit{MP\_MEM}) \\ +3. $t.used \leftarrow 2 \cdot a.used + 1$ \\ +4. For $ix$ from 0 to $a.used - 1$ do \\ +\hspace{3mm}Calculate the square. \\ +\hspace{3mm}4.1 $\hat r \leftarrow t_{2ix} + \left (a_{ix} \right )^2$ \\ +\hspace{3mm}4.2 $t_{2ix} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\ +\hspace{3mm}Calculate the double products after the square. \\ +\hspace{3mm}4.3 $u \leftarrow \lfloor \hat r / \beta \rfloor$ \\ +\hspace{3mm}4.4 For $iy$ from $ix + 1$ to $a.used - 1$ do \\ +\hspace{6mm}4.4.1 $\hat r \leftarrow 2 \cdot a_{ix}a_{iy} + t_{ix + iy} + u$ \\ +\hspace{6mm}4.4.2 $t_{ix + iy} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\ +\hspace{6mm}4.4.3 $u \leftarrow \lfloor \hat r / \beta \rfloor$ \\ +\hspace{3mm}Set the last carry. \\ +\hspace{3mm}4.5 While $u > 0$ do \\ +\hspace{6mm}4.5.1 $iy \leftarrow iy + 1$ \\ +\hspace{6mm}4.5.2 $\hat r \leftarrow t_{ix + iy} + u$ \\ +\hspace{6mm}4.5.3 $t_{ix + iy} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\ +\hspace{6mm}4.5.4 $u \leftarrow \lfloor \hat r / \beta \rfloor$ \\ +5. Clamp excess digits of $t$. (\textit{mp\_clamp}) \\ +6. Exchange $b$ and $t$. \\ +7. Clear $t$ (\textit{mp\_clear}) \\ +8. Return(\textit{MP\_OKAY}) \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm s\_mp\_sqr} +\end{figure} + +\textbf{Algorithm s\_mp\_sqr.} +This algorithm computes the square of an input using the three observations on squaring. It is based fairly faithfully on algorithm 14.16 of HAC +\cite[pp.596-597]{HAC}. Similar to algorithm s\_mp\_mul\_digs, a temporary mp\_int is allocated to hold the result of the squaring. This allows the +destination mp\_int to be the same as the source mp\_int. + +The outer loop of this algorithm begins on step 4. It is best to think of the outer loop as walking down the rows of the partial results, while +the inner loop computes the columns of the partial result. Step 4.1 and 4.2 compute the square term for each row, and step 4.3 and 4.4 propagate +the carry and compute the double products. + +The requirement that a mp\_word be able to represent the range $0 \le x < 2 \beta^2$ arises from this +very algorithm. The product $a_{ix}a_{iy}$ will lie in the range $0 \le x \le \beta^2 - 2\beta + 1$ which is obviously less than $\beta^2$ meaning that +when it is multiplied by two, it can be properly represented by a mp\_word. + +Similar to algorithm s\_mp\_mul\_digs, after every pass of the inner loop, the destination is correctly set to the sum of all of the partial +results calculated so far. This involves expensive carry propagation which will be eliminated in the next algorithm. + +EXAM,bn_s_mp_sqr.c + +Inside the outer loop (line @32,for@) the square term is calculated on line @35,r =@. The carry (line @42,>>@) has been +extracted from the mp\_word accumulator using a right shift. Aliases for $a_{ix}$ and $t_{ix+iy}$ are initialized +(lines @45,tmpx@ and @48,tmpt@) to simplify the inner loop. The doubling is performed using two +additions (line @57,r + r@) since it is usually faster than shifting, if not at least as fast. + +The important observation is that the inner loop does not begin at $iy = 0$ like for multiplication. As such the inner loops +get progressively shorter as the algorithm proceeds. This is what leads to the savings compared to using a multiplication to +square a number. + +\subsection{Faster Squaring by the ``Comba'' Method} +A major drawback to the baseline method is the requirement for single precision shifting inside the $O(n^2)$ nested loop. Squaring has an additional +drawback that it must double the product inside the inner loop as well. As for multiplication, the Comba technique can be used to eliminate these +performance hazards. + +The first obvious solution is to make an array of mp\_words which will hold all of the columns. This will indeed eliminate all of the carry +propagation operations from the inner loop. However, the inner product must still be doubled $O(n^2)$ times. The solution stems from the simple fact +that $2a + 2b + 2c = 2(a + b + c)$. That is the sum of all of the double products is equal to double the sum of all the products. For example, +$ab + ba + ac + ca = 2ab + 2ac = 2(ab + ac)$. + +However, we cannot simply double all of the columns, since the squares appear only once per row. The most practical solution is to have two +mp\_word arrays. One array will hold the squares and the other array will hold the double products. With both arrays the doubling and +carry propagation can be moved to a $O(n)$ work level outside the $O(n^2)$ level. In this case, we have an even simpler solution in mind. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{fast\_s\_mp\_sqr}. \\ +\textbf{Input}. mp\_int $a$ \\ +\textbf{Output}. $b \leftarrow a^2$ \\ +\hline \\ +Place an array of \textbf{MP\_WARRAY} mp\_digits named $W$ on the stack. \\ +1. If $b.alloc < 2a.used + 1$ then grow $b$ to $2a.used + 1$ digits. (\textit{mp\_grow}). \\ +2. If step 1 failed return(\textit{MP\_MEM}). \\ +\\ +3. $pa \leftarrow 2 \cdot a.used$ \\ +4. $\hat W1 \leftarrow 0$ \\ +5. for $ix$ from $0$ to $pa - 1$ do \\ +\hspace{3mm}5.1 $\_ \hat W \leftarrow 0$ \\ +\hspace{3mm}5.2 $ty \leftarrow \mbox{MIN}(a.used - 1, ix)$ \\ +\hspace{3mm}5.3 $tx \leftarrow ix - ty$ \\ +\hspace{3mm}5.4 $iy \leftarrow \mbox{MIN}(a.used - tx, ty + 1)$ \\ +\hspace{3mm}5.5 $iy \leftarrow \mbox{MIN}(iy, \lfloor \left (ty - tx + 1 \right )/2 \rfloor)$ \\ +\hspace{3mm}5.6 for $iz$ from $0$ to $iz - 1$ do \\ +\hspace{6mm}5.6.1 $\_ \hat W \leftarrow \_ \hat W + a_{tx + iz}a_{ty - iz}$ \\ +\hspace{3mm}5.7 $\_ \hat W \leftarrow 2 \cdot \_ \hat W + \hat W1$ \\ +\hspace{3mm}5.8 if $ix$ is even then \\ +\hspace{6mm}5.8.1 $\_ \hat W \leftarrow \_ \hat W + \left ( a_{\lfloor ix/2 \rfloor}\right )^2$ \\ +\hspace{3mm}5.9 $W_{ix} \leftarrow \_ \hat W (\mbox{mod }\beta)$ \\ +\hspace{3mm}5.10 $\hat W1 \leftarrow \lfloor \_ \hat W / \beta \rfloor$ \\ +\\ +6. $oldused \leftarrow b.used$ \\ +7. $b.used \leftarrow 2 \cdot a.used$ \\ +8. for $ix$ from $0$ to $pa - 1$ do \\ +\hspace{3mm}8.1 $b_{ix} \leftarrow W_{ix}$ \\ +9. for $ix$ from $pa$ to $oldused - 1$ do \\ +\hspace{3mm}9.1 $b_{ix} \leftarrow 0$ \\ +10. Clamp excess digits from $b$. (\textit{mp\_clamp}) \\ +11. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm fast\_s\_mp\_sqr} +\end{figure} + +\textbf{Algorithm fast\_s\_mp\_sqr.} +This algorithm computes the square of an input using the Comba technique. It is designed to be a replacement for algorithm +s\_mp\_sqr when the number of input digits is less than \textbf{MP\_WARRAY} and less than $\delta \over 2$. +This algorithm is very similar to the Comba multiplier except with a few key differences we shall make note of. + +First, we have an accumulator and carry variables $\_ \hat W$ and $\hat W1$ respectively. This is because the inner loop +products are to be doubled. If we had added the previous carry in we would be doubling too much. Next we perform an +addition MIN condition on $iy$ (step 5.5) to prevent overlapping digits. For example, $a_3 \cdot a_5$ is equal +$a_5 \cdot a_3$. Whereas in the multiplication case we would have $5 < a.used$ and $3 \ge 0$ is maintained since we double the sum +of the products just outside the inner loop we have to avoid doing this. This is also a good thing since we perform +fewer multiplications and the routine ends up being faster. + +Finally the last difference is the addition of the ``square'' term outside the inner loop (step 5.8). We add in the square +only to even outputs and it is the square of the term at the $\lfloor ix / 2 \rfloor$ position. + +EXAM,bn_fast_s_mp_sqr.c + +This implementation is essentially a copy of Comba multiplication with the appropriate changes added to make it faster for +the special case of squaring. + +\subsection{Polynomial Basis Squaring} +The same algorithm that performs optimal polynomial basis multiplication can be used to perform polynomial basis squaring. The minor exception +is that $\zeta_y = f(y)g(y)$ is actually equivalent to $\zeta_y = f(y)^2$ since $f(y) = g(y)$. Instead of performing $2n + 1$ +multiplications to find the $\zeta$ relations, squaring operations are performed instead. + +\subsection{Karatsuba Squaring} +Let $f(x) = ax + b$ represent the polynomial basis representation of a number to square. +Let $h(x) = \left ( f(x) \right )^2$ represent the square of the polynomial. The Karatsuba equation can be modified to square a +number with the following equation. + +\begin{equation} +h(x) = a^2x^2 + \left ((a + b)^2 - (a^2 + b^2) \right )x + b^2 +\end{equation} + +Upon closer inspection this equation only requires the calculation of three half-sized squares: $a^2$, $b^2$ and $(a + b)^2$. As in +Karatsuba multiplication, this algorithm can be applied recursively on the input and will achieve an asymptotic running time of +$O \left ( n^{lg(3)} \right )$. + +If the asymptotic times of Karatsuba squaring and multiplication are the same, why not simply use the multiplication algorithm +instead? The answer to this arises from the cutoff point for squaring. As in multiplication there exists a cutoff point, at which the +time required for a Comba based squaring and a Karatsuba based squaring meet. Due to the overhead inherent in the Karatsuba method, the cutoff +point is fairly high. For example, on an AMD Athlon XP processor with $\beta = 2^{28}$, the cutoff point is around 127 digits. + +Consider squaring a 200 digit number with this technique. It will be split into two 100 digit halves which are subsequently squared. +The 100 digit halves will not be squared using Karatsuba, but instead using the faster Comba based squaring algorithm. If Karatsuba multiplication +were used instead, the 100 digit numbers would be squared with a slower Comba based multiplication. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_karatsuba\_sqr}. \\ +\textbf{Input}. mp\_int $a$ \\ +\textbf{Output}. $b \leftarrow a^2$ \\ +\hline \\ +1. Initialize the following temporary mp\_ints: $x0$, $x1$, $t1$, $t2$, $x0x0$ and $x1x1$. \\ +2. If any of the initializations on step 1 failed return(\textit{MP\_MEM}). \\ +\\ +Split the input. e.g. $a = x1\beta^B + x0$ \\ +3. $B \leftarrow \lfloor a.used / 2 \rfloor$ \\ +4. $x0 \leftarrow a \mbox{ (mod }\beta^B\mbox{)}$ (\textit{mp\_mod\_2d}) \\ +5. $x1 \leftarrow \lfloor a / \beta^B \rfloor$ (\textit{mp\_lshd}) \\ +\\ +Calculate the three squares. \\ +6. $x0x0 \leftarrow x0^2$ (\textit{mp\_sqr}) \\ +7. $x1x1 \leftarrow x1^2$ \\ +8. $t1 \leftarrow x1 + x0$ (\textit{s\_mp\_add}) \\ +9. $t1 \leftarrow t1^2$ \\ +\\ +Compute the middle term. \\ +10. $t2 \leftarrow x0x0 + x1x1$ (\textit{s\_mp\_add}) \\ +11. $t1 \leftarrow t1 - t2$ \\ +\\ +Compute final product. \\ +12. $t1 \leftarrow t1\beta^B$ (\textit{mp\_lshd}) \\ +13. $x1x1 \leftarrow x1x1\beta^{2B}$ \\ +14. $t1 \leftarrow t1 + x0x0$ \\ +15. $b \leftarrow t1 + x1x1$ \\ +16. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_karatsuba\_sqr} +\end{figure} + +\textbf{Algorithm mp\_karatsuba\_sqr.} +This algorithm computes the square of an input $a$ using the Karatsuba technique. This algorithm is very similar to the Karatsuba based +multiplication algorithm with the exception that the three half-size multiplications have been replaced with three half-size squarings. + +The radix point for squaring is simply placed exactly in the middle of the digits when the input has an odd number of digits, otherwise it is +placed just below the middle. Step 3, 4 and 5 compute the two halves required using $B$ +as the radix point. The first two squares in steps 6 and 7 are rather straightforward while the last square is of a more compact form. + +By expanding $\left (x1 + x0 \right )^2$, the $x1^2$ and $x0^2$ terms in the middle disappear, that is $(x0 - x1)^2 - (x1^2 + x0^2) = 2 \cdot x0 \cdot x1$. +Now if $5n$ single precision additions and a squaring of $n$-digits is faster than multiplying two $n$-digit numbers and doubling then +this method is faster. Assuming no further recursions occur, the difference can be estimated with the following inequality. + +Let $p$ represent the cost of a single precision addition and $q$ the cost of a single precision multiplication both in terms of time\footnote{Or +machine clock cycles.}. + +\begin{equation} +5pn +{{q(n^2 + n)} \over 2} \le pn + qn^2 +\end{equation} + +For example, on an AMD Athlon XP processor $p = {1 \over 3}$ and $q = 6$. This implies that the following inequality should hold. +\begin{center} +\begin{tabular}{rcl} +${5n \over 3} + 3n^2 + 3n$ & $<$ & ${n \over 3} + 6n^2$ \\ +${5 \over 3} + 3n + 3$ & $<$ & ${1 \over 3} + 6n$ \\ +${13 \over 9}$ & $<$ & $n$ \\ +\end{tabular} +\end{center} + +This results in a cutoff point around $n = 2$. As a consequence it is actually faster to compute the middle term the ``long way'' on processors +where multiplication is substantially slower\footnote{On the Athlon there is a 1:17 ratio between clock cycles for addition and multiplication. On +the Intel P4 processor this ratio is 1:29 making this method even more beneficial. The only common exception is the ARMv4 processor which has a +ratio of 1:7. } than simpler operations such as addition. + +EXAM,bn_mp_karatsuba_sqr.c + +This implementation is largely based on the implementation of algorithm mp\_karatsuba\_mul. It uses the same inline style to copy and +shift the input into the two halves. The loop from line @54,{@ to line @70,}@ has been modified since only one input exists. The \textbf{used} +count of both $x0$ and $x1$ is fixed up and $x0$ is clamped before the calculations begin. At this point $x1$ and $x0$ are valid equivalents +to the respective halves as if mp\_rshd and mp\_mod\_2d had been used. + +By inlining the copy and shift operations the cutoff point for Karatsuba multiplication can be lowered. On the Athlon the cutoff point +is exactly at the point where Comba squaring can no longer be used (\textit{128 digits}). On slower processors such as the Intel P4 +it is actually below the Comba limit (\textit{at 110 digits}). + +This routine uses the same error trap coding style as mp\_karatsuba\_sqr. As the temporary variables are initialized errors are +redirected to the error trap higher up. If the algorithm completes without error the error code is set to \textbf{MP\_OKAY} and +mp\_clears are executed normally. + +\subsection{Toom-Cook Squaring} +The Toom-Cook squaring algorithm mp\_toom\_sqr is heavily based on the algorithm mp\_toom\_mul with the exception that squarings are used +instead of multiplication to find the five relations. The reader is encouraged to read the description of the latter algorithm and try to +derive their own Toom-Cook squaring algorithm. + +\subsection{High Level Squaring} +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_sqr}. \\ +\textbf{Input}. mp\_int $a$ \\ +\textbf{Output}. $b \leftarrow a^2$ \\ +\hline \\ +1. If $a.used \ge TOOM\_SQR\_CUTOFF$ then \\ +\hspace{3mm}1.1 $b \leftarrow a^2$ using algorithm mp\_toom\_sqr \\ +2. else if $a.used \ge KARATSUBA\_SQR\_CUTOFF$ then \\ +\hspace{3mm}2.1 $b \leftarrow a^2$ using algorithm mp\_karatsuba\_sqr \\ +3. else \\ +\hspace{3mm}3.1 $digs \leftarrow a.used + b.used + 1$ \\ +\hspace{3mm}3.2 If $digs < MP\_ARRAY$ and $a.used \le \delta$ then \\ +\hspace{6mm}3.2.1 $b \leftarrow a^2$ using algorithm fast\_s\_mp\_sqr. \\ +\hspace{3mm}3.3 else \\ +\hspace{6mm}3.3.1 $b \leftarrow a^2$ using algorithm s\_mp\_sqr. \\ +4. $b.sign \leftarrow MP\_ZPOS$ \\ +5. Return the result of the unsigned squaring performed. \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_sqr} +\end{figure} + +\textbf{Algorithm mp\_sqr.} +This algorithm computes the square of the input using one of four different algorithms. If the input is very large and has at least +\textbf{TOOM\_SQR\_CUTOFF} or \textbf{KARATSUBA\_SQR\_CUTOFF} digits then either the Toom-Cook or the Karatsuba Squaring algorithm is used. If +neither of the polynomial basis algorithms should be used then either the Comba or baseline algorithm is used. + +EXAM,bn_mp_sqr.c + +\section*{Exercises} +\begin{tabular}{cl} +$\left [ 3 \right ] $ & Devise an efficient algorithm for selection of the radix point to handle inputs \\ + & that have different number of digits in Karatsuba multiplication. \\ + & \\ +$\left [ 2 \right ] $ & In ~SQUARE~ the fact that every column of a squaring is made up \\ + & of double products and at most one square is stated. Prove this statement. \\ + & \\ +$\left [ 3 \right ] $ & Prove the equation for Karatsuba squaring. \\ + & \\ +$\left [ 1 \right ] $ & Prove that Karatsuba squaring requires $O \left (n^{lg(3)} \right )$ time. \\ + & \\ +$\left [ 2 \right ] $ & Determine the minimal ratio between addition and multiplication clock cycles \\ + & required for equation $6.7$ to be true. \\ + & \\ +$\left [ 3 \right ] $ & Implement a threaded version of Comba multiplication (and squaring) where you \\ + & compute subsets of the columns in each thread. Determine a cutoff point where \\ + & it is effective and add the logic to mp\_mul() and mp\_sqr(). \\ + &\\ +$\left [ 4 \right ] $ & Same as the previous but also modify the Karatsuba and Toom-Cook. You must \\ + & increase the throughput of mp\_exptmod() for random odd moduli in the range \\ + & $512 \ldots 4096$ bits significantly ($> 2x$) to complete this challenge. \\ + & \\ +\end{tabular} + +\chapter{Modular Reduction} +MARK,REDUCTION +\section{Basics of Modular Reduction} +\index{modular residue} +Modular reduction is an operation that arises quite often within public key cryptography algorithms and various number theoretic algorithms, +such as factoring. Modular reduction algorithms are the third class of algorithms of the ``multipliers'' set. A number $a$ is said to be \textit{reduced} +modulo another number $b$ by finding the remainder of the division $a/b$. Full integer division with remainder is a topic to be covered +in~\ref{sec:division}. + +Modular reduction is equivalent to solving for $r$ in the following equation. $a = bq + r$ where $q = \lfloor a/b \rfloor$. The result +$r$ is said to be ``congruent to $a$ modulo $b$'' which is also written as $r \equiv a \mbox{ (mod }b\mbox{)}$. In other vernacular $r$ is known as the +``modular residue'' which leads to ``quadratic residue''\footnote{That's fancy talk for $b \equiv a^2 \mbox{ (mod }p\mbox{)}$.} and +other forms of residues. + +Modular reductions are normally used to create either finite groups, rings or fields. The most common usage for performance driven modular reductions +is in modular exponentiation algorithms. That is to compute $d = a^b \mbox{ (mod }c\mbox{)}$ as fast as possible. This operation is used in the +RSA and Diffie-Hellman public key algorithms, for example. Modular multiplication and squaring also appears as a fundamental operation in +elliptic curve cryptographic algorithms. As will be discussed in the subsequent chapter there exist fast algorithms for computing modular +exponentiations without having to perform (\textit{in this example}) $b - 1$ multiplications. These algorithms will produce partial results in the +range $0 \le x < c^2$ which can be taken advantage of to create several efficient algorithms. They have also been used to create redundancy check +algorithms known as CRCs, error correction codes such as Reed-Solomon and solve a variety of number theoeretic problems. + +\section{The Barrett Reduction} +The Barrett reduction algorithm \cite{BARRETT} was inspired by fast division algorithms which multiply by the reciprocal to emulate +division. Barretts observation was that the residue $c$ of $a$ modulo $b$ is equal to + +\begin{equation} +c = a - b \cdot \lfloor a/b \rfloor +\end{equation} + +Since algorithms such as modular exponentiation would be using the same modulus extensively, typical DSP\footnote{It is worth noting that Barrett's paper +targeted the DSP56K processor.} intuition would indicate the next step would be to replace $a/b$ by a multiplication by the reciprocal. However, +DSP intuition on its own will not work as these numbers are considerably larger than the precision of common DSP floating point data types. +It would take another common optimization to optimize the algorithm. + +\subsection{Fixed Point Arithmetic} +The trick used to optimize the above equation is based on a technique of emulating floating point data types with fixed precision integers. Fixed +point arithmetic would become very popular as it greatly optimize the ``3d-shooter'' genre of games in the mid 1990s when floating point units were +fairly slow if not unavailable. The idea behind fixed point arithmetic is to take a normal $k$-bit integer data type and break it into $p$-bit +integer and a $q$-bit fraction part (\textit{where $p+q = k$}). + +In this system a $k$-bit integer $n$ would actually represent $n/2^q$. For example, with $q = 4$ the integer $n = 37$ would actually represent the +value $2.3125$. To multiply two fixed point numbers the integers are multiplied using traditional arithmetic and subsequently normalized by +moving the implied decimal point back to where it should be. For example, with $q = 4$ to multiply the integers $9$ and $5$ they must be converted +to fixed point first by multiplying by $2^q$. Let $a = 9(2^q)$ represent the fixed point representation of $9$ and $b = 5(2^q)$ represent the +fixed point representation of $5$. The product $ab$ is equal to $45(2^{2q})$ which when normalized by dividing by $2^q$ produces $45(2^q)$. + +This technique became popular since a normal integer multiplication and logical shift right are the only required operations to perform a multiplication +of two fixed point numbers. Using fixed point arithmetic, division can be easily approximated by multiplying by the reciprocal. If $2^q$ is +equivalent to one than $2^q/b$ is equivalent to the fixed point approximation of $1/b$ using real arithmetic. Using this fact dividing an integer +$a$ by another integer $b$ can be achieved with the following expression. + +\begin{equation} +\lfloor a / b \rfloor \mbox{ }\approx\mbox{ } \lfloor (a \cdot \lfloor 2^q / b \rfloor)/2^q \rfloor +\end{equation} + +The precision of the division is proportional to the value of $q$. If the divisor $b$ is used frequently as is the case with +modular exponentiation pre-computing $2^q/b$ will allow a division to be performed with a multiplication and a right shift. Both operations +are considerably faster than division on most processors. + +Consider dividing $19$ by $5$. The correct result is $\lfloor 19/5 \rfloor = 3$. With $q = 3$ the reciprocal is $\lfloor 2^q/5 \rfloor = 1$ which +leads to a product of $19$ which when divided by $2^q$ produces $2$. However, with $q = 4$ the reciprocal is $\lfloor 2^q/5 \rfloor = 3$ and +the result of the emulated division is $\lfloor 3 \cdot 19 / 2^q \rfloor = 3$ which is correct. The value of $2^q$ must be close to or ideally +larger than the dividend. In effect if $a$ is the dividend then $q$ should allow $0 \le \lfloor a/2^q \rfloor \le 1$ in order for this approach +to work correctly. Plugging this form of divison into the original equation the following modular residue equation arises. + +\begin{equation} +c = a - b \cdot \lfloor (a \cdot \lfloor 2^q / b \rfloor)/2^q \rfloor +\end{equation} + +Using the notation from \cite{BARRETT} the value of $\lfloor 2^q / b \rfloor$ will be represented by the $\mu$ symbol. Using the $\mu$ +variable also helps re-inforce the idea that it is meant to be computed once and re-used. + +\begin{equation} +c = a - b \cdot \lfloor (a \cdot \mu)/2^q \rfloor +\end{equation} + +Provided that $2^q \ge a$ this algorithm will produce a quotient that is either exactly correct or off by a value of one. In the context of Barrett +reduction the value of $a$ is bound by $0 \le a \le (b - 1)^2$ meaning that $2^q \ge b^2$ is sufficient to ensure the reciprocal will have enough +precision. + +Let $n$ represent the number of digits in $b$. This algorithm requires approximately $2n^2$ single precision multiplications to produce the quotient and +another $n^2$ single precision multiplications to find the residue. In total $3n^2$ single precision multiplications are required to +reduce the number. + +For example, if $b = 1179677$ and $q = 41$ ($2^q > b^2$), then the reciprocal $\mu$ is equal to $\lfloor 2^q / b \rfloor = 1864089$. Consider reducing +$a = 180388626447$ modulo $b$ using the above reduction equation. The quotient using the new formula is $\lfloor (a \cdot \mu) / 2^q \rfloor = 152913$. +By subtracting $152913b$ from $a$ the correct residue $a \equiv 677346 \mbox{ (mod }b\mbox{)}$ is found. + +\subsection{Choosing a Radix Point} +Using the fixed point representation a modular reduction can be performed with $3n^2$ single precision multiplications. If that were the best +that could be achieved a full division\footnote{A division requires approximately $O(2cn^2)$ single precision multiplications for a small value of $c$. +See~\ref{sec:division} for further details.} might as well be used in its place. The key to optimizing the reduction is to reduce the precision of +the initial multiplication that finds the quotient. + +Let $a$ represent the number of which the residue is sought. Let $b$ represent the modulus used to find the residue. Let $m$ represent +the number of digits in $b$. For the purposes of this discussion we will assume that the number of digits in $a$ is $2m$, which is generally true if +two $m$-digit numbers have been multiplied. Dividing $a$ by $b$ is the same as dividing a $2m$ digit integer by a $m$ digit integer. Digits below the +$m - 1$'th digit of $a$ will contribute at most a value of $1$ to the quotient because $\beta^k < b$ for any $0 \le k \le m - 1$. Another way to +express this is by re-writing $a$ as two parts. If $a' \equiv a \mbox{ (mod }b^m\mbox{)}$ and $a'' = a - a'$ then +${a \over b} \equiv {{a' + a''} \over b}$ which is equivalent to ${a' \over b} + {a'' \over b}$. Since $a'$ is bound to be less than $b$ the quotient +is bound by $0 \le {a' \over b} < 1$. + +Since the digits of $a'$ do not contribute much to the quotient the observation is that they might as well be zero. However, if the digits +``might as well be zero'' they might as well not be there in the first place. Let $q_0 = \lfloor a/\beta^{m-1} \rfloor$ represent the input +with the irrelevant digits trimmed. Now the modular reduction is trimmed to the almost equivalent equation + +\begin{equation} +c = a - b \cdot \lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor +\end{equation} + +Note that the original divisor $2^q$ has been replaced with $\beta^{m+1}$ where in this case $q$ is a multiple of $lg(\beta)$. Also note that the +exponent on the divisor when added to the amount $q_0$ was shifted by equals $2m$. If the optimization had not been performed the divisor +would have the exponent $2m$ so in the end the exponents do ``add up''. Using the above equation the quotient +$\lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor$ can be off from the true quotient by at most two. The original fixed point quotient can be off +by as much as one (\textit{provided the radix point is chosen suitably}) and now that the lower irrelevent digits have been trimmed the quotient +can be off by an additional value of one for a total of at most two. This implies that +$0 \le a - b \cdot \lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor < 3b$. By first subtracting $b$ times the quotient and then conditionally subtracting +$b$ once or twice the residue is found. + +The quotient is now found using $(m + 1)(m) = m^2 + m$ single precision multiplications and the residue with an additional $m^2$ single +precision multiplications, ignoring the subtractions required. In total $2m^2 + m$ single precision multiplications are required to find the residue. +This is considerably faster than the original attempt. + +For example, let $\beta = 10$ represent the radix of the digits. Let $b = 9999$ represent the modulus which implies $m = 4$. Let $a = 99929878$ +represent the value of which the residue is desired. In this case $q = 8$ since $10^7 < 9999^2$ meaning that $\mu = \lfloor \beta^{q}/b \rfloor = 10001$. +With the new observation the multiplicand for the quotient is equal to $q_0 = \lfloor a / \beta^{m - 1} \rfloor = 99929$. The quotient is then +$\lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor = 9993$. Subtracting $9993b$ from $a$ and the correct residue $a \equiv 9871 \mbox{ (mod }b\mbox{)}$ +is found. + +\subsection{Trimming the Quotient} +So far the reduction algorithm has been optimized from $3m^2$ single precision multiplications down to $2m^2 + m$ single precision multiplications. As +it stands now the algorithm is already fairly fast compared to a full integer division algorithm. However, there is still room for +optimization. + +After the first multiplication inside the quotient ($q_0 \cdot \mu$) the value is shifted right by $m + 1$ places effectively nullifying the lower +half of the product. It would be nice to be able to remove those digits from the product to effectively cut down the number of single precision +multiplications. If the number of digits in the modulus $m$ is far less than $\beta$ a full product is not required for the algorithm to work properly. +In fact the lower $m - 2$ digits will not affect the upper half of the product at all and do not need to be computed. + +The value of $\mu$ is a $m$-digit number and $q_0$ is a $m + 1$ digit number. Using a full multiplier $(m + 1)(m) = m^2 + m$ single precision +multiplications would be required. Using a multiplier that will only produce digits at and above the $m - 1$'th digit reduces the number +of single precision multiplications to ${m^2 + m} \over 2$ single precision multiplications. + +\subsection{Trimming the Residue} +After the quotient has been calculated it is used to reduce the input. As previously noted the algorithm is not exact and it can be off by a small +multiple of the modulus, that is $0 \le a - b \cdot \lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor < 3b$. If $b$ is $m$ digits than the +result of reduction equation is a value of at most $m + 1$ digits (\textit{provided $3 < \beta$}) implying that the upper $m - 1$ digits are +implicitly zero. + +The next optimization arises from this very fact. Instead of computing $b \cdot \lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor$ using a full +$O(m^2)$ multiplication algorithm only the lower $m+1$ digits of the product have to be computed. Similarly the value of $a$ can +be reduced modulo $\beta^{m+1}$ before the multiple of $b$ is subtracted which simplifes the subtraction as well. A multiplication that produces +only the lower $m+1$ digits requires ${m^2 + 3m - 2} \over 2$ single precision multiplications. + +With both optimizations in place the algorithm is the algorithm Barrett proposed. It requires $m^2 + 2m - 1$ single precision multiplications which +is considerably faster than the straightforward $3m^2$ method. + +\subsection{The Barrett Algorithm} +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_reduce}. \\ +\textbf{Input}. mp\_int $a$, mp\_int $b$ and $\mu = \lfloor \beta^{2m}/b \rfloor, m = \lceil lg_{\beta}(b) \rceil, (0 \le a < b^2, b > 1)$ \\ +\textbf{Output}. $a \mbox{ (mod }b\mbox{)}$ \\ +\hline \\ +Let $m$ represent the number of digits in $b$. \\ +1. Make a copy of $a$ and store it in $q$. (\textit{mp\_init\_copy}) \\ +2. $q \leftarrow \lfloor q / \beta^{m - 1} \rfloor$ (\textit{mp\_rshd}) \\ +\\ +Produce the quotient. \\ +3. $q \leftarrow q \cdot \mu$ (\textit{note: only produce digits at or above $m-1$}) \\ +4. $q \leftarrow \lfloor q / \beta^{m + 1} \rfloor$ \\ +\\ +Subtract the multiple of modulus from the input. \\ +5. $a \leftarrow a \mbox{ (mod }\beta^{m+1}\mbox{)}$ (\textit{mp\_mod\_2d}) \\ +6. $q \leftarrow q \cdot b \mbox{ (mod }\beta^{m+1}\mbox{)}$ (\textit{s\_mp\_mul\_digs}) \\ +7. $a \leftarrow a - q$ (\textit{mp\_sub}) \\ +\\ +Add $\beta^{m+1}$ if a carry occured. \\ +8. If $a < 0$ then (\textit{mp\_cmp\_d}) \\ +\hspace{3mm}8.1 $q \leftarrow 1$ (\textit{mp\_set}) \\ +\hspace{3mm}8.2 $q \leftarrow q \cdot \beta^{m+1}$ (\textit{mp\_lshd}) \\ +\hspace{3mm}8.3 $a \leftarrow a + q$ \\ +\\ +Now subtract the modulus if the residue is too large (e.g. quotient too small). \\ +9. While $a \ge b$ do (\textit{mp\_cmp}) \\ +\hspace{3mm}9.1 $c \leftarrow a - b$ \\ +10. Clear $q$. \\ +11. Return(\textit{MP\_OKAY}) \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_reduce} +\end{figure} + +\textbf{Algorithm mp\_reduce.} +This algorithm will reduce the input $a$ modulo $b$ in place using the Barrett algorithm. It is loosely based on algorithm 14.42 of HAC +\cite[pp. 602]{HAC} which is based on the paper from Paul Barrett \cite{BARRETT}. The algorithm has several restrictions and assumptions which must +be adhered to for the algorithm to work. + +First the modulus $b$ is assumed to be positive and greater than one. If the modulus were less than or equal to one than subtracting +a multiple of it would either accomplish nothing or actually enlarge the input. The input $a$ must be in the range $0 \le a < b^2$ in order +for the quotient to have enough precision. If $a$ is the product of two numbers that were already reduced modulo $b$, this will not be a problem. +Technically the algorithm will still work if $a \ge b^2$ but it will take much longer to finish. The value of $\mu$ is passed as an argument to this +algorithm and is assumed to be calculated and stored before the algorithm is used. + +Recall that the multiplication for the quotient on step 3 must only produce digits at or above the $m-1$'th position. An algorithm called +$s\_mp\_mul\_high\_digs$ which has not been presented is used to accomplish this task. The algorithm is based on $s\_mp\_mul\_digs$ except that +instead of stopping at a given level of precision it starts at a given level of precision. This optimal algorithm can only be used if the number +of digits in $b$ is very much smaller than $\beta$. + +While it is known that +$a \ge b \cdot \lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor$ only the lower $m+1$ digits are being used to compute the residue, so an implied +``borrow'' from the higher digits might leave a negative result. After the multiple of the modulus has been subtracted from $a$ the residue must be +fixed up in case it is negative. The invariant $\beta^{m+1}$ must be added to the residue to make it positive again. + +The while loop at step 9 will subtract $b$ until the residue is less than $b$. If the algorithm is performed correctly this step is +performed at most twice, and on average once. However, if $a \ge b^2$ than it will iterate substantially more times than it should. + +EXAM,bn_mp_reduce.c + +The first multiplication that determines the quotient can be performed by only producing the digits from $m - 1$ and up. This essentially halves +the number of single precision multiplications required. However, the optimization is only safe if $\beta$ is much larger than the number of digits +in the modulus. In the source code this is evaluated on lines @36,if@ to @44,}@ where algorithm s\_mp\_mul\_high\_digs is used when it is +safe to do so. + +\subsection{The Barrett Setup Algorithm} +In order to use algorithm mp\_reduce the value of $\mu$ must be calculated in advance. Ideally this value should be computed once and stored for +future use so that the Barrett algorithm can be used without delay. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_reduce\_setup}. \\ +\textbf{Input}. mp\_int $a$ ($a > 1$) \\ +\textbf{Output}. $\mu \leftarrow \lfloor \beta^{2m}/a \rfloor$ \\ +\hline \\ +1. $\mu \leftarrow 2^{2 \cdot lg(\beta) \cdot m}$ (\textit{mp\_2expt}) \\ +2. $\mu \leftarrow \lfloor \mu / b \rfloor$ (\textit{mp\_div}) \\ +3. Return(\textit{MP\_OKAY}) \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_reduce\_setup} +\end{figure} + +\textbf{Algorithm mp\_reduce\_setup.} +This algorithm computes the reciprocal $\mu$ required for Barrett reduction. First $\beta^{2m}$ is calculated as $2^{2 \cdot lg(\beta) \cdot m}$ which +is equivalent and much faster. The final value is computed by taking the integer quotient of $\lfloor \mu / b \rfloor$. + +EXAM,bn_mp_reduce_setup.c + +This simple routine calculates the reciprocal $\mu$ required by Barrett reduction. Note the extended usage of algorithm mp\_div where the variable +which would received the remainder is passed as NULL. As will be discussed in~\ref{sec:division} the division routine allows both the quotient and the +remainder to be passed as NULL meaning to ignore the value. + +\section{The Montgomery Reduction} +Montgomery reduction\footnote{Thanks to Niels Ferguson for his insightful explanation of the algorithm.} \cite{MONT} is by far the most interesting +form of reduction in common use. It computes a modular residue which is not actually equal to the residue of the input yet instead equal to a +residue times a constant. However, as perplexing as this may sound the algorithm is relatively simple and very efficient. + +Throughout this entire section the variable $n$ will represent the modulus used to form the residue. As will be discussed shortly the value of +$n$ must be odd. The variable $x$ will represent the quantity of which the residue is sought. Similar to the Barrett algorithm the input +is restricted to $0 \le x < n^2$. To begin the description some simple number theory facts must be established. + +\textbf{Fact 1.} Adding $n$ to $x$ does not change the residue since in effect it adds one to the quotient $\lfloor x / n \rfloor$. Another way +to explain this is that $n$ is (\textit{or multiples of $n$ are}) congruent to zero modulo $n$. Adding zero will not change the value of the residue. + +\textbf{Fact 2.} If $x$ is even then performing a division by two in $\Z$ is congruent to $x \cdot 2^{-1} \mbox{ (mod }n\mbox{)}$. Actually +this is an application of the fact that if $x$ is evenly divisible by any $k \in \Z$ then division in $\Z$ will be congruent to +multiplication by $k^{-1}$ modulo $n$. + +From these two simple facts the following simple algorithm can be derived. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{Montgomery Reduction}. \\ +\textbf{Input}. Integer $x$, $n$ and $k$ \\ +\textbf{Output}. $2^{-k}x \mbox{ (mod }n\mbox{)}$ \\ +\hline \\ +1. for $t$ from $1$ to $k$ do \\ +\hspace{3mm}1.1 If $x$ is odd then \\ +\hspace{6mm}1.1.1 $x \leftarrow x + n$ \\ +\hspace{3mm}1.2 $x \leftarrow x/2$ \\ +2. Return $x$. \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm Montgomery Reduction} +\end{figure} + +The algorithm reduces the input one bit at a time using the two congruencies stated previously. Inside the loop $n$, which is odd, is +added to $x$ if $x$ is odd. This forces $x$ to be even which allows the division by two in $\Z$ to be congruent to a modular division by two. Since +$x$ is assumed to be initially much larger than $n$ the addition of $n$ will contribute an insignificant magnitude to $x$. Let $r$ represent the +final result of the Montgomery algorithm. If $k > lg(n)$ and $0 \le x < n^2$ then the final result is limited to +$0 \le r < \lfloor x/2^k \rfloor + n$. As a result at most a single subtraction is required to get the residue desired. + +\begin{figure}[here] +\begin{small} +\begin{center} +\begin{tabular}{|c|l|} +\hline \textbf{Step number ($t$)} & \textbf{Result ($x$)} \\ +\hline $1$ & $x + n = 5812$, $x/2 = 2906$ \\ +\hline $2$ & $x/2 = 1453$ \\ +\hline $3$ & $x + n = 1710$, $x/2 = 855$ \\ +\hline $4$ & $x + n = 1112$, $x/2 = 556$ \\ +\hline $5$ & $x/2 = 278$ \\ +\hline $6$ & $x/2 = 139$ \\ +\hline $7$ & $x + n = 396$, $x/2 = 198$ \\ +\hline $8$ & $x/2 = 99$ \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Example of Montgomery Reduction (I)} +\label{fig:MONT1} +\end{figure} + +Consider the example in figure~\ref{fig:MONT1} which reduces $x = 5555$ modulo $n = 257$ when $k = 8$. The result of the algorithm $r = 99$ is +congruent to the value of $2^{-8} \cdot 5555 \mbox{ (mod }257\mbox{)}$. When $r$ is multiplied by $2^8$ modulo $257$ the correct residue +$r \equiv 158$ is produced. + +Let $k = \lfloor lg(n) \rfloor + 1$ represent the number of bits in $n$. The current algorithm requires $2k^2$ single precision shifts +and $k^2$ single precision additions. At this rate the algorithm is most certainly slower than Barrett reduction and not terribly useful. +Fortunately there exists an alternative representation of the algorithm. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{Montgomery Reduction} (modified I). \\ +\textbf{Input}. Integer $x$, $n$ and $k$ \\ +\textbf{Output}. $2^{-k}x \mbox{ (mod }n\mbox{)}$ \\ +\hline \\ +1. for $t$ from $0$ to $k - 1$ do \\ +\hspace{3mm}1.1 If the $t$'th bit of $x$ is one then \\ +\hspace{6mm}1.1.1 $x \leftarrow x + 2^tn$ \\ +2. Return $x/2^k$. \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm Montgomery Reduction (modified I)} +\end{figure} + +This algorithm is equivalent since $2^tn$ is a multiple of $n$ and the lower $k$ bits of $x$ are zero by step 2. The number of single +precision shifts has now been reduced from $2k^2$ to $k^2 + k$ which is only a small improvement. + +\begin{figure}[here] +\begin{small} +\begin{center} +\begin{tabular}{|c|l|r|} +\hline \textbf{Step number ($t$)} & \textbf{Result ($x$)} & \textbf{Result ($x$) in Binary} \\ +\hline -- & $5555$ & $1010110110011$ \\ +\hline $1$ & $x + 2^{0}n = 5812$ & $1011010110100$ \\ +\hline $2$ & $5812$ & $1011010110100$ \\ +\hline $3$ & $x + 2^{2}n = 6840$ & $1101010111000$ \\ +\hline $4$ & $x + 2^{3}n = 8896$ & $10001011000000$ \\ +\hline $5$ & $8896$ & $10001011000000$ \\ +\hline $6$ & $8896$ & $10001011000000$ \\ +\hline $7$ & $x + 2^{6}n = 25344$ & $110001100000000$ \\ +\hline $8$ & $25344$ & $110001100000000$ \\ +\hline -- & $x/2^k = 99$ & \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Example of Montgomery Reduction (II)} +\label{fig:MONT2} +\end{figure} + +Figure~\ref{fig:MONT2} demonstrates the modified algorithm reducing $x = 5555$ modulo $n = 257$ with $k = 8$. +With this algorithm a single shift right at the end is the only right shift required to reduce the input instead of $k$ right shifts inside the +loop. Note that for the iterations $t = 2, 5, 6$ and $8$ where the result $x$ is not changed. In those iterations the $t$'th bit of $x$ is +zero and the appropriate multiple of $n$ does not need to be added to force the $t$'th bit of the result to zero. + +\subsection{Digit Based Montgomery Reduction} +Instead of computing the reduction on a bit-by-bit basis it is actually much faster to compute it on digit-by-digit basis. Consider the +previous algorithm re-written to compute the Montgomery reduction in this new fashion. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{Montgomery Reduction} (modified II). \\ +\textbf{Input}. Integer $x$, $n$ and $k$ \\ +\textbf{Output}. $\beta^{-k}x \mbox{ (mod }n\mbox{)}$ \\ +\hline \\ +1. for $t$ from $0$ to $k - 1$ do \\ +\hspace{3mm}1.1 $x \leftarrow x + \mu n \beta^t$ \\ +2. Return $x/\beta^k$. \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm Montgomery Reduction (modified II)} +\end{figure} + +The value $\mu n \beta^t$ is a multiple of the modulus $n$ meaning that it will not change the residue. If the first digit of +the value $\mu n \beta^t$ equals the negative (modulo $\beta$) of the $t$'th digit of $x$ then the addition will result in a zero digit. This +problem breaks down to solving the following congruency. + +\begin{center} +\begin{tabular}{rcl} +$x_t + \mu n_0$ & $\equiv$ & $0 \mbox{ (mod }\beta\mbox{)}$ \\ +$\mu n_0$ & $\equiv$ & $-x_t \mbox{ (mod }\beta\mbox{)}$ \\ +$\mu$ & $\equiv$ & $-x_t/n_0 \mbox{ (mod }\beta\mbox{)}$ \\ +\end{tabular} +\end{center} + +In each iteration of the loop on step 1 a new value of $\mu$ must be calculated. The value of $-1/n_0 \mbox{ (mod }\beta\mbox{)}$ is used +extensively in this algorithm and should be precomputed. Let $\rho$ represent the negative of the modular inverse of $n_0$ modulo $\beta$. + +For example, let $\beta = 10$ represent the radix. Let $n = 17$ represent the modulus which implies $k = 2$ and $\rho \equiv 7$. Let $x = 33$ +represent the value to reduce. + +\newpage\begin{figure} +\begin{center} +\begin{tabular}{|c|c|c|} +\hline \textbf{Step ($t$)} & \textbf{Value of $x$} & \textbf{Value of $\mu$} \\ +\hline -- & $33$ & --\\ +\hline $0$ & $33 + \mu n = 50$ & $1$ \\ +\hline $1$ & $50 + \mu n \beta = 900$ & $5$ \\ +\hline +\end{tabular} +\end{center} +\caption{Example of Montgomery Reduction} +\end{figure} + +The final result $900$ is then divided by $\beta^k$ to produce the final result $9$. The first observation is that $9 \nequiv x \mbox{ (mod }n\mbox{)}$ +which implies the result is not the modular residue of $x$ modulo $n$. However, recall that the residue is actually multiplied by $\beta^{-k}$ in +the algorithm. To get the true residue the value must be multiplied by $\beta^k$. In this case $\beta^k \equiv 15 \mbox{ (mod }n\mbox{)}$ and +the correct residue is $9 \cdot 15 \equiv 16 \mbox{ (mod }n\mbox{)}$. + +\subsection{Baseline Montgomery Reduction} +The baseline Montgomery reduction algorithm will produce the residue for any size input. It is designed to be a catch-all algororithm for +Montgomery reductions. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_montgomery\_reduce}. \\ +\textbf{Input}. mp\_int $x$, mp\_int $n$ and a digit $\rho \equiv -1/n_0 \mbox{ (mod }n\mbox{)}$. \\ +\hspace{11.5mm}($0 \le x < n^2, n > 1, (n, \beta) = 1, \beta^k > n$) \\ +\textbf{Output}. $\beta^{-k}x \mbox{ (mod }n\mbox{)}$ \\ +\hline \\ +1. $digs \leftarrow 2n.used + 1$ \\ +2. If $digs < MP\_ARRAY$ and $m.used < \delta$ then \\ +\hspace{3mm}2.1 Use algorithm fast\_mp\_montgomery\_reduce instead. \\ +\\ +Setup $x$ for the reduction. \\ +3. If $x.alloc < digs$ then grow $x$ to $digs$ digits. \\ +4. $x.used \leftarrow digs$ \\ +\\ +Eliminate the lower $k$ digits. \\ +5. For $ix$ from $0$ to $k - 1$ do \\ +\hspace{3mm}5.1 $\mu \leftarrow x_{ix} \cdot \rho \mbox{ (mod }\beta\mbox{)}$ \\ +\hspace{3mm}5.2 $u \leftarrow 0$ \\ +\hspace{3mm}5.3 For $iy$ from $0$ to $k - 1$ do \\ +\hspace{6mm}5.3.1 $\hat r \leftarrow \mu n_{iy} + x_{ix + iy} + u$ \\ +\hspace{6mm}5.3.2 $x_{ix + iy} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\ +\hspace{6mm}5.3.3 $u \leftarrow \lfloor \hat r / \beta \rfloor$ \\ +\hspace{3mm}5.4 While $u > 0$ do \\ +\hspace{6mm}5.4.1 $iy \leftarrow iy + 1$ \\ +\hspace{6mm}5.4.2 $x_{ix + iy} \leftarrow x_{ix + iy} + u$ \\ +\hspace{6mm}5.4.3 $u \leftarrow \lfloor x_{ix+iy} / \beta \rfloor$ \\ +\hspace{6mm}5.4.4 $x_{ix + iy} \leftarrow x_{ix+iy} \mbox{ (mod }\beta\mbox{)}$ \\ +\\ +Divide by $\beta^k$ and fix up as required. \\ +6. $x \leftarrow \lfloor x / \beta^k \rfloor$ \\ +7. If $x \ge n$ then \\ +\hspace{3mm}7.1 $x \leftarrow x - n$ \\ +8. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_montgomery\_reduce} +\end{figure} + +\textbf{Algorithm mp\_montgomery\_reduce.} +This algorithm reduces the input $x$ modulo $n$ in place using the Montgomery reduction algorithm. The algorithm is loosely based +on algorithm 14.32 of \cite[pp.601]{HAC} except it merges the multiplication of $\mu n \beta^t$ with the addition in the inner loop. The +restrictions on this algorithm are fairly easy to adapt to. First $0 \le x < n^2$ bounds the input to numbers in the same range as +for the Barrett algorithm. Additionally if $n > 1$ and $n$ is odd there will exist a modular inverse $\rho$. $\rho$ must be calculated in +advance of this algorithm. Finally the variable $k$ is fixed and a pseudonym for $n.used$. + +Step 2 decides whether a faster Montgomery algorithm can be used. It is based on the Comba technique meaning that there are limits on +the size of the input. This algorithm is discussed in ~COMBARED~. + +Step 5 is the main reduction loop of the algorithm. The value of $\mu$ is calculated once per iteration in the outer loop. The inner loop +calculates $x + \mu n \beta^{ix}$ by multiplying $\mu n$ and adding the result to $x$ shifted by $ix$ digits. Both the addition and +multiplication are performed in the same loop to save time and memory. Step 5.4 will handle any additional carries that escape the inner loop. + +Using a quick inspection this algorithm requires $n$ single precision multiplications for the outer loop and $n^2$ single precision multiplications +in the inner loop. In total $n^2 + n$ single precision multiplications which compares favourably to Barrett at $n^2 + 2n - 1$ single precision +multiplications. + +EXAM,bn_mp_montgomery_reduce.c + +This is the baseline implementation of the Montgomery reduction algorithm. Lines @30,digs@ to @35,}@ determine if the Comba based +routine can be used instead. Line @47,mu@ computes the value of $\mu$ for that particular iteration of the outer loop. + +The multiplication $\mu n \beta^{ix}$ is performed in one step in the inner loop. The alias $tmpx$ refers to the $ix$'th digit of $x$ and +the alias $tmpn$ refers to the modulus $n$. + +\subsection{Faster ``Comba'' Montgomery Reduction} +MARK,COMBARED + +The Montgomery reduction requires fewer single precision multiplications than a Barrett reduction, however it is much slower due to the serial +nature of the inner loop. The Barrett reduction algorithm requires two slightly modified multipliers which can be implemented with the Comba +technique. The Montgomery reduction algorithm cannot directly use the Comba technique to any significant advantage since the inner loop calculates +a $k \times 1$ product $k$ times. + +The biggest obstacle is that at the $ix$'th iteration of the outer loop the value of $x_{ix}$ is required to calculate $\mu$. This means the +carries from $0$ to $ix - 1$ must have been propagated upwards to form a valid $ix$'th digit. The solution as it turns out is very simple. +Perform a Comba like multiplier and inside the outer loop just after the inner loop fix up the $ix + 1$'th digit by forwarding the carry. + +With this change in place the Montgomery reduction algorithm can be performed with a Comba style multiplication loop which substantially increases +the speed of the algorithm. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{fast\_mp\_montgomery\_reduce}. \\ +\textbf{Input}. mp\_int $x$, mp\_int $n$ and a digit $\rho \equiv -1/n_0 \mbox{ (mod }n\mbox{)}$. \\ +\hspace{11.5mm}($0 \le x < n^2, n > 1, (n, \beta) = 1, \beta^k > n$) \\ +\textbf{Output}. $\beta^{-k}x \mbox{ (mod }n\mbox{)}$ \\ +\hline \\ +Place an array of \textbf{MP\_WARRAY} mp\_word variables called $\hat W$ on the stack. \\ +1. if $x.alloc < n.used + 1$ then grow $x$ to $n.used + 1$ digits. \\ +Copy the digits of $x$ into the array $\hat W$ \\ +2. For $ix$ from $0$ to $x.used - 1$ do \\ +\hspace{3mm}2.1 $\hat W_{ix} \leftarrow x_{ix}$ \\ +3. For $ix$ from $x.used$ to $2n.used - 1$ do \\ +\hspace{3mm}3.1 $\hat W_{ix} \leftarrow 0$ \\ +Elimiate the lower $k$ digits. \\ +4. for $ix$ from $0$ to $n.used - 1$ do \\ +\hspace{3mm}4.1 $\mu \leftarrow \hat W_{ix} \cdot \rho \mbox{ (mod }\beta\mbox{)}$ \\ +\hspace{3mm}4.2 For $iy$ from $0$ to $n.used - 1$ do \\ +\hspace{6mm}4.2.1 $\hat W_{iy + ix} \leftarrow \hat W_{iy + ix} + \mu \cdot n_{iy}$ \\ +\hspace{3mm}4.3 $\hat W_{ix + 1} \leftarrow \hat W_{ix + 1} + \lfloor \hat W_{ix} / \beta \rfloor$ \\ +Propagate carries upwards. \\ +5. for $ix$ from $n.used$ to $2n.used + 1$ do \\ +\hspace{3mm}5.1 $\hat W_{ix + 1} \leftarrow \hat W_{ix + 1} + \lfloor \hat W_{ix} / \beta \rfloor$ \\ +Shift right and reduce modulo $\beta$ simultaneously. \\ +6. for $ix$ from $0$ to $n.used + 1$ do \\ +\hspace{3mm}6.1 $x_{ix} \leftarrow \hat W_{ix + n.used} \mbox{ (mod }\beta\mbox{)}$ \\ +Zero excess digits and fixup $x$. \\ +7. if $x.used > n.used + 1$ then do \\ +\hspace{3mm}7.1 for $ix$ from $n.used + 1$ to $x.used - 1$ do \\ +\hspace{6mm}7.1.1 $x_{ix} \leftarrow 0$ \\ +8. $x.used \leftarrow n.used + 1$ \\ +9. Clamp excessive digits of $x$. \\ +10. If $x \ge n$ then \\ +\hspace{3mm}10.1 $x \leftarrow x - n$ \\ +11. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm fast\_mp\_montgomery\_reduce} +\end{figure} + +\textbf{Algorithm fast\_mp\_montgomery\_reduce.} +This algorithm will compute the Montgomery reduction of $x$ modulo $n$ using the Comba technique. It is on most computer platforms significantly +faster than algorithm mp\_montgomery\_reduce and algorithm mp\_reduce (\textit{Barrett reduction}). The algorithm has the same restrictions +on the input as the baseline reduction algorithm. An additional two restrictions are imposed on this algorithm. The number of digits $k$ in the +the modulus $n$ must not violate $MP\_WARRAY > 2k +1$ and $n < \delta$. When $\beta = 2^{28}$ this algorithm can be used to reduce modulo +a modulus of at most $3,556$ bits in length. + +As in the other Comba reduction algorithms there is a $\hat W$ array which stores the columns of the product. It is initially filled with the +contents of $x$ with the excess digits zeroed. The reduction loop is very similar the to the baseline loop at heart. The multiplication on step +4.1 can be single precision only since $ab \mbox{ (mod }\beta\mbox{)} \equiv (a \mbox{ mod }\beta)(b \mbox{ mod }\beta)$. Some multipliers such +as those on the ARM processors take a variable length time to complete depending on the number of bytes of result it must produce. By performing +a single precision multiplication instead half the amount of time is spent. + +Also note that digit $\hat W_{ix}$ must have the carry from the $ix - 1$'th digit propagated upwards in order for this to work. That is what step +4.3 will do. In effect over the $n.used$ iterations of the outer loop the $n.used$'th lower columns all have the their carries propagated forwards. Note +how the upper bits of those same words are not reduced modulo $\beta$. This is because those values will be discarded shortly and there is no +point. + +Step 5 will propagate the remainder of the carries upwards. On step 6 the columns are reduced modulo $\beta$ and shifted simultaneously as they are +stored in the destination $x$. + +EXAM,bn_fast_mp_montgomery_reduce.c + +The $\hat W$ array is first filled with digits of $x$ on line @49,for@ then the rest of the digits are zeroed on line @54,for@. Both loops share +the same alias variables to make the code easier to read. + +The value of $\mu$ is calculated in an interesting fashion. First the value $\hat W_{ix}$ is reduced modulo $\beta$ and cast to a mp\_digit. This +forces the compiler to use a single precision multiplication and prevents any concerns about loss of precision. Line @101,>>@ fixes the carry +for the next iteration of the loop by propagating the carry from $\hat W_{ix}$ to $\hat W_{ix+1}$. + +The for loop on line @113,for@ propagates the rest of the carries upwards through the columns. The for loop on line @126,for@ reduces the columns +modulo $\beta$ and shifts them $k$ places at the same time. The alias $\_ \hat W$ actually refers to the array $\hat W$ starting at the $n.used$'th +digit, that is $\_ \hat W_{t} = \hat W_{n.used + t}$. + +\subsection{Montgomery Setup} +To calculate the variable $\rho$ a relatively simple algorithm will be required. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_montgomery\_setup}. \\ +\textbf{Input}. mp\_int $n$ ($n > 1$ and $(n, 2) = 1$) \\ +\textbf{Output}. $\rho \equiv -1/n_0 \mbox{ (mod }\beta\mbox{)}$ \\ +\hline \\ +1. $b \leftarrow n_0$ \\ +2. If $b$ is even return(\textit{MP\_VAL}) \\ +3. $x \leftarrow (((b + 2) \mbox{ AND } 4) << 1) + b$ \\ +4. for $k$ from 0 to $\lceil lg(lg(\beta)) \rceil - 2$ do \\ +\hspace{3mm}4.1 $x \leftarrow x \cdot (2 - bx)$ \\ +5. $\rho \leftarrow \beta - x \mbox{ (mod }\beta\mbox{)}$ \\ +6. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_montgomery\_setup} +\end{figure} + +\textbf{Algorithm mp\_montgomery\_setup.} +This algorithm will calculate the value of $\rho$ required within the Montgomery reduction algorithms. It uses a very interesting trick +to calculate $1/n_0$ when $\beta$ is a power of two. + +EXAM,bn_mp_montgomery_setup.c + +This source code computes the value of $\rho$ required to perform Montgomery reduction. It has been modified to avoid performing excess +multiplications when $\beta$ is not the default 28-bits. + +\section{The Diminished Radix Algorithm} +The Diminished Radix method of modular reduction \cite{DRMET} is a fairly clever technique which can be more efficient than either the Barrett +or Montgomery methods for certain forms of moduli. The technique is based on the following simple congruence. + +\begin{equation} +(x \mbox{ mod } n) + k \lfloor x / n \rfloor \equiv x \mbox{ (mod }(n - k)\mbox{)} +\end{equation} + +This observation was used in the MMB \cite{MMB} block cipher to create a diffusion primitive. It used the fact that if $n = 2^{31}$ and $k=1$ that +then a x86 multiplier could produce the 62-bit product and use the ``shrd'' instruction to perform a double-precision right shift. The proof +of the above equation is very simple. First write $x$ in the product form. + +\begin{equation} +x = qn + r +\end{equation} + +Now reduce both sides modulo $(n - k)$. + +\begin{equation} +x \equiv qk + r \mbox{ (mod }(n-k)\mbox{)} +\end{equation} + +The variable $n$ reduces modulo $n - k$ to $k$. By putting $q = \lfloor x/n \rfloor$ and $r = x \mbox{ mod } n$ +into the equation the original congruence is reproduced, thus concluding the proof. The following algorithm is based on this observation. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{Diminished Radix Reduction}. \\ +\textbf{Input}. Integer $x$, $n$, $k$ \\ +\textbf{Output}. $x \mbox{ mod } (n - k)$ \\ +\hline \\ +1. $q \leftarrow \lfloor x / n \rfloor$ \\ +2. $q \leftarrow k \cdot q$ \\ +3. $x \leftarrow x \mbox{ (mod }n\mbox{)}$ \\ +4. $x \leftarrow x + q$ \\ +5. If $x \ge (n - k)$ then \\ +\hspace{3mm}5.1 $x \leftarrow x - (n - k)$ \\ +\hspace{3mm}5.2 Goto step 1. \\ +6. Return $x$ \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm Diminished Radix Reduction} +\label{fig:DR} +\end{figure} + +This algorithm will reduce $x$ modulo $n - k$ and return the residue. If $0 \le x < (n - k)^2$ then the algorithm will loop almost always +once or twice and occasionally three times. For simplicity sake the value of $x$ is bounded by the following simple polynomial. + +\begin{equation} +0 \le x < n^2 + k^2 - 2nk +\end{equation} + +The true bound is $0 \le x < (n - k - 1)^2$ but this has quite a few more terms. The value of $q$ after step 1 is bounded by the following. + +\begin{equation} +q < n - 2k - k^2/n +\end{equation} + +Since $k^2$ is going to be considerably smaller than $n$ that term will always be zero. The value of $x$ after step 3 is bounded trivially as +$0 \le x < n$. By step four the sum $x + q$ is bounded by + +\begin{equation} +0 \le q + x < (k + 1)n - 2k^2 - 1 +\end{equation} + +With a second pass $q$ will be loosely bounded by $0 \le q < k^2$ after step 2 while $x$ will still be loosely bounded by $0 \le x < n$ after step 3. After the second pass it is highly unlike that the +sum in step 4 will exceed $n - k$. In practice fewer than three passes of the algorithm are required to reduce virtually every input in the +range $0 \le x < (n - k - 1)^2$. + +\begin{figure} +\begin{small} +\begin{center} +\begin{tabular}{|l|} +\hline +$x = 123456789, n = 256, k = 3$ \\ +\hline $q \leftarrow \lfloor x/n \rfloor = 482253$ \\ +$q \leftarrow q*k = 1446759$ \\ +$x \leftarrow x \mbox{ mod } n = 21$ \\ +$x \leftarrow x + q = 1446780$ \\ +$x \leftarrow x - (n - k) = 1446527$ \\ +\hline +$q \leftarrow \lfloor x/n \rfloor = 5650$ \\ +$q \leftarrow q*k = 16950$ \\ +$x \leftarrow x \mbox{ mod } n = 127$ \\ +$x \leftarrow x + q = 17077$ \\ +$x \leftarrow x - (n - k) = 16824$ \\ +\hline +$q \leftarrow \lfloor x/n \rfloor = 65$ \\ +$q \leftarrow q*k = 195$ \\ +$x \leftarrow x \mbox{ mod } n = 184$ \\ +$x \leftarrow x + q = 379$ \\ +$x \leftarrow x - (n - k) = 126$ \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Example Diminished Radix Reduction} +\label{fig:EXDR} +\end{figure} + +Figure~\ref{fig:EXDR} demonstrates the reduction of $x = 123456789$ modulo $n - k = 253$ when $n = 256$ and $k = 3$. Note that even while $x$ +is considerably larger than $(n - k - 1)^2 = 63504$ the algorithm still converges on the modular residue exceedingly fast. In this case only +three passes were required to find the residue $x \equiv 126$. + + +\subsection{Choice of Moduli} +On the surface this algorithm looks like a very expensive algorithm. It requires a couple of subtractions followed by multiplication and other +modular reductions. The usefulness of this algorithm becomes exceedingly clear when an appropriate modulus is chosen. + +Division in general is a very expensive operation to perform. The one exception is when the division is by a power of the radix of representation used. +Division by ten for example is simple for pencil and paper mathematics since it amounts to shifting the decimal place to the right. Similarly division +by two (\textit{or powers of two}) is very simple for binary computers to perform. It would therefore seem logical to choose $n$ of the form $2^p$ +which would imply that $\lfloor x / n \rfloor$ is a simple shift of $x$ right $p$ bits. + +However, there is one operation related to division of power of twos that is even faster than this. If $n = \beta^p$ then the division may be +performed by moving whole digits to the right $p$ places. In practice division by $\beta^p$ is much faster than division by $2^p$ for any $p$. +Also with the choice of $n = \beta^p$ reducing $x$ modulo $n$ merely requires zeroing the digits above the $p-1$'th digit of $x$. + +Throughout the next section the term ``restricted modulus'' will refer to a modulus of the form $\beta^p - k$ whereas the term ``unrestricted +modulus'' will refer to a modulus of the form $2^p - k$. The word ``restricted'' in this case refers to the fact that it is based on the +$2^p$ logic except $p$ must be a multiple of $lg(\beta)$. + +\subsection{Choice of $k$} +Now that division and reduction (\textit{step 1 and 3 of figure~\ref{fig:DR}}) have been optimized to simple digit operations the multiplication by $k$ +in step 2 is the most expensive operation. Fortunately the choice of $k$ is not terribly limited. For all intents and purposes it might +as well be a single digit. The smaller the value of $k$ is the faster the algorithm will be. + +\subsection{Restricted Diminished Radix Reduction} +The restricted Diminished Radix algorithm can quickly reduce an input modulo a modulus of the form $n = \beta^p - k$. This algorithm can reduce +an input $x$ within the range $0 \le x < n^2$ using only a couple passes of the algorithm demonstrated in figure~\ref{fig:DR}. The implementation +of this algorithm has been optimized to avoid additional overhead associated with a division by $\beta^p$, the multiplication by $k$ or the addition +of $x$ and $q$. The resulting algorithm is very efficient and can lead to substantial improvements over Barrett and Montgomery reduction when modular +exponentiations are performed. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_dr\_reduce}. \\ +\textbf{Input}. mp\_int $x$, $n$ and a mp\_digit $k = \beta - n_0$ \\ +\hspace{11.5mm}($0 \le x < n^2$, $n > 1$, $0 < k < \beta$) \\ +\textbf{Output}. $x \mbox{ mod } n$ \\ +\hline \\ +1. $m \leftarrow n.used$ \\ +2. If $x.alloc < 2m$ then grow $x$ to $2m$ digits. \\ +3. $\mu \leftarrow 0$ \\ +4. for $i$ from $0$ to $m - 1$ do \\ +\hspace{3mm}4.1 $\hat r \leftarrow k \cdot x_{m+i} + x_{i} + \mu$ \\ +\hspace{3mm}4.2 $x_{i} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\ +\hspace{3mm}4.3 $\mu \leftarrow \lfloor \hat r / \beta \rfloor$ \\ +5. $x_{m} \leftarrow \mu$ \\ +6. for $i$ from $m + 1$ to $x.used - 1$ do \\ +\hspace{3mm}6.1 $x_{i} \leftarrow 0$ \\ +7. Clamp excess digits of $x$. \\ +8. If $x \ge n$ then \\ +\hspace{3mm}8.1 $x \leftarrow x - n$ \\ +\hspace{3mm}8.2 Goto step 3. \\ +9. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_dr\_reduce} +\end{figure} + +\textbf{Algorithm mp\_dr\_reduce.} +This algorithm will perform the Dimished Radix reduction of $x$ modulo $n$. It has similar restrictions to that of the Barrett reduction +with the addition that $n$ must be of the form $n = \beta^m - k$ where $0 < k <\beta$. + +This algorithm essentially implements the pseudo-code in figure~\ref{fig:DR} except with a slight optimization. The division by $\beta^m$, multiplication by $k$ +and addition of $x \mbox{ mod }\beta^m$ are all performed simultaneously inside the loop on step 4. The division by $\beta^m$ is emulated by accessing +the term at the $m+i$'th position which is subsequently multiplied by $k$ and added to the term at the $i$'th position. After the loop the $m$'th +digit is set to the carry and the upper digits are zeroed. Steps 5 and 6 emulate the reduction modulo $\beta^m$ that should have happend to +$x$ before the addition of the multiple of the upper half. + +At step 8 if $x$ is still larger than $n$ another pass of the algorithm is required. First $n$ is subtracted from $x$ and then the algorithm resumes +at step 3. + +EXAM,bn_mp_dr_reduce.c + +The first step is to grow $x$ as required to $2m$ digits since the reduction is performed in place on $x$. The label on line @49,top:@ is where +the algorithm will resume if further reduction passes are required. In theory it could be placed at the top of the function however, the size of +the modulus and question of whether $x$ is large enough are invariant after the first pass meaning that it would be a waste of time. + +The aliases $tmpx1$ and $tmpx2$ refer to the digits of $x$ where the latter is offset by $m$ digits. By reading digits from $x$ offset by $m$ digits +a division by $\beta^m$ can be simulated virtually for free. The loop on line @61,for@ performs the bulk of the work (\textit{corresponds to step 4 of algorithm 7.11}) +in this algorithm. + +By line @68,mu@ the pointer $tmpx1$ points to the $m$'th digit of $x$ which is where the final carry will be placed. Similarly by line @71,for@ the +same pointer will point to the $m+1$'th digit where the zeroes will be placed. + +Since the algorithm is only valid if both $x$ and $n$ are greater than zero an unsigned comparison suffices to determine if another pass is required. +With the same logic at line @82,sub@ the value of $x$ is known to be greater than or equal to $n$ meaning that an unsigned subtraction can be used +as well. Since the destination of the subtraction is the larger of the inputs the call to algorithm s\_mp\_sub cannot fail and the return code +does not need to be checked. + +\subsubsection{Setup} +To setup the restricted Diminished Radix algorithm the value $k = \beta - n_0$ is required. This algorithm is not really complicated but provided for +completeness. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_dr\_setup}. \\ +\textbf{Input}. mp\_int $n$ \\ +\textbf{Output}. $k = \beta - n_0$ \\ +\hline \\ +1. $k \leftarrow \beta - n_0$ \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_dr\_setup} +\end{figure} + +EXAM,bn_mp_dr_setup.c + +\subsubsection{Modulus Detection} +Another algorithm which will be useful is the ability to detect a restricted Diminished Radix modulus. An integer is said to be +of restricted Diminished Radix form if all of the digits are equal to $\beta - 1$ except the trailing digit which may be any value. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_dr\_is\_modulus}. \\ +\textbf{Input}. mp\_int $n$ \\ +\textbf{Output}. $1$ if $n$ is in D.R form, $0$ otherwise \\ +\hline +1. If $n.used < 2$ then return($0$). \\ +2. for $ix$ from $1$ to $n.used - 1$ do \\ +\hspace{3mm}2.1 If $n_{ix} \ne \beta - 1$ return($0$). \\ +3. Return($1$). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_dr\_is\_modulus} +\end{figure} + +\textbf{Algorithm mp\_dr\_is\_modulus.} +This algorithm determines if a value is in Diminished Radix form. Step 1 rejects obvious cases where fewer than two digits are +in the mp\_int. Step 2 tests all but the first digit to see if they are equal to $\beta - 1$. If the algorithm manages to get to +step 3 then $n$ must be of Diminished Radix form. + +EXAM,bn_mp_dr_is_modulus.c + +\subsection{Unrestricted Diminished Radix Reduction} +The unrestricted Diminished Radix algorithm allows modular reductions to be performed when the modulus is of the form $2^p - k$. This algorithm +is a straightforward adaptation of algorithm~\ref{fig:DR}. + +In general the restricted Diminished Radix reduction algorithm is much faster since it has considerably lower overhead. However, this new +algorithm is much faster than either Montgomery or Barrett reduction when the moduli are of the appropriate form. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_reduce\_2k}. \\ +\textbf{Input}. mp\_int $a$ and $n$. mp\_digit $k$ \\ +\hspace{11.5mm}($a \ge 0$, $n > 1$, $0 < k < \beta$, $n + k$ is a power of two) \\ +\textbf{Output}. $a \mbox{ (mod }n\mbox{)}$ \\ +\hline +1. $p \leftarrow \lceil lg(n) \rceil$ (\textit{mp\_count\_bits}) \\ +2. While $a \ge n$ do \\ +\hspace{3mm}2.1 $q \leftarrow \lfloor a / 2^p \rfloor$ (\textit{mp\_div\_2d}) \\ +\hspace{3mm}2.2 $a \leftarrow a \mbox{ (mod }2^p\mbox{)}$ (\textit{mp\_mod\_2d}) \\ +\hspace{3mm}2.3 $q \leftarrow q \cdot k$ (\textit{mp\_mul\_d}) \\ +\hspace{3mm}2.4 $a \leftarrow a - q$ (\textit{s\_mp\_sub}) \\ +\hspace{3mm}2.5 If $a \ge n$ then do \\ +\hspace{6mm}2.5.1 $a \leftarrow a - n$ \\ +3. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_reduce\_2k} +\end{figure} + +\textbf{Algorithm mp\_reduce\_2k.} +This algorithm quickly reduces an input $a$ modulo an unrestricted Diminished Radix modulus $n$. Division by $2^p$ is emulated with a right +shift which makes the algorithm fairly inexpensive to use. + +EXAM,bn_mp_reduce_2k.c + +The algorithm mp\_count\_bits calculates the number of bits in an mp\_int which is used to find the initial value of $p$. The call to mp\_div\_2d +on line @31,mp_div_2d@ calculates both the quotient $q$ and the remainder $a$ required. By doing both in a single function call the code size +is kept fairly small. The multiplication by $k$ is only performed if $k > 1$. This allows reductions modulo $2^p - 1$ to be performed without +any multiplications. + +The unsigned s\_mp\_add, mp\_cmp\_mag and s\_mp\_sub are used in place of their full sign counterparts since the inputs are only valid if they are +positive. By using the unsigned versions the overhead is kept to a minimum. + +\subsubsection{Unrestricted Setup} +To setup this reduction algorithm the value of $k = 2^p - n$ is required. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_reduce\_2k\_setup}. \\ +\textbf{Input}. mp\_int $n$ \\ +\textbf{Output}. $k = 2^p - n$ \\ +\hline +1. $p \leftarrow \lceil lg(n) \rceil$ (\textit{mp\_count\_bits}) \\ +2. $x \leftarrow 2^p$ (\textit{mp\_2expt}) \\ +3. $x \leftarrow x - n$ (\textit{mp\_sub}) \\ +4. $k \leftarrow x_0$ \\ +5. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_reduce\_2k\_setup} +\end{figure} + +\textbf{Algorithm mp\_reduce\_2k\_setup.} +This algorithm computes the value of $k$ required for the algorithm mp\_reduce\_2k. By making a temporary variable $x$ equal to $2^p$ a subtraction +is sufficient to solve for $k$. Alternatively if $n$ has more than one digit the value of $k$ is simply $\beta - n_0$. + +EXAM,bn_mp_reduce_2k_setup.c + +\subsubsection{Unrestricted Detection} +An integer $n$ is a valid unrestricted Diminished Radix modulus if either of the following are true. + +\begin{enumerate} +\item The number has only one digit. +\item The number has more than one digit and every bit from the $\beta$'th to the most significant is one. +\end{enumerate} + +If either condition is true than there is a power of two $2^p$ such that $0 < 2^p - n < \beta$. If the input is only +one digit than it will always be of the correct form. Otherwise all of the bits above the first digit must be one. This arises from the fact +that there will be value of $k$ that when added to the modulus causes a carry in the first digit which propagates all the way to the most +significant bit. The resulting sum will be a power of two. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_reduce\_is\_2k}. \\ +\textbf{Input}. mp\_int $n$ \\ +\textbf{Output}. $1$ if of proper form, $0$ otherwise \\ +\hline +1. If $n.used = 0$ then return($0$). \\ +2. If $n.used = 1$ then return($1$). \\ +3. $p \leftarrow \lceil lg(n) \rceil$ (\textit{mp\_count\_bits}) \\ +4. for $x$ from $lg(\beta)$ to $p$ do \\ +\hspace{3mm}4.1 If the ($x \mbox{ mod }lg(\beta)$)'th bit of the $\lfloor x / lg(\beta) \rfloor$ of $n$ is zero then return($0$). \\ +5. Return($1$). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_reduce\_is\_2k} +\end{figure} + +\textbf{Algorithm mp\_reduce\_is\_2k.} +This algorithm quickly determines if a modulus is of the form required for algorithm mp\_reduce\_2k to function properly. + +EXAM,bn_mp_reduce_is_2k.c + + + +\section{Algorithm Comparison} +So far three very different algorithms for modular reduction have been discussed. Each of the algorithms have their own strengths and weaknesses +that makes having such a selection very useful. The following table sumarizes the three algorithms along with comparisons of work factors. Since +all three algorithms have the restriction that $0 \le x < n^2$ and $n > 1$ those limitations are not included in the table. + +\begin{center} +\begin{small} +\begin{tabular}{|c|c|c|c|c|c|} +\hline \textbf{Method} & \textbf{Work Required} & \textbf{Limitations} & \textbf{$m = 8$} & \textbf{$m = 32$} & \textbf{$m = 64$} \\ +\hline Barrett & $m^2 + 2m - 1$ & None & $79$ & $1087$ & $4223$ \\ +\hline Montgomery & $m^2 + m$ & $n$ must be odd & $72$ & $1056$ & $4160$ \\ +\hline D.R. & $2m$ & $n = \beta^m - k$ & $16$ & $64$ & $128$ \\ +\hline +\end{tabular} +\end{small} +\end{center} + +In theory Montgomery and Barrett reductions would require roughly the same amount of time to complete. However, in practice since Montgomery +reduction can be written as a single function with the Comba technique it is much faster. Barrett reduction suffers from the overhead of +calling the half precision multipliers, addition and division by $\beta$ algorithms. + +For almost every cryptographic algorithm Montgomery reduction is the algorithm of choice. The one set of algorithms where Diminished Radix reduction truly +shines are based on the discrete logarithm problem such as Diffie-Hellman \cite{DH} and ElGamal \cite{ELGAMAL}. In these algorithms +primes of the form $\beta^m - k$ can be found and shared amongst users. These primes will allow the Diminished Radix algorithm to be used in +modular exponentiation to greatly speed up the operation. + + + +\section*{Exercises} +\begin{tabular}{cl} +$\left [ 3 \right ]$ & Prove that the ``trick'' in algorithm mp\_montgomery\_setup actually \\ + & calculates the correct value of $\rho$. \\ + & \\ +$\left [ 2 \right ]$ & Devise an algorithm to reduce modulo $n + k$ for small $k$ quickly. \\ + & \\ +$\left [ 4 \right ]$ & Prove that the pseudo-code algorithm ``Diminished Radix Reduction'' \\ + & (\textit{figure~\ref{fig:DR}}) terminates. Also prove the probability that it will \\ + & terminate within $1 \le k \le 10$ iterations. \\ + & \\ +\end{tabular} + + +\chapter{Exponentiation} +Exponentiation is the operation of raising one variable to the power of another, for example, $a^b$. A variant of exponentiation, computed +in a finite field or ring, is called modular exponentiation. This latter style of operation is typically used in public key +cryptosystems such as RSA and Diffie-Hellman. The ability to quickly compute modular exponentiations is of great benefit to any +such cryptosystem and many methods have been sought to speed it up. + +\section{Exponentiation Basics} +A trivial algorithm would simply multiply $a$ against itself $b - 1$ times to compute the exponentiation desired. However, as $b$ grows in size +the number of multiplications becomes prohibitive. Imagine what would happen if $b$ $\approx$ $2^{1024}$ as is the case when computing an RSA signature +with a $1024$-bit key. Such a calculation could never be completed as it would take simply far too long. + +Fortunately there is a very simple algorithm based on the laws of exponents. Recall that $lg_a(a^b) = b$ and that $lg_a(a^ba^c) = b + c$ which +are two trivial relationships between the base and the exponent. Let $b_i$ represent the $i$'th bit of $b$ starting from the least +significant bit. If $b$ is a $k$-bit integer than the following equation is true. + +\begin{equation} +a^b = \prod_{i=0}^{k-1} a^{2^i \cdot b_i} +\end{equation} + +By taking the base $a$ logarithm of both sides of the equation the following equation is the result. + +\begin{equation} +b = \sum_{i=0}^{k-1}2^i \cdot b_i +\end{equation} + +The term $a^{2^i}$ can be found from the $i - 1$'th term by squaring the term since $\left ( a^{2^i} \right )^2$ is equal to +$a^{2^{i+1}}$. This observation forms the basis of essentially all fast exponentiation algorithms. It requires $k$ squarings and on average +$k \over 2$ multiplications to compute the result. This is indeed quite an improvement over simply multiplying by $a$ a total of $b-1$ times. + +While this current method is a considerable speed up there are further improvements to be made. For example, the $a^{2^i}$ term does not need to +be computed in an auxilary variable. Consider the following equivalent algorithm. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{Left to Right Exponentiation}. \\ +\textbf{Input}. Integer $a$, $b$ and $k$ \\ +\textbf{Output}. $c = a^b$ \\ +\hline \\ +1. $c \leftarrow 1$ \\ +2. for $i$ from $k - 1$ to $0$ do \\ +\hspace{3mm}2.1 $c \leftarrow c^2$ \\ +\hspace{3mm}2.2 $c \leftarrow c \cdot a^{b_i}$ \\ +3. Return $c$. \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Left to Right Exponentiation} +\label{fig:LTOR} +\end{figure} + +This algorithm starts from the most significant bit and works towards the least significant bit. When the $i$'th bit of $b$ is set $a$ is +multiplied against the current product. In each iteration the product is squared which doubles the exponent of the individual terms of the +product. + +For example, let $b = 101100_2 \equiv 44_{10}$. The following chart demonstrates the actions of the algorithm. + +\newpage\begin{figure} +\begin{center} +\begin{tabular}{|c|c|} +\hline \textbf{Value of $i$} & \textbf{Value of $c$} \\ +\hline - & $1$ \\ +\hline $5$ & $a$ \\ +\hline $4$ & $a^2$ \\ +\hline $3$ & $a^4 \cdot a$ \\ +\hline $2$ & $a^8 \cdot a^2 \cdot a$ \\ +\hline $1$ & $a^{16} \cdot a^4 \cdot a^2$ \\ +\hline $0$ & $a^{32} \cdot a^8 \cdot a^4$ \\ +\hline +\end{tabular} +\end{center} +\caption{Example of Left to Right Exponentiation} +\end{figure} + +When the product $a^{32} \cdot a^8 \cdot a^4$ is simplified it is equal $a^{44}$ which is the desired exponentiation. This particular algorithm is +called ``Left to Right'' because it reads the exponent in that order. All of the exponentiation algorithms that will be presented are of this nature. + +\subsection{Single Digit Exponentiation} +The first algorithm in the series of exponentiation algorithms will be an unbounded algorithm where the exponent is a single digit. It is intended +to be used when a small power of an input is required (\textit{e.g. $a^5$}). It is faster than simply multiplying $b - 1$ times for all values of +$b$ that are greater than three. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_expt\_d}. \\ +\textbf{Input}. mp\_int $a$ and mp\_digit $b$ \\ +\textbf{Output}. $c = a^b$ \\ +\hline \\ +1. $g \leftarrow a$ (\textit{mp\_init\_copy}) \\ +2. $c \leftarrow 1$ (\textit{mp\_set}) \\ +3. for $x$ from 1 to $lg(\beta)$ do \\ +\hspace{3mm}3.1 $c \leftarrow c^2$ (\textit{mp\_sqr}) \\ +\hspace{3mm}3.2 If $b$ AND $2^{lg(\beta) - 1} \ne 0$ then \\ +\hspace{6mm}3.2.1 $c \leftarrow c \cdot g$ (\textit{mp\_mul}) \\ +\hspace{3mm}3.3 $b \leftarrow b << 1$ \\ +4. Clear $g$. \\ +5. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_expt\_d} +\end{figure} + +\textbf{Algorithm mp\_expt\_d.} +This algorithm computes the value of $a$ raised to the power of a single digit $b$. It uses the left to right exponentiation algorithm to +quickly compute the exponentiation. It is loosely based on algorithm 14.79 of HAC \cite[pp. 615]{HAC} with the difference that the +exponent is a fixed width. + +A copy of $a$ is made first to allow destination variable $c$ be the same as the source variable $a$. The result is set to the initial value of +$1$ in the subsequent step. + +Inside the loop the exponent is read from the most significant bit first down to the least significant bit. First $c$ is invariably squared +on step 3.1. In the following step if the most significant bit of $b$ is one the copy of $a$ is multiplied against $c$. The value +of $b$ is shifted left one bit to make the next bit down from the most signficant bit the new most significant bit. In effect each +iteration of the loop moves the bits of the exponent $b$ upwards to the most significant location. + +EXAM,bn_mp_expt_d.c + +Line @29,mp_set@ sets the initial value of the result to $1$. Next the loop on line @31,for@ steps through each bit of the exponent starting from +the most significant down towards the least significant. The invariant squaring operation placed on line @333,mp_sqr@ is performed first. After +the squaring the result $c$ is multiplied by the base $g$ if and only if the most significant bit of the exponent is set. The shift on line +@47,<<@ moves all of the bits of the exponent upwards towards the most significant location. + +\section{$k$-ary Exponentiation} +When calculating an exponentiation the most time consuming bottleneck is the multiplications which are in general a small factor +slower than squaring. Recall from the previous algorithm that $b_{i}$ refers to the $i$'th bit of the exponent $b$. Suppose instead it referred to +the $i$'th $k$-bit digit of the exponent of $b$. For $k = 1$ the definitions are synonymous and for $k > 1$ algorithm~\ref{fig:KARY} +computes the same exponentiation. A group of $k$ bits from the exponent is called a \textit{window}. That is it is a small window on only a +portion of the entire exponent. Consider the following modification to the basic left to right exponentiation algorithm. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{$k$-ary Exponentiation}. \\ +\textbf{Input}. Integer $a$, $b$, $k$ and $t$ \\ +\textbf{Output}. $c = a^b$ \\ +\hline \\ +1. $c \leftarrow 1$ \\ +2. for $i$ from $t - 1$ to $0$ do \\ +\hspace{3mm}2.1 $c \leftarrow c^{2^k} $ \\ +\hspace{3mm}2.2 Extract the $i$'th $k$-bit word from $b$ and store it in $g$. \\ +\hspace{3mm}2.3 $c \leftarrow c \cdot a^g$ \\ +3. Return $c$. \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{$k$-ary Exponentiation} +\label{fig:KARY} +\end{figure} + +The squaring on step 2.1 can be calculated by squaring the value $c$ successively $k$ times. If the values of $a^g$ for $0 < g < 2^k$ have been +precomputed this algorithm requires only $t$ multiplications and $tk$ squarings. The table can be generated with $2^{k - 1} - 1$ squarings and +$2^{k - 1} + 1$ multiplications. This algorithm assumes that the number of bits in the exponent is evenly divisible by $k$. +However, when it is not the remaining $0 < x \le k - 1$ bits can be handled with algorithm~\ref{fig:LTOR}. + +Suppose $k = 4$ and $t = 100$. This modified algorithm will require $109$ multiplications and $408$ squarings to compute the exponentiation. The +original algorithm would on average have required $200$ multiplications and $400$ squrings to compute the same value. The total number of squarings +has increased slightly but the number of multiplications has nearly halved. + +\subsection{Optimal Values of $k$} +An optimal value of $k$ will minimize $2^{k} + \lceil n / k \rceil + n - 1$ for a fixed number of bits in the exponent $n$. The simplest +approach is to brute force search amongst the values $k = 2, 3, \ldots, 8$ for the lowest result. Table~\ref{fig:OPTK} lists optimal values of $k$ +for various exponent sizes and compares the number of multiplication and squarings required against algorithm~\ref{fig:LTOR}. + +\begin{figure}[here] +\begin{center} +\begin{small} +\begin{tabular}{|c|c|c|c|c|c|} +\hline \textbf{Exponent (bits)} & \textbf{Optimal $k$} & \textbf{Work at $k$} & \textbf{Work with ~\ref{fig:LTOR}} \\ +\hline $16$ & $2$ & $27$ & $24$ \\ +\hline $32$ & $3$ & $49$ & $48$ \\ +\hline $64$ & $3$ & $92$ & $96$ \\ +\hline $128$ & $4$ & $175$ & $192$ \\ +\hline $256$ & $4$ & $335$ & $384$ \\ +\hline $512$ & $5$ & $645$ & $768$ \\ +\hline $1024$ & $6$ & $1257$ & $1536$ \\ +\hline $2048$ & $6$ & $2452$ & $3072$ \\ +\hline $4096$ & $7$ & $4808$ & $6144$ \\ +\hline +\end{tabular} +\end{small} +\end{center} +\caption{Optimal Values of $k$ for $k$-ary Exponentiation} +\label{fig:OPTK} +\end{figure} + +\subsection{Sliding-Window Exponentiation} +A simple modification to the previous algorithm is only generate the upper half of the table in the range $2^{k-1} \le g < 2^k$. Essentially +this is a table for all values of $g$ where the most significant bit of $g$ is a one. However, in order for this to be allowed in the +algorithm values of $g$ in the range $0 \le g < 2^{k-1}$ must be avoided. + +Table~\ref{fig:OPTK2} lists optimal values of $k$ for various exponent sizes and compares the work required against algorithm~\ref{fig:KARY}. + +\begin{figure}[here] +\begin{center} +\begin{small} +\begin{tabular}{|c|c|c|c|c|c|} +\hline \textbf{Exponent (bits)} & \textbf{Optimal $k$} & \textbf{Work at $k$} & \textbf{Work with ~\ref{fig:KARY}} \\ +\hline $16$ & $3$ & $24$ & $27$ \\ +\hline $32$ & $3$ & $45$ & $49$ \\ +\hline $64$ & $4$ & $87$ & $92$ \\ +\hline $128$ & $4$ & $167$ & $175$ \\ +\hline $256$ & $5$ & $322$ & $335$ \\ +\hline $512$ & $6$ & $628$ & $645$ \\ +\hline $1024$ & $6$ & $1225$ & $1257$ \\ +\hline $2048$ & $7$ & $2403$ & $2452$ \\ +\hline $4096$ & $8$ & $4735$ & $4808$ \\ +\hline +\end{tabular} +\end{small} +\end{center} +\caption{Optimal Values of $k$ for Sliding Window Exponentiation} +\label{fig:OPTK2} +\end{figure} + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{Sliding Window $k$-ary Exponentiation}. \\ +\textbf{Input}. Integer $a$, $b$, $k$ and $t$ \\ +\textbf{Output}. $c = a^b$ \\ +\hline \\ +1. $c \leftarrow 1$ \\ +2. for $i$ from $t - 1$ to $0$ do \\ +\hspace{3mm}2.1 If the $i$'th bit of $b$ is a zero then \\ +\hspace{6mm}2.1.1 $c \leftarrow c^2$ \\ +\hspace{3mm}2.2 else do \\ +\hspace{6mm}2.2.1 $c \leftarrow c^{2^k}$ \\ +\hspace{6mm}2.2.2 Extract the $k$ bits from $(b_{i}b_{i-1}\ldots b_{i-(k-1)})$ and store it in $g$. \\ +\hspace{6mm}2.2.3 $c \leftarrow c \cdot a^g$ \\ +\hspace{6mm}2.2.4 $i \leftarrow i - k$ \\ +3. Return $c$. \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Sliding Window $k$-ary Exponentiation} +\end{figure} + +Similar to the previous algorithm this algorithm must have a special handler when fewer than $k$ bits are left in the exponent. While this +algorithm requires the same number of squarings it can potentially have fewer multiplications. The pre-computed table $a^g$ is also half +the size as the previous table. + +Consider the exponent $b = 111101011001000_2 \equiv 31432_{10}$ with $k = 3$ using both algorithms. The first algorithm will divide the exponent up as +the following five $3$-bit words $b \equiv \left ( 111, 101, 011, 001, 000 \right )_{2}$. The second algorithm will break the +exponent as $b \equiv \left ( 111, 101, 0, 110, 0, 100, 0 \right )_{2}$. The single digit $0$ in the second representation are where +a single squaring took place instead of a squaring and multiplication. In total the first method requires $10$ multiplications and $18$ +squarings. The second method requires $8$ multiplications and $18$ squarings. + +In general the sliding window method is never slower than the generic $k$-ary method and often it is slightly faster. + +\section{Modular Exponentiation} + +Modular exponentiation is essentially computing the power of a base within a finite field or ring. For example, computing +$d \equiv a^b \mbox{ (mod }c\mbox{)}$ is a modular exponentiation. Instead of first computing $a^b$ and then reducing it +modulo $c$ the intermediate result is reduced modulo $c$ after every squaring or multiplication operation. + +This guarantees that any intermediate result is bounded by $0 \le d \le c^2 - 2c + 1$ and can be reduced modulo $c$ quickly using +one of the algorithms presented in ~REDUCTION~. + +Before the actual modular exponentiation algorithm can be written a wrapper algorithm must be written first. This algorithm +will allow the exponent $b$ to be negative which is computed as $c \equiv \left (1 / a \right )^{\vert b \vert} \mbox{(mod }d\mbox{)}$. The +value of $(1/a) \mbox{ mod }c$ is computed using the modular inverse (\textit{see \ref{sec;modinv}}). If no inverse exists the algorithm +terminates with an error. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_exptmod}. \\ +\textbf{Input}. mp\_int $a$, $b$ and $c$ \\ +\textbf{Output}. $y \equiv g^x \mbox{ (mod }p\mbox{)}$ \\ +\hline \\ +1. If $c.sign = MP\_NEG$ return(\textit{MP\_VAL}). \\ +2. If $b.sign = MP\_NEG$ then \\ +\hspace{3mm}2.1 $g' \leftarrow g^{-1} \mbox{ (mod }c\mbox{)}$ \\ +\hspace{3mm}2.2 $x' \leftarrow \vert x \vert$ \\ +\hspace{3mm}2.3 Compute $d \equiv g'^{x'} \mbox{ (mod }c\mbox{)}$ via recursion. \\ +3. if $p$ is odd \textbf{OR} $p$ is a D.R. modulus then \\ +\hspace{3mm}3.1 Compute $y \equiv g^{x} \mbox{ (mod }p\mbox{)}$ via algorithm mp\_exptmod\_fast. \\ +4. else \\ +\hspace{3mm}4.1 Compute $y \equiv g^{x} \mbox{ (mod }p\mbox{)}$ via algorithm s\_mp\_exptmod. \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_exptmod} +\end{figure} + +\textbf{Algorithm mp\_exptmod.} +The first algorithm which actually performs modular exponentiation is algorithm s\_mp\_exptmod. It is a sliding window $k$-ary algorithm +which uses Barrett reduction to reduce the product modulo $p$. The second algorithm mp\_exptmod\_fast performs the same operation +except it uses either Montgomery or Diminished Radix reduction. The two latter reduction algorithms are clumped in the same exponentiation +algorithm since their arguments are essentially the same (\textit{two mp\_ints and one mp\_digit}). + +EXAM,bn_mp_exptmod.c + +In order to keep the algorithms in a known state the first step on line @29,if@ is to reject any negative modulus as input. If the exponent is +negative the algorithm tries to perform a modular exponentiation with the modular inverse of the base $G$. The temporary variable $tmpG$ is assigned +the modular inverse of $G$ and $tmpX$ is assigned the absolute value of $X$. The algorithm will recuse with these new values with a positive +exponent. + +If the exponent is positive the algorithm resumes the exponentiation. Line @63,dr_@ determines if the modulus is of the restricted Diminished Radix +form. If it is not line @65,reduce@ attempts to determine if it is of a unrestricted Diminished Radix form. The integer $dr$ will take on one +of three values. + +\begin{enumerate} +\item $dr = 0$ means that the modulus is not of either restricted or unrestricted Diminished Radix form. +\item $dr = 1$ means that the modulus is of restricted Diminished Radix form. +\item $dr = 2$ means that the modulus is of unrestricted Diminished Radix form. +\end{enumerate} + +Line @69,if@ determines if the fast modular exponentiation algorithm can be used. It is allowed if $dr \ne 0$ or if the modulus is odd. Otherwise, +the slower s\_mp\_exptmod algorithm is used which uses Barrett reduction. + +\subsection{Barrett Modular Exponentiation} + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{s\_mp\_exptmod}. \\ +\textbf{Input}. mp\_int $a$, $b$ and $c$ \\ +\textbf{Output}. $y \equiv g^x \mbox{ (mod }p\mbox{)}$ \\ +\hline \\ +1. $k \leftarrow lg(x)$ \\ +2. $winsize \leftarrow \left \lbrace \begin{array}{ll} + 2 & \mbox{if }k \le 7 \\ + 3 & \mbox{if }7 < k \le 36 \\ + 4 & \mbox{if }36 < k \le 140 \\ + 5 & \mbox{if }140 < k \le 450 \\ + 6 & \mbox{if }450 < k \le 1303 \\ + 7 & \mbox{if }1303 < k \le 3529 \\ + 8 & \mbox{if }3529 < k \\ + \end{array} \right .$ \\ +3. Initialize $2^{winsize}$ mp\_ints in an array named $M$ and one mp\_int named $\mu$ \\ +4. Calculate the $\mu$ required for Barrett Reduction (\textit{mp\_reduce\_setup}). \\ +5. $M_1 \leftarrow g \mbox{ (mod }p\mbox{)}$ \\ +\\ +Setup the table of small powers of $g$. First find $g^{2^{winsize}}$ and then all multiples of it. \\ +6. $k \leftarrow 2^{winsize - 1}$ \\ +7. $M_{k} \leftarrow M_1$ \\ +8. for $ix$ from 0 to $winsize - 2$ do \\ +\hspace{3mm}8.1 $M_k \leftarrow \left ( M_k \right )^2$ (\textit{mp\_sqr}) \\ +\hspace{3mm}8.2 $M_k \leftarrow M_k \mbox{ (mod }p\mbox{)}$ (\textit{mp\_reduce}) \\ +9. for $ix$ from $2^{winsize - 1} + 1$ to $2^{winsize} - 1$ do \\ +\hspace{3mm}9.1 $M_{ix} \leftarrow M_{ix - 1} \cdot M_{1}$ (\textit{mp\_mul}) \\ +\hspace{3mm}9.2 $M_{ix} \leftarrow M_{ix} \mbox{ (mod }p\mbox{)}$ (\textit{mp\_reduce}) \\ +10. $res \leftarrow 1$ \\ +\\ +Start Sliding Window. \\ +11. $mode \leftarrow 0, bitcnt \leftarrow 1, buf \leftarrow 0, digidx \leftarrow x.used - 1, bitcpy \leftarrow 0, bitbuf \leftarrow 0$ \\ +12. Loop \\ +\hspace{3mm}12.1 $bitcnt \leftarrow bitcnt - 1$ \\ +\hspace{3mm}12.2 If $bitcnt = 0$ then do \\ +\hspace{6mm}12.2.1 If $digidx = -1$ goto step 13. \\ +\hspace{6mm}12.2.2 $buf \leftarrow x_{digidx}$ \\ +\hspace{6mm}12.2.3 $digidx \leftarrow digidx - 1$ \\ +\hspace{6mm}12.2.4 $bitcnt \leftarrow lg(\beta)$ \\ +Continued on next page. \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm s\_mp\_exptmod} +\end{figure} + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{s\_mp\_exptmod} (\textit{continued}). \\ +\textbf{Input}. mp\_int $a$, $b$ and $c$ \\ +\textbf{Output}. $y \equiv g^x \mbox{ (mod }p\mbox{)}$ \\ +\hline \\ +\hspace{3mm}12.3 $y \leftarrow (buf >> (lg(\beta) - 1))$ AND $1$ \\ +\hspace{3mm}12.4 $buf \leftarrow buf << 1$ \\ +\hspace{3mm}12.5 if $mode = 0$ and $y = 0$ then goto step 12. \\ +\hspace{3mm}12.6 if $mode = 1$ and $y = 0$ then do \\ +\hspace{6mm}12.6.1 $res \leftarrow res^2$ \\ +\hspace{6mm}12.6.2 $res \leftarrow res \mbox{ (mod }p\mbox{)}$ \\ +\hspace{6mm}12.6.3 Goto step 12. \\ +\hspace{3mm}12.7 $bitcpy \leftarrow bitcpy + 1$ \\ +\hspace{3mm}12.8 $bitbuf \leftarrow bitbuf + (y << (winsize - bitcpy))$ \\ +\hspace{3mm}12.9 $mode \leftarrow 2$ \\ +\hspace{3mm}12.10 If $bitcpy = winsize$ then do \\ +\hspace{6mm}Window is full so perform the squarings and single multiplication. \\ +\hspace{6mm}12.10.1 for $ix$ from $0$ to $winsize -1$ do \\ +\hspace{9mm}12.10.1.1 $res \leftarrow res^2$ \\ +\hspace{9mm}12.10.1.2 $res \leftarrow res \mbox{ (mod }p\mbox{)}$ \\ +\hspace{6mm}12.10.2 $res \leftarrow res \cdot M_{bitbuf}$ \\ +\hspace{6mm}12.10.3 $res \leftarrow res \mbox{ (mod }p\mbox{)}$ \\ +\hspace{6mm}Reset the window. \\ +\hspace{6mm}12.10.4 $bitcpy \leftarrow 0, bitbuf \leftarrow 0, mode \leftarrow 1$ \\ +\\ +No more windows left. Check for residual bits of exponent. \\ +13. If $mode = 2$ and $bitcpy > 0$ then do \\ +\hspace{3mm}13.1 for $ix$ form $0$ to $bitcpy - 1$ do \\ +\hspace{6mm}13.1.1 $res \leftarrow res^2$ \\ +\hspace{6mm}13.1.2 $res \leftarrow res \mbox{ (mod }p\mbox{)}$ \\ +\hspace{6mm}13.1.3 $bitbuf \leftarrow bitbuf << 1$ \\ +\hspace{6mm}13.1.4 If $bitbuf$ AND $2^{winsize} \ne 0$ then do \\ +\hspace{9mm}13.1.4.1 $res \leftarrow res \cdot M_{1}$ \\ +\hspace{9mm}13.1.4.2 $res \leftarrow res \mbox{ (mod }p\mbox{)}$ \\ +14. $y \leftarrow res$ \\ +15. Clear $res$, $mu$ and the $M$ array. \\ +16. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm s\_mp\_exptmod (continued)} +\end{figure} + +\textbf{Algorithm s\_mp\_exptmod.} +This algorithm computes the $x$'th power of $g$ modulo $p$ and stores the result in $y$. It takes advantage of the Barrett reduction +algorithm to keep the product small throughout the algorithm. + +The first two steps determine the optimal window size based on the number of bits in the exponent. The larger the exponent the +larger the window size becomes. After a window size $winsize$ has been chosen an array of $2^{winsize}$ mp\_int variables is allocated. This +table will hold the values of $g^x \mbox{ (mod }p\mbox{)}$ for $2^{winsize - 1} \le x < 2^{winsize}$. + +After the table is allocated the first power of $g$ is found. Since $g \ge p$ is allowed it must be first reduced modulo $p$ to make +the rest of the algorithm more efficient. The first element of the table at $2^{winsize - 1}$ is found by squaring $M_1$ successively $winsize - 2$ +times. The rest of the table elements are found by multiplying the previous element by $M_1$ modulo $p$. + +Now that the table is available the sliding window may begin. The following list describes the functions of all the variables in the window. +\begin{enumerate} +\item The variable $mode$ dictates how the bits of the exponent are interpreted. +\begin{enumerate} + \item When $mode = 0$ the bits are ignored since no non-zero bit of the exponent has been seen yet. For example, if the exponent were simply + $1$ then there would be $lg(\beta) - 1$ zero bits before the first non-zero bit. In this case bits are ignored until a non-zero bit is found. + \item When $mode = 1$ a non-zero bit has been seen before and a new $winsize$-bit window has not been formed yet. In this mode leading $0$ bits + are read and a single squaring is performed. If a non-zero bit is read a new window is created. + \item When $mode = 2$ the algorithm is in the middle of forming a window and new bits are appended to the window from the most significant bit + downwards. +\end{enumerate} +\item The variable $bitcnt$ indicates how many bits are left in the current digit of the exponent left to be read. When it reaches zero a new digit + is fetched from the exponent. +\item The variable $buf$ holds the currently read digit of the exponent. +\item The variable $digidx$ is an index into the exponents digits. It starts at the leading digit $x.used - 1$ and moves towards the trailing digit. +\item The variable $bitcpy$ indicates how many bits are in the currently formed window. When it reaches $winsize$ the window is flushed and + the appropriate operations performed. +\item The variable $bitbuf$ holds the current bits of the window being formed. +\end{enumerate} + +All of step 12 is the window processing loop. It will iterate while there are digits available form the exponent to read. The first step +inside this loop is to extract a new digit if no more bits are available in the current digit. If there are no bits left a new digit is +read and if there are no digits left than the loop terminates. + +After a digit is made available step 12.3 will extract the most significant bit of the current digit and move all other bits in the digit +upwards. In effect the digit is read from most significant bit to least significant bit and since the digits are read from leading to +trailing edges the entire exponent is read from most significant bit to least significant bit. + +At step 12.5 if the $mode$ and currently extracted bit $y$ are both zero the bit is ignored and the next bit is read. This prevents the +algorithm from having to perform trivial squaring and reduction operations before the first non-zero bit is read. Step 12.6 and 12.7-10 handle +the two cases of $mode = 1$ and $mode = 2$ respectively. + +FIGU,expt_state,Sliding Window State Diagram + +By step 13 there are no more digits left in the exponent. However, there may be partial bits in the window left. If $mode = 2$ then +a Left-to-Right algorithm is used to process the remaining few bits. + +EXAM,bn_s_mp_exptmod.c + +Lines @26,if@ through @40,}@ determine the optimal window size based on the length of the exponent in bits. The window divisions are sorted +from smallest to greatest so that in each \textbf{if} statement only one condition must be tested. For example, by the \textbf{if} statement +on line @32,if@ the value of $x$ is already known to be greater than $140$. + +The conditional piece of code beginning on line @42,ifdef@ allows the window size to be restricted to five bits. This logic is used to ensure +the table of precomputed powers of $G$ remains relatively small. + +The for loop on line @49,for@ initializes the $M$ array while lines @59,mp_init@ and @62,mp_reduce@ compute the value of $\mu$ required for +Barrett reduction. + +-- More later. + +\section{Quick Power of Two} +Calculating $b = 2^a$ can be performed much quicker than with any of the previous algorithms. Recall that a logical shift left $m << k$ is +equivalent to $m \cdot 2^k$. By this logic when $m = 1$ a quick power of two can be achieved. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_2expt}. \\ +\textbf{Input}. integer $b$ \\ +\textbf{Output}. $a \leftarrow 2^b$ \\ +\hline \\ +1. $a \leftarrow 0$ \\ +2. If $a.alloc < \lfloor b / lg(\beta) \rfloor + 1$ then grow $a$ appropriately. \\ +3. $a.used \leftarrow \lfloor b / lg(\beta) \rfloor + 1$ \\ +4. $a_{\lfloor b / lg(\beta) \rfloor} \leftarrow 1 << (b \mbox{ mod } lg(\beta))$ \\ +5. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_2expt} +\end{figure} + +\textbf{Algorithm mp\_2expt.} + +EXAM,bn_mp_2expt.c + +\chapter{Higher Level Algorithms} + +This chapter discusses the various higher level algorithms that are required to complete a well rounded multiple precision integer package. These +routines are less performance oriented than the algorithms of chapters five, six and seven but are no less important. + +The first section describes a method of integer division with remainder that is universally well known. It provides the signed division logic +for the package. The subsequent section discusses a set of algorithms which allow a single digit to be the 2nd operand for a variety of operations. +These algorithms serve mostly to simplify other algorithms where small constants are required. The last two sections discuss how to manipulate +various representations of integers. For example, converting from an mp\_int to a string of character. + +\section{Integer Division with Remainder} +\label{sec:division} + +Integer division aside from modular exponentiation is the most intensive algorithm to compute. Like addition, subtraction and multiplication +the basis of this algorithm is the long-hand division algorithm taught to school children. Throughout this discussion several common variables +will be used. Let $x$ represent the divisor and $y$ represent the dividend. Let $q$ represent the integer quotient $\lfloor y / x \rfloor$ and +let $r$ represent the remainder $r = y - x \lfloor y / x \rfloor$. The following simple algorithm will be used to start the discussion. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{Radix-$\beta$ Integer Division}. \\ +\textbf{Input}. integer $x$ and $y$ \\ +\textbf{Output}. $q = \lfloor y/x\rfloor, r = y - xq$ \\ +\hline \\ +1. $q \leftarrow 0$ \\ +2. $n \leftarrow \vert \vert y \vert \vert - \vert \vert x \vert \vert$ \\ +3. for $t$ from $n$ down to $0$ do \\ +\hspace{3mm}3.1 Maximize $k$ such that $kx\beta^t$ is less than or equal to $y$ and $(k + 1)x\beta^t$ is greater. \\ +\hspace{3mm}3.2 $q \leftarrow q + k\beta^t$ \\ +\hspace{3mm}3.3 $y \leftarrow y - kx\beta^t$ \\ +4. $r \leftarrow y$ \\ +5. Return($q, r$) \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm Radix-$\beta$ Integer Division} +\label{fig:raddiv} +\end{figure} + +As children we are taught this very simple algorithm for the case of $\beta = 10$. Almost instinctively several optimizations are taught for which +their reason of existing are never explained. For this example let $y = 5471$ represent the dividend and $x = 23$ represent the divisor. + +To find the first digit of the quotient the value of $k$ must be maximized such that $kx\beta^t$ is less than or equal to $y$ and +simultaneously $(k + 1)x\beta^t$ is greater than $y$. Implicitly $k$ is the maximum value the $t$'th digit of the quotient may have. The habitual method +used to find the maximum is to ``eyeball'' the two numbers, typically only the leading digits and quickly estimate a quotient. By only using leading +digits a much simpler division may be used to form an educated guess at what the value must be. In this case $k = \lfloor 54/23\rfloor = 2$ quickly +arises as a possible solution. Indeed $2x\beta^2 = 4600$ is less than $y = 5471$ and simultaneously $(k + 1)x\beta^2 = 6900$ is larger than $y$. +As a result $k\beta^2$ is added to the quotient which now equals $q = 200$ and $4600$ is subtracted from $y$ to give a remainder of $y = 841$. + +Again this process is repeated to produce the quotient digit $k = 3$ which makes the quotient $q = 200 + 3\beta = 230$ and the remainder +$y = 841 - 3x\beta = 181$. Finally the last iteration of the loop produces $k = 7$ which leads to the quotient $q = 230 + 7 = 237$ and the +remainder $y = 181 - 7x = 20$. The final quotient and remainder found are $q = 237$ and $r = y = 20$ which are indeed correct since +$237 \cdot 23 + 20 = 5471$ is true. + +\subsection{Quotient Estimation} +\label{sec:divest} +As alluded to earlier the quotient digit $k$ can be estimated from only the leading digits of both the divisor and dividend. When $p$ leading +digits are used from both the divisor and dividend to form an estimation the accuracy of the estimation rises as $p$ grows. Technically +speaking the estimation is based on assuming the lower $\vert \vert y \vert \vert - p$ and $\vert \vert x \vert \vert - p$ lower digits of the +dividend and divisor are zero. + +The value of the estimation may off by a few values in either direction and in general is fairly correct. A simplification \cite[pp. 271]{TAOCPV2} +of the estimation technique is to use $t + 1$ digits of the dividend and $t$ digits of the divisor, in particularly when $t = 1$. The estimate +using this technique is never too small. For the following proof let $t = \vert \vert y \vert \vert - 1$ and $s = \vert \vert x \vert \vert - 1$ +represent the most significant digits of the dividend and divisor respectively. + +\textbf{Proof.}\textit{ The quotient $\hat k = \lfloor (y_t\beta + y_{t-1}) / x_s \rfloor$ is greater than or equal to +$k = \lfloor y / (x \cdot \beta^{\vert \vert y \vert \vert - \vert \vert x \vert \vert - 1}) \rfloor$. } +The first obvious case is when $\hat k = \beta - 1$ in which case the proof is concluded since the real quotient cannot be larger. For all other +cases $\hat k = \lfloor (y_t\beta + y_{t-1}) / x_s \rfloor$ and $\hat k x_s \ge y_t\beta + y_{t-1} - x_s + 1$. The latter portion of the inequalility +$-x_s + 1$ arises from the fact that a truncated integer division will give the same quotient for at most $x_s - 1$ values. Next a series of +inequalities will prove the hypothesis. + +\begin{equation} +y - \hat k x \le y - \hat k x_s\beta^s +\end{equation} + +This is trivially true since $x \ge x_s\beta^s$. Next we replace $\hat kx_s\beta^s$ by the previous inequality for $\hat kx_s$. + +\begin{equation} +y - \hat k x \le y_t\beta^t + \ldots + y_0 - (y_t\beta^t + y_{t-1}\beta^{t-1} - x_s\beta^t + \beta^s) +\end{equation} + +By simplifying the previous inequality the following inequality is formed. + +\begin{equation} +y - \hat k x \le y_{t-2}\beta^{t-2} + \ldots + y_0 + x_s\beta^s - \beta^s +\end{equation} + +Subsequently, + +\begin{equation} +y_{t-2}\beta^{t-2} + \ldots + y_0 + x_s\beta^s - \beta^s < x_s\beta^s \le x +\end{equation} + +Which proves that $y - \hat kx \le x$ and by consequence $\hat k \ge k$ which concludes the proof. \textbf{QED} + + +\subsection{Normalized Integers} +For the purposes of division a normalized input is when the divisors leading digit $x_n$ is greater than or equal to $\beta / 2$. By multiplying both +$x$ and $y$ by $j = \lfloor (\beta / 2) / x_n \rfloor$ the quotient remains unchanged and the remainder is simply $j$ times the original +remainder. The purpose of normalization is to ensure the leading digit of the divisor is sufficiently large such that the estimated quotient will +lie in the domain of a single digit. Consider the maximum dividend $(\beta - 1) \cdot \beta + (\beta - 1)$ and the minimum divisor $\beta / 2$. + +\begin{equation} +{{\beta^2 - 1} \over { \beta / 2}} \le 2\beta - {2 \over \beta} +\end{equation} + +At most the quotient approaches $2\beta$, however, in practice this will not occur since that would imply the previous quotient digit was too small. + +\subsection{Radix-$\beta$ Division with Remainder} +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_div}. \\ +\textbf{Input}. mp\_int $a, b$ \\ +\textbf{Output}. $c = \lfloor a/b \rfloor$, $d = a - bc$ \\ +\hline \\ +1. If $b = 0$ return(\textit{MP\_VAL}). \\ +2. If $\vert a \vert < \vert b \vert$ then do \\ +\hspace{3mm}2.1 $d \leftarrow a$ \\ +\hspace{3mm}2.2 $c \leftarrow 0$ \\ +\hspace{3mm}2.3 Return(\textit{MP\_OKAY}). \\ +\\ +Setup the quotient to receive the digits. \\ +3. Grow $q$ to $a.used + 2$ digits. \\ +4. $q \leftarrow 0$ \\ +5. $x \leftarrow \vert a \vert , y \leftarrow \vert b \vert$ \\ +6. $sign \leftarrow \left \lbrace \begin{array}{ll} + MP\_ZPOS & \mbox{if }a.sign = b.sign \\ + MP\_NEG & \mbox{otherwise} \\ + \end{array} \right .$ \\ +\\ +Normalize the inputs such that the leading digit of $y$ is greater than or equal to $\beta / 2$. \\ +7. $norm \leftarrow (lg(\beta) - 1) - (\lceil lg(y) \rceil \mbox{ (mod }lg(\beta)\mbox{)})$ \\ +8. $x \leftarrow x \cdot 2^{norm}, y \leftarrow y \cdot 2^{norm}$ \\ +\\ +Find the leading digit of the quotient. \\ +9. $n \leftarrow x.used - 1, t \leftarrow y.used - 1$ \\ +10. $y \leftarrow y \cdot \beta^{n - t}$ \\ +11. While ($x \ge y$) do \\ +\hspace{3mm}11.1 $q_{n - t} \leftarrow q_{n - t} + 1$ \\ +\hspace{3mm}11.2 $x \leftarrow x - y$ \\ +12. $y \leftarrow \lfloor y / \beta^{n-t} \rfloor$ \\ +\\ +Continued on the next page. \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_div} +\end{figure} + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_div} (continued). \\ +\textbf{Input}. mp\_int $a, b$ \\ +\textbf{Output}. $c = \lfloor a/b \rfloor$, $d = a - bc$ \\ +\hline \\ +Now find the remainder fo the digits. \\ +13. for $i$ from $n$ down to $(t + 1)$ do \\ +\hspace{3mm}13.1 If $i > x.used$ then jump to the next iteration of this loop. \\ +\hspace{3mm}13.2 If $x_{i} = y_{t}$ then \\ +\hspace{6mm}13.2.1 $q_{i - t - 1} \leftarrow \beta - 1$ \\ +\hspace{3mm}13.3 else \\ +\hspace{6mm}13.3.1 $\hat r \leftarrow x_{i} \cdot \beta + x_{i - 1}$ \\ +\hspace{6mm}13.3.2 $\hat r \leftarrow \lfloor \hat r / y_{t} \rfloor$ \\ +\hspace{6mm}13.3.3 $q_{i - t - 1} \leftarrow \hat r$ \\ +\hspace{3mm}13.4 $q_{i - t - 1} \leftarrow q_{i - t - 1} + 1$ \\ +\\ +Fixup quotient estimation. \\ +\hspace{3mm}13.5 Loop \\ +\hspace{6mm}13.5.1 $q_{i - t - 1} \leftarrow q_{i - t - 1} - 1$ \\ +\hspace{6mm}13.5.2 t$1 \leftarrow 0$ \\ +\hspace{6mm}13.5.3 t$1_0 \leftarrow y_{t - 1}, $ t$1_1 \leftarrow y_t,$ t$1.used \leftarrow 2$ \\ +\hspace{6mm}13.5.4 $t1 \leftarrow t1 \cdot q_{i - t - 1}$ \\ +\hspace{6mm}13.5.5 t$2_0 \leftarrow x_{i - 2}, $ t$2_1 \leftarrow x_{i - 1}, $ t$2_2 \leftarrow x_i, $ t$2.used \leftarrow 3$ \\ +\hspace{6mm}13.5.6 If $\vert t1 \vert > \vert t2 \vert$ then goto step 13.5. \\ +\hspace{3mm}13.6 t$1 \leftarrow y \cdot q_{i - t - 1}$ \\ +\hspace{3mm}13.7 t$1 \leftarrow $ t$1 \cdot \beta^{i - t - 1}$ \\ +\hspace{3mm}13.8 $x \leftarrow x - $ t$1$ \\ +\hspace{3mm}13.9 If $x.sign = MP\_NEG$ then \\ +\hspace{6mm}13.10 t$1 \leftarrow y$ \\ +\hspace{6mm}13.11 t$1 \leftarrow $ t$1 \cdot \beta^{i - t - 1}$ \\ +\hspace{6mm}13.12 $x \leftarrow x + $ t$1$ \\ +\hspace{6mm}13.13 $q_{i - t - 1} \leftarrow q_{i - t - 1} - 1$ \\ +\\ +Finalize the result. \\ +14. Clamp excess digits of $q$ \\ +15. $c \leftarrow q, c.sign \leftarrow sign$ \\ +16. $x.sign \leftarrow a.sign$ \\ +17. $d \leftarrow \lfloor x / 2^{norm} \rfloor$ \\ +18. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_div (continued)} +\end{figure} +\textbf{Algorithm mp\_div.} +This algorithm will calculate quotient and remainder from an integer division given a dividend and divisor. The algorithm is a signed +division and will produce a fully qualified quotient and remainder. + +First the divisor $b$ must be non-zero which is enforced in step one. If the divisor is larger than the dividend than the quotient is implicitly +zero and the remainder is the dividend. + +After the first two trivial cases of inputs are handled the variable $q$ is setup to receive the digits of the quotient. Two unsigned copies of the +divisor $y$ and dividend $x$ are made as well. The core of the division algorithm is an unsigned division and will only work if the values are +positive. Now the two values $x$ and $y$ must be normalized such that the leading digit of $y$ is greater than or equal to $\beta / 2$. +This is performed by shifting both to the left by enough bits to get the desired normalization. + +At this point the division algorithm can begin producing digits of the quotient. Recall that maximum value of the estimation used is +$2\beta - {2 \over \beta}$ which means that a digit of the quotient must be first produced by another means. In this case $y$ is shifted +to the left (\textit{step ten}) so that it has the same number of digits as $x$. The loop on step eleven will subtract multiples of the +shifted copy of $y$ until $x$ is smaller. Since the leading digit of $y$ is greater than or equal to $\beta/2$ this loop will iterate at most two +times to produce the desired leading digit of the quotient. + +Now the remainder of the digits can be produced. The equation $\hat q = \lfloor {{x_i \beta + x_{i-1}}\over y_t} \rfloor$ is used to fairly +accurately approximate the true quotient digit. The estimation can in theory produce an estimation as high as $2\beta - {2 \over \beta}$ but by +induction the upper quotient digit is correct (\textit{as established on step eleven}) and the estimate must be less than $\beta$. + +Recall from section~\ref{sec:divest} that the estimation is never too low but may be too high. The next step of the estimation process is +to refine the estimation. The loop on step 13.5 uses $x_i\beta^2 + x_{i-1}\beta + x_{i-2}$ and $q_{i - t - 1}(y_t\beta + y_{t-1})$ as a higher +order approximation to adjust the quotient digit. + +After both phases of estimation the quotient digit may still be off by a value of one\footnote{This is similar to the error introduced +by optimizing Barrett reduction.}. Steps 13.6 and 13.7 subtract the multiple of the divisor from the dividend (\textit{Similar to step 3.3 of +algorithm~\ref{fig:raddiv}} and then subsequently add a multiple of the divisor if the quotient was too large. + +Now that the quotient has been determine finializing the result is a matter of clamping the quotient, fixing the sizes and de-normalizing the +remainder. An important aspect of this algorithm seemingly overlooked in other descriptions such as that of Algorithm 14.20 HAC \cite[pp. 598]{HAC} +is that when the estimations are being made (\textit{inside the loop on step 13.5}) that the digits $y_{t-1}$, $x_{i-2}$ and $x_{i-1}$ may lie +outside their respective boundaries. For example, if $t = 0$ or $i \le 1$ then the digits would be undefined. In those cases the digits should +respectively be replaced with a zero. + +EXAM,bn_mp_div.c + +The implementation of this algorithm differs slightly from the pseudo code presented previously. In this algorithm either of the quotient $c$ or +remainder $d$ may be passed as a \textbf{NULL} pointer which indicates their value is not desired. For example, the C code to call the division +algorithm with only the quotient is + +\begin{verbatim} +mp_div(&a, &b, &c, NULL); /* c = [a/b] */ +\end{verbatim} + +Lines @37,if@ and @42,if@ handle the two trivial cases of inputs which are division by zero and dividend smaller than the divisor +respectively. After the two trivial cases all of the temporary variables are initialized. Line @76,neg@ determines the sign of +the quotient and line @77,sign@ ensures that both $x$ and $y$ are positive. + +The number of bits in the leading digit is calculated on line @80,norm@. Implictly an mp\_int with $r$ digits will require $lg(\beta)(r-1) + k$ bits +of precision which when reduced modulo $lg(\beta)$ produces the value of $k$. In this case $k$ is the number of bits in the leading digit which is +exactly what is required. For the algorithm to operate $k$ must equal $lg(\beta) - 1$ and when it does not the inputs must be normalized by shifting +them to the left by $lg(\beta) - 1 - k$ bits. + +Throughout the variables $n$ and $t$ will represent the highest digit of $x$ and $y$ respectively. These are first used to produce the +leading digit of the quotient. The loop beginning on line @113,for@ will produce the remainder of the quotient digits. + +The conditional ``continue'' on line @114,if@ is used to prevent the algorithm from reading past the leading edge of $x$ which can occur when the +algorithm eliminates multiple non-zero digits in a single iteration. This ensures that $x_i$ is always non-zero since by definition the digits +above the $i$'th position $x$ must be zero in order for the quotient to be precise\footnote{Precise as far as integer division is concerned.}. + +Lines @142,t1@, @143,t1@ and @150,t2@ through @152,t2@ manually construct the high accuracy estimations by setting the digits of the two mp\_int +variables directly. + +\section{Single Digit Helpers} + +This section briefly describes a series of single digit helper algorithms which come in handy when working with small constants. All of +the helper functions assume the single digit input is positive and will treat them as such. + +\subsection{Single Digit Addition and Subtraction} + +Both addition and subtraction are performed by ``cheating'' and using mp\_set followed by the higher level addition or subtraction +algorithms. As a result these algorithms are subtantially simpler with a slight cost in performance. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_add\_d}. \\ +\textbf{Input}. mp\_int $a$ and a mp\_digit $b$ \\ +\textbf{Output}. $c = a + b$ \\ +\hline \\ +1. $t \leftarrow b$ (\textit{mp\_set}) \\ +2. $c \leftarrow a + t$ \\ +3. Return(\textit{MP\_OKAY}) \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_add\_d} +\end{figure} + +\textbf{Algorithm mp\_add\_d.} +This algorithm initiates a temporary mp\_int with the value of the single digit and uses algorithm mp\_add to add the two values together. + +EXAM,bn_mp_add_d.c + +Clever use of the letter 't'. + +\subsubsection{Subtraction} +The single digit subtraction algorithm mp\_sub\_d is essentially the same except it uses mp\_sub to subtract the digit from the mp\_int. + +\subsection{Single Digit Multiplication} +Single digit multiplication arises enough in division and radix conversion that it ought to be implement as a special case of the baseline +multiplication algorithm. Essentially this algorithm is a modified version of algorithm s\_mp\_mul\_digs where one of the multiplicands +only has one digit. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_mul\_d}. \\ +\textbf{Input}. mp\_int $a$ and a mp\_digit $b$ \\ +\textbf{Output}. $c = ab$ \\ +\hline \\ +1. $pa \leftarrow a.used$ \\ +2. Grow $c$ to at least $pa + 1$ digits. \\ +3. $oldused \leftarrow c.used$ \\ +4. $c.used \leftarrow pa + 1$ \\ +5. $c.sign \leftarrow a.sign$ \\ +6. $\mu \leftarrow 0$ \\ +7. for $ix$ from $0$ to $pa - 1$ do \\ +\hspace{3mm}7.1 $\hat r \leftarrow \mu + a_{ix}b$ \\ +\hspace{3mm}7.2 $c_{ix} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\ +\hspace{3mm}7.3 $\mu \leftarrow \lfloor \hat r / \beta \rfloor$ \\ +8. $c_{pa} \leftarrow \mu$ \\ +9. for $ix$ from $pa + 1$ to $oldused$ do \\ +\hspace{3mm}9.1 $c_{ix} \leftarrow 0$ \\ +10. Clamp excess digits of $c$. \\ +11. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_mul\_d} +\end{figure} +\textbf{Algorithm mp\_mul\_d.} +This algorithm quickly multiplies an mp\_int by a small single digit value. It is specially tailored to the job and has a minimal of overhead. +Unlike the full multiplication algorithms this algorithm does not require any significnat temporary storage or memory allocations. + +EXAM,bn_mp_mul_d.c + +In this implementation the destination $c$ may point to the same mp\_int as the source $a$ since the result is written after the digit is +read from the source. This function uses pointer aliases $tmpa$ and $tmpc$ for the digits of $a$ and $c$ respectively. + +\subsection{Single Digit Division} +Like the single digit multiplication algorithm, single digit division is also a fairly common algorithm used in radix conversion. Since the +divisor is only a single digit a specialized variant of the division algorithm can be used to compute the quotient. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_div\_d}. \\ +\textbf{Input}. mp\_int $a$ and a mp\_digit $b$ \\ +\textbf{Output}. $c = \lfloor a / b \rfloor, d = a - cb$ \\ +\hline \\ +1. If $b = 0$ then return(\textit{MP\_VAL}).\\ +2. If $b = 3$ then use algorithm mp\_div\_3 instead. \\ +3. Init $q$ to $a.used$ digits. \\ +4. $q.used \leftarrow a.used$ \\ +5. $q.sign \leftarrow a.sign$ \\ +6. $\hat w \leftarrow 0$ \\ +7. for $ix$ from $a.used - 1$ down to $0$ do \\ +\hspace{3mm}7.1 $\hat w \leftarrow \hat w \beta + a_{ix}$ \\ +\hspace{3mm}7.2 If $\hat w \ge b$ then \\ +\hspace{6mm}7.2.1 $t \leftarrow \lfloor \hat w / b \rfloor$ \\ +\hspace{6mm}7.2.2 $\hat w \leftarrow \hat w \mbox{ (mod }b\mbox{)}$ \\ +\hspace{3mm}7.3 else\\ +\hspace{6mm}7.3.1 $t \leftarrow 0$ \\ +\hspace{3mm}7.4 $q_{ix} \leftarrow t$ \\ +8. $d \leftarrow \hat w$ \\ +9. Clamp excess digits of $q$. \\ +10. $c \leftarrow q$ \\ +11. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_div\_d} +\end{figure} +\textbf{Algorithm mp\_div\_d.} +This algorithm divides the mp\_int $a$ by the single mp\_digit $b$ using an optimized approach. Essentially in every iteration of the +algorithm another digit of the dividend is reduced and another digit of quotient produced. Provided $b < \beta$ the value of $\hat w$ +after step 7.1 will be limited such that $0 \le \lfloor \hat w / b \rfloor < \beta$. + +If the divisor $b$ is equal to three a variant of this algorithm is used which is called mp\_div\_3. It replaces the division by three with +a multiplication by $\lfloor \beta / 3 \rfloor$ and the appropriate shift and residual fixup. In essence it is much like the Barrett reduction +from chapter seven. + +EXAM,bn_mp_div_d.c + +Like the implementation of algorithm mp\_div this algorithm allows either of the quotient or remainder to be passed as a \textbf{NULL} pointer to +indicate the respective value is not required. This allows a trivial single digit modular reduction algorithm, mp\_mod\_d to be created. + +The division and remainder on lines @44,/@ and @45,%@ can be replaced often by a single division on most processors. For example, the 32-bit x86 based +processors can divide a 64-bit quantity by a 32-bit quantity and produce the quotient and remainder simultaneously. Unfortunately the GCC +compiler does not recognize that optimization and will actually produce two function calls to find the quotient and remainder respectively. + +\subsection{Single Digit Root Extraction} + +Finding the $n$'th root of an integer is fairly easy as far as numerical analysis is concerned. Algorithms such as the Newton-Raphson approximation +(\ref{eqn:newton}) series will converge very quickly to a root for any continuous function $f(x)$. + +\begin{equation} +x_{i+1} = x_i - {f(x_i) \over f'(x_i)} +\label{eqn:newton} +\end{equation} + +In this case the $n$'th root is desired and $f(x) = x^n - a$ where $a$ is the integer of which the root is desired. The derivative of $f(x)$ is +simply $f'(x) = nx^{n - 1}$. Of particular importance is that this algorithm will be used over the integers not over the a more continuous domain +such as the real numbers. As a result the root found can be above the true root by few and must be manually adjusted. Ideally at the end of the +algorithm the $n$'th root $b$ of an integer $a$ is desired such that $b^n \le a$. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_n\_root}. \\ +\textbf{Input}. mp\_int $a$ and a mp\_digit $b$ \\ +\textbf{Output}. $c^b \le a$ \\ +\hline \\ +1. If $b$ is even and $a.sign = MP\_NEG$ return(\textit{MP\_VAL}). \\ +2. $sign \leftarrow a.sign$ \\ +3. $a.sign \leftarrow MP\_ZPOS$ \\ +4. t$2 \leftarrow 2$ \\ +5. Loop \\ +\hspace{3mm}5.1 t$1 \leftarrow $ t$2$ \\ +\hspace{3mm}5.2 t$3 \leftarrow $ t$1^{b - 1}$ \\ +\hspace{3mm}5.3 t$2 \leftarrow $ t$3 $ $\cdot$ t$1$ \\ +\hspace{3mm}5.4 t$2 \leftarrow $ t$2 - a$ \\ +\hspace{3mm}5.5 t$3 \leftarrow $ t$3 \cdot b$ \\ +\hspace{3mm}5.6 t$3 \leftarrow \lfloor $t$2 / $t$3 \rfloor$ \\ +\hspace{3mm}5.7 t$2 \leftarrow $ t$1 - $ t$3$ \\ +\hspace{3mm}5.8 If t$1 \ne $ t$2$ then goto step 5. \\ +6. Loop \\ +\hspace{3mm}6.1 t$2 \leftarrow $ t$1^b$ \\ +\hspace{3mm}6.2 If t$2 > a$ then \\ +\hspace{6mm}6.2.1 t$1 \leftarrow $ t$1 - 1$ \\ +\hspace{6mm}6.2.2 Goto step 6. \\ +7. $a.sign \leftarrow sign$ \\ +8. $c \leftarrow $ t$1$ \\ +9. $c.sign \leftarrow sign$ \\ +10. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_n\_root} +\end{figure} +\textbf{Algorithm mp\_n\_root.} +This algorithm finds the integer $n$'th root of an input using the Newton-Raphson approach. It is partially optimized based on the observation +that the numerator of ${f(x) \over f'(x)}$ can be derived from a partial denominator. That is at first the denominator is calculated by finding +$x^{b - 1}$. This value can then be multiplied by $x$ and have $a$ subtracted from it to find the numerator. This saves a total of $b - 1$ +multiplications by t$1$ inside the loop. + +The initial value of the approximation is t$2 = 2$ which allows the algorithm to start with very small values and quickly converge on the +root. Ideally this algorithm is meant to find the $n$'th root of an input where $n$ is bounded by $2 \le n \le 5$. + +EXAM,bn_mp_n_root.c + +\section{Random Number Generation} + +Random numbers come up in a variety of activities from public key cryptography to simple simulations and various randomized algorithms. Pollard-Rho +factoring for example, can make use of random values as starting points to find factors of a composite integer. In this case the algorithm presented +is solely for simulations and not intended for cryptographic use. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_rand}. \\ +\textbf{Input}. An integer $b$ \\ +\textbf{Output}. A pseudo-random number of $b$ digits \\ +\hline \\ +1. $a \leftarrow 0$ \\ +2. If $b \le 0$ return(\textit{MP\_OKAY}) \\ +3. Pick a non-zero random digit $d$. \\ +4. $a \leftarrow a + d$ \\ +5. for $ix$ from 1 to $d - 1$ do \\ +\hspace{3mm}5.1 $a \leftarrow a \cdot \beta$ \\ +\hspace{3mm}5.2 Pick a random digit $d$. \\ +\hspace{3mm}5.3 $a \leftarrow a + d$ \\ +6. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_rand} +\end{figure} +\textbf{Algorithm mp\_rand.} +This algorithm produces a pseudo-random integer of $b$ digits. By ensuring that the first digit is non-zero the algorithm also guarantees that the +final result has at least $b$ digits. It relies heavily on a third-part random number generator which should ideally generate uniformly all of +the integers from $0$ to $\beta - 1$. + +EXAM,bn_mp_rand.c + +\section{Formatted Representations} +The ability to emit a radix-$n$ textual representation of an integer is useful for interacting with human parties. For example, the ability to +be given a string of characters such as ``114585'' and turn it into the radix-$\beta$ equivalent would make it easier to enter numbers +into a program. + +\subsection{Reading Radix-n Input} +For the purposes of this text we will assume that a simple lower ASCII map (\ref{fig:ASC}) is used for the values of from $0$ to $63$ to +printable characters. For example, when the character ``N'' is read it represents the integer $23$. The first $16$ characters of the +map are for the common representations up to hexadecimal. After that they match the ``base64'' encoding scheme which are suitable chosen +such that they are printable. While outputting as base64 may not be too helpful for human operators it does allow communication via non binary +mediums. + +\newpage\begin{figure}[here] +\begin{center} +\begin{tabular}{cc|cc|cc|cc} +\hline \textbf{Value} & \textbf{Char} & \textbf{Value} & \textbf{Char} & \textbf{Value} & \textbf{Char} & \textbf{Value} & \textbf{Char} \\ +\hline +0 & 0 & 1 & 1 & 2 & 2 & 3 & 3 \\ +4 & 4 & 5 & 5 & 6 & 6 & 7 & 7 \\ +8 & 8 & 9 & 9 & 10 & A & 11 & B \\ +12 & C & 13 & D & 14 & E & 15 & F \\ +16 & G & 17 & H & 18 & I & 19 & J \\ +20 & K & 21 & L & 22 & M & 23 & N \\ +24 & O & 25 & P & 26 & Q & 27 & R \\ +28 & S & 29 & T & 30 & U & 31 & V \\ +32 & W & 33 & X & 34 & Y & 35 & Z \\ +36 & a & 37 & b & 38 & c & 39 & d \\ +40 & e & 41 & f & 42 & g & 43 & h \\ +44 & i & 45 & j & 46 & k & 47 & l \\ +48 & m & 49 & n & 50 & o & 51 & p \\ +52 & q & 53 & r & 54 & s & 55 & t \\ +56 & u & 57 & v & 58 & w & 59 & x \\ +60 & y & 61 & z & 62 & $+$ & 63 & $/$ \\ +\hline +\end{tabular} +\end{center} +\caption{Lower ASCII Map} +\label{fig:ASC} +\end{figure} + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_read\_radix}. \\ +\textbf{Input}. A string $str$ of length $sn$ and radix $r$. \\ +\textbf{Output}. The radix-$\beta$ equivalent mp\_int. \\ +\hline \\ +1. If $r < 2$ or $r > 64$ return(\textit{MP\_VAL}). \\ +2. $ix \leftarrow 0$ \\ +3. If $str_0 =$ ``-'' then do \\ +\hspace{3mm}3.1 $ix \leftarrow ix + 1$ \\ +\hspace{3mm}3.2 $sign \leftarrow MP\_NEG$ \\ +4. else \\ +\hspace{3mm}4.1 $sign \leftarrow MP\_ZPOS$ \\ +5. $a \leftarrow 0$ \\ +6. for $iy$ from $ix$ to $sn - 1$ do \\ +\hspace{3mm}6.1 Let $y$ denote the position in the map of $str_{iy}$. \\ +\hspace{3mm}6.2 If $str_{iy}$ is not in the map or $y \ge r$ then goto step 7. \\ +\hspace{3mm}6.3 $a \leftarrow a \cdot r$ \\ +\hspace{3mm}6.4 $a \leftarrow a + y$ \\ +7. If $a \ne 0$ then $a.sign \leftarrow sign$ \\ +8. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_read\_radix} +\end{figure} +\textbf{Algorithm mp\_read\_radix.} +This algorithm will read an ASCII string and produce the radix-$\beta$ mp\_int representation of the same integer. A minus symbol ``-'' may precede the +string to indicate the value is negative, otherwise it is assumed to be positive. The algorithm will read up to $sn$ characters from the input +and will stop when it reads a character it cannot map the algorithm stops reading characters from the string. This allows numbers to be embedded +as part of larger input without any significant problem. + +EXAM,bn_mp_read_radix.c + +\subsection{Generating Radix-$n$ Output} +Generating radix-$n$ output is fairly trivial with a division and remainder algorithm. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_toradix}. \\ +\textbf{Input}. A mp\_int $a$ and an integer $r$\\ +\textbf{Output}. The radix-$r$ representation of $a$ \\ +\hline \\ +1. If $r < 2$ or $r > 64$ return(\textit{MP\_VAL}). \\ +2. If $a = 0$ then $str = $ ``$0$'' and return(\textit{MP\_OKAY}). \\ +3. $t \leftarrow a$ \\ +4. $str \leftarrow$ ``'' \\ +5. if $t.sign = MP\_NEG$ then \\ +\hspace{3mm}5.1 $str \leftarrow str + $ ``-'' \\ +\hspace{3mm}5.2 $t.sign = MP\_ZPOS$ \\ +6. While ($t \ne 0$) do \\ +\hspace{3mm}6.1 $d \leftarrow t \mbox{ (mod }r\mbox{)}$ \\ +\hspace{3mm}6.2 $t \leftarrow \lfloor t / r \rfloor$ \\ +\hspace{3mm}6.3 Look up $d$ in the map and store the equivalent character in $y$. \\ +\hspace{3mm}6.4 $str \leftarrow str + y$ \\ +7. If $str_0 = $``$-$'' then \\ +\hspace{3mm}7.1 Reverse the digits $str_1, str_2, \ldots str_n$. \\ +8. Otherwise \\ +\hspace{3mm}8.1 Reverse the digits $str_0, str_1, \ldots str_n$. \\ +9. Return(\textit{MP\_OKAY}).\\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_toradix} +\end{figure} +\textbf{Algorithm mp\_toradix.} +This algorithm computes the radix-$r$ representation of an mp\_int $a$. The ``digits'' of the representation are extracted by reducing +successive powers of $\lfloor a / r^k \rfloor$ the input modulo $r$ until $r^k > a$. Note that instead of actually dividing by $r^k$ in +each iteration the quotient $\lfloor a / r \rfloor$ is saved for the next iteration. As a result a series of trivial $n \times 1$ divisions +are required instead of a series of $n \times k$ divisions. One design flaw of this approach is that the digits are produced in the reverse order +(see~\ref{fig:mpradix}). To remedy this flaw the digits must be swapped or simply ``reversed''. + +\begin{figure} +\begin{center} +\begin{tabular}{|c|c|c|} +\hline \textbf{Value of $a$} & \textbf{Value of $d$} & \textbf{Value of $str$} \\ +\hline $1234$ & -- & -- \\ +\hline $123$ & $4$ & ``4'' \\ +\hline $12$ & $3$ & ``43'' \\ +\hline $1$ & $2$ & ``432'' \\ +\hline $0$ & $1$ & ``4321'' \\ +\hline +\end{tabular} +\end{center} +\caption{Example of Algorithm mp\_toradix.} +\label{fig:mpradix} +\end{figure} + +EXAM,bn_mp_toradix.c + +\chapter{Number Theoretic Algorithms} +This chapter discusses several fundamental number theoretic algorithms such as the greatest common divisor, least common multiple and Jacobi +symbol computation. These algorithms arise as essential components in several key cryptographic algorithms such as the RSA public key algorithm and +various Sieve based factoring algorithms. + +\section{Greatest Common Divisor} +The greatest common divisor of two integers $a$ and $b$, often denoted as $(a, b)$ is the largest integer $k$ that is a proper divisor of +both $a$ and $b$. That is, $k$ is the largest integer such that $0 \equiv a \mbox{ (mod }k\mbox{)}$ and $0 \equiv b \mbox{ (mod }k\mbox{)}$ occur +simultaneously. + +The most common approach (cite) is to reduce one input modulo another. That is if $a$ and $b$ are divisible by some integer $k$ and if $qa + r = b$ then +$r$ is also divisible by $k$. The reduction pattern follows $\left < a , b \right > \rightarrow \left < b, a \mbox{ mod } b \right >$. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{Greatest Common Divisor (I)}. \\ +\textbf{Input}. Two positive integers $a$ and $b$ greater than zero. \\ +\textbf{Output}. The greatest common divisor $(a, b)$. \\ +\hline \\ +1. While ($b > 0$) do \\ +\hspace{3mm}1.1 $r \leftarrow a \mbox{ (mod }b\mbox{)}$ \\ +\hspace{3mm}1.2 $a \leftarrow b$ \\ +\hspace{3mm}1.3 $b \leftarrow r$ \\ +2. Return($a$). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm Greatest Common Divisor (I)} +\label{fig:gcd1} +\end{figure} + +This algorithm will quickly converge on the greatest common divisor since the residue $r$ tends diminish rapidly. However, divisions are +relatively expensive operations to perform and should ideally be avoided. There is another approach based on a similar relationship of +greatest common divisors. The faster approach is based on the observation that if $k$ divides both $a$ and $b$ it will also divide $a - b$. +In particular, we would like $a - b$ to decrease in magnitude which implies that $b \ge a$. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{Greatest Common Divisor (II)}. \\ +\textbf{Input}. Two positive integers $a$ and $b$ greater than zero. \\ +\textbf{Output}. The greatest common divisor $(a, b)$. \\ +\hline \\ +1. While ($b > 0$) do \\ +\hspace{3mm}1.1 Swap $a$ and $b$ such that $a$ is the smallest of the two. \\ +\hspace{3mm}1.2 $b \leftarrow b - a$ \\ +2. Return($a$). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm Greatest Common Divisor (II)} +\label{fig:gcd2} +\end{figure} + +\textbf{Proof} \textit{Algorithm~\ref{fig:gcd2} will return the greatest common divisor of $a$ and $b$.} +The algorithm in figure~\ref{fig:gcd2} will eventually terminate since $b \ge a$ the subtraction in step 1.2 will be a value less than $b$. In other +words in every iteration that tuple $\left < a, b \right >$ decrease in magnitude until eventually $a = b$. Since both $a$ and $b$ are always +divisible by the greatest common divisor (\textit{until the last iteration}) and in the last iteration of the algorithm $b = 0$, therefore, in the +second to last iteration of the algorithm $b = a$ and clearly $(a, a) = a$ which concludes the proof. \textbf{QED}. + +As a matter of practicality algorithm \ref{fig:gcd1} decreases far too slowly to be useful. Specially if $b$ is much larger than $a$ such that +$b - a$ is still very much larger than $a$. A simple addition to the algorithm is to divide $b - a$ by a power of some integer $p$ which does +not divide the greatest common divisor but will divide $b - a$. In this case ${b - a} \over p$ is also an integer and still divisible by +the greatest common divisor. + +However, instead of factoring $b - a$ to find a suitable value of $p$ the powers of $p$ can be removed from $a$ and $b$ that are in common first. +Then inside the loop whenever $b - a$ is divisible by some power of $p$ it can be safely removed. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{Greatest Common Divisor (III)}. \\ +\textbf{Input}. Two positive integers $a$ and $b$ greater than zero. \\ +\textbf{Output}. The greatest common divisor $(a, b)$. \\ +\hline \\ +1. $k \leftarrow 0$ \\ +2. While $a$ and $b$ are both divisible by $p$ do \\ +\hspace{3mm}2.1 $a \leftarrow \lfloor a / p \rfloor$ \\ +\hspace{3mm}2.2 $b \leftarrow \lfloor b / p \rfloor$ \\ +\hspace{3mm}2.3 $k \leftarrow k + 1$ \\ +3. While $a$ is divisible by $p$ do \\ +\hspace{3mm}3.1 $a \leftarrow \lfloor a / p \rfloor$ \\ +4. While $b$ is divisible by $p$ do \\ +\hspace{3mm}4.1 $b \leftarrow \lfloor b / p \rfloor$ \\ +5. While ($b > 0$) do \\ +\hspace{3mm}5.1 Swap $a$ and $b$ such that $a$ is the smallest of the two. \\ +\hspace{3mm}5.2 $b \leftarrow b - a$ \\ +\hspace{3mm}5.3 While $b$ is divisible by $p$ do \\ +\hspace{6mm}5.3.1 $b \leftarrow \lfloor b / p \rfloor$ \\ +6. Return($a \cdot p^k$). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm Greatest Common Divisor (III)} +\label{fig:gcd3} +\end{figure} + +This algorithm is based on the first except it removes powers of $p$ first and inside the main loop to ensure the tuple $\left < a, b \right >$ +decreases more rapidly. The first loop on step two removes powers of $p$ that are in common. A count, $k$, is kept which will present a common +divisor of $p^k$. After step two the remaining common divisor of $a$ and $b$ cannot be divisible by $p$. This means that $p$ can be safely +divided out of the difference $b - a$ so long as the division leaves no remainder. + +In particular the value of $p$ should be chosen such that the division on step 5.3.1 occur often. It also helps that division by $p$ be easy +to compute. The ideal choice of $p$ is two since division by two amounts to a right logical shift. Another important observation is that by +step five both $a$ and $b$ are odd. Therefore, the diffrence $b - a$ must be even which means that each iteration removes one bit from the +largest of the pair. + +\subsection{Complete Greatest Common Divisor} +The algorithms presented so far cannot handle inputs which are zero or negative. The following algorithm can handle all input cases properly +and will produce the greatest common divisor. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_gcd}. \\ +\textbf{Input}. mp\_int $a$ and $b$ \\ +\textbf{Output}. The greatest common divisor $c = (a, b)$. \\ +\hline \\ +1. If $a = 0$ and $b \ne 0$ then \\ +\hspace{3mm}1.1 $c \leftarrow b$ \\ +\hspace{3mm}1.2 Return(\textit{MP\_OKAY}). \\ +2. If $a \ne 0$ and $b = 0$ then \\ +\hspace{3mm}2.1 $c \leftarrow a$ \\ +\hspace{3mm}2.2 Return(\textit{MP\_OKAY}). \\ +3. If $a = b = 0$ then \\ +\hspace{3mm}3.1 $c \leftarrow 1$ \\ +\hspace{3mm}3.2 Return(\textit{MP\_OKAY}). \\ +4. $u \leftarrow \vert a \vert, v \leftarrow \vert b \vert$ \\ +5. $k \leftarrow 0$ \\ +6. While $u.used > 0$ and $v.used > 0$ and $u_0 \equiv v_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\ +\hspace{3mm}6.1 $k \leftarrow k + 1$ \\ +\hspace{3mm}6.2 $u \leftarrow \lfloor u / 2 \rfloor$ \\ +\hspace{3mm}6.3 $v \leftarrow \lfloor v / 2 \rfloor$ \\ +7. While $u.used > 0$ and $u_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\ +\hspace{3mm}7.1 $u \leftarrow \lfloor u / 2 \rfloor$ \\ +8. While $v.used > 0$ and $v_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\ +\hspace{3mm}8.1 $v \leftarrow \lfloor v / 2 \rfloor$ \\ +9. While $v.used > 0$ \\ +\hspace{3mm}9.1 If $\vert u \vert > \vert v \vert$ then \\ +\hspace{6mm}9.1.1 Swap $u$ and $v$. \\ +\hspace{3mm}9.2 $v \leftarrow \vert v \vert - \vert u \vert$ \\ +\hspace{3mm}9.3 While $v.used > 0$ and $v_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\ +\hspace{6mm}9.3.1 $v \leftarrow \lfloor v / 2 \rfloor$ \\ +10. $c \leftarrow u \cdot 2^k$ \\ +11. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_gcd} +\end{figure} +\textbf{Algorithm mp\_gcd.} +This algorithm will produce the greatest common divisor of two mp\_ints $a$ and $b$. The algorithm was originally based on Algorithm B of +Knuth \cite[pp. 338]{TAOCPV2} but has been modified to be simpler to explain. In theory it achieves the same asymptotic working time as +Algorithm B and in practice this appears to be true. + +The first three steps handle the cases where either one of or both inputs are zero. If either input is zero the greatest common divisor is the +largest input or zero if they are both zero. If the inputs are not trivial than $u$ and $v$ are assigned the absolute values of +$a$ and $b$ respectively and the algorithm will proceed to reduce the pair. + +Step six will divide out any common factors of two and keep track of the count in the variable $k$. After this step two is no longer a +factor of the remaining greatest common divisor between $u$ and $v$ and can be safely evenly divided out of either whenever they are even. Step +seven and eight ensure that the $u$ and $v$ respectively have no more factors of two. At most only one of the while loops will iterate since +they cannot both be even. + +By step nine both of $u$ and $v$ are odd which is required for the inner logic. First the pair are swapped such that $v$ is equal to +or greater than $u$. This ensures that the subtraction on step 9.2 will always produce a positive and even result. Step 9.3 removes any +factors of two from the difference $u$ to ensure that in the next iteration of the loop both are once again odd. + +After $v = 0$ occurs the variable $u$ has the greatest common divisor of the pair $\left < u, v \right >$ just after step six. The result +must be adjusted by multiplying by the common factors of two ($2^k$) removed earlier. + +EXAM,bn_mp_gcd.c + +This function makes use of the macros mp\_iszero and mp\_iseven. The former evaluates to $1$ if the input mp\_int is equivalent to the +integer zero otherwise it evaluates to $0$. The latter evaluates to $1$ if the input mp\_int represents a non-zero even integer otherwise +it evaluates to $0$. Note that just because mp\_iseven may evaluate to $0$ does not mean the input is odd, it could also be zero. The three +trivial cases of inputs are handled on lines @25,zero@ through @34,}@. After those lines the inputs are assumed to be non-zero. + +Lines @36,if@ and @40,if@ make local copies $u$ and $v$ of the inputs $a$ and $b$ respectively. At this point the common factors of two +must be divided out of the two inputs. The while loop on line @49,while@ iterates so long as both are even. The local integer $k$ is used to +keep track of how many factors of $2$ are pulled out of both values. It is assumed that the number of factors will not exceed the maximum +value of a C ``int'' data type\footnote{Strictly speaking no array in C may have more than entries than are accessible by an ``int'' so this is not +a limitation.}. + +At this point there are no more common factors of two in the two values. The while loops on lines @60,while@ and @65,while@ remove any independent +factors of two such that both $u$ and $v$ are guaranteed to be an odd integer before hitting the main body of the algorithm. The while loop +on line @71, while@ performs the reduction of the pair until $v$ is equal to zero. The unsigned comparison and subtraction algorithms are used in +place of the full signed routines since both values are guaranteed to be positive and the result of the subtraction is guaranteed to be non-negative. + +\section{Least Common Multiple} +The least common multiple of a pair of integers is their product divided by their greatest common divisor. For two integers $a$ and $b$ the +least common multiple is normally denoted as $[ a, b ]$ and numerically equivalent to ${ab} \over {(a, b)}$. For example, if $a = 2 \cdot 2 \cdot 3 = 12$ +and $b = 2 \cdot 3 \cdot 3 \cdot 7 = 126$ the least common multiple is ${126 \over {(12, 126)}} = {126 \over 6} = 21$. + +The least common multiple arises often in coding theory as well as number theory. If two functions have periods of $a$ and $b$ respectively they will +collide, that is be in synchronous states, after only $[ a, b ]$ iterations. This is why, for example, random number generators based on +Linear Feedback Shift Registers (LFSR) tend to use registers with periods which are co-prime (\textit{e.g. the greatest common divisor is one.}). +Similarly in number theory if a composite $n$ has two prime factors $p$ and $q$ then maximal order of any unit of $\Z/n\Z$ will be $[ p - 1, q - 1] $. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_lcm}. \\ +\textbf{Input}. mp\_int $a$ and $b$ \\ +\textbf{Output}. The least common multiple $c = [a, b]$. \\ +\hline \\ +1. $c \leftarrow (a, b)$ \\ +2. $t \leftarrow a \cdot b$ \\ +3. $c \leftarrow \lfloor t / c \rfloor$ \\ +4. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_lcm} +\end{figure} +\textbf{Algorithm mp\_lcm.} +This algorithm computes the least common multiple of two mp\_int inputs $a$ and $b$. It computes the least common multiple directly by +dividing the product of the two inputs by their greatest common divisor. + +EXAM,bn_mp_lcm.c + +\section{Jacobi Symbol Computation} +To explain the Jacobi Symbol we shall first discuss the Legendre function\footnote{Arrg. What is the name of this?} off which the Jacobi symbol is +defined. The Legendre function computes whether or not an integer $a$ is a quadratic residue modulo an odd prime $p$. Numerically it is +equivalent to equation \ref{eqn:legendre}. + +\textit{-- Tom, don't be an ass, cite your source here...!} + +\begin{equation} +a^{(p-1)/2} \equiv \begin{array}{rl} + -1 & \mbox{if }a\mbox{ is a quadratic non-residue.} \\ + 0 & \mbox{if }a\mbox{ divides }p\mbox{.} \\ + 1 & \mbox{if }a\mbox{ is a quadratic residue}. + \end{array} \mbox{ (mod }p\mbox{)} +\label{eqn:legendre} +\end{equation} + +\textbf{Proof.} \textit{Equation \ref{eqn:legendre} correctly identifies the residue status of an integer $a$ modulo a prime $p$.} +An integer $a$ is a quadratic residue if the following equation has a solution. + +\begin{equation} +x^2 \equiv a \mbox{ (mod }p\mbox{)} +\label{eqn:root} +\end{equation} + +Consider the following equation. + +\begin{equation} +0 \equiv x^{p-1} - 1 \equiv \left \lbrace \left (x^2 \right )^{(p-1)/2} - a^{(p-1)/2} \right \rbrace + \left ( a^{(p-1)/2} - 1 \right ) \mbox{ (mod }p\mbox{)} +\label{eqn:rooti} +\end{equation} + +Whether equation \ref{eqn:root} has a solution or not equation \ref{eqn:rooti} is always true. If $a^{(p-1)/2} - 1 \equiv 0 \mbox{ (mod }p\mbox{)}$ +then the quantity in the braces must be zero. By reduction, + +\begin{eqnarray} +\left (x^2 \right )^{(p-1)/2} - a^{(p-1)/2} \equiv 0 \nonumber \\ +\left (x^2 \right )^{(p-1)/2} \equiv a^{(p-1)/2} \nonumber \\ +x^2 \equiv a \mbox{ (mod }p\mbox{)} +\end{eqnarray} + +As a result there must be a solution to the quadratic equation and in turn $a$ must be a quadratic residue. If $a$ does not divide $p$ and $a$ +is not a quadratic residue then the only other value $a^{(p-1)/2}$ may be congruent to is $-1$ since +\begin{equation} +0 \equiv a^{p - 1} - 1 \equiv (a^{(p-1)/2} + 1)(a^{(p-1)/2} - 1) \mbox{ (mod }p\mbox{)} +\end{equation} +One of the terms on the right hand side must be zero. \textbf{QED} + +\subsection{Jacobi Symbol} +The Jacobi symbol is a generalization of the Legendre function for any odd non prime moduli $p$ greater than 2. If $p = \prod_{i=0}^n p_i$ then +the Jacobi symbol $\left ( { a \over p } \right )$ is equal to the following equation. + +\begin{equation} +\left ( { a \over p } \right ) = \left ( { a \over p_0} \right ) \left ( { a \over p_1} \right ) \ldots \left ( { a \over p_n} \right ) +\end{equation} + +By inspection if $p$ is prime the Jacobi symbol is equivalent to the Legendre function. The following facts\footnote{See HAC \cite[pp. 72-74]{HAC} for +further details.} will be used to derive an efficient Jacobi symbol algorithm. Where $p$ is an odd integer greater than two and $a, b \in \Z$ the +following are true. + +\begin{enumerate} +\item $\left ( { a \over p} \right )$ equals $-1$, $0$ or $1$. +\item $\left ( { ab \over p} \right ) = \left ( { a \over p} \right )\left ( { b \over p} \right )$. +\item If $a \equiv b$ then $\left ( { a \over p} \right ) = \left ( { b \over p} \right )$. +\item $\left ( { 2 \over p} \right )$ equals $1$ if $p \equiv 1$ or $7 \mbox{ (mod }8\mbox{)}$. Otherwise, it equals $-1$. +\item $\left ( { a \over p} \right ) \equiv \left ( { p \over a} \right ) \cdot (-1)^{(p-1)(a-1)/4}$. More specifically +$\left ( { a \over p} \right ) = \left ( { p \over a} \right )$ if $p \equiv a \equiv 1 \mbox{ (mod }4\mbox{)}$. +\end{enumerate} + +Using these facts if $a = 2^k \cdot a'$ then + +\begin{eqnarray} +\left ( { a \over p } \right ) = \left ( {{2^k} \over p } \right ) \left ( {a' \over p} \right ) \nonumber \\ + = \left ( {2 \over p } \right )^k \left ( {a' \over p} \right ) +\label{eqn:jacobi} +\end{eqnarray} + +By fact five, + +\begin{equation} +\left ( { a \over p } \right ) = \left ( { p \over a } \right ) \cdot (-1)^{(p-1)(a-1)/4} +\end{equation} + +Subsequently by fact three since $p \equiv (p \mbox{ mod }a) \mbox{ (mod }a\mbox{)}$ then + +\begin{equation} +\left ( { a \over p } \right ) = \left ( { {p \mbox{ mod } a} \over a } \right ) \cdot (-1)^{(p-1)(a-1)/4} +\end{equation} + +By putting both observations into equation \ref{eqn:jacobi} the following simplified equation is formed. + +\begin{equation} +\left ( { a \over p } \right ) = \left ( {2 \over p } \right )^k \left ( {{p\mbox{ mod }a'} \over a'} \right ) \cdot (-1)^{(p-1)(a'-1)/4} +\end{equation} + +The value of $\left ( {{p \mbox{ mod }a'} \over a'} \right )$ can be found by using the same equation recursively. The value of +$\left ( {2 \over p } \right )^k$ equals $1$ if $k$ is even otherwise it equals $\left ( {2 \over p } \right )$. Using this approach the +factors of $p$ do not have to be known. Furthermore, if $(a, p) = 1$ then the algorithm will terminate when the recursion requests the +Jacobi symbol computation of $\left ( {1 \over a'} \right )$ which is simply $1$. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_jacobi}. \\ +\textbf{Input}. mp\_int $a$ and $p$, $a \ge 0$, $p \ge 3$, $p \equiv 1 \mbox{ (mod }2\mbox{)}$ \\ +\textbf{Output}. The Jacobi symbol $c = \left ( {a \over p } \right )$. \\ +\hline \\ +1. If $a = 0$ then \\ +\hspace{3mm}1.1 $c \leftarrow 0$ \\ +\hspace{3mm}1.2 Return(\textit{MP\_OKAY}). \\ +2. If $a = 1$ then \\ +\hspace{3mm}2.1 $c \leftarrow 1$ \\ +\hspace{3mm}2.2 Return(\textit{MP\_OKAY}). \\ +3. $a' \leftarrow a$ \\ +4. $k \leftarrow 0$ \\ +5. While $a'.used > 0$ and $a'_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\ +\hspace{3mm}5.1 $k \leftarrow k + 1$ \\ +\hspace{3mm}5.2 $a' \leftarrow \lfloor a' / 2 \rfloor$ \\ +6. If $k \equiv 0 \mbox{ (mod }2\mbox{)}$ then \\ +\hspace{3mm}6.1 $s \leftarrow 1$ \\ +7. else \\ +\hspace{3mm}7.1 $r \leftarrow p_0 \mbox{ (mod }8\mbox{)}$ \\ +\hspace{3mm}7.2 If $r = 1$ or $r = 7$ then \\ +\hspace{6mm}7.2.1 $s \leftarrow 1$ \\ +\hspace{3mm}7.3 else \\ +\hspace{6mm}7.3.1 $s \leftarrow -1$ \\ +8. If $p_0 \equiv a'_0 \equiv 3 \mbox{ (mod }4\mbox{)}$ then \\ +\hspace{3mm}8.1 $s \leftarrow -s$ \\ +9. If $a' \ne 1$ then \\ +\hspace{3mm}9.1 $p' \leftarrow p \mbox{ (mod }a'\mbox{)}$ \\ +\hspace{3mm}9.2 $s \leftarrow s \cdot \mbox{mp\_jacobi}(p', a')$ \\ +10. $c \leftarrow s$ \\ +11. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_jacobi} +\end{figure} +\textbf{Algorithm mp\_jacobi.} +This algorithm computes the Jacobi symbol for an arbitrary positive integer $a$ with respect to an odd integer $p$ greater than three. The algorithm +is based on algorithm 2.149 of HAC \cite[pp. 73]{HAC}. + +Step numbers one and two handle the trivial cases of $a = 0$ and $a = 1$ respectively. Step five determines the number of two factors in the +input $a$. If $k$ is even than the term $\left ( { 2 \over p } \right )^k$ must always evaluate to one. If $k$ is odd than the term evaluates to one +if $p_0$ is congruent to one or seven modulo eight, otherwise it evaluates to $-1$. After the the $\left ( { 2 \over p } \right )^k$ term is handled +the $(-1)^{(p-1)(a'-1)/4}$ is computed and multiplied against the current product $s$. The latter term evaluates to one if both $p$ and $a'$ +are congruent to one modulo four, otherwise it evaluates to negative one. + +By step nine if $a'$ does not equal one a recursion is required. Step 9.1 computes $p' \equiv p \mbox{ (mod }a'\mbox{)}$ and will recurse to compute +$\left ( {p' \over a'} \right )$ which is multiplied against the current Jacobi product. + +EXAM,bn_mp_jacobi.c + +As a matter of practicality the variable $a'$ as per the pseudo-code is reprensented by the variable $a1$ since the $'$ symbol is not valid for a C +variable name character. + +The two simple cases of $a = 0$ and $a = 1$ are handled at the very beginning to simplify the algorithm. If the input is non-trivial the algorithm +has to proceed compute the Jacobi. The variable $s$ is used to hold the current Jacobi product. Note that $s$ is merely a C ``int'' data type since +the values it may obtain are merely $-1$, $0$ and $1$. + +After a local copy of $a$ is made all of the factors of two are divided out and the total stored in $k$. Technically only the least significant +bit of $k$ is required, however, it makes the algorithm simpler to follow to perform an addition. In practice an exclusive-or and addition have the same +processor requirements and neither is faster than the other. + +Line @59, if@ through @70, }@ determines the value of $\left ( { 2 \over p } \right )^k$. If the least significant bit of $k$ is zero than +$k$ is even and the value is one. Otherwise, the value of $s$ depends on which residue class $p$ belongs to modulo eight. The value of +$(-1)^{(p-1)(a'-1)/4}$ is compute and multiplied against $s$ on lines @73, if@ through @75, }@. + +Finally, if $a1$ does not equal one the algorithm must recurse and compute $\left ( {p' \over a'} \right )$. + +\textit{-- Comment about default $s$ and such...} + +\section{Modular Inverse} +\label{sec:modinv} +The modular inverse of a number actually refers to the modular multiplicative inverse. Essentially for any integer $a$ such that $(a, p) = 1$ there +exist another integer $b$ such that $ab \equiv 1 \mbox{ (mod }p\mbox{)}$. The integer $b$ is called the multiplicative inverse of $a$ which is +denoted as $b = a^{-1}$. Technically speaking modular inversion is a well defined operation for any finite ring or field not just for rings and +fields of integers. However, the former will be the matter of discussion. + +The simplest approach is to compute the algebraic inverse of the input. That is to compute $b \equiv a^{\Phi(p) - 1}$. If $\Phi(p)$ is the +order of the multiplicative subgroup modulo $p$ then $b$ must be the multiplicative inverse of $a$. The proof of which is trivial. + +\begin{equation} +ab \equiv a \left (a^{\Phi(p) - 1} \right ) \equiv a^{\Phi(p)} \equiv a^0 \equiv 1 \mbox{ (mod }p\mbox{)} +\end{equation} + +However, as simple as this approach may be it has two serious flaws. It requires that the value of $\Phi(p)$ be known which if $p$ is composite +requires all of the prime factors. This approach also is very slow as the size of $p$ grows. + +A simpler approach is based on the observation that solving for the multiplicative inverse is equivalent to solving the linear +Diophantine\footnote{See LeVeque \cite[pp. 40-43]{LeVeque} for more information.} equation. + +\begin{equation} +ab + pq = 1 +\end{equation} + +Where $a$, $b$, $p$ and $q$ are all integers. If such a pair of integers $ \left < b, q \right >$ exist than $b$ is the multiplicative inverse of +$a$ modulo $p$. The extended Euclidean algorithm (Knuth \cite[pp. 342]{TAOCPV2}) can be used to solve such equations provided $(a, p) = 1$. +However, instead of using that algorithm directly a variant known as the binary Extended Euclidean algorithm will be used in its place. The +binary approach is very similar to the binary greatest common divisor algorithm except it will produce a full solution to the Diophantine +equation. + +\subsection{General Case} +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_invmod}. \\ +\textbf{Input}. mp\_int $a$ and $b$, $(a, b) = 1$, $p \ge 2$, $0 < a < p$. \\ +\textbf{Output}. The modular inverse $c \equiv a^{-1} \mbox{ (mod }b\mbox{)}$. \\ +\hline \\ +1. If $b \le 0$ then return(\textit{MP\_VAL}). \\ +2. If $b_0 \equiv 1 \mbox{ (mod }2\mbox{)}$ then use algorithm fast\_mp\_invmod. \\ +3. $x \leftarrow \vert a \vert, y \leftarrow b$ \\ +4. If $x_0 \equiv y_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ then return(\textit{MP\_VAL}). \\ +5. $B \leftarrow 0, C \leftarrow 0, A \leftarrow 1, D \leftarrow 1$ \\ +6. While $u.used > 0$ and $u_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\ +\hspace{3mm}6.1 $u \leftarrow \lfloor u / 2 \rfloor$ \\ +\hspace{3mm}6.2 If ($A.used > 0$ and $A_0 \equiv 1 \mbox{ (mod }2\mbox{)}$) or ($B.used > 0$ and $B_0 \equiv 1 \mbox{ (mod }2\mbox{)}$) then \\ +\hspace{6mm}6.2.1 $A \leftarrow A + y$ \\ +\hspace{6mm}6.2.2 $B \leftarrow B - x$ \\ +\hspace{3mm}6.3 $A \leftarrow \lfloor A / 2 \rfloor$ \\ +\hspace{3mm}6.4 $B \leftarrow \lfloor B / 2 \rfloor$ \\ +7. While $v.used > 0$ and $v_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\ +\hspace{3mm}7.1 $v \leftarrow \lfloor v / 2 \rfloor$ \\ +\hspace{3mm}7.2 If ($C.used > 0$ and $C_0 \equiv 1 \mbox{ (mod }2\mbox{)}$) or ($D.used > 0$ and $D_0 \equiv 1 \mbox{ (mod }2\mbox{)}$) then \\ +\hspace{6mm}7.2.1 $C \leftarrow C + y$ \\ +\hspace{6mm}7.2.2 $D \leftarrow D - x$ \\ +\hspace{3mm}7.3 $C \leftarrow \lfloor C / 2 \rfloor$ \\ +\hspace{3mm}7.4 $D \leftarrow \lfloor D / 2 \rfloor$ \\ +8. If $u \ge v$ then \\ +\hspace{3mm}8.1 $u \leftarrow u - v$ \\ +\hspace{3mm}8.2 $A \leftarrow A - C$ \\ +\hspace{3mm}8.3 $B \leftarrow B - D$ \\ +9. else \\ +\hspace{3mm}9.1 $v \leftarrow v - u$ \\ +\hspace{3mm}9.2 $C \leftarrow C - A$ \\ +\hspace{3mm}9.3 $D \leftarrow D - B$ \\ +10. If $u \ne 0$ goto step 6. \\ +11. If $v \ne 1$ return(\textit{MP\_VAL}). \\ +12. While $C \le 0$ do \\ +\hspace{3mm}12.1 $C \leftarrow C + b$ \\ +13. While $C \ge b$ do \\ +\hspace{3mm}13.1 $C \leftarrow C - b$ \\ +14. $c \leftarrow C$ \\ +15. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\end{figure} +\textbf{Algorithm mp\_invmod.} +This algorithm computes the modular multiplicative inverse of an integer $a$ modulo an integer $b$. This algorithm is a variation of the +extended binary Euclidean algorithm from HAC \cite[pp. 608]{HAC}. It has been modified to only compute the modular inverse and not a complete +Diophantine solution. + +If $b \le 0$ than the modulus is invalid and MP\_VAL is returned. Similarly if both $a$ and $b$ are even then there cannot be a multiplicative +inverse for $a$ and the error is reported. + +The astute reader will observe that steps seven through nine are very similar to the binary greatest common divisor algorithm mp\_gcd. In this case +the other variables to the Diophantine equation are solved. The algorithm terminates when $u = 0$ in which case the solution is + +\begin{equation} +Ca + Db = v +\end{equation} + +If $v$, the greatest common divisor of $a$ and $b$ is not equal to one then the algorithm will report an error as no inverse exists. Otherwise, $C$ +is the modular inverse of $a$. The actual value of $C$ is congruent to, but not necessarily equal to, the ideal modular inverse which should lie +within $1 \le a^{-1} < b$. Step numbers twelve and thirteen adjust the inverse until it is in range. If the original input $a$ is within $0 < a < p$ +then only a couple of additions or subtractions will be required to adjust the inverse. + +EXAM,bn_mp_invmod.c + +\subsubsection{Odd Moduli} + +When the modulus $b$ is odd the variables $A$ and $C$ are fixed and are not required to compute the inverse. In particular by attempting to solve +the Diophantine $Cb + Da = 1$ only $B$ and $D$ are required to find the inverse of $a$. + +The algorithm fast\_mp\_invmod is a direct adaptation of algorithm mp\_invmod with all all steps involving either $A$ or $C$ removed. This +optimization will halve the time required to compute the modular inverse. + +\section{Primality Tests} + +A non-zero integer $a$ is said to be prime if it is not divisible by any other integer excluding one and itself. For example, $a = 7$ is prime +since the integers $2 \ldots 6$ do not evenly divide $a$. By contrast, $a = 6$ is not prime since $a = 6 = 2 \cdot 3$. + +Prime numbers arise in cryptography considerably as they allow finite fields to be formed. The ability to determine whether an integer is prime or +not quickly has been a viable subject in cryptography and number theory for considerable time. The algorithms that will be presented are all +probablistic algorithms in that when they report an integer is composite it must be composite. However, when the algorithms report an integer is +prime the algorithm may be incorrect. + +As will be discussed it is possible to limit the probability of error so well that for practical purposes the probablity of error might as +well be zero. For the purposes of these discussions let $n$ represent the candidate integer of which the primality is in question. + +\subsection{Trial Division} + +Trial division means to attempt to evenly divide a candidate integer by small prime integers. If the candidate can be evenly divided it obviously +cannot be prime. By dividing by all primes $1 < p \le \sqrt{n}$ this test can actually prove whether an integer is prime. However, such a test +would require a prohibitive amount of time as $n$ grows. + +Instead of dividing by every prime, a smaller, more mangeable set of primes may be used instead. By performing trial division with only a subset +of the primes less than $\sqrt{n} + 1$ the algorithm cannot prove if a candidate is prime. However, often it can prove a candidate is not prime. + +The benefit of this test is that trial division by small values is fairly efficient. Specially compared to the other algorithms that will be +discussed shortly. The probability that this approach correctly identifies a composite candidate when tested with all primes upto $q$ is given by +$1 - {1.12 \over ln(q)}$. The graph (\ref{pic:primality}, will be added later) demonstrates the probability of success for the range +$3 \le q \le 100$. + +At approximately $q = 30$ the gain of performing further tests diminishes fairly quickly. At $q = 90$ further testing is generally not going to +be of any practical use. In the case of LibTomMath the default limit $q = 256$ was chosen since it is not too high and will eliminate +approximately $80\%$ of all candidate integers. The constant \textbf{PRIME\_SIZE} is equal to the number of primes in the test base. The +array \_\_prime\_tab is an array of the first \textbf{PRIME\_SIZE} prime numbers. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_prime\_is\_divisible}. \\ +\textbf{Input}. mp\_int $a$ \\ +\textbf{Output}. $c = 1$ if $n$ is divisible by a small prime, otherwise $c = 0$. \\ +\hline \\ +1. for $ix$ from $0$ to $PRIME\_SIZE$ do \\ +\hspace{3mm}1.1 $d \leftarrow n \mbox{ (mod }\_\_prime\_tab_{ix}\mbox{)}$ \\ +\hspace{3mm}1.2 If $d = 0$ then \\ +\hspace{6mm}1.2.1 $c \leftarrow 1$ \\ +\hspace{6mm}1.2.2 Return(\textit{MP\_OKAY}). \\ +2. $c \leftarrow 0$ \\ +3. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_prime\_is\_divisible} +\end{figure} +\textbf{Algorithm mp\_prime\_is\_divisible.} +This algorithm attempts to determine if a candidate integer $n$ is composite by performing trial divisions. + +EXAM,bn_mp_prime_is_divisible.c + +The algorithm defaults to a return of $0$ in case an error occurs. The values in the prime table are all specified to be in the range of a +mp\_digit. The table \_\_prime\_tab is defined in the following file. + +EXAM,bn_prime_tab.c + +Note that there are two possible tables. When an mp\_digit is 7-bits long only the primes upto $127$ may be included, otherwise the primes +upto $1619$ are used. Note that the value of \textbf{PRIME\_SIZE} is a constant dependent on the size of a mp\_digit. + +\subsection{The Fermat Test} +The Fermat test is probably one the oldest tests to have a non-trivial probability of success. It is based on the fact that if $n$ is in +fact prime then $a^{n} \equiv a \mbox{ (mod }n\mbox{)}$ for all $0 < a < n$. The reason being that if $n$ is prime than the order of +the multiplicative sub group is $n - 1$. Any base $a$ must have an order which divides $n - 1$ and as such $a^n$ is equivalent to +$a^1 = a$. + +If $n$ is composite then any given base $a$ does not have to have a period which divides $n - 1$. In which case +it is possible that $a^n \nequiv a \mbox{ (mod }n\mbox{)}$. However, this test is not absolute as it is possible that the order +of a base will divide $n - 1$ which would then be reported as prime. Such a base yields what is known as a Fermat pseudo-prime. Several +integers known as Carmichael numbers will be a pseudo-prime to all valid bases. Fortunately such numbers are extremely rare as $n$ grows +in size. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_prime\_fermat}. \\ +\textbf{Input}. mp\_int $a$ and $b$, $a \ge 2$, $0 < b < a$. \\ +\textbf{Output}. $c = 1$ if $b^a \equiv b \mbox{ (mod }a\mbox{)}$, otherwise $c = 0$. \\ +\hline \\ +1. $t \leftarrow b^a \mbox{ (mod }a\mbox{)}$ \\ +2. If $t = b$ then \\ +\hspace{3mm}2.1 $c = 1$ \\ +3. else \\ +\hspace{3mm}3.1 $c = 0$ \\ +4. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_prime\_fermat} +\end{figure} +\textbf{Algorithm mp\_prime\_fermat.} +This algorithm determines whether an mp\_int $a$ is a Fermat prime to the base $b$ or not. It uses a single modular exponentiation to +determine the result. + +EXAM,bn_mp_prime_fermat.c + +\subsection{The Miller-Rabin Test} +The Miller-Rabin (citation) test is another primality test which has tighter error bounds than the Fermat test specifically with sequentially chosen +candidate integers. The algorithm is based on the observation that if $n - 1 = 2^kr$ and if $b^r \nequiv \pm 1$ then after upto $k - 1$ squarings the +value must be equal to $-1$. The squarings are stopped as soon as $-1$ is observed. If the value of $1$ is observed first it means that +some value not congruent to $\pm 1$ when squared equals one which cannot occur if $n$ is prime. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_prime\_miller\_rabin}. \\ +\textbf{Input}. mp\_int $a$ and $b$, $a \ge 2$, $0 < b < a$. \\ +\textbf{Output}. $c = 1$ if $a$ is a Miller-Rabin prime to the base $a$, otherwise $c = 0$. \\ +\hline +1. $a' \leftarrow a - 1$ \\ +2. $r \leftarrow n1$ \\ +3. $c \leftarrow 0, s \leftarrow 0$ \\ +4. While $r.used > 0$ and $r_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\ +\hspace{3mm}4.1 $s \leftarrow s + 1$ \\ +\hspace{3mm}4.2 $r \leftarrow \lfloor r / 2 \rfloor$ \\ +5. $y \leftarrow b^r \mbox{ (mod }a\mbox{)}$ \\ +6. If $y \nequiv \pm 1$ then \\ +\hspace{3mm}6.1 $j \leftarrow 1$ \\ +\hspace{3mm}6.2 While $j \le (s - 1)$ and $y \nequiv a'$ \\ +\hspace{6mm}6.2.1 $y \leftarrow y^2 \mbox{ (mod }a\mbox{)}$ \\ +\hspace{6mm}6.2.2 If $y = 1$ then goto step 8. \\ +\hspace{6mm}6.2.3 $j \leftarrow j + 1$ \\ +\hspace{3mm}6.3 If $y \nequiv a'$ goto step 8. \\ +7. $c \leftarrow 1$\\ +8. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_prime\_miller\_rabin} +\end{figure} +\textbf{Algorithm mp\_prime\_miller\_rabin.} +This algorithm performs one trial round of the Miller-Rabin algorithm to the base $b$. It will set $c = 1$ if the algorithm cannot determine +if $b$ is composite or $c = 0$ if $b$ is provably composite. The values of $s$ and $r$ are computed such that $a' = a - 1 = 2^sr$. + +If the value $y \equiv b^r$ is congruent to $\pm 1$ then the algorithm cannot prove if $a$ is composite or not. Otherwise, the algorithm will +square $y$ upto $s - 1$ times stopping only when $y \equiv -1$. If $y^2 \equiv 1$ and $y \nequiv \pm 1$ then the algorithm can report that $a$ +is provably composite. If the algorithm performs $s - 1$ squarings and $y \nequiv -1$ then $a$ is provably composite. If $a$ is not provably +composite then it is \textit{probably} prime. + +EXAM,bn_mp_prime_miller_rabin.c + + + + +\backmatter +\appendix +\begin{thebibliography}{ABCDEF} +\bibitem[1]{TAOCPV2} +Donald Knuth, \textit{The Art of Computer Programming}, Third Edition, Volume Two, Seminumerical Algorithms, Addison-Wesley, 1998 + +\bibitem[2]{HAC} +A. Menezes, P. van Oorschot, S. Vanstone, \textit{Handbook of Applied Cryptography}, CRC Press, 1996 + +\bibitem[3]{ROSE} +Michael Rosing, \textit{Implementing Elliptic Curve Cryptography}, Manning Publications, 1999 + +\bibitem[4]{COMBA} +Paul G. Comba, \textit{Exponentiation Cryptosystems on the IBM PC}. IBM Systems Journal 29(4): 526-538 (1990) + +\bibitem[5]{KARA} +A. Karatsuba, Doklay Akad. Nauk SSSR 145 (1962), pp.293-294 + +\bibitem[6]{KARAP} +Andre Weimerskirch and Christof Paar, \textit{Generalizations of the Karatsuba Algorithm for Polynomial Multiplication}, Submitted to Design, Codes and Cryptography, March 2002 + +\bibitem[7]{BARRETT} +Paul Barrett, \textit{Implementing the Rivest Shamir and Adleman Public Key Encryption Algorithm on a Standard Digital Signal Processor}, Advances in Cryptology, Crypto '86, Springer-Verlag. + +\bibitem[8]{MONT} +P.L.Montgomery. \textit{Modular multiplication without trial division}. Mathematics of Computation, 44(170):519-521, April 1985. + +\bibitem[9]{DRMET} +Chae Hoon Lim and Pil Joong Lee, \textit{Generating Efficient Primes for Discrete Log Cryptosystems}, POSTECH Information Research Laboratories + +\bibitem[10]{MMB} +J. Daemen and R. Govaerts and J. Vandewalle, \textit{Block ciphers based on Modular Arithmetic}, State and {P}rogress in the {R}esearch of {C}ryptography, 1993, pp. 80-89 + +\bibitem[11]{RSAREF} +R.L. Rivest, A. Shamir, L. Adleman, \textit{A Method for Obtaining Digital Signatures and Public-Key Cryptosystems} + +\bibitem[12]{DHREF} +Whitfield Diffie, Martin E. Hellman, \textit{New Directions in Cryptography}, IEEE Transactions on Information Theory, 1976 + +\bibitem[13]{IEEE} +IEEE Standard for Binary Floating-Point Arithmetic (ANSI/IEEE Std 754-1985) + +\bibitem[14]{GMP} +GNU Multiple Precision (GMP), \url{http://www.swox.com/gmp/} + +\bibitem[15]{MPI} +Multiple Precision Integer Library (MPI), Michael Fromberger, \url{http://thayer.dartmouth.edu/~sting/mpi/} + +\bibitem[16]{OPENSSL} +OpenSSL Cryptographic Toolkit, \url{http://openssl.org} + +\bibitem[17]{LIP} +Large Integer Package, \url{http://home.hetnet.nl/~ecstr/LIP.zip} + +\bibitem[18]{ISOC} +JTC1/SC22/WG14, ISO/IEC 9899:1999, ``A draft rationale for the C99 standard.'' + +\bibitem[19]{JAVA} +The Sun Java Website, \url{http://java.sun.com/} + +\end{thebibliography} + +\input{tommath.ind} + +\end{document} ADDED libtommath/tommath.tex Index: libtommath/tommath.tex ================================================================== --- /dev/null +++ libtommath/tommath.tex @@ -0,0 +1,10880 @@ +\documentclass[b5paper]{book} +\usepackage{hyperref} +\usepackage{makeidx} +\usepackage{amssymb} +\usepackage{color} +\usepackage{alltt} +\usepackage{graphicx} +\usepackage{layout} +\def\union{\cup} +\def\intersect{\cap} +\def\getsrandom{\stackrel{\rm R}{\gets}} +\def\cross{\times} +\def\cat{\hspace{0.5em} \| \hspace{0.5em}} +\def\catn{$\|$} +\def\divides{\hspace{0.3em} | \hspace{0.3em}} +\def\nequiv{\not\equiv} +\def\approx{\raisebox{0.2ex}{\mbox{\small $\sim$}}} +\def\lcm{{\rm lcm}} +\def\gcd{{\rm gcd}} +\def\log{{\rm log}} +\def\ord{{\rm ord}} +\def\abs{{\mathit abs}} +\def\rep{{\mathit rep}} +\def\mod{{\mathit\ mod\ }} +\renewcommand{\pmod}[1]{\ ({\rm mod\ }{#1})} +\newcommand{\floor}[1]{\left\lfloor{#1}\right\rfloor} +\newcommand{\ceil}[1]{\left\lceil{#1}\right\rceil} +\def\Or{{\rm\ or\ }} +\def\And{{\rm\ and\ }} +\def\iff{\hspace{1em}\Longleftrightarrow\hspace{1em}} +\def\implies{\Rightarrow} +\def\undefined{{\rm ``undefined"}} +\def\Proof{\vspace{1ex}\noindent {\bf Proof:}\hspace{1em}} +\let\oldphi\phi +\def\phi{\varphi} +\def\Pr{{\rm Pr}} +\newcommand{\str}[1]{{\mathbf{#1}}} +\def\F{{\mathbb F}} +\def\N{{\mathbb N}} +\def\Z{{\mathbb Z}} +\def\R{{\mathbb R}} +\def\C{{\mathbb C}} +\def\Q{{\mathbb Q}} +\definecolor{DGray}{gray}{0.5} +\newcommand{\emailaddr}[1]{\mbox{$<${#1}$>$}} +\def\twiddle{\raisebox{0.3ex}{\mbox{\tiny $\sim$}}} +\def\gap{\vspace{0.5ex}} +\makeindex +\begin{document} +\frontmatter +\pagestyle{empty} +\title{Multi--Precision Math} +\author{\mbox{ +%\begin{small} +\begin{tabular}{c} +Tom St Denis \\ +Algonquin College \\ +\\ +Mads Rasmussen \\ +Open Communications Security \\ +\\ +Greg Rose \\ +QUALCOMM Australia \\ +\end{tabular} +%\end{small} +} +} +\maketitle +This text has been placed in the public domain. This text corresponds to the v0.36 release of the +LibTomMath project. + +\begin{alltt} +Tom St Denis +111 Banning Rd +Ottawa, Ontario +K2L 1C3 +Canada + +Phone: 1-613-836-3160 +Email: tomstdenis@iahu.ca +\end{alltt} + +This text is formatted to the international B5 paper size of 176mm wide by 250mm tall using the \LaTeX{} +{\em book} macro package and the Perl {\em booker} package. + +\tableofcontents +\listoffigures +\chapter*{Prefaces} +When I tell people about my LibTom projects and that I release them as public domain they are often puzzled. +They ask why I did it and especially why I continue to work on them for free. The best I can explain it is ``Because I can.'' +Which seems odd and perhaps too terse for adult conversation. I often qualify it with ``I am able, I am willing.'' which +perhaps explains it better. I am the first to admit there is not anything that special with what I have done. Perhaps +others can see that too and then we would have a society to be proud of. My LibTom projects are what I am doing to give +back to society in the form of tools and knowledge that can help others in their endeavours. + +I started writing this book because it was the most logical task to further my goal of open academia. The LibTomMath source +code itself was written to be easy to follow and learn from. There are times, however, where pure C source code does not +explain the algorithms properly. Hence this book. The book literally starts with the foundation of the library and works +itself outwards to the more complicated algorithms. The use of both pseudo--code and verbatim source code provides a duality +of ``theory'' and ``practice'' that the computer science students of the world shall appreciate. I never deviate too far +from relatively straightforward algebra and I hope that this book can be a valuable learning asset. + +This book and indeed much of the LibTom projects would not exist in their current form if it was not for a plethora +of kind people donating their time, resources and kind words to help support my work. Writing a text of significant +length (along with the source code) is a tiresome and lengthy process. Currently the LibTom project is four years old, +comprises of literally thousands of users and over 100,000 lines of source code, TeX and other material. People like Mads and Greg +were there at the beginning to encourage me to work well. It is amazing how timely validation from others can boost morale to +continue the project. Definitely my parents were there for me by providing room and board during the many months of work in 2003. + +To my many friends whom I have met through the years I thank you for the good times and the words of encouragement. I hope I +honour your kind gestures with this project. + +Open Source. Open Academia. Open Minds. + +\begin{flushright} Tom St Denis \end{flushright} + +\newpage +I found the opportunity to work with Tom appealing for several reasons, not only could I broaden my own horizons, but also +contribute to educate others facing the problem of having to handle big number mathematical calculations. + +This book is Tom's child and he has been caring and fostering the project ever since the beginning with a clear mind of +how he wanted the project to turn out. I have helped by proofreading the text and we have had several discussions about +the layout and language used. + +I hold a masters degree in cryptography from the University of Southern Denmark and have always been interested in the +practical aspects of cryptography. + +Having worked in the security consultancy business for several years in S\~{a}o Paulo, Brazil, I have been in touch with a +great deal of work in which multiple precision mathematics was needed. Understanding the possibilities for speeding up +multiple precision calculations is often very important since we deal with outdated machine architecture where modular +reductions, for example, become painfully slow. + +This text is for people who stop and wonder when first examining algorithms such as RSA for the first time and asks +themselves, ``You tell me this is only secure for large numbers, fine; but how do you implement these numbers?'' + +\begin{flushright} +Mads Rasmussen + +S\~{a}o Paulo - SP + +Brazil +\end{flushright} + +\newpage +It's all because I broke my leg. That just happened to be at about the same time that Tom asked for someone to review the section of the book about +Karatsuba multiplication. I was laid up, alone and immobile, and thought ``Why not?'' I vaguely knew what Karatsuba multiplication was, but not +really, so I thought I could help, learn, and stop myself from watching daytime cable TV, all at once. + +At the time of writing this, I've still not met Tom or Mads in meatspace. I've been following Tom's progress since his first splash on the +sci.crypt Usenet news group. I watched him go from a clueless newbie, to the cryptographic equivalent of a reformed smoker, to a real +contributor to the field, over a period of about two years. I've been impressed with his obvious intelligence, and astounded by his productivity. +Of course, he's young enough to be my own child, so he doesn't have my problems with staying awake. + +When I reviewed that single section of the book, in its very earliest form, I was very pleasantly surprised. So I decided to collaborate more fully, +and at least review all of it, and perhaps write some bits too. There's still a long way to go with it, and I have watched a number of close +friends go through the mill of publication, so I think that the way to go is longer than Tom thinks it is. Nevertheless, it's a good effort, +and I'm pleased to be involved with it. + +\begin{flushright} +Greg Rose, Sydney, Australia, June 2003. +\end{flushright} + +\mainmatter +\pagestyle{headings} +\chapter{Introduction} +\section{Multiple Precision Arithmetic} + +\subsection{What is Multiple Precision Arithmetic?} +When we think of long-hand arithmetic such as addition or multiplication we rarely consider the fact that we instinctively +raise or lower the precision of the numbers we are dealing with. For example, in decimal we almost immediate can +reason that $7$ times $6$ is $42$. However, $42$ has two digits of precision as opposed to one digit we started with. +Further multiplications of say $3$ result in a larger precision result $126$. In these few examples we have multiple +precisions for the numbers we are working with. Despite the various levels of precision a single subset\footnote{With the occasional optimization.} + of algorithms can be designed to accomodate them. + +By way of comparison a fixed or single precision operation would lose precision on various operations. For example, in +the decimal system with fixed precision $6 \cdot 7 = 2$. + +Essentially at the heart of computer based multiple precision arithmetic are the same long-hand algorithms taught in +schools to manually add, subtract, multiply and divide. + +\subsection{The Need for Multiple Precision Arithmetic} +The most prevalent need for multiple precision arithmetic, often referred to as ``bignum'' math, is within the implementation +of public-key cryptography algorithms. Algorithms such as RSA \cite{RSAREF} and Diffie-Hellman \cite{DHREF} require +integers of significant magnitude to resist known cryptanalytic attacks. For example, at the time of this writing a +typical RSA modulus would be at least greater than $10^{309}$. However, modern programming languages such as ISO C \cite{ISOC} and +Java \cite{JAVA} only provide instrinsic support for integers which are relatively small and single precision. + +\begin{figure}[!here] +\begin{center} +\begin{tabular}{|r|c|} +\hline \textbf{Data Type} & \textbf{Range} \\ +\hline char & $-128 \ldots 127$ \\ +\hline short & $-32768 \ldots 32767$ \\ +\hline long & $-2147483648 \ldots 2147483647$ \\ +\hline long long & $-9223372036854775808 \ldots 9223372036854775807$ \\ +\hline +\end{tabular} +\end{center} +\caption{Typical Data Types for the C Programming Language} +\label{fig:ISOC} +\end{figure} + +The largest data type guaranteed to be provided by the ISO C programming +language\footnote{As per the ISO C standard. However, each compiler vendor is allowed to augment the precision as they +see fit.} can only represent values up to $10^{19}$ as shown in figure \ref{fig:ISOC}. On its own the C language is +insufficient to accomodate the magnitude required for the problem at hand. An RSA modulus of magnitude $10^{19}$ could be +trivially factored\footnote{A Pollard-Rho factoring would take only $2^{16}$ time.} on the average desktop computer, +rendering any protocol based on the algorithm insecure. Multiple precision algorithms solve this very problem by +extending the range of representable integers while using single precision data types. + +Most advancements in fast multiple precision arithmetic stem from the need for faster and more efficient cryptographic +primitives. Faster modular reduction and exponentiation algorithms such as Barrett's algorithm, which have appeared in +various cryptographic journals, can render algorithms such as RSA and Diffie-Hellman more efficient. In fact, several +major companies such as RSA Security, Certicom and Entrust have built entire product lines on the implementation and +deployment of efficient algorithms. + +However, cryptography is not the only field of study that can benefit from fast multiple precision integer routines. +Another auxiliary use of multiple precision integers is high precision floating point data types. +The basic IEEE \cite{IEEE} standard floating point type is made up of an integer mantissa $q$, an exponent $e$ and a sign bit $s$. +Numbers are given in the form $n = q \cdot b^e \cdot -1^s$ where $b = 2$ is the most common base for IEEE. Since IEEE +floating point is meant to be implemented in hardware the precision of the mantissa is often fairly small +(\textit{23, 48 and 64 bits}). The mantissa is merely an integer and a multiple precision integer could be used to create +a mantissa of much larger precision than hardware alone can efficiently support. This approach could be useful where +scientific applications must minimize the total output error over long calculations. + +Yet another use for large integers is within arithmetic on polynomials of large characteristic (i.e. $GF(p)[x]$ for large $p$). +In fact the library discussed within this text has already been used to form a polynomial basis library\footnote{See \url{http://poly.libtomcrypt.org} for more details.}. + +\subsection{Benefits of Multiple Precision Arithmetic} +\index{precision} +The benefit of multiple precision representations over single or fixed precision representations is that +no precision is lost while representing the result of an operation which requires excess precision. For example, +the product of two $n$-bit integers requires at least $2n$ bits of precision to be represented faithfully. A multiple +precision algorithm would augment the precision of the destination to accomodate the result while a single precision system +would truncate excess bits to maintain a fixed level of precision. + +It is possible to implement algorithms which require large integers with fixed precision algorithms. For example, elliptic +curve cryptography (\textit{ECC}) is often implemented on smartcards by fixing the precision of the integers to the maximum +size the system will ever need. Such an approach can lead to vastly simpler algorithms which can accomodate the +integers required even if the host platform cannot natively accomodate them\footnote{For example, the average smartcard +processor has an 8 bit accumulator.}. However, as efficient as such an approach may be, the resulting source code is not +normally very flexible. It cannot, at runtime, accomodate inputs of higher magnitude than the designer anticipated. + +Multiple precision algorithms have the most overhead of any style of arithmetic. For the the most part the +overhead can be kept to a minimum with careful planning, but overall, it is not well suited for most memory starved +platforms. However, multiple precision algorithms do offer the most flexibility in terms of the magnitude of the +inputs. That is, the same algorithms based on multiple precision integers can accomodate any reasonable size input +without the designer's explicit forethought. This leads to lower cost of ownership for the code as it only has to +be written and tested once. + +\section{Purpose of This Text} +The purpose of this text is to instruct the reader regarding how to implement efficient multiple precision algorithms. +That is to not only explain a limited subset of the core theory behind the algorithms but also the various ``house keeping'' +elements that are neglected by authors of other texts on the subject. Several well reknowned texts \cite{TAOCPV2,HAC} +give considerably detailed explanations of the theoretical aspects of algorithms and often very little information +regarding the practical implementation aspects. + +In most cases how an algorithm is explained and how it is actually implemented are two very different concepts. For +example, the Handbook of Applied Cryptography (\textit{HAC}), algorithm 14.7 on page 594, gives a relatively simple +algorithm for performing multiple precision integer addition. However, the description lacks any discussion concerning +the fact that the two integer inputs may be of differing magnitudes. As a result the implementation is not as simple +as the text would lead people to believe. Similarly the division routine (\textit{algorithm 14.20, pp. 598}) does not +discuss how to handle sign or handle the dividend's decreasing magnitude in the main loop (\textit{step \#3}). + +Both texts also do not discuss several key optimal algorithms required such as ``Comba'' and Karatsuba multipliers +and fast modular inversion, which we consider practical oversights. These optimal algorithms are vital to achieve +any form of useful performance in non-trivial applications. + +To solve this problem the focus of this text is on the practical aspects of implementing a multiple precision integer +package. As a case study the ``LibTomMath''\footnote{Available at \url{http://math.libtomcrypt.org}} package is used +to demonstrate algorithms with real implementations\footnote{In the ISO C programming language.} that have been field +tested and work very well. The LibTomMath library is freely available on the Internet for all uses and this text +discusses a very large portion of the inner workings of the library. + +The algorithms that are presented will always include at least one ``pseudo-code'' description followed +by the actual C source code that implements the algorithm. The pseudo-code can be used to implement the same +algorithm in other programming languages as the reader sees fit. + +This text shall also serve as a walkthrough of the creation of multiple precision algorithms from scratch. Showing +the reader how the algorithms fit together as well as where to start on various taskings. + +\section{Discussion and Notation} +\subsection{Notation} +A multiple precision integer of $n$-digits shall be denoted as $x = (x_{n-1}, \ldots, x_1, x_0)_{ \beta }$ and represent +the integer $x \equiv \sum_{i=0}^{n-1} x_i\beta^i$. The elements of the array $x$ are said to be the radix $\beta$ digits +of the integer. For example, $x = (1,2,3)_{10}$ would represent the integer +$1\cdot 10^2 + 2\cdot10^1 + 3\cdot10^0 = 123$. + +\index{mp\_int} +The term ``mp\_int'' shall refer to a composite structure which contains the digits of the integer it represents, as well +as auxilary data required to manipulate the data. These additional members are discussed further in section +\ref{sec:MPINT}. For the purposes of this text a ``multiple precision integer'' and an ``mp\_int'' are assumed to be +synonymous. When an algorithm is specified to accept an mp\_int variable it is assumed the various auxliary data members +are present as well. An expression of the type \textit{variablename.item} implies that it should evaluate to the +member named ``item'' of the variable. For example, a string of characters may have a member ``length'' which would +evaluate to the number of characters in the string. If the string $a$ equals ``hello'' then it follows that +$a.length = 5$. + +For certain discussions more generic algorithms are presented to help the reader understand the final algorithm used +to solve a given problem. When an algorithm is described as accepting an integer input it is assumed the input is +a plain integer with no additional multiple-precision members. That is, algorithms that use integers as opposed to +mp\_ints as inputs do not concern themselves with the housekeeping operations required such as memory management. These +algorithms will be used to establish the relevant theory which will subsequently be used to describe a multiple +precision algorithm to solve the same problem. + +\subsection{Precision Notation} +The variable $\beta$ represents the radix of a single digit of a multiple precision integer and +must be of the form $q^p$ for $q, p \in \Z^+$. A single precision variable must be able to represent integers in +the range $0 \le x < q \beta$ while a double precision variable must be able to represent integers in the range +$0 \le x < q \beta^2$. The extra radix-$q$ factor allows additions and subtractions to proceed without truncation of the +carry. Since all modern computers are binary, it is assumed that $q$ is two. + +\index{mp\_digit} \index{mp\_word} +Within the source code that will be presented for each algorithm, the data type \textbf{mp\_digit} will represent +a single precision integer type, while, the data type \textbf{mp\_word} will represent a double precision integer type. In +several algorithms (notably the Comba routines) temporary results will be stored in arrays of double precision mp\_words. +For the purposes of this text $x_j$ will refer to the $j$'th digit of a single precision array and $\hat x_j$ will refer to +the $j$'th digit of a double precision array. Whenever an expression is to be assigned to a double precision +variable it is assumed that all single precision variables are promoted to double precision during the evaluation. +Expressions that are assigned to a single precision variable are truncated to fit within the precision of a single +precision data type. + +For example, if $\beta = 10^2$ a single precision data type may represent a value in the +range $0 \le x < 10^3$, while a double precision data type may represent a value in the range $0 \le x < 10^5$. Let +$a = 23$ and $b = 49$ represent two single precision variables. The single precision product shall be written +as $c \leftarrow a \cdot b$ while the double precision product shall be written as $\hat c \leftarrow a \cdot b$. +In this particular case, $\hat c = 1127$ and $c = 127$. The most significant digit of the product would not fit +in a single precision data type and as a result $c \ne \hat c$. + +\subsection{Algorithm Inputs and Outputs} +Within the algorithm descriptions all variables are assumed to be scalars of either single or double precision +as indicated. The only exception to this rule is when variables have been indicated to be of type mp\_int. This +distinction is important as scalars are often used as array indicies and various other counters. + +\subsection{Mathematical Expressions} +The $\lfloor \mbox{ } \rfloor$ brackets imply an expression truncated to an integer not greater than the expression +itself. For example, $\lfloor 5.7 \rfloor = 5$. Similarly the $\lceil \mbox{ } \rceil$ brackets imply an expression +rounded to an integer not less than the expression itself. For example, $\lceil 5.1 \rceil = 6$. Typically when +the $/$ division symbol is used the intention is to perform an integer division with truncation. For example, +$5/2 = 2$ which will often be written as $\lfloor 5/2 \rfloor = 2$ for clarity. When an expression is written as a +fraction a real value division is implied, for example ${5 \over 2} = 2.5$. + +The norm of a multiple precision integer, for example $\vert \vert x \vert \vert$, will be used to represent the number of digits in the representation +of the integer. For example, $\vert \vert 123 \vert \vert = 3$ and $\vert \vert 79452 \vert \vert = 5$. + +\subsection{Work Effort} +\index{big-Oh} +To measure the efficiency of the specified algorithms, a modified big-Oh notation is used. In this system all +single precision operations are considered to have the same cost\footnote{Except where explicitly noted.}. +That is a single precision addition, multiplication and division are assumed to take the same time to +complete. While this is generally not true in practice, it will simplify the discussions considerably. + +Some algorithms have slight advantages over others which is why some constants will not be removed in +the notation. For example, a normal baseline multiplication (section \ref{sec:basemult}) requires $O(n^2)$ work while a +baseline squaring (section \ref{sec:basesquare}) requires $O({{n^2 + n}\over 2})$ work. In standard big-Oh notation these +would both be said to be equivalent to $O(n^2)$. However, +in the context of the this text this is not the case as the magnitude of the inputs will typically be rather small. As a +result small constant factors in the work effort will make an observable difference in algorithm efficiency. + +All of the algorithms presented in this text have a polynomial time work level. That is, of the form +$O(n^k)$ for $n, k \in \Z^{+}$. This will help make useful comparisons in terms of the speed of the algorithms and how +various optimizations will help pay off in the long run. + +\section{Exercises} +Within the more advanced chapters a section will be set aside to give the reader some challenging exercises related to +the discussion at hand. These exercises are not designed to be prize winning problems, but instead to be thought +provoking. Wherever possible the problems are forward minded, stating problems that will be answered in subsequent +chapters. The reader is encouraged to finish the exercises as they appear to get a better understanding of the +subject material. + +That being said, the problems are designed to affirm knowledge of a particular subject matter. Students in particular +are encouraged to verify they can answer the problems correctly before moving on. + +Similar to the exercises of \cite[pp. ix]{TAOCPV2} these exercises are given a scoring system based on the difficulty of +the problem. However, unlike \cite{TAOCPV2} the problems do not get nearly as hard. The scoring of these +exercises ranges from one (the easiest) to five (the hardest). The following table sumarizes the +scoring system used. + +\begin{figure}[here] +\begin{center} +\begin{small} +\begin{tabular}{|c|l|} +\hline $\left [ 1 \right ]$ & An easy problem that should only take the reader a manner of \\ + & minutes to solve. Usually does not involve much computer time \\ + & to solve. \\ +\hline $\left [ 2 \right ]$ & An easy problem that involves a marginal amount of computer \\ + & time usage. Usually requires a program to be written to \\ + & solve the problem. \\ +\hline $\left [ 3 \right ]$ & A moderately hard problem that requires a non-trivial amount \\ + & of work. Usually involves trivial research and development of \\ + & new theory from the perspective of a student. \\ +\hline $\left [ 4 \right ]$ & A moderately hard problem that involves a non-trivial amount \\ + & of work and research, the solution to which will demonstrate \\ + & a higher mastery of the subject matter. \\ +\hline $\left [ 5 \right ]$ & A hard problem that involves concepts that are difficult for a \\ + & novice to solve. Solutions to these problems will demonstrate a \\ + & complete mastery of the given subject. \\ +\hline +\end{tabular} +\end{small} +\end{center} +\caption{Exercise Scoring System} +\end{figure} + +Problems at the first level are meant to be simple questions that the reader can answer quickly without programming a solution or +devising new theory. These problems are quick tests to see if the material is understood. Problems at the second level +are also designed to be easy but will require a program or algorithm to be implemented to arrive at the answer. These +two levels are essentially entry level questions. + +Problems at the third level are meant to be a bit more difficult than the first two levels. The answer is often +fairly obvious but arriving at an exacting solution requires some thought and skill. These problems will almost always +involve devising a new algorithm or implementing a variation of another algorithm previously presented. Readers who can +answer these questions will feel comfortable with the concepts behind the topic at hand. + +Problems at the fourth level are meant to be similar to those of the level three questions except they will require +additional research to be completed. The reader will most likely not know the answer right away, nor will the text provide +the exact details of the answer until a subsequent chapter. + +Problems at the fifth level are meant to be the hardest +problems relative to all the other problems in the chapter. People who can correctly answer fifth level problems have a +mastery of the subject matter at hand. + +Often problems will be tied together. The purpose of this is to start a chain of thought that will be discussed in future chapters. The reader +is encouraged to answer the follow-up problems and try to draw the relevance of problems. + +\section{Introduction to LibTomMath} + +\subsection{What is LibTomMath?} +LibTomMath is a free and open source multiple precision integer library written entirely in portable ISO C. By portable it +is meant that the library does not contain any code that is computer platform dependent or otherwise problematic to use on +any given platform. + +The library has been successfully tested under numerous operating systems including Unix\footnote{All of these +trademarks belong to their respective rightful owners.}, MacOS, Windows, Linux, PalmOS and on standalone hardware such +as the Gameboy Advance. The library is designed to contain enough functionality to be able to develop applications such +as public key cryptosystems and still maintain a relatively small footprint. + +\subsection{Goals of LibTomMath} + +Libraries which obtain the most efficiency are rarely written in a high level programming language such as C. However, +even though this library is written entirely in ISO C, considerable care has been taken to optimize the algorithm implementations within the +library. Specifically the code has been written to work well with the GNU C Compiler (\textit{GCC}) on both x86 and ARM +processors. Wherever possible, highly efficient algorithms, such as Karatsuba multiplication, sliding window +exponentiation and Montgomery reduction have been provided to make the library more efficient. + +Even with the nearly optimal and specialized algorithms that have been included the Application Programing Interface +(\textit{API}) has been kept as simple as possible. Often generic place holder routines will make use of specialized +algorithms automatically without the developer's specific attention. One such example is the generic multiplication +algorithm \textbf{mp\_mul()} which will automatically use Toom--Cook, Karatsuba, Comba or baseline multiplication +based on the magnitude of the inputs and the configuration of the library. + +Making LibTomMath as efficient as possible is not the only goal of the LibTomMath project. Ideally the library should +be source compatible with another popular library which makes it more attractive for developers to use. In this case the +MPI library was used as a API template for all the basic functions. MPI was chosen because it is another library that fits +in the same niche as LibTomMath. Even though LibTomMath uses MPI as the template for the function names and argument +passing conventions, it has been written from scratch by Tom St Denis. + +The project is also meant to act as a learning tool for students, the logic being that no easy-to-follow ``bignum'' +library exists which can be used to teach computer science students how to perform fast and reliable multiple precision +integer arithmetic. To this end the source code has been given quite a few comments and algorithm discussion points. + +\section{Choice of LibTomMath} +LibTomMath was chosen as the case study of this text not only because the author of both projects is one and the same but +for more worthy reasons. Other libraries such as GMP \cite{GMP}, MPI \cite{MPI}, LIP \cite{LIP} and OpenSSL +\cite{OPENSSL} have multiple precision integer arithmetic routines but would not be ideal for this text for +reasons that will be explained in the following sub-sections. + +\subsection{Code Base} +The LibTomMath code base is all portable ISO C source code. This means that there are no platform dependent conditional +segments of code littered throughout the source. This clean and uncluttered approach to the library means that a +developer can more readily discern the true intent of a given section of source code without trying to keep track of +what conditional code will be used. + +The code base of LibTomMath is well organized. Each function is in its own separate source code file +which allows the reader to find a given function very quickly. On average there are $76$ lines of code per source +file which makes the source very easily to follow. By comparison MPI and LIP are single file projects making code tracing +very hard. GMP has many conditional code segments which also hinder tracing. + +When compiled with GCC for the x86 processor and optimized for speed the entire library is approximately $100$KiB\footnote{The notation ``KiB'' means $2^{10}$ octets, similarly ``MiB'' means $2^{20}$ octets.} + which is fairly small compared to GMP (over $250$KiB). LibTomMath is slightly larger than MPI (which compiles to about +$50$KiB) but LibTomMath is also much faster and more complete than MPI. + +\subsection{API Simplicity} +LibTomMath is designed after the MPI library and shares the API design. Quite often programs that use MPI will build +with LibTomMath without change. The function names correlate directly to the action they perform. Almost all of the +functions share the same parameter passing convention. The learning curve is fairly shallow with the API provided +which is an extremely valuable benefit for the student and developer alike. + +The LIP library is an example of a library with an API that is awkward to work with. LIP uses function names that are often ``compressed'' to +illegible short hand. LibTomMath does not share this characteristic. + +The GMP library also does not return error codes. Instead it uses a POSIX.1 \cite{POSIX1} signal system where errors +are signaled to the host application. This happens to be the fastest approach but definitely not the most versatile. In +effect a math error (i.e. invalid input, heap error, etc) can cause a program to stop functioning which is definitely +undersireable in many situations. + +\subsection{Optimizations} +While LibTomMath is certainly not the fastest library (GMP often beats LibTomMath by a factor of two) it does +feature a set of optimal algorithms for tasks such as modular reduction, exponentiation, multiplication and squaring. GMP +and LIP also feature such optimizations while MPI only uses baseline algorithms with no optimizations. GMP lacks a few +of the additional modular reduction optimizations that LibTomMath features\footnote{At the time of this writing GMP +only had Barrett and Montgomery modular reduction algorithms.}. + +LibTomMath is almost always an order of magnitude faster than the MPI library at computationally expensive tasks such as modular +exponentiation. In the grand scheme of ``bignum'' libraries LibTomMath is faster than the average library and usually +slower than the best libraries such as GMP and OpenSSL by only a small factor. + +\subsection{Portability and Stability} +LibTomMath will build ``out of the box'' on any platform equipped with a modern version of the GNU C Compiler +(\textit{GCC}). This means that without changes the library will build without configuration or setting up any +variables. LIP and MPI will build ``out of the box'' as well but have numerous known bugs. Most notably the author of +MPI has recently stopped working on his library and LIP has long since been discontinued. + +GMP requires a configuration script to run and will not build out of the box. GMP and LibTomMath are still in active +development and are very stable across a variety of platforms. + +\subsection{Choice} +LibTomMath is a relatively compact, well documented, highly optimized and portable library which seems only natural for +the case study of this text. Various source files from the LibTomMath project will be included within the text. However, +the reader is encouraged to download their own copy of the library to actually be able to work with the library. + +\chapter{Getting Started} +\section{Library Basics} +The trick to writing any useful library of source code is to build a solid foundation and work outwards from it. First, +a problem along with allowable solution parameters should be identified and analyzed. In this particular case the +inability to accomodate multiple precision integers is the problem. Futhermore, the solution must be written +as portable source code that is reasonably efficient across several different computer platforms. + +After a foundation is formed the remainder of the library can be designed and implemented in a hierarchical fashion. +That is, to implement the lowest level dependencies first and work towards the most abstract functions last. For example, +before implementing a modular exponentiation algorithm one would implement a modular reduction algorithm. +By building outwards from a base foundation instead of using a parallel design methodology the resulting project is +highly modular. Being highly modular is a desirable property of any project as it often means the resulting product +has a small footprint and updates are easy to perform. + +Usually when I start a project I will begin with the header files. I define the data types I think I will need and +prototype the initial functions that are not dependent on other functions (within the library). After I +implement these base functions I prototype more dependent functions and implement them. The process repeats until +I implement all of the functions I require. For example, in the case of LibTomMath I implemented functions such as +mp\_init() well before I implemented mp\_mul() and even further before I implemented mp\_exptmod(). As an example as to +why this design works note that the Karatsuba and Toom-Cook multipliers were written \textit{after} the +dependent function mp\_exptmod() was written. Adding the new multiplication algorithms did not require changes to the +mp\_exptmod() function itself and lowered the total cost of ownership (\textit{so to speak}) and of development +for new algorithms. This methodology allows new algorithms to be tested in a complete framework with relative ease. + +\begin{center} +\begin{figure}[here] +\includegraphics{pics/design_process.ps} +\caption{Design Flow of the First Few Original LibTomMath Functions.} +\label{pic:design_process} +\end{figure} +\end{center} + +Only after the majority of the functions were in place did I pursue a less hierarchical approach to auditing and optimizing +the source code. For example, one day I may audit the multipliers and the next day the polynomial basis functions. + +It only makes sense to begin the text with the preliminary data types and support algorithms required as well. +This chapter discusses the core algorithms of the library which are the dependents for every other algorithm. + +\section{What is a Multiple Precision Integer?} +Recall that most programming languages, in particular ISO C \cite{ISOC}, only have fixed precision data types that on their own cannot +be used to represent values larger than their precision will allow. The purpose of multiple precision algorithms is +to use fixed precision data types to create and manipulate multiple precision integers which may represent values +that are very large. + +As a well known analogy, school children are taught how to form numbers larger than nine by prepending more radix ten digits. In the decimal system +the largest single digit value is $9$. However, by concatenating digits together larger numbers may be represented. Newly prepended digits +(\textit{to the left}) are said to be in a different power of ten column. That is, the number $123$ can be described as having a $1$ in the hundreds +column, $2$ in the tens column and $3$ in the ones column. Or more formally $123 = 1 \cdot 10^2 + 2 \cdot 10^1 + 3 \cdot 10^0$. Computer based +multiple precision arithmetic is essentially the same concept. Larger integers are represented by adjoining fixed +precision computer words with the exception that a different radix is used. + +What most people probably do not think about explicitly are the various other attributes that describe a multiple precision +integer. For example, the integer $154_{10}$ has two immediately obvious properties. First, the integer is positive, +that is the sign of this particular integer is positive as opposed to negative. Second, the integer has three digits in +its representation. There is an additional property that the integer posesses that does not concern pencil-and-paper +arithmetic. The third property is how many digits placeholders are available to hold the integer. + +The human analogy of this third property is ensuring there is enough space on the paper to write the integer. For example, +if one starts writing a large number too far to the right on a piece of paper they will have to erase it and move left. +Similarly, computer algorithms must maintain strict control over memory usage to ensure that the digits of an integer +will not exceed the allowed boundaries. These three properties make up what is known as a multiple precision +integer or mp\_int for short. + +\subsection{The mp\_int Structure} +\label{sec:MPINT} +The mp\_int structure is the ISO C based manifestation of what represents a multiple precision integer. The ISO C standard does not provide for +any such data type but it does provide for making composite data types known as structures. The following is the structure definition +used within LibTomMath. + +\index{mp\_int} +\begin{figure}[here] +\begin{center} +\begin{small} +%\begin{verbatim} +\begin{tabular}{|l|} +\hline +typedef struct \{ \\ +\hspace{3mm}int used, alloc, sign;\\ +\hspace{3mm}mp\_digit *dp;\\ +\} \textbf{mp\_int}; \\ +\hline +\end{tabular} +%\end{verbatim} +\end{small} +\caption{The mp\_int Structure} +\label{fig:mpint} +\end{center} +\end{figure} + +The mp\_int structure (fig. \ref{fig:mpint}) can be broken down as follows. + +\begin{enumerate} +\item The \textbf{used} parameter denotes how many digits of the array \textbf{dp} contain the digits used to represent +a given integer. The \textbf{used} count must be positive (or zero) and may not exceed the \textbf{alloc} count. + +\item The \textbf{alloc} parameter denotes how +many digits are available in the array to use by functions before it has to increase in size. When the \textbf{used} count +of a result would exceed the \textbf{alloc} count all of the algorithms will automatically increase the size of the +array to accommodate the precision of the result. + +\item The pointer \textbf{dp} points to a dynamically allocated array of digits that represent the given multiple +precision integer. It is padded with $(\textbf{alloc} - \textbf{used})$ zero digits. The array is maintained in a least +significant digit order. As a pencil and paper analogy the array is organized such that the right most digits are stored +first starting at the location indexed by zero\footnote{In C all arrays begin at zero.} in the array. For example, +if \textbf{dp} contains $\lbrace a, b, c, \ldots \rbrace$ where \textbf{dp}$_0 = a$, \textbf{dp}$_1 = b$, \textbf{dp}$_2 = c$, $\ldots$ then +it would represent the integer $a + b\beta + c\beta^2 + \ldots$ + +\index{MP\_ZPOS} \index{MP\_NEG} +\item The \textbf{sign} parameter denotes the sign as either zero/positive (\textbf{MP\_ZPOS}) or negative (\textbf{MP\_NEG}). +\end{enumerate} + +\subsubsection{Valid mp\_int Structures} +Several rules are placed on the state of an mp\_int structure and are assumed to be followed for reasons of efficiency. +The only exceptions are when the structure is passed to initialization functions such as mp\_init() and mp\_init\_copy(). + +\begin{enumerate} +\item The value of \textbf{alloc} may not be less than one. That is \textbf{dp} always points to a previously allocated +array of digits. +\item The value of \textbf{used} may not exceed \textbf{alloc} and must be greater than or equal to zero. +\item The value of \textbf{used} implies the digit at index $(used - 1)$ of the \textbf{dp} array is non-zero. That is, +leading zero digits in the most significant positions must be trimmed. + \begin{enumerate} + \item Digits in the \textbf{dp} array at and above the \textbf{used} location must be zero. + \end{enumerate} +\item The value of \textbf{sign} must be \textbf{MP\_ZPOS} if \textbf{used} is zero; +this represents the mp\_int value of zero. +\end{enumerate} + +\section{Argument Passing} +A convention of argument passing must be adopted early on in the development of any library. Making the function +prototypes consistent will help eliminate many headaches in the future as the library grows to significant complexity. +In LibTomMath the multiple precision integer functions accept parameters from left to right as pointers to mp\_int +structures. That means that the source (input) operands are placed on the left and the destination (output) on the right. +Consider the following examples. + +\begin{verbatim} + mp_mul(&a, &b, &c); /* c = a * b */ + mp_add(&a, &b, &a); /* a = a + b */ + mp_sqr(&a, &b); /* b = a * a */ +\end{verbatim} + +The left to right order is a fairly natural way to implement the functions since it lets the developer read aloud the +functions and make sense of them. For example, the first function would read ``multiply a and b and store in c''. + +Certain libraries (\textit{LIP by Lenstra for instance}) accept parameters the other way around, to mimic the order +of assignment expressions. That is, the destination (output) is on the left and arguments (inputs) are on the right. In +truth, it is entirely a matter of preference. In the case of LibTomMath the convention from the MPI library has been +adopted. + +Another very useful design consideration, provided for in LibTomMath, is whether to allow argument sources to also be a +destination. For example, the second example (\textit{mp\_add}) adds $a$ to $b$ and stores in $a$. This is an important +feature to implement since it allows the calling functions to cut down on the number of variables it must maintain. +However, to implement this feature specific care has to be given to ensure the destination is not modified before the +source is fully read. + +\section{Return Values} +A well implemented application, no matter what its purpose, should trap as many runtime errors as possible and return them +to the caller. By catching runtime errors a library can be guaranteed to prevent undefined behaviour. However, the end +developer can still manage to cause a library to crash. For example, by passing an invalid pointer an application may +fault by dereferencing memory not owned by the application. + +In the case of LibTomMath the only errors that are checked for are related to inappropriate inputs (division by zero for +instance) and memory allocation errors. It will not check that the mp\_int passed to any function is valid nor +will it check pointers for validity. Any function that can cause a runtime error will return an error code as an +\textbf{int} data type with one of the following values (fig \ref{fig:errcodes}). + +\index{MP\_OKAY} \index{MP\_VAL} \index{MP\_MEM} +\begin{figure}[here] +\begin{center} +\begin{tabular}{|l|l|} +\hline \textbf{Value} & \textbf{Meaning} \\ +\hline \textbf{MP\_OKAY} & The function was successful \\ +\hline \textbf{MP\_VAL} & One of the input value(s) was invalid \\ +\hline \textbf{MP\_MEM} & The function ran out of heap memory \\ +\hline +\end{tabular} +\end{center} +\caption{LibTomMath Error Codes} +\label{fig:errcodes} +\end{figure} + +When an error is detected within a function it should free any memory it allocated, often during the initialization of +temporary mp\_ints, and return as soon as possible. The goal is to leave the system in the same state it was when the +function was called. Error checking with this style of API is fairly simple. + +\begin{verbatim} + int err; + if ((err = mp_add(&a, &b, &c)) != MP_OKAY) { + printf("Error: %s\n", mp_error_to_string(err)); + exit(EXIT_FAILURE); + } +\end{verbatim} + +The GMP \cite{GMP} library uses C style \textit{signals} to flag errors which is of questionable use. Not all errors are fatal +and it was not deemed ideal by the author of LibTomMath to force developers to have signal handlers for such cases. + +\section{Initialization and Clearing} +The logical starting point when actually writing multiple precision integer functions is the initialization and +clearing of the mp\_int structures. These two algorithms will be used by the majority of the higher level algorithms. + +Given the basic mp\_int structure an initialization routine must first allocate memory to hold the digits of +the integer. Often it is optimal to allocate a sufficiently large pre-set number of digits even though +the initial integer will represent zero. If only a single digit were allocated quite a few subsequent re-allocations +would occur when operations are performed on the integers. There is a tradeoff between how many default digits to allocate +and how many re-allocations are tolerable. Obviously allocating an excessive amount of digits initially will waste +memory and become unmanageable. + +If the memory for the digits has been successfully allocated then the rest of the members of the structure must +be initialized. Since the initial state of an mp\_int is to represent the zero integer, the allocated digits must be set +to zero. The \textbf{used} count set to zero and \textbf{sign} set to \textbf{MP\_ZPOS}. + +\subsection{Initializing an mp\_int} +An mp\_int is said to be initialized if it is set to a valid, preferably default, state such that all of the members of the +structure are set to valid values. The mp\_init algorithm will perform such an action. + +\index{mp\_init} +\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_init}. \\ +\textbf{Input}. An mp\_int $a$ \\ +\textbf{Output}. Allocate memory and initialize $a$ to a known valid mp\_int state. \\ +\hline \\ +1. Allocate memory for \textbf{MP\_PREC} digits. \\ +2. If the allocation failed return(\textit{MP\_MEM}) \\ +3. for $n$ from $0$ to $MP\_PREC - 1$ do \\ +\hspace{3mm}3.1 $a_n \leftarrow 0$\\ +4. $a.sign \leftarrow MP\_ZPOS$\\ +5. $a.used \leftarrow 0$\\ +6. $a.alloc \leftarrow MP\_PREC$\\ +7. Return(\textit{MP\_OKAY})\\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_init} +\end{figure} + +\textbf{Algorithm mp\_init.} +The purpose of this function is to initialize an mp\_int structure so that the rest of the library can properly +manipulte it. It is assumed that the input may not have had any of its members previously initialized which is certainly +a valid assumption if the input resides on the stack. + +Before any of the members such as \textbf{sign}, \textbf{used} or \textbf{alloc} are initialized the memory for +the digits is allocated. If this fails the function returns before setting any of the other members. The \textbf{MP\_PREC} +name represents a constant\footnote{Defined in the ``tommath.h'' header file within LibTomMath.} +used to dictate the minimum precision of newly initialized mp\_int integers. Ideally, it is at least equal to the smallest +precision number you'll be working with. + +Allocating a block of digits at first instead of a single digit has the benefit of lowering the number of usually slow +heap operations later functions will have to perform in the future. If \textbf{MP\_PREC} is set correctly the slack +memory and the number of heap operations will be trivial. + +Once the allocation has been made the digits have to be set to zero as well as the \textbf{used}, \textbf{sign} and +\textbf{alloc} members initialized. This ensures that the mp\_int will always represent the default state of zero regardless +of the original condition of the input. + +\textbf{Remark.} +This function introduces the idiosyncrasy that all iterative loops, commonly initiated with the ``for'' keyword, iterate incrementally +when the ``to'' keyword is placed between two expressions. For example, ``for $a$ from $b$ to $c$ do'' means that +a subsequent expression (or body of expressions) are to be evaluated upto $c - b$ times so long as $b \le c$. In each +iteration the variable $a$ is substituted for a new integer that lies inclusively between $b$ and $c$. If $b > c$ occured +the loop would not iterate. By contrast if the ``downto'' keyword were used in place of ``to'' the loop would iterate +decrementally. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_init.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* init a new mp_int */ +018 int mp_init (mp_int * a) +019 \{ +020 int i; +021 +022 /* allocate memory required and clear it */ +023 a->dp = OPT_CAST(mp_digit) XMALLOC (sizeof (mp_digit) * MP_PREC); +024 if (a->dp == NULL) \{ +025 return MP_MEM; +026 \} +027 +028 /* set the digits to zero */ +029 for (i = 0; i < MP_PREC; i++) \{ +030 a->dp[i] = 0; +031 \} +032 +033 /* set the used to zero, allocated digits to the default precision +034 * and sign to positive */ +035 a->used = 0; +036 a->alloc = MP_PREC; +037 a->sign = MP_ZPOS; +038 +039 return MP_OKAY; +040 \} +041 #endif +042 +\end{alltt} +\end{small} + +One immediate observation of this initializtion function is that it does not return a pointer to a mp\_int structure. It +is assumed that the caller has already allocated memory for the mp\_int structure, typically on the application stack. The +call to mp\_init() is used only to initialize the members of the structure to a known default state. + +Here we see (line 23) the memory allocation is performed first. This allows us to exit cleanly and quickly +if there is an error. If the allocation fails the routine will return \textbf{MP\_MEM} to the caller to indicate there +was a memory error. The function XMALLOC is what actually allocates the memory. Technically XMALLOC is not a function +but a macro defined in ``tommath.h``. By default, XMALLOC will evaluate to malloc() which is the C library's built--in +memory allocation routine. + +In order to assure the mp\_int is in a known state the digits must be set to zero. On most platforms this could have been +accomplished by using calloc() instead of malloc(). However, to correctly initialize a integer type to a given value in a +portable fashion you have to actually assign the value. The for loop (line 29) performs this required +operation. + +After the memory has been successfully initialized the remainder of the members are initialized +(lines 33 through 34) to their respective default states. At this point the algorithm has succeeded and +a success code is returned to the calling function. If this function returns \textbf{MP\_OKAY} it is safe to assume the +mp\_int structure has been properly initialized and is safe to use with other functions within the library. + +\subsection{Clearing an mp\_int} +When an mp\_int is no longer required by the application, the memory that has been allocated for its digits must be +returned to the application's memory pool with the mp\_clear algorithm. + +\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_clear}. \\ +\textbf{Input}. An mp\_int $a$ \\ +\textbf{Output}. The memory for $a$ shall be deallocated. \\ +\hline \\ +1. If $a$ has been previously freed then return(\textit{MP\_OKAY}). \\ +2. for $n$ from 0 to $a.used - 1$ do \\ +\hspace{3mm}2.1 $a_n \leftarrow 0$ \\ +3. Free the memory allocated for the digits of $a$. \\ +4. $a.used \leftarrow 0$ \\ +5. $a.alloc \leftarrow 0$ \\ +6. $a.sign \leftarrow MP\_ZPOS$ \\ +7. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_clear} +\end{figure} + +\textbf{Algorithm mp\_clear.} +This algorithm accomplishes two goals. First, it clears the digits and the other mp\_int members. This ensures that +if a developer accidentally re-uses a cleared structure it is less likely to cause problems. The second goal +is to free the allocated memory. + +The logic behind the algorithm is extended by marking cleared mp\_int structures so that subsequent calls to this +algorithm will not try to free the memory multiple times. Cleared mp\_ints are detectable by having a pre-defined invalid +digit pointer \textbf{dp} setting. + +Once an mp\_int has been cleared the mp\_int structure is no longer in a valid state for any other algorithm +with the exception of algorithms mp\_init, mp\_init\_copy, mp\_init\_size and mp\_clear. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_clear.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* clear one (frees) */ +018 void +019 mp_clear (mp_int * a) +020 \{ +021 int i; +022 +023 /* only do anything if a hasn't been freed previously */ +024 if (a->dp != NULL) \{ +025 /* first zero the digits */ +026 for (i = 0; i < a->used; i++) \{ +027 a->dp[i] = 0; +028 \} +029 +030 /* free ram */ +031 XFREE(a->dp); +032 +033 /* reset members to make debugging easier */ +034 a->dp = NULL; +035 a->alloc = a->used = 0; +036 a->sign = MP_ZPOS; +037 \} +038 \} +039 #endif +040 +\end{alltt} +\end{small} + +The algorithm only operates on the mp\_int if it hasn't been previously cleared. The if statement (line 24) +checks to see if the \textbf{dp} member is not \textbf{NULL}. If the mp\_int is a valid mp\_int then \textbf{dp} cannot be +\textbf{NULL} in which case the if statement will evaluate to true. + +The digits of the mp\_int are cleared by the for loop (line 26) which assigns a zero to every digit. Similar to mp\_init() +the digits are assigned zero instead of using block memory operations (such as memset()) since this is more portable. + +The digits are deallocated off the heap via the XFREE macro. Similar to XMALLOC the XFREE macro actually evaluates to +a standard C library function. In this case the free() function. Since free() only deallocates the memory the pointer +still has to be reset to \textbf{NULL} manually (line 34). + +Now that the digits have been cleared and deallocated the other members are set to their final values (lines 35 and 36). + +\section{Maintenance Algorithms} + +The previous sections describes how to initialize and clear an mp\_int structure. To further support operations +that are to be performed on mp\_int structures (such as addition and multiplication) the dependent algorithms must be +able to augment the precision of an mp\_int and +initialize mp\_ints with differing initial conditions. + +These algorithms complete the set of low level algorithms required to work with mp\_int structures in the higher level +algorithms such as addition, multiplication and modular exponentiation. + +\subsection{Augmenting an mp\_int's Precision} +When storing a value in an mp\_int structure, a sufficient number of digits must be available to accomodate the entire +result of an operation without loss of precision. Quite often the size of the array given by the \textbf{alloc} member +is large enough to simply increase the \textbf{used} digit count. However, when the size of the array is too small it +must be re-sized appropriately to accomodate the result. The mp\_grow algorithm will provide this functionality. + +\newpage\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_grow}. \\ +\textbf{Input}. An mp\_int $a$ and an integer $b$. \\ +\textbf{Output}. $a$ is expanded to accomodate $b$ digits. \\ +\hline \\ +1. if $a.alloc \ge b$ then return(\textit{MP\_OKAY}) \\ +2. $u \leftarrow b\mbox{ (mod }MP\_PREC\mbox{)}$ \\ +3. $v \leftarrow b + 2 \cdot MP\_PREC - u$ \\ +4. Re-allocate the array of digits $a$ to size $v$ \\ +5. If the allocation failed then return(\textit{MP\_MEM}). \\ +6. for n from a.alloc to $v - 1$ do \\ +\hspace{+3mm}6.1 $a_n \leftarrow 0$ \\ +7. $a.alloc \leftarrow v$ \\ +8. Return(\textit{MP\_OKAY}) \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_grow} +\end{figure} + +\textbf{Algorithm mp\_grow.} +It is ideal to prevent re-allocations from being performed if they are not required (step one). This is useful to +prevent mp\_ints from growing excessively in code that erroneously calls mp\_grow. + +The requested digit count is padded up to next multiple of \textbf{MP\_PREC} plus an additional \textbf{MP\_PREC} (steps two and three). +This helps prevent many trivial reallocations that would grow an mp\_int by trivially small values. + +It is assumed that the reallocation (step four) leaves the lower $a.alloc$ digits of the mp\_int intact. This is much +akin to how the \textit{realloc} function from the standard C library works. Since the newly allocated digits are +assumed to contain undefined values they are initially set to zero. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_grow.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* grow as required */ +018 int mp_grow (mp_int * a, int size) +019 \{ +020 int i; +021 mp_digit *tmp; +022 +023 /* if the alloc size is smaller alloc more ram */ +024 if (a->alloc < size) \{ +025 /* ensure there are always at least MP_PREC digits extra on top */ +026 size += (MP_PREC * 2) - (size % MP_PREC); +027 +028 /* reallocate the array a->dp +029 * +030 * We store the return in a temporary variable +031 * in case the operation failed we don't want +032 * to overwrite the dp member of a. +033 */ +034 tmp = OPT_CAST(mp_digit) XREALLOC (a->dp, sizeof (mp_digit) * size); +035 if (tmp == NULL) \{ +036 /* reallocation failed but "a" is still valid [can be freed] */ +037 return MP_MEM; +038 \} +039 +040 /* reallocation succeeded so set a->dp */ +041 a->dp = tmp; +042 +043 /* zero excess digits */ +044 i = a->alloc; +045 a->alloc = size; +046 for (; i < a->alloc; i++) \{ +047 a->dp[i] = 0; +048 \} +049 \} +050 return MP_OKAY; +051 \} +052 #endif +053 +\end{alltt} +\end{small} + +A quick optimization is to first determine if a memory re-allocation is required at all. The if statement (line 24) checks +if the \textbf{alloc} member of the mp\_int is smaller than the requested digit count. If the count is not larger than \textbf{alloc} +the function skips the re-allocation part thus saving time. + +When a re-allocation is performed it is turned into an optimal request to save time in the future. The requested digit count is +padded upwards to 2nd multiple of \textbf{MP\_PREC} larger than \textbf{alloc} (line 26). The XREALLOC function is used +to re-allocate the memory. As per the other functions XREALLOC is actually a macro which evaluates to realloc by default. The realloc +function leaves the base of the allocation intact which means the first \textbf{alloc} digits of the mp\_int are the same as before +the re-allocation. All that is left is to clear the newly allocated digits and return. + +Note that the re-allocation result is actually stored in a temporary pointer $tmp$. This is to allow this function to return +an error with a valid pointer. Earlier releases of the library stored the result of XREALLOC into the mp\_int $a$. That would +result in a memory leak if XREALLOC ever failed. + +\subsection{Initializing Variable Precision mp\_ints} +Occasionally the number of digits required will be known in advance of an initialization, based on, for example, the size +of input mp\_ints to a given algorithm. The purpose of algorithm mp\_init\_size is similar to mp\_init except that it +will allocate \textit{at least} a specified number of digits. + +\begin{figure}[here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_init\_size}. \\ +\textbf{Input}. An mp\_int $a$ and the requested number of digits $b$. \\ +\textbf{Output}. $a$ is initialized to hold at least $b$ digits. \\ +\hline \\ +1. $u \leftarrow b \mbox{ (mod }MP\_PREC\mbox{)}$ \\ +2. $v \leftarrow b + 2 \cdot MP\_PREC - u$ \\ +3. Allocate $v$ digits. \\ +4. for $n$ from $0$ to $v - 1$ do \\ +\hspace{3mm}4.1 $a_n \leftarrow 0$ \\ +5. $a.sign \leftarrow MP\_ZPOS$\\ +6. $a.used \leftarrow 0$\\ +7. $a.alloc \leftarrow v$\\ +8. Return(\textit{MP\_OKAY})\\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_init\_size} +\end{figure} + +\textbf{Algorithm mp\_init\_size.} +This algorithm will initialize an mp\_int structure $a$ like algorithm mp\_init with the exception that the number of +digits allocated can be controlled by the second input argument $b$. The input size is padded upwards so it is a +multiple of \textbf{MP\_PREC} plus an additional \textbf{MP\_PREC} digits. This padding is used to prevent trivial +allocations from becoming a bottleneck in the rest of the algorithms. + +Like algorithm mp\_init, the mp\_int structure is initialized to a default state representing the integer zero. This +particular algorithm is useful if it is known ahead of time the approximate size of the input. If the approximation is +correct no further memory re-allocations are required to work with the mp\_int. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_init\_size.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* init an mp_init for a given size */ +018 int mp_init_size (mp_int * a, int size) +019 \{ +020 int x; +021 +022 /* pad size so there are always extra digits */ +023 size += (MP_PREC * 2) - (size % MP_PREC); +024 +025 /* alloc mem */ +026 a->dp = OPT_CAST(mp_digit) XMALLOC (sizeof (mp_digit) * size); +027 if (a->dp == NULL) \{ +028 return MP_MEM; +029 \} +030 +031 /* set the members */ +032 a->used = 0; +033 a->alloc = size; +034 a->sign = MP_ZPOS; +035 +036 /* zero the digits */ +037 for (x = 0; x < size; x++) \{ +038 a->dp[x] = 0; +039 \} +040 +041 return MP_OKAY; +042 \} +043 #endif +044 +\end{alltt} +\end{small} + +The number of digits $b$ requested is padded (line 23) by first augmenting it to the next multiple of +\textbf{MP\_PREC} and then adding \textbf{MP\_PREC} to the result. If the memory can be successfully allocated the +mp\_int is placed in a default state representing the integer zero. Otherwise, the error code \textbf{MP\_MEM} will be +returned (line 28). + +The digits are allocated and set to zero at the same time with the calloc() function (line @25,XCALLOC@). The +\textbf{used} count is set to zero, the \textbf{alloc} count set to the padded digit count and the \textbf{sign} flag set +to \textbf{MP\_ZPOS} to achieve a default valid mp\_int state (lines 32, 33 and 34). If the function +returns succesfully then it is correct to assume that the mp\_int structure is in a valid state for the remainder of the +functions to work with. + +\subsection{Multiple Integer Initializations and Clearings} +Occasionally a function will require a series of mp\_int data types to be made available simultaneously. +The purpose of algorithm mp\_init\_multi is to initialize a variable length array of mp\_int structures in a single +statement. It is essentially a shortcut to multiple initializations. + +\newpage\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_init\_multi}. \\ +\textbf{Input}. Variable length array $V_k$ of mp\_int variables of length $k$. \\ +\textbf{Output}. The array is initialized such that each mp\_int of $V_k$ is ready to use. \\ +\hline \\ +1. for $n$ from 0 to $k - 1$ do \\ +\hspace{+3mm}1.1. Initialize the mp\_int $V_n$ (\textit{mp\_init}) \\ +\hspace{+3mm}1.2. If initialization failed then do \\ +\hspace{+6mm}1.2.1. for $j$ from $0$ to $n$ do \\ +\hspace{+9mm}1.2.1.1. Free the mp\_int $V_j$ (\textit{mp\_clear}) \\ +\hspace{+6mm}1.2.2. Return(\textit{MP\_MEM}) \\ +2. Return(\textit{MP\_OKAY}) \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_init\_multi} +\end{figure} + +\textbf{Algorithm mp\_init\_multi.} +The algorithm will initialize the array of mp\_int variables one at a time. If a runtime error has been detected +(\textit{step 1.2}) all of the previously initialized variables are cleared. The goal is an ``all or nothing'' +initialization which allows for quick recovery from runtime errors. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_init\_multi.c +\vspace{-3mm} +\begin{alltt} +016 #include +017 +018 int mp_init_multi(mp_int *mp, ...) +019 \{ +020 mp_err res = MP_OKAY; /* Assume ok until proven otherwise */ +021 int n = 0; /* Number of ok inits */ +022 mp_int* cur_arg = mp; +023 va_list args; +024 +025 va_start(args, mp); /* init args to next argument from caller */ +026 while (cur_arg != NULL) \{ +027 if (mp_init(cur_arg) != MP_OKAY) \{ +028 /* Oops - error! Back-track and mp_clear what we already +029 succeeded in init-ing, then return error. +030 */ +031 va_list clean_args; +032 +033 /* end the current list */ +034 va_end(args); +035 +036 /* now start cleaning up */ +037 cur_arg = mp; +038 va_start(clean_args, mp); +039 while (n--) \{ +040 mp_clear(cur_arg); +041 cur_arg = va_arg(clean_args, mp_int*); +042 \} +043 va_end(clean_args); +044 res = MP_MEM; +045 break; +046 \} +047 n++; +048 cur_arg = va_arg(args, mp_int*); +049 \} +050 va_end(args); +051 return res; /* Assumed ok, if error flagged above. */ +052 \} +053 +054 #endif +055 +\end{alltt} +\end{small} + +This function intializes a variable length list of mp\_int structure pointers. However, instead of having the mp\_int +structures in an actual C array they are simply passed as arguments to the function. This function makes use of the +``...'' argument syntax of the C programming language. The list is terminated with a final \textbf{NULL} argument +appended on the right. + +The function uses the ``stdarg.h'' \textit{va} functions to step portably through the arguments to the function. A count +$n$ of succesfully initialized mp\_int structures is maintained (line 47) such that if a failure does occur, +the algorithm can backtrack and free the previously initialized structures (lines 27 to 46). + + +\subsection{Clamping Excess Digits} +When a function anticipates a result will be $n$ digits it is simpler to assume this is true within the body of +the function instead of checking during the computation. For example, a multiplication of a $i$ digit number by a +$j$ digit produces a result of at most $i + j$ digits. It is entirely possible that the result is $i + j - 1$ +though, with no final carry into the last position. However, suppose the destination had to be first expanded +(\textit{via mp\_grow}) to accomodate $i + j - 1$ digits than further expanded to accomodate the final carry. +That would be a considerable waste of time since heap operations are relatively slow. + +The ideal solution is to always assume the result is $i + j$ and fix up the \textbf{used} count after the function +terminates. This way a single heap operation (\textit{at most}) is required. However, if the result was not checked +there would be an excess high order zero digit. + +For example, suppose the product of two integers was $x_n = (0x_{n-1}x_{n-2}...x_0)_{\beta}$. The leading zero digit +will not contribute to the precision of the result. In fact, through subsequent operations more leading zero digits would +accumulate to the point the size of the integer would be prohibitive. As a result even though the precision is very +low the representation is excessively large. + +The mp\_clamp algorithm is designed to solve this very problem. It will trim high-order zeros by decrementing the +\textbf{used} count until a non-zero most significant digit is found. Also in this system, zero is considered to be a +positive number which means that if the \textbf{used} count is decremented to zero, the sign must be set to +\textbf{MP\_ZPOS}. + +\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_clamp}. \\ +\textbf{Input}. An mp\_int $a$ \\ +\textbf{Output}. Any excess leading zero digits of $a$ are removed \\ +\hline \\ +1. while $a.used > 0$ and $a_{a.used - 1} = 0$ do \\ +\hspace{+3mm}1.1 $a.used \leftarrow a.used - 1$ \\ +2. if $a.used = 0$ then do \\ +\hspace{+3mm}2.1 $a.sign \leftarrow MP\_ZPOS$ \\ +\hline \\ +\end{tabular} +\end{center} +\caption{Algorithm mp\_clamp} +\end{figure} + +\textbf{Algorithm mp\_clamp.} +As can be expected this algorithm is very simple. The loop on step one is expected to iterate only once or twice at +the most. For example, this will happen in cases where there is not a carry to fill the last position. Step two fixes the sign for +when all of the digits are zero to ensure that the mp\_int is valid at all times. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_clamp.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* trim unused digits +018 * +019 * This is used to ensure that leading zero digits are +020 * trimed and the leading "used" digit will be non-zero +021 * Typically very fast. Also fixes the sign if there +022 * are no more leading digits +023 */ +024 void +025 mp_clamp (mp_int * a) +026 \{ +027 /* decrease used while the most significant digit is +028 * zero. +029 */ +030 while (a->used > 0 && a->dp[a->used - 1] == 0) \{ +031 --(a->used); +032 \} +033 +034 /* reset the sign flag if used == 0 */ +035 if (a->used == 0) \{ +036 a->sign = MP_ZPOS; +037 \} +038 \} +039 #endif +040 +\end{alltt} +\end{small} + +Note on line 27 how to test for the \textbf{used} count is made on the left of the \&\& operator. In the C programming +language the terms to \&\& are evaluated left to right with a boolean short-circuit if any condition fails. This is +important since if the \textbf{used} is zero the test on the right would fetch below the array. That is obviously +undesirable. The parenthesis on line 30 is used to make sure the \textbf{used} count is decremented and not +the pointer ``a''. + +\section*{Exercises} +\begin{tabular}{cl} +$\left [ 1 \right ]$ & Discuss the relevance of the \textbf{used} member of the mp\_int structure. \\ + & \\ +$\left [ 1 \right ]$ & Discuss the consequences of not using padding when performing allocations. \\ + & \\ +$\left [ 2 \right ]$ & Estimate an ideal value for \textbf{MP\_PREC} when performing 1024-bit RSA \\ + & encryption when $\beta = 2^{28}$. \\ + & \\ +$\left [ 1 \right ]$ & Discuss the relevance of the algorithm mp\_clamp. What does it prevent? \\ + & \\ +$\left [ 1 \right ]$ & Give an example of when the algorithm mp\_init\_copy might be useful. \\ + & \\ +\end{tabular} + + +%%% +% CHAPTER FOUR +%%% + +\chapter{Basic Operations} + +\section{Introduction} +In the previous chapter a series of low level algorithms were established that dealt with initializing and maintaining +mp\_int structures. This chapter will discuss another set of seemingly non-algebraic algorithms which will form the low +level basis of the entire library. While these algorithm are relatively trivial it is important to understand how they +work before proceeding since these algorithms will be used almost intrinsically in the following chapters. + +The algorithms in this chapter deal primarily with more ``programmer'' related tasks such as creating copies of +mp\_int structures, assigning small values to mp\_int structures and comparisons of the values mp\_int structures +represent. + +\section{Assigning Values to mp\_int Structures} +\subsection{Copying an mp\_int} +Assigning the value that a given mp\_int structure represents to another mp\_int structure shall be known as making +a copy for the purposes of this text. The copy of the mp\_int will be a separate entity that represents the same +value as the mp\_int it was copied from. The mp\_copy algorithm provides this functionality. + +\newpage\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_copy}. \\ +\textbf{Input}. An mp\_int $a$ and $b$. \\ +\textbf{Output}. Store a copy of $a$ in $b$. \\ +\hline \\ +1. If $b.alloc < a.used$ then grow $b$ to $a.used$ digits. (\textit{mp\_grow}) \\ +2. for $n$ from 0 to $a.used - 1$ do \\ +\hspace{3mm}2.1 $b_{n} \leftarrow a_{n}$ \\ +3. for $n$ from $a.used$ to $b.used - 1$ do \\ +\hspace{3mm}3.1 $b_{n} \leftarrow 0$ \\ +4. $b.used \leftarrow a.used$ \\ +5. $b.sign \leftarrow a.sign$ \\ +6. return(\textit{MP\_OKAY}) \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_copy} +\end{figure} + +\textbf{Algorithm mp\_copy.} +This algorithm copies the mp\_int $a$ such that upon succesful termination of the algorithm the mp\_int $b$ will +represent the same integer as the mp\_int $a$. The mp\_int $b$ shall be a complete and distinct copy of the +mp\_int $a$ meaing that the mp\_int $a$ can be modified and it shall not affect the value of the mp\_int $b$. + +If $b$ does not have enough room for the digits of $a$ it must first have its precision augmented via the mp\_grow +algorithm. The digits of $a$ are copied over the digits of $b$ and any excess digits of $b$ are set to zero (step two +and three). The \textbf{used} and \textbf{sign} members of $a$ are finally copied over the respective members of +$b$. + +\textbf{Remark.} This algorithm also introduces a new idiosyncrasy that will be used throughout the rest of the +text. The error return codes of other algorithms are not explicitly checked in the pseudo-code presented. For example, in +step one of the mp\_copy algorithm the return of mp\_grow is not explicitly checked to ensure it succeeded. Text space is +limited so it is assumed that if a algorithm fails it will clear all temporarily allocated mp\_ints and return +the error code itself. However, the C code presented will demonstrate all of the error handling logic required to +implement the pseudo-code. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_copy.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* copy, b = a */ +018 int +019 mp_copy (mp_int * a, mp_int * b) +020 \{ +021 int res, n; +022 +023 /* if dst == src do nothing */ +024 if (a == b) \{ +025 return MP_OKAY; +026 \} +027 +028 /* grow dest */ +029 if (b->alloc < a->used) \{ +030 if ((res = mp_grow (b, a->used)) != MP_OKAY) \{ +031 return res; +032 \} +033 \} +034 +035 /* zero b and copy the parameters over */ +036 \{ +037 register mp_digit *tmpa, *tmpb; +038 +039 /* pointer aliases */ +040 +041 /* source */ +042 tmpa = a->dp; +043 +044 /* destination */ +045 tmpb = b->dp; +046 +047 /* copy all the digits */ +048 for (n = 0; n < a->used; n++) \{ +049 *tmpb++ = *tmpa++; +050 \} +051 +052 /* clear high digits */ +053 for (; n < b->used; n++) \{ +054 *tmpb++ = 0; +055 \} +056 \} +057 +058 /* copy used count and sign */ +059 b->used = a->used; +060 b->sign = a->sign; +061 return MP_OKAY; +062 \} +063 #endif +064 +\end{alltt} +\end{small} + +Occasionally a dependent algorithm may copy an mp\_int effectively into itself such as when the input and output +mp\_int structures passed to a function are one and the same. For this case it is optimal to return immediately without +copying digits (line 24). + +The mp\_int $b$ must have enough digits to accomodate the used digits of the mp\_int $a$. If $b.alloc$ is less than +$a.used$ the algorithm mp\_grow is used to augment the precision of $b$ (lines 29 to 33). In order to +simplify the inner loop that copies the digits from $a$ to $b$, two aliases $tmpa$ and $tmpb$ point directly at the digits +of the mp\_ints $a$ and $b$ respectively. These aliases (lines 42 and 45) allow the compiler to access the digits without first dereferencing the +mp\_int pointers and then subsequently the pointer to the digits. + +After the aliases are established the digits from $a$ are copied into $b$ (lines 48 to 50) and then the excess +digits of $b$ are set to zero (lines 53 to 55). Both ``for'' loops make use of the pointer aliases and in +fact the alias for $b$ is carried through into the second ``for'' loop to clear the excess digits. This optimization +allows the alias to stay in a machine register fairly easy between the two loops. + +\textbf{Remarks.} The use of pointer aliases is an implementation methodology first introduced in this function that will +be used considerably in other functions. Technically, a pointer alias is simply a short hand alias used to lower the +number of pointer dereferencing operations required to access data. For example, a for loop may resemble + +\begin{alltt} +for (x = 0; x < 100; x++) \{ + a->num[4]->dp[x] = 0; +\} +\end{alltt} + +This could be re-written using aliases as + +\begin{alltt} +mp_digit *tmpa; +a = a->num[4]->dp; +for (x = 0; x < 100; x++) \{ + *a++ = 0; +\} +\end{alltt} + +In this case an alias is used to access the +array of digits within an mp\_int structure directly. It may seem that a pointer alias is strictly not required +as a compiler may optimize out the redundant pointer operations. However, there are two dominant reasons to use aliases. + +The first reason is that most compilers will not effectively optimize pointer arithmetic. For example, some optimizations +may work for the Microsoft Visual C++ compiler (MSVC) and not for the GNU C Compiler (GCC). Also some optimizations may +work for GCC and not MSVC. As such it is ideal to find a common ground for as many compilers as possible. Pointer +aliases optimize the code considerably before the compiler even reads the source code which means the end compiled code +stands a better chance of being faster. + +The second reason is that pointer aliases often can make an algorithm simpler to read. Consider the first ``for'' +loop of the function mp\_copy() re-written to not use pointer aliases. + +\begin{alltt} + /* copy all the digits */ + for (n = 0; n < a->used; n++) \{ + b->dp[n] = a->dp[n]; + \} +\end{alltt} + +Whether this code is harder to read depends strongly on the individual. However, it is quantifiably slightly more +complicated as there are four variables within the statement instead of just two. + +\subsubsection{Nested Statements} +Another commonly used technique in the source routines is that certain sections of code are nested. This is used in +particular with the pointer aliases to highlight code phases. For example, a Comba multiplier (discussed in chapter six) +will typically have three different phases. First the temporaries are initialized, then the columns calculated and +finally the carries are propagated. In this example the middle column production phase will typically be nested as it +uses temporary variables and aliases the most. + +The nesting also simplies the source code as variables that are nested are only valid for their scope. As a result +the various temporary variables required do not propagate into other sections of code. + + +\subsection{Creating a Clone} +Another common operation is to make a local temporary copy of an mp\_int argument. To initialize an mp\_int +and then copy another existing mp\_int into the newly intialized mp\_int will be known as creating a clone. This is +useful within functions that need to modify an argument but do not wish to actually modify the original copy. The +mp\_init\_copy algorithm has been designed to help perform this task. + +\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_init\_copy}. \\ +\textbf{Input}. An mp\_int $a$ and $b$\\ +\textbf{Output}. $a$ is initialized to be a copy of $b$. \\ +\hline \\ +1. Init $a$. (\textit{mp\_init}) \\ +2. Copy $b$ to $a$. (\textit{mp\_copy}) \\ +3. Return the status of the copy operation. \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_init\_copy} +\end{figure} + +\textbf{Algorithm mp\_init\_copy.} +This algorithm will initialize an mp\_int variable and copy another previously initialized mp\_int variable into it. As +such this algorithm will perform two operations in one step. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_init\_copy.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* creates "a" then copies b into it */ +018 int mp_init_copy (mp_int * a, mp_int * b) +019 \{ +020 int res; +021 +022 if ((res = mp_init (a)) != MP_OKAY) \{ +023 return res; +024 \} +025 return mp_copy (b, a); +026 \} +027 #endif +028 +\end{alltt} +\end{small} + +This will initialize \textbf{a} and make it a verbatim copy of the contents of \textbf{b}. Note that +\textbf{a} will have its own memory allocated which means that \textbf{b} may be cleared after the call +and \textbf{a} will be left intact. + +\section{Zeroing an Integer} +Reseting an mp\_int to the default state is a common step in many algorithms. The mp\_zero algorithm will be the algorithm used to +perform this task. + +\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_zero}. \\ +\textbf{Input}. An mp\_int $a$ \\ +\textbf{Output}. Zero the contents of $a$ \\ +\hline \\ +1. $a.used \leftarrow 0$ \\ +2. $a.sign \leftarrow$ MP\_ZPOS \\ +3. for $n$ from 0 to $a.alloc - 1$ do \\ +\hspace{3mm}3.1 $a_n \leftarrow 0$ \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_zero} +\end{figure} + +\textbf{Algorithm mp\_zero.} +This algorithm simply resets a mp\_int to the default state. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_zero.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* set to zero */ +018 void mp_zero (mp_int * a) +019 \{ +020 int n; +021 mp_digit *tmp; +022 +023 a->sign = MP_ZPOS; +024 a->used = 0; +025 +026 tmp = a->dp; +027 for (n = 0; n < a->alloc; n++) \{ +028 *tmp++ = 0; +029 \} +030 \} +031 #endif +032 +\end{alltt} +\end{small} + +After the function is completed, all of the digits are zeroed, the \textbf{used} count is zeroed and the +\textbf{sign} variable is set to \textbf{MP\_ZPOS}. + +\section{Sign Manipulation} +\subsection{Absolute Value} +With the mp\_int representation of an integer, calculating the absolute value is trivial. The mp\_abs algorithm will compute +the absolute value of an mp\_int. + +\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_abs}. \\ +\textbf{Input}. An mp\_int $a$ \\ +\textbf{Output}. Computes $b = \vert a \vert$ \\ +\hline \\ +1. Copy $a$ to $b$. (\textit{mp\_copy}) \\ +2. If the copy failed return(\textit{MP\_MEM}). \\ +3. $b.sign \leftarrow MP\_ZPOS$ \\ +4. Return(\textit{MP\_OKAY}) \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_abs} +\end{figure} + +\textbf{Algorithm mp\_abs.} +This algorithm computes the absolute of an mp\_int input. First it copies $a$ over $b$. This is an example of an +algorithm where the check in mp\_copy that determines if the source and destination are equal proves useful. This allows, +for instance, the developer to pass the same mp\_int as the source and destination to this function without addition +logic to handle it. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_abs.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* b = |a| +018 * +019 * Simple function copies the input and fixes the sign to positive +020 */ +021 int +022 mp_abs (mp_int * a, mp_int * b) +023 \{ +024 int res; +025 +026 /* copy a to b */ +027 if (a != b) \{ +028 if ((res = mp_copy (a, b)) != MP_OKAY) \{ +029 return res; +030 \} +031 \} +032 +033 /* force the sign of b to positive */ +034 b->sign = MP_ZPOS; +035 +036 return MP_OKAY; +037 \} +038 #endif +039 +\end{alltt} +\end{small} + +This fairly trivial algorithm first eliminates non--required duplications (line 27) and then sets the +\textbf{sign} flag to \textbf{MP\_ZPOS}. + +\subsection{Integer Negation} +With the mp\_int representation of an integer, calculating the negation is also trivial. The mp\_neg algorithm will compute +the negative of an mp\_int input. + +\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_neg}. \\ +\textbf{Input}. An mp\_int $a$ \\ +\textbf{Output}. Computes $b = -a$ \\ +\hline \\ +1. Copy $a$ to $b$. (\textit{mp\_copy}) \\ +2. If the copy failed return(\textit{MP\_MEM}). \\ +3. If $a.used = 0$ then return(\textit{MP\_OKAY}). \\ +4. If $a.sign = MP\_ZPOS$ then do \\ +\hspace{3mm}4.1 $b.sign = MP\_NEG$. \\ +5. else do \\ +\hspace{3mm}5.1 $b.sign = MP\_ZPOS$. \\ +6. Return(\textit{MP\_OKAY}) \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_neg} +\end{figure} + +\textbf{Algorithm mp\_neg.} +This algorithm computes the negation of an input. First it copies $a$ over $b$. If $a$ has no used digits then +the algorithm returns immediately. Otherwise it flips the sign flag and stores the result in $b$. Note that if +$a$ had no digits then it must be positive by definition. Had step three been omitted then the algorithm would return +zero as negative. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_neg.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* b = -a */ +018 int mp_neg (mp_int * a, mp_int * b) +019 \{ +020 int res; +021 if (a != b) \{ +022 if ((res = mp_copy (a, b)) != MP_OKAY) \{ +023 return res; +024 \} +025 \} +026 +027 if (mp_iszero(b) != MP_YES) \{ +028 b->sign = (a->sign == MP_ZPOS) ? MP_NEG : MP_ZPOS; +029 \} else \{ +030 b->sign = MP_ZPOS; +031 \} +032 +033 return MP_OKAY; +034 \} +035 #endif +036 +\end{alltt} +\end{small} + +Like mp\_abs() this function avoids non--required duplications (line 21) and then sets the sign. We +have to make sure that only non--zero values get a \textbf{sign} of \textbf{MP\_NEG}. If the mp\_int is zero +than the \textbf{sign} is hard--coded to \textbf{MP\_ZPOS}. + +\section{Small Constants} +\subsection{Setting Small Constants} +Often a mp\_int must be set to a relatively small value such as $1$ or $2$. For these cases the mp\_set algorithm is useful. + +\newpage\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_set}. \\ +\textbf{Input}. An mp\_int $a$ and a digit $b$ \\ +\textbf{Output}. Make $a$ equivalent to $b$ \\ +\hline \\ +1. Zero $a$ (\textit{mp\_zero}). \\ +2. $a_0 \leftarrow b \mbox{ (mod }\beta\mbox{)}$ \\ +3. $a.used \leftarrow \left \lbrace \begin{array}{ll} + 1 & \mbox{if }a_0 > 0 \\ + 0 & \mbox{if }a_0 = 0 + \end{array} \right .$ \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_set} +\end{figure} + +\textbf{Algorithm mp\_set.} +This algorithm sets a mp\_int to a small single digit value. Step number 1 ensures that the integer is reset to the default state. The +single digit is set (\textit{modulo $\beta$}) and the \textbf{used} count is adjusted accordingly. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_set.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* set to a digit */ +018 void mp_set (mp_int * a, mp_digit b) +019 \{ +020 mp_zero (a); +021 a->dp[0] = b & MP_MASK; +022 a->used = (a->dp[0] != 0) ? 1 : 0; +023 \} +024 #endif +025 +\end{alltt} +\end{small} + +First we zero (line 20) the mp\_int to make sure that the other members are initialized for a +small positive constant. mp\_zero() ensures that the \textbf{sign} is positive and the \textbf{used} count +is zero. Next we set the digit and reduce it modulo $\beta$ (line 21). After this step we have to +check if the resulting digit is zero or not. If it is not then we set the \textbf{used} count to one, otherwise +to zero. + +We can quickly reduce modulo $\beta$ since it is of the form $2^k$ and a quick binary AND operation with +$2^k - 1$ will perform the same operation. + +One important limitation of this function is that it will only set one digit. The size of a digit is not fixed, meaning source that uses +this function should take that into account. Only trivially small constants can be set using this function. + +\subsection{Setting Large Constants} +To overcome the limitations of the mp\_set algorithm the mp\_set\_int algorithm is ideal. It accepts a ``long'' +data type as input and will always treat it as a 32-bit integer. + +\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_set\_int}. \\ +\textbf{Input}. An mp\_int $a$ and a ``long'' integer $b$ \\ +\textbf{Output}. Make $a$ equivalent to $b$ \\ +\hline \\ +1. Zero $a$ (\textit{mp\_zero}) \\ +2. for $n$ from 0 to 7 do \\ +\hspace{3mm}2.1 $a \leftarrow a \cdot 16$ (\textit{mp\_mul2d}) \\ +\hspace{3mm}2.2 $u \leftarrow \lfloor b / 2^{4(7 - n)} \rfloor \mbox{ (mod }16\mbox{)}$\\ +\hspace{3mm}2.3 $a_0 \leftarrow a_0 + u$ \\ +\hspace{3mm}2.4 $a.used \leftarrow a.used + 1$ \\ +3. Clamp excess used digits (\textit{mp\_clamp}) \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_set\_int} +\end{figure} + +\textbf{Algorithm mp\_set\_int.} +The algorithm performs eight iterations of a simple loop where in each iteration four bits from the source are added to the +mp\_int. Step 2.1 will multiply the current result by sixteen making room for four more bits in the less significant positions. In step 2.2 the +next four bits from the source are extracted and are added to the mp\_int. The \textbf{used} digit count is +incremented to reflect the addition. The \textbf{used} digit counter is incremented since if any of the leading digits were zero the mp\_int would have +zero digits used and the newly added four bits would be ignored. + +Excess zero digits are trimmed in steps 2.1 and 3 by using higher level algorithms mp\_mul2d and mp\_clamp. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_set\_int.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* set a 32-bit const */ +018 int mp_set_int (mp_int * a, unsigned long b) +019 \{ +020 int x, res; +021 +022 mp_zero (a); +023 +024 /* set four bits at a time */ +025 for (x = 0; x < 8; x++) \{ +026 /* shift the number up four bits */ +027 if ((res = mp_mul_2d (a, 4, a)) != MP_OKAY) \{ +028 return res; +029 \} +030 +031 /* OR in the top four bits of the source */ +032 a->dp[0] |= (b >> 28) & 15; +033 +034 /* shift the source up to the next four bits */ +035 b <<= 4; +036 +037 /* ensure that digits are not clamped off */ +038 a->used += 1; +039 \} +040 mp_clamp (a); +041 return MP_OKAY; +042 \} +043 #endif +044 +\end{alltt} +\end{small} + +This function sets four bits of the number at a time to handle all practical \textbf{DIGIT\_BIT} sizes. The weird +addition on line 38 ensures that the newly added in bits are added to the number of digits. While it may not +seem obvious as to why the digit counter does not grow exceedingly large it is because of the shift on line 27 +as well as the call to mp\_clamp() on line 40. Both functions will clamp excess leading digits which keeps +the number of used digits low. + +\section{Comparisons} +\subsection{Unsigned Comparisions} +Comparing a multiple precision integer is performed with the exact same algorithm used to compare two decimal numbers. For example, +to compare $1,234$ to $1,264$ the digits are extracted by their positions. That is we compare $1 \cdot 10^3 + 2 \cdot 10^2 + 3 \cdot 10^1 + 4 \cdot 10^0$ +to $1 \cdot 10^3 + 2 \cdot 10^2 + 6 \cdot 10^1 + 4 \cdot 10^0$ by comparing single digits at a time starting with the highest magnitude +positions. If any leading digit of one integer is greater than a digit in the same position of another integer then obviously it must be greater. + +The first comparision routine that will be developed is the unsigned magnitude compare which will perform a comparison based on the digits of two +mp\_int variables alone. It will ignore the sign of the two inputs. Such a function is useful when an absolute comparison is required or if the +signs are known to agree in advance. + +To facilitate working with the results of the comparison functions three constants are required. + +\begin{figure}[here] +\begin{center} +\begin{tabular}{|r|l|} +\hline \textbf{Constant} & \textbf{Meaning} \\ +\hline \textbf{MP\_GT} & Greater Than \\ +\hline \textbf{MP\_EQ} & Equal To \\ +\hline \textbf{MP\_LT} & Less Than \\ +\hline +\end{tabular} +\end{center} +\caption{Comparison Return Codes} +\end{figure} + +\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_cmp\_mag}. \\ +\textbf{Input}. Two mp\_ints $a$ and $b$. \\ +\textbf{Output}. Unsigned comparison results ($a$ to the left of $b$). \\ +\hline \\ +1. If $a.used > b.used$ then return(\textit{MP\_GT}) \\ +2. If $a.used < b.used$ then return(\textit{MP\_LT}) \\ +3. for n from $a.used - 1$ to 0 do \\ +\hspace{+3mm}3.1 if $a_n > b_n$ then return(\textit{MP\_GT}) \\ +\hspace{+3mm}3.2 if $a_n < b_n$ then return(\textit{MP\_LT}) \\ +4. Return(\textit{MP\_EQ}) \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_cmp\_mag} +\end{figure} + +\textbf{Algorithm mp\_cmp\_mag.} +By saying ``$a$ to the left of $b$'' it is meant that the comparison is with respect to $a$, that is if $a$ is greater than $b$ it will return +\textbf{MP\_GT} and similar with respect to when $a = b$ and $a < b$. The first two steps compare the number of digits used in both $a$ and $b$. +Obviously if the digit counts differ there would be an imaginary zero digit in the smaller number where the leading digit of the larger number is. +If both have the same number of digits than the actual digits themselves must be compared starting at the leading digit. + +By step three both inputs must have the same number of digits so its safe to start from either $a.used - 1$ or $b.used - 1$ and count down to +the zero'th digit. If after all of the digits have been compared, no difference is found, the algorithm returns \textbf{MP\_EQ}. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_cmp\_mag.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* compare maginitude of two ints (unsigned) */ +018 int mp_cmp_mag (mp_int * a, mp_int * b) +019 \{ +020 int n; +021 mp_digit *tmpa, *tmpb; +022 +023 /* compare based on # of non-zero digits */ +024 if (a->used > b->used) \{ +025 return MP_GT; +026 \} +027 +028 if (a->used < b->used) \{ +029 return MP_LT; +030 \} +031 +032 /* alias for a */ +033 tmpa = a->dp + (a->used - 1); +034 +035 /* alias for b */ +036 tmpb = b->dp + (a->used - 1); +037 +038 /* compare based on digits */ +039 for (n = 0; n < a->used; ++n, --tmpa, --tmpb) \{ +040 if (*tmpa > *tmpb) \{ +041 return MP_GT; +042 \} +043 +044 if (*tmpa < *tmpb) \{ +045 return MP_LT; +046 \} +047 \} +048 return MP_EQ; +049 \} +050 #endif +051 +\end{alltt} +\end{small} + +The two if statements (lines 24 and 28) compare the number of digits in the two inputs. These two are +performed before all of the digits are compared since it is a very cheap test to perform and can potentially save +considerable time. The implementation given is also not valid without those two statements. $b.alloc$ may be +smaller than $a.used$, meaning that undefined values will be read from $b$ past the end of the array of digits. + + + +\subsection{Signed Comparisons} +Comparing with sign considerations is also fairly critical in several routines (\textit{division for example}). Based on an unsigned magnitude +comparison a trivial signed comparison algorithm can be written. + +\begin{figure}[here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_cmp}. \\ +\textbf{Input}. Two mp\_ints $a$ and $b$ \\ +\textbf{Output}. Signed Comparison Results ($a$ to the left of $b$) \\ +\hline \\ +1. if $a.sign = MP\_NEG$ and $b.sign = MP\_ZPOS$ then return(\textit{MP\_LT}) \\ +2. if $a.sign = MP\_ZPOS$ and $b.sign = MP\_NEG$ then return(\textit{MP\_GT}) \\ +3. if $a.sign = MP\_NEG$ then \\ +\hspace{+3mm}3.1 Return the unsigned comparison of $b$ and $a$ (\textit{mp\_cmp\_mag}) \\ +4 Otherwise \\ +\hspace{+3mm}4.1 Return the unsigned comparison of $a$ and $b$ \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_cmp} +\end{figure} + +\textbf{Algorithm mp\_cmp.} +The first two steps compare the signs of the two inputs. If the signs do not agree then it can return right away with the appropriate +comparison code. When the signs are equal the digits of the inputs must be compared to determine the correct result. In step +three the unsigned comparision flips the order of the arguments since they are both negative. For instance, if $-a > -b$ then +$\vert a \vert < \vert b \vert$. Step number four will compare the two when they are both positive. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_cmp.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* compare two ints (signed)*/ +018 int +019 mp_cmp (mp_int * a, mp_int * b) +020 \{ +021 /* compare based on sign */ +022 if (a->sign != b->sign) \{ +023 if (a->sign == MP_NEG) \{ +024 return MP_LT; +025 \} else \{ +026 return MP_GT; +027 \} +028 \} +029 +030 /* compare digits */ +031 if (a->sign == MP_NEG) \{ +032 /* if negative compare opposite direction */ +033 return mp_cmp_mag(b, a); +034 \} else \{ +035 return mp_cmp_mag(a, b); +036 \} +037 \} +038 #endif +039 +\end{alltt} +\end{small} + +The two if statements (lines 22 and 23) perform the initial sign comparison. If the signs are not the equal then which ever +has the positive sign is larger. The inputs are compared (line 31) based on magnitudes. If the signs were both +negative then the unsigned comparison is performed in the opposite direction (line 33). Otherwise, the signs are assumed to +be both positive and a forward direction unsigned comparison is performed. + +\section*{Exercises} +\begin{tabular}{cl} +$\left [ 2 \right ]$ & Modify algorithm mp\_set\_int to accept as input a variable length array of bits. \\ + & \\ +$\left [ 3 \right ]$ & Give the probability that algorithm mp\_cmp\_mag will have to compare $k$ digits \\ + & of two random digits (of equal magnitude) before a difference is found. \\ + & \\ +$\left [ 1 \right ]$ & Suggest a simple method to speed up the implementation of mp\_cmp\_mag based \\ + & on the observations made in the previous problem. \\ + & +\end{tabular} + +\chapter{Basic Arithmetic} +\section{Introduction} +At this point algorithms for initialization, clearing, zeroing, copying, comparing and setting small constants have been +established. The next logical set of algorithms to develop are addition, subtraction and digit shifting algorithms. These +algorithms make use of the lower level algorithms and are the cruicial building block for the multiplication algorithms. It is very important +that these algorithms are highly optimized. On their own they are simple $O(n)$ algorithms but they can be called from higher level algorithms +which easily places them at $O(n^2)$ or even $O(n^3)$ work levels. + +All of the algorithms within this chapter make use of the logical bit shift operations denoted by $<<$ and $>>$ for left and right +logical shifts respectively. A logical shift is analogous to sliding the decimal point of radix-10 representations. For example, the real +number $0.9345$ is equivalent to $93.45\%$ which is found by sliding the the decimal two places to the right (\textit{multiplying by $\beta^2 = 10^2$}). +Algebraically a binary logical shift is equivalent to a division or multiplication by a power of two. +For example, $a << k = a \cdot 2^k$ while $a >> k = \lfloor a/2^k \rfloor$. + +One significant difference between a logical shift and the way decimals are shifted is that digits below the zero'th position are removed +from the number. For example, consider $1101_2 >> 1$ using decimal notation this would produce $110.1_2$. However, with a logical shift the +result is $110_2$. + +\section{Addition and Subtraction} +In common twos complement fixed precision arithmetic negative numbers are easily represented by subtraction from the modulus. For example, with 32-bit integers +$a - b\mbox{ (mod }2^{32}\mbox{)}$ is the same as $a + (2^{32} - b) \mbox{ (mod }2^{32}\mbox{)}$ since $2^{32} \equiv 0 \mbox{ (mod }2^{32}\mbox{)}$. +As a result subtraction can be performed with a trivial series of logical operations and an addition. + +However, in multiple precision arithmetic negative numbers are not represented in the same way. Instead a sign flag is used to keep track of the +sign of the integer. As a result signed addition and subtraction are actually implemented as conditional usage of lower level addition or +subtraction algorithms with the sign fixed up appropriately. + +The lower level algorithms will add or subtract integers without regard to the sign flag. That is they will add or subtract the magnitude of +the integers respectively. + +\subsection{Low Level Addition} +An unsigned addition of multiple precision integers is performed with the same long-hand algorithm used to add decimal numbers. That is to add the +trailing digits first and propagate the resulting carry upwards. Since this is a lower level algorithm the name will have a ``s\_'' prefix. +Historically that convention stems from the MPI library where ``s\_'' stood for static functions that were hidden from the developer entirely. + +\newpage +\begin{figure}[!here] +\begin{center} +\begin{small} +\begin{tabular}{l} +\hline Algorithm \textbf{s\_mp\_add}. \\ +\textbf{Input}. Two mp\_ints $a$ and $b$ \\ +\textbf{Output}. The unsigned addition $c = \vert a \vert + \vert b \vert$. \\ +\hline \\ +1. if $a.used > b.used$ then \\ +\hspace{+3mm}1.1 $min \leftarrow b.used$ \\ +\hspace{+3mm}1.2 $max \leftarrow a.used$ \\ +\hspace{+3mm}1.3 $x \leftarrow a$ \\ +2. else \\ +\hspace{+3mm}2.1 $min \leftarrow a.used$ \\ +\hspace{+3mm}2.2 $max \leftarrow b.used$ \\ +\hspace{+3mm}2.3 $x \leftarrow b$ \\ +3. If $c.alloc < max + 1$ then grow $c$ to hold at least $max + 1$ digits (\textit{mp\_grow}) \\ +4. $oldused \leftarrow c.used$ \\ +5. $c.used \leftarrow max + 1$ \\ +6. $u \leftarrow 0$ \\ +7. for $n$ from $0$ to $min - 1$ do \\ +\hspace{+3mm}7.1 $c_n \leftarrow a_n + b_n + u$ \\ +\hspace{+3mm}7.2 $u \leftarrow c_n >> lg(\beta)$ \\ +\hspace{+3mm}7.3 $c_n \leftarrow c_n \mbox{ (mod }\beta\mbox{)}$ \\ +8. if $min \ne max$ then do \\ +\hspace{+3mm}8.1 for $n$ from $min$ to $max - 1$ do \\ +\hspace{+6mm}8.1.1 $c_n \leftarrow x_n + u$ \\ +\hspace{+6mm}8.1.2 $u \leftarrow c_n >> lg(\beta)$ \\ +\hspace{+6mm}8.1.3 $c_n \leftarrow c_n \mbox{ (mod }\beta\mbox{)}$ \\ +9. $c_{max} \leftarrow u$ \\ +10. if $olduse > max$ then \\ +\hspace{+3mm}10.1 for $n$ from $max + 1$ to $oldused - 1$ do \\ +\hspace{+6mm}10.1.1 $c_n \leftarrow 0$ \\ +11. Clamp excess digits in $c$. (\textit{mp\_clamp}) \\ +12. Return(\textit{MP\_OKAY}) \\ +\hline +\end{tabular} +\end{small} +\end{center} +\caption{Algorithm s\_mp\_add} +\end{figure} + +\textbf{Algorithm s\_mp\_add.} +This algorithm is loosely based on algorithm 14.7 of HAC \cite[pp. 594]{HAC} but has been extended to allow the inputs to have different magnitudes. +Coincidentally the description of algorithm A in Knuth \cite[pp. 266]{TAOCPV2} shares the same deficiency as the algorithm from \cite{HAC}. Even the +MIX pseudo machine code presented by Knuth \cite[pp. 266-267]{TAOCPV2} is incapable of handling inputs which are of different magnitudes. + +The first thing that has to be accomplished is to sort out which of the two inputs is the largest. The addition logic +will simply add all of the smallest input to the largest input and store that first part of the result in the +destination. Then it will apply a simpler addition loop to excess digits of the larger input. + +The first two steps will handle sorting the inputs such that $min$ and $max$ hold the digit counts of the two +inputs. The variable $x$ will be an mp\_int alias for the largest input or the second input $b$ if they have the +same number of digits. After the inputs are sorted the destination $c$ is grown as required to accomodate the sum +of the two inputs. The original \textbf{used} count of $c$ is copied and set to the new used count. + +At this point the first addition loop will go through as many digit positions that both inputs have. The carry +variable $\mu$ is set to zero outside the loop. Inside the loop an ``addition'' step requires three statements to produce +one digit of the summand. First +two digits from $a$ and $b$ are added together along with the carry $\mu$. The carry of this step is extracted and stored +in $\mu$ and finally the digit of the result $c_n$ is truncated within the range $0 \le c_n < \beta$. + +Now all of the digit positions that both inputs have in common have been exhausted. If $min \ne max$ then $x$ is an alias +for one of the inputs that has more digits. A simplified addition loop is then used to essentially copy the remaining digits +and the carry to the destination. + +The final carry is stored in $c_{max}$ and digits above $max$ upto $oldused$ are zeroed which completes the addition. + + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_s\_mp\_add.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* low level addition, based on HAC pp.594, Algorithm 14.7 */ +018 int +019 s_mp_add (mp_int * a, mp_int * b, mp_int * c) +020 \{ +021 mp_int *x; +022 int olduse, res, min, max; +023 +024 /* find sizes, we let |a| <= |b| which means we have to sort +025 * them. "x" will point to the input with the most digits +026 */ +027 if (a->used > b->used) \{ +028 min = b->used; +029 max = a->used; +030 x = a; +031 \} else \{ +032 min = a->used; +033 max = b->used; +034 x = b; +035 \} +036 +037 /* init result */ +038 if (c->alloc < max + 1) \{ +039 if ((res = mp_grow (c, max + 1)) != MP_OKAY) \{ +040 return res; +041 \} +042 \} +043 +044 /* get old used digit count and set new one */ +045 olduse = c->used; +046 c->used = max + 1; +047 +048 \{ +049 register mp_digit u, *tmpa, *tmpb, *tmpc; +050 register int i; +051 +052 /* alias for digit pointers */ +053 +054 /* first input */ +055 tmpa = a->dp; +056 +057 /* second input */ +058 tmpb = b->dp; +059 +060 /* destination */ +061 tmpc = c->dp; +062 +063 /* zero the carry */ +064 u = 0; +065 for (i = 0; i < min; i++) \{ +066 /* Compute the sum at one digit, T[i] = A[i] + B[i] + U */ +067 *tmpc = *tmpa++ + *tmpb++ + u; +068 +069 /* U = carry bit of T[i] */ +070 u = *tmpc >> ((mp_digit)DIGIT_BIT); +071 +072 /* take away carry bit from T[i] */ +073 *tmpc++ &= MP_MASK; +074 \} +075 +076 /* now copy higher words if any, that is in A+B +077 * if A or B has more digits add those in +078 */ +079 if (min != max) \{ +080 for (; i < max; i++) \{ +081 /* T[i] = X[i] + U */ +082 *tmpc = x->dp[i] + u; +083 +084 /* U = carry bit of T[i] */ +085 u = *tmpc >> ((mp_digit)DIGIT_BIT); +086 +087 /* take away carry bit from T[i] */ +088 *tmpc++ &= MP_MASK; +089 \} +090 \} +091 +092 /* add carry */ +093 *tmpc++ = u; +094 +095 /* clear digits above oldused */ +096 for (i = c->used; i < olduse; i++) \{ +097 *tmpc++ = 0; +098 \} +099 \} +100 +101 mp_clamp (c); +102 return MP_OKAY; +103 \} +104 #endif +105 +\end{alltt} +\end{small} + +We first sort (lines 27 to 35) the inputs based on magnitude and determine the $min$ and $max$ variables. +Note that $x$ is a pointer to an mp\_int assigned to the largest input, in effect it is a local alias. Next we +grow the destination (37 to 42) ensure that it can accomodate the result of the addition. + +Similar to the implementation of mp\_copy this function uses the braced code and local aliases coding style. The three aliases that are on +lines 55, 58 and 61 represent the two inputs and destination variables respectively. These aliases are used to ensure the +compiler does not have to dereference $a$, $b$ or $c$ (respectively) to access the digits of the respective mp\_int. + +The initial carry $u$ will be cleared (line 64), note that $u$ is of type mp\_digit which ensures type +compatibility within the implementation. The initial addition (line 65 to 74) adds digits from +both inputs until the smallest input runs out of digits. Similarly the conditional addition loop +(line 80 to 90) adds the remaining digits from the larger of the two inputs. The addition is finished +with the final carry being stored in $tmpc$ (line 93). Note the ``++'' operator within the same expression. +After line 93, $tmpc$ will point to the $c.used$'th digit of the mp\_int $c$. This is useful +for the next loop (line 96 to 99) which set any old upper digits to zero. + +\subsection{Low Level Subtraction} +The low level unsigned subtraction algorithm is very similar to the low level unsigned addition algorithm. The principle difference is that the +unsigned subtraction algorithm requires the result to be positive. That is when computing $a - b$ the condition $\vert a \vert \ge \vert b\vert$ must +be met for this algorithm to function properly. Keep in mind this low level algorithm is not meant to be used in higher level algorithms directly. +This algorithm as will be shown can be used to create functional signed addition and subtraction algorithms. + + +For this algorithm a new variable is required to make the description simpler. Recall from section 1.3.1 that a mp\_digit must be able to represent +the range $0 \le x < 2\beta$ for the algorithms to work correctly. However, it is allowable that a mp\_digit represent a larger range of values. For +this algorithm we will assume that the variable $\gamma$ represents the number of bits available in a +mp\_digit (\textit{this implies $2^{\gamma} > \beta$}). + +For example, the default for LibTomMath is to use a ``unsigned long'' for the mp\_digit ``type'' while $\beta = 2^{28}$. In ISO C an ``unsigned long'' +data type must be able to represent $0 \le x < 2^{32}$ meaning that in this case $\gamma \ge 32$. + +\newpage\begin{figure}[!here] +\begin{center} +\begin{small} +\begin{tabular}{l} +\hline Algorithm \textbf{s\_mp\_sub}. \\ +\textbf{Input}. Two mp\_ints $a$ and $b$ ($\vert a \vert \ge \vert b \vert$) \\ +\textbf{Output}. The unsigned subtraction $c = \vert a \vert - \vert b \vert$. \\ +\hline \\ +1. $min \leftarrow b.used$ \\ +2. $max \leftarrow a.used$ \\ +3. If $c.alloc < max$ then grow $c$ to hold at least $max$ digits. (\textit{mp\_grow}) \\ +4. $oldused \leftarrow c.used$ \\ +5. $c.used \leftarrow max$ \\ +6. $u \leftarrow 0$ \\ +7. for $n$ from $0$ to $min - 1$ do \\ +\hspace{3mm}7.1 $c_n \leftarrow a_n - b_n - u$ \\ +\hspace{3mm}7.2 $u \leftarrow c_n >> (\gamma - 1)$ \\ +\hspace{3mm}7.3 $c_n \leftarrow c_n \mbox{ (mod }\beta\mbox{)}$ \\ +8. if $min < max$ then do \\ +\hspace{3mm}8.1 for $n$ from $min$ to $max - 1$ do \\ +\hspace{6mm}8.1.1 $c_n \leftarrow a_n - u$ \\ +\hspace{6mm}8.1.2 $u \leftarrow c_n >> (\gamma - 1)$ \\ +\hspace{6mm}8.1.3 $c_n \leftarrow c_n \mbox{ (mod }\beta\mbox{)}$ \\ +9. if $oldused > max$ then do \\ +\hspace{3mm}9.1 for $n$ from $max$ to $oldused - 1$ do \\ +\hspace{6mm}9.1.1 $c_n \leftarrow 0$ \\ +10. Clamp excess digits of $c$. (\textit{mp\_clamp}). \\ +11. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{small} +\end{center} +\caption{Algorithm s\_mp\_sub} +\end{figure} + +\textbf{Algorithm s\_mp\_sub.} +This algorithm performs the unsigned subtraction of two mp\_int variables under the restriction that the result must be positive. That is when +passing variables $a$ and $b$ the condition that $\vert a \vert \ge \vert b \vert$ must be met for the algorithm to function correctly. This +algorithm is loosely based on algorithm 14.9 \cite[pp. 595]{HAC} and is similar to algorithm S in \cite[pp. 267]{TAOCPV2} as well. As was the case +of the algorithm s\_mp\_add both other references lack discussion concerning various practical details such as when the inputs differ in magnitude. + +The initial sorting of the inputs is trivial in this algorithm since $a$ is guaranteed to have at least the same magnitude of $b$. Steps 1 and 2 +set the $min$ and $max$ variables. Unlike the addition routine there is guaranteed to be no carry which means that the final result can be at +most $max$ digits in length as opposed to $max + 1$. Similar to the addition algorithm the \textbf{used} count of $c$ is copied locally and +set to the maximal count for the operation. + +The subtraction loop that begins on step seven is essentially the same as the addition loop of algorithm s\_mp\_add except single precision +subtraction is used instead. Note the use of the $\gamma$ variable to extract the carry (\textit{also known as the borrow}) within the subtraction +loops. Under the assumption that two's complement single precision arithmetic is used this will successfully extract the desired carry. + +For example, consider subtracting $0101_2$ from $0100_2$ where $\gamma = 4$ and $\beta = 2$. The least significant bit will force a carry upwards to +the third bit which will be set to zero after the borrow. After the very first bit has been subtracted $4 - 1 \equiv 0011_2$ will remain, When the +third bit of $0101_2$ is subtracted from the result it will cause another carry. In this case though the carry will be forced to propagate all the +way to the most significant bit. + +Recall that $\beta < 2^{\gamma}$. This means that if a carry does occur just before the $lg(\beta)$'th bit it will propagate all the way to the most +significant bit. Thus, the high order bits of the mp\_digit that are not part of the actual digit will either be all zero, or all one. All that +is needed is a single zero or one bit for the carry. Therefore a single logical shift right by $\gamma - 1$ positions is sufficient to extract the +carry. This method of carry extraction may seem awkward but the reason for it becomes apparent when the implementation is discussed. + +If $b$ has a smaller magnitude than $a$ then step 9 will force the carry and copy operation to propagate through the larger input $a$ into $c$. Step +10 will ensure that any leading digits of $c$ above the $max$'th position are zeroed. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_s\_mp\_sub.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* low level subtraction (assumes |a| > |b|), HAC pp.595 Algorithm 14.9 */ +018 int +019 s_mp_sub (mp_int * a, mp_int * b, mp_int * c) +020 \{ +021 int olduse, res, min, max; +022 +023 /* find sizes */ +024 min = b->used; +025 max = a->used; +026 +027 /* init result */ +028 if (c->alloc < max) \{ +029 if ((res = mp_grow (c, max)) != MP_OKAY) \{ +030 return res; +031 \} +032 \} +033 olduse = c->used; +034 c->used = max; +035 +036 \{ +037 register mp_digit u, *tmpa, *tmpb, *tmpc; +038 register int i; +039 +040 /* alias for digit pointers */ +041 tmpa = a->dp; +042 tmpb = b->dp; +043 tmpc = c->dp; +044 +045 /* set carry to zero */ +046 u = 0; +047 for (i = 0; i < min; i++) \{ +048 /* T[i] = A[i] - B[i] - U */ +049 *tmpc = *tmpa++ - *tmpb++ - u; +050 +051 /* U = carry bit of T[i] +052 * Note this saves performing an AND operation since +053 * if a carry does occur it will propagate all the way to the +054 * MSB. As a result a single shift is enough to get the carry +055 */ +056 u = *tmpc >> ((mp_digit)(CHAR_BIT * sizeof (mp_digit) - 1)); +057 +058 /* Clear carry from T[i] */ +059 *tmpc++ &= MP_MASK; +060 \} +061 +062 /* now copy higher words if any, e.g. if A has more digits than B */ +063 for (; i < max; i++) \{ +064 /* T[i] = A[i] - U */ +065 *tmpc = *tmpa++ - u; +066 +067 /* U = carry bit of T[i] */ +068 u = *tmpc >> ((mp_digit)(CHAR_BIT * sizeof (mp_digit) - 1)); +069 +070 /* Clear carry from T[i] */ +071 *tmpc++ &= MP_MASK; +072 \} +073 +074 /* clear digits above used (since we may not have grown result above) */ + +075 for (i = c->used; i < olduse; i++) \{ +076 *tmpc++ = 0; +077 \} +078 \} +079 +080 mp_clamp (c); +081 return MP_OKAY; +082 \} +083 +084 #endif +085 +\end{alltt} +\end{small} + +Like low level addition we ``sort'' the inputs. Except in this case the sorting is hardcoded +(lines 24 and 25). In reality the $min$ and $max$ variables are only aliases and are only +used to make the source code easier to read. Again the pointer alias optimization is used +within this algorithm. The aliases $tmpa$, $tmpb$ and $tmpc$ are initialized +(lines 41, 42 and 43) for $a$, $b$ and $c$ respectively. + +The first subtraction loop (lines 46 through 60) subtract digits from both inputs until the smaller of +the two inputs has been exhausted. As remarked earlier there is an implementation reason for using the ``awkward'' +method of extracting the carry (line 56). The traditional method for extracting the carry would be to shift +by $lg(\beta)$ positions and logically AND the least significant bit. The AND operation is required because all of +the bits above the $\lg(\beta)$'th bit will be set to one after a carry occurs from subtraction. This carry +extraction requires two relatively cheap operations to extract the carry. The other method is to simply shift the +most significant bit to the least significant bit thus extracting the carry with a single cheap operation. This +optimization only works on twos compliment machines which is a safe assumption to make. + +If $a$ has a larger magnitude than $b$ an additional loop (lines 63 through 72) is required to propagate +the carry through $a$ and copy the result to $c$. + +\subsection{High Level Addition} +Now that both lower level addition and subtraction algorithms have been established an effective high level signed addition algorithm can be +established. This high level addition algorithm will be what other algorithms and developers will use to perform addition of mp\_int data +types. + +Recall from section 5.2 that an mp\_int represents an integer with an unsigned mantissa (\textit{the array of digits}) and a \textbf{sign} +flag. A high level addition is actually performed as a series of eight separate cases which can be optimized down to three unique cases. + +\begin{figure}[!here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_add}. \\ +\textbf{Input}. Two mp\_ints $a$ and $b$ \\ +\textbf{Output}. The signed addition $c = a + b$. \\ +\hline \\ +1. if $a.sign = b.sign$ then do \\ +\hspace{3mm}1.1 $c.sign \leftarrow a.sign$ \\ +\hspace{3mm}1.2 $c \leftarrow \vert a \vert + \vert b \vert$ (\textit{s\_mp\_add})\\ +2. else do \\ +\hspace{3mm}2.1 if $\vert a \vert < \vert b \vert$ then do (\textit{mp\_cmp\_mag}) \\ +\hspace{6mm}2.1.1 $c.sign \leftarrow b.sign$ \\ +\hspace{6mm}2.1.2 $c \leftarrow \vert b \vert - \vert a \vert$ (\textit{s\_mp\_sub}) \\ +\hspace{3mm}2.2 else do \\ +\hspace{6mm}2.2.1 $c.sign \leftarrow a.sign$ \\ +\hspace{6mm}2.2.2 $c \leftarrow \vert a \vert - \vert b \vert$ \\ +3. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_add} +\end{figure} + +\textbf{Algorithm mp\_add.} +This algorithm performs the signed addition of two mp\_int variables. There is no reference algorithm to draw upon from +either \cite{TAOCPV2} or \cite{HAC} since they both only provide unsigned operations. The algorithm is fairly +straightforward but restricted since subtraction can only produce positive results. + +\begin{figure}[here] +\begin{small} +\begin{center} +\begin{tabular}{|c|c|c|c|c|} +\hline \textbf{Sign of $a$} & \textbf{Sign of $b$} & \textbf{$\vert a \vert > \vert b \vert $} & \textbf{Unsigned Operation} & \textbf{Result Sign Flag} \\ +\hline $+$ & $+$ & Yes & $c = a + b$ & $a.sign$ \\ +\hline $+$ & $+$ & No & $c = a + b$ & $a.sign$ \\ +\hline $-$ & $-$ & Yes & $c = a + b$ & $a.sign$ \\ +\hline $-$ & $-$ & No & $c = a + b$ & $a.sign$ \\ +\hline &&&&\\ + +\hline $+$ & $-$ & No & $c = b - a$ & $b.sign$ \\ +\hline $-$ & $+$ & No & $c = b - a$ & $b.sign$ \\ + +\hline &&&&\\ + +\hline $+$ & $-$ & Yes & $c = a - b$ & $a.sign$ \\ +\hline $-$ & $+$ & Yes & $c = a - b$ & $a.sign$ \\ + +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Addition Guide Chart} +\label{fig:AddChart} +\end{figure} + +Figure~\ref{fig:AddChart} lists all of the eight possible input combinations and is sorted to show that only three +specific cases need to be handled. The return code of the unsigned operations at step 1.2, 2.1.2 and 2.2.2 are +forwarded to step three to check for errors. This simplifies the description of the algorithm considerably and best +follows how the implementation actually was achieved. + +Also note how the \textbf{sign} is set before the unsigned addition or subtraction is performed. Recall from the descriptions of algorithms +s\_mp\_add and s\_mp\_sub that the mp\_clamp function is used at the end to trim excess digits. The mp\_clamp algorithm will set the \textbf{sign} +to \textbf{MP\_ZPOS} when the \textbf{used} digit count reaches zero. + +For example, consider performing $-a + a$ with algorithm mp\_add. By the description of the algorithm the sign is set to \textbf{MP\_NEG} which would +produce a result of $-0$. However, since the sign is set first then the unsigned addition is performed the subsequent usage of algorithm mp\_clamp +within algorithm s\_mp\_add will force $-0$ to become $0$. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_add.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* high level addition (handles signs) */ +018 int mp_add (mp_int * a, mp_int * b, mp_int * c) +019 \{ +020 int sa, sb, res; +021 +022 /* get sign of both inputs */ +023 sa = a->sign; +024 sb = b->sign; +025 +026 /* handle two cases, not four */ +027 if (sa == sb) \{ +028 /* both positive or both negative */ +029 /* add their magnitudes, copy the sign */ +030 c->sign = sa; +031 res = s_mp_add (a, b, c); +032 \} else \{ +033 /* one positive, the other negative */ +034 /* subtract the one with the greater magnitude from */ +035 /* the one of the lesser magnitude. The result gets */ +036 /* the sign of the one with the greater magnitude. */ +037 if (mp_cmp_mag (a, b) == MP_LT) \{ +038 c->sign = sb; +039 res = s_mp_sub (b, a, c); +040 \} else \{ +041 c->sign = sa; +042 res = s_mp_sub (a, b, c); +043 \} +044 \} +045 return res; +046 \} +047 +048 #endif +049 +\end{alltt} +\end{small} + +The source code follows the algorithm fairly closely. The most notable new source code addition is the usage of the $res$ integer variable which +is used to pass result of the unsigned operations forward. Unlike in the algorithm, the variable $res$ is merely returned as is without +explicitly checking it and returning the constant \textbf{MP\_OKAY}. The observation is this algorithm will succeed or fail only if the lower +level functions do so. Returning their return code is sufficient. + +\subsection{High Level Subtraction} +The high level signed subtraction algorithm is essentially the same as the high level signed addition algorithm. + +\newpage\begin{figure}[!here] +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_sub}. \\ +\textbf{Input}. Two mp\_ints $a$ and $b$ \\ +\textbf{Output}. The signed subtraction $c = a - b$. \\ +\hline \\ +1. if $a.sign \ne b.sign$ then do \\ +\hspace{3mm}1.1 $c.sign \leftarrow a.sign$ \\ +\hspace{3mm}1.2 $c \leftarrow \vert a \vert + \vert b \vert$ (\textit{s\_mp\_add}) \\ +2. else do \\ +\hspace{3mm}2.1 if $\vert a \vert \ge \vert b \vert$ then do (\textit{mp\_cmp\_mag}) \\ +\hspace{6mm}2.1.1 $c.sign \leftarrow a.sign$ \\ +\hspace{6mm}2.1.2 $c \leftarrow \vert a \vert - \vert b \vert$ (\textit{s\_mp\_sub}) \\ +\hspace{3mm}2.2 else do \\ +\hspace{6mm}2.2.1 $c.sign \leftarrow \left \lbrace \begin{array}{ll} + MP\_ZPOS & \mbox{if }a.sign = MP\_NEG \\ + MP\_NEG & \mbox{otherwise} \\ + \end{array} \right .$ \\ +\hspace{6mm}2.2.2 $c \leftarrow \vert b \vert - \vert a \vert$ \\ +3. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\caption{Algorithm mp\_sub} +\end{figure} + +\textbf{Algorithm mp\_sub.} +This algorithm performs the signed subtraction of two inputs. Similar to algorithm mp\_add there is no reference in either \cite{TAOCPV2} or +\cite{HAC}. Also this algorithm is restricted by algorithm s\_mp\_sub. Chart \ref{fig:SubChart} lists the eight possible inputs and +the operations required. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{|c|c|c|c|c|} +\hline \textbf{Sign of $a$} & \textbf{Sign of $b$} & \textbf{$\vert a \vert \ge \vert b \vert $} & \textbf{Unsigned Operation} & \textbf{Result Sign Flag} \\ +\hline $+$ & $-$ & Yes & $c = a + b$ & $a.sign$ \\ +\hline $+$ & $-$ & No & $c = a + b$ & $a.sign$ \\ +\hline $-$ & $+$ & Yes & $c = a + b$ & $a.sign$ \\ +\hline $-$ & $+$ & No & $c = a + b$ & $a.sign$ \\ +\hline &&&& \\ +\hline $+$ & $+$ & Yes & $c = a - b$ & $a.sign$ \\ +\hline $-$ & $-$ & Yes & $c = a - b$ & $a.sign$ \\ +\hline &&&& \\ +\hline $+$ & $+$ & No & $c = b - a$ & $\mbox{opposite of }a.sign$ \\ +\hline $-$ & $-$ & No & $c = b - a$ & $\mbox{opposite of }a.sign$ \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Subtraction Guide Chart} +\label{fig:SubChart} +\end{figure} + +Similar to the case of algorithm mp\_add the \textbf{sign} is set first before the unsigned addition or subtraction. That is to prevent the +algorithm from producing $-a - -a = -0$ as a result. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_sub.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* high level subtraction (handles signs) */ +018 int +019 mp_sub (mp_int * a, mp_int * b, mp_int * c) +020 \{ +021 int sa, sb, res; +022 +023 sa = a->sign; +024 sb = b->sign; +025 +026 if (sa != sb) \{ +027 /* subtract a negative from a positive, OR */ +028 /* subtract a positive from a negative. */ +029 /* In either case, ADD their magnitudes, */ +030 /* and use the sign of the first number. */ +031 c->sign = sa; +032 res = s_mp_add (a, b, c); +033 \} else \{ +034 /* subtract a positive from a positive, OR */ +035 /* subtract a negative from a negative. */ +036 /* First, take the difference between their */ +037 /* magnitudes, then... */ +038 if (mp_cmp_mag (a, b) != MP_LT) \{ +039 /* Copy the sign from the first */ +040 c->sign = sa; +041 /* The first has a larger or equal magnitude */ +042 res = s_mp_sub (a, b, c); +043 \} else \{ +044 /* The result has the *opposite* sign from */ +045 /* the first number. */ +046 c->sign = (sa == MP_ZPOS) ? MP_NEG : MP_ZPOS; +047 /* The second has a larger magnitude */ +048 res = s_mp_sub (b, a, c); +049 \} +050 \} +051 return res; +052 \} +053 +054 #endif +055 +\end{alltt} +\end{small} + +Much like the implementation of algorithm mp\_add the variable $res$ is used to catch the return code of the unsigned addition or subtraction operations +and forward it to the end of the function. On line 38 the ``not equal to'' \textbf{MP\_LT} expression is used to emulate a +``greater than or equal to'' comparison. + +\section{Bit and Digit Shifting} +It is quite common to think of a multiple precision integer as a polynomial in $x$, that is $y = f(\beta)$ where $f(x) = \sum_{i=0}^{n-1} a_i x^i$. +This notation arises within discussion of Montgomery and Diminished Radix Reduction as well as Karatsuba multiplication and squaring. + +In order to facilitate operations on polynomials in $x$ as above a series of simple ``digit'' algorithms have to be established. That is to shift +the digits left or right as well to shift individual bits of the digits left and right. It is important to note that not all ``shift'' operations +are on radix-$\beta$ digits. + +\subsection{Multiplication by Two} + +In a binary system where the radix is a power of two multiplication by two not only arises often in other algorithms it is a fairly efficient +operation to perform. A single precision logical shift left is sufficient to multiply a single digit by two. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_mul\_2}. \\ +\textbf{Input}. One mp\_int $a$ \\ +\textbf{Output}. $b = 2a$. \\ +\hline \\ +1. If $b.alloc < a.used + 1$ then grow $b$ to hold $a.used + 1$ digits. (\textit{mp\_grow}) \\ +2. $oldused \leftarrow b.used$ \\ +3. $b.used \leftarrow a.used$ \\ +4. $r \leftarrow 0$ \\ +5. for $n$ from 0 to $a.used - 1$ do \\ +\hspace{3mm}5.1 $rr \leftarrow a_n >> (lg(\beta) - 1)$ \\ +\hspace{3mm}5.2 $b_n \leftarrow (a_n << 1) + r \mbox{ (mod }\beta\mbox{)}$ \\ +\hspace{3mm}5.3 $r \leftarrow rr$ \\ +6. If $r \ne 0$ then do \\ +\hspace{3mm}6.1 $b_{n + 1} \leftarrow r$ \\ +\hspace{3mm}6.2 $b.used \leftarrow b.used + 1$ \\ +7. If $b.used < oldused - 1$ then do \\ +\hspace{3mm}7.1 for $n$ from $b.used$ to $oldused - 1$ do \\ +\hspace{6mm}7.1.1 $b_n \leftarrow 0$ \\ +8. $b.sign \leftarrow a.sign$ \\ +9. Return(\textit{MP\_OKAY}).\\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_mul\_2} +\end{figure} + +\textbf{Algorithm mp\_mul\_2.} +This algorithm will quickly multiply a mp\_int by two provided $\beta$ is a power of two. Neither \cite{TAOCPV2} nor \cite{HAC} describe such +an algorithm despite the fact it arises often in other algorithms. The algorithm is setup much like the lower level algorithm s\_mp\_add since +it is for all intents and purposes equivalent to the operation $b = \vert a \vert + \vert a \vert$. + +Step 1 and 2 grow the input as required to accomodate the maximum number of \textbf{used} digits in the result. The initial \textbf{used} count +is set to $a.used$ at step 4. Only if there is a final carry will the \textbf{used} count require adjustment. + +Step 6 is an optimization implementation of the addition loop for this specific case. That is since the two values being added together +are the same there is no need to perform two reads from the digits of $a$. Step 6.1 performs a single precision shift on the current digit $a_n$ to +obtain what will be the carry for the next iteration. Step 6.2 calculates the $n$'th digit of the result as single precision shift of $a_n$ plus +the previous carry. Recall from section 4.1 that $a_n << 1$ is equivalent to $a_n \cdot 2$. An iteration of the addition loop is finished with +forwarding the carry to the next iteration. + +Step 7 takes care of any final carry by setting the $a.used$'th digit of the result to the carry and augmenting the \textbf{used} count of $b$. +Step 8 clears any leading digits of $b$ in case it originally had a larger magnitude than $a$. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_mul\_2.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* b = a*2 */ +018 int mp_mul_2(mp_int * a, mp_int * b) +019 \{ +020 int x, res, oldused; +021 +022 /* grow to accomodate result */ +023 if (b->alloc < a->used + 1) \{ +024 if ((res = mp_grow (b, a->used + 1)) != MP_OKAY) \{ +025 return res; +026 \} +027 \} +028 +029 oldused = b->used; +030 b->used = a->used; +031 +032 \{ +033 register mp_digit r, rr, *tmpa, *tmpb; +034 +035 /* alias for source */ +036 tmpa = a->dp; +037 +038 /* alias for dest */ +039 tmpb = b->dp; +040 +041 /* carry */ +042 r = 0; +043 for (x = 0; x < a->used; x++) \{ +044 +045 /* get what will be the *next* carry bit from the +046 * MSB of the current digit +047 */ +048 rr = *tmpa >> ((mp_digit)(DIGIT_BIT - 1)); +049 +050 /* now shift up this digit, add in the carry [from the previous] */ +051 *tmpb++ = ((*tmpa++ << ((mp_digit)1)) | r) & MP_MASK; +052 +053 /* copy the carry that would be from the source +054 * digit into the next iteration +055 */ +056 r = rr; +057 \} +058 +059 /* new leading digit? */ +060 if (r != 0) \{ +061 /* add a MSB which is always 1 at this point */ +062 *tmpb = 1; +063 ++(b->used); +064 \} +065 +066 /* now zero any excess digits on the destination +067 * that we didn't write to +068 */ +069 tmpb = b->dp + b->used; +070 for (x = b->used; x < oldused; x++) \{ +071 *tmpb++ = 0; +072 \} +073 \} +074 b->sign = a->sign; +075 return MP_OKAY; +076 \} +077 #endif +078 +\end{alltt} +\end{small} + +This implementation is essentially an optimized implementation of s\_mp\_add for the case of doubling an input. The only noteworthy difference +is the use of the logical shift operator on line 51 to perform a single precision doubling. + +\subsection{Division by Two} +A division by two can just as easily be accomplished with a logical shift right as multiplication by two can be with a logical shift left. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_div\_2}. \\ +\textbf{Input}. One mp\_int $a$ \\ +\textbf{Output}. $b = a/2$. \\ +\hline \\ +1. If $b.alloc < a.used$ then grow $b$ to hold $a.used$ digits. (\textit{mp\_grow}) \\ +2. If the reallocation failed return(\textit{MP\_MEM}). \\ +3. $oldused \leftarrow b.used$ \\ +4. $b.used \leftarrow a.used$ \\ +5. $r \leftarrow 0$ \\ +6. for $n$ from $b.used - 1$ to $0$ do \\ +\hspace{3mm}6.1 $rr \leftarrow a_n \mbox{ (mod }2\mbox{)}$\\ +\hspace{3mm}6.2 $b_n \leftarrow (a_n >> 1) + (r << (lg(\beta) - 1)) \mbox{ (mod }\beta\mbox{)}$ \\ +\hspace{3mm}6.3 $r \leftarrow rr$ \\ +7. If $b.used < oldused - 1$ then do \\ +\hspace{3mm}7.1 for $n$ from $b.used$ to $oldused - 1$ do \\ +\hspace{6mm}7.1.1 $b_n \leftarrow 0$ \\ +8. $b.sign \leftarrow a.sign$ \\ +9. Clamp excess digits of $b$. (\textit{mp\_clamp}) \\ +10. Return(\textit{MP\_OKAY}).\\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_div\_2} +\end{figure} + +\textbf{Algorithm mp\_div\_2.} +This algorithm will divide an mp\_int by two using logical shifts to the right. Like mp\_mul\_2 it uses a modified low level addition +core as the basis of the algorithm. Unlike mp\_mul\_2 the shift operations work from the leading digit to the trailing digit. The algorithm +could be written to work from the trailing digit to the leading digit however, it would have to stop one short of $a.used - 1$ digits to prevent +reading past the end of the array of digits. + +Essentially the loop at step 6 is similar to that of mp\_mul\_2 except the logical shifts go in the opposite direction and the carry is at the +least significant bit not the most significant bit. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_div\_2.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* b = a/2 */ +018 int mp_div_2(mp_int * a, mp_int * b) +019 \{ +020 int x, res, oldused; +021 +022 /* copy */ +023 if (b->alloc < a->used) \{ +024 if ((res = mp_grow (b, a->used)) != MP_OKAY) \{ +025 return res; +026 \} +027 \} +028 +029 oldused = b->used; +030 b->used = a->used; +031 \{ +032 register mp_digit r, rr, *tmpa, *tmpb; +033 +034 /* source alias */ +035 tmpa = a->dp + b->used - 1; +036 +037 /* dest alias */ +038 tmpb = b->dp + b->used - 1; +039 +040 /* carry */ +041 r = 0; +042 for (x = b->used - 1; x >= 0; x--) \{ +043 /* get the carry for the next iteration */ +044 rr = *tmpa & 1; +045 +046 /* shift the current digit, add in carry and store */ +047 *tmpb-- = (*tmpa-- >> 1) | (r << (DIGIT_BIT - 1)); +048 +049 /* forward carry to next iteration */ +050 r = rr; +051 \} +052 +053 /* zero excess digits */ +054 tmpb = b->dp + b->used; +055 for (x = b->used; x < oldused; x++) \{ +056 *tmpb++ = 0; +057 \} +058 \} +059 b->sign = a->sign; +060 mp_clamp (b); +061 return MP_OKAY; +062 \} +063 #endif +064 +\end{alltt} +\end{small} + +\section{Polynomial Basis Operations} +Recall from section 4.3 that any integer can be represented as a polynomial in $x$ as $y = f(\beta)$. Such a representation is also known as +the polynomial basis \cite[pp. 48]{ROSE}. Given such a notation a multiplication or division by $x$ amounts to shifting whole digits a single +place. The need for such operations arises in several other higher level algorithms such as Barrett and Montgomery reduction, integer +division and Karatsuba multiplication. + +Converting from an array of digits to polynomial basis is very simple. Consider the integer $y \equiv (a_2, a_1, a_0)_{\beta}$ and recall that +$y = \sum_{i=0}^{2} a_i \beta^i$. Simply replace $\beta$ with $x$ and the expression is in polynomial basis. For example, $f(x) = 8x + 9$ is the +polynomial basis representation for $89$ using radix ten. That is, $f(10) = 8(10) + 9 = 89$. + +\subsection{Multiplication by $x$} + +Given a polynomial in $x$ such as $f(x) = a_n x^n + a_{n-1} x^{n-1} + ... + a_0$ multiplying by $x$ amounts to shifting the coefficients up one +degree. In this case $f(x) \cdot x = a_n x^{n+1} + a_{n-1} x^n + ... + a_0 x$. From a scalar basis point of view multiplying by $x$ is equivalent to +multiplying by the integer $\beta$. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_lshd}. \\ +\textbf{Input}. One mp\_int $a$ and an integer $b$ \\ +\textbf{Output}. $a \leftarrow a \cdot \beta^b$ (equivalent to multiplication by $x^b$). \\ +\hline \\ +1. If $b \le 0$ then return(\textit{MP\_OKAY}). \\ +2. If $a.alloc < a.used + b$ then grow $a$ to at least $a.used + b$ digits. (\textit{mp\_grow}). \\ +3. If the reallocation failed return(\textit{MP\_MEM}). \\ +4. $a.used \leftarrow a.used + b$ \\ +5. $i \leftarrow a.used - 1$ \\ +6. $j \leftarrow a.used - 1 - b$ \\ +7. for $n$ from $a.used - 1$ to $b$ do \\ +\hspace{3mm}7.1 $a_{i} \leftarrow a_{j}$ \\ +\hspace{3mm}7.2 $i \leftarrow i - 1$ \\ +\hspace{3mm}7.3 $j \leftarrow j - 1$ \\ +8. for $n$ from 0 to $b - 1$ do \\ +\hspace{3mm}8.1 $a_n \leftarrow 0$ \\ +9. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_lshd} +\end{figure} + +\textbf{Algorithm mp\_lshd.} +This algorithm multiplies an mp\_int by the $b$'th power of $x$. This is equivalent to multiplying by $\beta^b$. The algorithm differs +from the other algorithms presented so far as it performs the operation in place instead storing the result in a separate location. The +motivation behind this change is due to the way this function is typically used. Algorithms such as mp\_add store the result in an optionally +different third mp\_int because the original inputs are often still required. Algorithm mp\_lshd (\textit{and similarly algorithm mp\_rshd}) is +typically used on values where the original value is no longer required. The algorithm will return success immediately if +$b \le 0$ since the rest of algorithm is only valid when $b > 0$. + +First the destination $a$ is grown as required to accomodate the result. The counters $i$ and $j$ are used to form a \textit{sliding window} over +the digits of $a$ of length $b$. The head of the sliding window is at $i$ (\textit{the leading digit}) and the tail at $j$ (\textit{the trailing digit}). +The loop on step 7 copies the digit from the tail to the head. In each iteration the window is moved down one digit. The last loop on +step 8 sets the lower $b$ digits to zero. + +\newpage +\begin{center} +\begin{figure}[here] +\includegraphics{pics/sliding_window.ps} +\caption{Sliding Window Movement} +\label{pic:sliding_window} +\end{figure} +\end{center} + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_lshd.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* shift left a certain amount of digits */ +018 int mp_lshd (mp_int * a, int b) +019 \{ +020 int x, res; +021 +022 /* if its less than zero return */ +023 if (b <= 0) \{ +024 return MP_OKAY; +025 \} +026 +027 /* grow to fit the new digits */ +028 if (a->alloc < a->used + b) \{ +029 if ((res = mp_grow (a, a->used + b)) != MP_OKAY) \{ +030 return res; +031 \} +032 \} +033 +034 \{ +035 register mp_digit *top, *bottom; +036 +037 /* increment the used by the shift amount then copy upwards */ +038 a->used += b; +039 +040 /* top */ +041 top = a->dp + a->used - 1; +042 +043 /* base */ +044 bottom = a->dp + a->used - 1 - b; +045 +046 /* much like mp_rshd this is implemented using a sliding window +047 * except the window goes the otherway around. Copying from +048 * the bottom to the top. see bn_mp_rshd.c for more info. +049 */ +050 for (x = a->used - 1; x >= b; x--) \{ +051 *top-- = *bottom--; +052 \} +053 +054 /* zero the lower digits */ +055 top = a->dp; +056 for (x = 0; x < b; x++) \{ +057 *top++ = 0; +058 \} +059 \} +060 return MP_OKAY; +061 \} +062 #endif +063 +\end{alltt} +\end{small} + +The if statement (line 23) ensures that the $b$ variable is greater than zero since we do not interpret negative +shift counts properly. The \textbf{used} count is incremented by $b$ before the copy loop begins. This elminates +the need for an additional variable in the for loop. The variable $top$ (line 41) is an alias +for the leading digit while $bottom$ (line 44) is an alias for the trailing edge. The aliases form a +window of exactly $b$ digits over the input. + +\subsection{Division by $x$} + +Division by powers of $x$ is easily achieved by shifting the digits right and removing any that will end up to the right of the zero'th digit. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_rshd}. \\ +\textbf{Input}. One mp\_int $a$ and an integer $b$ \\ +\textbf{Output}. $a \leftarrow a / \beta^b$ (Divide by $x^b$). \\ +\hline \\ +1. If $b \le 0$ then return. \\ +2. If $a.used \le b$ then do \\ +\hspace{3mm}2.1 Zero $a$. (\textit{mp\_zero}). \\ +\hspace{3mm}2.2 Return. \\ +3. $i \leftarrow 0$ \\ +4. $j \leftarrow b$ \\ +5. for $n$ from 0 to $a.used - b - 1$ do \\ +\hspace{3mm}5.1 $a_i \leftarrow a_j$ \\ +\hspace{3mm}5.2 $i \leftarrow i + 1$ \\ +\hspace{3mm}5.3 $j \leftarrow j + 1$ \\ +6. for $n$ from $a.used - b$ to $a.used - 1$ do \\ +\hspace{3mm}6.1 $a_n \leftarrow 0$ \\ +7. $a.used \leftarrow a.used - b$ \\ +8. Return. \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_rshd} +\end{figure} + +\textbf{Algorithm mp\_rshd.} +This algorithm divides the input in place by the $b$'th power of $x$. It is analogous to dividing by a $\beta^b$ but much quicker since +it does not require single precision division. This algorithm does not actually return an error code as it cannot fail. + +If the input $b$ is less than one the algorithm quickly returns without performing any work. If the \textbf{used} count is less than or equal +to the shift count $b$ then it will simply zero the input and return. + +After the trivial cases of inputs have been handled the sliding window is setup. Much like the case of algorithm mp\_lshd a sliding window that +is $b$ digits wide is used to copy the digits. Unlike mp\_lshd the window slides in the opposite direction from the trailing to the leading digit. +Also the digits are copied from the leading to the trailing edge. + +Once the window copy is complete the upper digits must be zeroed and the \textbf{used} count decremented. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_rshd.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* shift right a certain amount of digits */ +018 void mp_rshd (mp_int * a, int b) +019 \{ +020 int x; +021 +022 /* if b <= 0 then ignore it */ +023 if (b <= 0) \{ +024 return; +025 \} +026 +027 /* if b > used then simply zero it and return */ +028 if (a->used <= b) \{ +029 mp_zero (a); +030 return; +031 \} +032 +033 \{ +034 register mp_digit *bottom, *top; +035 +036 /* shift the digits down */ +037 +038 /* bottom */ +039 bottom = a->dp; +040 +041 /* top [offset into digits] */ +042 top = a->dp + b; +043 +044 /* this is implemented as a sliding window where +045 * the window is b-digits long and digits from +046 * the top of the window are copied to the bottom +047 * +048 * e.g. +049 +050 b-2 | b-1 | b0 | b1 | b2 | ... | bb | ----> +051 /\symbol{92} | ----> +052 \symbol{92}-------------------/ ----> +053 */ +054 for (x = 0; x < (a->used - b); x++) \{ +055 *bottom++ = *top++; +056 \} +057 +058 /* zero the top digits */ +059 for (; x < a->used; x++) \{ +060 *bottom++ = 0; +061 \} +062 \} +063 +064 /* remove excess digits */ +065 a->used -= b; +066 \} +067 #endif +068 +\end{alltt} +\end{small} + +The only noteworthy element of this routine is the lack of a return type since it cannot fail. Like mp\_lshd() we +form a sliding window except we copy in the other direction. After the window (line 59) we then zero +the upper digits of the input to make sure the result is correct. + +\section{Powers of Two} + +Now that algorithms for moving single bits as well as whole digits exist algorithms for moving the ``in between'' distances are required. For +example, to quickly multiply by $2^k$ for any $k$ without using a full multiplier algorithm would prove useful. Instead of performing single +shifts $k$ times to achieve a multiplication by $2^{\pm k}$ a mixture of whole digit shifting and partial digit shifting is employed. + +\subsection{Multiplication by Power of Two} + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_mul\_2d}. \\ +\textbf{Input}. One mp\_int $a$ and an integer $b$ \\ +\textbf{Output}. $c \leftarrow a \cdot 2^b$. \\ +\hline \\ +1. $c \leftarrow a$. (\textit{mp\_copy}) \\ +2. If $c.alloc < c.used + \lfloor b / lg(\beta) \rfloor + 2$ then grow $c$ accordingly. \\ +3. If the reallocation failed return(\textit{MP\_MEM}). \\ +4. If $b \ge lg(\beta)$ then \\ +\hspace{3mm}4.1 $c \leftarrow c \cdot \beta^{\lfloor b / lg(\beta) \rfloor}$ (\textit{mp\_lshd}). \\ +\hspace{3mm}4.2 If step 4.1 failed return(\textit{MP\_MEM}). \\ +5. $d \leftarrow b \mbox{ (mod }lg(\beta)\mbox{)}$ \\ +6. If $d \ne 0$ then do \\ +\hspace{3mm}6.1 $mask \leftarrow 2^d$ \\ +\hspace{3mm}6.2 $r \leftarrow 0$ \\ +\hspace{3mm}6.3 for $n$ from $0$ to $c.used - 1$ do \\ +\hspace{6mm}6.3.1 $rr \leftarrow c_n >> (lg(\beta) - d) \mbox{ (mod }mask\mbox{)}$ \\ +\hspace{6mm}6.3.2 $c_n \leftarrow (c_n << d) + r \mbox{ (mod }\beta\mbox{)}$ \\ +\hspace{6mm}6.3.3 $r \leftarrow rr$ \\ +\hspace{3mm}6.4 If $r > 0$ then do \\ +\hspace{6mm}6.4.1 $c_{c.used} \leftarrow r$ \\ +\hspace{6mm}6.4.2 $c.used \leftarrow c.used + 1$ \\ +7. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_mul\_2d} +\end{figure} + +\textbf{Algorithm mp\_mul\_2d.} +This algorithm multiplies $a$ by $2^b$ and stores the result in $c$. The algorithm uses algorithm mp\_lshd and a derivative of algorithm mp\_mul\_2 to +quickly compute the product. + +First the algorithm will multiply $a$ by $x^{\lfloor b / lg(\beta) \rfloor}$ which will ensure that the remainder multiplicand is less than +$\beta$. For example, if $b = 37$ and $\beta = 2^{28}$ then this step will multiply by $x$ leaving a multiplication by $2^{37 - 28} = 2^{9}$ +left. + +After the digits have been shifted appropriately at most $lg(\beta) - 1$ shifts are left to perform. Step 5 calculates the number of remaining shifts +required. If it is non-zero a modified shift loop is used to calculate the remaining product. +Essentially the loop is a generic version of algorith mp\_mul2 designed to handle any shift count in the range $1 \le x < lg(\beta)$. The $mask$ +variable is used to extract the upper $d$ bits to form the carry for the next iteration. + +This algorithm is loosely measured as a $O(2n)$ algorithm which means that if the input is $n$-digits that it takes $2n$ ``time'' to +complete. It is possible to optimize this algorithm down to a $O(n)$ algorithm at a cost of making the algorithm slightly harder to follow. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_mul\_2d.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* shift left by a certain bit count */ +018 int mp_mul_2d (mp_int * a, int b, mp_int * c) +019 \{ +020 mp_digit d; +021 int res; +022 +023 /* copy */ +024 if (a != c) \{ +025 if ((res = mp_copy (a, c)) != MP_OKAY) \{ +026 return res; +027 \} +028 \} +029 +030 if (c->alloc < (int)(c->used + b/DIGIT_BIT + 1)) \{ +031 if ((res = mp_grow (c, c->used + b / DIGIT_BIT + 1)) != MP_OKAY) \{ +032 return res; +033 \} +034 \} +035 +036 /* shift by as many digits in the bit count */ +037 if (b >= (int)DIGIT_BIT) \{ +038 if ((res = mp_lshd (c, b / DIGIT_BIT)) != MP_OKAY) \{ +039 return res; +040 \} +041 \} +042 +043 /* shift any bit count < DIGIT_BIT */ +044 d = (mp_digit) (b % DIGIT_BIT); +045 if (d != 0) \{ +046 register mp_digit *tmpc, shift, mask, r, rr; +047 register int x; +048 +049 /* bitmask for carries */ +050 mask = (((mp_digit)1) << d) - 1; +051 +052 /* shift for msbs */ +053 shift = DIGIT_BIT - d; +054 +055 /* alias */ +056 tmpc = c->dp; +057 +058 /* carry */ +059 r = 0; +060 for (x = 0; x < c->used; x++) \{ +061 /* get the higher bits of the current word */ +062 rr = (*tmpc >> shift) & mask; +063 +064 /* shift the current word and OR in the carry */ +065 *tmpc = ((*tmpc << d) | r) & MP_MASK; +066 ++tmpc; +067 +068 /* set the carry to the carry bits of the current word */ +069 r = rr; +070 \} +071 +072 /* set final carry */ +073 if (r != 0) \{ +074 c->dp[(c->used)++] = r; +075 \} +076 \} +077 mp_clamp (c); +078 return MP_OKAY; +079 \} +080 #endif +081 +\end{alltt} +\end{small} + +The shifting is performed in--place which means the first step (line 24) is to copy the input to the +destination. We avoid calling mp\_copy() by making sure the mp\_ints are different. The destination then +has to be grown (line 31) to accomodate the result. + +If the shift count $b$ is larger than $lg(\beta)$ then a call to mp\_lshd() is used to handle all of the multiples +of $lg(\beta)$. Leaving only a remaining shift of $lg(\beta) - 1$ or fewer bits left. Inside the actual shift +loop (lines 45 to 76) we make use of pre--computed values $shift$ and $mask$. These are used to +extract the carry bit(s) to pass into the next iteration of the loop. The $r$ and $rr$ variables form a +chain between consecutive iterations to propagate the carry. + +\subsection{Division by Power of Two} + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_div\_2d}. \\ +\textbf{Input}. One mp\_int $a$ and an integer $b$ \\ +\textbf{Output}. $c \leftarrow \lfloor a / 2^b \rfloor, d \leftarrow a \mbox{ (mod }2^b\mbox{)}$. \\ +\hline \\ +1. If $b \le 0$ then do \\ +\hspace{3mm}1.1 $c \leftarrow a$ (\textit{mp\_copy}) \\ +\hspace{3mm}1.2 $d \leftarrow 0$ (\textit{mp\_zero}) \\ +\hspace{3mm}1.3 Return(\textit{MP\_OKAY}). \\ +2. $c \leftarrow a$ \\ +3. $d \leftarrow a \mbox{ (mod }2^b\mbox{)}$ (\textit{mp\_mod\_2d}) \\ +4. If $b \ge lg(\beta)$ then do \\ +\hspace{3mm}4.1 $c \leftarrow \lfloor c/\beta^{\lfloor b/lg(\beta) \rfloor} \rfloor$ (\textit{mp\_rshd}). \\ +5. $k \leftarrow b \mbox{ (mod }lg(\beta)\mbox{)}$ \\ +6. If $k \ne 0$ then do \\ +\hspace{3mm}6.1 $mask \leftarrow 2^k$ \\ +\hspace{3mm}6.2 $r \leftarrow 0$ \\ +\hspace{3mm}6.3 for $n$ from $c.used - 1$ to $0$ do \\ +\hspace{6mm}6.3.1 $rr \leftarrow c_n \mbox{ (mod }mask\mbox{)}$ \\ +\hspace{6mm}6.3.2 $c_n \leftarrow (c_n >> k) + (r << (lg(\beta) - k))$ \\ +\hspace{6mm}6.3.3 $r \leftarrow rr$ \\ +7. Clamp excess digits of $c$. (\textit{mp\_clamp}) \\ +8. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_div\_2d} +\end{figure} + +\textbf{Algorithm mp\_div\_2d.} +This algorithm will divide an input $a$ by $2^b$ and produce the quotient and remainder. The algorithm is designed much like algorithm +mp\_mul\_2d by first using whole digit shifts then single precision shifts. This algorithm will also produce the remainder of the division +by using algorithm mp\_mod\_2d. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_div\_2d.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* shift right by a certain bit count (store quotient in c, optional remaind + er in d) */ +018 int mp_div_2d (mp_int * a, int b, mp_int * c, mp_int * d) +019 \{ +020 mp_digit D, r, rr; +021 int x, res; +022 mp_int t; +023 +024 +025 /* if the shift count is <= 0 then we do no work */ +026 if (b <= 0) \{ +027 res = mp_copy (a, c); +028 if (d != NULL) \{ +029 mp_zero (d); +030 \} +031 return res; +032 \} +033 +034 if ((res = mp_init (&t)) != MP_OKAY) \{ +035 return res; +036 \} +037 +038 /* get the remainder */ +039 if (d != NULL) \{ +040 if ((res = mp_mod_2d (a, b, &t)) != MP_OKAY) \{ +041 mp_clear (&t); +042 return res; +043 \} +044 \} +045 +046 /* copy */ +047 if ((res = mp_copy (a, c)) != MP_OKAY) \{ +048 mp_clear (&t); +049 return res; +050 \} +051 +052 /* shift by as many digits in the bit count */ +053 if (b >= (int)DIGIT_BIT) \{ +054 mp_rshd (c, b / DIGIT_BIT); +055 \} +056 +057 /* shift any bit count < DIGIT_BIT */ +058 D = (mp_digit) (b % DIGIT_BIT); +059 if (D != 0) \{ +060 register mp_digit *tmpc, mask, shift; +061 +062 /* mask */ +063 mask = (((mp_digit)1) << D) - 1; +064 +065 /* shift for lsb */ +066 shift = DIGIT_BIT - D; +067 +068 /* alias */ +069 tmpc = c->dp + (c->used - 1); +070 +071 /* carry */ +072 r = 0; +073 for (x = c->used - 1; x >= 0; x--) \{ +074 /* get the lower bits of this word in a temp */ +075 rr = *tmpc & mask; +076 +077 /* shift the current word and mix in the carry bits from the previous + word */ +078 *tmpc = (*tmpc >> D) | (r << shift); +079 --tmpc; +080 +081 /* set the carry to the carry bits of the current word found above */ +082 r = rr; +083 \} +084 \} +085 mp_clamp (c); +086 if (d != NULL) \{ +087 mp_exch (&t, d); +088 \} +089 mp_clear (&t); +090 return MP_OKAY; +091 \} +092 #endif +093 +\end{alltt} +\end{small} + +The implementation of algorithm mp\_div\_2d is slightly different than the algorithm specifies. The remainder $d$ may be optionally +ignored by passing \textbf{NULL} as the pointer to the mp\_int variable. The temporary mp\_int variable $t$ is used to hold the +result of the remainder operation until the end. This allows $d$ and $a$ to represent the same mp\_int without modifying $a$ before +the quotient is obtained. + +The remainder of the source code is essentially the same as the source code for mp\_mul\_2d. The only significant difference is +the direction of the shifts. + +\subsection{Remainder of Division by Power of Two} + +The last algorithm in the series of polynomial basis power of two algorithms is calculating the remainder of division by $2^b$. This +algorithm benefits from the fact that in twos complement arithmetic $a \mbox{ (mod }2^b\mbox{)}$ is the same as $a$ AND $2^b - 1$. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_mod\_2d}. \\ +\textbf{Input}. One mp\_int $a$ and an integer $b$ \\ +\textbf{Output}. $c \leftarrow a \mbox{ (mod }2^b\mbox{)}$. \\ +\hline \\ +1. If $b \le 0$ then do \\ +\hspace{3mm}1.1 $c \leftarrow 0$ (\textit{mp\_zero}) \\ +\hspace{3mm}1.2 Return(\textit{MP\_OKAY}). \\ +2. If $b > a.used \cdot lg(\beta)$ then do \\ +\hspace{3mm}2.1 $c \leftarrow a$ (\textit{mp\_copy}) \\ +\hspace{3mm}2.2 Return the result of step 2.1. \\ +3. $c \leftarrow a$ \\ +4. If step 3 failed return(\textit{MP\_MEM}). \\ +5. for $n$ from $\lceil b / lg(\beta) \rceil$ to $c.used$ do \\ +\hspace{3mm}5.1 $c_n \leftarrow 0$ \\ +6. $k \leftarrow b \mbox{ (mod }lg(\beta)\mbox{)}$ \\ +7. $c_{\lfloor b / lg(\beta) \rfloor} \leftarrow c_{\lfloor b / lg(\beta) \rfloor} \mbox{ (mod }2^{k}\mbox{)}$. \\ +8. Clamp excess digits of $c$. (\textit{mp\_clamp}) \\ +9. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_mod\_2d} +\end{figure} + +\textbf{Algorithm mp\_mod\_2d.} +This algorithm will quickly calculate the value of $a \mbox{ (mod }2^b\mbox{)}$. First if $b$ is less than or equal to zero the +result is set to zero. If $b$ is greater than the number of bits in $a$ then it simply copies $a$ to $c$ and returns. Otherwise, $a$ +is copied to $b$, leading digits are removed and the remaining leading digit is trimed to the exact bit count. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_mod\_2d.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* calc a value mod 2**b */ +018 int +019 mp_mod_2d (mp_int * a, int b, mp_int * c) +020 \{ +021 int x, res; +022 +023 /* if b is <= 0 then zero the int */ +024 if (b <= 0) \{ +025 mp_zero (c); +026 return MP_OKAY; +027 \} +028 +029 /* if the modulus is larger than the value than return */ +030 if (b >= (int) (a->used * DIGIT_BIT)) \{ +031 res = mp_copy (a, c); +032 return res; +033 \} +034 +035 /* copy */ +036 if ((res = mp_copy (a, c)) != MP_OKAY) \{ +037 return res; +038 \} +039 +040 /* zero digits above the last digit of the modulus */ +041 for (x = (b / DIGIT_BIT) + ((b % DIGIT_BIT) == 0 ? 0 : 1); x < c->used; x+ + +) \{ +042 c->dp[x] = 0; +043 \} +044 /* clear the digit that is not completely outside/inside the modulus */ +045 c->dp[b / DIGIT_BIT] &= +046 (mp_digit) ((((mp_digit) 1) << (((mp_digit) b) % DIGIT_BIT)) - ((mp_digi + t) 1)); +047 mp_clamp (c); +048 return MP_OKAY; +049 \} +050 #endif +051 +\end{alltt} +\end{small} + +We first avoid cases of $b \le 0$ by simply mp\_zero()'ing the destination in such cases. Next if $2^b$ is larger +than the input we just mp\_copy() the input and return right away. After this point we know we must actually +perform some work to produce the remainder. + +Recalling that reducing modulo $2^k$ and a binary ``and'' with $2^k - 1$ are numerically equivalent we can quickly reduce +the number. First we zero any digits above the last digit in $2^b$ (line 41). Next we reduce the +leading digit of both (line 45) and then mp\_clamp(). + +\section*{Exercises} +\begin{tabular}{cl} +$\left [ 3 \right ] $ & Devise an algorithm that performs $a \cdot 2^b$ for generic values of $b$ \\ + & in $O(n)$ time. \\ + &\\ +$\left [ 3 \right ] $ & Devise an efficient algorithm to multiply by small low hamming \\ + & weight values such as $3$, $5$ and $9$. Extend it to handle all values \\ + & upto $64$ with a hamming weight less than three. \\ + &\\ +$\left [ 2 \right ] $ & Modify the preceding algorithm to handle values of the form \\ + & $2^k - 1$ as well. \\ + &\\ +$\left [ 3 \right ] $ & Using only algorithms mp\_mul\_2, mp\_div\_2 and mp\_add create an \\ + & algorithm to multiply two integers in roughly $O(2n^2)$ time for \\ + & any $n$-bit input. Note that the time of addition is ignored in the \\ + & calculation. \\ + & \\ +$\left [ 5 \right ] $ & Improve the previous algorithm to have a working time of at most \\ + & $O \left (2^{(k-1)}n + \left ({2n^2 \over k} \right ) \right )$ for an appropriate choice of $k$. Again ignore \\ + & the cost of addition. \\ + & \\ +$\left [ 2 \right ] $ & Devise a chart to find optimal values of $k$ for the previous problem \\ + & for $n = 64 \ldots 1024$ in steps of $64$. \\ + & \\ +$\left [ 2 \right ] $ & Using only algorithms mp\_abs and mp\_sub devise another method for \\ + & calculating the result of a signed comparison. \\ + & +\end{tabular} + +\chapter{Multiplication and Squaring} +\section{The Multipliers} +For most number theoretic problems including certain public key cryptographic algorithms, the ``multipliers'' form the most important subset of +algorithms of any multiple precision integer package. The set of multiplier algorithms include integer multiplication, squaring and modular reduction +where in each of the algorithms single precision multiplication is the dominant operation performed. This chapter will discuss integer multiplication +and squaring, leaving modular reductions for the subsequent chapter. + +The importance of the multiplier algorithms is for the most part driven by the fact that certain popular public key algorithms are based on modular +exponentiation, that is computing $d \equiv a^b \mbox{ (mod }c\mbox{)}$ for some arbitrary choice of $a$, $b$, $c$ and $d$. During a modular +exponentiation the majority\footnote{Roughly speaking a modular exponentiation will spend about 40\% of the time performing modular reductions, +35\% of the time performing squaring and 25\% of the time performing multiplications.} of the processor time is spent performing single precision +multiplications. + +For centuries general purpose multiplication has required a lengthly $O(n^2)$ process, whereby each digit of one multiplicand has to be multiplied +against every digit of the other multiplicand. Traditional long-hand multiplication is based on this process; while the techniques can differ the +overall algorithm used is essentially the same. Only ``recently'' have faster algorithms been studied. First Karatsuba multiplication was discovered in +1962. This algorithm can multiply two numbers with considerably fewer single precision multiplications when compared to the long-hand approach. +This technique led to the discovery of polynomial basis algorithms (\textit{good reference?}) and subquently Fourier Transform based solutions. + +\section{Multiplication} +\subsection{The Baseline Multiplication} +\label{sec:basemult} +\index{baseline multiplication} +Computing the product of two integers in software can be achieved using a trivial adaptation of the standard $O(n^2)$ long-hand multiplication +algorithm that school children are taught. The algorithm is considered an $O(n^2)$ algorithm since for two $n$-digit inputs $n^2$ single precision +multiplications are required. More specifically for a $m$ and $n$ digit input $m \cdot n$ single precision multiplications are required. To +simplify most discussions, it will be assumed that the inputs have comparable number of digits. + +The ``baseline multiplication'' algorithm is designed to act as the ``catch-all'' algorithm, only to be used when the faster algorithms cannot be +used. This algorithm does not use any particularly interesting optimizations and should ideally be avoided if possible. One important +facet of this algorithm, is that it has been modified to only produce a certain amount of output digits as resolution. The importance of this +modification will become evident during the discussion of Barrett modular reduction. Recall that for a $n$ and $m$ digit input the product +will be at most $n + m$ digits. Therefore, this algorithm can be reduced to a full multiplier by having it produce $n + m$ digits of the product. + +Recall from sub-section 4.2.2 the definition of $\gamma$ as the number of bits in the type \textbf{mp\_digit}. We shall now extend the variable set to +include $\alpha$ which shall represent the number of bits in the type \textbf{mp\_word}. This implies that $2^{\alpha} > 2 \cdot \beta^2$. The +constant $\delta = 2^{\alpha - 2lg(\beta)}$ will represent the maximal weight of any column in a product (\textit{see sub-section 5.2.2 for more information}). + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{s\_mp\_mul\_digs}. \\ +\textbf{Input}. mp\_int $a$, mp\_int $b$ and an integer $digs$ \\ +\textbf{Output}. $c \leftarrow \vert a \vert \cdot \vert b \vert \mbox{ (mod }\beta^{digs}\mbox{)}$. \\ +\hline \\ +1. If min$(a.used, b.used) < \delta$ then do \\ +\hspace{3mm}1.1 Calculate $c = \vert a \vert \cdot \vert b \vert$ by the Comba method (\textit{see algorithm~\ref{fig:COMBAMULT}}). \\ +\hspace{3mm}1.2 Return the result of step 1.1 \\ +\\ +Allocate and initialize a temporary mp\_int. \\ +2. Init $t$ to be of size $digs$ \\ +3. If step 2 failed return(\textit{MP\_MEM}). \\ +4. $t.used \leftarrow digs$ \\ +\\ +Compute the product. \\ +5. for $ix$ from $0$ to $a.used - 1$ do \\ +\hspace{3mm}5.1 $u \leftarrow 0$ \\ +\hspace{3mm}5.2 $pb \leftarrow \mbox{min}(b.used, digs - ix)$ \\ +\hspace{3mm}5.3 If $pb < 1$ then goto step 6. \\ +\hspace{3mm}5.4 for $iy$ from $0$ to $pb - 1$ do \\ +\hspace{6mm}5.4.1 $\hat r \leftarrow t_{iy + ix} + a_{ix} \cdot b_{iy} + u$ \\ +\hspace{6mm}5.4.2 $t_{iy + ix} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\ +\hspace{6mm}5.4.3 $u \leftarrow \lfloor \hat r / \beta \rfloor$ \\ +\hspace{3mm}5.5 if $ix + pb < digs$ then do \\ +\hspace{6mm}5.5.1 $t_{ix + pb} \leftarrow u$ \\ +6. Clamp excess digits of $t$. \\ +7. Swap $c$ with $t$ \\ +8. Clear $t$ \\ +9. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm s\_mp\_mul\_digs} +\end{figure} + +\textbf{Algorithm s\_mp\_mul\_digs.} +This algorithm computes the unsigned product of two inputs $a$ and $b$, limited to an output precision of $digs$ digits. While it may seem +a bit awkward to modify the function from its simple $O(n^2)$ description, the usefulness of partial multipliers will arise in a subsequent +algorithm. The algorithm is loosely based on algorithm 14.12 from \cite[pp. 595]{HAC} and is similar to Algorithm M of Knuth \cite[pp. 268]{TAOCPV2}. +Algorithm s\_mp\_mul\_digs differs from these cited references since it can produce a variable output precision regardless of the precision of the +inputs. + +The first thing this algorithm checks for is whether a Comba multiplier can be used instead. If the minimum digit count of either +input is less than $\delta$, then the Comba method may be used instead. After the Comba method is ruled out, the baseline algorithm begins. A +temporary mp\_int variable $t$ is used to hold the intermediate result of the product. This allows the algorithm to be used to +compute products when either $a = c$ or $b = c$ without overwriting the inputs. + +All of step 5 is the infamous $O(n^2)$ multiplication loop slightly modified to only produce upto $digs$ digits of output. The $pb$ variable +is given the count of digits to read from $b$ inside the nested loop. If $pb \le 1$ then no more output digits can be produced and the algorithm +will exit the loop. The best way to think of the loops are as a series of $pb \times 1$ multiplications. That is, in each pass of the +innermost loop $a_{ix}$ is multiplied against $b$ and the result is added (\textit{with an appropriate shift}) to $t$. + +For example, consider multiplying $576$ by $241$. That is equivalent to computing $10^0(1)(576) + 10^1(4)(576) + 10^2(2)(576)$ which is best +visualized in the following table. + +\begin{figure}[here] +\begin{center} +\begin{tabular}{|c|c|c|c|c|c|l|} +\hline && & 5 & 7 & 6 & \\ +\hline $\times$&& & 2 & 4 & 1 & \\ +\hline &&&&&&\\ + && & 5 & 7 & 6 & $10^0(1)(576)$ \\ + &2 & 3 & 6 & 1 & 6 & $10^1(4)(576) + 10^0(1)(576)$ \\ + 1 & 3 & 8 & 8 & 1 & 6 & $10^2(2)(576) + 10^1(4)(576) + 10^0(1)(576)$ \\ +\hline +\end{tabular} +\end{center} +\caption{Long-Hand Multiplication Diagram} +\end{figure} + +Each row of the product is added to the result after being shifted to the left (\textit{multiplied by a power of the radix}) by the appropriate +count. That is in pass $ix$ of the inner loop the product is added starting at the $ix$'th digit of the reult. + +Step 5.4.1 introduces the hat symbol (\textit{e.g. $\hat r$}) which represents a double precision variable. The multiplication on that step +is assumed to be a double wide output single precision multiplication. That is, two single precision variables are multiplied to produce a +double precision result. The step is somewhat optimized from a long-hand multiplication algorithm because the carry from the addition in step +5.4.1 is propagated through the nested loop. If the carry was not propagated immediately it would overflow the single precision digit +$t_{ix+iy}$ and the result would be lost. + +At step 5.5 the nested loop is finished and any carry that was left over should be forwarded. The carry does not have to be added to the $ix+pb$'th +digit since that digit is assumed to be zero at this point. However, if $ix + pb \ge digs$ the carry is not set as it would make the result +exceed the precision requested. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_s\_mp\_mul\_digs.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* multiplies |a| * |b| and only computes upto digs digits of result +018 * HAC pp. 595, Algorithm 14.12 Modified so you can control how +019 * many digits of output are created. +020 */ +021 int s_mp_mul_digs (mp_int * a, mp_int * b, mp_int * c, int digs) +022 \{ +023 mp_int t; +024 int res, pa, pb, ix, iy; +025 mp_digit u; +026 mp_word r; +027 mp_digit tmpx, *tmpt, *tmpy; +028 +029 /* can we use the fast multiplier? */ +030 if (((digs) < MP_WARRAY) && +031 MIN (a->used, b->used) < +032 (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) \{ +033 return fast_s_mp_mul_digs (a, b, c, digs); +034 \} +035 +036 if ((res = mp_init_size (&t, digs)) != MP_OKAY) \{ +037 return res; +038 \} +039 t.used = digs; +040 +041 /* compute the digits of the product directly */ +042 pa = a->used; +043 for (ix = 0; ix < pa; ix++) \{ +044 /* set the carry to zero */ +045 u = 0; +046 +047 /* limit ourselves to making digs digits of output */ +048 pb = MIN (b->used, digs - ix); +049 +050 /* setup some aliases */ +051 /* copy of the digit from a used within the nested loop */ +052 tmpx = a->dp[ix]; +053 +054 /* an alias for the destination shifted ix places */ +055 tmpt = t.dp + ix; +056 +057 /* an alias for the digits of b */ +058 tmpy = b->dp; +059 +060 /* compute the columns of the output and propagate the carry */ +061 for (iy = 0; iy < pb; iy++) \{ +062 /* compute the column as a mp_word */ +063 r = ((mp_word)*tmpt) + +064 ((mp_word)tmpx) * ((mp_word)*tmpy++) + +065 ((mp_word) u); +066 +067 /* the new column is the lower part of the result */ +068 *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK)); +069 +070 /* get the carry word from the result */ +071 u = (mp_digit) (r >> ((mp_word) DIGIT_BIT)); +072 \} +073 /* set carry if it is placed below digs */ +074 if (ix + iy < digs) \{ +075 *tmpt = u; +076 \} +077 \} +078 +079 mp_clamp (&t); +080 mp_exch (&t, c); +081 +082 mp_clear (&t); +083 return MP_OKAY; +084 \} +085 #endif +086 +\end{alltt} +\end{small} + +First we determine (line 30) if the Comba method can be used first since it's faster. The conditions for +sing the Comba routine are that min$(a.used, b.used) < \delta$ and the number of digits of output is less than +\textbf{MP\_WARRAY}. This new constant is used to control the stack usage in the Comba routines. By default it is +set to $\delta$ but can be reduced when memory is at a premium. + +If we cannot use the Comba method we proceed to setup the baseline routine. We allocate the the destination mp\_int +$t$ (line 36) to the exact size of the output to avoid further re--allocations. At this point we now +begin the $O(n^2)$ loop. + +This implementation of multiplication has the caveat that it can be trimmed to only produce a variable number of +digits as output. In each iteration of the outer loop the $pb$ variable is set (line 48) to the maximum +number of inner loop iterations. + +Inside the inner loop we calculate $\hat r$ as the mp\_word product of the two mp\_digits and the addition of the +carry from the previous iteration. A particularly important observation is that most modern optimizing +C compilers (GCC for instance) can recognize that a $N \times N \rightarrow 2N$ multiplication is all that +is required for the product. In x86 terms for example, this means using the MUL instruction. + +Each digit of the product is stored in turn (line 68) and the carry propagated (line 71) to the +next iteration. + +\subsection{Faster Multiplication by the ``Comba'' Method} + +One of the huge drawbacks of the ``baseline'' algorithms is that at the $O(n^2)$ level the carry must be +computed and propagated upwards. This makes the nested loop very sequential and hard to unroll and implement +in parallel. The ``Comba'' \cite{COMBA} method is named after little known (\textit{in cryptographic venues}) Paul G. +Comba who described a method of implementing fast multipliers that do not require nested carry fixup operations. As an +interesting aside it seems that Paul Barrett describes a similar technique in his 1986 paper \cite{BARRETT} written +five years before. + +At the heart of the Comba technique is once again the long-hand algorithm. Except in this case a slight +twist is placed on how the columns of the result are produced. In the standard long-hand algorithm rows of products +are produced then added together to form the final result. In the baseline algorithm the columns are added together +after each iteration to get the result instantaneously. + +In the Comba algorithm the columns of the result are produced entirely independently of each other. That is at +the $O(n^2)$ level a simple multiplication and addition step is performed. The carries of the columns are propagated +after the nested loop to reduce the amount of work requiored. Succintly the first step of the algorithm is to compute +the product vector $\vec x$ as follows. + +\begin{equation} +\vec x_n = \sum_{i+j = n} a_ib_j, \forall n \in \lbrace 0, 1, 2, \ldots, i + j \rbrace +\end{equation} + +Where $\vec x_n$ is the $n'th$ column of the output vector. Consider the following example which computes the vector $\vec x$ for the multiplication +of $576$ and $241$. + +\newpage\begin{figure}[here] +\begin{small} +\begin{center} +\begin{tabular}{|c|c|c|c|c|c|} + \hline & & 5 & 7 & 6 & First Input\\ + \hline $\times$ & & 2 & 4 & 1 & Second Input\\ +\hline & & $1 \cdot 5 = 5$ & $1 \cdot 7 = 7$ & $1 \cdot 6 = 6$ & First pass \\ + & $4 \cdot 5 = 20$ & $4 \cdot 7+5=33$ & $4 \cdot 6+7=31$ & 6 & Second pass \\ + $2 \cdot 5 = 10$ & $2 \cdot 7 + 20 = 34$ & $2 \cdot 6+33=45$ & 31 & 6 & Third pass \\ +\hline 10 & 34 & 45 & 31 & 6 & Final Result \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Comba Multiplication Diagram} +\end{figure} + +At this point the vector $x = \left < 10, 34, 45, 31, 6 \right >$ is the result of the first step of the Comba multipler. +Now the columns must be fixed by propagating the carry upwards. The resultant vector will have one extra dimension over the input vector which is +congruent to adding a leading zero digit. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{Comba Fixup}. \\ +\textbf{Input}. Vector $\vec x$ of dimension $k$ \\ +\textbf{Output}. Vector $\vec x$ such that the carries have been propagated. \\ +\hline \\ +1. for $n$ from $0$ to $k - 1$ do \\ +\hspace{3mm}1.1 $\vec x_{n+1} \leftarrow \vec x_{n+1} + \lfloor \vec x_{n}/\beta \rfloor$ \\ +\hspace{3mm}1.2 $\vec x_{n} \leftarrow \vec x_{n} \mbox{ (mod }\beta\mbox{)}$ \\ +2. Return($\vec x$). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm Comba Fixup} +\end{figure} + +With that algorithm and $k = 5$ and $\beta = 10$ the following vector is produced $\vec x= \left < 1, 3, 8, 8, 1, 6 \right >$. In this case +$241 \cdot 576$ is in fact $138816$ and the procedure succeeded. If the algorithm is correct and as will be demonstrated shortly more +efficient than the baseline algorithm why not simply always use this algorithm? + +\subsubsection{Column Weight.} +At the nested $O(n^2)$ level the Comba method adds the product of two single precision variables to each column of the output +independently. A serious obstacle is if the carry is lost, due to lack of precision before the algorithm has a chance to fix +the carries. For example, in the multiplication of two three-digit numbers the third column of output will be the sum of +three single precision multiplications. If the precision of the accumulator for the output digits is less then $3 \cdot (\beta - 1)^2$ then +an overflow can occur and the carry information will be lost. For any $m$ and $n$ digit inputs the maximum weight of any column is +min$(m, n)$ which is fairly obvious. + +The maximum number of terms in any column of a product is known as the ``column weight'' and strictly governs when the algorithm can be used. Recall +from earlier that a double precision type has $\alpha$ bits of resolution and a single precision digit has $lg(\beta)$ bits of precision. Given these +two quantities we must not violate the following + +\begin{equation} +k \cdot \left (\beta - 1 \right )^2 < 2^{\alpha} +\end{equation} + +Which reduces to + +\begin{equation} +k \cdot \left ( \beta^2 - 2\beta + 1 \right ) < 2^{\alpha} +\end{equation} + +Let $\rho = lg(\beta)$ represent the number of bits in a single precision digit. By further re-arrangement of the equation the final solution is +found. + +\begin{equation} +k < {{2^{\alpha}} \over {\left (2^{2\rho} - 2^{\rho + 1} + 1 \right )}} +\end{equation} + +The defaults for LibTomMath are $\beta = 2^{28}$ and $\alpha = 2^{64}$ which means that $k$ is bounded by $k < 257$. In this configuration +the smaller input may not have more than $256$ digits if the Comba method is to be used. This is quite satisfactory for most applications since +$256$ digits would allow for numbers in the range of $0 \le x < 2^{7168}$ which, is much larger than most public key cryptographic algorithms require. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{fast\_s\_mp\_mul\_digs}. \\ +\textbf{Input}. mp\_int $a$, mp\_int $b$ and an integer $digs$ \\ +\textbf{Output}. $c \leftarrow \vert a \vert \cdot \vert b \vert \mbox{ (mod }\beta^{digs}\mbox{)}$. \\ +\hline \\ +Place an array of \textbf{MP\_WARRAY} single precision digits named $W$ on the stack. \\ +1. If $c.alloc < digs$ then grow $c$ to $digs$ digits. (\textit{mp\_grow}) \\ +2. If step 1 failed return(\textit{MP\_MEM}).\\ +\\ +3. $pa \leftarrow \mbox{MIN}(digs, a.used + b.used)$ \\ +\\ +4. $\_ \hat W \leftarrow 0$ \\ +5. for $ix$ from 0 to $pa - 1$ do \\ +\hspace{3mm}5.1 $ty \leftarrow \mbox{MIN}(b.used - 1, ix)$ \\ +\hspace{3mm}5.2 $tx \leftarrow ix - ty$ \\ +\hspace{3mm}5.3 $iy \leftarrow \mbox{MIN}(a.used - tx, ty + 1)$ \\ +\hspace{3mm}5.4 for $iz$ from 0 to $iy - 1$ do \\ +\hspace{6mm}5.4.1 $\_ \hat W \leftarrow \_ \hat W + a_{tx+iy}b_{ty-iy}$ \\ +\hspace{3mm}5.5 $W_{ix} \leftarrow \_ \hat W (\mbox{mod }\beta)$\\ +\hspace{3mm}5.6 $\_ \hat W \leftarrow \lfloor \_ \hat W / \beta \rfloor$ \\ +6. $W_{pa} \leftarrow \_ \hat W (\mbox{mod }\beta)$ \\ +\\ +7. $oldused \leftarrow c.used$ \\ +8. $c.used \leftarrow digs$ \\ +9. for $ix$ from $0$ to $pa$ do \\ +\hspace{3mm}9.1 $c_{ix} \leftarrow W_{ix}$ \\ +10. for $ix$ from $pa + 1$ to $oldused - 1$ do \\ +\hspace{3mm}10.1 $c_{ix} \leftarrow 0$ \\ +\\ +11. Clamp $c$. \\ +12. Return MP\_OKAY. \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm fast\_s\_mp\_mul\_digs} +\label{fig:COMBAMULT} +\end{figure} + +\textbf{Algorithm fast\_s\_mp\_mul\_digs.} +This algorithm performs the unsigned multiplication of $a$ and $b$ using the Comba method limited to $digs$ digits of precision. + +The outer loop of this algorithm is more complicated than that of the baseline multiplier. This is because on the inside of the +loop we want to produce one column per pass. This allows the accumulator $\_ \hat W$ to be placed in CPU registers and +reduce the memory bandwidth to two \textbf{mp\_digit} reads per iteration. + +The $ty$ variable is set to the minimum count of $ix$ or the number of digits in $b$. That way if $a$ has more digits than +$b$ this will be limited to $b.used - 1$. The $tx$ variable is set to the to the distance past $b.used$ the variable +$ix$ is. This is used for the immediately subsequent statement where we find $iy$. + +The variable $iy$ is the minimum digits we can read from either $a$ or $b$ before running out. Computing one column at a time +means we have to scan one integer upwards and the other downwards. $a$ starts at $tx$ and $b$ starts at $ty$. In each +pass we are producing the $ix$'th output column and we note that $tx + ty = ix$. As we move $tx$ upwards we have to +move $ty$ downards so the equality remains valid. The $iy$ variable is the number of iterations until +$tx \ge a.used$ or $ty < 0$ occurs. + +After every inner pass we store the lower half of the accumulator into $W_{ix}$ and then propagate the carry of the accumulator +into the next round by dividing $\_ \hat W$ by $\beta$. + +To measure the benefits of the Comba method over the baseline method consider the number of operations that are required. If the +cost in terms of time of a multiply and addition is $p$ and the cost of a carry propagation is $q$ then a baseline multiplication would require +$O \left ((p + q)n^2 \right )$ time to multiply two $n$-digit numbers. The Comba method requires only $O(pn^2 + qn)$ time, however in practice, +the speed increase is actually much more. With $O(n)$ space the algorithm can be reduced to $O(pn + qn)$ time by implementing the $n$ multiply +and addition operations in the nested loop in parallel. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_fast\_s\_mp\_mul\_digs.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* Fast (comba) multiplier +018 * +019 * This is the fast column-array [comba] multiplier. It is +020 * designed to compute the columns of the product first +021 * then handle the carries afterwards. This has the effect +022 * of making the nested loops that compute the columns very +023 * simple and schedulable on super-scalar processors. +024 * +025 * This has been modified to produce a variable number of +026 * digits of output so if say only a half-product is required +027 * you don't have to compute the upper half (a feature +028 * required for fast Barrett reduction). +029 * +030 * Based on Algorithm 14.12 on pp.595 of HAC. +031 * +032 */ +033 int fast_s_mp_mul_digs (mp_int * a, mp_int * b, mp_int * c, int digs) +034 \{ +035 int olduse, res, pa, ix, iz; +036 mp_digit W[MP_WARRAY]; +037 register mp_word _W; +038 +039 /* grow the destination as required */ +040 if (c->alloc < digs) \{ +041 if ((res = mp_grow (c, digs)) != MP_OKAY) \{ +042 return res; +043 \} +044 \} +045 +046 /* number of output digits to produce */ +047 pa = MIN(digs, a->used + b->used); +048 +049 /* clear the carry */ +050 _W = 0; +051 for (ix = 0; ix < pa; ix++) \{ +052 int tx, ty; +053 int iy; +054 mp_digit *tmpx, *tmpy; +055 +056 /* get offsets into the two bignums */ +057 ty = MIN(b->used-1, ix); +058 tx = ix - ty; +059 +060 /* setup temp aliases */ +061 tmpx = a->dp + tx; +062 tmpy = b->dp + ty; +063 +064 /* this is the number of times the loop will iterrate, essentially +065 while (tx++ < a->used && ty-- >= 0) \{ ... \} +066 */ +067 iy = MIN(a->used-tx, ty+1); +068 +069 /* execute loop */ +070 for (iz = 0; iz < iy; ++iz) \{ +071 _W += ((mp_word)*tmpx++)*((mp_word)*tmpy--); +072 +073 \} +074 +075 /* store term */ +076 W[ix] = ((mp_digit)_W) & MP_MASK; +077 +078 /* make next carry */ +079 _W = _W >> ((mp_word)DIGIT_BIT); +080 \} +081 +082 /* store final carry */ +083 W[ix] = (mp_digit)(_W & MP_MASK); +084 +085 /* setup dest */ +086 olduse = c->used; +087 c->used = pa; +088 +089 \{ +090 register mp_digit *tmpc; +091 tmpc = c->dp; +092 for (ix = 0; ix < pa+1; ix++) \{ +093 /* now extract the previous digit [below the carry] */ +094 *tmpc++ = W[ix]; +095 \} +096 +097 /* clear unused digits [that existed in the old copy of c] */ +098 for (; ix < olduse; ix++) \{ +099 *tmpc++ = 0; +100 \} +101 \} +102 mp_clamp (c); +103 return MP_OKAY; +104 \} +105 #endif +106 +\end{alltt} +\end{small} + +As per the pseudo--code we first calculate $pa$ (line 47) as the number of digits to output. Next we begin the outer loop +to produce the individual columns of the product. We use the two aliases $tmpx$ and $tmpy$ (lines 61, 62) to point +inside the two multiplicands quickly. + +The inner loop (lines 70 to 73) of this implementation is where the tradeoff come into play. Originally this comba +implementation was ``row--major'' which means it adds to each of the columns in each pass. After the outer loop it would then fix +the carries. This was very fast except it had an annoying drawback. You had to read a mp\_word and two mp\_digits and write +one mp\_word per iteration. On processors such as the Athlon XP and P4 this did not matter much since the cache bandwidth +is very high and it can keep the ALU fed with data. It did, however, matter on older and embedded cpus where cache is often +slower and also often doesn't exist. This new algorithm only performs two reads per iteration under the assumption that the +compiler has aliased $\_ \hat W$ to a CPU register. + +After the inner loop we store the current accumulator in $W$ and shift $\_ \hat W$ (lines 76, 79) to forward it as +a carry for the next pass. After the outer loop we use the final carry (line 83) as the last digit of the product. + +\subsection{Polynomial Basis Multiplication} +To break the $O(n^2)$ barrier in multiplication requires a completely different look at integer multiplication. In the following algorithms +the use of polynomial basis representation for two integers $a$ and $b$ as $f(x) = \sum_{i=0}^{n} a_i x^i$ and +$g(x) = \sum_{i=0}^{n} b_i x^i$ respectively, is required. In this system both $f(x)$ and $g(x)$ have $n + 1$ terms and are of the $n$'th degree. + +The product $a \cdot b \equiv f(x)g(x)$ is the polynomial $W(x) = \sum_{i=0}^{2n} w_i x^i$. The coefficients $w_i$ will +directly yield the desired product when $\beta$ is substituted for $x$. The direct solution to solve for the $2n + 1$ coefficients +requires $O(n^2)$ time and would in practice be slower than the Comba technique. + +However, numerical analysis theory indicates that only $2n + 1$ distinct points in $W(x)$ are required to determine the values of the $2n + 1$ unknown +coefficients. This means by finding $\zeta_y = W(y)$ for $2n + 1$ small values of $y$ the coefficients of $W(x)$ can be found with +Gaussian elimination. This technique is also occasionally refered to as the \textit{interpolation technique} (\textit{references please...}) since in +effect an interpolation based on $2n + 1$ points will yield a polynomial equivalent to $W(x)$. + +The coefficients of the polynomial $W(x)$ are unknown which makes finding $W(y)$ for any value of $y$ impossible. However, since +$W(x) = f(x)g(x)$ the equivalent $\zeta_y = f(y) g(y)$ can be used in its place. The benefit of this technique stems from the +fact that $f(y)$ and $g(y)$ are much smaller than either $a$ or $b$ respectively. As a result finding the $2n + 1$ relations required +by multiplying $f(y)g(y)$ involves multiplying integers that are much smaller than either of the inputs. + +When picking points to gather relations there are always three obvious points to choose, $y = 0, 1$ and $ \infty$. The $\zeta_0$ term +is simply the product $W(0) = w_0 = a_0 \cdot b_0$. The $\zeta_1$ term is the product +$W(1) = \left (\sum_{i = 0}^{n} a_i \right ) \left (\sum_{i = 0}^{n} b_i \right )$. The third point $\zeta_{\infty}$ is less obvious but rather +simple to explain. The $2n + 1$'th coefficient of $W(x)$ is numerically equivalent to the most significant column in an integer multiplication. +The point at $\infty$ is used symbolically to represent the most significant column, that is $W(\infty) = w_{2n} = a_nb_n$. Note that the +points at $y = 0$ and $\infty$ yield the coefficients $w_0$ and $w_{2n}$ directly. + +If more points are required they should be of small values and powers of two such as $2^q$ and the related \textit{mirror points} +$\left (2^q \right )^{2n} \cdot \zeta_{2^{-q}}$ for small values of $q$. The term ``mirror point'' stems from the fact that +$\left (2^q \right )^{2n} \cdot \zeta_{2^{-q}}$ can be calculated in the exact opposite fashion as $\zeta_{2^q}$. For +example, when $n = 2$ and $q = 1$ then following two equations are equivalent to the point $\zeta_{2}$ and its mirror. + +\begin{eqnarray} +\zeta_{2} = f(2)g(2) = (4a_2 + 2a_1 + a_0)(4b_2 + 2b_1 + b_0) \nonumber \\ +16 \cdot \zeta_{1 \over 2} = 4f({1\over 2}) \cdot 4g({1 \over 2}) = (a_2 + 2a_1 + 4a_0)(b_2 + 2b_1 + 4b_0) +\end{eqnarray} + +Using such points will allow the values of $f(y)$ and $g(y)$ to be independently calculated using only left shifts. For example, when $n = 2$ the +polynomial $f(2^q)$ is equal to $2^q((2^qa_2) + a_1) + a_0$. This technique of polynomial representation is known as Horner's method. + +As a general rule of the algorithm when the inputs are split into $n$ parts each there are $2n - 1$ multiplications. Each multiplication is of +multiplicands that have $n$ times fewer digits than the inputs. The asymptotic running time of this algorithm is +$O \left ( k^{lg_n(2n - 1)} \right )$ for $k$ digit inputs (\textit{assuming they have the same number of digits}). Figure~\ref{fig:exponent} +summarizes the exponents for various values of $n$. + +\begin{figure} +\begin{center} +\begin{tabular}{|c|c|c|} +\hline \textbf{Split into $n$ Parts} & \textbf{Exponent} & \textbf{Notes}\\ +\hline $2$ & $1.584962501$ & This is Karatsuba Multiplication. \\ +\hline $3$ & $1.464973520$ & This is Toom-Cook Multiplication. \\ +\hline $4$ & $1.403677461$ &\\ +\hline $5$ & $1.365212389$ &\\ +\hline $10$ & $1.278753601$ &\\ +\hline $100$ & $1.149426538$ &\\ +\hline $1000$ & $1.100270931$ &\\ +\hline $10000$ & $1.075252070$ &\\ +\hline +\end{tabular} +\end{center} +\caption{Asymptotic Running Time of Polynomial Basis Multiplication} +\label{fig:exponent} +\end{figure} + +At first it may seem like a good idea to choose $n = 1000$ since the exponent is approximately $1.1$. However, the overhead +of solving for the 2001 terms of $W(x)$ will certainly consume any savings the algorithm could offer for all but exceedingly large +numbers. + +\subsubsection{Cutoff Point} +The polynomial basis multiplication algorithms all require fewer single precision multiplications than a straight Comba approach. However, +the algorithms incur an overhead (\textit{at the $O(n)$ work level}) since they require a system of equations to be solved. This makes the +polynomial basis approach more costly to use with small inputs. + +Let $m$ represent the number of digits in the multiplicands (\textit{assume both multiplicands have the same number of digits}). There exists a +point $y$ such that when $m < y$ the polynomial basis algorithms are more costly than Comba, when $m = y$ they are roughly the same cost and +when $m > y$ the Comba methods are slower than the polynomial basis algorithms. + +The exact location of $y$ depends on several key architectural elements of the computer platform in question. + +\begin{enumerate} +\item The ratio of clock cycles for single precision multiplication versus other simpler operations such as addition, shifting, etc. For example +on the AMD Athlon the ratio is roughly $17 : 1$ while on the Intel P4 it is $29 : 1$. The higher the ratio in favour of multiplication the lower +the cutoff point $y$ will be. + +\item The complexity of the linear system of equations (\textit{for the coefficients of $W(x)$}) is. Generally speaking as the number of splits +grows the complexity grows substantially. Ideally solving the system will only involve addition, subtraction and shifting of integers. This +directly reflects on the ratio previous mentioned. + +\item To a lesser extent memory bandwidth and function call overheads. Provided the values are in the processor cache this is less of an +influence over the cutoff point. + +\end{enumerate} + +A clean cutoff point separation occurs when a point $y$ is found such that all of the cutoff point conditions are met. For example, if the point +is too low then there will be values of $m$ such that $m > y$ and the Comba method is still faster. Finding the cutoff points is fairly simple when +a high resolution timer is available. + +\subsection{Karatsuba Multiplication} +Karatsuba \cite{KARA} multiplication when originally proposed in 1962 was among the first set of algorithms to break the $O(n^2)$ barrier for +general purpose multiplication. Given two polynomial basis representations $f(x) = ax + b$ and $g(x) = cx + d$, Karatsuba proved with +light algebra \cite{KARAP} that the following polynomial is equivalent to multiplication of the two integers the polynomials represent. + +\begin{equation} +f(x) \cdot g(x) = acx^2 + ((a + b)(c + d) - (ac + bd))x + bd +\end{equation} + +Using the observation that $ac$ and $bd$ could be re-used only three half sized multiplications would be required to produce the product. Applying +this algorithm recursively, the work factor becomes $O(n^{lg(3)})$ which is substantially better than the work factor $O(n^2)$ of the Comba technique. It turns +out what Karatsuba did not know or at least did not publish was that this is simply polynomial basis multiplication with the points +$\zeta_0$, $\zeta_{\infty}$ and $\zeta_{1}$. Consider the resultant system of equations. + +\begin{center} +\begin{tabular}{rcrcrcrc} +$\zeta_{0}$ & $=$ & & & & & $w_0$ \\ +$\zeta_{1}$ & $=$ & $w_2$ & $+$ & $w_1$ & $+$ & $w_0$ \\ +$\zeta_{\infty}$ & $=$ & $w_2$ & & & & \\ +\end{tabular} +\end{center} + +By adding the first and last equation to the equation in the middle the term $w_1$ can be isolated and all three coefficients solved for. The simplicity +of this system of equations has made Karatsuba fairly popular. In fact the cutoff point is often fairly low\footnote{With LibTomMath 0.18 it is 70 and 109 digits for the Intel P4 and AMD Athlon respectively.} +making it an ideal algorithm to speed up certain public key cryptosystems such as RSA and Diffie-Hellman. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_karatsuba\_mul}. \\ +\textbf{Input}. mp\_int $a$ and mp\_int $b$ \\ +\textbf{Output}. $c \leftarrow \vert a \vert \cdot \vert b \vert$ \\ +\hline \\ +1. Init the following mp\_int variables: $x0$, $x1$, $y0$, $y1$, $t1$, $x0y0$, $x1y1$.\\ +2. If step 2 failed then return(\textit{MP\_MEM}). \\ +\\ +Split the input. e.g. $a = x1 \cdot \beta^B + x0$ \\ +3. $B \leftarrow \mbox{min}(a.used, b.used)/2$ \\ +4. $x0 \leftarrow a \mbox{ (mod }\beta^B\mbox{)}$ (\textit{mp\_mod\_2d}) \\ +5. $y0 \leftarrow b \mbox{ (mod }\beta^B\mbox{)}$ \\ +6. $x1 \leftarrow \lfloor a / \beta^B \rfloor$ (\textit{mp\_rshd}) \\ +7. $y1 \leftarrow \lfloor b / \beta^B \rfloor$ \\ +\\ +Calculate the three products. \\ +8. $x0y0 \leftarrow x0 \cdot y0$ (\textit{mp\_mul}) \\ +9. $x1y1 \leftarrow x1 \cdot y1$ \\ +10. $t1 \leftarrow x1 + x0$ (\textit{mp\_add}) \\ +11. $x0 \leftarrow y1 + y0$ \\ +12. $t1 \leftarrow t1 \cdot x0$ \\ +\\ +Calculate the middle term. \\ +13. $x0 \leftarrow x0y0 + x1y1$ \\ +14. $t1 \leftarrow t1 - x0$ (\textit{s\_mp\_sub}) \\ +\\ +Calculate the final product. \\ +15. $t1 \leftarrow t1 \cdot \beta^B$ (\textit{mp\_lshd}) \\ +16. $x1y1 \leftarrow x1y1 \cdot \beta^{2B}$ \\ +17. $t1 \leftarrow x0y0 + t1$ \\ +18. $c \leftarrow t1 + x1y1$ \\ +19. Clear all of the temporary variables. \\ +20. Return(\textit{MP\_OKAY}).\\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_karatsuba\_mul} +\end{figure} + +\textbf{Algorithm mp\_karatsuba\_mul.} +This algorithm computes the unsigned product of two inputs using the Karatsuba multiplication algorithm. It is loosely based on the description +from Knuth \cite[pp. 294-295]{TAOCPV2}. + +\index{radix point} +In order to split the two inputs into their respective halves, a suitable \textit{radix point} must be chosen. The radix point chosen must +be used for both of the inputs meaning that it must be smaller than the smallest input. Step 3 chooses the radix point $B$ as half of the +smallest input \textbf{used} count. After the radix point is chosen the inputs are split into lower and upper halves. Step 4 and 5 +compute the lower halves. Step 6 and 7 computer the upper halves. + +After the halves have been computed the three intermediate half-size products must be computed. Step 8 and 9 compute the trivial products +$x0 \cdot y0$ and $x1 \cdot y1$. The mp\_int $x0$ is used as a temporary variable after $x1 + x0$ has been computed. By using $x0$ instead +of an additional temporary variable, the algorithm can avoid an addition memory allocation operation. + +The remaining steps 13 through 18 compute the Karatsuba polynomial through a variety of digit shifting and addition operations. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_karatsuba\_mul.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* c = |a| * |b| using Karatsuba Multiplication using +018 * three half size multiplications +019 * +020 * Let B represent the radix [e.g. 2**DIGIT_BIT] and +021 * let n represent half of the number of digits in +022 * the min(a,b) +023 * +024 * a = a1 * B**n + a0 +025 * b = b1 * B**n + b0 +026 * +027 * Then, a * b => +028 a1b1 * B**2n + ((a1 + a0)(b1 + b0) - (a0b0 + a1b1)) * B + a0b0 +029 * +030 * Note that a1b1 and a0b0 are used twice and only need to be +031 * computed once. So in total three half size (half # of +032 * digit) multiplications are performed, a0b0, a1b1 and +033 * (a1+b1)(a0+b0) +034 * +035 * Note that a multiplication of half the digits requires +036 * 1/4th the number of single precision multiplications so in +037 * total after one call 25% of the single precision multiplications +038 * are saved. Note also that the call to mp_mul can end up back +039 * in this function if the a0, a1, b0, or b1 are above the threshold. +040 * This is known as divide-and-conquer and leads to the famous +041 * O(N**lg(3)) or O(N**1.584) work which is asymptopically lower than +042 * the standard O(N**2) that the baseline/comba methods use. +043 * Generally though the overhead of this method doesn't pay off +044 * until a certain size (N ~ 80) is reached. +045 */ +046 int mp_karatsuba_mul (mp_int * a, mp_int * b, mp_int * c) +047 \{ +048 mp_int x0, x1, y0, y1, t1, x0y0, x1y1; +049 int B, err; +050 +051 /* default the return code to an error */ +052 err = MP_MEM; +053 +054 /* min # of digits */ +055 B = MIN (a->used, b->used); +056 +057 /* now divide in two */ +058 B = B >> 1; +059 +060 /* init copy all the temps */ +061 if (mp_init_size (&x0, B) != MP_OKAY) +062 goto ERR; +063 if (mp_init_size (&x1, a->used - B) != MP_OKAY) +064 goto X0; +065 if (mp_init_size (&y0, B) != MP_OKAY) +066 goto X1; +067 if (mp_init_size (&y1, b->used - B) != MP_OKAY) +068 goto Y0; +069 +070 /* init temps */ +071 if (mp_init_size (&t1, B * 2) != MP_OKAY) +072 goto Y1; +073 if (mp_init_size (&x0y0, B * 2) != MP_OKAY) +074 goto T1; +075 if (mp_init_size (&x1y1, B * 2) != MP_OKAY) +076 goto X0Y0; +077 +078 /* now shift the digits */ +079 x0.used = y0.used = B; +080 x1.used = a->used - B; +081 y1.used = b->used - B; +082 +083 \{ +084 register int x; +085 register mp_digit *tmpa, *tmpb, *tmpx, *tmpy; +086 +087 /* we copy the digits directly instead of using higher level functions +088 * since we also need to shift the digits +089 */ +090 tmpa = a->dp; +091 tmpb = b->dp; +092 +093 tmpx = x0.dp; +094 tmpy = y0.dp; +095 for (x = 0; x < B; x++) \{ +096 *tmpx++ = *tmpa++; +097 *tmpy++ = *tmpb++; +098 \} +099 +100 tmpx = x1.dp; +101 for (x = B; x < a->used; x++) \{ +102 *tmpx++ = *tmpa++; +103 \} +104 +105 tmpy = y1.dp; +106 for (x = B; x < b->used; x++) \{ +107 *tmpy++ = *tmpb++; +108 \} +109 \} +110 +111 /* only need to clamp the lower words since by definition the +112 * upper words x1/y1 must have a known number of digits +113 */ +114 mp_clamp (&x0); +115 mp_clamp (&y0); +116 +117 /* now calc the products x0y0 and x1y1 */ +118 /* after this x0 is no longer required, free temp [x0==t2]! */ +119 if (mp_mul (&x0, &y0, &x0y0) != MP_OKAY) +120 goto X1Y1; /* x0y0 = x0*y0 */ +121 if (mp_mul (&x1, &y1, &x1y1) != MP_OKAY) +122 goto X1Y1; /* x1y1 = x1*y1 */ +123 +124 /* now calc x1+x0 and y1+y0 */ +125 if (s_mp_add (&x1, &x0, &t1) != MP_OKAY) +126 goto X1Y1; /* t1 = x1 - x0 */ +127 if (s_mp_add (&y1, &y0, &x0) != MP_OKAY) +128 goto X1Y1; /* t2 = y1 - y0 */ +129 if (mp_mul (&t1, &x0, &t1) != MP_OKAY) +130 goto X1Y1; /* t1 = (x1 + x0) * (y1 + y0) */ +131 +132 /* add x0y0 */ +133 if (mp_add (&x0y0, &x1y1, &x0) != MP_OKAY) +134 goto X1Y1; /* t2 = x0y0 + x1y1 */ +135 if (s_mp_sub (&t1, &x0, &t1) != MP_OKAY) +136 goto X1Y1; /* t1 = (x1+x0)*(y1+y0) - (x1y1 + x0y0) */ +137 +138 /* shift by B */ +139 if (mp_lshd (&t1, B) != MP_OKAY) +140 goto X1Y1; /* t1 = (x0y0 + x1y1 - (x1-x0)*(y1-y0))<used, b->used) / 3; +038 +039 /* a = a2 * B**2 + a1 * B + a0 */ +040 if ((res = mp_mod_2d(a, DIGIT_BIT * B, &a0)) != MP_OKAY) \{ +041 goto ERR; +042 \} +043 +044 if ((res = mp_copy(a, &a1)) != MP_OKAY) \{ +045 goto ERR; +046 \} +047 mp_rshd(&a1, B); +048 mp_mod_2d(&a1, DIGIT_BIT * B, &a1); +049 +050 if ((res = mp_copy(a, &a2)) != MP_OKAY) \{ +051 goto ERR; +052 \} +053 mp_rshd(&a2, B*2); +054 +055 /* b = b2 * B**2 + b1 * B + b0 */ +056 if ((res = mp_mod_2d(b, DIGIT_BIT * B, &b0)) != MP_OKAY) \{ +057 goto ERR; +058 \} +059 +060 if ((res = mp_copy(b, &b1)) != MP_OKAY) \{ +061 goto ERR; +062 \} +063 mp_rshd(&b1, B); +064 mp_mod_2d(&b1, DIGIT_BIT * B, &b1); +065 +066 if ((res = mp_copy(b, &b2)) != MP_OKAY) \{ +067 goto ERR; +068 \} +069 mp_rshd(&b2, B*2); +070 +071 /* w0 = a0*b0 */ +072 if ((res = mp_mul(&a0, &b0, &w0)) != MP_OKAY) \{ +073 goto ERR; +074 \} +075 +076 /* w4 = a2 * b2 */ +077 if ((res = mp_mul(&a2, &b2, &w4)) != MP_OKAY) \{ +078 goto ERR; +079 \} +080 +081 /* w1 = (a2 + 2(a1 + 2a0))(b2 + 2(b1 + 2b0)) */ +082 if ((res = mp_mul_2(&a0, &tmp1)) != MP_OKAY) \{ +083 goto ERR; +084 \} +085 if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) \{ +086 goto ERR; +087 \} +088 if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) \{ +089 goto ERR; +090 \} +091 if ((res = mp_add(&tmp1, &a2, &tmp1)) != MP_OKAY) \{ +092 goto ERR; +093 \} +094 +095 if ((res = mp_mul_2(&b0, &tmp2)) != MP_OKAY) \{ +096 goto ERR; +097 \} +098 if ((res = mp_add(&tmp2, &b1, &tmp2)) != MP_OKAY) \{ +099 goto ERR; +100 \} +101 if ((res = mp_mul_2(&tmp2, &tmp2)) != MP_OKAY) \{ +102 goto ERR; +103 \} +104 if ((res = mp_add(&tmp2, &b2, &tmp2)) != MP_OKAY) \{ +105 goto ERR; +106 \} +107 +108 if ((res = mp_mul(&tmp1, &tmp2, &w1)) != MP_OKAY) \{ +109 goto ERR; +110 \} +111 +112 /* w3 = (a0 + 2(a1 + 2a2))(b0 + 2(b1 + 2b2)) */ +113 if ((res = mp_mul_2(&a2, &tmp1)) != MP_OKAY) \{ +114 goto ERR; +115 \} +116 if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) \{ +117 goto ERR; +118 \} +119 if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) \{ +120 goto ERR; +121 \} +122 if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) \{ +123 goto ERR; +124 \} +125 +126 if ((res = mp_mul_2(&b2, &tmp2)) != MP_OKAY) \{ +127 goto ERR; +128 \} +129 if ((res = mp_add(&tmp2, &b1, &tmp2)) != MP_OKAY) \{ +130 goto ERR; +131 \} +132 if ((res = mp_mul_2(&tmp2, &tmp2)) != MP_OKAY) \{ +133 goto ERR; +134 \} +135 if ((res = mp_add(&tmp2, &b0, &tmp2)) != MP_OKAY) \{ +136 goto ERR; +137 \} +138 +139 if ((res = mp_mul(&tmp1, &tmp2, &w3)) != MP_OKAY) \{ +140 goto ERR; +141 \} +142 +143 +144 /* w2 = (a2 + a1 + a0)(b2 + b1 + b0) */ +145 if ((res = mp_add(&a2, &a1, &tmp1)) != MP_OKAY) \{ +146 goto ERR; +147 \} +148 if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) \{ +149 goto ERR; +150 \} +151 if ((res = mp_add(&b2, &b1, &tmp2)) != MP_OKAY) \{ +152 goto ERR; +153 \} +154 if ((res = mp_add(&tmp2, &b0, &tmp2)) != MP_OKAY) \{ +155 goto ERR; +156 \} +157 if ((res = mp_mul(&tmp1, &tmp2, &w2)) != MP_OKAY) \{ +158 goto ERR; +159 \} +160 +161 /* now solve the matrix +162 +163 0 0 0 0 1 +164 1 2 4 8 16 +165 1 1 1 1 1 +166 16 8 4 2 1 +167 1 0 0 0 0 +168 +169 using 12 subtractions, 4 shifts, +170 2 small divisions and 1 small multiplication +171 */ +172 +173 /* r1 - r4 */ +174 if ((res = mp_sub(&w1, &w4, &w1)) != MP_OKAY) \{ +175 goto ERR; +176 \} +177 /* r3 - r0 */ +178 if ((res = mp_sub(&w3, &w0, &w3)) != MP_OKAY) \{ +179 goto ERR; +180 \} +181 /* r1/2 */ +182 if ((res = mp_div_2(&w1, &w1)) != MP_OKAY) \{ +183 goto ERR; +184 \} +185 /* r3/2 */ +186 if ((res = mp_div_2(&w3, &w3)) != MP_OKAY) \{ +187 goto ERR; +188 \} +189 /* r2 - r0 - r4 */ +190 if ((res = mp_sub(&w2, &w0, &w2)) != MP_OKAY) \{ +191 goto ERR; +192 \} +193 if ((res = mp_sub(&w2, &w4, &w2)) != MP_OKAY) \{ +194 goto ERR; +195 \} +196 /* r1 - r2 */ +197 if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) \{ +198 goto ERR; +199 \} +200 /* r3 - r2 */ +201 if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) \{ +202 goto ERR; +203 \} +204 /* r1 - 8r0 */ +205 if ((res = mp_mul_2d(&w0, 3, &tmp1)) != MP_OKAY) \{ +206 goto ERR; +207 \} +208 if ((res = mp_sub(&w1, &tmp1, &w1)) != MP_OKAY) \{ +209 goto ERR; +210 \} +211 /* r3 - 8r4 */ +212 if ((res = mp_mul_2d(&w4, 3, &tmp1)) != MP_OKAY) \{ +213 goto ERR; +214 \} +215 if ((res = mp_sub(&w3, &tmp1, &w3)) != MP_OKAY) \{ +216 goto ERR; +217 \} +218 /* 3r2 - r1 - r3 */ +219 if ((res = mp_mul_d(&w2, 3, &w2)) != MP_OKAY) \{ +220 goto ERR; +221 \} +222 if ((res = mp_sub(&w2, &w1, &w2)) != MP_OKAY) \{ +223 goto ERR; +224 \} +225 if ((res = mp_sub(&w2, &w3, &w2)) != MP_OKAY) \{ +226 goto ERR; +227 \} +228 /* r1 - r2 */ +229 if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) \{ +230 goto ERR; +231 \} +232 /* r3 - r2 */ +233 if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) \{ +234 goto ERR; +235 \} +236 /* r1/3 */ +237 if ((res = mp_div_3(&w1, &w1, NULL)) != MP_OKAY) \{ +238 goto ERR; +239 \} +240 /* r3/3 */ +241 if ((res = mp_div_3(&w3, &w3, NULL)) != MP_OKAY) \{ +242 goto ERR; +243 \} +244 +245 /* at this point shift W[n] by B*n */ +246 if ((res = mp_lshd(&w1, 1*B)) != MP_OKAY) \{ +247 goto ERR; +248 \} +249 if ((res = mp_lshd(&w2, 2*B)) != MP_OKAY) \{ +250 goto ERR; +251 \} +252 if ((res = mp_lshd(&w3, 3*B)) != MP_OKAY) \{ +253 goto ERR; +254 \} +255 if ((res = mp_lshd(&w4, 4*B)) != MP_OKAY) \{ +256 goto ERR; +257 \} +258 +259 if ((res = mp_add(&w0, &w1, c)) != MP_OKAY) \{ +260 goto ERR; +261 \} +262 if ((res = mp_add(&w2, &w3, &tmp1)) != MP_OKAY) \{ +263 goto ERR; +264 \} +265 if ((res = mp_add(&w4, &tmp1, &tmp1)) != MP_OKAY) \{ +266 goto ERR; +267 \} +268 if ((res = mp_add(&tmp1, c, c)) != MP_OKAY) \{ +269 goto ERR; +270 \} +271 +272 ERR: +273 mp_clear_multi(&w0, &w1, &w2, &w3, &w4, +274 &a0, &a1, &a2, &b0, &b1, +275 &b2, &tmp1, &tmp2, NULL); +276 return res; +277 \} +278 +279 #endif +280 +\end{alltt} +\end{small} + +The first obvious thing to note is that this algorithm is complicated. The complexity is worth it if you are multiplying very +large numbers. For example, a 10,000 digit multiplication takes approximaly 99,282,205 fewer single precision multiplications with +Toom--Cook than a Comba or baseline approach (this is a savings of more than 99$\%$). For most ``crypto'' sized numbers this +algorithm is not practical as Karatsuba has a much lower cutoff point. + +First we split $a$ and $b$ into three roughly equal portions. This has been accomplished (lines 40 to 69) with +combinations of mp\_rshd() and mp\_mod\_2d() function calls. At this point $a = a2 \cdot \beta^2 + a1 \cdot \beta + a0$ and similiarly +for $b$. + +Next we compute the five points $w0, w1, w2, w3$ and $w4$. Recall that $w0$ and $w4$ can be computed directly from the portions so +we get those out of the way first (lines 72 and 77). Next we compute $w1, w2$ and $w3$ using Horners method. + +After this point we solve for the actual values of $w1, w2$ and $w3$ by reducing the $5 \times 5$ system which is relatively +straight forward. + +\subsection{Signed Multiplication} +Now that algorithms to handle multiplications of every useful dimensions have been developed, a rather simple finishing touch is required. So far all +of the multiplication algorithms have been unsigned multiplications which leaves only a signed multiplication algorithm to be established. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_mul}. \\ +\textbf{Input}. mp\_int $a$ and mp\_int $b$ \\ +\textbf{Output}. $c \leftarrow a \cdot b$ \\ +\hline \\ +1. If $a.sign = b.sign$ then \\ +\hspace{3mm}1.1 $sign = MP\_ZPOS$ \\ +2. else \\ +\hspace{3mm}2.1 $sign = MP\_ZNEG$ \\ +3. If min$(a.used, b.used) \ge TOOM\_MUL\_CUTOFF$ then \\ +\hspace{3mm}3.1 $c \leftarrow a \cdot b$ using algorithm mp\_toom\_mul \\ +4. else if min$(a.used, b.used) \ge KARATSUBA\_MUL\_CUTOFF$ then \\ +\hspace{3mm}4.1 $c \leftarrow a \cdot b$ using algorithm mp\_karatsuba\_mul \\ +5. else \\ +\hspace{3mm}5.1 $digs \leftarrow a.used + b.used + 1$ \\ +\hspace{3mm}5.2 If $digs < MP\_ARRAY$ and min$(a.used, b.used) \le \delta$ then \\ +\hspace{6mm}5.2.1 $c \leftarrow a \cdot b \mbox{ (mod }\beta^{digs}\mbox{)}$ using algorithm fast\_s\_mp\_mul\_digs. \\ +\hspace{3mm}5.3 else \\ +\hspace{6mm}5.3.1 $c \leftarrow a \cdot b \mbox{ (mod }\beta^{digs}\mbox{)}$ using algorithm s\_mp\_mul\_digs. \\ +6. $c.sign \leftarrow sign$ \\ +7. Return the result of the unsigned multiplication performed. \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_mul} +\end{figure} + +\textbf{Algorithm mp\_mul.} +This algorithm performs the signed multiplication of two inputs. It will make use of any of the three unsigned multiplication algorithms +available when the input is of appropriate size. The \textbf{sign} of the result is not set until the end of the algorithm since algorithm +s\_mp\_mul\_digs will clear it. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_mul.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* high level multiplication (handles sign) */ +018 int mp_mul (mp_int * a, mp_int * b, mp_int * c) +019 \{ +020 int res, neg; +021 neg = (a->sign == b->sign) ? MP_ZPOS : MP_NEG; +022 +023 /* use Toom-Cook? */ +024 #ifdef BN_MP_TOOM_MUL_C +025 if (MIN (a->used, b->used) >= TOOM_MUL_CUTOFF) \{ +026 res = mp_toom_mul(a, b, c); +027 \} else +028 #endif +029 #ifdef BN_MP_KARATSUBA_MUL_C +030 /* use Karatsuba? */ +031 if (MIN (a->used, b->used) >= KARATSUBA_MUL_CUTOFF) \{ +032 res = mp_karatsuba_mul (a, b, c); +033 \} else +034 #endif +035 \{ +036 /* can we use the fast multiplier? +037 * +038 * The fast multiplier can be used if the output will +039 * have less than MP_WARRAY digits and the number of +040 * digits won't affect carry propagation +041 */ +042 int digs = a->used + b->used + 1; +043 +044 #ifdef BN_FAST_S_MP_MUL_DIGS_C +045 if ((digs < MP_WARRAY) && +046 MIN(a->used, b->used) <= +047 (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) \{ +048 res = fast_s_mp_mul_digs (a, b, c, digs); +049 \} else +050 #endif +051 #ifdef BN_S_MP_MUL_DIGS_C +052 res = s_mp_mul (a, b, c); /* uses s_mp_mul_digs */ +053 #else +054 res = MP_VAL; +055 #endif +056 +057 \} +058 c->sign = (c->used > 0) ? neg : MP_ZPOS; +059 return res; +060 \} +061 #endif +062 +\end{alltt} +\end{small} + +The implementation is rather simplistic and is not particularly noteworthy. Line 23 computes the sign of the result using the ``?'' +operator from the C programming language. Line 47 computes $\delta$ using the fact that $1 << k$ is equal to $2^k$. + +\section{Squaring} +\label{sec:basesquare} + +Squaring is a special case of multiplication where both multiplicands are equal. At first it may seem like there is no significant optimization +available but in fact there is. Consider the multiplication of $576$ against $241$. In total there will be nine single precision multiplications +performed which are $1\cdot 6$, $1 \cdot 7$, $1 \cdot 5$, $4 \cdot 6$, $4 \cdot 7$, $4 \cdot 5$, $2 \cdot 6$, $2 \cdot 7$ and $2 \cdot 5$. Now consider +the multiplication of $123$ against $123$. The nine products are $3 \cdot 3$, $3 \cdot 2$, $3 \cdot 1$, $2 \cdot 3$, $2 \cdot 2$, $2 \cdot 1$, +$1 \cdot 3$, $1 \cdot 2$ and $1 \cdot 1$. On closer inspection some of the products are equivalent. For example, $3 \cdot 2 = 2 \cdot 3$ +and $3 \cdot 1 = 1 \cdot 3$. + +For any $n$-digit input, there are ${{\left (n^2 + n \right)}\over 2}$ possible unique single precision multiplications required compared to the $n^2$ +required for multiplication. The following diagram gives an example of the operations required. + +\begin{figure}[here] +\begin{center} +\begin{tabular}{ccccc|c} +&&1&2&3&\\ +$\times$ &&1&2&3&\\ +\hline && $3 \cdot 1$ & $3 \cdot 2$ & $3 \cdot 3$ & Row 0\\ + & $2 \cdot 1$ & $2 \cdot 2$ & $2 \cdot 3$ && Row 1 \\ + $1 \cdot 1$ & $1 \cdot 2$ & $1 \cdot 3$ &&& Row 2 \\ +\end{tabular} +\end{center} +\caption{Squaring Optimization Diagram} +\end{figure} + +Starting from zero and numbering the columns from right to left a very simple pattern becomes obvious. For the purposes of this discussion let $x$ +represent the number being squared. The first observation is that in row $k$ the $2k$'th column of the product has a $\left (x_k \right)^2$ term in it. + +The second observation is that every column $j$ in row $k$ where $j \ne 2k$ is part of a double product. Every non-square term of a column will +appear twice hence the name ``double product''. Every odd column is made up entirely of double products. In fact every column is made up of double +products and at most one square (\textit{see the exercise section}). + +The third and final observation is that for row $k$ the first unique non-square term, that is, one that hasn't already appeared in an earlier row, +occurs at column $2k + 1$. For example, on row $1$ of the previous squaring, column one is part of the double product with column one from row zero. +Column two of row one is a square and column three is the first unique column. + +\subsection{The Baseline Squaring Algorithm} +The baseline squaring algorithm is meant to be a catch-all squaring algorithm. It will handle any of the input sizes that the faster routines +will not handle. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{s\_mp\_sqr}. \\ +\textbf{Input}. mp\_int $a$ \\ +\textbf{Output}. $b \leftarrow a^2$ \\ +\hline \\ +1. Init a temporary mp\_int of at least $2 \cdot a.used +1$ digits. (\textit{mp\_init\_size}) \\ +2. If step 1 failed return(\textit{MP\_MEM}) \\ +3. $t.used \leftarrow 2 \cdot a.used + 1$ \\ +4. For $ix$ from 0 to $a.used - 1$ do \\ +\hspace{3mm}Calculate the square. \\ +\hspace{3mm}4.1 $\hat r \leftarrow t_{2ix} + \left (a_{ix} \right )^2$ \\ +\hspace{3mm}4.2 $t_{2ix} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\ +\hspace{3mm}Calculate the double products after the square. \\ +\hspace{3mm}4.3 $u \leftarrow \lfloor \hat r / \beta \rfloor$ \\ +\hspace{3mm}4.4 For $iy$ from $ix + 1$ to $a.used - 1$ do \\ +\hspace{6mm}4.4.1 $\hat r \leftarrow 2 \cdot a_{ix}a_{iy} + t_{ix + iy} + u$ \\ +\hspace{6mm}4.4.2 $t_{ix + iy} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\ +\hspace{6mm}4.4.3 $u \leftarrow \lfloor \hat r / \beta \rfloor$ \\ +\hspace{3mm}Set the last carry. \\ +\hspace{3mm}4.5 While $u > 0$ do \\ +\hspace{6mm}4.5.1 $iy \leftarrow iy + 1$ \\ +\hspace{6mm}4.5.2 $\hat r \leftarrow t_{ix + iy} + u$ \\ +\hspace{6mm}4.5.3 $t_{ix + iy} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\ +\hspace{6mm}4.5.4 $u \leftarrow \lfloor \hat r / \beta \rfloor$ \\ +5. Clamp excess digits of $t$. (\textit{mp\_clamp}) \\ +6. Exchange $b$ and $t$. \\ +7. Clear $t$ (\textit{mp\_clear}) \\ +8. Return(\textit{MP\_OKAY}) \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm s\_mp\_sqr} +\end{figure} + +\textbf{Algorithm s\_mp\_sqr.} +This algorithm computes the square of an input using the three observations on squaring. It is based fairly faithfully on algorithm 14.16 of HAC +\cite[pp.596-597]{HAC}. Similar to algorithm s\_mp\_mul\_digs, a temporary mp\_int is allocated to hold the result of the squaring. This allows the +destination mp\_int to be the same as the source mp\_int. + +The outer loop of this algorithm begins on step 4. It is best to think of the outer loop as walking down the rows of the partial results, while +the inner loop computes the columns of the partial result. Step 4.1 and 4.2 compute the square term for each row, and step 4.3 and 4.4 propagate +the carry and compute the double products. + +The requirement that a mp\_word be able to represent the range $0 \le x < 2 \beta^2$ arises from this +very algorithm. The product $a_{ix}a_{iy}$ will lie in the range $0 \le x \le \beta^2 - 2\beta + 1$ which is obviously less than $\beta^2$ meaning that +when it is multiplied by two, it can be properly represented by a mp\_word. + +Similar to algorithm s\_mp\_mul\_digs, after every pass of the inner loop, the destination is correctly set to the sum of all of the partial +results calculated so far. This involves expensive carry propagation which will be eliminated in the next algorithm. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_s\_mp\_sqr.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* low level squaring, b = a*a, HAC pp.596-597, Algorithm 14.16 */ +018 int s_mp_sqr (mp_int * a, mp_int * b) +019 \{ +020 mp_int t; +021 int res, ix, iy, pa; +022 mp_word r; +023 mp_digit u, tmpx, *tmpt; +024 +025 pa = a->used; +026 if ((res = mp_init_size (&t, 2*pa + 1)) != MP_OKAY) \{ +027 return res; +028 \} +029 +030 /* default used is maximum possible size */ +031 t.used = 2*pa + 1; +032 +033 for (ix = 0; ix < pa; ix++) \{ +034 /* first calculate the digit at 2*ix */ +035 /* calculate double precision result */ +036 r = ((mp_word) t.dp[2*ix]) + +037 ((mp_word)a->dp[ix])*((mp_word)a->dp[ix]); +038 +039 /* store lower part in result */ +040 t.dp[ix+ix] = (mp_digit) (r & ((mp_word) MP_MASK)); +041 +042 /* get the carry */ +043 u = (mp_digit)(r >> ((mp_word) DIGIT_BIT)); +044 +045 /* left hand side of A[ix] * A[iy] */ +046 tmpx = a->dp[ix]; +047 +048 /* alias for where to store the results */ +049 tmpt = t.dp + (2*ix + 1); +050 +051 for (iy = ix + 1; iy < pa; iy++) \{ +052 /* first calculate the product */ +053 r = ((mp_word)tmpx) * ((mp_word)a->dp[iy]); +054 +055 /* now calculate the double precision result, note we use +056 * addition instead of *2 since it's easier to optimize +057 */ +058 r = ((mp_word) *tmpt) + r + r + ((mp_word) u); +059 +060 /* store lower part */ +061 *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK)); +062 +063 /* get carry */ +064 u = (mp_digit)(r >> ((mp_word) DIGIT_BIT)); +065 \} +066 /* propagate upwards */ +067 while (u != ((mp_digit) 0)) \{ +068 r = ((mp_word) *tmpt) + ((mp_word) u); +069 *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK)); +070 u = (mp_digit)(r >> ((mp_word) DIGIT_BIT)); +071 \} +072 \} +073 +074 mp_clamp (&t); +075 mp_exch (&t, b); +076 mp_clear (&t); +077 return MP_OKAY; +078 \} +079 #endif +080 +\end{alltt} +\end{small} + +Inside the outer loop (line 33) the square term is calculated on line 36. The carry (line 43) has been +extracted from the mp\_word accumulator using a right shift. Aliases for $a_{ix}$ and $t_{ix+iy}$ are initialized +(lines 46 and 49) to simplify the inner loop. The doubling is performed using two +additions (line 58) since it is usually faster than shifting, if not at least as fast. + +The important observation is that the inner loop does not begin at $iy = 0$ like for multiplication. As such the inner loops +get progressively shorter as the algorithm proceeds. This is what leads to the savings compared to using a multiplication to +square a number. + +\subsection{Faster Squaring by the ``Comba'' Method} +A major drawback to the baseline method is the requirement for single precision shifting inside the $O(n^2)$ nested loop. Squaring has an additional +drawback that it must double the product inside the inner loop as well. As for multiplication, the Comba technique can be used to eliminate these +performance hazards. + +The first obvious solution is to make an array of mp\_words which will hold all of the columns. This will indeed eliminate all of the carry +propagation operations from the inner loop. However, the inner product must still be doubled $O(n^2)$ times. The solution stems from the simple fact +that $2a + 2b + 2c = 2(a + b + c)$. That is the sum of all of the double products is equal to double the sum of all the products. For example, +$ab + ba + ac + ca = 2ab + 2ac = 2(ab + ac)$. + +However, we cannot simply double all of the columns, since the squares appear only once per row. The most practical solution is to have two +mp\_word arrays. One array will hold the squares and the other array will hold the double products. With both arrays the doubling and +carry propagation can be moved to a $O(n)$ work level outside the $O(n^2)$ level. In this case, we have an even simpler solution in mind. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{fast\_s\_mp\_sqr}. \\ +\textbf{Input}. mp\_int $a$ \\ +\textbf{Output}. $b \leftarrow a^2$ \\ +\hline \\ +Place an array of \textbf{MP\_WARRAY} mp\_digits named $W$ on the stack. \\ +1. If $b.alloc < 2a.used + 1$ then grow $b$ to $2a.used + 1$ digits. (\textit{mp\_grow}). \\ +2. If step 1 failed return(\textit{MP\_MEM}). \\ +\\ +3. $pa \leftarrow 2 \cdot a.used$ \\ +4. $\hat W1 \leftarrow 0$ \\ +5. for $ix$ from $0$ to $pa - 1$ do \\ +\hspace{3mm}5.1 $\_ \hat W \leftarrow 0$ \\ +\hspace{3mm}5.2 $ty \leftarrow \mbox{MIN}(a.used - 1, ix)$ \\ +\hspace{3mm}5.3 $tx \leftarrow ix - ty$ \\ +\hspace{3mm}5.4 $iy \leftarrow \mbox{MIN}(a.used - tx, ty + 1)$ \\ +\hspace{3mm}5.5 $iy \leftarrow \mbox{MIN}(iy, \lfloor \left (ty - tx + 1 \right )/2 \rfloor)$ \\ +\hspace{3mm}5.6 for $iz$ from $0$ to $iz - 1$ do \\ +\hspace{6mm}5.6.1 $\_ \hat W \leftarrow \_ \hat W + a_{tx + iz}a_{ty - iz}$ \\ +\hspace{3mm}5.7 $\_ \hat W \leftarrow 2 \cdot \_ \hat W + \hat W1$ \\ +\hspace{3mm}5.8 if $ix$ is even then \\ +\hspace{6mm}5.8.1 $\_ \hat W \leftarrow \_ \hat W + \left ( a_{\lfloor ix/2 \rfloor}\right )^2$ \\ +\hspace{3mm}5.9 $W_{ix} \leftarrow \_ \hat W (\mbox{mod }\beta)$ \\ +\hspace{3mm}5.10 $\hat W1 \leftarrow \lfloor \_ \hat W / \beta \rfloor$ \\ +\\ +6. $oldused \leftarrow b.used$ \\ +7. $b.used \leftarrow 2 \cdot a.used$ \\ +8. for $ix$ from $0$ to $pa - 1$ do \\ +\hspace{3mm}8.1 $b_{ix} \leftarrow W_{ix}$ \\ +9. for $ix$ from $pa$ to $oldused - 1$ do \\ +\hspace{3mm}9.1 $b_{ix} \leftarrow 0$ \\ +10. Clamp excess digits from $b$. (\textit{mp\_clamp}) \\ +11. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm fast\_s\_mp\_sqr} +\end{figure} + +\textbf{Algorithm fast\_s\_mp\_sqr.} +This algorithm computes the square of an input using the Comba technique. It is designed to be a replacement for algorithm +s\_mp\_sqr when the number of input digits is less than \textbf{MP\_WARRAY} and less than $\delta \over 2$. +This algorithm is very similar to the Comba multiplier except with a few key differences we shall make note of. + +First, we have an accumulator and carry variables $\_ \hat W$ and $\hat W1$ respectively. This is because the inner loop +products are to be doubled. If we had added the previous carry in we would be doubling too much. Next we perform an +addition MIN condition on $iy$ (step 5.5) to prevent overlapping digits. For example, $a_3 \cdot a_5$ is equal +$a_5 \cdot a_3$. Whereas in the multiplication case we would have $5 < a.used$ and $3 \ge 0$ is maintained since we double the sum +of the products just outside the inner loop we have to avoid doing this. This is also a good thing since we perform +fewer multiplications and the routine ends up being faster. + +Finally the last difference is the addition of the ``square'' term outside the inner loop (step 5.8). We add in the square +only to even outputs and it is the square of the term at the $\lfloor ix / 2 \rfloor$ position. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_fast\_s\_mp\_sqr.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* the jist of squaring... +018 * you do like mult except the offset of the tmpx [one that +019 * starts closer to zero] can't equal the offset of tmpy. +020 * So basically you set up iy like before then you min it with +021 * (ty-tx) so that it never happens. You double all those +022 * you add in the inner loop +023 +024 After that loop you do the squares and add them in. +025 */ +026 +027 int fast_s_mp_sqr (mp_int * a, mp_int * b) +028 \{ +029 int olduse, res, pa, ix, iz; +030 mp_digit W[MP_WARRAY], *tmpx; +031 mp_word W1; +032 +033 /* grow the destination as required */ +034 pa = a->used + a->used; +035 if (b->alloc < pa) \{ +036 if ((res = mp_grow (b, pa)) != MP_OKAY) \{ +037 return res; +038 \} +039 \} +040 +041 /* number of output digits to produce */ +042 W1 = 0; +043 for (ix = 0; ix < pa; ix++) \{ +044 int tx, ty, iy; +045 mp_word _W; +046 mp_digit *tmpy; +047 +048 /* clear counter */ +049 _W = 0; +050 +051 /* get offsets into the two bignums */ +052 ty = MIN(a->used-1, ix); +053 tx = ix - ty; +054 +055 /* setup temp aliases */ +056 tmpx = a->dp + tx; +057 tmpy = a->dp + ty; +058 +059 /* this is the number of times the loop will iterrate, essentially +060 while (tx++ < a->used && ty-- >= 0) \{ ... \} +061 */ +062 iy = MIN(a->used-tx, ty+1); +063 +064 /* now for squaring tx can never equal ty +065 * we halve the distance since they approach at a rate of 2x +066 * and we have to round because odd cases need to be executed +067 */ +068 iy = MIN(iy, (ty-tx+1)>>1); +069 +070 /* execute loop */ +071 for (iz = 0; iz < iy; iz++) \{ +072 _W += ((mp_word)*tmpx++)*((mp_word)*tmpy--); +073 \} +074 +075 /* double the inner product and add carry */ +076 _W = _W + _W + W1; +077 +078 /* even columns have the square term in them */ +079 if ((ix&1) == 0) \{ +080 _W += ((mp_word)a->dp[ix>>1])*((mp_word)a->dp[ix>>1]); +081 \} +082 +083 /* store it */ +084 W[ix] = (mp_digit)(_W & MP_MASK); +085 +086 /* make next carry */ +087 W1 = _W >> ((mp_word)DIGIT_BIT); +088 \} +089 +090 /* setup dest */ +091 olduse = b->used; +092 b->used = a->used+a->used; +093 +094 \{ +095 mp_digit *tmpb; +096 tmpb = b->dp; +097 for (ix = 0; ix < pa; ix++) \{ +098 *tmpb++ = W[ix] & MP_MASK; +099 \} +100 +101 /* clear unused digits [that existed in the old copy of c] */ +102 for (; ix < olduse; ix++) \{ +103 *tmpb++ = 0; +104 \} +105 \} +106 mp_clamp (b); +107 return MP_OKAY; +108 \} +109 #endif +110 +\end{alltt} +\end{small} + +This implementation is essentially a copy of Comba multiplication with the appropriate changes added to make it faster for +the special case of squaring. + +\subsection{Polynomial Basis Squaring} +The same algorithm that performs optimal polynomial basis multiplication can be used to perform polynomial basis squaring. The minor exception +is that $\zeta_y = f(y)g(y)$ is actually equivalent to $\zeta_y = f(y)^2$ since $f(y) = g(y)$. Instead of performing $2n + 1$ +multiplications to find the $\zeta$ relations, squaring operations are performed instead. + +\subsection{Karatsuba Squaring} +Let $f(x) = ax + b$ represent the polynomial basis representation of a number to square. +Let $h(x) = \left ( f(x) \right )^2$ represent the square of the polynomial. The Karatsuba equation can be modified to square a +number with the following equation. + +\begin{equation} +h(x) = a^2x^2 + \left ((a + b)^2 - (a^2 + b^2) \right )x + b^2 +\end{equation} + +Upon closer inspection this equation only requires the calculation of three half-sized squares: $a^2$, $b^2$ and $(a + b)^2$. As in +Karatsuba multiplication, this algorithm can be applied recursively on the input and will achieve an asymptotic running time of +$O \left ( n^{lg(3)} \right )$. + +If the asymptotic times of Karatsuba squaring and multiplication are the same, why not simply use the multiplication algorithm +instead? The answer to this arises from the cutoff point for squaring. As in multiplication there exists a cutoff point, at which the +time required for a Comba based squaring and a Karatsuba based squaring meet. Due to the overhead inherent in the Karatsuba method, the cutoff +point is fairly high. For example, on an AMD Athlon XP processor with $\beta = 2^{28}$, the cutoff point is around 127 digits. + +Consider squaring a 200 digit number with this technique. It will be split into two 100 digit halves which are subsequently squared. +The 100 digit halves will not be squared using Karatsuba, but instead using the faster Comba based squaring algorithm. If Karatsuba multiplication +were used instead, the 100 digit numbers would be squared with a slower Comba based multiplication. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_karatsuba\_sqr}. \\ +\textbf{Input}. mp\_int $a$ \\ +\textbf{Output}. $b \leftarrow a^2$ \\ +\hline \\ +1. Initialize the following temporary mp\_ints: $x0$, $x1$, $t1$, $t2$, $x0x0$ and $x1x1$. \\ +2. If any of the initializations on step 1 failed return(\textit{MP\_MEM}). \\ +\\ +Split the input. e.g. $a = x1\beta^B + x0$ \\ +3. $B \leftarrow \lfloor a.used / 2 \rfloor$ \\ +4. $x0 \leftarrow a \mbox{ (mod }\beta^B\mbox{)}$ (\textit{mp\_mod\_2d}) \\ +5. $x1 \leftarrow \lfloor a / \beta^B \rfloor$ (\textit{mp\_lshd}) \\ +\\ +Calculate the three squares. \\ +6. $x0x0 \leftarrow x0^2$ (\textit{mp\_sqr}) \\ +7. $x1x1 \leftarrow x1^2$ \\ +8. $t1 \leftarrow x1 + x0$ (\textit{s\_mp\_add}) \\ +9. $t1 \leftarrow t1^2$ \\ +\\ +Compute the middle term. \\ +10. $t2 \leftarrow x0x0 + x1x1$ (\textit{s\_mp\_add}) \\ +11. $t1 \leftarrow t1 - t2$ \\ +\\ +Compute final product. \\ +12. $t1 \leftarrow t1\beta^B$ (\textit{mp\_lshd}) \\ +13. $x1x1 \leftarrow x1x1\beta^{2B}$ \\ +14. $t1 \leftarrow t1 + x0x0$ \\ +15. $b \leftarrow t1 + x1x1$ \\ +16. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_karatsuba\_sqr} +\end{figure} + +\textbf{Algorithm mp\_karatsuba\_sqr.} +This algorithm computes the square of an input $a$ using the Karatsuba technique. This algorithm is very similar to the Karatsuba based +multiplication algorithm with the exception that the three half-size multiplications have been replaced with three half-size squarings. + +The radix point for squaring is simply placed exactly in the middle of the digits when the input has an odd number of digits, otherwise it is +placed just below the middle. Step 3, 4 and 5 compute the two halves required using $B$ +as the radix point. The first two squares in steps 6 and 7 are rather straightforward while the last square is of a more compact form. + +By expanding $\left (x1 + x0 \right )^2$, the $x1^2$ and $x0^2$ terms in the middle disappear, that is $(x0 - x1)^2 - (x1^2 + x0^2) = 2 \cdot x0 \cdot x1$. +Now if $5n$ single precision additions and a squaring of $n$-digits is faster than multiplying two $n$-digit numbers and doubling then +this method is faster. Assuming no further recursions occur, the difference can be estimated with the following inequality. + +Let $p$ represent the cost of a single precision addition and $q$ the cost of a single precision multiplication both in terms of time\footnote{Or +machine clock cycles.}. + +\begin{equation} +5pn +{{q(n^2 + n)} \over 2} \le pn + qn^2 +\end{equation} + +For example, on an AMD Athlon XP processor $p = {1 \over 3}$ and $q = 6$. This implies that the following inequality should hold. +\begin{center} +\begin{tabular}{rcl} +${5n \over 3} + 3n^2 + 3n$ & $<$ & ${n \over 3} + 6n^2$ \\ +${5 \over 3} + 3n + 3$ & $<$ & ${1 \over 3} + 6n$ \\ +${13 \over 9}$ & $<$ & $n$ \\ +\end{tabular} +\end{center} + +This results in a cutoff point around $n = 2$. As a consequence it is actually faster to compute the middle term the ``long way'' on processors +where multiplication is substantially slower\footnote{On the Athlon there is a 1:17 ratio between clock cycles for addition and multiplication. On +the Intel P4 processor this ratio is 1:29 making this method even more beneficial. The only common exception is the ARMv4 processor which has a +ratio of 1:7. } than simpler operations such as addition. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_karatsuba\_sqr.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* Karatsuba squaring, computes b = a*a using three +018 * half size squarings +019 * +020 * See comments of karatsuba_mul for details. It +021 * is essentially the same algorithm but merely +022 * tuned to perform recursive squarings. +023 */ +024 int mp_karatsuba_sqr (mp_int * a, mp_int * b) +025 \{ +026 mp_int x0, x1, t1, t2, x0x0, x1x1; +027 int B, err; +028 +029 err = MP_MEM; +030 +031 /* min # of digits */ +032 B = a->used; +033 +034 /* now divide in two */ +035 B = B >> 1; +036 +037 /* init copy all the temps */ +038 if (mp_init_size (&x0, B) != MP_OKAY) +039 goto ERR; +040 if (mp_init_size (&x1, a->used - B) != MP_OKAY) +041 goto X0; +042 +043 /* init temps */ +044 if (mp_init_size (&t1, a->used * 2) != MP_OKAY) +045 goto X1; +046 if (mp_init_size (&t2, a->used * 2) != MP_OKAY) +047 goto T1; +048 if (mp_init_size (&x0x0, B * 2) != MP_OKAY) +049 goto T2; +050 if (mp_init_size (&x1x1, (a->used - B) * 2) != MP_OKAY) +051 goto X0X0; +052 +053 \{ +054 register int x; +055 register mp_digit *dst, *src; +056 +057 src = a->dp; +058 +059 /* now shift the digits */ +060 dst = x0.dp; +061 for (x = 0; x < B; x++) \{ +062 *dst++ = *src++; +063 \} +064 +065 dst = x1.dp; +066 for (x = B; x < a->used; x++) \{ +067 *dst++ = *src++; +068 \} +069 \} +070 +071 x0.used = B; +072 x1.used = a->used - B; +073 +074 mp_clamp (&x0); +075 +076 /* now calc the products x0*x0 and x1*x1 */ +077 if (mp_sqr (&x0, &x0x0) != MP_OKAY) +078 goto X1X1; /* x0x0 = x0*x0 */ +079 if (mp_sqr (&x1, &x1x1) != MP_OKAY) +080 goto X1X1; /* x1x1 = x1*x1 */ +081 +082 /* now calc (x1+x0)**2 */ +083 if (s_mp_add (&x1, &x0, &t1) != MP_OKAY) +084 goto X1X1; /* t1 = x1 - x0 */ +085 if (mp_sqr (&t1, &t1) != MP_OKAY) +086 goto X1X1; /* t1 = (x1 - x0) * (x1 - x0) */ +087 +088 /* add x0y0 */ +089 if (s_mp_add (&x0x0, &x1x1, &t2) != MP_OKAY) +090 goto X1X1; /* t2 = x0x0 + x1x1 */ +091 if (s_mp_sub (&t1, &t2, &t1) != MP_OKAY) +092 goto X1X1; /* t1 = (x1+x0)**2 - (x0x0 + x1x1) */ +093 +094 /* shift by B */ +095 if (mp_lshd (&t1, B) != MP_OKAY) +096 goto X1X1; /* t1 = (x0x0 + x1x1 - (x1-x0)*(x1-x0))<used >= TOOM_SQR_CUTOFF) \{ +026 res = mp_toom_sqr(a, b); +027 /* Karatsuba? */ +028 \} else +029 #endif +030 #ifdef BN_MP_KARATSUBA_SQR_C +031 if (a->used >= KARATSUBA_SQR_CUTOFF) \{ +032 res = mp_karatsuba_sqr (a, b); +033 \} else +034 #endif +035 \{ +036 #ifdef BN_FAST_S_MP_SQR_C +037 /* can we use the fast comba multiplier? */ +038 if ((a->used * 2 + 1) < MP_WARRAY && +039 a->used < +040 (1 << (sizeof(mp_word) * CHAR_BIT - 2*DIGIT_BIT - 1))) \{ +041 res = fast_s_mp_sqr (a, b); +042 \} else +043 #endif +044 #ifdef BN_S_MP_SQR_C +045 res = s_mp_sqr (a, b); +046 #else +047 res = MP_VAL; +048 #endif +049 \} +050 b->sign = MP_ZPOS; +051 return res; +052 \} +053 #endif +054 +\end{alltt} +\end{small} + +\section*{Exercises} +\begin{tabular}{cl} +$\left [ 3 \right ] $ & Devise an efficient algorithm for selection of the radix point to handle inputs \\ + & that have different number of digits in Karatsuba multiplication. \\ + & \\ +$\left [ 2 \right ] $ & In section 5.3 the fact that every column of a squaring is made up \\ + & of double products and at most one square is stated. Prove this statement. \\ + & \\ +$\left [ 3 \right ] $ & Prove the equation for Karatsuba squaring. \\ + & \\ +$\left [ 1 \right ] $ & Prove that Karatsuba squaring requires $O \left (n^{lg(3)} \right )$ time. \\ + & \\ +$\left [ 2 \right ] $ & Determine the minimal ratio between addition and multiplication clock cycles \\ + & required for equation $6.7$ to be true. \\ + & \\ +$\left [ 3 \right ] $ & Implement a threaded version of Comba multiplication (and squaring) where you \\ + & compute subsets of the columns in each thread. Determine a cutoff point where \\ + & it is effective and add the logic to mp\_mul() and mp\_sqr(). \\ + &\\ +$\left [ 4 \right ] $ & Same as the previous but also modify the Karatsuba and Toom-Cook. You must \\ + & increase the throughput of mp\_exptmod() for random odd moduli in the range \\ + & $512 \ldots 4096$ bits significantly ($> 2x$) to complete this challenge. \\ + & \\ +\end{tabular} + +\chapter{Modular Reduction} +\section{Basics of Modular Reduction} +\index{modular residue} +Modular reduction is an operation that arises quite often within public key cryptography algorithms and various number theoretic algorithms, +such as factoring. Modular reduction algorithms are the third class of algorithms of the ``multipliers'' set. A number $a$ is said to be \textit{reduced} +modulo another number $b$ by finding the remainder of the division $a/b$. Full integer division with remainder is a topic to be covered +in~\ref{sec:division}. + +Modular reduction is equivalent to solving for $r$ in the following equation. $a = bq + r$ where $q = \lfloor a/b \rfloor$. The result +$r$ is said to be ``congruent to $a$ modulo $b$'' which is also written as $r \equiv a \mbox{ (mod }b\mbox{)}$. In other vernacular $r$ is known as the +``modular residue'' which leads to ``quadratic residue''\footnote{That's fancy talk for $b \equiv a^2 \mbox{ (mod }p\mbox{)}$.} and +other forms of residues. + +Modular reductions are normally used to create either finite groups, rings or fields. The most common usage for performance driven modular reductions +is in modular exponentiation algorithms. That is to compute $d = a^b \mbox{ (mod }c\mbox{)}$ as fast as possible. This operation is used in the +RSA and Diffie-Hellman public key algorithms, for example. Modular multiplication and squaring also appears as a fundamental operation in +elliptic curve cryptographic algorithms. As will be discussed in the subsequent chapter there exist fast algorithms for computing modular +exponentiations without having to perform (\textit{in this example}) $b - 1$ multiplications. These algorithms will produce partial results in the +range $0 \le x < c^2$ which can be taken advantage of to create several efficient algorithms. They have also been used to create redundancy check +algorithms known as CRCs, error correction codes such as Reed-Solomon and solve a variety of number theoeretic problems. + +\section{The Barrett Reduction} +The Barrett reduction algorithm \cite{BARRETT} was inspired by fast division algorithms which multiply by the reciprocal to emulate +division. Barretts observation was that the residue $c$ of $a$ modulo $b$ is equal to + +\begin{equation} +c = a - b \cdot \lfloor a/b \rfloor +\end{equation} + +Since algorithms such as modular exponentiation would be using the same modulus extensively, typical DSP\footnote{It is worth noting that Barrett's paper +targeted the DSP56K processor.} intuition would indicate the next step would be to replace $a/b$ by a multiplication by the reciprocal. However, +DSP intuition on its own will not work as these numbers are considerably larger than the precision of common DSP floating point data types. +It would take another common optimization to optimize the algorithm. + +\subsection{Fixed Point Arithmetic} +The trick used to optimize the above equation is based on a technique of emulating floating point data types with fixed precision integers. Fixed +point arithmetic would become very popular as it greatly optimize the ``3d-shooter'' genre of games in the mid 1990s when floating point units were +fairly slow if not unavailable. The idea behind fixed point arithmetic is to take a normal $k$-bit integer data type and break it into $p$-bit +integer and a $q$-bit fraction part (\textit{where $p+q = k$}). + +In this system a $k$-bit integer $n$ would actually represent $n/2^q$. For example, with $q = 4$ the integer $n = 37$ would actually represent the +value $2.3125$. To multiply two fixed point numbers the integers are multiplied using traditional arithmetic and subsequently normalized by +moving the implied decimal point back to where it should be. For example, with $q = 4$ to multiply the integers $9$ and $5$ they must be converted +to fixed point first by multiplying by $2^q$. Let $a = 9(2^q)$ represent the fixed point representation of $9$ and $b = 5(2^q)$ represent the +fixed point representation of $5$. The product $ab$ is equal to $45(2^{2q})$ which when normalized by dividing by $2^q$ produces $45(2^q)$. + +This technique became popular since a normal integer multiplication and logical shift right are the only required operations to perform a multiplication +of two fixed point numbers. Using fixed point arithmetic, division can be easily approximated by multiplying by the reciprocal. If $2^q$ is +equivalent to one than $2^q/b$ is equivalent to the fixed point approximation of $1/b$ using real arithmetic. Using this fact dividing an integer +$a$ by another integer $b$ can be achieved with the following expression. + +\begin{equation} +\lfloor a / b \rfloor \mbox{ }\approx\mbox{ } \lfloor (a \cdot \lfloor 2^q / b \rfloor)/2^q \rfloor +\end{equation} + +The precision of the division is proportional to the value of $q$. If the divisor $b$ is used frequently as is the case with +modular exponentiation pre-computing $2^q/b$ will allow a division to be performed with a multiplication and a right shift. Both operations +are considerably faster than division on most processors. + +Consider dividing $19$ by $5$. The correct result is $\lfloor 19/5 \rfloor = 3$. With $q = 3$ the reciprocal is $\lfloor 2^q/5 \rfloor = 1$ which +leads to a product of $19$ which when divided by $2^q$ produces $2$. However, with $q = 4$ the reciprocal is $\lfloor 2^q/5 \rfloor = 3$ and +the result of the emulated division is $\lfloor 3 \cdot 19 / 2^q \rfloor = 3$ which is correct. The value of $2^q$ must be close to or ideally +larger than the dividend. In effect if $a$ is the dividend then $q$ should allow $0 \le \lfloor a/2^q \rfloor \le 1$ in order for this approach +to work correctly. Plugging this form of divison into the original equation the following modular residue equation arises. + +\begin{equation} +c = a - b \cdot \lfloor (a \cdot \lfloor 2^q / b \rfloor)/2^q \rfloor +\end{equation} + +Using the notation from \cite{BARRETT} the value of $\lfloor 2^q / b \rfloor$ will be represented by the $\mu$ symbol. Using the $\mu$ +variable also helps re-inforce the idea that it is meant to be computed once and re-used. + +\begin{equation} +c = a - b \cdot \lfloor (a \cdot \mu)/2^q \rfloor +\end{equation} + +Provided that $2^q \ge a$ this algorithm will produce a quotient that is either exactly correct or off by a value of one. In the context of Barrett +reduction the value of $a$ is bound by $0 \le a \le (b - 1)^2$ meaning that $2^q \ge b^2$ is sufficient to ensure the reciprocal will have enough +precision. + +Let $n$ represent the number of digits in $b$. This algorithm requires approximately $2n^2$ single precision multiplications to produce the quotient and +another $n^2$ single precision multiplications to find the residue. In total $3n^2$ single precision multiplications are required to +reduce the number. + +For example, if $b = 1179677$ and $q = 41$ ($2^q > b^2$), then the reciprocal $\mu$ is equal to $\lfloor 2^q / b \rfloor = 1864089$. Consider reducing +$a = 180388626447$ modulo $b$ using the above reduction equation. The quotient using the new formula is $\lfloor (a \cdot \mu) / 2^q \rfloor = 152913$. +By subtracting $152913b$ from $a$ the correct residue $a \equiv 677346 \mbox{ (mod }b\mbox{)}$ is found. + +\subsection{Choosing a Radix Point} +Using the fixed point representation a modular reduction can be performed with $3n^2$ single precision multiplications. If that were the best +that could be achieved a full division\footnote{A division requires approximately $O(2cn^2)$ single precision multiplications for a small value of $c$. +See~\ref{sec:division} for further details.} might as well be used in its place. The key to optimizing the reduction is to reduce the precision of +the initial multiplication that finds the quotient. + +Let $a$ represent the number of which the residue is sought. Let $b$ represent the modulus used to find the residue. Let $m$ represent +the number of digits in $b$. For the purposes of this discussion we will assume that the number of digits in $a$ is $2m$, which is generally true if +two $m$-digit numbers have been multiplied. Dividing $a$ by $b$ is the same as dividing a $2m$ digit integer by a $m$ digit integer. Digits below the +$m - 1$'th digit of $a$ will contribute at most a value of $1$ to the quotient because $\beta^k < b$ for any $0 \le k \le m - 1$. Another way to +express this is by re-writing $a$ as two parts. If $a' \equiv a \mbox{ (mod }b^m\mbox{)}$ and $a'' = a - a'$ then +${a \over b} \equiv {{a' + a''} \over b}$ which is equivalent to ${a' \over b} + {a'' \over b}$. Since $a'$ is bound to be less than $b$ the quotient +is bound by $0 \le {a' \over b} < 1$. + +Since the digits of $a'$ do not contribute much to the quotient the observation is that they might as well be zero. However, if the digits +``might as well be zero'' they might as well not be there in the first place. Let $q_0 = \lfloor a/\beta^{m-1} \rfloor$ represent the input +with the irrelevant digits trimmed. Now the modular reduction is trimmed to the almost equivalent equation + +\begin{equation} +c = a - b \cdot \lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor +\end{equation} + +Note that the original divisor $2^q$ has been replaced with $\beta^{m+1}$ where in this case $q$ is a multiple of $lg(\beta)$. Also note that the +exponent on the divisor when added to the amount $q_0$ was shifted by equals $2m$. If the optimization had not been performed the divisor +would have the exponent $2m$ so in the end the exponents do ``add up''. Using the above equation the quotient +$\lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor$ can be off from the true quotient by at most two. The original fixed point quotient can be off +by as much as one (\textit{provided the radix point is chosen suitably}) and now that the lower irrelevent digits have been trimmed the quotient +can be off by an additional value of one for a total of at most two. This implies that +$0 \le a - b \cdot \lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor < 3b$. By first subtracting $b$ times the quotient and then conditionally subtracting +$b$ once or twice the residue is found. + +The quotient is now found using $(m + 1)(m) = m^2 + m$ single precision multiplications and the residue with an additional $m^2$ single +precision multiplications, ignoring the subtractions required. In total $2m^2 + m$ single precision multiplications are required to find the residue. +This is considerably faster than the original attempt. + +For example, let $\beta = 10$ represent the radix of the digits. Let $b = 9999$ represent the modulus which implies $m = 4$. Let $a = 99929878$ +represent the value of which the residue is desired. In this case $q = 8$ since $10^7 < 9999^2$ meaning that $\mu = \lfloor \beta^{q}/b \rfloor = 10001$. +With the new observation the multiplicand for the quotient is equal to $q_0 = \lfloor a / \beta^{m - 1} \rfloor = 99929$. The quotient is then +$\lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor = 9993$. Subtracting $9993b$ from $a$ and the correct residue $a \equiv 9871 \mbox{ (mod }b\mbox{)}$ +is found. + +\subsection{Trimming the Quotient} +So far the reduction algorithm has been optimized from $3m^2$ single precision multiplications down to $2m^2 + m$ single precision multiplications. As +it stands now the algorithm is already fairly fast compared to a full integer division algorithm. However, there is still room for +optimization. + +After the first multiplication inside the quotient ($q_0 \cdot \mu$) the value is shifted right by $m + 1$ places effectively nullifying the lower +half of the product. It would be nice to be able to remove those digits from the product to effectively cut down the number of single precision +multiplications. If the number of digits in the modulus $m$ is far less than $\beta$ a full product is not required for the algorithm to work properly. +In fact the lower $m - 2$ digits will not affect the upper half of the product at all and do not need to be computed. + +The value of $\mu$ is a $m$-digit number and $q_0$ is a $m + 1$ digit number. Using a full multiplier $(m + 1)(m) = m^2 + m$ single precision +multiplications would be required. Using a multiplier that will only produce digits at and above the $m - 1$'th digit reduces the number +of single precision multiplications to ${m^2 + m} \over 2$ single precision multiplications. + +\subsection{Trimming the Residue} +After the quotient has been calculated it is used to reduce the input. As previously noted the algorithm is not exact and it can be off by a small +multiple of the modulus, that is $0 \le a - b \cdot \lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor < 3b$. If $b$ is $m$ digits than the +result of reduction equation is a value of at most $m + 1$ digits (\textit{provided $3 < \beta$}) implying that the upper $m - 1$ digits are +implicitly zero. + +The next optimization arises from this very fact. Instead of computing $b \cdot \lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor$ using a full +$O(m^2)$ multiplication algorithm only the lower $m+1$ digits of the product have to be computed. Similarly the value of $a$ can +be reduced modulo $\beta^{m+1}$ before the multiple of $b$ is subtracted which simplifes the subtraction as well. A multiplication that produces +only the lower $m+1$ digits requires ${m^2 + 3m - 2} \over 2$ single precision multiplications. + +With both optimizations in place the algorithm is the algorithm Barrett proposed. It requires $m^2 + 2m - 1$ single precision multiplications which +is considerably faster than the straightforward $3m^2$ method. + +\subsection{The Barrett Algorithm} +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_reduce}. \\ +\textbf{Input}. mp\_int $a$, mp\_int $b$ and $\mu = \lfloor \beta^{2m}/b \rfloor, m = \lceil lg_{\beta}(b) \rceil, (0 \le a < b^2, b > 1)$ \\ +\textbf{Output}. $a \mbox{ (mod }b\mbox{)}$ \\ +\hline \\ +Let $m$ represent the number of digits in $b$. \\ +1. Make a copy of $a$ and store it in $q$. (\textit{mp\_init\_copy}) \\ +2. $q \leftarrow \lfloor q / \beta^{m - 1} \rfloor$ (\textit{mp\_rshd}) \\ +\\ +Produce the quotient. \\ +3. $q \leftarrow q \cdot \mu$ (\textit{note: only produce digits at or above $m-1$}) \\ +4. $q \leftarrow \lfloor q / \beta^{m + 1} \rfloor$ \\ +\\ +Subtract the multiple of modulus from the input. \\ +5. $a \leftarrow a \mbox{ (mod }\beta^{m+1}\mbox{)}$ (\textit{mp\_mod\_2d}) \\ +6. $q \leftarrow q \cdot b \mbox{ (mod }\beta^{m+1}\mbox{)}$ (\textit{s\_mp\_mul\_digs}) \\ +7. $a \leftarrow a - q$ (\textit{mp\_sub}) \\ +\\ +Add $\beta^{m+1}$ if a carry occured. \\ +8. If $a < 0$ then (\textit{mp\_cmp\_d}) \\ +\hspace{3mm}8.1 $q \leftarrow 1$ (\textit{mp\_set}) \\ +\hspace{3mm}8.2 $q \leftarrow q \cdot \beta^{m+1}$ (\textit{mp\_lshd}) \\ +\hspace{3mm}8.3 $a \leftarrow a + q$ \\ +\\ +Now subtract the modulus if the residue is too large (e.g. quotient too small). \\ +9. While $a \ge b$ do (\textit{mp\_cmp}) \\ +\hspace{3mm}9.1 $c \leftarrow a - b$ \\ +10. Clear $q$. \\ +11. Return(\textit{MP\_OKAY}) \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_reduce} +\end{figure} + +\textbf{Algorithm mp\_reduce.} +This algorithm will reduce the input $a$ modulo $b$ in place using the Barrett algorithm. It is loosely based on algorithm 14.42 of HAC +\cite[pp. 602]{HAC} which is based on the paper from Paul Barrett \cite{BARRETT}. The algorithm has several restrictions and assumptions which must +be adhered to for the algorithm to work. + +First the modulus $b$ is assumed to be positive and greater than one. If the modulus were less than or equal to one than subtracting +a multiple of it would either accomplish nothing or actually enlarge the input. The input $a$ must be in the range $0 \le a < b^2$ in order +for the quotient to have enough precision. If $a$ is the product of two numbers that were already reduced modulo $b$, this will not be a problem. +Technically the algorithm will still work if $a \ge b^2$ but it will take much longer to finish. The value of $\mu$ is passed as an argument to this +algorithm and is assumed to be calculated and stored before the algorithm is used. + +Recall that the multiplication for the quotient on step 3 must only produce digits at or above the $m-1$'th position. An algorithm called +$s\_mp\_mul\_high\_digs$ which has not been presented is used to accomplish this task. The algorithm is based on $s\_mp\_mul\_digs$ except that +instead of stopping at a given level of precision it starts at a given level of precision. This optimal algorithm can only be used if the number +of digits in $b$ is very much smaller than $\beta$. + +While it is known that +$a \ge b \cdot \lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor$ only the lower $m+1$ digits are being used to compute the residue, so an implied +``borrow'' from the higher digits might leave a negative result. After the multiple of the modulus has been subtracted from $a$ the residue must be +fixed up in case it is negative. The invariant $\beta^{m+1}$ must be added to the residue to make it positive again. + +The while loop at step 9 will subtract $b$ until the residue is less than $b$. If the algorithm is performed correctly this step is +performed at most twice, and on average once. However, if $a \ge b^2$ than it will iterate substantially more times than it should. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_reduce.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* reduces x mod m, assumes 0 < x < m**2, mu is +018 * precomputed via mp_reduce_setup. +019 * From HAC pp.604 Algorithm 14.42 +020 */ +021 int mp_reduce (mp_int * x, mp_int * m, mp_int * mu) +022 \{ +023 mp_int q; +024 int res, um = m->used; +025 +026 /* q = x */ +027 if ((res = mp_init_copy (&q, x)) != MP_OKAY) \{ +028 return res; +029 \} +030 +031 /* q1 = x / b**(k-1) */ +032 mp_rshd (&q, um - 1); +033 +034 /* according to HAC this optimization is ok */ +035 if (((unsigned long) um) > (((mp_digit)1) << (DIGIT_BIT - 1))) \{ +036 if ((res = mp_mul (&q, mu, &q)) != MP_OKAY) \{ +037 goto CLEANUP; +038 \} +039 \} else \{ +040 #ifdef BN_S_MP_MUL_HIGH_DIGS_C +041 if ((res = s_mp_mul_high_digs (&q, mu, &q, um)) != MP_OKAY) \{ +042 goto CLEANUP; +043 \} +044 #elif defined(BN_FAST_S_MP_MUL_HIGH_DIGS_C) +045 if ((res = fast_s_mp_mul_high_digs (&q, mu, &q, um)) != MP_OKAY) \{ +046 goto CLEANUP; +047 \} +048 #else +049 \{ +050 res = MP_VAL; +051 goto CLEANUP; +052 \} +053 #endif +054 \} +055 +056 /* q3 = q2 / b**(k+1) */ +057 mp_rshd (&q, um + 1); +058 +059 /* x = x mod b**(k+1), quick (no division) */ +060 if ((res = mp_mod_2d (x, DIGIT_BIT * (um + 1), x)) != MP_OKAY) \{ +061 goto CLEANUP; +062 \} +063 +064 /* q = q * m mod b**(k+1), quick (no division) */ +065 if ((res = s_mp_mul_digs (&q, m, &q, um + 1)) != MP_OKAY) \{ +066 goto CLEANUP; +067 \} +068 +069 /* x = x - q */ +070 if ((res = mp_sub (x, &q, x)) != MP_OKAY) \{ +071 goto CLEANUP; +072 \} +073 +074 /* If x < 0, add b**(k+1) to it */ +075 if (mp_cmp_d (x, 0) == MP_LT) \{ +076 mp_set (&q, 1); +077 if ((res = mp_lshd (&q, um + 1)) != MP_OKAY) +078 goto CLEANUP; +079 if ((res = mp_add (x, &q, x)) != MP_OKAY) +080 goto CLEANUP; +081 \} +082 +083 /* Back off if it's too big */ +084 while (mp_cmp (x, m) != MP_LT) \{ +085 if ((res = s_mp_sub (x, m, x)) != MP_OKAY) \{ +086 goto CLEANUP; +087 \} +088 \} +089 +090 CLEANUP: +091 mp_clear (&q); +092 +093 return res; +094 \} +095 #endif +096 +\end{alltt} +\end{small} + +The first multiplication that determines the quotient can be performed by only producing the digits from $m - 1$ and up. This essentially halves +the number of single precision multiplications required. However, the optimization is only safe if $\beta$ is much larger than the number of digits +in the modulus. In the source code this is evaluated on lines 36 to 43 where algorithm s\_mp\_mul\_high\_digs is used when it is +safe to do so. + +\subsection{The Barrett Setup Algorithm} +In order to use algorithm mp\_reduce the value of $\mu$ must be calculated in advance. Ideally this value should be computed once and stored for +future use so that the Barrett algorithm can be used without delay. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_reduce\_setup}. \\ +\textbf{Input}. mp\_int $a$ ($a > 1$) \\ +\textbf{Output}. $\mu \leftarrow \lfloor \beta^{2m}/a \rfloor$ \\ +\hline \\ +1. $\mu \leftarrow 2^{2 \cdot lg(\beta) \cdot m}$ (\textit{mp\_2expt}) \\ +2. $\mu \leftarrow \lfloor \mu / b \rfloor$ (\textit{mp\_div}) \\ +3. Return(\textit{MP\_OKAY}) \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_reduce\_setup} +\end{figure} + +\textbf{Algorithm mp\_reduce\_setup.} +This algorithm computes the reciprocal $\mu$ required for Barrett reduction. First $\beta^{2m}$ is calculated as $2^{2 \cdot lg(\beta) \cdot m}$ which +is equivalent and much faster. The final value is computed by taking the integer quotient of $\lfloor \mu / b \rfloor$. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_reduce\_setup.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* pre-calculate the value required for Barrett reduction +018 * For a given modulus "b" it calulates the value required in "a" +019 */ +020 int mp_reduce_setup (mp_int * a, mp_int * b) +021 \{ +022 int res; +023 +024 if ((res = mp_2expt (a, b->used * 2 * DIGIT_BIT)) != MP_OKAY) \{ +025 return res; +026 \} +027 return mp_div (a, b, a, NULL); +028 \} +029 #endif +030 +\end{alltt} +\end{small} + +This simple routine calculates the reciprocal $\mu$ required by Barrett reduction. Note the extended usage of algorithm mp\_div where the variable +which would received the remainder is passed as NULL. As will be discussed in~\ref{sec:division} the division routine allows both the quotient and the +remainder to be passed as NULL meaning to ignore the value. + +\section{The Montgomery Reduction} +Montgomery reduction\footnote{Thanks to Niels Ferguson for his insightful explanation of the algorithm.} \cite{MONT} is by far the most interesting +form of reduction in common use. It computes a modular residue which is not actually equal to the residue of the input yet instead equal to a +residue times a constant. However, as perplexing as this may sound the algorithm is relatively simple and very efficient. + +Throughout this entire section the variable $n$ will represent the modulus used to form the residue. As will be discussed shortly the value of +$n$ must be odd. The variable $x$ will represent the quantity of which the residue is sought. Similar to the Barrett algorithm the input +is restricted to $0 \le x < n^2$. To begin the description some simple number theory facts must be established. + +\textbf{Fact 1.} Adding $n$ to $x$ does not change the residue since in effect it adds one to the quotient $\lfloor x / n \rfloor$. Another way +to explain this is that $n$ is (\textit{or multiples of $n$ are}) congruent to zero modulo $n$. Adding zero will not change the value of the residue. + +\textbf{Fact 2.} If $x$ is even then performing a division by two in $\Z$ is congruent to $x \cdot 2^{-1} \mbox{ (mod }n\mbox{)}$. Actually +this is an application of the fact that if $x$ is evenly divisible by any $k \in \Z$ then division in $\Z$ will be congruent to +multiplication by $k^{-1}$ modulo $n$. + +From these two simple facts the following simple algorithm can be derived. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{Montgomery Reduction}. \\ +\textbf{Input}. Integer $x$, $n$ and $k$ \\ +\textbf{Output}. $2^{-k}x \mbox{ (mod }n\mbox{)}$ \\ +\hline \\ +1. for $t$ from $1$ to $k$ do \\ +\hspace{3mm}1.1 If $x$ is odd then \\ +\hspace{6mm}1.1.1 $x \leftarrow x + n$ \\ +\hspace{3mm}1.2 $x \leftarrow x/2$ \\ +2. Return $x$. \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm Montgomery Reduction} +\end{figure} + +The algorithm reduces the input one bit at a time using the two congruencies stated previously. Inside the loop $n$, which is odd, is +added to $x$ if $x$ is odd. This forces $x$ to be even which allows the division by two in $\Z$ to be congruent to a modular division by two. Since +$x$ is assumed to be initially much larger than $n$ the addition of $n$ will contribute an insignificant magnitude to $x$. Let $r$ represent the +final result of the Montgomery algorithm. If $k > lg(n)$ and $0 \le x < n^2$ then the final result is limited to +$0 \le r < \lfloor x/2^k \rfloor + n$. As a result at most a single subtraction is required to get the residue desired. + +\begin{figure}[here] +\begin{small} +\begin{center} +\begin{tabular}{|c|l|} +\hline \textbf{Step number ($t$)} & \textbf{Result ($x$)} \\ +\hline $1$ & $x + n = 5812$, $x/2 = 2906$ \\ +\hline $2$ & $x/2 = 1453$ \\ +\hline $3$ & $x + n = 1710$, $x/2 = 855$ \\ +\hline $4$ & $x + n = 1112$, $x/2 = 556$ \\ +\hline $5$ & $x/2 = 278$ \\ +\hline $6$ & $x/2 = 139$ \\ +\hline $7$ & $x + n = 396$, $x/2 = 198$ \\ +\hline $8$ & $x/2 = 99$ \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Example of Montgomery Reduction (I)} +\label{fig:MONT1} +\end{figure} + +Consider the example in figure~\ref{fig:MONT1} which reduces $x = 5555$ modulo $n = 257$ when $k = 8$. The result of the algorithm $r = 99$ is +congruent to the value of $2^{-8} \cdot 5555 \mbox{ (mod }257\mbox{)}$. When $r$ is multiplied by $2^8$ modulo $257$ the correct residue +$r \equiv 158$ is produced. + +Let $k = \lfloor lg(n) \rfloor + 1$ represent the number of bits in $n$. The current algorithm requires $2k^2$ single precision shifts +and $k^2$ single precision additions. At this rate the algorithm is most certainly slower than Barrett reduction and not terribly useful. +Fortunately there exists an alternative representation of the algorithm. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{Montgomery Reduction} (modified I). \\ +\textbf{Input}. Integer $x$, $n$ and $k$ \\ +\textbf{Output}. $2^{-k}x \mbox{ (mod }n\mbox{)}$ \\ +\hline \\ +1. for $t$ from $0$ to $k - 1$ do \\ +\hspace{3mm}1.1 If the $t$'th bit of $x$ is one then \\ +\hspace{6mm}1.1.1 $x \leftarrow x + 2^tn$ \\ +2. Return $x/2^k$. \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm Montgomery Reduction (modified I)} +\end{figure} + +This algorithm is equivalent since $2^tn$ is a multiple of $n$ and the lower $k$ bits of $x$ are zero by step 2. The number of single +precision shifts has now been reduced from $2k^2$ to $k^2 + k$ which is only a small improvement. + +\begin{figure}[here] +\begin{small} +\begin{center} +\begin{tabular}{|c|l|r|} +\hline \textbf{Step number ($t$)} & \textbf{Result ($x$)} & \textbf{Result ($x$) in Binary} \\ +\hline -- & $5555$ & $1010110110011$ \\ +\hline $1$ & $x + 2^{0}n = 5812$ & $1011010110100$ \\ +\hline $2$ & $5812$ & $1011010110100$ \\ +\hline $3$ & $x + 2^{2}n = 6840$ & $1101010111000$ \\ +\hline $4$ & $x + 2^{3}n = 8896$ & $10001011000000$ \\ +\hline $5$ & $8896$ & $10001011000000$ \\ +\hline $6$ & $8896$ & $10001011000000$ \\ +\hline $7$ & $x + 2^{6}n = 25344$ & $110001100000000$ \\ +\hline $8$ & $25344$ & $110001100000000$ \\ +\hline -- & $x/2^k = 99$ & \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Example of Montgomery Reduction (II)} +\label{fig:MONT2} +\end{figure} + +Figure~\ref{fig:MONT2} demonstrates the modified algorithm reducing $x = 5555$ modulo $n = 257$ with $k = 8$. +With this algorithm a single shift right at the end is the only right shift required to reduce the input instead of $k$ right shifts inside the +loop. Note that for the iterations $t = 2, 5, 6$ and $8$ where the result $x$ is not changed. In those iterations the $t$'th bit of $x$ is +zero and the appropriate multiple of $n$ does not need to be added to force the $t$'th bit of the result to zero. + +\subsection{Digit Based Montgomery Reduction} +Instead of computing the reduction on a bit-by-bit basis it is actually much faster to compute it on digit-by-digit basis. Consider the +previous algorithm re-written to compute the Montgomery reduction in this new fashion. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{Montgomery Reduction} (modified II). \\ +\textbf{Input}. Integer $x$, $n$ and $k$ \\ +\textbf{Output}. $\beta^{-k}x \mbox{ (mod }n\mbox{)}$ \\ +\hline \\ +1. for $t$ from $0$ to $k - 1$ do \\ +\hspace{3mm}1.1 $x \leftarrow x + \mu n \beta^t$ \\ +2. Return $x/\beta^k$. \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm Montgomery Reduction (modified II)} +\end{figure} + +The value $\mu n \beta^t$ is a multiple of the modulus $n$ meaning that it will not change the residue. If the first digit of +the value $\mu n \beta^t$ equals the negative (modulo $\beta$) of the $t$'th digit of $x$ then the addition will result in a zero digit. This +problem breaks down to solving the following congruency. + +\begin{center} +\begin{tabular}{rcl} +$x_t + \mu n_0$ & $\equiv$ & $0 \mbox{ (mod }\beta\mbox{)}$ \\ +$\mu n_0$ & $\equiv$ & $-x_t \mbox{ (mod }\beta\mbox{)}$ \\ +$\mu$ & $\equiv$ & $-x_t/n_0 \mbox{ (mod }\beta\mbox{)}$ \\ +\end{tabular} +\end{center} + +In each iteration of the loop on step 1 a new value of $\mu$ must be calculated. The value of $-1/n_0 \mbox{ (mod }\beta\mbox{)}$ is used +extensively in this algorithm and should be precomputed. Let $\rho$ represent the negative of the modular inverse of $n_0$ modulo $\beta$. + +For example, let $\beta = 10$ represent the radix. Let $n = 17$ represent the modulus which implies $k = 2$ and $\rho \equiv 7$. Let $x = 33$ +represent the value to reduce. + +\newpage\begin{figure} +\begin{center} +\begin{tabular}{|c|c|c|} +\hline \textbf{Step ($t$)} & \textbf{Value of $x$} & \textbf{Value of $\mu$} \\ +\hline -- & $33$ & --\\ +\hline $0$ & $33 + \mu n = 50$ & $1$ \\ +\hline $1$ & $50 + \mu n \beta = 900$ & $5$ \\ +\hline +\end{tabular} +\end{center} +\caption{Example of Montgomery Reduction} +\end{figure} + +The final result $900$ is then divided by $\beta^k$ to produce the final result $9$. The first observation is that $9 \nequiv x \mbox{ (mod }n\mbox{)}$ +which implies the result is not the modular residue of $x$ modulo $n$. However, recall that the residue is actually multiplied by $\beta^{-k}$ in +the algorithm. To get the true residue the value must be multiplied by $\beta^k$. In this case $\beta^k \equiv 15 \mbox{ (mod }n\mbox{)}$ and +the correct residue is $9 \cdot 15 \equiv 16 \mbox{ (mod }n\mbox{)}$. + +\subsection{Baseline Montgomery Reduction} +The baseline Montgomery reduction algorithm will produce the residue for any size input. It is designed to be a catch-all algororithm for +Montgomery reductions. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_montgomery\_reduce}. \\ +\textbf{Input}. mp\_int $x$, mp\_int $n$ and a digit $\rho \equiv -1/n_0 \mbox{ (mod }n\mbox{)}$. \\ +\hspace{11.5mm}($0 \le x < n^2, n > 1, (n, \beta) = 1, \beta^k > n$) \\ +\textbf{Output}. $\beta^{-k}x \mbox{ (mod }n\mbox{)}$ \\ +\hline \\ +1. $digs \leftarrow 2n.used + 1$ \\ +2. If $digs < MP\_ARRAY$ and $m.used < \delta$ then \\ +\hspace{3mm}2.1 Use algorithm fast\_mp\_montgomery\_reduce instead. \\ +\\ +Setup $x$ for the reduction. \\ +3. If $x.alloc < digs$ then grow $x$ to $digs$ digits. \\ +4. $x.used \leftarrow digs$ \\ +\\ +Eliminate the lower $k$ digits. \\ +5. For $ix$ from $0$ to $k - 1$ do \\ +\hspace{3mm}5.1 $\mu \leftarrow x_{ix} \cdot \rho \mbox{ (mod }\beta\mbox{)}$ \\ +\hspace{3mm}5.2 $u \leftarrow 0$ \\ +\hspace{3mm}5.3 For $iy$ from $0$ to $k - 1$ do \\ +\hspace{6mm}5.3.1 $\hat r \leftarrow \mu n_{iy} + x_{ix + iy} + u$ \\ +\hspace{6mm}5.3.2 $x_{ix + iy} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\ +\hspace{6mm}5.3.3 $u \leftarrow \lfloor \hat r / \beta \rfloor$ \\ +\hspace{3mm}5.4 While $u > 0$ do \\ +\hspace{6mm}5.4.1 $iy \leftarrow iy + 1$ \\ +\hspace{6mm}5.4.2 $x_{ix + iy} \leftarrow x_{ix + iy} + u$ \\ +\hspace{6mm}5.4.3 $u \leftarrow \lfloor x_{ix+iy} / \beta \rfloor$ \\ +\hspace{6mm}5.4.4 $x_{ix + iy} \leftarrow x_{ix+iy} \mbox{ (mod }\beta\mbox{)}$ \\ +\\ +Divide by $\beta^k$ and fix up as required. \\ +6. $x \leftarrow \lfloor x / \beta^k \rfloor$ \\ +7. If $x \ge n$ then \\ +\hspace{3mm}7.1 $x \leftarrow x - n$ \\ +8. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_montgomery\_reduce} +\end{figure} + +\textbf{Algorithm mp\_montgomery\_reduce.} +This algorithm reduces the input $x$ modulo $n$ in place using the Montgomery reduction algorithm. The algorithm is loosely based +on algorithm 14.32 of \cite[pp.601]{HAC} except it merges the multiplication of $\mu n \beta^t$ with the addition in the inner loop. The +restrictions on this algorithm are fairly easy to adapt to. First $0 \le x < n^2$ bounds the input to numbers in the same range as +for the Barrett algorithm. Additionally if $n > 1$ and $n$ is odd there will exist a modular inverse $\rho$. $\rho$ must be calculated in +advance of this algorithm. Finally the variable $k$ is fixed and a pseudonym for $n.used$. + +Step 2 decides whether a faster Montgomery algorithm can be used. It is based on the Comba technique meaning that there are limits on +the size of the input. This algorithm is discussed in sub-section 6.3.3. + +Step 5 is the main reduction loop of the algorithm. The value of $\mu$ is calculated once per iteration in the outer loop. The inner loop +calculates $x + \mu n \beta^{ix}$ by multiplying $\mu n$ and adding the result to $x$ shifted by $ix$ digits. Both the addition and +multiplication are performed in the same loop to save time and memory. Step 5.4 will handle any additional carries that escape the inner loop. + +Using a quick inspection this algorithm requires $n$ single precision multiplications for the outer loop and $n^2$ single precision multiplications +in the inner loop. In total $n^2 + n$ single precision multiplications which compares favourably to Barrett at $n^2 + 2n - 1$ single precision +multiplications. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_montgomery\_reduce.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* computes xR**-1 == x (mod N) via Montgomery Reduction */ +018 int +019 mp_montgomery_reduce (mp_int * x, mp_int * n, mp_digit rho) +020 \{ +021 int ix, res, digs; +022 mp_digit mu; +023 +024 /* can the fast reduction [comba] method be used? +025 * +026 * Note that unlike in mul you're safely allowed *less* +027 * than the available columns [255 per default] since carries +028 * are fixed up in the inner loop. +029 */ +030 digs = n->used * 2 + 1; +031 if ((digs < MP_WARRAY) && +032 n->used < +033 (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) \{ +034 return fast_mp_montgomery_reduce (x, n, rho); +035 \} +036 +037 /* grow the input as required */ +038 if (x->alloc < digs) \{ +039 if ((res = mp_grow (x, digs)) != MP_OKAY) \{ +040 return res; +041 \} +042 \} +043 x->used = digs; +044 +045 for (ix = 0; ix < n->used; ix++) \{ +046 /* mu = ai * rho mod b +047 * +048 * The value of rho must be precalculated via +049 * montgomery_setup() such that +050 * it equals -1/n0 mod b this allows the +051 * following inner loop to reduce the +052 * input one digit at a time +053 */ +054 mu = (mp_digit) (((mp_word)x->dp[ix]) * ((mp_word)rho) & MP_MASK); +055 +056 /* a = a + mu * m * b**i */ +057 \{ +058 register int iy; +059 register mp_digit *tmpn, *tmpx, u; +060 register mp_word r; +061 +062 /* alias for digits of the modulus */ +063 tmpn = n->dp; +064 +065 /* alias for the digits of x [the input] */ +066 tmpx = x->dp + ix; +067 +068 /* set the carry to zero */ +069 u = 0; +070 +071 /* Multiply and add in place */ +072 for (iy = 0; iy < n->used; iy++) \{ +073 /* compute product and sum */ +074 r = ((mp_word)mu) * ((mp_word)*tmpn++) + +075 ((mp_word) u) + ((mp_word) * tmpx); +076 +077 /* get carry */ +078 u = (mp_digit)(r >> ((mp_word) DIGIT_BIT)); +079 +080 /* fix digit */ +081 *tmpx++ = (mp_digit)(r & ((mp_word) MP_MASK)); +082 \} +083 /* At this point the ix'th digit of x should be zero */ +084 +085 +086 /* propagate carries upwards as required*/ +087 while (u) \{ +088 *tmpx += u; +089 u = *tmpx >> DIGIT_BIT; +090 *tmpx++ &= MP_MASK; +091 \} +092 \} +093 \} +094 +095 /* at this point the n.used'th least +096 * significant digits of x are all zero +097 * which means we can shift x to the +098 * right by n.used digits and the +099 * residue is unchanged. +100 */ +101 +102 /* x = x/b**n.used */ +103 mp_clamp(x); +104 mp_rshd (x, n->used); +105 +106 /* if x >= n then x = x - n */ +107 if (mp_cmp_mag (x, n) != MP_LT) \{ +108 return s_mp_sub (x, n, x); +109 \} +110 +111 return MP_OKAY; +112 \} +113 #endif +114 +\end{alltt} +\end{small} + +This is the baseline implementation of the Montgomery reduction algorithm. Lines 30 to 35 determine if the Comba based +routine can be used instead. Line 48 computes the value of $\mu$ for that particular iteration of the outer loop. + +The multiplication $\mu n \beta^{ix}$ is performed in one step in the inner loop. The alias $tmpx$ refers to the $ix$'th digit of $x$ and +the alias $tmpn$ refers to the modulus $n$. + +\subsection{Faster ``Comba'' Montgomery Reduction} + +The Montgomery reduction requires fewer single precision multiplications than a Barrett reduction, however it is much slower due to the serial +nature of the inner loop. The Barrett reduction algorithm requires two slightly modified multipliers which can be implemented with the Comba +technique. The Montgomery reduction algorithm cannot directly use the Comba technique to any significant advantage since the inner loop calculates +a $k \times 1$ product $k$ times. + +The biggest obstacle is that at the $ix$'th iteration of the outer loop the value of $x_{ix}$ is required to calculate $\mu$. This means the +carries from $0$ to $ix - 1$ must have been propagated upwards to form a valid $ix$'th digit. The solution as it turns out is very simple. +Perform a Comba like multiplier and inside the outer loop just after the inner loop fix up the $ix + 1$'th digit by forwarding the carry. + +With this change in place the Montgomery reduction algorithm can be performed with a Comba style multiplication loop which substantially increases +the speed of the algorithm. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{fast\_mp\_montgomery\_reduce}. \\ +\textbf{Input}. mp\_int $x$, mp\_int $n$ and a digit $\rho \equiv -1/n_0 \mbox{ (mod }n\mbox{)}$. \\ +\hspace{11.5mm}($0 \le x < n^2, n > 1, (n, \beta) = 1, \beta^k > n$) \\ +\textbf{Output}. $\beta^{-k}x \mbox{ (mod }n\mbox{)}$ \\ +\hline \\ +Place an array of \textbf{MP\_WARRAY} mp\_word variables called $\hat W$ on the stack. \\ +1. if $x.alloc < n.used + 1$ then grow $x$ to $n.used + 1$ digits. \\ +Copy the digits of $x$ into the array $\hat W$ \\ +2. For $ix$ from $0$ to $x.used - 1$ do \\ +\hspace{3mm}2.1 $\hat W_{ix} \leftarrow x_{ix}$ \\ +3. For $ix$ from $x.used$ to $2n.used - 1$ do \\ +\hspace{3mm}3.1 $\hat W_{ix} \leftarrow 0$ \\ +Elimiate the lower $k$ digits. \\ +4. for $ix$ from $0$ to $n.used - 1$ do \\ +\hspace{3mm}4.1 $\mu \leftarrow \hat W_{ix} \cdot \rho \mbox{ (mod }\beta\mbox{)}$ \\ +\hspace{3mm}4.2 For $iy$ from $0$ to $n.used - 1$ do \\ +\hspace{6mm}4.2.1 $\hat W_{iy + ix} \leftarrow \hat W_{iy + ix} + \mu \cdot n_{iy}$ \\ +\hspace{3mm}4.3 $\hat W_{ix + 1} \leftarrow \hat W_{ix + 1} + \lfloor \hat W_{ix} / \beta \rfloor$ \\ +Propagate carries upwards. \\ +5. for $ix$ from $n.used$ to $2n.used + 1$ do \\ +\hspace{3mm}5.1 $\hat W_{ix + 1} \leftarrow \hat W_{ix + 1} + \lfloor \hat W_{ix} / \beta \rfloor$ \\ +Shift right and reduce modulo $\beta$ simultaneously. \\ +6. for $ix$ from $0$ to $n.used + 1$ do \\ +\hspace{3mm}6.1 $x_{ix} \leftarrow \hat W_{ix + n.used} \mbox{ (mod }\beta\mbox{)}$ \\ +Zero excess digits and fixup $x$. \\ +7. if $x.used > n.used + 1$ then do \\ +\hspace{3mm}7.1 for $ix$ from $n.used + 1$ to $x.used - 1$ do \\ +\hspace{6mm}7.1.1 $x_{ix} \leftarrow 0$ \\ +8. $x.used \leftarrow n.used + 1$ \\ +9. Clamp excessive digits of $x$. \\ +10. If $x \ge n$ then \\ +\hspace{3mm}10.1 $x \leftarrow x - n$ \\ +11. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm fast\_mp\_montgomery\_reduce} +\end{figure} + +\textbf{Algorithm fast\_mp\_montgomery\_reduce.} +This algorithm will compute the Montgomery reduction of $x$ modulo $n$ using the Comba technique. It is on most computer platforms significantly +faster than algorithm mp\_montgomery\_reduce and algorithm mp\_reduce (\textit{Barrett reduction}). The algorithm has the same restrictions +on the input as the baseline reduction algorithm. An additional two restrictions are imposed on this algorithm. The number of digits $k$ in the +the modulus $n$ must not violate $MP\_WARRAY > 2k +1$ and $n < \delta$. When $\beta = 2^{28}$ this algorithm can be used to reduce modulo +a modulus of at most $3,556$ bits in length. + +As in the other Comba reduction algorithms there is a $\hat W$ array which stores the columns of the product. It is initially filled with the +contents of $x$ with the excess digits zeroed. The reduction loop is very similar the to the baseline loop at heart. The multiplication on step +4.1 can be single precision only since $ab \mbox{ (mod }\beta\mbox{)} \equiv (a \mbox{ mod }\beta)(b \mbox{ mod }\beta)$. Some multipliers such +as those on the ARM processors take a variable length time to complete depending on the number of bytes of result it must produce. By performing +a single precision multiplication instead half the amount of time is spent. + +Also note that digit $\hat W_{ix}$ must have the carry from the $ix - 1$'th digit propagated upwards in order for this to work. That is what step +4.3 will do. In effect over the $n.used$ iterations of the outer loop the $n.used$'th lower columns all have the their carries propagated forwards. Note +how the upper bits of those same words are not reduced modulo $\beta$. This is because those values will be discarded shortly and there is no +point. + +Step 5 will propagate the remainder of the carries upwards. On step 6 the columns are reduced modulo $\beta$ and shifted simultaneously as they are +stored in the destination $x$. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_fast\_mp\_montgomery\_reduce.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* computes xR**-1 == x (mod N) via Montgomery Reduction +018 * +019 * This is an optimized implementation of montgomery_reduce +020 * which uses the comba method to quickly calculate the columns of the +021 * reduction. +022 * +023 * Based on Algorithm 14.32 on pp.601 of HAC. +024 */ +025 int fast_mp_montgomery_reduce (mp_int * x, mp_int * n, mp_digit rho) +026 \{ +027 int ix, res, olduse; +028 mp_word W[MP_WARRAY]; +029 +030 /* get old used count */ +031 olduse = x->used; +032 +033 /* grow a as required */ +034 if (x->alloc < n->used + 1) \{ +035 if ((res = mp_grow (x, n->used + 1)) != MP_OKAY) \{ +036 return res; +037 \} +038 \} +039 +040 /* first we have to get the digits of the input into +041 * an array of double precision words W[...] +042 */ +043 \{ +044 register mp_word *_W; +045 register mp_digit *tmpx; +046 +047 /* alias for the W[] array */ +048 _W = W; +049 +050 /* alias for the digits of x*/ +051 tmpx = x->dp; +052 +053 /* copy the digits of a into W[0..a->used-1] */ +054 for (ix = 0; ix < x->used; ix++) \{ +055 *_W++ = *tmpx++; +056 \} +057 +058 /* zero the high words of W[a->used..m->used*2] */ +059 for (; ix < n->used * 2 + 1; ix++) \{ +060 *_W++ = 0; +061 \} +062 \} +063 +064 /* now we proceed to zero successive digits +065 * from the least significant upwards +066 */ +067 for (ix = 0; ix < n->used; ix++) \{ +068 /* mu = ai * m' mod b +069 * +070 * We avoid a double precision multiplication (which isn't required) +071 * by casting the value down to a mp_digit. Note this requires +072 * that W[ix-1] have the carry cleared (see after the inner loop) +073 */ +074 register mp_digit mu; +075 mu = (mp_digit) (((W[ix] & MP_MASK) * rho) & MP_MASK); +076 +077 /* a = a + mu * m * b**i +078 * +079 * This is computed in place and on the fly. The multiplication +080 * by b**i is handled by offseting which columns the results +081 * are added to. +082 * +083 * Note the comba method normally doesn't handle carries in the +084 * inner loop In this case we fix the carry from the previous +085 * column since the Montgomery reduction requires digits of the +086 * result (so far) [see above] to work. This is +087 * handled by fixing up one carry after the inner loop. The +088 * carry fixups are done in order so after these loops the +089 * first m->used words of W[] have the carries fixed +090 */ +091 \{ +092 register int iy; +093 register mp_digit *tmpn; +094 register mp_word *_W; +095 +096 /* alias for the digits of the modulus */ +097 tmpn = n->dp; +098 +099 /* Alias for the columns set by an offset of ix */ +100 _W = W + ix; +101 +102 /* inner loop */ +103 for (iy = 0; iy < n->used; iy++) \{ +104 *_W++ += ((mp_word)mu) * ((mp_word)*tmpn++); +105 \} +106 \} +107 +108 /* now fix carry for next digit, W[ix+1] */ +109 W[ix + 1] += W[ix] >> ((mp_word) DIGIT_BIT); +110 \} +111 +112 /* now we have to propagate the carries and +113 * shift the words downward [all those least +114 * significant digits we zeroed]. +115 */ +116 \{ +117 register mp_digit *tmpx; +118 register mp_word *_W, *_W1; +119 +120 /* nox fix rest of carries */ +121 +122 /* alias for current word */ +123 _W1 = W + ix; +124 +125 /* alias for next word, where the carry goes */ +126 _W = W + ++ix; +127 +128 for (; ix <= n->used * 2 + 1; ix++) \{ +129 *_W++ += *_W1++ >> ((mp_word) DIGIT_BIT); +130 \} +131 +132 /* copy out, A = A/b**n +133 * +134 * The result is A/b**n but instead of converting from an +135 * array of mp_word to mp_digit than calling mp_rshd +136 * we just copy them in the right order +137 */ +138 +139 /* alias for destination word */ +140 tmpx = x->dp; +141 +142 /* alias for shifted double precision result */ +143 _W = W + n->used; +144 +145 for (ix = 0; ix < n->used + 1; ix++) \{ +146 *tmpx++ = (mp_digit)(*_W++ & ((mp_word) MP_MASK)); +147 \} +148 +149 /* zero oldused digits, if the input a was larger than +150 * m->used+1 we'll have to clear the digits +151 */ +152 for (; ix < olduse; ix++) \{ +153 *tmpx++ = 0; +154 \} +155 \} +156 +157 /* set the max used and clamp */ +158 x->used = n->used + 1; +159 mp_clamp (x); +160 +161 /* if A >= m then A = A - m */ +162 if (mp_cmp_mag (x, n) != MP_LT) \{ +163 return s_mp_sub (x, n, x); +164 \} +165 return MP_OKAY; +166 \} +167 #endif +168 +\end{alltt} +\end{small} + +The $\hat W$ array is first filled with digits of $x$ on line 50 then the rest of the digits are zeroed on line 54. Both loops share +the same alias variables to make the code easier to read. + +The value of $\mu$ is calculated in an interesting fashion. First the value $\hat W_{ix}$ is reduced modulo $\beta$ and cast to a mp\_digit. This +forces the compiler to use a single precision multiplication and prevents any concerns about loss of precision. Line 109 fixes the carry +for the next iteration of the loop by propagating the carry from $\hat W_{ix}$ to $\hat W_{ix+1}$. + +The for loop on line 108 propagates the rest of the carries upwards through the columns. The for loop on line 125 reduces the columns +modulo $\beta$ and shifts them $k$ places at the same time. The alias $\_ \hat W$ actually refers to the array $\hat W$ starting at the $n.used$'th +digit, that is $\_ \hat W_{t} = \hat W_{n.used + t}$. + +\subsection{Montgomery Setup} +To calculate the variable $\rho$ a relatively simple algorithm will be required. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_montgomery\_setup}. \\ +\textbf{Input}. mp\_int $n$ ($n > 1$ and $(n, 2) = 1$) \\ +\textbf{Output}. $\rho \equiv -1/n_0 \mbox{ (mod }\beta\mbox{)}$ \\ +\hline \\ +1. $b \leftarrow n_0$ \\ +2. If $b$ is even return(\textit{MP\_VAL}) \\ +3. $x \leftarrow (((b + 2) \mbox{ AND } 4) << 1) + b$ \\ +4. for $k$ from 0 to $\lceil lg(lg(\beta)) \rceil - 2$ do \\ +\hspace{3mm}4.1 $x \leftarrow x \cdot (2 - bx)$ \\ +5. $\rho \leftarrow \beta - x \mbox{ (mod }\beta\mbox{)}$ \\ +6. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_montgomery\_setup} +\end{figure} + +\textbf{Algorithm mp\_montgomery\_setup.} +This algorithm will calculate the value of $\rho$ required within the Montgomery reduction algorithms. It uses a very interesting trick +to calculate $1/n_0$ when $\beta$ is a power of two. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_montgomery\_setup.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* setups the montgomery reduction stuff */ +018 int +019 mp_montgomery_setup (mp_int * n, mp_digit * rho) +020 \{ +021 mp_digit x, b; +022 +023 /* fast inversion mod 2**k +024 * +025 * Based on the fact that +026 * +027 * XA = 1 (mod 2**n) => (X(2-XA)) A = 1 (mod 2**2n) +028 * => 2*X*A - X*X*A*A = 1 +029 * => 2*(1) - (1) = 1 +030 */ +031 b = n->dp[0]; +032 +033 if ((b & 1) == 0) \{ +034 return MP_VAL; +035 \} +036 +037 x = (((b + 2) & 4) << 1) + b; /* here x*a==1 mod 2**4 */ +038 x *= 2 - b * x; /* here x*a==1 mod 2**8 */ +039 #if !defined(MP_8BIT) +040 x *= 2 - b * x; /* here x*a==1 mod 2**16 */ +041 #endif +042 #if defined(MP_64BIT) || !(defined(MP_8BIT) || defined(MP_16BIT)) +043 x *= 2 - b * x; /* here x*a==1 mod 2**32 */ +044 #endif +045 #ifdef MP_64BIT +046 x *= 2 - b * x; /* here x*a==1 mod 2**64 */ +047 #endif +048 +049 /* rho = -1/m mod b */ +050 *rho = (((mp_word)1 << ((mp_word) DIGIT_BIT)) - x) & MP_MASK; +051 +052 return MP_OKAY; +053 \} +054 #endif +055 +\end{alltt} +\end{small} + +This source code computes the value of $\rho$ required to perform Montgomery reduction. It has been modified to avoid performing excess +multiplications when $\beta$ is not the default 28-bits. + +\section{The Diminished Radix Algorithm} +The Diminished Radix method of modular reduction \cite{DRMET} is a fairly clever technique which can be more efficient than either the Barrett +or Montgomery methods for certain forms of moduli. The technique is based on the following simple congruence. + +\begin{equation} +(x \mbox{ mod } n) + k \lfloor x / n \rfloor \equiv x \mbox{ (mod }(n - k)\mbox{)} +\end{equation} + +This observation was used in the MMB \cite{MMB} block cipher to create a diffusion primitive. It used the fact that if $n = 2^{31}$ and $k=1$ that +then a x86 multiplier could produce the 62-bit product and use the ``shrd'' instruction to perform a double-precision right shift. The proof +of the above equation is very simple. First write $x$ in the product form. + +\begin{equation} +x = qn + r +\end{equation} + +Now reduce both sides modulo $(n - k)$. + +\begin{equation} +x \equiv qk + r \mbox{ (mod }(n-k)\mbox{)} +\end{equation} + +The variable $n$ reduces modulo $n - k$ to $k$. By putting $q = \lfloor x/n \rfloor$ and $r = x \mbox{ mod } n$ +into the equation the original congruence is reproduced, thus concluding the proof. The following algorithm is based on this observation. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{Diminished Radix Reduction}. \\ +\textbf{Input}. Integer $x$, $n$, $k$ \\ +\textbf{Output}. $x \mbox{ mod } (n - k)$ \\ +\hline \\ +1. $q \leftarrow \lfloor x / n \rfloor$ \\ +2. $q \leftarrow k \cdot q$ \\ +3. $x \leftarrow x \mbox{ (mod }n\mbox{)}$ \\ +4. $x \leftarrow x + q$ \\ +5. If $x \ge (n - k)$ then \\ +\hspace{3mm}5.1 $x \leftarrow x - (n - k)$ \\ +\hspace{3mm}5.2 Goto step 1. \\ +6. Return $x$ \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm Diminished Radix Reduction} +\label{fig:DR} +\end{figure} + +This algorithm will reduce $x$ modulo $n - k$ and return the residue. If $0 \le x < (n - k)^2$ then the algorithm will loop almost always +once or twice and occasionally three times. For simplicity sake the value of $x$ is bounded by the following simple polynomial. + +\begin{equation} +0 \le x < n^2 + k^2 - 2nk +\end{equation} + +The true bound is $0 \le x < (n - k - 1)^2$ but this has quite a few more terms. The value of $q$ after step 1 is bounded by the following. + +\begin{equation} +q < n - 2k - k^2/n +\end{equation} + +Since $k^2$ is going to be considerably smaller than $n$ that term will always be zero. The value of $x$ after step 3 is bounded trivially as +$0 \le x < n$. By step four the sum $x + q$ is bounded by + +\begin{equation} +0 \le q + x < (k + 1)n - 2k^2 - 1 +\end{equation} + +With a second pass $q$ will be loosely bounded by $0 \le q < k^2$ after step 2 while $x$ will still be loosely bounded by $0 \le x < n$ after step 3. After the second pass it is highly unlike that the +sum in step 4 will exceed $n - k$. In practice fewer than three passes of the algorithm are required to reduce virtually every input in the +range $0 \le x < (n - k - 1)^2$. + +\begin{figure} +\begin{small} +\begin{center} +\begin{tabular}{|l|} +\hline +$x = 123456789, n = 256, k = 3$ \\ +\hline $q \leftarrow \lfloor x/n \rfloor = 482253$ \\ +$q \leftarrow q*k = 1446759$ \\ +$x \leftarrow x \mbox{ mod } n = 21$ \\ +$x \leftarrow x + q = 1446780$ \\ +$x \leftarrow x - (n - k) = 1446527$ \\ +\hline +$q \leftarrow \lfloor x/n \rfloor = 5650$ \\ +$q \leftarrow q*k = 16950$ \\ +$x \leftarrow x \mbox{ mod } n = 127$ \\ +$x \leftarrow x + q = 17077$ \\ +$x \leftarrow x - (n - k) = 16824$ \\ +\hline +$q \leftarrow \lfloor x/n \rfloor = 65$ \\ +$q \leftarrow q*k = 195$ \\ +$x \leftarrow x \mbox{ mod } n = 184$ \\ +$x \leftarrow x + q = 379$ \\ +$x \leftarrow x - (n - k) = 126$ \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Example Diminished Radix Reduction} +\label{fig:EXDR} +\end{figure} + +Figure~\ref{fig:EXDR} demonstrates the reduction of $x = 123456789$ modulo $n - k = 253$ when $n = 256$ and $k = 3$. Note that even while $x$ +is considerably larger than $(n - k - 1)^2 = 63504$ the algorithm still converges on the modular residue exceedingly fast. In this case only +three passes were required to find the residue $x \equiv 126$. + + +\subsection{Choice of Moduli} +On the surface this algorithm looks like a very expensive algorithm. It requires a couple of subtractions followed by multiplication and other +modular reductions. The usefulness of this algorithm becomes exceedingly clear when an appropriate modulus is chosen. + +Division in general is a very expensive operation to perform. The one exception is when the division is by a power of the radix of representation used. +Division by ten for example is simple for pencil and paper mathematics since it amounts to shifting the decimal place to the right. Similarly division +by two (\textit{or powers of two}) is very simple for binary computers to perform. It would therefore seem logical to choose $n$ of the form $2^p$ +which would imply that $\lfloor x / n \rfloor$ is a simple shift of $x$ right $p$ bits. + +However, there is one operation related to division of power of twos that is even faster than this. If $n = \beta^p$ then the division may be +performed by moving whole digits to the right $p$ places. In practice division by $\beta^p$ is much faster than division by $2^p$ for any $p$. +Also with the choice of $n = \beta^p$ reducing $x$ modulo $n$ merely requires zeroing the digits above the $p-1$'th digit of $x$. + +Throughout the next section the term ``restricted modulus'' will refer to a modulus of the form $\beta^p - k$ whereas the term ``unrestricted +modulus'' will refer to a modulus of the form $2^p - k$. The word ``restricted'' in this case refers to the fact that it is based on the +$2^p$ logic except $p$ must be a multiple of $lg(\beta)$. + +\subsection{Choice of $k$} +Now that division and reduction (\textit{step 1 and 3 of figure~\ref{fig:DR}}) have been optimized to simple digit operations the multiplication by $k$ +in step 2 is the most expensive operation. Fortunately the choice of $k$ is not terribly limited. For all intents and purposes it might +as well be a single digit. The smaller the value of $k$ is the faster the algorithm will be. + +\subsection{Restricted Diminished Radix Reduction} +The restricted Diminished Radix algorithm can quickly reduce an input modulo a modulus of the form $n = \beta^p - k$. This algorithm can reduce +an input $x$ within the range $0 \le x < n^2$ using only a couple passes of the algorithm demonstrated in figure~\ref{fig:DR}. The implementation +of this algorithm has been optimized to avoid additional overhead associated with a division by $\beta^p$, the multiplication by $k$ or the addition +of $x$ and $q$. The resulting algorithm is very efficient and can lead to substantial improvements over Barrett and Montgomery reduction when modular +exponentiations are performed. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_dr\_reduce}. \\ +\textbf{Input}. mp\_int $x$, $n$ and a mp\_digit $k = \beta - n_0$ \\ +\hspace{11.5mm}($0 \le x < n^2$, $n > 1$, $0 < k < \beta$) \\ +\textbf{Output}. $x \mbox{ mod } n$ \\ +\hline \\ +1. $m \leftarrow n.used$ \\ +2. If $x.alloc < 2m$ then grow $x$ to $2m$ digits. \\ +3. $\mu \leftarrow 0$ \\ +4. for $i$ from $0$ to $m - 1$ do \\ +\hspace{3mm}4.1 $\hat r \leftarrow k \cdot x_{m+i} + x_{i} + \mu$ \\ +\hspace{3mm}4.2 $x_{i} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\ +\hspace{3mm}4.3 $\mu \leftarrow \lfloor \hat r / \beta \rfloor$ \\ +5. $x_{m} \leftarrow \mu$ \\ +6. for $i$ from $m + 1$ to $x.used - 1$ do \\ +\hspace{3mm}6.1 $x_{i} \leftarrow 0$ \\ +7. Clamp excess digits of $x$. \\ +8. If $x \ge n$ then \\ +\hspace{3mm}8.1 $x \leftarrow x - n$ \\ +\hspace{3mm}8.2 Goto step 3. \\ +9. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_dr\_reduce} +\end{figure} + +\textbf{Algorithm mp\_dr\_reduce.} +This algorithm will perform the Dimished Radix reduction of $x$ modulo $n$. It has similar restrictions to that of the Barrett reduction +with the addition that $n$ must be of the form $n = \beta^m - k$ where $0 < k <\beta$. + +This algorithm essentially implements the pseudo-code in figure~\ref{fig:DR} except with a slight optimization. The division by $\beta^m$, multiplication by $k$ +and addition of $x \mbox{ mod }\beta^m$ are all performed simultaneously inside the loop on step 4. The division by $\beta^m$ is emulated by accessing +the term at the $m+i$'th position which is subsequently multiplied by $k$ and added to the term at the $i$'th position. After the loop the $m$'th +digit is set to the carry and the upper digits are zeroed. Steps 5 and 6 emulate the reduction modulo $\beta^m$ that should have happend to +$x$ before the addition of the multiple of the upper half. + +At step 8 if $x$ is still larger than $n$ another pass of the algorithm is required. First $n$ is subtracted from $x$ and then the algorithm resumes +at step 3. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_dr\_reduce.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* reduce "x" in place modulo "n" using the Diminished Radix algorithm. +018 * +019 * Based on algorithm from the paper +020 * +021 * "Generating Efficient Primes for Discrete Log Cryptosystems" +022 * Chae Hoon Lim, Pil Joong Lee, +023 * POSTECH Information Research Laboratories +024 * +025 * The modulus must be of a special format [see manual] +026 * +027 * Has been modified to use algorithm 7.10 from the LTM book instead +028 * +029 * Input x must be in the range 0 <= x <= (n-1)**2 +030 */ +031 int +032 mp_dr_reduce (mp_int * x, mp_int * n, mp_digit k) +033 \{ +034 int err, i, m; +035 mp_word r; +036 mp_digit mu, *tmpx1, *tmpx2; +037 +038 /* m = digits in modulus */ +039 m = n->used; +040 +041 /* ensure that "x" has at least 2m digits */ +042 if (x->alloc < m + m) \{ +043 if ((err = mp_grow (x, m + m)) != MP_OKAY) \{ +044 return err; +045 \} +046 \} +047 +048 /* top of loop, this is where the code resumes if +049 * another reduction pass is required. +050 */ +051 top: +052 /* aliases for digits */ +053 /* alias for lower half of x */ +054 tmpx1 = x->dp; +055 +056 /* alias for upper half of x, or x/B**m */ +057 tmpx2 = x->dp + m; +058 +059 /* set carry to zero */ +060 mu = 0; +061 +062 /* compute (x mod B**m) + k * [x/B**m] inline and inplace */ +063 for (i = 0; i < m; i++) \{ +064 r = ((mp_word)*tmpx2++) * ((mp_word)k) + *tmpx1 + mu; +065 *tmpx1++ = (mp_digit)(r & MP_MASK); +066 mu = (mp_digit)(r >> ((mp_word)DIGIT_BIT)); +067 \} +068 +069 /* set final carry */ +070 *tmpx1++ = mu; +071 +072 /* zero words above m */ +073 for (i = m + 1; i < x->used; i++) \{ +074 *tmpx1++ = 0; +075 \} +076 +077 /* clamp, sub and return */ +078 mp_clamp (x); +079 +080 /* if x >= n then subtract and reduce again +081 * Each successive "recursion" makes the input smaller and smaller. +082 */ +083 if (mp_cmp_mag (x, n) != MP_LT) \{ +084 s_mp_sub(x, n, x); +085 goto top; +086 \} +087 return MP_OKAY; +088 \} +089 #endif +090 +\end{alltt} +\end{small} + +The first step is to grow $x$ as required to $2m$ digits since the reduction is performed in place on $x$. The label on line 51 is where +the algorithm will resume if further reduction passes are required. In theory it could be placed at the top of the function however, the size of +the modulus and question of whether $x$ is large enough are invariant after the first pass meaning that it would be a waste of time. + +The aliases $tmpx1$ and $tmpx2$ refer to the digits of $x$ where the latter is offset by $m$ digits. By reading digits from $x$ offset by $m$ digits +a division by $\beta^m$ can be simulated virtually for free. The loop on line 63 performs the bulk of the work (\textit{corresponds to step 4 of algorithm 7.11}) +in this algorithm. + +By line 70 the pointer $tmpx1$ points to the $m$'th digit of $x$ which is where the final carry will be placed. Similarly by line 73 the +same pointer will point to the $m+1$'th digit where the zeroes will be placed. + +Since the algorithm is only valid if both $x$ and $n$ are greater than zero an unsigned comparison suffices to determine if another pass is required. +With the same logic at line 84 the value of $x$ is known to be greater than or equal to $n$ meaning that an unsigned subtraction can be used +as well. Since the destination of the subtraction is the larger of the inputs the call to algorithm s\_mp\_sub cannot fail and the return code +does not need to be checked. + +\subsubsection{Setup} +To setup the restricted Diminished Radix algorithm the value $k = \beta - n_0$ is required. This algorithm is not really complicated but provided for +completeness. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_dr\_setup}. \\ +\textbf{Input}. mp\_int $n$ \\ +\textbf{Output}. $k = \beta - n_0$ \\ +\hline \\ +1. $k \leftarrow \beta - n_0$ \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_dr\_setup} +\end{figure} + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_dr\_setup.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* determines the setup value */ +018 void mp_dr_setup(mp_int *a, mp_digit *d) +019 \{ +020 /* the casts are required if DIGIT_BIT is one less than +021 * the number of bits in a mp_digit [e.g. DIGIT_BIT==31] +022 */ +023 *d = (mp_digit)((((mp_word)1) << ((mp_word)DIGIT_BIT)) - +024 ((mp_word)a->dp[0])); +025 \} +026 +027 #endif +028 +\end{alltt} +\end{small} + +\subsubsection{Modulus Detection} +Another algorithm which will be useful is the ability to detect a restricted Diminished Radix modulus. An integer is said to be +of restricted Diminished Radix form if all of the digits are equal to $\beta - 1$ except the trailing digit which may be any value. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_dr\_is\_modulus}. \\ +\textbf{Input}. mp\_int $n$ \\ +\textbf{Output}. $1$ if $n$ is in D.R form, $0$ otherwise \\ +\hline +1. If $n.used < 2$ then return($0$). \\ +2. for $ix$ from $1$ to $n.used - 1$ do \\ +\hspace{3mm}2.1 If $n_{ix} \ne \beta - 1$ return($0$). \\ +3. Return($1$). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_dr\_is\_modulus} +\end{figure} + +\textbf{Algorithm mp\_dr\_is\_modulus.} +This algorithm determines if a value is in Diminished Radix form. Step 1 rejects obvious cases where fewer than two digits are +in the mp\_int. Step 2 tests all but the first digit to see if they are equal to $\beta - 1$. If the algorithm manages to get to +step 3 then $n$ must be of Diminished Radix form. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_dr\_is\_modulus.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* determines if a number is a valid DR modulus */ +018 int mp_dr_is_modulus(mp_int *a) +019 \{ +020 int ix; +021 +022 /* must be at least two digits */ +023 if (a->used < 2) \{ +024 return 0; +025 \} +026 +027 /* must be of the form b**k - a [a <= b] so all +028 * but the first digit must be equal to -1 (mod b). +029 */ +030 for (ix = 1; ix < a->used; ix++) \{ +031 if (a->dp[ix] != MP_MASK) \{ +032 return 0; +033 \} +034 \} +035 return 1; +036 \} +037 +038 #endif +039 +\end{alltt} +\end{small} + +\subsection{Unrestricted Diminished Radix Reduction} +The unrestricted Diminished Radix algorithm allows modular reductions to be performed when the modulus is of the form $2^p - k$. This algorithm +is a straightforward adaptation of algorithm~\ref{fig:DR}. + +In general the restricted Diminished Radix reduction algorithm is much faster since it has considerably lower overhead. However, this new +algorithm is much faster than either Montgomery or Barrett reduction when the moduli are of the appropriate form. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_reduce\_2k}. \\ +\textbf{Input}. mp\_int $a$ and $n$. mp\_digit $k$ \\ +\hspace{11.5mm}($a \ge 0$, $n > 1$, $0 < k < \beta$, $n + k$ is a power of two) \\ +\textbf{Output}. $a \mbox{ (mod }n\mbox{)}$ \\ +\hline +1. $p \leftarrow \lceil lg(n) \rceil$ (\textit{mp\_count\_bits}) \\ +2. While $a \ge n$ do \\ +\hspace{3mm}2.1 $q \leftarrow \lfloor a / 2^p \rfloor$ (\textit{mp\_div\_2d}) \\ +\hspace{3mm}2.2 $a \leftarrow a \mbox{ (mod }2^p\mbox{)}$ (\textit{mp\_mod\_2d}) \\ +\hspace{3mm}2.3 $q \leftarrow q \cdot k$ (\textit{mp\_mul\_d}) \\ +\hspace{3mm}2.4 $a \leftarrow a - q$ (\textit{s\_mp\_sub}) \\ +\hspace{3mm}2.5 If $a \ge n$ then do \\ +\hspace{6mm}2.5.1 $a \leftarrow a - n$ \\ +3. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_reduce\_2k} +\end{figure} + +\textbf{Algorithm mp\_reduce\_2k.} +This algorithm quickly reduces an input $a$ modulo an unrestricted Diminished Radix modulus $n$. Division by $2^p$ is emulated with a right +shift which makes the algorithm fairly inexpensive to use. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_reduce\_2k.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* reduces a modulo n where n is of the form 2**p - d */ +018 int mp_reduce_2k(mp_int *a, mp_int *n, mp_digit d) +019 \{ +020 mp_int q; +021 int p, res; +022 +023 if ((res = mp_init(&q)) != MP_OKAY) \{ +024 return res; +025 \} +026 +027 p = mp_count_bits(n); +028 top: +029 /* q = a/2**p, a = a mod 2**p */ +030 if ((res = mp_div_2d(a, p, &q, a)) != MP_OKAY) \{ +031 goto ERR; +032 \} +033 +034 if (d != 1) \{ +035 /* q = q * d */ +036 if ((res = mp_mul_d(&q, d, &q)) != MP_OKAY) \{ +037 goto ERR; +038 \} +039 \} +040 +041 /* a = a + q */ +042 if ((res = s_mp_add(a, &q, a)) != MP_OKAY) \{ +043 goto ERR; +044 \} +045 +046 if (mp_cmp_mag(a, n) != MP_LT) \{ +047 s_mp_sub(a, n, a); +048 goto top; +049 \} +050 +051 ERR: +052 mp_clear(&q); +053 return res; +054 \} +055 +056 #endif +057 +\end{alltt} +\end{small} + +The algorithm mp\_count\_bits calculates the number of bits in an mp\_int which is used to find the initial value of $p$. The call to mp\_div\_2d +on line 30 calculates both the quotient $q$ and the remainder $a$ required. By doing both in a single function call the code size +is kept fairly small. The multiplication by $k$ is only performed if $k > 1$. This allows reductions modulo $2^p - 1$ to be performed without +any multiplications. + +The unsigned s\_mp\_add, mp\_cmp\_mag and s\_mp\_sub are used in place of their full sign counterparts since the inputs are only valid if they are +positive. By using the unsigned versions the overhead is kept to a minimum. + +\subsubsection{Unrestricted Setup} +To setup this reduction algorithm the value of $k = 2^p - n$ is required. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_reduce\_2k\_setup}. \\ +\textbf{Input}. mp\_int $n$ \\ +\textbf{Output}. $k = 2^p - n$ \\ +\hline +1. $p \leftarrow \lceil lg(n) \rceil$ (\textit{mp\_count\_bits}) \\ +2. $x \leftarrow 2^p$ (\textit{mp\_2expt}) \\ +3. $x \leftarrow x - n$ (\textit{mp\_sub}) \\ +4. $k \leftarrow x_0$ \\ +5. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_reduce\_2k\_setup} +\end{figure} + +\textbf{Algorithm mp\_reduce\_2k\_setup.} +This algorithm computes the value of $k$ required for the algorithm mp\_reduce\_2k. By making a temporary variable $x$ equal to $2^p$ a subtraction +is sufficient to solve for $k$. Alternatively if $n$ has more than one digit the value of $k$ is simply $\beta - n_0$. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_reduce\_2k\_setup.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* determines the setup value */ +018 int mp_reduce_2k_setup(mp_int *a, mp_digit *d) +019 \{ +020 int res, p; +021 mp_int tmp; +022 +023 if ((res = mp_init(&tmp)) != MP_OKAY) \{ +024 return res; +025 \} +026 +027 p = mp_count_bits(a); +028 if ((res = mp_2expt(&tmp, p)) != MP_OKAY) \{ +029 mp_clear(&tmp); +030 return res; +031 \} +032 +033 if ((res = s_mp_sub(&tmp, a, &tmp)) != MP_OKAY) \{ +034 mp_clear(&tmp); +035 return res; +036 \} +037 +038 *d = tmp.dp[0]; +039 mp_clear(&tmp); +040 return MP_OKAY; +041 \} +042 #endif +043 +\end{alltt} +\end{small} + +\subsubsection{Unrestricted Detection} +An integer $n$ is a valid unrestricted Diminished Radix modulus if either of the following are true. + +\begin{enumerate} +\item The number has only one digit. +\item The number has more than one digit and every bit from the $\beta$'th to the most significant is one. +\end{enumerate} + +If either condition is true than there is a power of two $2^p$ such that $0 < 2^p - n < \beta$. If the input is only +one digit than it will always be of the correct form. Otherwise all of the bits above the first digit must be one. This arises from the fact +that there will be value of $k$ that when added to the modulus causes a carry in the first digit which propagates all the way to the most +significant bit. The resulting sum will be a power of two. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_reduce\_is\_2k}. \\ +\textbf{Input}. mp\_int $n$ \\ +\textbf{Output}. $1$ if of proper form, $0$ otherwise \\ +\hline +1. If $n.used = 0$ then return($0$). \\ +2. If $n.used = 1$ then return($1$). \\ +3. $p \leftarrow \lceil lg(n) \rceil$ (\textit{mp\_count\_bits}) \\ +4. for $x$ from $lg(\beta)$ to $p$ do \\ +\hspace{3mm}4.1 If the ($x \mbox{ mod }lg(\beta)$)'th bit of the $\lfloor x / lg(\beta) \rfloor$ of $n$ is zero then return($0$). \\ +5. Return($1$). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_reduce\_is\_2k} +\end{figure} + +\textbf{Algorithm mp\_reduce\_is\_2k.} +This algorithm quickly determines if a modulus is of the form required for algorithm mp\_reduce\_2k to function properly. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_reduce\_is\_2k.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* determines if mp_reduce_2k can be used */ +018 int mp_reduce_is_2k(mp_int *a) +019 \{ +020 int ix, iy, iw; +021 mp_digit iz; +022 +023 if (a->used == 0) \{ +024 return MP_NO; +025 \} else if (a->used == 1) \{ +026 return MP_YES; +027 \} else if (a->used > 1) \{ +028 iy = mp_count_bits(a); +029 iz = 1; +030 iw = 1; +031 +032 /* Test every bit from the second digit up, must be 1 */ +033 for (ix = DIGIT_BIT; ix < iy; ix++) \{ +034 if ((a->dp[iw] & iz) == 0) \{ +035 return MP_NO; +036 \} +037 iz <<= 1; +038 if (iz > (mp_digit)MP_MASK) \{ +039 ++iw; +040 iz = 1; +041 \} +042 \} +043 \} +044 return MP_YES; +045 \} +046 +047 #endif +048 +\end{alltt} +\end{small} + + + +\section{Algorithm Comparison} +So far three very different algorithms for modular reduction have been discussed. Each of the algorithms have their own strengths and weaknesses +that makes having such a selection very useful. The following table sumarizes the three algorithms along with comparisons of work factors. Since +all three algorithms have the restriction that $0 \le x < n^2$ and $n > 1$ those limitations are not included in the table. + +\begin{center} +\begin{small} +\begin{tabular}{|c|c|c|c|c|c|} +\hline \textbf{Method} & \textbf{Work Required} & \textbf{Limitations} & \textbf{$m = 8$} & \textbf{$m = 32$} & \textbf{$m = 64$} \\ +\hline Barrett & $m^2 + 2m - 1$ & None & $79$ & $1087$ & $4223$ \\ +\hline Montgomery & $m^2 + m$ & $n$ must be odd & $72$ & $1056$ & $4160$ \\ +\hline D.R. & $2m$ & $n = \beta^m - k$ & $16$ & $64$ & $128$ \\ +\hline +\end{tabular} +\end{small} +\end{center} + +In theory Montgomery and Barrett reductions would require roughly the same amount of time to complete. However, in practice since Montgomery +reduction can be written as a single function with the Comba technique it is much faster. Barrett reduction suffers from the overhead of +calling the half precision multipliers, addition and division by $\beta$ algorithms. + +For almost every cryptographic algorithm Montgomery reduction is the algorithm of choice. The one set of algorithms where Diminished Radix reduction truly +shines are based on the discrete logarithm problem such as Diffie-Hellman \cite{DH} and ElGamal \cite{ELGAMAL}. In these algorithms +primes of the form $\beta^m - k$ can be found and shared amongst users. These primes will allow the Diminished Radix algorithm to be used in +modular exponentiation to greatly speed up the operation. + + + +\section*{Exercises} +\begin{tabular}{cl} +$\left [ 3 \right ]$ & Prove that the ``trick'' in algorithm mp\_montgomery\_setup actually \\ + & calculates the correct value of $\rho$. \\ + & \\ +$\left [ 2 \right ]$ & Devise an algorithm to reduce modulo $n + k$ for small $k$ quickly. \\ + & \\ +$\left [ 4 \right ]$ & Prove that the pseudo-code algorithm ``Diminished Radix Reduction'' \\ + & (\textit{figure~\ref{fig:DR}}) terminates. Also prove the probability that it will \\ + & terminate within $1 \le k \le 10$ iterations. \\ + & \\ +\end{tabular} + + +\chapter{Exponentiation} +Exponentiation is the operation of raising one variable to the power of another, for example, $a^b$. A variant of exponentiation, computed +in a finite field or ring, is called modular exponentiation. This latter style of operation is typically used in public key +cryptosystems such as RSA and Diffie-Hellman. The ability to quickly compute modular exponentiations is of great benefit to any +such cryptosystem and many methods have been sought to speed it up. + +\section{Exponentiation Basics} +A trivial algorithm would simply multiply $a$ against itself $b - 1$ times to compute the exponentiation desired. However, as $b$ grows in size +the number of multiplications becomes prohibitive. Imagine what would happen if $b$ $\approx$ $2^{1024}$ as is the case when computing an RSA signature +with a $1024$-bit key. Such a calculation could never be completed as it would take simply far too long. + +Fortunately there is a very simple algorithm based on the laws of exponents. Recall that $lg_a(a^b) = b$ and that $lg_a(a^ba^c) = b + c$ which +are two trivial relationships between the base and the exponent. Let $b_i$ represent the $i$'th bit of $b$ starting from the least +significant bit. If $b$ is a $k$-bit integer than the following equation is true. + +\begin{equation} +a^b = \prod_{i=0}^{k-1} a^{2^i \cdot b_i} +\end{equation} + +By taking the base $a$ logarithm of both sides of the equation the following equation is the result. + +\begin{equation} +b = \sum_{i=0}^{k-1}2^i \cdot b_i +\end{equation} + +The term $a^{2^i}$ can be found from the $i - 1$'th term by squaring the term since $\left ( a^{2^i} \right )^2$ is equal to +$a^{2^{i+1}}$. This observation forms the basis of essentially all fast exponentiation algorithms. It requires $k$ squarings and on average +$k \over 2$ multiplications to compute the result. This is indeed quite an improvement over simply multiplying by $a$ a total of $b-1$ times. + +While this current method is a considerable speed up there are further improvements to be made. For example, the $a^{2^i}$ term does not need to +be computed in an auxilary variable. Consider the following equivalent algorithm. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{Left to Right Exponentiation}. \\ +\textbf{Input}. Integer $a$, $b$ and $k$ \\ +\textbf{Output}. $c = a^b$ \\ +\hline \\ +1. $c \leftarrow 1$ \\ +2. for $i$ from $k - 1$ to $0$ do \\ +\hspace{3mm}2.1 $c \leftarrow c^2$ \\ +\hspace{3mm}2.2 $c \leftarrow c \cdot a^{b_i}$ \\ +3. Return $c$. \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Left to Right Exponentiation} +\label{fig:LTOR} +\end{figure} + +This algorithm starts from the most significant bit and works towards the least significant bit. When the $i$'th bit of $b$ is set $a$ is +multiplied against the current product. In each iteration the product is squared which doubles the exponent of the individual terms of the +product. + +For example, let $b = 101100_2 \equiv 44_{10}$. The following chart demonstrates the actions of the algorithm. + +\newpage\begin{figure} +\begin{center} +\begin{tabular}{|c|c|} +\hline \textbf{Value of $i$} & \textbf{Value of $c$} \\ +\hline - & $1$ \\ +\hline $5$ & $a$ \\ +\hline $4$ & $a^2$ \\ +\hline $3$ & $a^4 \cdot a$ \\ +\hline $2$ & $a^8 \cdot a^2 \cdot a$ \\ +\hline $1$ & $a^{16} \cdot a^4 \cdot a^2$ \\ +\hline $0$ & $a^{32} \cdot a^8 \cdot a^4$ \\ +\hline +\end{tabular} +\end{center} +\caption{Example of Left to Right Exponentiation} +\end{figure} + +When the product $a^{32} \cdot a^8 \cdot a^4$ is simplified it is equal $a^{44}$ which is the desired exponentiation. This particular algorithm is +called ``Left to Right'' because it reads the exponent in that order. All of the exponentiation algorithms that will be presented are of this nature. + +\subsection{Single Digit Exponentiation} +The first algorithm in the series of exponentiation algorithms will be an unbounded algorithm where the exponent is a single digit. It is intended +to be used when a small power of an input is required (\textit{e.g. $a^5$}). It is faster than simply multiplying $b - 1$ times for all values of +$b$ that are greater than three. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_expt\_d}. \\ +\textbf{Input}. mp\_int $a$ and mp\_digit $b$ \\ +\textbf{Output}. $c = a^b$ \\ +\hline \\ +1. $g \leftarrow a$ (\textit{mp\_init\_copy}) \\ +2. $c \leftarrow 1$ (\textit{mp\_set}) \\ +3. for $x$ from 1 to $lg(\beta)$ do \\ +\hspace{3mm}3.1 $c \leftarrow c^2$ (\textit{mp\_sqr}) \\ +\hspace{3mm}3.2 If $b$ AND $2^{lg(\beta) - 1} \ne 0$ then \\ +\hspace{6mm}3.2.1 $c \leftarrow c \cdot g$ (\textit{mp\_mul}) \\ +\hspace{3mm}3.3 $b \leftarrow b << 1$ \\ +4. Clear $g$. \\ +5. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_expt\_d} +\end{figure} + +\textbf{Algorithm mp\_expt\_d.} +This algorithm computes the value of $a$ raised to the power of a single digit $b$. It uses the left to right exponentiation algorithm to +quickly compute the exponentiation. It is loosely based on algorithm 14.79 of HAC \cite[pp. 615]{HAC} with the difference that the +exponent is a fixed width. + +A copy of $a$ is made first to allow destination variable $c$ be the same as the source variable $a$. The result is set to the initial value of +$1$ in the subsequent step. + +Inside the loop the exponent is read from the most significant bit first down to the least significant bit. First $c$ is invariably squared +on step 3.1. In the following step if the most significant bit of $b$ is one the copy of $a$ is multiplied against $c$. The value +of $b$ is shifted left one bit to make the next bit down from the most signficant bit the new most significant bit. In effect each +iteration of the loop moves the bits of the exponent $b$ upwards to the most significant location. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_expt\_d.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* calculate c = a**b using a square-multiply algorithm */ +018 int mp_expt_d (mp_int * a, mp_digit b, mp_int * c) +019 \{ +020 int res, x; +021 mp_int g; +022 +023 if ((res = mp_init_copy (&g, a)) != MP_OKAY) \{ +024 return res; +025 \} +026 +027 /* set initial result */ +028 mp_set (c, 1); +029 +030 for (x = 0; x < (int) DIGIT_BIT; x++) \{ +031 /* square */ +032 if ((res = mp_sqr (c, c)) != MP_OKAY) \{ +033 mp_clear (&g); +034 return res; +035 \} +036 +037 /* if the bit is set multiply */ +038 if ((b & (mp_digit) (((mp_digit)1) << (DIGIT_BIT - 1))) != 0) \{ +039 if ((res = mp_mul (c, &g, c)) != MP_OKAY) \{ +040 mp_clear (&g); +041 return res; +042 \} +043 \} +044 +045 /* shift to next bit */ +046 b <<= 1; +047 \} +048 +049 mp_clear (&g); +050 return MP_OKAY; +051 \} +052 #endif +053 +\end{alltt} +\end{small} + +Line 28 sets the initial value of the result to $1$. Next the loop on line 30 steps through each bit of the exponent starting from +the most significant down towards the least significant. The invariant squaring operation placed on line 32 is performed first. After +the squaring the result $c$ is multiplied by the base $g$ if and only if the most significant bit of the exponent is set. The shift on line +46 moves all of the bits of the exponent upwards towards the most significant location. + +\section{$k$-ary Exponentiation} +When calculating an exponentiation the most time consuming bottleneck is the multiplications which are in general a small factor +slower than squaring. Recall from the previous algorithm that $b_{i}$ refers to the $i$'th bit of the exponent $b$. Suppose instead it referred to +the $i$'th $k$-bit digit of the exponent of $b$. For $k = 1$ the definitions are synonymous and for $k > 1$ algorithm~\ref{fig:KARY} +computes the same exponentiation. A group of $k$ bits from the exponent is called a \textit{window}. That is it is a small window on only a +portion of the entire exponent. Consider the following modification to the basic left to right exponentiation algorithm. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{$k$-ary Exponentiation}. \\ +\textbf{Input}. Integer $a$, $b$, $k$ and $t$ \\ +\textbf{Output}. $c = a^b$ \\ +\hline \\ +1. $c \leftarrow 1$ \\ +2. for $i$ from $t - 1$ to $0$ do \\ +\hspace{3mm}2.1 $c \leftarrow c^{2^k} $ \\ +\hspace{3mm}2.2 Extract the $i$'th $k$-bit word from $b$ and store it in $g$. \\ +\hspace{3mm}2.3 $c \leftarrow c \cdot a^g$ \\ +3. Return $c$. \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{$k$-ary Exponentiation} +\label{fig:KARY} +\end{figure} + +The squaring on step 2.1 can be calculated by squaring the value $c$ successively $k$ times. If the values of $a^g$ for $0 < g < 2^k$ have been +precomputed this algorithm requires only $t$ multiplications and $tk$ squarings. The table can be generated with $2^{k - 1} - 1$ squarings and +$2^{k - 1} + 1$ multiplications. This algorithm assumes that the number of bits in the exponent is evenly divisible by $k$. +However, when it is not the remaining $0 < x \le k - 1$ bits can be handled with algorithm~\ref{fig:LTOR}. + +Suppose $k = 4$ and $t = 100$. This modified algorithm will require $109$ multiplications and $408$ squarings to compute the exponentiation. The +original algorithm would on average have required $200$ multiplications and $400$ squrings to compute the same value. The total number of squarings +has increased slightly but the number of multiplications has nearly halved. + +\subsection{Optimal Values of $k$} +An optimal value of $k$ will minimize $2^{k} + \lceil n / k \rceil + n - 1$ for a fixed number of bits in the exponent $n$. The simplest +approach is to brute force search amongst the values $k = 2, 3, \ldots, 8$ for the lowest result. Table~\ref{fig:OPTK} lists optimal values of $k$ +for various exponent sizes and compares the number of multiplication and squarings required against algorithm~\ref{fig:LTOR}. + +\begin{figure}[here] +\begin{center} +\begin{small} +\begin{tabular}{|c|c|c|c|c|c|} +\hline \textbf{Exponent (bits)} & \textbf{Optimal $k$} & \textbf{Work at $k$} & \textbf{Work with ~\ref{fig:LTOR}} \\ +\hline $16$ & $2$ & $27$ & $24$ \\ +\hline $32$ & $3$ & $49$ & $48$ \\ +\hline $64$ & $3$ & $92$ & $96$ \\ +\hline $128$ & $4$ & $175$ & $192$ \\ +\hline $256$ & $4$ & $335$ & $384$ \\ +\hline $512$ & $5$ & $645$ & $768$ \\ +\hline $1024$ & $6$ & $1257$ & $1536$ \\ +\hline $2048$ & $6$ & $2452$ & $3072$ \\ +\hline $4096$ & $7$ & $4808$ & $6144$ \\ +\hline +\end{tabular} +\end{small} +\end{center} +\caption{Optimal Values of $k$ for $k$-ary Exponentiation} +\label{fig:OPTK} +\end{figure} + +\subsection{Sliding-Window Exponentiation} +A simple modification to the previous algorithm is only generate the upper half of the table in the range $2^{k-1} \le g < 2^k$. Essentially +this is a table for all values of $g$ where the most significant bit of $g$ is a one. However, in order for this to be allowed in the +algorithm values of $g$ in the range $0 \le g < 2^{k-1}$ must be avoided. + +Table~\ref{fig:OPTK2} lists optimal values of $k$ for various exponent sizes and compares the work required against algorithm~\ref{fig:KARY}. + +\begin{figure}[here] +\begin{center} +\begin{small} +\begin{tabular}{|c|c|c|c|c|c|} +\hline \textbf{Exponent (bits)} & \textbf{Optimal $k$} & \textbf{Work at $k$} & \textbf{Work with ~\ref{fig:KARY}} \\ +\hline $16$ & $3$ & $24$ & $27$ \\ +\hline $32$ & $3$ & $45$ & $49$ \\ +\hline $64$ & $4$ & $87$ & $92$ \\ +\hline $128$ & $4$ & $167$ & $175$ \\ +\hline $256$ & $5$ & $322$ & $335$ \\ +\hline $512$ & $6$ & $628$ & $645$ \\ +\hline $1024$ & $6$ & $1225$ & $1257$ \\ +\hline $2048$ & $7$ & $2403$ & $2452$ \\ +\hline $4096$ & $8$ & $4735$ & $4808$ \\ +\hline +\end{tabular} +\end{small} +\end{center} +\caption{Optimal Values of $k$ for Sliding Window Exponentiation} +\label{fig:OPTK2} +\end{figure} + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{Sliding Window $k$-ary Exponentiation}. \\ +\textbf{Input}. Integer $a$, $b$, $k$ and $t$ \\ +\textbf{Output}. $c = a^b$ \\ +\hline \\ +1. $c \leftarrow 1$ \\ +2. for $i$ from $t - 1$ to $0$ do \\ +\hspace{3mm}2.1 If the $i$'th bit of $b$ is a zero then \\ +\hspace{6mm}2.1.1 $c \leftarrow c^2$ \\ +\hspace{3mm}2.2 else do \\ +\hspace{6mm}2.2.1 $c \leftarrow c^{2^k}$ \\ +\hspace{6mm}2.2.2 Extract the $k$ bits from $(b_{i}b_{i-1}\ldots b_{i-(k-1)})$ and store it in $g$. \\ +\hspace{6mm}2.2.3 $c \leftarrow c \cdot a^g$ \\ +\hspace{6mm}2.2.4 $i \leftarrow i - k$ \\ +3. Return $c$. \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Sliding Window $k$-ary Exponentiation} +\end{figure} + +Similar to the previous algorithm this algorithm must have a special handler when fewer than $k$ bits are left in the exponent. While this +algorithm requires the same number of squarings it can potentially have fewer multiplications. The pre-computed table $a^g$ is also half +the size as the previous table. + +Consider the exponent $b = 111101011001000_2 \equiv 31432_{10}$ with $k = 3$ using both algorithms. The first algorithm will divide the exponent up as +the following five $3$-bit words $b \equiv \left ( 111, 101, 011, 001, 000 \right )_{2}$. The second algorithm will break the +exponent as $b \equiv \left ( 111, 101, 0, 110, 0, 100, 0 \right )_{2}$. The single digit $0$ in the second representation are where +a single squaring took place instead of a squaring and multiplication. In total the first method requires $10$ multiplications and $18$ +squarings. The second method requires $8$ multiplications and $18$ squarings. + +In general the sliding window method is never slower than the generic $k$-ary method and often it is slightly faster. + +\section{Modular Exponentiation} + +Modular exponentiation is essentially computing the power of a base within a finite field or ring. For example, computing +$d \equiv a^b \mbox{ (mod }c\mbox{)}$ is a modular exponentiation. Instead of first computing $a^b$ and then reducing it +modulo $c$ the intermediate result is reduced modulo $c$ after every squaring or multiplication operation. + +This guarantees that any intermediate result is bounded by $0 \le d \le c^2 - 2c + 1$ and can be reduced modulo $c$ quickly using +one of the algorithms presented in chapter six. + +Before the actual modular exponentiation algorithm can be written a wrapper algorithm must be written first. This algorithm +will allow the exponent $b$ to be negative which is computed as $c \equiv \left (1 / a \right )^{\vert b \vert} \mbox{(mod }d\mbox{)}$. The +value of $(1/a) \mbox{ mod }c$ is computed using the modular inverse (\textit{see \ref{sec;modinv}}). If no inverse exists the algorithm +terminates with an error. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_exptmod}. \\ +\textbf{Input}. mp\_int $a$, $b$ and $c$ \\ +\textbf{Output}. $y \equiv g^x \mbox{ (mod }p\mbox{)}$ \\ +\hline \\ +1. If $c.sign = MP\_NEG$ return(\textit{MP\_VAL}). \\ +2. If $b.sign = MP\_NEG$ then \\ +\hspace{3mm}2.1 $g' \leftarrow g^{-1} \mbox{ (mod }c\mbox{)}$ \\ +\hspace{3mm}2.2 $x' \leftarrow \vert x \vert$ \\ +\hspace{3mm}2.3 Compute $d \equiv g'^{x'} \mbox{ (mod }c\mbox{)}$ via recursion. \\ +3. if $p$ is odd \textbf{OR} $p$ is a D.R. modulus then \\ +\hspace{3mm}3.1 Compute $y \equiv g^{x} \mbox{ (mod }p\mbox{)}$ via algorithm mp\_exptmod\_fast. \\ +4. else \\ +\hspace{3mm}4.1 Compute $y \equiv g^{x} \mbox{ (mod }p\mbox{)}$ via algorithm s\_mp\_exptmod. \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_exptmod} +\end{figure} + +\textbf{Algorithm mp\_exptmod.} +The first algorithm which actually performs modular exponentiation is algorithm s\_mp\_exptmod. It is a sliding window $k$-ary algorithm +which uses Barrett reduction to reduce the product modulo $p$. The second algorithm mp\_exptmod\_fast performs the same operation +except it uses either Montgomery or Diminished Radix reduction. The two latter reduction algorithms are clumped in the same exponentiation +algorithm since their arguments are essentially the same (\textit{two mp\_ints and one mp\_digit}). + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_exptmod.c +\vspace{-3mm} +\begin{alltt} +016 +017 +018 /* this is a shell function that calls either the normal or Montgomery +019 * exptmod functions. Originally the call to the montgomery code was +020 * embedded in the normal function but that wasted alot of stack space +021 * for nothing (since 99% of the time the Montgomery code would be called) +022 */ +023 int mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y) +024 \{ +025 int dr; +026 +027 /* modulus P must be positive */ +028 if (P->sign == MP_NEG) \{ +029 return MP_VAL; +030 \} +031 +032 /* if exponent X is negative we have to recurse */ +033 if (X->sign == MP_NEG) \{ +034 #ifdef BN_MP_INVMOD_C +035 mp_int tmpG, tmpX; +036 int err; +037 +038 /* first compute 1/G mod P */ +039 if ((err = mp_init(&tmpG)) != MP_OKAY) \{ +040 return err; +041 \} +042 if ((err = mp_invmod(G, P, &tmpG)) != MP_OKAY) \{ +043 mp_clear(&tmpG); +044 return err; +045 \} +046 +047 /* now get |X| */ +048 if ((err = mp_init(&tmpX)) != MP_OKAY) \{ +049 mp_clear(&tmpG); +050 return err; +051 \} +052 if ((err = mp_abs(X, &tmpX)) != MP_OKAY) \{ +053 mp_clear_multi(&tmpG, &tmpX, NULL); +054 return err; +055 \} +056 +057 /* and now compute (1/G)**|X| instead of G**X [X < 0] */ +058 err = mp_exptmod(&tmpG, &tmpX, P, Y); +059 mp_clear_multi(&tmpG, &tmpX, NULL); +060 return err; +061 #else +062 /* no invmod */ +063 return MP_VAL; +064 #endif +065 \} +066 +067 /* modified diminished radix reduction */ +068 #if defined(BN_MP_REDUCE_IS_2K_L_C) && defined(BN_MP_REDUCE_2K_L_C) && defin + ed(BN_S_MP_EXPTMOD_C) +069 if (mp_reduce_is_2k_l(P) == MP_YES) \{ +070 return s_mp_exptmod(G, X, P, Y, 1); +071 \} +072 #endif +073 +074 #ifdef BN_MP_DR_IS_MODULUS_C +075 /* is it a DR modulus? */ +076 dr = mp_dr_is_modulus(P); +077 #else +078 /* default to no */ +079 dr = 0; +080 #endif +081 +082 #ifdef BN_MP_REDUCE_IS_2K_C +083 /* if not, is it a unrestricted DR modulus? */ +084 if (dr == 0) \{ +085 dr = mp_reduce_is_2k(P) << 1; +086 \} +087 #endif +088 +089 /* if the modulus is odd or dr != 0 use the montgomery method */ +090 #ifdef BN_MP_EXPTMOD_FAST_C +091 if (mp_isodd (P) == 1 || dr != 0) \{ +092 return mp_exptmod_fast (G, X, P, Y, dr); +093 \} else \{ +094 #endif +095 #ifdef BN_S_MP_EXPTMOD_C +096 /* otherwise use the generic Barrett reduction technique */ +097 return s_mp_exptmod (G, X, P, Y, 0); +098 #else +099 /* no exptmod for evens */ +100 return MP_VAL; +101 #endif +102 #ifdef BN_MP_EXPTMOD_FAST_C +103 \} +104 #endif +105 \} +106 +107 #endif +108 +\end{alltt} +\end{small} + +In order to keep the algorithms in a known state the first step on line 28 is to reject any negative modulus as input. If the exponent is +negative the algorithm tries to perform a modular exponentiation with the modular inverse of the base $G$. The temporary variable $tmpG$ is assigned +the modular inverse of $G$ and $tmpX$ is assigned the absolute value of $X$. The algorithm will recuse with these new values with a positive +exponent. + +If the exponent is positive the algorithm resumes the exponentiation. Line 76 determines if the modulus is of the restricted Diminished Radix +form. If it is not line 69 attempts to determine if it is of a unrestricted Diminished Radix form. The integer $dr$ will take on one +of three values. + +\begin{enumerate} +\item $dr = 0$ means that the modulus is not of either restricted or unrestricted Diminished Radix form. +\item $dr = 1$ means that the modulus is of restricted Diminished Radix form. +\item $dr = 2$ means that the modulus is of unrestricted Diminished Radix form. +\end{enumerate} + +Line 69 determines if the fast modular exponentiation algorithm can be used. It is allowed if $dr \ne 0$ or if the modulus is odd. Otherwise, +the slower s\_mp\_exptmod algorithm is used which uses Barrett reduction. + +\subsection{Barrett Modular Exponentiation} + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{s\_mp\_exptmod}. \\ +\textbf{Input}. mp\_int $a$, $b$ and $c$ \\ +\textbf{Output}. $y \equiv g^x \mbox{ (mod }p\mbox{)}$ \\ +\hline \\ +1. $k \leftarrow lg(x)$ \\ +2. $winsize \leftarrow \left \lbrace \begin{array}{ll} + 2 & \mbox{if }k \le 7 \\ + 3 & \mbox{if }7 < k \le 36 \\ + 4 & \mbox{if }36 < k \le 140 \\ + 5 & \mbox{if }140 < k \le 450 \\ + 6 & \mbox{if }450 < k \le 1303 \\ + 7 & \mbox{if }1303 < k \le 3529 \\ + 8 & \mbox{if }3529 < k \\ + \end{array} \right .$ \\ +3. Initialize $2^{winsize}$ mp\_ints in an array named $M$ and one mp\_int named $\mu$ \\ +4. Calculate the $\mu$ required for Barrett Reduction (\textit{mp\_reduce\_setup}). \\ +5. $M_1 \leftarrow g \mbox{ (mod }p\mbox{)}$ \\ +\\ +Setup the table of small powers of $g$. First find $g^{2^{winsize}}$ and then all multiples of it. \\ +6. $k \leftarrow 2^{winsize - 1}$ \\ +7. $M_{k} \leftarrow M_1$ \\ +8. for $ix$ from 0 to $winsize - 2$ do \\ +\hspace{3mm}8.1 $M_k \leftarrow \left ( M_k \right )^2$ (\textit{mp\_sqr}) \\ +\hspace{3mm}8.2 $M_k \leftarrow M_k \mbox{ (mod }p\mbox{)}$ (\textit{mp\_reduce}) \\ +9. for $ix$ from $2^{winsize - 1} + 1$ to $2^{winsize} - 1$ do \\ +\hspace{3mm}9.1 $M_{ix} \leftarrow M_{ix - 1} \cdot M_{1}$ (\textit{mp\_mul}) \\ +\hspace{3mm}9.2 $M_{ix} \leftarrow M_{ix} \mbox{ (mod }p\mbox{)}$ (\textit{mp\_reduce}) \\ +10. $res \leftarrow 1$ \\ +\\ +Start Sliding Window. \\ +11. $mode \leftarrow 0, bitcnt \leftarrow 1, buf \leftarrow 0, digidx \leftarrow x.used - 1, bitcpy \leftarrow 0, bitbuf \leftarrow 0$ \\ +12. Loop \\ +\hspace{3mm}12.1 $bitcnt \leftarrow bitcnt - 1$ \\ +\hspace{3mm}12.2 If $bitcnt = 0$ then do \\ +\hspace{6mm}12.2.1 If $digidx = -1$ goto step 13. \\ +\hspace{6mm}12.2.2 $buf \leftarrow x_{digidx}$ \\ +\hspace{6mm}12.2.3 $digidx \leftarrow digidx - 1$ \\ +\hspace{6mm}12.2.4 $bitcnt \leftarrow lg(\beta)$ \\ +Continued on next page. \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm s\_mp\_exptmod} +\end{figure} + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{s\_mp\_exptmod} (\textit{continued}). \\ +\textbf{Input}. mp\_int $a$, $b$ and $c$ \\ +\textbf{Output}. $y \equiv g^x \mbox{ (mod }p\mbox{)}$ \\ +\hline \\ +\hspace{3mm}12.3 $y \leftarrow (buf >> (lg(\beta) - 1))$ AND $1$ \\ +\hspace{3mm}12.4 $buf \leftarrow buf << 1$ \\ +\hspace{3mm}12.5 if $mode = 0$ and $y = 0$ then goto step 12. \\ +\hspace{3mm}12.6 if $mode = 1$ and $y = 0$ then do \\ +\hspace{6mm}12.6.1 $res \leftarrow res^2$ \\ +\hspace{6mm}12.6.2 $res \leftarrow res \mbox{ (mod }p\mbox{)}$ \\ +\hspace{6mm}12.6.3 Goto step 12. \\ +\hspace{3mm}12.7 $bitcpy \leftarrow bitcpy + 1$ \\ +\hspace{3mm}12.8 $bitbuf \leftarrow bitbuf + (y << (winsize - bitcpy))$ \\ +\hspace{3mm}12.9 $mode \leftarrow 2$ \\ +\hspace{3mm}12.10 If $bitcpy = winsize$ then do \\ +\hspace{6mm}Window is full so perform the squarings and single multiplication. \\ +\hspace{6mm}12.10.1 for $ix$ from $0$ to $winsize -1$ do \\ +\hspace{9mm}12.10.1.1 $res \leftarrow res^2$ \\ +\hspace{9mm}12.10.1.2 $res \leftarrow res \mbox{ (mod }p\mbox{)}$ \\ +\hspace{6mm}12.10.2 $res \leftarrow res \cdot M_{bitbuf}$ \\ +\hspace{6mm}12.10.3 $res \leftarrow res \mbox{ (mod }p\mbox{)}$ \\ +\hspace{6mm}Reset the window. \\ +\hspace{6mm}12.10.4 $bitcpy \leftarrow 0, bitbuf \leftarrow 0, mode \leftarrow 1$ \\ +\\ +No more windows left. Check for residual bits of exponent. \\ +13. If $mode = 2$ and $bitcpy > 0$ then do \\ +\hspace{3mm}13.1 for $ix$ form $0$ to $bitcpy - 1$ do \\ +\hspace{6mm}13.1.1 $res \leftarrow res^2$ \\ +\hspace{6mm}13.1.2 $res \leftarrow res \mbox{ (mod }p\mbox{)}$ \\ +\hspace{6mm}13.1.3 $bitbuf \leftarrow bitbuf << 1$ \\ +\hspace{6mm}13.1.4 If $bitbuf$ AND $2^{winsize} \ne 0$ then do \\ +\hspace{9mm}13.1.4.1 $res \leftarrow res \cdot M_{1}$ \\ +\hspace{9mm}13.1.4.2 $res \leftarrow res \mbox{ (mod }p\mbox{)}$ \\ +14. $y \leftarrow res$ \\ +15. Clear $res$, $mu$ and the $M$ array. \\ +16. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm s\_mp\_exptmod (continued)} +\end{figure} + +\textbf{Algorithm s\_mp\_exptmod.} +This algorithm computes the $x$'th power of $g$ modulo $p$ and stores the result in $y$. It takes advantage of the Barrett reduction +algorithm to keep the product small throughout the algorithm. + +The first two steps determine the optimal window size based on the number of bits in the exponent. The larger the exponent the +larger the window size becomes. After a window size $winsize$ has been chosen an array of $2^{winsize}$ mp\_int variables is allocated. This +table will hold the values of $g^x \mbox{ (mod }p\mbox{)}$ for $2^{winsize - 1} \le x < 2^{winsize}$. + +After the table is allocated the first power of $g$ is found. Since $g \ge p$ is allowed it must be first reduced modulo $p$ to make +the rest of the algorithm more efficient. The first element of the table at $2^{winsize - 1}$ is found by squaring $M_1$ successively $winsize - 2$ +times. The rest of the table elements are found by multiplying the previous element by $M_1$ modulo $p$. + +Now that the table is available the sliding window may begin. The following list describes the functions of all the variables in the window. +\begin{enumerate} +\item The variable $mode$ dictates how the bits of the exponent are interpreted. +\begin{enumerate} + \item When $mode = 0$ the bits are ignored since no non-zero bit of the exponent has been seen yet. For example, if the exponent were simply + $1$ then there would be $lg(\beta) - 1$ zero bits before the first non-zero bit. In this case bits are ignored until a non-zero bit is found. + \item When $mode = 1$ a non-zero bit has been seen before and a new $winsize$-bit window has not been formed yet. In this mode leading $0$ bits + are read and a single squaring is performed. If a non-zero bit is read a new window is created. + \item When $mode = 2$ the algorithm is in the middle of forming a window and new bits are appended to the window from the most significant bit + downwards. +\end{enumerate} +\item The variable $bitcnt$ indicates how many bits are left in the current digit of the exponent left to be read. When it reaches zero a new digit + is fetched from the exponent. +\item The variable $buf$ holds the currently read digit of the exponent. +\item The variable $digidx$ is an index into the exponents digits. It starts at the leading digit $x.used - 1$ and moves towards the trailing digit. +\item The variable $bitcpy$ indicates how many bits are in the currently formed window. When it reaches $winsize$ the window is flushed and + the appropriate operations performed. +\item The variable $bitbuf$ holds the current bits of the window being formed. +\end{enumerate} + +All of step 12 is the window processing loop. It will iterate while there are digits available form the exponent to read. The first step +inside this loop is to extract a new digit if no more bits are available in the current digit. If there are no bits left a new digit is +read and if there are no digits left than the loop terminates. + +After a digit is made available step 12.3 will extract the most significant bit of the current digit and move all other bits in the digit +upwards. In effect the digit is read from most significant bit to least significant bit and since the digits are read from leading to +trailing edges the entire exponent is read from most significant bit to least significant bit. + +At step 12.5 if the $mode$ and currently extracted bit $y$ are both zero the bit is ignored and the next bit is read. This prevents the +algorithm from having to perform trivial squaring and reduction operations before the first non-zero bit is read. Step 12.6 and 12.7-10 handle +the two cases of $mode = 1$ and $mode = 2$ respectively. + +\begin{center} +\begin{figure}[here] +\includegraphics{pics/expt_state.ps} +\caption{Sliding Window State Diagram} +\label{pic:expt_state} +\end{figure} +\end{center} + +By step 13 there are no more digits left in the exponent. However, there may be partial bits in the window left. If $mode = 2$ then +a Left-to-Right algorithm is used to process the remaining few bits. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_s\_mp\_exptmod.c +\vspace{-3mm} +\begin{alltt} +016 #ifdef MP_LOW_MEM +017 #define TAB_SIZE 32 +018 #else +019 #define TAB_SIZE 256 +020 #endif +021 +022 int s_mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y, int redmod + e) +023 \{ +024 mp_int M[TAB_SIZE], res, mu; +025 mp_digit buf; +026 int err, bitbuf, bitcpy, bitcnt, mode, digidx, x, y, winsize; +027 int (*redux)(mp_int*,mp_int*,mp_int*); +028 +029 /* find window size */ +030 x = mp_count_bits (X); +031 if (x <= 7) \{ +032 winsize = 2; +033 \} else if (x <= 36) \{ +034 winsize = 3; +035 \} else if (x <= 140) \{ +036 winsize = 4; +037 \} else if (x <= 450) \{ +038 winsize = 5; +039 \} else if (x <= 1303) \{ +040 winsize = 6; +041 \} else if (x <= 3529) \{ +042 winsize = 7; +043 \} else \{ +044 winsize = 8; +045 \} +046 +047 #ifdef MP_LOW_MEM +048 if (winsize > 5) \{ +049 winsize = 5; +050 \} +051 #endif +052 +053 /* init M array */ +054 /* init first cell */ +055 if ((err = mp_init(&M[1])) != MP_OKAY) \{ +056 return err; +057 \} +058 +059 /* now init the second half of the array */ +060 for (x = 1<<(winsize-1); x < (1 << winsize); x++) \{ +061 if ((err = mp_init(&M[x])) != MP_OKAY) \{ +062 for (y = 1<<(winsize-1); y < x; y++) \{ +063 mp_clear (&M[y]); +064 \} +065 mp_clear(&M[1]); +066 return err; +067 \} +068 \} +069 +070 /* create mu, used for Barrett reduction */ +071 if ((err = mp_init (&mu)) != MP_OKAY) \{ +072 goto LBL_M; +073 \} +074 +075 if (redmode == 0) \{ +076 if ((err = mp_reduce_setup (&mu, P)) != MP_OKAY) \{ +077 goto LBL_MU; +078 \} +079 redux = mp_reduce; +080 \} else \{ +081 if ((err = mp_reduce_2k_setup_l (P, &mu)) != MP_OKAY) \{ +082 goto LBL_MU; +083 \} +084 redux = mp_reduce_2k_l; +085 \} +086 +087 /* create M table +088 * +089 * The M table contains powers of the base, +090 * e.g. M[x] = G**x mod P +091 * +092 * The first half of the table is not +093 * computed though accept for M[0] and M[1] +094 */ +095 if ((err = mp_mod (G, P, &M[1])) != MP_OKAY) \{ +096 goto LBL_MU; +097 \} +098 +099 /* compute the value at M[1<<(winsize-1)] by squaring +100 * M[1] (winsize-1) times +101 */ +102 if ((err = mp_copy (&M[1], &M[1 << (winsize - 1)])) != MP_OKAY) \{ +103 goto LBL_MU; +104 \} +105 +106 for (x = 0; x < (winsize - 1); x++) \{ +107 /* square it */ +108 if ((err = mp_sqr (&M[1 << (winsize - 1)], +109 &M[1 << (winsize - 1)])) != MP_OKAY) \{ +110 goto LBL_MU; +111 \} +112 +113 /* reduce modulo P */ +114 if ((err = redux (&M[1 << (winsize - 1)], P, &mu)) != MP_OKAY) \{ +115 goto LBL_MU; +116 \} +117 \} +118 +119 /* create upper table, that is M[x] = M[x-1] * M[1] (mod P) +120 * for x = (2**(winsize - 1) + 1) to (2**winsize - 1) +121 */ +122 for (x = (1 << (winsize - 1)) + 1; x < (1 << winsize); x++) \{ +123 if ((err = mp_mul (&M[x - 1], &M[1], &M[x])) != MP_OKAY) \{ +124 goto LBL_MU; +125 \} +126 if ((err = redux (&M[x], P, &mu)) != MP_OKAY) \{ +127 goto LBL_MU; +128 \} +129 \} +130 +131 /* setup result */ +132 if ((err = mp_init (&res)) != MP_OKAY) \{ +133 goto LBL_MU; +134 \} +135 mp_set (&res, 1); +136 +137 /* set initial mode and bit cnt */ +138 mode = 0; +139 bitcnt = 1; +140 buf = 0; +141 digidx = X->used - 1; +142 bitcpy = 0; +143 bitbuf = 0; +144 +145 for (;;) \{ +146 /* grab next digit as required */ +147 if (--bitcnt == 0) \{ +148 /* if digidx == -1 we are out of digits */ +149 if (digidx == -1) \{ +150 break; +151 \} +152 /* read next digit and reset the bitcnt */ +153 buf = X->dp[digidx--]; +154 bitcnt = (int) DIGIT_BIT; +155 \} +156 +157 /* grab the next msb from the exponent */ +158 y = (buf >> (mp_digit)(DIGIT_BIT - 1)) & 1; +159 buf <<= (mp_digit)1; +160 +161 /* if the bit is zero and mode == 0 then we ignore it +162 * These represent the leading zero bits before the first 1 bit +163 * in the exponent. Technically this opt is not required but it +164 * does lower the # of trivial squaring/reductions used +165 */ +166 if (mode == 0 && y == 0) \{ +167 continue; +168 \} +169 +170 /* if the bit is zero and mode == 1 then we square */ +171 if (mode == 1 && y == 0) \{ +172 if ((err = mp_sqr (&res, &res)) != MP_OKAY) \{ +173 goto LBL_RES; +174 \} +175 if ((err = redux (&res, P, &mu)) != MP_OKAY) \{ +176 goto LBL_RES; +177 \} +178 continue; +179 \} +180 +181 /* else we add it to the window */ +182 bitbuf |= (y << (winsize - ++bitcpy)); +183 mode = 2; +184 +185 if (bitcpy == winsize) \{ +186 /* ok window is filled so square as required and multiply */ +187 /* square first */ +188 for (x = 0; x < winsize; x++) \{ +189 if ((err = mp_sqr (&res, &res)) != MP_OKAY) \{ +190 goto LBL_RES; +191 \} +192 if ((err = redux (&res, P, &mu)) != MP_OKAY) \{ +193 goto LBL_RES; +194 \} +195 \} +196 +197 /* then multiply */ +198 if ((err = mp_mul (&res, &M[bitbuf], &res)) != MP_OKAY) \{ +199 goto LBL_RES; +200 \} +201 if ((err = redux (&res, P, &mu)) != MP_OKAY) \{ +202 goto LBL_RES; +203 \} +204 +205 /* empty window and reset */ +206 bitcpy = 0; +207 bitbuf = 0; +208 mode = 1; +209 \} +210 \} +211 +212 /* if bits remain then square/multiply */ +213 if (mode == 2 && bitcpy > 0) \{ +214 /* square then multiply if the bit is set */ +215 for (x = 0; x < bitcpy; x++) \{ +216 if ((err = mp_sqr (&res, &res)) != MP_OKAY) \{ +217 goto LBL_RES; +218 \} +219 if ((err = redux (&res, P, &mu)) != MP_OKAY) \{ +220 goto LBL_RES; +221 \} +222 +223 bitbuf <<= 1; +224 if ((bitbuf & (1 << winsize)) != 0) \{ +225 /* then multiply */ +226 if ((err = mp_mul (&res, &M[1], &res)) != MP_OKAY) \{ +227 goto LBL_RES; +228 \} +229 if ((err = redux (&res, P, &mu)) != MP_OKAY) \{ +230 goto LBL_RES; +231 \} +232 \} +233 \} +234 \} +235 +236 mp_exch (&res, Y); +237 err = MP_OKAY; +238 LBL_RES:mp_clear (&res); +239 LBL_MU:mp_clear (&mu); +240 LBL_M: +241 mp_clear(&M[1]); +242 for (x = 1<<(winsize-1); x < (1 << winsize); x++) \{ +243 mp_clear (&M[x]); +244 \} +245 return err; +246 \} +247 #endif +248 +\end{alltt} +\end{small} + +Lines 31 through 41 determine the optimal window size based on the length of the exponent in bits. The window divisions are sorted +from smallest to greatest so that in each \textbf{if} statement only one condition must be tested. For example, by the \textbf{if} statement +on line 33 the value of $x$ is already known to be greater than $140$. + +The conditional piece of code beginning on line 47 allows the window size to be restricted to five bits. This logic is used to ensure +the table of precomputed powers of $G$ remains relatively small. + +The for loop on line 60 initializes the $M$ array while lines 61 and 76 compute the value of $\mu$ required for +Barrett reduction. + +-- More later. + +\section{Quick Power of Two} +Calculating $b = 2^a$ can be performed much quicker than with any of the previous algorithms. Recall that a logical shift left $m << k$ is +equivalent to $m \cdot 2^k$. By this logic when $m = 1$ a quick power of two can be achieved. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_2expt}. \\ +\textbf{Input}. integer $b$ \\ +\textbf{Output}. $a \leftarrow 2^b$ \\ +\hline \\ +1. $a \leftarrow 0$ \\ +2. If $a.alloc < \lfloor b / lg(\beta) \rfloor + 1$ then grow $a$ appropriately. \\ +3. $a.used \leftarrow \lfloor b / lg(\beta) \rfloor + 1$ \\ +4. $a_{\lfloor b / lg(\beta) \rfloor} \leftarrow 1 << (b \mbox{ mod } lg(\beta))$ \\ +5. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_2expt} +\end{figure} + +\textbf{Algorithm mp\_2expt.} + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_2expt.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* computes a = 2**b +018 * +019 * Simple algorithm which zeroes the int, grows it then just sets one bit +020 * as required. +021 */ +022 int +023 mp_2expt (mp_int * a, int b) +024 \{ +025 int res; +026 +027 /* zero a as per default */ +028 mp_zero (a); +029 +030 /* grow a to accomodate the single bit */ +031 if ((res = mp_grow (a, b / DIGIT_BIT + 1)) != MP_OKAY) \{ +032 return res; +033 \} +034 +035 /* set the used count of where the bit will go */ +036 a->used = b / DIGIT_BIT + 1; +037 +038 /* put the single bit in its place */ +039 a->dp[b / DIGIT_BIT] = ((mp_digit)1) << (b % DIGIT_BIT); +040 +041 return MP_OKAY; +042 \} +043 #endif +044 +\end{alltt} +\end{small} + +\chapter{Higher Level Algorithms} + +This chapter discusses the various higher level algorithms that are required to complete a well rounded multiple precision integer package. These +routines are less performance oriented than the algorithms of chapters five, six and seven but are no less important. + +The first section describes a method of integer division with remainder that is universally well known. It provides the signed division logic +for the package. The subsequent section discusses a set of algorithms which allow a single digit to be the 2nd operand for a variety of operations. +These algorithms serve mostly to simplify other algorithms where small constants are required. The last two sections discuss how to manipulate +various representations of integers. For example, converting from an mp\_int to a string of character. + +\section{Integer Division with Remainder} +\label{sec:division} + +Integer division aside from modular exponentiation is the most intensive algorithm to compute. Like addition, subtraction and multiplication +the basis of this algorithm is the long-hand division algorithm taught to school children. Throughout this discussion several common variables +will be used. Let $x$ represent the divisor and $y$ represent the dividend. Let $q$ represent the integer quotient $\lfloor y / x \rfloor$ and +let $r$ represent the remainder $r = y - x \lfloor y / x \rfloor$. The following simple algorithm will be used to start the discussion. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{Radix-$\beta$ Integer Division}. \\ +\textbf{Input}. integer $x$ and $y$ \\ +\textbf{Output}. $q = \lfloor y/x\rfloor, r = y - xq$ \\ +\hline \\ +1. $q \leftarrow 0$ \\ +2. $n \leftarrow \vert \vert y \vert \vert - \vert \vert x \vert \vert$ \\ +3. for $t$ from $n$ down to $0$ do \\ +\hspace{3mm}3.1 Maximize $k$ such that $kx\beta^t$ is less than or equal to $y$ and $(k + 1)x\beta^t$ is greater. \\ +\hspace{3mm}3.2 $q \leftarrow q + k\beta^t$ \\ +\hspace{3mm}3.3 $y \leftarrow y - kx\beta^t$ \\ +4. $r \leftarrow y$ \\ +5. Return($q, r$) \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm Radix-$\beta$ Integer Division} +\label{fig:raddiv} +\end{figure} + +As children we are taught this very simple algorithm for the case of $\beta = 10$. Almost instinctively several optimizations are taught for which +their reason of existing are never explained. For this example let $y = 5471$ represent the dividend and $x = 23$ represent the divisor. + +To find the first digit of the quotient the value of $k$ must be maximized such that $kx\beta^t$ is less than or equal to $y$ and +simultaneously $(k + 1)x\beta^t$ is greater than $y$. Implicitly $k$ is the maximum value the $t$'th digit of the quotient may have. The habitual method +used to find the maximum is to ``eyeball'' the two numbers, typically only the leading digits and quickly estimate a quotient. By only using leading +digits a much simpler division may be used to form an educated guess at what the value must be. In this case $k = \lfloor 54/23\rfloor = 2$ quickly +arises as a possible solution. Indeed $2x\beta^2 = 4600$ is less than $y = 5471$ and simultaneously $(k + 1)x\beta^2 = 6900$ is larger than $y$. +As a result $k\beta^2$ is added to the quotient which now equals $q = 200$ and $4600$ is subtracted from $y$ to give a remainder of $y = 841$. + +Again this process is repeated to produce the quotient digit $k = 3$ which makes the quotient $q = 200 + 3\beta = 230$ and the remainder +$y = 841 - 3x\beta = 181$. Finally the last iteration of the loop produces $k = 7$ which leads to the quotient $q = 230 + 7 = 237$ and the +remainder $y = 181 - 7x = 20$. The final quotient and remainder found are $q = 237$ and $r = y = 20$ which are indeed correct since +$237 \cdot 23 + 20 = 5471$ is true. + +\subsection{Quotient Estimation} +\label{sec:divest} +As alluded to earlier the quotient digit $k$ can be estimated from only the leading digits of both the divisor and dividend. When $p$ leading +digits are used from both the divisor and dividend to form an estimation the accuracy of the estimation rises as $p$ grows. Technically +speaking the estimation is based on assuming the lower $\vert \vert y \vert \vert - p$ and $\vert \vert x \vert \vert - p$ lower digits of the +dividend and divisor are zero. + +The value of the estimation may off by a few values in either direction and in general is fairly correct. A simplification \cite[pp. 271]{TAOCPV2} +of the estimation technique is to use $t + 1$ digits of the dividend and $t$ digits of the divisor, in particularly when $t = 1$. The estimate +using this technique is never too small. For the following proof let $t = \vert \vert y \vert \vert - 1$ and $s = \vert \vert x \vert \vert - 1$ +represent the most significant digits of the dividend and divisor respectively. + +\textbf{Proof.}\textit{ The quotient $\hat k = \lfloor (y_t\beta + y_{t-1}) / x_s \rfloor$ is greater than or equal to +$k = \lfloor y / (x \cdot \beta^{\vert \vert y \vert \vert - \vert \vert x \vert \vert - 1}) \rfloor$. } +The first obvious case is when $\hat k = \beta - 1$ in which case the proof is concluded since the real quotient cannot be larger. For all other +cases $\hat k = \lfloor (y_t\beta + y_{t-1}) / x_s \rfloor$ and $\hat k x_s \ge y_t\beta + y_{t-1} - x_s + 1$. The latter portion of the inequalility +$-x_s + 1$ arises from the fact that a truncated integer division will give the same quotient for at most $x_s - 1$ values. Next a series of +inequalities will prove the hypothesis. + +\begin{equation} +y - \hat k x \le y - \hat k x_s\beta^s +\end{equation} + +This is trivially true since $x \ge x_s\beta^s$. Next we replace $\hat kx_s\beta^s$ by the previous inequality for $\hat kx_s$. + +\begin{equation} +y - \hat k x \le y_t\beta^t + \ldots + y_0 - (y_t\beta^t + y_{t-1}\beta^{t-1} - x_s\beta^t + \beta^s) +\end{equation} + +By simplifying the previous inequality the following inequality is formed. + +\begin{equation} +y - \hat k x \le y_{t-2}\beta^{t-2} + \ldots + y_0 + x_s\beta^s - \beta^s +\end{equation} + +Subsequently, + +\begin{equation} +y_{t-2}\beta^{t-2} + \ldots + y_0 + x_s\beta^s - \beta^s < x_s\beta^s \le x +\end{equation} + +Which proves that $y - \hat kx \le x$ and by consequence $\hat k \ge k$ which concludes the proof. \textbf{QED} + + +\subsection{Normalized Integers} +For the purposes of division a normalized input is when the divisors leading digit $x_n$ is greater than or equal to $\beta / 2$. By multiplying both +$x$ and $y$ by $j = \lfloor (\beta / 2) / x_n \rfloor$ the quotient remains unchanged and the remainder is simply $j$ times the original +remainder. The purpose of normalization is to ensure the leading digit of the divisor is sufficiently large such that the estimated quotient will +lie in the domain of a single digit. Consider the maximum dividend $(\beta - 1) \cdot \beta + (\beta - 1)$ and the minimum divisor $\beta / 2$. + +\begin{equation} +{{\beta^2 - 1} \over { \beta / 2}} \le 2\beta - {2 \over \beta} +\end{equation} + +At most the quotient approaches $2\beta$, however, in practice this will not occur since that would imply the previous quotient digit was too small. + +\subsection{Radix-$\beta$ Division with Remainder} +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_div}. \\ +\textbf{Input}. mp\_int $a, b$ \\ +\textbf{Output}. $c = \lfloor a/b \rfloor$, $d = a - bc$ \\ +\hline \\ +1. If $b = 0$ return(\textit{MP\_VAL}). \\ +2. If $\vert a \vert < \vert b \vert$ then do \\ +\hspace{3mm}2.1 $d \leftarrow a$ \\ +\hspace{3mm}2.2 $c \leftarrow 0$ \\ +\hspace{3mm}2.3 Return(\textit{MP\_OKAY}). \\ +\\ +Setup the quotient to receive the digits. \\ +3. Grow $q$ to $a.used + 2$ digits. \\ +4. $q \leftarrow 0$ \\ +5. $x \leftarrow \vert a \vert , y \leftarrow \vert b \vert$ \\ +6. $sign \leftarrow \left \lbrace \begin{array}{ll} + MP\_ZPOS & \mbox{if }a.sign = b.sign \\ + MP\_NEG & \mbox{otherwise} \\ + \end{array} \right .$ \\ +\\ +Normalize the inputs such that the leading digit of $y$ is greater than or equal to $\beta / 2$. \\ +7. $norm \leftarrow (lg(\beta) - 1) - (\lceil lg(y) \rceil \mbox{ (mod }lg(\beta)\mbox{)})$ \\ +8. $x \leftarrow x \cdot 2^{norm}, y \leftarrow y \cdot 2^{norm}$ \\ +\\ +Find the leading digit of the quotient. \\ +9. $n \leftarrow x.used - 1, t \leftarrow y.used - 1$ \\ +10. $y \leftarrow y \cdot \beta^{n - t}$ \\ +11. While ($x \ge y$) do \\ +\hspace{3mm}11.1 $q_{n - t} \leftarrow q_{n - t} + 1$ \\ +\hspace{3mm}11.2 $x \leftarrow x - y$ \\ +12. $y \leftarrow \lfloor y / \beta^{n-t} \rfloor$ \\ +\\ +Continued on the next page. \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_div} +\end{figure} + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_div} (continued). \\ +\textbf{Input}. mp\_int $a, b$ \\ +\textbf{Output}. $c = \lfloor a/b \rfloor$, $d = a - bc$ \\ +\hline \\ +Now find the remainder fo the digits. \\ +13. for $i$ from $n$ down to $(t + 1)$ do \\ +\hspace{3mm}13.1 If $i > x.used$ then jump to the next iteration of this loop. \\ +\hspace{3mm}13.2 If $x_{i} = y_{t}$ then \\ +\hspace{6mm}13.2.1 $q_{i - t - 1} \leftarrow \beta - 1$ \\ +\hspace{3mm}13.3 else \\ +\hspace{6mm}13.3.1 $\hat r \leftarrow x_{i} \cdot \beta + x_{i - 1}$ \\ +\hspace{6mm}13.3.2 $\hat r \leftarrow \lfloor \hat r / y_{t} \rfloor$ \\ +\hspace{6mm}13.3.3 $q_{i - t - 1} \leftarrow \hat r$ \\ +\hspace{3mm}13.4 $q_{i - t - 1} \leftarrow q_{i - t - 1} + 1$ \\ +\\ +Fixup quotient estimation. \\ +\hspace{3mm}13.5 Loop \\ +\hspace{6mm}13.5.1 $q_{i - t - 1} \leftarrow q_{i - t - 1} - 1$ \\ +\hspace{6mm}13.5.2 t$1 \leftarrow 0$ \\ +\hspace{6mm}13.5.3 t$1_0 \leftarrow y_{t - 1}, $ t$1_1 \leftarrow y_t,$ t$1.used \leftarrow 2$ \\ +\hspace{6mm}13.5.4 $t1 \leftarrow t1 \cdot q_{i - t - 1}$ \\ +\hspace{6mm}13.5.5 t$2_0 \leftarrow x_{i - 2}, $ t$2_1 \leftarrow x_{i - 1}, $ t$2_2 \leftarrow x_i, $ t$2.used \leftarrow 3$ \\ +\hspace{6mm}13.5.6 If $\vert t1 \vert > \vert t2 \vert$ then goto step 13.5. \\ +\hspace{3mm}13.6 t$1 \leftarrow y \cdot q_{i - t - 1}$ \\ +\hspace{3mm}13.7 t$1 \leftarrow $ t$1 \cdot \beta^{i - t - 1}$ \\ +\hspace{3mm}13.8 $x \leftarrow x - $ t$1$ \\ +\hspace{3mm}13.9 If $x.sign = MP\_NEG$ then \\ +\hspace{6mm}13.10 t$1 \leftarrow y$ \\ +\hspace{6mm}13.11 t$1 \leftarrow $ t$1 \cdot \beta^{i - t - 1}$ \\ +\hspace{6mm}13.12 $x \leftarrow x + $ t$1$ \\ +\hspace{6mm}13.13 $q_{i - t - 1} \leftarrow q_{i - t - 1} - 1$ \\ +\\ +Finalize the result. \\ +14. Clamp excess digits of $q$ \\ +15. $c \leftarrow q, c.sign \leftarrow sign$ \\ +16. $x.sign \leftarrow a.sign$ \\ +17. $d \leftarrow \lfloor x / 2^{norm} \rfloor$ \\ +18. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_div (continued)} +\end{figure} +\textbf{Algorithm mp\_div.} +This algorithm will calculate quotient and remainder from an integer division given a dividend and divisor. The algorithm is a signed +division and will produce a fully qualified quotient and remainder. + +First the divisor $b$ must be non-zero which is enforced in step one. If the divisor is larger than the dividend than the quotient is implicitly +zero and the remainder is the dividend. + +After the first two trivial cases of inputs are handled the variable $q$ is setup to receive the digits of the quotient. Two unsigned copies of the +divisor $y$ and dividend $x$ are made as well. The core of the division algorithm is an unsigned division and will only work if the values are +positive. Now the two values $x$ and $y$ must be normalized such that the leading digit of $y$ is greater than or equal to $\beta / 2$. +This is performed by shifting both to the left by enough bits to get the desired normalization. + +At this point the division algorithm can begin producing digits of the quotient. Recall that maximum value of the estimation used is +$2\beta - {2 \over \beta}$ which means that a digit of the quotient must be first produced by another means. In this case $y$ is shifted +to the left (\textit{step ten}) so that it has the same number of digits as $x$. The loop on step eleven will subtract multiples of the +shifted copy of $y$ until $x$ is smaller. Since the leading digit of $y$ is greater than or equal to $\beta/2$ this loop will iterate at most two +times to produce the desired leading digit of the quotient. + +Now the remainder of the digits can be produced. The equation $\hat q = \lfloor {{x_i \beta + x_{i-1}}\over y_t} \rfloor$ is used to fairly +accurately approximate the true quotient digit. The estimation can in theory produce an estimation as high as $2\beta - {2 \over \beta}$ but by +induction the upper quotient digit is correct (\textit{as established on step eleven}) and the estimate must be less than $\beta$. + +Recall from section~\ref{sec:divest} that the estimation is never too low but may be too high. The next step of the estimation process is +to refine the estimation. The loop on step 13.5 uses $x_i\beta^2 + x_{i-1}\beta + x_{i-2}$ and $q_{i - t - 1}(y_t\beta + y_{t-1})$ as a higher +order approximation to adjust the quotient digit. + +After both phases of estimation the quotient digit may still be off by a value of one\footnote{This is similar to the error introduced +by optimizing Barrett reduction.}. Steps 13.6 and 13.7 subtract the multiple of the divisor from the dividend (\textit{Similar to step 3.3 of +algorithm~\ref{fig:raddiv}} and then subsequently add a multiple of the divisor if the quotient was too large. + +Now that the quotient has been determine finializing the result is a matter of clamping the quotient, fixing the sizes and de-normalizing the +remainder. An important aspect of this algorithm seemingly overlooked in other descriptions such as that of Algorithm 14.20 HAC \cite[pp. 598]{HAC} +is that when the estimations are being made (\textit{inside the loop on step 13.5}) that the digits $y_{t-1}$, $x_{i-2}$ and $x_{i-1}$ may lie +outside their respective boundaries. For example, if $t = 0$ or $i \le 1$ then the digits would be undefined. In those cases the digits should +respectively be replaced with a zero. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_div.c +\vspace{-3mm} +\begin{alltt} +016 +017 #ifdef BN_MP_DIV_SMALL +018 +019 /* slower bit-bang division... also smaller */ +020 int mp_div(mp_int * a, mp_int * b, mp_int * c, mp_int * d) +021 \{ +022 mp_int ta, tb, tq, q; +023 int res, n, n2; +024 +025 /* is divisor zero ? */ +026 if (mp_iszero (b) == 1) \{ +027 return MP_VAL; +028 \} +029 +030 /* if a < b then q=0, r = a */ +031 if (mp_cmp_mag (a, b) == MP_LT) \{ +032 if (d != NULL) \{ +033 res = mp_copy (a, d); +034 \} else \{ +035 res = MP_OKAY; +036 \} +037 if (c != NULL) \{ +038 mp_zero (c); +039 \} +040 return res; +041 \} +042 +043 /* init our temps */ +044 if ((res = mp_init_multi(&ta, &tb, &tq, &q, NULL) != MP_OKAY)) \{ +045 return res; +046 \} +047 +048 +049 mp_set(&tq, 1); +050 n = mp_count_bits(a) - mp_count_bits(b); +051 if (((res = mp_abs(a, &ta)) != MP_OKAY) || +052 ((res = mp_abs(b, &tb)) != MP_OKAY) || +053 ((res = mp_mul_2d(&tb, n, &tb)) != MP_OKAY) || +054 ((res = mp_mul_2d(&tq, n, &tq)) != MP_OKAY)) \{ +055 goto LBL_ERR; +056 \} +057 +058 while (n-- >= 0) \{ +059 if (mp_cmp(&tb, &ta) != MP_GT) \{ +060 if (((res = mp_sub(&ta, &tb, &ta)) != MP_OKAY) || +061 ((res = mp_add(&q, &tq, &q)) != MP_OKAY)) \{ +062 goto LBL_ERR; +063 \} +064 \} +065 if (((res = mp_div_2d(&tb, 1, &tb, NULL)) != MP_OKAY) || +066 ((res = mp_div_2d(&tq, 1, &tq, NULL)) != MP_OKAY)) \{ +067 goto LBL_ERR; +068 \} +069 \} +070 +071 /* now q == quotient and ta == remainder */ +072 n = a->sign; +073 n2 = (a->sign == b->sign ? MP_ZPOS : MP_NEG); +074 if (c != NULL) \{ +075 mp_exch(c, &q); +076 c->sign = (mp_iszero(c) == MP_YES) ? MP_ZPOS : n2; +077 \} +078 if (d != NULL) \{ +079 mp_exch(d, &ta); +080 d->sign = (mp_iszero(d) == MP_YES) ? MP_ZPOS : n; +081 \} +082 LBL_ERR: +083 mp_clear_multi(&ta, &tb, &tq, &q, NULL); +084 return res; +085 \} +086 +087 #else +088 +089 /* integer signed division. +090 * c*b + d == a [e.g. a/b, c=quotient, d=remainder] +091 * HAC pp.598 Algorithm 14.20 +092 * +093 * Note that the description in HAC is horribly +094 * incomplete. For example, it doesn't consider +095 * the case where digits are removed from 'x' in +096 * the inner loop. It also doesn't consider the +097 * case that y has fewer than three digits, etc.. +098 * +099 * The overall algorithm is as described as +100 * 14.20 from HAC but fixed to treat these cases. +101 */ +102 int mp_div (mp_int * a, mp_int * b, mp_int * c, mp_int * d) +103 \{ +104 mp_int q, x, y, t1, t2; +105 int res, n, t, i, norm, neg; +106 +107 /* is divisor zero ? */ +108 if (mp_iszero (b) == 1) \{ +109 return MP_VAL; +110 \} +111 +112 /* if a < b then q=0, r = a */ +113 if (mp_cmp_mag (a, b) == MP_LT) \{ +114 if (d != NULL) \{ +115 res = mp_copy (a, d); +116 \} else \{ +117 res = MP_OKAY; +118 \} +119 if (c != NULL) \{ +120 mp_zero (c); +121 \} +122 return res; +123 \} +124 +125 if ((res = mp_init_size (&q, a->used + 2)) != MP_OKAY) \{ +126 return res; +127 \} +128 q.used = a->used + 2; +129 +130 if ((res = mp_init (&t1)) != MP_OKAY) \{ +131 goto LBL_Q; +132 \} +133 +134 if ((res = mp_init (&t2)) != MP_OKAY) \{ +135 goto LBL_T1; +136 \} +137 +138 if ((res = mp_init_copy (&x, a)) != MP_OKAY) \{ +139 goto LBL_T2; +140 \} +141 +142 if ((res = mp_init_copy (&y, b)) != MP_OKAY) \{ +143 goto LBL_X; +144 \} +145 +146 /* fix the sign */ +147 neg = (a->sign == b->sign) ? MP_ZPOS : MP_NEG; +148 x.sign = y.sign = MP_ZPOS; +149 +150 /* normalize both x and y, ensure that y >= b/2, [b == 2**DIGIT_BIT] */ +151 norm = mp_count_bits(&y) % DIGIT_BIT; +152 if (norm < (int)(DIGIT_BIT-1)) \{ +153 norm = (DIGIT_BIT-1) - norm; +154 if ((res = mp_mul_2d (&x, norm, &x)) != MP_OKAY) \{ +155 goto LBL_Y; +156 \} +157 if ((res = mp_mul_2d (&y, norm, &y)) != MP_OKAY) \{ +158 goto LBL_Y; +159 \} +160 \} else \{ +161 norm = 0; +162 \} +163 +164 /* note hac does 0 based, so if used==5 then its 0,1,2,3,4, e.g. use 4 */ +165 n = x.used - 1; +166 t = y.used - 1; +167 +168 /* while (x >= y*b**n-t) do \{ q[n-t] += 1; x -= y*b**\{n-t\} \} */ +169 if ((res = mp_lshd (&y, n - t)) != MP_OKAY) \{ /* y = y*b**\{n-t\} */ +170 goto LBL_Y; +171 \} +172 +173 while (mp_cmp (&x, &y) != MP_LT) \{ +174 ++(q.dp[n - t]); +175 if ((res = mp_sub (&x, &y, &x)) != MP_OKAY) \{ +176 goto LBL_Y; +177 \} +178 \} +179 +180 /* reset y by shifting it back down */ +181 mp_rshd (&y, n - t); +182 +183 /* step 3. for i from n down to (t + 1) */ +184 for (i = n; i >= (t + 1); i--) \{ +185 if (i > x.used) \{ +186 continue; +187 \} +188 +189 /* step 3.1 if xi == yt then set q\{i-t-1\} to b-1, +190 * otherwise set q\{i-t-1\} to (xi*b + x\{i-1\})/yt */ +191 if (x.dp[i] == y.dp[t]) \{ +192 q.dp[i - t - 1] = ((((mp_digit)1) << DIGIT_BIT) - 1); +193 \} else \{ +194 mp_word tmp; +195 tmp = ((mp_word) x.dp[i]) << ((mp_word) DIGIT_BIT); +196 tmp |= ((mp_word) x.dp[i - 1]); +197 tmp /= ((mp_word) y.dp[t]); +198 if (tmp > (mp_word) MP_MASK) +199 tmp = MP_MASK; +200 q.dp[i - t - 1] = (mp_digit) (tmp & (mp_word) (MP_MASK)); +201 \} +202 +203 /* while (q\{i-t-1\} * (yt * b + y\{t-1\})) > +204 xi * b**2 + xi-1 * b + xi-2 +205 +206 do q\{i-t-1\} -= 1; +207 */ +208 q.dp[i - t - 1] = (q.dp[i - t - 1] + 1) & MP_MASK; +209 do \{ +210 q.dp[i - t - 1] = (q.dp[i - t - 1] - 1) & MP_MASK; +211 +212 /* find left hand */ +213 mp_zero (&t1); +214 t1.dp[0] = (t - 1 < 0) ? 0 : y.dp[t - 1]; +215 t1.dp[1] = y.dp[t]; +216 t1.used = 2; +217 if ((res = mp_mul_d (&t1, q.dp[i - t - 1], &t1)) != MP_OKAY) \{ +218 goto LBL_Y; +219 \} +220 +221 /* find right hand */ +222 t2.dp[0] = (i - 2 < 0) ? 0 : x.dp[i - 2]; +223 t2.dp[1] = (i - 1 < 0) ? 0 : x.dp[i - 1]; +224 t2.dp[2] = x.dp[i]; +225 t2.used = 3; +226 \} while (mp_cmp_mag(&t1, &t2) == MP_GT); +227 +228 /* step 3.3 x = x - q\{i-t-1\} * y * b**\{i-t-1\} */ +229 if ((res = mp_mul_d (&y, q.dp[i - t - 1], &t1)) != MP_OKAY) \{ +230 goto LBL_Y; +231 \} +232 +233 if ((res = mp_lshd (&t1, i - t - 1)) != MP_OKAY) \{ +234 goto LBL_Y; +235 \} +236 +237 if ((res = mp_sub (&x, &t1, &x)) != MP_OKAY) \{ +238 goto LBL_Y; +239 \} +240 +241 /* if x < 0 then \{ x = x + y*b**\{i-t-1\}; q\{i-t-1\} -= 1; \} */ +242 if (x.sign == MP_NEG) \{ +243 if ((res = mp_copy (&y, &t1)) != MP_OKAY) \{ +244 goto LBL_Y; +245 \} +246 if ((res = mp_lshd (&t1, i - t - 1)) != MP_OKAY) \{ +247 goto LBL_Y; +248 \} +249 if ((res = mp_add (&x, &t1, &x)) != MP_OKAY) \{ +250 goto LBL_Y; +251 \} +252 +253 q.dp[i - t - 1] = (q.dp[i - t - 1] - 1UL) & MP_MASK; +254 \} +255 \} +256 +257 /* now q is the quotient and x is the remainder +258 * [which we have to normalize] +259 */ +260 +261 /* get sign before writing to c */ +262 x.sign = x.used == 0 ? MP_ZPOS : a->sign; +263 +264 if (c != NULL) \{ +265 mp_clamp (&q); +266 mp_exch (&q, c); +267 c->sign = neg; +268 \} +269 +270 if (d != NULL) \{ +271 mp_div_2d (&x, norm, &x, NULL); +272 mp_exch (&x, d); +273 \} +274 +275 res = MP_OKAY; +276 +277 LBL_Y:mp_clear (&y); +278 LBL_X:mp_clear (&x); +279 LBL_T2:mp_clear (&t2); +280 LBL_T1:mp_clear (&t1); +281 LBL_Q:mp_clear (&q); +282 return res; +283 \} +284 +285 #endif +286 +287 #endif +288 +\end{alltt} +\end{small} + +The implementation of this algorithm differs slightly from the pseudo code presented previously. In this algorithm either of the quotient $c$ or +remainder $d$ may be passed as a \textbf{NULL} pointer which indicates their value is not desired. For example, the C code to call the division +algorithm with only the quotient is + +\begin{verbatim} +mp_div(&a, &b, &c, NULL); /* c = [a/b] */ +\end{verbatim} + +Lines 37 and 44 handle the two trivial cases of inputs which are division by zero and dividend smaller than the divisor +respectively. After the two trivial cases all of the temporary variables are initialized. Line 105 determines the sign of +the quotient and line 76 ensures that both $x$ and $y$ are positive. + +The number of bits in the leading digit is calculated on line 105. Implictly an mp\_int with $r$ digits will require $lg(\beta)(r-1) + k$ bits +of precision which when reduced modulo $lg(\beta)$ produces the value of $k$. In this case $k$ is the number of bits in the leading digit which is +exactly what is required. For the algorithm to operate $k$ must equal $lg(\beta) - 1$ and when it does not the inputs must be normalized by shifting +them to the left by $lg(\beta) - 1 - k$ bits. + +Throughout the variables $n$ and $t$ will represent the highest digit of $x$ and $y$ respectively. These are first used to produce the +leading digit of the quotient. The loop beginning on line 183 will produce the remainder of the quotient digits. + +The conditional ``continue'' on line 114 is used to prevent the algorithm from reading past the leading edge of $x$ which can occur when the +algorithm eliminates multiple non-zero digits in a single iteration. This ensures that $x_i$ is always non-zero since by definition the digits +above the $i$'th position $x$ must be zero in order for the quotient to be precise\footnote{Precise as far as integer division is concerned.}. + +Lines 130, 130 and 134 through 134 manually construct the high accuracy estimations by setting the digits of the two mp\_int +variables directly. + +\section{Single Digit Helpers} + +This section briefly describes a series of single digit helper algorithms which come in handy when working with small constants. All of +the helper functions assume the single digit input is positive and will treat them as such. + +\subsection{Single Digit Addition and Subtraction} + +Both addition and subtraction are performed by ``cheating'' and using mp\_set followed by the higher level addition or subtraction +algorithms. As a result these algorithms are subtantially simpler with a slight cost in performance. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_add\_d}. \\ +\textbf{Input}. mp\_int $a$ and a mp\_digit $b$ \\ +\textbf{Output}. $c = a + b$ \\ +\hline \\ +1. $t \leftarrow b$ (\textit{mp\_set}) \\ +2. $c \leftarrow a + t$ \\ +3. Return(\textit{MP\_OKAY}) \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_add\_d} +\end{figure} + +\textbf{Algorithm mp\_add\_d.} +This algorithm initiates a temporary mp\_int with the value of the single digit and uses algorithm mp\_add to add the two values together. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_add\_d.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* single digit addition */ +018 int +019 mp_add_d (mp_int * a, mp_digit b, mp_int * c) +020 \{ +021 int res, ix, oldused; +022 mp_digit *tmpa, *tmpc, mu; +023 +024 /* grow c as required */ +025 if (c->alloc < a->used + 1) \{ +026 if ((res = mp_grow(c, a->used + 1)) != MP_OKAY) \{ +027 return res; +028 \} +029 \} +030 +031 /* if a is negative and |a| >= b, call c = |a| - b */ +032 if (a->sign == MP_NEG && (a->used > 1 || a->dp[0] >= b)) \{ +033 /* temporarily fix sign of a */ +034 a->sign = MP_ZPOS; +035 +036 /* c = |a| - b */ +037 res = mp_sub_d(a, b, c); +038 +039 /* fix sign */ +040 a->sign = c->sign = MP_NEG; +041 +042 return res; +043 \} +044 +045 /* old number of used digits in c */ +046 oldused = c->used; +047 +048 /* sign always positive */ +049 c->sign = MP_ZPOS; +050 +051 /* source alias */ +052 tmpa = a->dp; +053 +054 /* destination alias */ +055 tmpc = c->dp; +056 +057 /* if a is positive */ +058 if (a->sign == MP_ZPOS) \{ +059 /* add digit, after this we're propagating +060 * the carry. +061 */ +062 *tmpc = *tmpa++ + b; +063 mu = *tmpc >> DIGIT_BIT; +064 *tmpc++ &= MP_MASK; +065 +066 /* now handle rest of the digits */ +067 for (ix = 1; ix < a->used; ix++) \{ +068 *tmpc = *tmpa++ + mu; +069 mu = *tmpc >> DIGIT_BIT; +070 *tmpc++ &= MP_MASK; +071 \} +072 /* set final carry */ +073 ix++; +074 *tmpc++ = mu; +075 +076 /* setup size */ +077 c->used = a->used + 1; +078 \} else \{ +079 /* a was negative and |a| < b */ +080 c->used = 1; +081 +082 /* the result is a single digit */ +083 if (a->used == 1) \{ +084 *tmpc++ = b - a->dp[0]; +085 \} else \{ +086 *tmpc++ = b; +087 \} +088 +089 /* setup count so the clearing of oldused +090 * can fall through correctly +091 */ +092 ix = 1; +093 \} +094 +095 /* now zero to oldused */ +096 while (ix++ < oldused) \{ +097 *tmpc++ = 0; +098 \} +099 mp_clamp(c); +100 +101 return MP_OKAY; +102 \} +103 +104 #endif +105 +\end{alltt} +\end{small} + +Clever use of the letter 't'. + +\subsubsection{Subtraction} +The single digit subtraction algorithm mp\_sub\_d is essentially the same except it uses mp\_sub to subtract the digit from the mp\_int. + +\subsection{Single Digit Multiplication} +Single digit multiplication arises enough in division and radix conversion that it ought to be implement as a special case of the baseline +multiplication algorithm. Essentially this algorithm is a modified version of algorithm s\_mp\_mul\_digs where one of the multiplicands +only has one digit. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_mul\_d}. \\ +\textbf{Input}. mp\_int $a$ and a mp\_digit $b$ \\ +\textbf{Output}. $c = ab$ \\ +\hline \\ +1. $pa \leftarrow a.used$ \\ +2. Grow $c$ to at least $pa + 1$ digits. \\ +3. $oldused \leftarrow c.used$ \\ +4. $c.used \leftarrow pa + 1$ \\ +5. $c.sign \leftarrow a.sign$ \\ +6. $\mu \leftarrow 0$ \\ +7. for $ix$ from $0$ to $pa - 1$ do \\ +\hspace{3mm}7.1 $\hat r \leftarrow \mu + a_{ix}b$ \\ +\hspace{3mm}7.2 $c_{ix} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\ +\hspace{3mm}7.3 $\mu \leftarrow \lfloor \hat r / \beta \rfloor$ \\ +8. $c_{pa} \leftarrow \mu$ \\ +9. for $ix$ from $pa + 1$ to $oldused$ do \\ +\hspace{3mm}9.1 $c_{ix} \leftarrow 0$ \\ +10. Clamp excess digits of $c$. \\ +11. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_mul\_d} +\end{figure} +\textbf{Algorithm mp\_mul\_d.} +This algorithm quickly multiplies an mp\_int by a small single digit value. It is specially tailored to the job and has a minimal of overhead. +Unlike the full multiplication algorithms this algorithm does not require any significnat temporary storage or memory allocations. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_mul\_d.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* multiply by a digit */ +018 int +019 mp_mul_d (mp_int * a, mp_digit b, mp_int * c) +020 \{ +021 mp_digit u, *tmpa, *tmpc; +022 mp_word r; +023 int ix, res, olduse; +024 +025 /* make sure c is big enough to hold a*b */ +026 if (c->alloc < a->used + 1) \{ +027 if ((res = mp_grow (c, a->used + 1)) != MP_OKAY) \{ +028 return res; +029 \} +030 \} +031 +032 /* get the original destinations used count */ +033 olduse = c->used; +034 +035 /* set the sign */ +036 c->sign = a->sign; +037 +038 /* alias for a->dp [source] */ +039 tmpa = a->dp; +040 +041 /* alias for c->dp [dest] */ +042 tmpc = c->dp; +043 +044 /* zero carry */ +045 u = 0; +046 +047 /* compute columns */ +048 for (ix = 0; ix < a->used; ix++) \{ +049 /* compute product and carry sum for this term */ +050 r = ((mp_word) u) + ((mp_word)*tmpa++) * ((mp_word)b); +051 +052 /* mask off higher bits to get a single digit */ +053 *tmpc++ = (mp_digit) (r & ((mp_word) MP_MASK)); +054 +055 /* send carry into next iteration */ +056 u = (mp_digit) (r >> ((mp_word) DIGIT_BIT)); +057 \} +058 +059 /* store final carry [if any] and increment ix offset */ +060 *tmpc++ = u; +061 ++ix; +062 +063 /* now zero digits above the top */ +064 while (ix++ < olduse) \{ +065 *tmpc++ = 0; +066 \} +067 +068 /* set used count */ +069 c->used = a->used + 1; +070 mp_clamp(c); +071 +072 return MP_OKAY; +073 \} +074 #endif +075 +\end{alltt} +\end{small} + +In this implementation the destination $c$ may point to the same mp\_int as the source $a$ since the result is written after the digit is +read from the source. This function uses pointer aliases $tmpa$ and $tmpc$ for the digits of $a$ and $c$ respectively. + +\subsection{Single Digit Division} +Like the single digit multiplication algorithm, single digit division is also a fairly common algorithm used in radix conversion. Since the +divisor is only a single digit a specialized variant of the division algorithm can be used to compute the quotient. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_div\_d}. \\ +\textbf{Input}. mp\_int $a$ and a mp\_digit $b$ \\ +\textbf{Output}. $c = \lfloor a / b \rfloor, d = a - cb$ \\ +\hline \\ +1. If $b = 0$ then return(\textit{MP\_VAL}).\\ +2. If $b = 3$ then use algorithm mp\_div\_3 instead. \\ +3. Init $q$ to $a.used$ digits. \\ +4. $q.used \leftarrow a.used$ \\ +5. $q.sign \leftarrow a.sign$ \\ +6. $\hat w \leftarrow 0$ \\ +7. for $ix$ from $a.used - 1$ down to $0$ do \\ +\hspace{3mm}7.1 $\hat w \leftarrow \hat w \beta + a_{ix}$ \\ +\hspace{3mm}7.2 If $\hat w \ge b$ then \\ +\hspace{6mm}7.2.1 $t \leftarrow \lfloor \hat w / b \rfloor$ \\ +\hspace{6mm}7.2.2 $\hat w \leftarrow \hat w \mbox{ (mod }b\mbox{)}$ \\ +\hspace{3mm}7.3 else\\ +\hspace{6mm}7.3.1 $t \leftarrow 0$ \\ +\hspace{3mm}7.4 $q_{ix} \leftarrow t$ \\ +8. $d \leftarrow \hat w$ \\ +9. Clamp excess digits of $q$. \\ +10. $c \leftarrow q$ \\ +11. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_div\_d} +\end{figure} +\textbf{Algorithm mp\_div\_d.} +This algorithm divides the mp\_int $a$ by the single mp\_digit $b$ using an optimized approach. Essentially in every iteration of the +algorithm another digit of the dividend is reduced and another digit of quotient produced. Provided $b < \beta$ the value of $\hat w$ +after step 7.1 will be limited such that $0 \le \lfloor \hat w / b \rfloor < \beta$. + +If the divisor $b$ is equal to three a variant of this algorithm is used which is called mp\_div\_3. It replaces the division by three with +a multiplication by $\lfloor \beta / 3 \rfloor$ and the appropriate shift and residual fixup. In essence it is much like the Barrett reduction +from chapter seven. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_div\_d.c +\vspace{-3mm} +\begin{alltt} +016 +017 static int s_is_power_of_two(mp_digit b, int *p) +018 \{ +019 int x; +020 +021 for (x = 1; x < DIGIT_BIT; x++) \{ +022 if (b == (((mp_digit)1)<dp[0] & ((((mp_digit)1)<used)) != MP_OKAY) \{ +074 return res; +075 \} +076 +077 q.used = a->used; +078 q.sign = a->sign; +079 w = 0; +080 for (ix = a->used - 1; ix >= 0; ix--) \{ +081 w = (w << ((mp_word)DIGIT_BIT)) | ((mp_word)a->dp[ix]); +082 +083 if (w >= b) \{ +084 t = (mp_digit)(w / b); +085 w -= ((mp_word)t) * ((mp_word)b); +086 \} else \{ +087 t = 0; +088 \} +089 q.dp[ix] = (mp_digit)t; +090 \} +091 +092 if (d != NULL) \{ +093 *d = (mp_digit)w; +094 \} +095 +096 if (c != NULL) \{ +097 mp_clamp(&q); +098 mp_exch(&q, c); +099 \} +100 mp_clear(&q); +101 +102 return res; +103 \} +104 +105 #endif +106 +\end{alltt} +\end{small} + +Like the implementation of algorithm mp\_div this algorithm allows either of the quotient or remainder to be passed as a \textbf{NULL} pointer to +indicate the respective value is not required. This allows a trivial single digit modular reduction algorithm, mp\_mod\_d to be created. + +The division and remainder on lines 43 and @45,%@ can be replaced often by a single division on most processors. For example, the 32-bit x86 based +processors can divide a 64-bit quantity by a 32-bit quantity and produce the quotient and remainder simultaneously. Unfortunately the GCC +compiler does not recognize that optimization and will actually produce two function calls to find the quotient and remainder respectively. + +\subsection{Single Digit Root Extraction} + +Finding the $n$'th root of an integer is fairly easy as far as numerical analysis is concerned. Algorithms such as the Newton-Raphson approximation +(\ref{eqn:newton}) series will converge very quickly to a root for any continuous function $f(x)$. + +\begin{equation} +x_{i+1} = x_i - {f(x_i) \over f'(x_i)} +\label{eqn:newton} +\end{equation} + +In this case the $n$'th root is desired and $f(x) = x^n - a$ where $a$ is the integer of which the root is desired. The derivative of $f(x)$ is +simply $f'(x) = nx^{n - 1}$. Of particular importance is that this algorithm will be used over the integers not over the a more continuous domain +such as the real numbers. As a result the root found can be above the true root by few and must be manually adjusted. Ideally at the end of the +algorithm the $n$'th root $b$ of an integer $a$ is desired such that $b^n \le a$. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_n\_root}. \\ +\textbf{Input}. mp\_int $a$ and a mp\_digit $b$ \\ +\textbf{Output}. $c^b \le a$ \\ +\hline \\ +1. If $b$ is even and $a.sign = MP\_NEG$ return(\textit{MP\_VAL}). \\ +2. $sign \leftarrow a.sign$ \\ +3. $a.sign \leftarrow MP\_ZPOS$ \\ +4. t$2 \leftarrow 2$ \\ +5. Loop \\ +\hspace{3mm}5.1 t$1 \leftarrow $ t$2$ \\ +\hspace{3mm}5.2 t$3 \leftarrow $ t$1^{b - 1}$ \\ +\hspace{3mm}5.3 t$2 \leftarrow $ t$3 $ $\cdot$ t$1$ \\ +\hspace{3mm}5.4 t$2 \leftarrow $ t$2 - a$ \\ +\hspace{3mm}5.5 t$3 \leftarrow $ t$3 \cdot b$ \\ +\hspace{3mm}5.6 t$3 \leftarrow \lfloor $t$2 / $t$3 \rfloor$ \\ +\hspace{3mm}5.7 t$2 \leftarrow $ t$1 - $ t$3$ \\ +\hspace{3mm}5.8 If t$1 \ne $ t$2$ then goto step 5. \\ +6. Loop \\ +\hspace{3mm}6.1 t$2 \leftarrow $ t$1^b$ \\ +\hspace{3mm}6.2 If t$2 > a$ then \\ +\hspace{6mm}6.2.1 t$1 \leftarrow $ t$1 - 1$ \\ +\hspace{6mm}6.2.2 Goto step 6. \\ +7. $a.sign \leftarrow sign$ \\ +8. $c \leftarrow $ t$1$ \\ +9. $c.sign \leftarrow sign$ \\ +10. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_n\_root} +\end{figure} +\textbf{Algorithm mp\_n\_root.} +This algorithm finds the integer $n$'th root of an input using the Newton-Raphson approach. It is partially optimized based on the observation +that the numerator of ${f(x) \over f'(x)}$ can be derived from a partial denominator. That is at first the denominator is calculated by finding +$x^{b - 1}$. This value can then be multiplied by $x$ and have $a$ subtracted from it to find the numerator. This saves a total of $b - 1$ +multiplications by t$1$ inside the loop. + +The initial value of the approximation is t$2 = 2$ which allows the algorithm to start with very small values and quickly converge on the +root. Ideally this algorithm is meant to find the $n$'th root of an input where $n$ is bounded by $2 \le n \le 5$. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_n\_root.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* find the n'th root of an integer +018 * +019 * Result found such that (c)**b <= a and (c+1)**b > a +020 * +021 * This algorithm uses Newton's approximation +022 * x[i+1] = x[i] - f(x[i])/f'(x[i]) +023 * which will find the root in log(N) time where +024 * each step involves a fair bit. This is not meant to +025 * find huge roots [square and cube, etc]. +026 */ +027 int mp_n_root (mp_int * a, mp_digit b, mp_int * c) +028 \{ +029 mp_int t1, t2, t3; +030 int res, neg; +031 +032 /* input must be positive if b is even */ +033 if ((b & 1) == 0 && a->sign == MP_NEG) \{ +034 return MP_VAL; +035 \} +036 +037 if ((res = mp_init (&t1)) != MP_OKAY) \{ +038 return res; +039 \} +040 +041 if ((res = mp_init (&t2)) != MP_OKAY) \{ +042 goto LBL_T1; +043 \} +044 +045 if ((res = mp_init (&t3)) != MP_OKAY) \{ +046 goto LBL_T2; +047 \} +048 +049 /* if a is negative fudge the sign but keep track */ +050 neg = a->sign; +051 a->sign = MP_ZPOS; +052 +053 /* t2 = 2 */ +054 mp_set (&t2, 2); +055 +056 do \{ +057 /* t1 = t2 */ +058 if ((res = mp_copy (&t2, &t1)) != MP_OKAY) \{ +059 goto LBL_T3; +060 \} +061 +062 /* t2 = t1 - ((t1**b - a) / (b * t1**(b-1))) */ +063 +064 /* t3 = t1**(b-1) */ +065 if ((res = mp_expt_d (&t1, b - 1, &t3)) != MP_OKAY) \{ +066 goto LBL_T3; +067 \} +068 +069 /* numerator */ +070 /* t2 = t1**b */ +071 if ((res = mp_mul (&t3, &t1, &t2)) != MP_OKAY) \{ +072 goto LBL_T3; +073 \} +074 +075 /* t2 = t1**b - a */ +076 if ((res = mp_sub (&t2, a, &t2)) != MP_OKAY) \{ +077 goto LBL_T3; +078 \} +079 +080 /* denominator */ +081 /* t3 = t1**(b-1) * b */ +082 if ((res = mp_mul_d (&t3, b, &t3)) != MP_OKAY) \{ +083 goto LBL_T3; +084 \} +085 +086 /* t3 = (t1**b - a)/(b * t1**(b-1)) */ +087 if ((res = mp_div (&t2, &t3, &t3, NULL)) != MP_OKAY) \{ +088 goto LBL_T3; +089 \} +090 +091 if ((res = mp_sub (&t1, &t3, &t2)) != MP_OKAY) \{ +092 goto LBL_T3; +093 \} +094 \} while (mp_cmp (&t1, &t2) != MP_EQ); +095 +096 /* result can be off by a few so check */ +097 for (;;) \{ +098 if ((res = mp_expt_d (&t1, b, &t2)) != MP_OKAY) \{ +099 goto LBL_T3; +100 \} +101 +102 if (mp_cmp (&t2, a) == MP_GT) \{ +103 if ((res = mp_sub_d (&t1, 1, &t1)) != MP_OKAY) \{ +104 goto LBL_T3; +105 \} +106 \} else \{ +107 break; +108 \} +109 \} +110 +111 /* reset the sign of a first */ +112 a->sign = neg; +113 +114 /* set the result */ +115 mp_exch (&t1, c); +116 +117 /* set the sign of the result */ +118 c->sign = neg; +119 +120 res = MP_OKAY; +121 +122 LBL_T3:mp_clear (&t3); +123 LBL_T2:mp_clear (&t2); +124 LBL_T1:mp_clear (&t1); +125 return res; +126 \} +127 #endif +128 +\end{alltt} +\end{small} + +\section{Random Number Generation} + +Random numbers come up in a variety of activities from public key cryptography to simple simulations and various randomized algorithms. Pollard-Rho +factoring for example, can make use of random values as starting points to find factors of a composite integer. In this case the algorithm presented +is solely for simulations and not intended for cryptographic use. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_rand}. \\ +\textbf{Input}. An integer $b$ \\ +\textbf{Output}. A pseudo-random number of $b$ digits \\ +\hline \\ +1. $a \leftarrow 0$ \\ +2. If $b \le 0$ return(\textit{MP\_OKAY}) \\ +3. Pick a non-zero random digit $d$. \\ +4. $a \leftarrow a + d$ \\ +5. for $ix$ from 1 to $d - 1$ do \\ +\hspace{3mm}5.1 $a \leftarrow a \cdot \beta$ \\ +\hspace{3mm}5.2 Pick a random digit $d$. \\ +\hspace{3mm}5.3 $a \leftarrow a + d$ \\ +6. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_rand} +\end{figure} +\textbf{Algorithm mp\_rand.} +This algorithm produces a pseudo-random integer of $b$ digits. By ensuring that the first digit is non-zero the algorithm also guarantees that the +final result has at least $b$ digits. It relies heavily on a third-part random number generator which should ideally generate uniformly all of +the integers from $0$ to $\beta - 1$. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_rand.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* makes a pseudo-random int of a given size */ +018 int +019 mp_rand (mp_int * a, int digits) +020 \{ +021 int res; +022 mp_digit d; +023 +024 mp_zero (a); +025 if (digits <= 0) \{ +026 return MP_OKAY; +027 \} +028 +029 /* first place a random non-zero digit */ +030 do \{ +031 d = ((mp_digit) abs (rand ())) & MP_MASK; +032 \} while (d == 0); +033 +034 if ((res = mp_add_d (a, d, a)) != MP_OKAY) \{ +035 return res; +036 \} +037 +038 while (--digits > 0) \{ +039 if ((res = mp_lshd (a, 1)) != MP_OKAY) \{ +040 return res; +041 \} +042 +043 if ((res = mp_add_d (a, ((mp_digit) abs (rand ())), a)) != MP_OKAY) \{ +044 return res; +045 \} +046 \} +047 +048 return MP_OKAY; +049 \} +050 #endif +051 +\end{alltt} +\end{small} + +\section{Formatted Representations} +The ability to emit a radix-$n$ textual representation of an integer is useful for interacting with human parties. For example, the ability to +be given a string of characters such as ``114585'' and turn it into the radix-$\beta$ equivalent would make it easier to enter numbers +into a program. + +\subsection{Reading Radix-n Input} +For the purposes of this text we will assume that a simple lower ASCII map (\ref{fig:ASC}) is used for the values of from $0$ to $63$ to +printable characters. For example, when the character ``N'' is read it represents the integer $23$. The first $16$ characters of the +map are for the common representations up to hexadecimal. After that they match the ``base64'' encoding scheme which are suitable chosen +such that they are printable. While outputting as base64 may not be too helpful for human operators it does allow communication via non binary +mediums. + +\newpage\begin{figure}[here] +\begin{center} +\begin{tabular}{cc|cc|cc|cc} +\hline \textbf{Value} & \textbf{Char} & \textbf{Value} & \textbf{Char} & \textbf{Value} & \textbf{Char} & \textbf{Value} & \textbf{Char} \\ +\hline +0 & 0 & 1 & 1 & 2 & 2 & 3 & 3 \\ +4 & 4 & 5 & 5 & 6 & 6 & 7 & 7 \\ +8 & 8 & 9 & 9 & 10 & A & 11 & B \\ +12 & C & 13 & D & 14 & E & 15 & F \\ +16 & G & 17 & H & 18 & I & 19 & J \\ +20 & K & 21 & L & 22 & M & 23 & N \\ +24 & O & 25 & P & 26 & Q & 27 & R \\ +28 & S & 29 & T & 30 & U & 31 & V \\ +32 & W & 33 & X & 34 & Y & 35 & Z \\ +36 & a & 37 & b & 38 & c & 39 & d \\ +40 & e & 41 & f & 42 & g & 43 & h \\ +44 & i & 45 & j & 46 & k & 47 & l \\ +48 & m & 49 & n & 50 & o & 51 & p \\ +52 & q & 53 & r & 54 & s & 55 & t \\ +56 & u & 57 & v & 58 & w & 59 & x \\ +60 & y & 61 & z & 62 & $+$ & 63 & $/$ \\ +\hline +\end{tabular} +\end{center} +\caption{Lower ASCII Map} +\label{fig:ASC} +\end{figure} + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_read\_radix}. \\ +\textbf{Input}. A string $str$ of length $sn$ and radix $r$. \\ +\textbf{Output}. The radix-$\beta$ equivalent mp\_int. \\ +\hline \\ +1. If $r < 2$ or $r > 64$ return(\textit{MP\_VAL}). \\ +2. $ix \leftarrow 0$ \\ +3. If $str_0 =$ ``-'' then do \\ +\hspace{3mm}3.1 $ix \leftarrow ix + 1$ \\ +\hspace{3mm}3.2 $sign \leftarrow MP\_NEG$ \\ +4. else \\ +\hspace{3mm}4.1 $sign \leftarrow MP\_ZPOS$ \\ +5. $a \leftarrow 0$ \\ +6. for $iy$ from $ix$ to $sn - 1$ do \\ +\hspace{3mm}6.1 Let $y$ denote the position in the map of $str_{iy}$. \\ +\hspace{3mm}6.2 If $str_{iy}$ is not in the map or $y \ge r$ then goto step 7. \\ +\hspace{3mm}6.3 $a \leftarrow a \cdot r$ \\ +\hspace{3mm}6.4 $a \leftarrow a + y$ \\ +7. If $a \ne 0$ then $a.sign \leftarrow sign$ \\ +8. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_read\_radix} +\end{figure} +\textbf{Algorithm mp\_read\_radix.} +This algorithm will read an ASCII string and produce the radix-$\beta$ mp\_int representation of the same integer. A minus symbol ``-'' may precede the +string to indicate the value is negative, otherwise it is assumed to be positive. The algorithm will read up to $sn$ characters from the input +and will stop when it reads a character it cannot map the algorithm stops reading characters from the string. This allows numbers to be embedded +as part of larger input without any significant problem. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_read\_radix.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* read a string [ASCII] in a given radix */ +018 int mp_read_radix (mp_int * a, const char *str, int radix) +019 \{ +020 int y, res, neg; +021 char ch; +022 +023 /* make sure the radix is ok */ +024 if (radix < 2 || radix > 64) \{ +025 return MP_VAL; +026 \} +027 +028 /* if the leading digit is a +029 * minus set the sign to negative. +030 */ +031 if (*str == '-') \{ +032 ++str; +033 neg = MP_NEG; +034 \} else \{ +035 neg = MP_ZPOS; +036 \} +037 +038 /* set the integer to the default of zero */ +039 mp_zero (a); +040 +041 /* process each digit of the string */ +042 while (*str) \{ +043 /* if the radix < 36 the conversion is case insensitive +044 * this allows numbers like 1AB and 1ab to represent the same value +045 * [e.g. in hex] +046 */ +047 ch = (char) ((radix < 36) ? toupper (*str) : *str); +048 for (y = 0; y < 64; y++) \{ +049 if (ch == mp_s_rmap[y]) \{ +050 break; +051 \} +052 \} +053 +054 /* if the char was found in the map +055 * and is less than the given radix add it +056 * to the number, otherwise exit the loop. +057 */ +058 if (y < radix) \{ +059 if ((res = mp_mul_d (a, (mp_digit) radix, a)) != MP_OKAY) \{ +060 return res; +061 \} +062 if ((res = mp_add_d (a, (mp_digit) y, a)) != MP_OKAY) \{ +063 return res; +064 \} +065 \} else \{ +066 break; +067 \} +068 ++str; +069 \} +070 +071 /* set the sign only if a != 0 */ +072 if (mp_iszero(a) != 1) \{ +073 a->sign = neg; +074 \} +075 return MP_OKAY; +076 \} +077 #endif +078 +\end{alltt} +\end{small} + +\subsection{Generating Radix-$n$ Output} +Generating radix-$n$ output is fairly trivial with a division and remainder algorithm. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_toradix}. \\ +\textbf{Input}. A mp\_int $a$ and an integer $r$\\ +\textbf{Output}. The radix-$r$ representation of $a$ \\ +\hline \\ +1. If $r < 2$ or $r > 64$ return(\textit{MP\_VAL}). \\ +2. If $a = 0$ then $str = $ ``$0$'' and return(\textit{MP\_OKAY}). \\ +3. $t \leftarrow a$ \\ +4. $str \leftarrow$ ``'' \\ +5. if $t.sign = MP\_NEG$ then \\ +\hspace{3mm}5.1 $str \leftarrow str + $ ``-'' \\ +\hspace{3mm}5.2 $t.sign = MP\_ZPOS$ \\ +6. While ($t \ne 0$) do \\ +\hspace{3mm}6.1 $d \leftarrow t \mbox{ (mod }r\mbox{)}$ \\ +\hspace{3mm}6.2 $t \leftarrow \lfloor t / r \rfloor$ \\ +\hspace{3mm}6.3 Look up $d$ in the map and store the equivalent character in $y$. \\ +\hspace{3mm}6.4 $str \leftarrow str + y$ \\ +7. If $str_0 = $``$-$'' then \\ +\hspace{3mm}7.1 Reverse the digits $str_1, str_2, \ldots str_n$. \\ +8. Otherwise \\ +\hspace{3mm}8.1 Reverse the digits $str_0, str_1, \ldots str_n$. \\ +9. Return(\textit{MP\_OKAY}).\\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_toradix} +\end{figure} +\textbf{Algorithm mp\_toradix.} +This algorithm computes the radix-$r$ representation of an mp\_int $a$. The ``digits'' of the representation are extracted by reducing +successive powers of $\lfloor a / r^k \rfloor$ the input modulo $r$ until $r^k > a$. Note that instead of actually dividing by $r^k$ in +each iteration the quotient $\lfloor a / r \rfloor$ is saved for the next iteration. As a result a series of trivial $n \times 1$ divisions +are required instead of a series of $n \times k$ divisions. One design flaw of this approach is that the digits are produced in the reverse order +(see~\ref{fig:mpradix}). To remedy this flaw the digits must be swapped or simply ``reversed''. + +\begin{figure} +\begin{center} +\begin{tabular}{|c|c|c|} +\hline \textbf{Value of $a$} & \textbf{Value of $d$} & \textbf{Value of $str$} \\ +\hline $1234$ & -- & -- \\ +\hline $123$ & $4$ & ``4'' \\ +\hline $12$ & $3$ & ``43'' \\ +\hline $1$ & $2$ & ``432'' \\ +\hline $0$ & $1$ & ``4321'' \\ +\hline +\end{tabular} +\end{center} +\caption{Example of Algorithm mp\_toradix.} +\label{fig:mpradix} +\end{figure} + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_toradix.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* stores a bignum as a ASCII string in a given radix (2..64) */ +018 int mp_toradix (mp_int * a, char *str, int radix) +019 \{ +020 int res, digs; +021 mp_int t; +022 mp_digit d; +023 char *_s = str; +024 +025 /* check range of the radix */ +026 if (radix < 2 || radix > 64) \{ +027 return MP_VAL; +028 \} +029 +030 /* quick out if its zero */ +031 if (mp_iszero(a) == 1) \{ +032 *str++ = '0'; +033 *str = '\symbol{92}0'; +034 return MP_OKAY; +035 \} +036 +037 if ((res = mp_init_copy (&t, a)) != MP_OKAY) \{ +038 return res; +039 \} +040 +041 /* if it is negative output a - */ +042 if (t.sign == MP_NEG) \{ +043 ++_s; +044 *str++ = '-'; +045 t.sign = MP_ZPOS; +046 \} +047 +048 digs = 0; +049 while (mp_iszero (&t) == 0) \{ +050 if ((res = mp_div_d (&t, (mp_digit) radix, &t, &d)) != MP_OKAY) \{ +051 mp_clear (&t); +052 return res; +053 \} +054 *str++ = mp_s_rmap[d]; +055 ++digs; +056 \} +057 +058 /* reverse the digits of the string. In this case _s points +059 * to the first digit [exluding the sign] of the number] +060 */ +061 bn_reverse ((unsigned char *)_s, digs); +062 +063 /* append a NULL so the string is properly terminated */ +064 *str = '\symbol{92}0'; +065 +066 mp_clear (&t); +067 return MP_OKAY; +068 \} +069 +070 #endif +071 +\end{alltt} +\end{small} + +\chapter{Number Theoretic Algorithms} +This chapter discusses several fundamental number theoretic algorithms such as the greatest common divisor, least common multiple and Jacobi +symbol computation. These algorithms arise as essential components in several key cryptographic algorithms such as the RSA public key algorithm and +various Sieve based factoring algorithms. + +\section{Greatest Common Divisor} +The greatest common divisor of two integers $a$ and $b$, often denoted as $(a, b)$ is the largest integer $k$ that is a proper divisor of +both $a$ and $b$. That is, $k$ is the largest integer such that $0 \equiv a \mbox{ (mod }k\mbox{)}$ and $0 \equiv b \mbox{ (mod }k\mbox{)}$ occur +simultaneously. + +The most common approach (cite) is to reduce one input modulo another. That is if $a$ and $b$ are divisible by some integer $k$ and if $qa + r = b$ then +$r$ is also divisible by $k$. The reduction pattern follows $\left < a , b \right > \rightarrow \left < b, a \mbox{ mod } b \right >$. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{Greatest Common Divisor (I)}. \\ +\textbf{Input}. Two positive integers $a$ and $b$ greater than zero. \\ +\textbf{Output}. The greatest common divisor $(a, b)$. \\ +\hline \\ +1. While ($b > 0$) do \\ +\hspace{3mm}1.1 $r \leftarrow a \mbox{ (mod }b\mbox{)}$ \\ +\hspace{3mm}1.2 $a \leftarrow b$ \\ +\hspace{3mm}1.3 $b \leftarrow r$ \\ +2. Return($a$). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm Greatest Common Divisor (I)} +\label{fig:gcd1} +\end{figure} + +This algorithm will quickly converge on the greatest common divisor since the residue $r$ tends diminish rapidly. However, divisions are +relatively expensive operations to perform and should ideally be avoided. There is another approach based on a similar relationship of +greatest common divisors. The faster approach is based on the observation that if $k$ divides both $a$ and $b$ it will also divide $a - b$. +In particular, we would like $a - b$ to decrease in magnitude which implies that $b \ge a$. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{Greatest Common Divisor (II)}. \\ +\textbf{Input}. Two positive integers $a$ and $b$ greater than zero. \\ +\textbf{Output}. The greatest common divisor $(a, b)$. \\ +\hline \\ +1. While ($b > 0$) do \\ +\hspace{3mm}1.1 Swap $a$ and $b$ such that $a$ is the smallest of the two. \\ +\hspace{3mm}1.2 $b \leftarrow b - a$ \\ +2. Return($a$). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm Greatest Common Divisor (II)} +\label{fig:gcd2} +\end{figure} + +\textbf{Proof} \textit{Algorithm~\ref{fig:gcd2} will return the greatest common divisor of $a$ and $b$.} +The algorithm in figure~\ref{fig:gcd2} will eventually terminate since $b \ge a$ the subtraction in step 1.2 will be a value less than $b$. In other +words in every iteration that tuple $\left < a, b \right >$ decrease in magnitude until eventually $a = b$. Since both $a$ and $b$ are always +divisible by the greatest common divisor (\textit{until the last iteration}) and in the last iteration of the algorithm $b = 0$, therefore, in the +second to last iteration of the algorithm $b = a$ and clearly $(a, a) = a$ which concludes the proof. \textbf{QED}. + +As a matter of practicality algorithm \ref{fig:gcd1} decreases far too slowly to be useful. Specially if $b$ is much larger than $a$ such that +$b - a$ is still very much larger than $a$. A simple addition to the algorithm is to divide $b - a$ by a power of some integer $p$ which does +not divide the greatest common divisor but will divide $b - a$. In this case ${b - a} \over p$ is also an integer and still divisible by +the greatest common divisor. + +However, instead of factoring $b - a$ to find a suitable value of $p$ the powers of $p$ can be removed from $a$ and $b$ that are in common first. +Then inside the loop whenever $b - a$ is divisible by some power of $p$ it can be safely removed. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{Greatest Common Divisor (III)}. \\ +\textbf{Input}. Two positive integers $a$ and $b$ greater than zero. \\ +\textbf{Output}. The greatest common divisor $(a, b)$. \\ +\hline \\ +1. $k \leftarrow 0$ \\ +2. While $a$ and $b$ are both divisible by $p$ do \\ +\hspace{3mm}2.1 $a \leftarrow \lfloor a / p \rfloor$ \\ +\hspace{3mm}2.2 $b \leftarrow \lfloor b / p \rfloor$ \\ +\hspace{3mm}2.3 $k \leftarrow k + 1$ \\ +3. While $a$ is divisible by $p$ do \\ +\hspace{3mm}3.1 $a \leftarrow \lfloor a / p \rfloor$ \\ +4. While $b$ is divisible by $p$ do \\ +\hspace{3mm}4.1 $b \leftarrow \lfloor b / p \rfloor$ \\ +5. While ($b > 0$) do \\ +\hspace{3mm}5.1 Swap $a$ and $b$ such that $a$ is the smallest of the two. \\ +\hspace{3mm}5.2 $b \leftarrow b - a$ \\ +\hspace{3mm}5.3 While $b$ is divisible by $p$ do \\ +\hspace{6mm}5.3.1 $b \leftarrow \lfloor b / p \rfloor$ \\ +6. Return($a \cdot p^k$). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm Greatest Common Divisor (III)} +\label{fig:gcd3} +\end{figure} + +This algorithm is based on the first except it removes powers of $p$ first and inside the main loop to ensure the tuple $\left < a, b \right >$ +decreases more rapidly. The first loop on step two removes powers of $p$ that are in common. A count, $k$, is kept which will present a common +divisor of $p^k$. After step two the remaining common divisor of $a$ and $b$ cannot be divisible by $p$. This means that $p$ can be safely +divided out of the difference $b - a$ so long as the division leaves no remainder. + +In particular the value of $p$ should be chosen such that the division on step 5.3.1 occur often. It also helps that division by $p$ be easy +to compute. The ideal choice of $p$ is two since division by two amounts to a right logical shift. Another important observation is that by +step five both $a$ and $b$ are odd. Therefore, the diffrence $b - a$ must be even which means that each iteration removes one bit from the +largest of the pair. + +\subsection{Complete Greatest Common Divisor} +The algorithms presented so far cannot handle inputs which are zero or negative. The following algorithm can handle all input cases properly +and will produce the greatest common divisor. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_gcd}. \\ +\textbf{Input}. mp\_int $a$ and $b$ \\ +\textbf{Output}. The greatest common divisor $c = (a, b)$. \\ +\hline \\ +1. If $a = 0$ and $b \ne 0$ then \\ +\hspace{3mm}1.1 $c \leftarrow b$ \\ +\hspace{3mm}1.2 Return(\textit{MP\_OKAY}). \\ +2. If $a \ne 0$ and $b = 0$ then \\ +\hspace{3mm}2.1 $c \leftarrow a$ \\ +\hspace{3mm}2.2 Return(\textit{MP\_OKAY}). \\ +3. If $a = b = 0$ then \\ +\hspace{3mm}3.1 $c \leftarrow 1$ \\ +\hspace{3mm}3.2 Return(\textit{MP\_OKAY}). \\ +4. $u \leftarrow \vert a \vert, v \leftarrow \vert b \vert$ \\ +5. $k \leftarrow 0$ \\ +6. While $u.used > 0$ and $v.used > 0$ and $u_0 \equiv v_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\ +\hspace{3mm}6.1 $k \leftarrow k + 1$ \\ +\hspace{3mm}6.2 $u \leftarrow \lfloor u / 2 \rfloor$ \\ +\hspace{3mm}6.3 $v \leftarrow \lfloor v / 2 \rfloor$ \\ +7. While $u.used > 0$ and $u_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\ +\hspace{3mm}7.1 $u \leftarrow \lfloor u / 2 \rfloor$ \\ +8. While $v.used > 0$ and $v_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\ +\hspace{3mm}8.1 $v \leftarrow \lfloor v / 2 \rfloor$ \\ +9. While $v.used > 0$ \\ +\hspace{3mm}9.1 If $\vert u \vert > \vert v \vert$ then \\ +\hspace{6mm}9.1.1 Swap $u$ and $v$. \\ +\hspace{3mm}9.2 $v \leftarrow \vert v \vert - \vert u \vert$ \\ +\hspace{3mm}9.3 While $v.used > 0$ and $v_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\ +\hspace{6mm}9.3.1 $v \leftarrow \lfloor v / 2 \rfloor$ \\ +10. $c \leftarrow u \cdot 2^k$ \\ +11. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_gcd} +\end{figure} +\textbf{Algorithm mp\_gcd.} +This algorithm will produce the greatest common divisor of two mp\_ints $a$ and $b$. The algorithm was originally based on Algorithm B of +Knuth \cite[pp. 338]{TAOCPV2} but has been modified to be simpler to explain. In theory it achieves the same asymptotic working time as +Algorithm B and in practice this appears to be true. + +The first three steps handle the cases where either one of or both inputs are zero. If either input is zero the greatest common divisor is the +largest input or zero if they are both zero. If the inputs are not trivial than $u$ and $v$ are assigned the absolute values of +$a$ and $b$ respectively and the algorithm will proceed to reduce the pair. + +Step six will divide out any common factors of two and keep track of the count in the variable $k$. After this step two is no longer a +factor of the remaining greatest common divisor between $u$ and $v$ and can be safely evenly divided out of either whenever they are even. Step +seven and eight ensure that the $u$ and $v$ respectively have no more factors of two. At most only one of the while loops will iterate since +they cannot both be even. + +By step nine both of $u$ and $v$ are odd which is required for the inner logic. First the pair are swapped such that $v$ is equal to +or greater than $u$. This ensures that the subtraction on step 9.2 will always produce a positive and even result. Step 9.3 removes any +factors of two from the difference $u$ to ensure that in the next iteration of the loop both are once again odd. + +After $v = 0$ occurs the variable $u$ has the greatest common divisor of the pair $\left < u, v \right >$ just after step six. The result +must be adjusted by multiplying by the common factors of two ($2^k$) removed earlier. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_gcd.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* Greatest Common Divisor using the binary method */ +018 int mp_gcd (mp_int * a, mp_int * b, mp_int * c) +019 \{ +020 mp_int u, v; +021 int k, u_lsb, v_lsb, res; +022 +023 /* either zero than gcd is the largest */ +024 if (mp_iszero (a) == 1 && mp_iszero (b) == 0) \{ +025 return mp_abs (b, c); +026 \} +027 if (mp_iszero (a) == 0 && mp_iszero (b) == 1) \{ +028 return mp_abs (a, c); +029 \} +030 +031 /* optimized. At this point if a == 0 then +032 * b must equal zero too +033 */ +034 if (mp_iszero (a) == 1) \{ +035 mp_zero(c); +036 return MP_OKAY; +037 \} +038 +039 /* get copies of a and b we can modify */ +040 if ((res = mp_init_copy (&u, a)) != MP_OKAY) \{ +041 return res; +042 \} +043 +044 if ((res = mp_init_copy (&v, b)) != MP_OKAY) \{ +045 goto LBL_U; +046 \} +047 +048 /* must be positive for the remainder of the algorithm */ +049 u.sign = v.sign = MP_ZPOS; +050 +051 /* B1. Find the common power of two for u and v */ +052 u_lsb = mp_cnt_lsb(&u); +053 v_lsb = mp_cnt_lsb(&v); +054 k = MIN(u_lsb, v_lsb); +055 +056 if (k > 0) \{ +057 /* divide the power of two out */ +058 if ((res = mp_div_2d(&u, k, &u, NULL)) != MP_OKAY) \{ +059 goto LBL_V; +060 \} +061 +062 if ((res = mp_div_2d(&v, k, &v, NULL)) != MP_OKAY) \{ +063 goto LBL_V; +064 \} +065 \} +066 +067 /* divide any remaining factors of two out */ +068 if (u_lsb != k) \{ +069 if ((res = mp_div_2d(&u, u_lsb - k, &u, NULL)) != MP_OKAY) \{ +070 goto LBL_V; +071 \} +072 \} +073 +074 if (v_lsb != k) \{ +075 if ((res = mp_div_2d(&v, v_lsb - k, &v, NULL)) != MP_OKAY) \{ +076 goto LBL_V; +077 \} +078 \} +079 +080 while (mp_iszero(&v) == 0) \{ +081 /* make sure v is the largest */ +082 if (mp_cmp_mag(&u, &v) == MP_GT) \{ +083 /* swap u and v to make sure v is >= u */ +084 mp_exch(&u, &v); +085 \} +086 +087 /* subtract smallest from largest */ +088 if ((res = s_mp_sub(&v, &u, &v)) != MP_OKAY) \{ +089 goto LBL_V; +090 \} +091 +092 /* Divide out all factors of two */ +093 if ((res = mp_div_2d(&v, mp_cnt_lsb(&v), &v, NULL)) != MP_OKAY) \{ +094 goto LBL_V; +095 \} +096 \} +097 +098 /* multiply by 2**k which we divided out at the beginning */ +099 if ((res = mp_mul_2d (&u, k, c)) != MP_OKAY) \{ +100 goto LBL_V; +101 \} +102 c->sign = MP_ZPOS; +103 res = MP_OKAY; +104 LBL_V:mp_clear (&u); +105 LBL_U:mp_clear (&v); +106 return res; +107 \} +108 #endif +109 +\end{alltt} +\end{small} + +This function makes use of the macros mp\_iszero and mp\_iseven. The former evaluates to $1$ if the input mp\_int is equivalent to the +integer zero otherwise it evaluates to $0$. The latter evaluates to $1$ if the input mp\_int represents a non-zero even integer otherwise +it evaluates to $0$. Note that just because mp\_iseven may evaluate to $0$ does not mean the input is odd, it could also be zero. The three +trivial cases of inputs are handled on lines 24 through 37. After those lines the inputs are assumed to be non-zero. + +Lines 34 and 40 make local copies $u$ and $v$ of the inputs $a$ and $b$ respectively. At this point the common factors of two +must be divided out of the two inputs. The while loop on line 80 iterates so long as both are even. The local integer $k$ is used to +keep track of how many factors of $2$ are pulled out of both values. It is assumed that the number of factors will not exceed the maximum +value of a C ``int'' data type\footnote{Strictly speaking no array in C may have more than entries than are accessible by an ``int'' so this is not +a limitation.}. + +At this point there are no more common factors of two in the two values. The while loops on lines 80 and 80 remove any independent +factors of two such that both $u$ and $v$ are guaranteed to be an odd integer before hitting the main body of the algorithm. The while loop +on line 80 performs the reduction of the pair until $v$ is equal to zero. The unsigned comparison and subtraction algorithms are used in +place of the full signed routines since both values are guaranteed to be positive and the result of the subtraction is guaranteed to be non-negative. + +\section{Least Common Multiple} +The least common multiple of a pair of integers is their product divided by their greatest common divisor. For two integers $a$ and $b$ the +least common multiple is normally denoted as $[ a, b ]$ and numerically equivalent to ${ab} \over {(a, b)}$. For example, if $a = 2 \cdot 2 \cdot 3 = 12$ +and $b = 2 \cdot 3 \cdot 3 \cdot 7 = 126$ the least common multiple is ${126 \over {(12, 126)}} = {126 \over 6} = 21$. + +The least common multiple arises often in coding theory as well as number theory. If two functions have periods of $a$ and $b$ respectively they will +collide, that is be in synchronous states, after only $[ a, b ]$ iterations. This is why, for example, random number generators based on +Linear Feedback Shift Registers (LFSR) tend to use registers with periods which are co-prime (\textit{e.g. the greatest common divisor is one.}). +Similarly in number theory if a composite $n$ has two prime factors $p$ and $q$ then maximal order of any unit of $\Z/n\Z$ will be $[ p - 1, q - 1] $. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_lcm}. \\ +\textbf{Input}. mp\_int $a$ and $b$ \\ +\textbf{Output}. The least common multiple $c = [a, b]$. \\ +\hline \\ +1. $c \leftarrow (a, b)$ \\ +2. $t \leftarrow a \cdot b$ \\ +3. $c \leftarrow \lfloor t / c \rfloor$ \\ +4. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_lcm} +\end{figure} +\textbf{Algorithm mp\_lcm.} +This algorithm computes the least common multiple of two mp\_int inputs $a$ and $b$. It computes the least common multiple directly by +dividing the product of the two inputs by their greatest common divisor. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_lcm.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* computes least common multiple as |a*b|/(a, b) */ +018 int mp_lcm (mp_int * a, mp_int * b, mp_int * c) +019 \{ +020 int res; +021 mp_int t1, t2; +022 +023 +024 if ((res = mp_init_multi (&t1, &t2, NULL)) != MP_OKAY) \{ +025 return res; +026 \} +027 +028 /* t1 = get the GCD of the two inputs */ +029 if ((res = mp_gcd (a, b, &t1)) != MP_OKAY) \{ +030 goto LBL_T; +031 \} +032 +033 /* divide the smallest by the GCD */ +034 if (mp_cmp_mag(a, b) == MP_LT) \{ +035 /* store quotient in t2 such that t2 * b is the LCM */ +036 if ((res = mp_div(a, &t1, &t2, NULL)) != MP_OKAY) \{ +037 goto LBL_T; +038 \} +039 res = mp_mul(b, &t2, c); +040 \} else \{ +041 /* store quotient in t2 such that t2 * a is the LCM */ +042 if ((res = mp_div(b, &t1, &t2, NULL)) != MP_OKAY) \{ +043 goto LBL_T; +044 \} +045 res = mp_mul(a, &t2, c); +046 \} +047 +048 /* fix the sign to positive */ +049 c->sign = MP_ZPOS; +050 +051 LBL_T: +052 mp_clear_multi (&t1, &t2, NULL); +053 return res; +054 \} +055 #endif +056 +\end{alltt} +\end{small} + +\section{Jacobi Symbol Computation} +To explain the Jacobi Symbol we shall first discuss the Legendre function\footnote{Arrg. What is the name of this?} off which the Jacobi symbol is +defined. The Legendre function computes whether or not an integer $a$ is a quadratic residue modulo an odd prime $p$. Numerically it is +equivalent to equation \ref{eqn:legendre}. + +\textit{-- Tom, don't be an ass, cite your source here...!} + +\begin{equation} +a^{(p-1)/2} \equiv \begin{array}{rl} + -1 & \mbox{if }a\mbox{ is a quadratic non-residue.} \\ + 0 & \mbox{if }a\mbox{ divides }p\mbox{.} \\ + 1 & \mbox{if }a\mbox{ is a quadratic residue}. + \end{array} \mbox{ (mod }p\mbox{)} +\label{eqn:legendre} +\end{equation} + +\textbf{Proof.} \textit{Equation \ref{eqn:legendre} correctly identifies the residue status of an integer $a$ modulo a prime $p$.} +An integer $a$ is a quadratic residue if the following equation has a solution. + +\begin{equation} +x^2 \equiv a \mbox{ (mod }p\mbox{)} +\label{eqn:root} +\end{equation} + +Consider the following equation. + +\begin{equation} +0 \equiv x^{p-1} - 1 \equiv \left \lbrace \left (x^2 \right )^{(p-1)/2} - a^{(p-1)/2} \right \rbrace + \left ( a^{(p-1)/2} - 1 \right ) \mbox{ (mod }p\mbox{)} +\label{eqn:rooti} +\end{equation} + +Whether equation \ref{eqn:root} has a solution or not equation \ref{eqn:rooti} is always true. If $a^{(p-1)/2} - 1 \equiv 0 \mbox{ (mod }p\mbox{)}$ +then the quantity in the braces must be zero. By reduction, + +\begin{eqnarray} +\left (x^2 \right )^{(p-1)/2} - a^{(p-1)/2} \equiv 0 \nonumber \\ +\left (x^2 \right )^{(p-1)/2} \equiv a^{(p-1)/2} \nonumber \\ +x^2 \equiv a \mbox{ (mod }p\mbox{)} +\end{eqnarray} + +As a result there must be a solution to the quadratic equation and in turn $a$ must be a quadratic residue. If $a$ does not divide $p$ and $a$ +is not a quadratic residue then the only other value $a^{(p-1)/2}$ may be congruent to is $-1$ since +\begin{equation} +0 \equiv a^{p - 1} - 1 \equiv (a^{(p-1)/2} + 1)(a^{(p-1)/2} - 1) \mbox{ (mod }p\mbox{)} +\end{equation} +One of the terms on the right hand side must be zero. \textbf{QED} + +\subsection{Jacobi Symbol} +The Jacobi symbol is a generalization of the Legendre function for any odd non prime moduli $p$ greater than 2. If $p = \prod_{i=0}^n p_i$ then +the Jacobi symbol $\left ( { a \over p } \right )$ is equal to the following equation. + +\begin{equation} +\left ( { a \over p } \right ) = \left ( { a \over p_0} \right ) \left ( { a \over p_1} \right ) \ldots \left ( { a \over p_n} \right ) +\end{equation} + +By inspection if $p$ is prime the Jacobi symbol is equivalent to the Legendre function. The following facts\footnote{See HAC \cite[pp. 72-74]{HAC} for +further details.} will be used to derive an efficient Jacobi symbol algorithm. Where $p$ is an odd integer greater than two and $a, b \in \Z$ the +following are true. + +\begin{enumerate} +\item $\left ( { a \over p} \right )$ equals $-1$, $0$ or $1$. +\item $\left ( { ab \over p} \right ) = \left ( { a \over p} \right )\left ( { b \over p} \right )$. +\item If $a \equiv b$ then $\left ( { a \over p} \right ) = \left ( { b \over p} \right )$. +\item $\left ( { 2 \over p} \right )$ equals $1$ if $p \equiv 1$ or $7 \mbox{ (mod }8\mbox{)}$. Otherwise, it equals $-1$. +\item $\left ( { a \over p} \right ) \equiv \left ( { p \over a} \right ) \cdot (-1)^{(p-1)(a-1)/4}$. More specifically +$\left ( { a \over p} \right ) = \left ( { p \over a} \right )$ if $p \equiv a \equiv 1 \mbox{ (mod }4\mbox{)}$. +\end{enumerate} + +Using these facts if $a = 2^k \cdot a'$ then + +\begin{eqnarray} +\left ( { a \over p } \right ) = \left ( {{2^k} \over p } \right ) \left ( {a' \over p} \right ) \nonumber \\ + = \left ( {2 \over p } \right )^k \left ( {a' \over p} \right ) +\label{eqn:jacobi} +\end{eqnarray} + +By fact five, + +\begin{equation} +\left ( { a \over p } \right ) = \left ( { p \over a } \right ) \cdot (-1)^{(p-1)(a-1)/4} +\end{equation} + +Subsequently by fact three since $p \equiv (p \mbox{ mod }a) \mbox{ (mod }a\mbox{)}$ then + +\begin{equation} +\left ( { a \over p } \right ) = \left ( { {p \mbox{ mod } a} \over a } \right ) \cdot (-1)^{(p-1)(a-1)/4} +\end{equation} + +By putting both observations into equation \ref{eqn:jacobi} the following simplified equation is formed. + +\begin{equation} +\left ( { a \over p } \right ) = \left ( {2 \over p } \right )^k \left ( {{p\mbox{ mod }a'} \over a'} \right ) \cdot (-1)^{(p-1)(a'-1)/4} +\end{equation} + +The value of $\left ( {{p \mbox{ mod }a'} \over a'} \right )$ can be found by using the same equation recursively. The value of +$\left ( {2 \over p } \right )^k$ equals $1$ if $k$ is even otherwise it equals $\left ( {2 \over p } \right )$. Using this approach the +factors of $p$ do not have to be known. Furthermore, if $(a, p) = 1$ then the algorithm will terminate when the recursion requests the +Jacobi symbol computation of $\left ( {1 \over a'} \right )$ which is simply $1$. + +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_jacobi}. \\ +\textbf{Input}. mp\_int $a$ and $p$, $a \ge 0$, $p \ge 3$, $p \equiv 1 \mbox{ (mod }2\mbox{)}$ \\ +\textbf{Output}. The Jacobi symbol $c = \left ( {a \over p } \right )$. \\ +\hline \\ +1. If $a = 0$ then \\ +\hspace{3mm}1.1 $c \leftarrow 0$ \\ +\hspace{3mm}1.2 Return(\textit{MP\_OKAY}). \\ +2. If $a = 1$ then \\ +\hspace{3mm}2.1 $c \leftarrow 1$ \\ +\hspace{3mm}2.2 Return(\textit{MP\_OKAY}). \\ +3. $a' \leftarrow a$ \\ +4. $k \leftarrow 0$ \\ +5. While $a'.used > 0$ and $a'_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\ +\hspace{3mm}5.1 $k \leftarrow k + 1$ \\ +\hspace{3mm}5.2 $a' \leftarrow \lfloor a' / 2 \rfloor$ \\ +6. If $k \equiv 0 \mbox{ (mod }2\mbox{)}$ then \\ +\hspace{3mm}6.1 $s \leftarrow 1$ \\ +7. else \\ +\hspace{3mm}7.1 $r \leftarrow p_0 \mbox{ (mod }8\mbox{)}$ \\ +\hspace{3mm}7.2 If $r = 1$ or $r = 7$ then \\ +\hspace{6mm}7.2.1 $s \leftarrow 1$ \\ +\hspace{3mm}7.3 else \\ +\hspace{6mm}7.3.1 $s \leftarrow -1$ \\ +8. If $p_0 \equiv a'_0 \equiv 3 \mbox{ (mod }4\mbox{)}$ then \\ +\hspace{3mm}8.1 $s \leftarrow -s$ \\ +9. If $a' \ne 1$ then \\ +\hspace{3mm}9.1 $p' \leftarrow p \mbox{ (mod }a'\mbox{)}$ \\ +\hspace{3mm}9.2 $s \leftarrow s \cdot \mbox{mp\_jacobi}(p', a')$ \\ +10. $c \leftarrow s$ \\ +11. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_jacobi} +\end{figure} +\textbf{Algorithm mp\_jacobi.} +This algorithm computes the Jacobi symbol for an arbitrary positive integer $a$ with respect to an odd integer $p$ greater than three. The algorithm +is based on algorithm 2.149 of HAC \cite[pp. 73]{HAC}. + +Step numbers one and two handle the trivial cases of $a = 0$ and $a = 1$ respectively. Step five determines the number of two factors in the +input $a$. If $k$ is even than the term $\left ( { 2 \over p } \right )^k$ must always evaluate to one. If $k$ is odd than the term evaluates to one +if $p_0$ is congruent to one or seven modulo eight, otherwise it evaluates to $-1$. After the the $\left ( { 2 \over p } \right )^k$ term is handled +the $(-1)^{(p-1)(a'-1)/4}$ is computed and multiplied against the current product $s$. The latter term evaluates to one if both $p$ and $a'$ +are congruent to one modulo four, otherwise it evaluates to negative one. + +By step nine if $a'$ does not equal one a recursion is required. Step 9.1 computes $p' \equiv p \mbox{ (mod }a'\mbox{)}$ and will recurse to compute +$\left ( {p' \over a'} \right )$ which is multiplied against the current Jacobi product. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_jacobi.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* computes the jacobi c = (a | n) (or Legendre if n is prime) +018 * HAC pp. 73 Algorithm 2.149 +019 */ +020 int mp_jacobi (mp_int * a, mp_int * p, int *c) +021 \{ +022 mp_int a1, p1; +023 int k, s, r, res; +024 mp_digit residue; +025 +026 /* if p <= 0 return MP_VAL */ +027 if (mp_cmp_d(p, 0) != MP_GT) \{ +028 return MP_VAL; +029 \} +030 +031 /* step 1. if a == 0, return 0 */ +032 if (mp_iszero (a) == 1) \{ +033 *c = 0; +034 return MP_OKAY; +035 \} +036 +037 /* step 2. if a == 1, return 1 */ +038 if (mp_cmp_d (a, 1) == MP_EQ) \{ +039 *c = 1; +040 return MP_OKAY; +041 \} +042 +043 /* default */ +044 s = 0; +045 +046 /* step 3. write a = a1 * 2**k */ +047 if ((res = mp_init_copy (&a1, a)) != MP_OKAY) \{ +048 return res; +049 \} +050 +051 if ((res = mp_init (&p1)) != MP_OKAY) \{ +052 goto LBL_A1; +053 \} +054 +055 /* divide out larger power of two */ +056 k = mp_cnt_lsb(&a1); +057 if ((res = mp_div_2d(&a1, k, &a1, NULL)) != MP_OKAY) \{ +058 goto LBL_P1; +059 \} +060 +061 /* step 4. if e is even set s=1 */ +062 if ((k & 1) == 0) \{ +063 s = 1; +064 \} else \{ +065 /* else set s=1 if p = 1/7 (mod 8) or s=-1 if p = 3/5 (mod 8) */ +066 residue = p->dp[0] & 7; +067 +068 if (residue == 1 || residue == 7) \{ +069 s = 1; +070 \} else if (residue == 3 || residue == 5) \{ +071 s = -1; +072 \} +073 \} +074 +075 /* step 5. if p == 3 (mod 4) *and* a1 == 3 (mod 4) then s = -s */ +076 if ( ((p->dp[0] & 3) == 3) && ((a1.dp[0] & 3) == 3)) \{ +077 s = -s; +078 \} +079 +080 /* if a1 == 1 we're done */ +081 if (mp_cmp_d (&a1, 1) == MP_EQ) \{ +082 *c = s; +083 \} else \{ +084 /* n1 = n mod a1 */ +085 if ((res = mp_mod (p, &a1, &p1)) != MP_OKAY) \{ +086 goto LBL_P1; +087 \} +088 if ((res = mp_jacobi (&p1, &a1, &r)) != MP_OKAY) \{ +089 goto LBL_P1; +090 \} +091 *c = s * r; +092 \} +093 +094 /* done */ +095 res = MP_OKAY; +096 LBL_P1:mp_clear (&p1); +097 LBL_A1:mp_clear (&a1); +098 return res; +099 \} +100 #endif +101 +\end{alltt} +\end{small} + +As a matter of practicality the variable $a'$ as per the pseudo-code is reprensented by the variable $a1$ since the $'$ symbol is not valid for a C +variable name character. + +The two simple cases of $a = 0$ and $a = 1$ are handled at the very beginning to simplify the algorithm. If the input is non-trivial the algorithm +has to proceed compute the Jacobi. The variable $s$ is used to hold the current Jacobi product. Note that $s$ is merely a C ``int'' data type since +the values it may obtain are merely $-1$, $0$ and $1$. + +After a local copy of $a$ is made all of the factors of two are divided out and the total stored in $k$. Technically only the least significant +bit of $k$ is required, however, it makes the algorithm simpler to follow to perform an addition. In practice an exclusive-or and addition have the same +processor requirements and neither is faster than the other. + +Line 61 through 70 determines the value of $\left ( { 2 \over p } \right )^k$. If the least significant bit of $k$ is zero than +$k$ is even and the value is one. Otherwise, the value of $s$ depends on which residue class $p$ belongs to modulo eight. The value of +$(-1)^{(p-1)(a'-1)/4}$ is compute and multiplied against $s$ on lines 75 through 73. + +Finally, if $a1$ does not equal one the algorithm must recurse and compute $\left ( {p' \over a'} \right )$. + +\textit{-- Comment about default $s$ and such...} + +\section{Modular Inverse} +\label{sec:modinv} +The modular inverse of a number actually refers to the modular multiplicative inverse. Essentially for any integer $a$ such that $(a, p) = 1$ there +exist another integer $b$ such that $ab \equiv 1 \mbox{ (mod }p\mbox{)}$. The integer $b$ is called the multiplicative inverse of $a$ which is +denoted as $b = a^{-1}$. Technically speaking modular inversion is a well defined operation for any finite ring or field not just for rings and +fields of integers. However, the former will be the matter of discussion. + +The simplest approach is to compute the algebraic inverse of the input. That is to compute $b \equiv a^{\Phi(p) - 1}$. If $\Phi(p)$ is the +order of the multiplicative subgroup modulo $p$ then $b$ must be the multiplicative inverse of $a$. The proof of which is trivial. + +\begin{equation} +ab \equiv a \left (a^{\Phi(p) - 1} \right ) \equiv a^{\Phi(p)} \equiv a^0 \equiv 1 \mbox{ (mod }p\mbox{)} +\end{equation} + +However, as simple as this approach may be it has two serious flaws. It requires that the value of $\Phi(p)$ be known which if $p$ is composite +requires all of the prime factors. This approach also is very slow as the size of $p$ grows. + +A simpler approach is based on the observation that solving for the multiplicative inverse is equivalent to solving the linear +Diophantine\footnote{See LeVeque \cite[pp. 40-43]{LeVeque} for more information.} equation. + +\begin{equation} +ab + pq = 1 +\end{equation} + +Where $a$, $b$, $p$ and $q$ are all integers. If such a pair of integers $ \left < b, q \right >$ exist than $b$ is the multiplicative inverse of +$a$ modulo $p$. The extended Euclidean algorithm (Knuth \cite[pp. 342]{TAOCPV2}) can be used to solve such equations provided $(a, p) = 1$. +However, instead of using that algorithm directly a variant known as the binary Extended Euclidean algorithm will be used in its place. The +binary approach is very similar to the binary greatest common divisor algorithm except it will produce a full solution to the Diophantine +equation. + +\subsection{General Case} +\newpage\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_invmod}. \\ +\textbf{Input}. mp\_int $a$ and $b$, $(a, b) = 1$, $p \ge 2$, $0 < a < p$. \\ +\textbf{Output}. The modular inverse $c \equiv a^{-1} \mbox{ (mod }b\mbox{)}$. \\ +\hline \\ +1. If $b \le 0$ then return(\textit{MP\_VAL}). \\ +2. If $b_0 \equiv 1 \mbox{ (mod }2\mbox{)}$ then use algorithm fast\_mp\_invmod. \\ +3. $x \leftarrow \vert a \vert, y \leftarrow b$ \\ +4. If $x_0 \equiv y_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ then return(\textit{MP\_VAL}). \\ +5. $B \leftarrow 0, C \leftarrow 0, A \leftarrow 1, D \leftarrow 1$ \\ +6. While $u.used > 0$ and $u_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\ +\hspace{3mm}6.1 $u \leftarrow \lfloor u / 2 \rfloor$ \\ +\hspace{3mm}6.2 If ($A.used > 0$ and $A_0 \equiv 1 \mbox{ (mod }2\mbox{)}$) or ($B.used > 0$ and $B_0 \equiv 1 \mbox{ (mod }2\mbox{)}$) then \\ +\hspace{6mm}6.2.1 $A \leftarrow A + y$ \\ +\hspace{6mm}6.2.2 $B \leftarrow B - x$ \\ +\hspace{3mm}6.3 $A \leftarrow \lfloor A / 2 \rfloor$ \\ +\hspace{3mm}6.4 $B \leftarrow \lfloor B / 2 \rfloor$ \\ +7. While $v.used > 0$ and $v_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\ +\hspace{3mm}7.1 $v \leftarrow \lfloor v / 2 \rfloor$ \\ +\hspace{3mm}7.2 If ($C.used > 0$ and $C_0 \equiv 1 \mbox{ (mod }2\mbox{)}$) or ($D.used > 0$ and $D_0 \equiv 1 \mbox{ (mod }2\mbox{)}$) then \\ +\hspace{6mm}7.2.1 $C \leftarrow C + y$ \\ +\hspace{6mm}7.2.2 $D \leftarrow D - x$ \\ +\hspace{3mm}7.3 $C \leftarrow \lfloor C / 2 \rfloor$ \\ +\hspace{3mm}7.4 $D \leftarrow \lfloor D / 2 \rfloor$ \\ +8. If $u \ge v$ then \\ +\hspace{3mm}8.1 $u \leftarrow u - v$ \\ +\hspace{3mm}8.2 $A \leftarrow A - C$ \\ +\hspace{3mm}8.3 $B \leftarrow B - D$ \\ +9. else \\ +\hspace{3mm}9.1 $v \leftarrow v - u$ \\ +\hspace{3mm}9.2 $C \leftarrow C - A$ \\ +\hspace{3mm}9.3 $D \leftarrow D - B$ \\ +10. If $u \ne 0$ goto step 6. \\ +11. If $v \ne 1$ return(\textit{MP\_VAL}). \\ +12. While $C \le 0$ do \\ +\hspace{3mm}12.1 $C \leftarrow C + b$ \\ +13. While $C \ge b$ do \\ +\hspace{3mm}13.1 $C \leftarrow C - b$ \\ +14. $c \leftarrow C$ \\ +15. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\end{figure} +\textbf{Algorithm mp\_invmod.} +This algorithm computes the modular multiplicative inverse of an integer $a$ modulo an integer $b$. This algorithm is a variation of the +extended binary Euclidean algorithm from HAC \cite[pp. 608]{HAC}. It has been modified to only compute the modular inverse and not a complete +Diophantine solution. + +If $b \le 0$ than the modulus is invalid and MP\_VAL is returned. Similarly if both $a$ and $b$ are even then there cannot be a multiplicative +inverse for $a$ and the error is reported. + +The astute reader will observe that steps seven through nine are very similar to the binary greatest common divisor algorithm mp\_gcd. In this case +the other variables to the Diophantine equation are solved. The algorithm terminates when $u = 0$ in which case the solution is + +\begin{equation} +Ca + Db = v +\end{equation} + +If $v$, the greatest common divisor of $a$ and $b$ is not equal to one then the algorithm will report an error as no inverse exists. Otherwise, $C$ +is the modular inverse of $a$. The actual value of $C$ is congruent to, but not necessarily equal to, the ideal modular inverse which should lie +within $1 \le a^{-1} < b$. Step numbers twelve and thirteen adjust the inverse until it is in range. If the original input $a$ is within $0 < a < p$ +then only a couple of additions or subtractions will be required to adjust the inverse. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_invmod.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* hac 14.61, pp608 */ +018 int mp_invmod (mp_int * a, mp_int * b, mp_int * c) +019 \{ +020 /* b cannot be negative */ +021 if (b->sign == MP_NEG || mp_iszero(b) == 1) \{ +022 return MP_VAL; +023 \} +024 +025 #ifdef BN_FAST_MP_INVMOD_C +026 /* if the modulus is odd we can use a faster routine instead */ +027 if (mp_isodd (b) == 1) \{ +028 return fast_mp_invmod (a, b, c); +029 \} +030 #endif +031 +032 #ifdef BN_MP_INVMOD_SLOW_C +033 return mp_invmod_slow(a, b, c); +034 #endif +035 +036 return MP_VAL; +037 \} +038 #endif +039 +\end{alltt} +\end{small} + +\subsubsection{Odd Moduli} + +When the modulus $b$ is odd the variables $A$ and $C$ are fixed and are not required to compute the inverse. In particular by attempting to solve +the Diophantine $Cb + Da = 1$ only $B$ and $D$ are required to find the inverse of $a$. + +The algorithm fast\_mp\_invmod is a direct adaptation of algorithm mp\_invmod with all all steps involving either $A$ or $C$ removed. This +optimization will halve the time required to compute the modular inverse. + +\section{Primality Tests} + +A non-zero integer $a$ is said to be prime if it is not divisible by any other integer excluding one and itself. For example, $a = 7$ is prime +since the integers $2 \ldots 6$ do not evenly divide $a$. By contrast, $a = 6$ is not prime since $a = 6 = 2 \cdot 3$. + +Prime numbers arise in cryptography considerably as they allow finite fields to be formed. The ability to determine whether an integer is prime or +not quickly has been a viable subject in cryptography and number theory for considerable time. The algorithms that will be presented are all +probablistic algorithms in that when they report an integer is composite it must be composite. However, when the algorithms report an integer is +prime the algorithm may be incorrect. + +As will be discussed it is possible to limit the probability of error so well that for practical purposes the probablity of error might as +well be zero. For the purposes of these discussions let $n$ represent the candidate integer of which the primality is in question. + +\subsection{Trial Division} + +Trial division means to attempt to evenly divide a candidate integer by small prime integers. If the candidate can be evenly divided it obviously +cannot be prime. By dividing by all primes $1 < p \le \sqrt{n}$ this test can actually prove whether an integer is prime. However, such a test +would require a prohibitive amount of time as $n$ grows. + +Instead of dividing by every prime, a smaller, more mangeable set of primes may be used instead. By performing trial division with only a subset +of the primes less than $\sqrt{n} + 1$ the algorithm cannot prove if a candidate is prime. However, often it can prove a candidate is not prime. + +The benefit of this test is that trial division by small values is fairly efficient. Specially compared to the other algorithms that will be +discussed shortly. The probability that this approach correctly identifies a composite candidate when tested with all primes upto $q$ is given by +$1 - {1.12 \over ln(q)}$. The graph (\ref{pic:primality}, will be added later) demonstrates the probability of success for the range +$3 \le q \le 100$. + +At approximately $q = 30$ the gain of performing further tests diminishes fairly quickly. At $q = 90$ further testing is generally not going to +be of any practical use. In the case of LibTomMath the default limit $q = 256$ was chosen since it is not too high and will eliminate +approximately $80\%$ of all candidate integers. The constant \textbf{PRIME\_SIZE} is equal to the number of primes in the test base. The +array \_\_prime\_tab is an array of the first \textbf{PRIME\_SIZE} prime numbers. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_prime\_is\_divisible}. \\ +\textbf{Input}. mp\_int $a$ \\ +\textbf{Output}. $c = 1$ if $n$ is divisible by a small prime, otherwise $c = 0$. \\ +\hline \\ +1. for $ix$ from $0$ to $PRIME\_SIZE$ do \\ +\hspace{3mm}1.1 $d \leftarrow n \mbox{ (mod }\_\_prime\_tab_{ix}\mbox{)}$ \\ +\hspace{3mm}1.2 If $d = 0$ then \\ +\hspace{6mm}1.2.1 $c \leftarrow 1$ \\ +\hspace{6mm}1.2.2 Return(\textit{MP\_OKAY}). \\ +2. $c \leftarrow 0$ \\ +3. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_prime\_is\_divisible} +\end{figure} +\textbf{Algorithm mp\_prime\_is\_divisible.} +This algorithm attempts to determine if a candidate integer $n$ is composite by performing trial divisions. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_prime\_is\_divisible.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* determines if an integers is divisible by one +018 * of the first PRIME_SIZE primes or not +019 * +020 * sets result to 0 if not, 1 if yes +021 */ +022 int mp_prime_is_divisible (mp_int * a, int *result) +023 \{ +024 int err, ix; +025 mp_digit res; +026 +027 /* default to not */ +028 *result = MP_NO; +029 +030 for (ix = 0; ix < PRIME_SIZE; ix++) \{ +031 /* what is a mod LBL_prime_tab[ix] */ +032 if ((err = mp_mod_d (a, ltm_prime_tab[ix], &res)) != MP_OKAY) \{ +033 return err; +034 \} +035 +036 /* is the residue zero? */ +037 if (res == 0) \{ +038 *result = MP_YES; +039 return MP_OKAY; +040 \} +041 \} +042 +043 return MP_OKAY; +044 \} +045 #endif +046 +\end{alltt} +\end{small} + +The algorithm defaults to a return of $0$ in case an error occurs. The values in the prime table are all specified to be in the range of a +mp\_digit. The table \_\_prime\_tab is defined in the following file. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_prime\_tab.c +\vspace{-3mm} +\begin{alltt} +016 const mp_digit ltm_prime_tab[] = \{ +017 0x0002, 0x0003, 0x0005, 0x0007, 0x000B, 0x000D, 0x0011, 0x0013, +018 0x0017, 0x001D, 0x001F, 0x0025, 0x0029, 0x002B, 0x002F, 0x0035, +019 0x003B, 0x003D, 0x0043, 0x0047, 0x0049, 0x004F, 0x0053, 0x0059, +020 0x0061, 0x0065, 0x0067, 0x006B, 0x006D, 0x0071, 0x007F, +021 #ifndef MP_8BIT +022 0x0083, +023 0x0089, 0x008B, 0x0095, 0x0097, 0x009D, 0x00A3, 0x00A7, 0x00AD, +024 0x00B3, 0x00B5, 0x00BF, 0x00C1, 0x00C5, 0x00C7, 0x00D3, 0x00DF, +025 0x00E3, 0x00E5, 0x00E9, 0x00EF, 0x00F1, 0x00FB, 0x0101, 0x0107, +026 0x010D, 0x010F, 0x0115, 0x0119, 0x011B, 0x0125, 0x0133, 0x0137, +027 +028 0x0139, 0x013D, 0x014B, 0x0151, 0x015B, 0x015D, 0x0161, 0x0167, +029 0x016F, 0x0175, 0x017B, 0x017F, 0x0185, 0x018D, 0x0191, 0x0199, +030 0x01A3, 0x01A5, 0x01AF, 0x01B1, 0x01B7, 0x01BB, 0x01C1, 0x01C9, +031 0x01CD, 0x01CF, 0x01D3, 0x01DF, 0x01E7, 0x01EB, 0x01F3, 0x01F7, +032 0x01FD, 0x0209, 0x020B, 0x021D, 0x0223, 0x022D, 0x0233, 0x0239, +033 0x023B, 0x0241, 0x024B, 0x0251, 0x0257, 0x0259, 0x025F, 0x0265, +034 0x0269, 0x026B, 0x0277, 0x0281, 0x0283, 0x0287, 0x028D, 0x0293, +035 0x0295, 0x02A1, 0x02A5, 0x02AB, 0x02B3, 0x02BD, 0x02C5, 0x02CF, +036 +037 0x02D7, 0x02DD, 0x02E3, 0x02E7, 0x02EF, 0x02F5, 0x02F9, 0x0301, +038 0x0305, 0x0313, 0x031D, 0x0329, 0x032B, 0x0335, 0x0337, 0x033B, +039 0x033D, 0x0347, 0x0355, 0x0359, 0x035B, 0x035F, 0x036D, 0x0371, +040 0x0373, 0x0377, 0x038B, 0x038F, 0x0397, 0x03A1, 0x03A9, 0x03AD, +041 0x03B3, 0x03B9, 0x03C7, 0x03CB, 0x03D1, 0x03D7, 0x03DF, 0x03E5, +042 0x03F1, 0x03F5, 0x03FB, 0x03FD, 0x0407, 0x0409, 0x040F, 0x0419, +043 0x041B, 0x0425, 0x0427, 0x042D, 0x043F, 0x0443, 0x0445, 0x0449, +044 0x044F, 0x0455, 0x045D, 0x0463, 0x0469, 0x047F, 0x0481, 0x048B, +045 +046 0x0493, 0x049D, 0x04A3, 0x04A9, 0x04B1, 0x04BD, 0x04C1, 0x04C7, +047 0x04CD, 0x04CF, 0x04D5, 0x04E1, 0x04EB, 0x04FD, 0x04FF, 0x0503, +048 0x0509, 0x050B, 0x0511, 0x0515, 0x0517, 0x051B, 0x0527, 0x0529, +049 0x052F, 0x0551, 0x0557, 0x055D, 0x0565, 0x0577, 0x0581, 0x058F, +050 0x0593, 0x0595, 0x0599, 0x059F, 0x05A7, 0x05AB, 0x05AD, 0x05B3, +051 0x05BF, 0x05C9, 0x05CB, 0x05CF, 0x05D1, 0x05D5, 0x05DB, 0x05E7, +052 0x05F3, 0x05FB, 0x0607, 0x060D, 0x0611, 0x0617, 0x061F, 0x0623, +053 0x062B, 0x062F, 0x063D, 0x0641, 0x0647, 0x0649, 0x064D, 0x0653 +054 #endif +055 \}; +056 #endif +057 +\end{alltt} +\end{small} + +Note that there are two possible tables. When an mp\_digit is 7-bits long only the primes upto $127$ may be included, otherwise the primes +upto $1619$ are used. Note that the value of \textbf{PRIME\_SIZE} is a constant dependent on the size of a mp\_digit. + +\subsection{The Fermat Test} +The Fermat test is probably one the oldest tests to have a non-trivial probability of success. It is based on the fact that if $n$ is in +fact prime then $a^{n} \equiv a \mbox{ (mod }n\mbox{)}$ for all $0 < a < n$. The reason being that if $n$ is prime than the order of +the multiplicative sub group is $n - 1$. Any base $a$ must have an order which divides $n - 1$ and as such $a^n$ is equivalent to +$a^1 = a$. + +If $n$ is composite then any given base $a$ does not have to have a period which divides $n - 1$. In which case +it is possible that $a^n \nequiv a \mbox{ (mod }n\mbox{)}$. However, this test is not absolute as it is possible that the order +of a base will divide $n - 1$ which would then be reported as prime. Such a base yields what is known as a Fermat pseudo-prime. Several +integers known as Carmichael numbers will be a pseudo-prime to all valid bases. Fortunately such numbers are extremely rare as $n$ grows +in size. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_prime\_fermat}. \\ +\textbf{Input}. mp\_int $a$ and $b$, $a \ge 2$, $0 < b < a$. \\ +\textbf{Output}. $c = 1$ if $b^a \equiv b \mbox{ (mod }a\mbox{)}$, otherwise $c = 0$. \\ +\hline \\ +1. $t \leftarrow b^a \mbox{ (mod }a\mbox{)}$ \\ +2. If $t = b$ then \\ +\hspace{3mm}2.1 $c = 1$ \\ +3. else \\ +\hspace{3mm}3.1 $c = 0$ \\ +4. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_prime\_fermat} +\end{figure} +\textbf{Algorithm mp\_prime\_fermat.} +This algorithm determines whether an mp\_int $a$ is a Fermat prime to the base $b$ or not. It uses a single modular exponentiation to +determine the result. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_prime\_fermat.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* performs one Fermat test. +018 * +019 * If "a" were prime then b**a == b (mod a) since the order of +020 * the multiplicative sub-group would be phi(a) = a-1. That means +021 * it would be the same as b**(a mod (a-1)) == b**1 == b (mod a). +022 * +023 * Sets result to 1 if the congruence holds, or zero otherwise. +024 */ +025 int mp_prime_fermat (mp_int * a, mp_int * b, int *result) +026 \{ +027 mp_int t; +028 int err; +029 +030 /* default to composite */ +031 *result = MP_NO; +032 +033 /* ensure b > 1 */ +034 if (mp_cmp_d(b, 1) != MP_GT) \{ +035 return MP_VAL; +036 \} +037 +038 /* init t */ +039 if ((err = mp_init (&t)) != MP_OKAY) \{ +040 return err; +041 \} +042 +043 /* compute t = b**a mod a */ +044 if ((err = mp_exptmod (b, a, a, &t)) != MP_OKAY) \{ +045 goto LBL_T; +046 \} +047 +048 /* is it equal to b? */ +049 if (mp_cmp (&t, b) == MP_EQ) \{ +050 *result = MP_YES; +051 \} +052 +053 err = MP_OKAY; +054 LBL_T:mp_clear (&t); +055 return err; +056 \} +057 #endif +058 +\end{alltt} +\end{small} + +\subsection{The Miller-Rabin Test} +The Miller-Rabin (citation) test is another primality test which has tighter error bounds than the Fermat test specifically with sequentially chosen +candidate integers. The algorithm is based on the observation that if $n - 1 = 2^kr$ and if $b^r \nequiv \pm 1$ then after upto $k - 1$ squarings the +value must be equal to $-1$. The squarings are stopped as soon as $-1$ is observed. If the value of $1$ is observed first it means that +some value not congruent to $\pm 1$ when squared equals one which cannot occur if $n$ is prime. + +\begin{figure}[!here] +\begin{small} +\begin{center} +\begin{tabular}{l} +\hline Algorithm \textbf{mp\_prime\_miller\_rabin}. \\ +\textbf{Input}. mp\_int $a$ and $b$, $a \ge 2$, $0 < b < a$. \\ +\textbf{Output}. $c = 1$ if $a$ is a Miller-Rabin prime to the base $a$, otherwise $c = 0$. \\ +\hline +1. $a' \leftarrow a - 1$ \\ +2. $r \leftarrow n1$ \\ +3. $c \leftarrow 0, s \leftarrow 0$ \\ +4. While $r.used > 0$ and $r_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\ +\hspace{3mm}4.1 $s \leftarrow s + 1$ \\ +\hspace{3mm}4.2 $r \leftarrow \lfloor r / 2 \rfloor$ \\ +5. $y \leftarrow b^r \mbox{ (mod }a\mbox{)}$ \\ +6. If $y \nequiv \pm 1$ then \\ +\hspace{3mm}6.1 $j \leftarrow 1$ \\ +\hspace{3mm}6.2 While $j \le (s - 1)$ and $y \nequiv a'$ \\ +\hspace{6mm}6.2.1 $y \leftarrow y^2 \mbox{ (mod }a\mbox{)}$ \\ +\hspace{6mm}6.2.2 If $y = 1$ then goto step 8. \\ +\hspace{6mm}6.2.3 $j \leftarrow j + 1$ \\ +\hspace{3mm}6.3 If $y \nequiv a'$ goto step 8. \\ +7. $c \leftarrow 1$\\ +8. Return(\textit{MP\_OKAY}). \\ +\hline +\end{tabular} +\end{center} +\end{small} +\caption{Algorithm mp\_prime\_miller\_rabin} +\end{figure} +\textbf{Algorithm mp\_prime\_miller\_rabin.} +This algorithm performs one trial round of the Miller-Rabin algorithm to the base $b$. It will set $c = 1$ if the algorithm cannot determine +if $b$ is composite or $c = 0$ if $b$ is provably composite. The values of $s$ and $r$ are computed such that $a' = a - 1 = 2^sr$. + +If the value $y \equiv b^r$ is congruent to $\pm 1$ then the algorithm cannot prove if $a$ is composite or not. Otherwise, the algorithm will +square $y$ upto $s - 1$ times stopping only when $y \equiv -1$. If $y^2 \equiv 1$ and $y \nequiv \pm 1$ then the algorithm can report that $a$ +is provably composite. If the algorithm performs $s - 1$ squarings and $y \nequiv -1$ then $a$ is provably composite. If $a$ is not provably +composite then it is \textit{probably} prime. + +\vspace{+3mm}\begin{small} +\hspace{-5.1mm}{\bf File}: bn\_mp\_prime\_miller\_rabin.c +\vspace{-3mm} +\begin{alltt} +016 +017 /* Miller-Rabin test of "a" to the base of "b" as described in +018 * HAC pp. 139 Algorithm 4.24 +019 * +020 * Sets result to 0 if definitely composite or 1 if probably prime. +021 * Randomly the chance of error is no more than 1/4 and often +022 * very much lower. +023 */ +024 int mp_prime_miller_rabin (mp_int * a, mp_int * b, int *result) +025 \{ +026 mp_int n1, y, r; +027 int s, j, err; +028 +029 /* default */ +030 *result = MP_NO; +031 +032 /* ensure b > 1 */ +033 if (mp_cmp_d(b, 1) != MP_GT) \{ +034 return MP_VAL; +035 \} +036 +037 /* get n1 = a - 1 */ +038 if ((err = mp_init_copy (&n1, a)) != MP_OKAY) \{ +039 return err; +040 \} +041 if ((err = mp_sub_d (&n1, 1, &n1)) != MP_OKAY) \{ +042 goto LBL_N1; +043 \} +044 +045 /* set 2**s * r = n1 */ +046 if ((err = mp_init_copy (&r, &n1)) != MP_OKAY) \{ +047 goto LBL_N1; +048 \} +049 +050 /* count the number of least significant bits +051 * which are zero +052 */ +053 s = mp_cnt_lsb(&r); +054 +055 /* now divide n - 1 by 2**s */ +056 if ((err = mp_div_2d (&r, s, &r, NULL)) != MP_OKAY) \{ +057 goto LBL_R; +058 \} +059 +060 /* compute y = b**r mod a */ +061 if ((err = mp_init (&y)) != MP_OKAY) \{ +062 goto LBL_R; +063 \} +064 if ((err = mp_exptmod (b, &r, a, &y)) != MP_OKAY) \{ +065 goto LBL_Y; +066 \} +067 +068 /* if y != 1 and y != n1 do */ +069 if (mp_cmp_d (&y, 1) != MP_EQ && mp_cmp (&y, &n1) != MP_EQ) \{ +070 j = 1; +071 /* while j <= s-1 and y != n1 */ +072 while ((j <= (s - 1)) && mp_cmp (&y, &n1) != MP_EQ) \{ +073 if ((err = mp_sqrmod (&y, a, &y)) != MP_OKAY) \{ +074 goto LBL_Y; +075 \} +076 +077 /* if y == 1 then composite */ +078 if (mp_cmp_d (&y, 1) == MP_EQ) \{ +079 goto LBL_Y; +080 \} +081 +082 ++j; +083 \} +084 +085 /* if y != n1 then composite */ +086 if (mp_cmp (&y, &n1) != MP_EQ) \{ +087 goto LBL_Y; +088 \} +089 \} +090 +091 /* probably prime now */ +092 *result = MP_YES; +093 LBL_Y:mp_clear (&y); +094 LBL_R:mp_clear (&r); +095 LBL_N1:mp_clear (&n1); +096 return err; +097 \} +098 #endif +099 +\end{alltt} +\end{small} + + + + +\backmatter +\appendix +\begin{thebibliography}{ABCDEF} +\bibitem[1]{TAOCPV2} +Donald Knuth, \textit{The Art of Computer Programming}, Third Edition, Volume Two, Seminumerical Algorithms, Addison-Wesley, 1998 + +\bibitem[2]{HAC} +A. Menezes, P. van Oorschot, S. Vanstone, \textit{Handbook of Applied Cryptography}, CRC Press, 1996 + +\bibitem[3]{ROSE} +Michael Rosing, \textit{Implementing Elliptic Curve Cryptography}, Manning Publications, 1999 + +\bibitem[4]{COMBA} +Paul G. Comba, \textit{Exponentiation Cryptosystems on the IBM PC}. IBM Systems Journal 29(4): 526-538 (1990) + +\bibitem[5]{KARA} +A. Karatsuba, Doklay Akad. Nauk SSSR 145 (1962), pp.293-294 + +\bibitem[6]{KARAP} +Andre Weimerskirch and Christof Paar, \textit{Generalizations of the Karatsuba Algorithm for Polynomial Multiplication}, Submitted to Design, Codes and Cryptography, March 2002 + +\bibitem[7]{BARRETT} +Paul Barrett, \textit{Implementing the Rivest Shamir and Adleman Public Key Encryption Algorithm on a Standard Digital Signal Processor}, Advances in Cryptology, Crypto '86, Springer-Verlag. + +\bibitem[8]{MONT} +P.L.Montgomery. \textit{Modular multiplication without trial division}. Mathematics of Computation, 44(170):519-521, April 1985. + +\bibitem[9]{DRMET} +Chae Hoon Lim and Pil Joong Lee, \textit{Generating Efficient Primes for Discrete Log Cryptosystems}, POSTECH Information Research Laboratories + +\bibitem[10]{MMB} +J. Daemen and R. Govaerts and J. Vandewalle, \textit{Block ciphers based on Modular Arithmetic}, State and {P}rogress in the {R}esearch of {C}ryptography, 1993, pp. 80-89 + +\bibitem[11]{RSAREF} +R.L. Rivest, A. Shamir, L. Adleman, \textit{A Method for Obtaining Digital Signatures and Public-Key Cryptosystems} + +\bibitem[12]{DHREF} +Whitfield Diffie, Martin E. Hellman, \textit{New Directions in Cryptography}, IEEE Transactions on Information Theory, 1976 + +\bibitem[13]{IEEE} +IEEE Standard for Binary Floating-Point Arithmetic (ANSI/IEEE Std 754-1985) + +\bibitem[14]{GMP} +GNU Multiple Precision (GMP), \url{http://www.swox.com/gmp/} + +\bibitem[15]{MPI} +Multiple Precision Integer Library (MPI), Michael Fromberger, \url{http://thayer.dartmouth.edu/~sting/mpi/} + +\bibitem[16]{OPENSSL} +OpenSSL Cryptographic Toolkit, \url{http://openssl.org} + +\bibitem[17]{LIP} +Large Integer Package, \url{http://home.hetnet.nl/~ecstr/LIP.zip} + +\bibitem[18]{ISOC} +JTC1/SC22/WG14, ISO/IEC 9899:1999, ``A draft rationale for the C99 standard.'' + +\bibitem[19]{JAVA} +The Sun Java Website, \url{http://java.sun.com/} + +\end{thebibliography} + +\input{tommath.ind} + +\end{document} ADDED libtommath/tommath_class.h Index: libtommath/tommath_class.h ================================================================== --- /dev/null +++ libtommath/tommath_class.h @@ -0,0 +1,999 @@ +#if !(defined(LTM1) && defined(LTM2) && defined(LTM3)) +#if defined(LTM2) +#define LTM3 +#endif +#if defined(LTM1) +#define LTM2 +#endif +#define LTM1 + +#if defined(LTM_ALL) +#define BN_ERROR_C +#define BN_FAST_MP_INVMOD_C +#define BN_FAST_MP_MONTGOMERY_REDUCE_C +#define BN_FAST_S_MP_MUL_DIGS_C +#define BN_FAST_S_MP_MUL_HIGH_DIGS_C +#define BN_FAST_S_MP_SQR_C +#define BN_MP_2EXPT_C +#define BN_MP_ABS_C +#define BN_MP_ADD_C +#define BN_MP_ADD_D_C +#define BN_MP_ADDMOD_C +#define BN_MP_AND_C +#define BN_MP_CLAMP_C +#define BN_MP_CLEAR_C +#define BN_MP_CLEAR_MULTI_C +#define BN_MP_CMP_C +#define BN_MP_CMP_D_C +#define BN_MP_CMP_MAG_C +#define BN_MP_CNT_LSB_C +#define BN_MP_COPY_C +#define BN_MP_COUNT_BITS_C +#define BN_MP_DIV_C +#define BN_MP_DIV_2_C +#define BN_MP_DIV_2D_C +#define BN_MP_DIV_3_C +#define BN_MP_DIV_D_C +#define BN_MP_DR_IS_MODULUS_C +#define BN_MP_DR_REDUCE_C +#define BN_MP_DR_SETUP_C +#define BN_MP_EXCH_C +#define BN_MP_EXPT_D_C +#define BN_MP_EXPTMOD_C +#define BN_MP_EXPTMOD_FAST_C +#define BN_MP_EXTEUCLID_C +#define BN_MP_FREAD_C +#define BN_MP_FWRITE_C +#define BN_MP_GCD_C +#define BN_MP_GET_INT_C +#define BN_MP_GROW_C +#define BN_MP_INIT_C +#define BN_MP_INIT_COPY_C +#define BN_MP_INIT_MULTI_C +#define BN_MP_INIT_SET_C +#define BN_MP_INIT_SET_INT_C +#define BN_MP_INIT_SIZE_C +#define BN_MP_INVMOD_C +#define BN_MP_INVMOD_SLOW_C +#define BN_MP_IS_SQUARE_C +#define BN_MP_JACOBI_C +#define BN_MP_KARATSUBA_MUL_C +#define BN_MP_KARATSUBA_SQR_C +#define BN_MP_LCM_C +#define BN_MP_LSHD_C +#define BN_MP_MOD_C +#define BN_MP_MOD_2D_C +#define BN_MP_MOD_D_C +#define BN_MP_MONTGOMERY_CALC_NORMALIZATION_C +#define BN_MP_MONTGOMERY_REDUCE_C +#define BN_MP_MONTGOMERY_SETUP_C +#define BN_MP_MUL_C +#define BN_MP_MUL_2_C +#define BN_MP_MUL_2D_C +#define BN_MP_MUL_D_C +#define BN_MP_MULMOD_C +#define BN_MP_N_ROOT_C +#define BN_MP_NEG_C +#define BN_MP_OR_C +#define BN_MP_PRIME_FERMAT_C +#define BN_MP_PRIME_IS_DIVISIBLE_C +#define BN_MP_PRIME_IS_PRIME_C +#define BN_MP_PRIME_MILLER_RABIN_C +#define BN_MP_PRIME_NEXT_PRIME_C +#define BN_MP_PRIME_RABIN_MILLER_TRIALS_C +#define BN_MP_PRIME_RANDOM_EX_C +#define BN_MP_RADIX_SIZE_C +#define BN_MP_RADIX_SMAP_C +#define BN_MP_RAND_C +#define BN_MP_READ_RADIX_C +#define BN_MP_READ_SIGNED_BIN_C +#define BN_MP_READ_UNSIGNED_BIN_C +#define BN_MP_REDUCE_C +#define BN_MP_REDUCE_2K_C +#define BN_MP_REDUCE_2K_L_C +#define BN_MP_REDUCE_2K_SETUP_C +#define BN_MP_REDUCE_2K_SETUP_L_C +#define BN_MP_REDUCE_IS_2K_C +#define BN_MP_REDUCE_IS_2K_L_C +#define BN_MP_REDUCE_SETUP_C +#define BN_MP_RSHD_C +#define BN_MP_SET_C +#define BN_MP_SET_INT_C +#define BN_MP_SHRINK_C +#define BN_MP_SIGNED_BIN_SIZE_C +#define BN_MP_SQR_C +#define BN_MP_SQRMOD_C +#define BN_MP_SQRT_C +#define BN_MP_SUB_C +#define BN_MP_SUB_D_C +#define BN_MP_SUBMOD_C +#define BN_MP_TO_SIGNED_BIN_C +#define BN_MP_TO_SIGNED_BIN_N_C +#define BN_MP_TO_UNSIGNED_BIN_C +#define BN_MP_TO_UNSIGNED_BIN_N_C +#define BN_MP_TOOM_MUL_C +#define BN_MP_TOOM_SQR_C +#define BN_MP_TORADIX_C +#define BN_MP_TORADIX_N_C +#define BN_MP_UNSIGNED_BIN_SIZE_C +#define BN_MP_XOR_C +#define BN_MP_ZERO_C +#define BN_PRIME_TAB_C +#define BN_REVERSE_C +#define BN_S_MP_ADD_C +#define BN_S_MP_EXPTMOD_C +#define BN_S_MP_MUL_DIGS_C +#define BN_S_MP_MUL_HIGH_DIGS_C +#define BN_S_MP_SQR_C +#define BN_S_MP_SUB_C +#define BNCORE_C +#endif + +#if defined(BN_ERROR_C) + #define BN_MP_ERROR_TO_STRING_C +#endif + +#if defined(BN_FAST_MP_INVMOD_C) + #define BN_MP_ISEVEN_C + #define BN_MP_INIT_MULTI_C + #define BN_MP_COPY_C + #define BN_MP_MOD_C + #define BN_MP_SET_C + #define BN_MP_DIV_2_C + #define BN_MP_ISODD_C + #define BN_MP_SUB_C + #define BN_MP_CMP_C + #define BN_MP_ISZERO_C + #define BN_MP_CMP_D_C + #define BN_MP_ADD_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_MULTI_C +#endif + +#if defined(BN_FAST_MP_MONTGOMERY_REDUCE_C) + #define BN_MP_GROW_C + #define BN_MP_RSHD_C + #define BN_MP_CLAMP_C + #define BN_MP_CMP_MAG_C + #define BN_S_MP_SUB_C +#endif + +#if defined(BN_FAST_S_MP_MUL_DIGS_C) + #define BN_MP_GROW_C + #define BN_MP_CLAMP_C +#endif + +#if defined(BN_FAST_S_MP_MUL_HIGH_DIGS_C) + #define BN_MP_GROW_C + #define BN_MP_CLAMP_C +#endif + +#if defined(BN_FAST_S_MP_SQR_C) + #define BN_MP_GROW_C + #define BN_MP_CLAMP_C +#endif + +#if defined(BN_MP_2EXPT_C) + #define BN_MP_ZERO_C + #define BN_MP_GROW_C +#endif + +#if defined(BN_MP_ABS_C) + #define BN_MP_COPY_C +#endif + +#if defined(BN_MP_ADD_C) + #define BN_S_MP_ADD_C + #define BN_MP_CMP_MAG_C + #define BN_S_MP_SUB_C +#endif + +#if defined(BN_MP_ADD_D_C) + #define BN_MP_GROW_C + #define BN_MP_SUB_D_C + #define BN_MP_CLAMP_C +#endif + +#if defined(BN_MP_ADDMOD_C) + #define BN_MP_INIT_C + #define BN_MP_ADD_C + #define BN_MP_CLEAR_C + #define BN_MP_MOD_C +#endif + +#if defined(BN_MP_AND_C) + #define BN_MP_INIT_COPY_C + #define BN_MP_CLAMP_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_CLAMP_C) +#endif + +#if defined(BN_MP_CLEAR_C) +#endif + +#if defined(BN_MP_CLEAR_MULTI_C) + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_CMP_C) + #define BN_MP_CMP_MAG_C +#endif + +#if defined(BN_MP_CMP_D_C) +#endif + +#if defined(BN_MP_CMP_MAG_C) +#endif + +#if defined(BN_MP_CNT_LSB_C) + #define BN_MP_ISZERO_C +#endif + +#if defined(BN_MP_COPY_C) + #define BN_MP_GROW_C +#endif + +#if defined(BN_MP_COUNT_BITS_C) +#endif + +#if defined(BN_MP_DIV_C) + #define BN_MP_ISZERO_C + #define BN_MP_CMP_MAG_C + #define BN_MP_COPY_C + #define BN_MP_ZERO_C + #define BN_MP_INIT_MULTI_C + #define BN_MP_SET_C + #define BN_MP_COUNT_BITS_C + #define BN_MP_ABS_C + #define BN_MP_MUL_2D_C + #define BN_MP_CMP_C + #define BN_MP_SUB_C + #define BN_MP_ADD_C + #define BN_MP_DIV_2D_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_MULTI_C + #define BN_MP_INIT_SIZE_C + #define BN_MP_INIT_C + #define BN_MP_INIT_COPY_C + #define BN_MP_LSHD_C + #define BN_MP_RSHD_C + #define BN_MP_MUL_D_C + #define BN_MP_CLAMP_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_DIV_2_C) + #define BN_MP_GROW_C + #define BN_MP_CLAMP_C +#endif + +#if defined(BN_MP_DIV_2D_C) + #define BN_MP_COPY_C + #define BN_MP_ZERO_C + #define BN_MP_INIT_C + #define BN_MP_MOD_2D_C + #define BN_MP_CLEAR_C + #define BN_MP_RSHD_C + #define BN_MP_CLAMP_C + #define BN_MP_EXCH_C +#endif + +#if defined(BN_MP_DIV_3_C) + #define BN_MP_INIT_SIZE_C + #define BN_MP_CLAMP_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_DIV_D_C) + #define BN_MP_ISZERO_C + #define BN_MP_COPY_C + #define BN_MP_DIV_2D_C + #define BN_MP_DIV_3_C + #define BN_MP_INIT_SIZE_C + #define BN_MP_CLAMP_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_DR_IS_MODULUS_C) +#endif + +#if defined(BN_MP_DR_REDUCE_C) + #define BN_MP_GROW_C + #define BN_MP_CLAMP_C + #define BN_MP_CMP_MAG_C + #define BN_S_MP_SUB_C +#endif + +#if defined(BN_MP_DR_SETUP_C) +#endif + +#if defined(BN_MP_EXCH_C) +#endif + +#if defined(BN_MP_EXPT_D_C) + #define BN_MP_INIT_COPY_C + #define BN_MP_SET_C + #define BN_MP_SQR_C + #define BN_MP_CLEAR_C + #define BN_MP_MUL_C +#endif + +#if defined(BN_MP_EXPTMOD_C) + #define BN_MP_INIT_C + #define BN_MP_INVMOD_C + #define BN_MP_CLEAR_C + #define BN_MP_ABS_C + #define BN_MP_CLEAR_MULTI_C + #define BN_MP_REDUCE_IS_2K_L_C + #define BN_S_MP_EXPTMOD_C + #define BN_MP_DR_IS_MODULUS_C + #define BN_MP_REDUCE_IS_2K_C + #define BN_MP_ISODD_C + #define BN_MP_EXPTMOD_FAST_C +#endif + +#if defined(BN_MP_EXPTMOD_FAST_C) + #define BN_MP_COUNT_BITS_C + #define BN_MP_INIT_C + #define BN_MP_CLEAR_C + #define BN_MP_MONTGOMERY_SETUP_C + #define BN_FAST_MP_MONTGOMERY_REDUCE_C + #define BN_MP_MONTGOMERY_REDUCE_C + #define BN_MP_DR_SETUP_C + #define BN_MP_DR_REDUCE_C + #define BN_MP_REDUCE_2K_SETUP_C + #define BN_MP_REDUCE_2K_C + #define BN_MP_MONTGOMERY_CALC_NORMALIZATION_C + #define BN_MP_MULMOD_C + #define BN_MP_SET_C + #define BN_MP_MOD_C + #define BN_MP_COPY_C + #define BN_MP_SQR_C + #define BN_MP_MUL_C + #define BN_MP_EXCH_C +#endif + +#if defined(BN_MP_EXTEUCLID_C) + #define BN_MP_INIT_MULTI_C + #define BN_MP_SET_C + #define BN_MP_COPY_C + #define BN_MP_ISZERO_C + #define BN_MP_DIV_C + #define BN_MP_MUL_C + #define BN_MP_SUB_C + #define BN_MP_NEG_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_MULTI_C +#endif + +#if defined(BN_MP_FREAD_C) + #define BN_MP_ZERO_C + #define BN_MP_S_RMAP_C + #define BN_MP_MUL_D_C + #define BN_MP_ADD_D_C + #define BN_MP_CMP_D_C +#endif + +#if defined(BN_MP_FWRITE_C) + #define BN_MP_RADIX_SIZE_C + #define BN_MP_TORADIX_C +#endif + +#if defined(BN_MP_GCD_C) + #define BN_MP_ISZERO_C + #define BN_MP_ABS_C + #define BN_MP_ZERO_C + #define BN_MP_INIT_COPY_C + #define BN_MP_CNT_LSB_C + #define BN_MP_DIV_2D_C + #define BN_MP_CMP_MAG_C + #define BN_MP_EXCH_C + #define BN_S_MP_SUB_C + #define BN_MP_MUL_2D_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_GET_INT_C) +#endif + +#if defined(BN_MP_GROW_C) +#endif + +#if defined(BN_MP_INIT_C) +#endif + +#if defined(BN_MP_INIT_COPY_C) + #define BN_MP_COPY_C +#endif + +#if defined(BN_MP_INIT_MULTI_C) + #define BN_MP_ERR_C + #define BN_MP_INIT_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_INIT_SET_C) + #define BN_MP_INIT_C + #define BN_MP_SET_C +#endif + +#if defined(BN_MP_INIT_SET_INT_C) + #define BN_MP_INIT_C + #define BN_MP_SET_INT_C +#endif + +#if defined(BN_MP_INIT_SIZE_C) + #define BN_MP_INIT_C +#endif + +#if defined(BN_MP_INVMOD_C) + #define BN_MP_ISZERO_C + #define BN_MP_ISODD_C + #define BN_FAST_MP_INVMOD_C + #define BN_MP_INVMOD_SLOW_C +#endif + +#if defined(BN_MP_INVMOD_SLOW_C) + #define BN_MP_ISZERO_C + #define BN_MP_INIT_MULTI_C + #define BN_MP_MOD_C + #define BN_MP_COPY_C + #define BN_MP_ISEVEN_C + #define BN_MP_SET_C + #define BN_MP_DIV_2_C + #define BN_MP_ISODD_C + #define BN_MP_ADD_C + #define BN_MP_SUB_C + #define BN_MP_CMP_C + #define BN_MP_CMP_D_C + #define BN_MP_CMP_MAG_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_MULTI_C +#endif + +#if defined(BN_MP_IS_SQUARE_C) + #define BN_MP_MOD_D_C + #define BN_MP_INIT_SET_INT_C + #define BN_MP_MOD_C + #define BN_MP_GET_INT_C + #define BN_MP_SQRT_C + #define BN_MP_SQR_C + #define BN_MP_CMP_MAG_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_JACOBI_C) + #define BN_MP_CMP_D_C + #define BN_MP_ISZERO_C + #define BN_MP_INIT_COPY_C + #define BN_MP_CNT_LSB_C + #define BN_MP_DIV_2D_C + #define BN_MP_MOD_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_KARATSUBA_MUL_C) + #define BN_MP_MUL_C + #define BN_MP_INIT_SIZE_C + #define BN_MP_CLAMP_C + #define BN_MP_SUB_C + #define BN_MP_ADD_C + #define BN_MP_LSHD_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_KARATSUBA_SQR_C) + #define BN_MP_INIT_SIZE_C + #define BN_MP_CLAMP_C + #define BN_MP_SQR_C + #define BN_MP_SUB_C + #define BN_S_MP_ADD_C + #define BN_MP_LSHD_C + #define BN_MP_ADD_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_LCM_C) + #define BN_MP_INIT_MULTI_C + #define BN_MP_GCD_C + #define BN_MP_CMP_MAG_C + #define BN_MP_DIV_C + #define BN_MP_MUL_C + #define BN_MP_CLEAR_MULTI_C +#endif + +#if defined(BN_MP_LSHD_C) + #define BN_MP_GROW_C + #define BN_MP_RSHD_C +#endif + +#if defined(BN_MP_MOD_C) + #define BN_MP_INIT_C + #define BN_MP_DIV_C + #define BN_MP_CLEAR_C + #define BN_MP_ADD_C + #define BN_MP_EXCH_C +#endif + +#if defined(BN_MP_MOD_2D_C) + #define BN_MP_ZERO_C + #define BN_MP_COPY_C + #define BN_MP_CLAMP_C +#endif + +#if defined(BN_MP_MOD_D_C) + #define BN_MP_DIV_D_C +#endif + +#if defined(BN_MP_MONTGOMERY_CALC_NORMALIZATION_C) + #define BN_MP_COUNT_BITS_C + #define BN_MP_2EXPT_C + #define BN_MP_SET_C + #define BN_MP_MUL_2_C + #define BN_MP_CMP_MAG_C + #define BN_S_MP_SUB_C +#endif + +#if defined(BN_MP_MONTGOMERY_REDUCE_C) + #define BN_FAST_MP_MONTGOMERY_REDUCE_C + #define BN_MP_GROW_C + #define BN_MP_CLAMP_C + #define BN_MP_RSHD_C + #define BN_MP_CMP_MAG_C + #define BN_S_MP_SUB_C +#endif + +#if defined(BN_MP_MONTGOMERY_SETUP_C) +#endif + +#if defined(BN_MP_MUL_C) + #define BN_MP_TOOM_MUL_C + #define BN_MP_KARATSUBA_MUL_C + #define BN_FAST_S_MP_MUL_DIGS_C + #define BN_S_MP_MUL_C + #define BN_S_MP_MUL_DIGS_C +#endif + +#if defined(BN_MP_MUL_2_C) + #define BN_MP_GROW_C +#endif + +#if defined(BN_MP_MUL_2D_C) + #define BN_MP_COPY_C + #define BN_MP_GROW_C + #define BN_MP_LSHD_C + #define BN_MP_CLAMP_C +#endif + +#if defined(BN_MP_MUL_D_C) + #define BN_MP_GROW_C + #define BN_MP_CLAMP_C +#endif + +#if defined(BN_MP_MULMOD_C) + #define BN_MP_INIT_C + #define BN_MP_MUL_C + #define BN_MP_CLEAR_C + #define BN_MP_MOD_C +#endif + +#if defined(BN_MP_N_ROOT_C) + #define BN_MP_INIT_C + #define BN_MP_SET_C + #define BN_MP_COPY_C + #define BN_MP_EXPT_D_C + #define BN_MP_MUL_C + #define BN_MP_SUB_C + #define BN_MP_MUL_D_C + #define BN_MP_DIV_C + #define BN_MP_CMP_C + #define BN_MP_SUB_D_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_NEG_C) + #define BN_MP_COPY_C + #define BN_MP_ISZERO_C +#endif + +#if defined(BN_MP_OR_C) + #define BN_MP_INIT_COPY_C + #define BN_MP_CLAMP_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_PRIME_FERMAT_C) + #define BN_MP_CMP_D_C + #define BN_MP_INIT_C + #define BN_MP_EXPTMOD_C + #define BN_MP_CMP_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_PRIME_IS_DIVISIBLE_C) + #define BN_MP_MOD_D_C +#endif + +#if defined(BN_MP_PRIME_IS_PRIME_C) + #define BN_MP_CMP_D_C + #define BN_MP_PRIME_IS_DIVISIBLE_C + #define BN_MP_INIT_C + #define BN_MP_SET_C + #define BN_MP_PRIME_MILLER_RABIN_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_PRIME_MILLER_RABIN_C) + #define BN_MP_CMP_D_C + #define BN_MP_INIT_COPY_C + #define BN_MP_SUB_D_C + #define BN_MP_CNT_LSB_C + #define BN_MP_DIV_2D_C + #define BN_MP_EXPTMOD_C + #define BN_MP_CMP_C + #define BN_MP_SQRMOD_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_PRIME_NEXT_PRIME_C) + #define BN_MP_CMP_D_C + #define BN_MP_SET_C + #define BN_MP_SUB_D_C + #define BN_MP_ISEVEN_C + #define BN_MP_MOD_D_C + #define BN_MP_INIT_C + #define BN_MP_ADD_D_C + #define BN_MP_PRIME_MILLER_RABIN_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_PRIME_RABIN_MILLER_TRIALS_C) +#endif + +#if defined(BN_MP_PRIME_RANDOM_EX_C) + #define BN_MP_READ_UNSIGNED_BIN_C + #define BN_MP_PRIME_IS_PRIME_C + #define BN_MP_SUB_D_C + #define BN_MP_DIV_2_C + #define BN_MP_MUL_2_C + #define BN_MP_ADD_D_C +#endif + +#if defined(BN_MP_RADIX_SIZE_C) + #define BN_MP_COUNT_BITS_C + #define BN_MP_INIT_COPY_C + #define BN_MP_ISZERO_C + #define BN_MP_DIV_D_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_RADIX_SMAP_C) + #define BN_MP_S_RMAP_C +#endif + +#if defined(BN_MP_RAND_C) + #define BN_MP_ZERO_C + #define BN_MP_ADD_D_C + #define BN_MP_LSHD_C +#endif + +#if defined(BN_MP_READ_RADIX_C) + #define BN_MP_ZERO_C + #define BN_MP_S_RMAP_C + #define BN_MP_RADIX_SMAP_C + #define BN_MP_MUL_D_C + #define BN_MP_ADD_D_C + #define BN_MP_ISZERO_C +#endif + +#if defined(BN_MP_READ_SIGNED_BIN_C) + #define BN_MP_READ_UNSIGNED_BIN_C +#endif + +#if defined(BN_MP_READ_UNSIGNED_BIN_C) + #define BN_MP_GROW_C + #define BN_MP_ZERO_C + #define BN_MP_MUL_2D_C + #define BN_MP_CLAMP_C +#endif + +#if defined(BN_MP_REDUCE_C) + #define BN_MP_REDUCE_SETUP_C + #define BN_MP_INIT_COPY_C + #define BN_MP_RSHD_C + #define BN_MP_MUL_C + #define BN_S_MP_MUL_HIGH_DIGS_C + #define BN_FAST_S_MP_MUL_HIGH_DIGS_C + #define BN_MP_MOD_2D_C + #define BN_S_MP_MUL_DIGS_C + #define BN_MP_SUB_C + #define BN_MP_CMP_D_C + #define BN_MP_SET_C + #define BN_MP_LSHD_C + #define BN_MP_ADD_C + #define BN_MP_CMP_C + #define BN_S_MP_SUB_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_REDUCE_2K_C) + #define BN_MP_INIT_C + #define BN_MP_COUNT_BITS_C + #define BN_MP_DIV_2D_C + #define BN_MP_MUL_D_C + #define BN_S_MP_ADD_C + #define BN_MP_CMP_MAG_C + #define BN_S_MP_SUB_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_REDUCE_2K_L_C) + #define BN_MP_INIT_C + #define BN_MP_COUNT_BITS_C + #define BN_MP_DIV_2D_C + #define BN_MP_MUL_C + #define BN_S_MP_ADD_C + #define BN_MP_CMP_MAG_C + #define BN_S_MP_SUB_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_REDUCE_2K_SETUP_C) + #define BN_MP_INIT_C + #define BN_MP_COUNT_BITS_C + #define BN_MP_2EXPT_C + #define BN_MP_CLEAR_C + #define BN_S_MP_SUB_C +#endif + +#if defined(BN_MP_REDUCE_2K_SETUP_L_C) + #define BN_MP_INIT_C + #define BN_MP_2EXPT_C + #define BN_MP_COUNT_BITS_C + #define BN_S_MP_SUB_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_REDUCE_IS_2K_C) + #define BN_MP_REDUCE_2K_C + #define BN_MP_COUNT_BITS_C +#endif + +#if defined(BN_MP_REDUCE_IS_2K_L_C) +#endif + +#if defined(BN_MP_REDUCE_SETUP_C) + #define BN_MP_2EXPT_C + #define BN_MP_DIV_C +#endif + +#if defined(BN_MP_RSHD_C) + #define BN_MP_ZERO_C +#endif + +#if defined(BN_MP_SET_C) + #define BN_MP_ZERO_C +#endif + +#if defined(BN_MP_SET_INT_C) + #define BN_MP_ZERO_C + #define BN_MP_MUL_2D_C + #define BN_MP_CLAMP_C +#endif + +#if defined(BN_MP_SHRINK_C) +#endif + +#if defined(BN_MP_SIGNED_BIN_SIZE_C) + #define BN_MP_UNSIGNED_BIN_SIZE_C +#endif + +#if defined(BN_MP_SQR_C) + #define BN_MP_TOOM_SQR_C + #define BN_MP_KARATSUBA_SQR_C + #define BN_FAST_S_MP_SQR_C + #define BN_S_MP_SQR_C +#endif + +#if defined(BN_MP_SQRMOD_C) + #define BN_MP_INIT_C + #define BN_MP_SQR_C + #define BN_MP_CLEAR_C + #define BN_MP_MOD_C +#endif + +#if defined(BN_MP_SQRT_C) + #define BN_MP_N_ROOT_C + #define BN_MP_ISZERO_C + #define BN_MP_ZERO_C + #define BN_MP_INIT_COPY_C + #define BN_MP_RSHD_C + #define BN_MP_DIV_C + #define BN_MP_ADD_C + #define BN_MP_DIV_2_C + #define BN_MP_CMP_MAG_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_SUB_C) + #define BN_S_MP_ADD_C + #define BN_MP_CMP_MAG_C + #define BN_S_MP_SUB_C +#endif + +#if defined(BN_MP_SUB_D_C) + #define BN_MP_GROW_C + #define BN_MP_ADD_D_C + #define BN_MP_CLAMP_C +#endif + +#if defined(BN_MP_SUBMOD_C) + #define BN_MP_INIT_C + #define BN_MP_SUB_C + #define BN_MP_CLEAR_C + #define BN_MP_MOD_C +#endif + +#if defined(BN_MP_TO_SIGNED_BIN_C) + #define BN_MP_TO_UNSIGNED_BIN_C +#endif + +#if defined(BN_MP_TO_SIGNED_BIN_N_C) + #define BN_MP_SIGNED_BIN_SIZE_C + #define BN_MP_TO_SIGNED_BIN_C +#endif + +#if defined(BN_MP_TO_UNSIGNED_BIN_C) + #define BN_MP_INIT_COPY_C + #define BN_MP_ISZERO_C + #define BN_MP_DIV_2D_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_TO_UNSIGNED_BIN_N_C) + #define BN_MP_UNSIGNED_BIN_SIZE_C + #define BN_MP_TO_UNSIGNED_BIN_C +#endif + +#if defined(BN_MP_TOOM_MUL_C) + #define BN_MP_INIT_MULTI_C + #define BN_MP_MOD_2D_C + #define BN_MP_COPY_C + #define BN_MP_RSHD_C + #define BN_MP_MUL_C + #define BN_MP_MUL_2_C + #define BN_MP_ADD_C + #define BN_MP_SUB_C + #define BN_MP_DIV_2_C + #define BN_MP_MUL_2D_C + #define BN_MP_MUL_D_C + #define BN_MP_DIV_3_C + #define BN_MP_LSHD_C + #define BN_MP_CLEAR_MULTI_C +#endif + +#if defined(BN_MP_TOOM_SQR_C) + #define BN_MP_INIT_MULTI_C + #define BN_MP_MOD_2D_C + #define BN_MP_COPY_C + #define BN_MP_RSHD_C + #define BN_MP_SQR_C + #define BN_MP_MUL_2_C + #define BN_MP_ADD_C + #define BN_MP_SUB_C + #define BN_MP_DIV_2_C + #define BN_MP_MUL_2D_C + #define BN_MP_MUL_D_C + #define BN_MP_DIV_3_C + #define BN_MP_LSHD_C + #define BN_MP_CLEAR_MULTI_C +#endif + +#if defined(BN_MP_TORADIX_C) + #define BN_MP_ISZERO_C + #define BN_MP_INIT_COPY_C + #define BN_MP_DIV_D_C + #define BN_MP_CLEAR_C + #define BN_MP_S_RMAP_C +#endif + +#if defined(BN_MP_TORADIX_N_C) + #define BN_MP_ISZERO_C + #define BN_MP_INIT_COPY_C + #define BN_MP_DIV_D_C + #define BN_MP_CLEAR_C + #define BN_MP_S_RMAP_C +#endif + +#if defined(BN_MP_UNSIGNED_BIN_SIZE_C) + #define BN_MP_COUNT_BITS_C +#endif + +#if defined(BN_MP_XOR_C) + #define BN_MP_INIT_COPY_C + #define BN_MP_CLAMP_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_ZERO_C) +#endif + +#if defined(BN_PRIME_TAB_C) +#endif + +#if defined(BN_REVERSE_C) +#endif + +#if defined(BN_S_MP_ADD_C) + #define BN_MP_GROW_C + #define BN_MP_CLAMP_C +#endif + +#if defined(BN_S_MP_EXPTMOD_C) + #define BN_MP_COUNT_BITS_C + #define BN_MP_INIT_C + #define BN_MP_CLEAR_C + #define BN_MP_REDUCE_SETUP_C + #define BN_MP_REDUCE_C + #define BN_MP_REDUCE_2K_SETUP_L_C + #define BN_MP_REDUCE_2K_L_C + #define BN_MP_MOD_C + #define BN_MP_COPY_C + #define BN_MP_SQR_C + #define BN_MP_MUL_C + #define BN_MP_SET_C + #define BN_MP_EXCH_C +#endif + +#if defined(BN_S_MP_MUL_DIGS_C) + #define BN_FAST_S_MP_MUL_DIGS_C + #define BN_MP_INIT_SIZE_C + #define BN_MP_CLAMP_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_S_MP_MUL_HIGH_DIGS_C) + #define BN_FAST_S_MP_MUL_HIGH_DIGS_C + #define BN_MP_INIT_SIZE_C + #define BN_MP_CLAMP_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_S_MP_SQR_C) + #define BN_MP_INIT_SIZE_C + #define BN_MP_CLAMP_C + #define BN_MP_EXCH_C + #define BN_MP_CLEAR_C +#endif + +#if defined(BN_S_MP_SUB_C) + #define BN_MP_GROW_C + #define BN_MP_CLAMP_C +#endif + +#if defined(BNCORE_C) +#endif + +#ifdef LTM3 +#define LTM_LAST +#endif +#include +#include +#else +#define LTM_LAST +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/tommath_class.h,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ ADDED libtommath/tommath_superclass.h Index: libtommath/tommath_superclass.h ================================================================== --- /dev/null +++ libtommath/tommath_superclass.h @@ -0,0 +1,76 @@ +/* super class file for PK algos */ + +/* default ... include all MPI */ +#define LTM_ALL + +/* RSA only (does not support DH/DSA/ECC) */ +/* #define SC_RSA_1 */ + +/* For reference.... On an Athlon64 optimizing for speed... + + LTM's mpi.o with all functions [striped] is 142KiB in size. + +*/ + +/* Works for RSA only, mpi.o is 68KiB */ +#ifdef SC_RSA_1 + #define BN_MP_SHRINK_C + #define BN_MP_LCM_C + #define BN_MP_PRIME_RANDOM_EX_C + #define BN_MP_INVMOD_C + #define BN_MP_GCD_C + #define BN_MP_MOD_C + #define BN_MP_MULMOD_C + #define BN_MP_ADDMOD_C + #define BN_MP_EXPTMOD_C + #define BN_MP_SET_INT_C + #define BN_MP_INIT_MULTI_C + #define BN_MP_CLEAR_MULTI_C + #define BN_MP_UNSIGNED_BIN_SIZE_C + #define BN_MP_TO_UNSIGNED_BIN_C + #define BN_MP_MOD_D_C + #define BN_MP_PRIME_RABIN_MILLER_TRIALS_C + #define BN_REVERSE_C + #define BN_PRIME_TAB_C + + /* other modifiers */ + #define BN_MP_DIV_SMALL /* Slower division, not critical */ + + /* here we are on the last pass so we turn things off. The functions classes are still there + * but we remove them specifically from the build. This also invokes tweaks in functions + * like removing support for even moduli, etc... + */ +#ifdef LTM_LAST + #undef BN_MP_TOOM_MUL_C + #undef BN_MP_TOOM_SQR_C + #undef BN_MP_KARATSUBA_MUL_C + #undef BN_MP_KARATSUBA_SQR_C + #undef BN_MP_REDUCE_C + #undef BN_MP_REDUCE_SETUP_C + #undef BN_MP_DR_IS_MODULUS_C + #undef BN_MP_DR_SETUP_C + #undef BN_MP_DR_REDUCE_C + #undef BN_MP_REDUCE_IS_2K_C + #undef BN_MP_REDUCE_2K_SETUP_C + #undef BN_MP_REDUCE_2K_C + #undef BN_S_MP_EXPTMOD_C + #undef BN_MP_DIV_3_C + #undef BN_S_MP_MUL_HIGH_DIGS_C + #undef BN_FAST_S_MP_MUL_HIGH_DIGS_C + #undef BN_FAST_MP_INVMOD_C + + /* To safely undefine these you have to make sure your RSA key won't exceed the Comba threshold + * which is roughly 255 digits [7140 bits for 32-bit machines, 15300 bits for 64-bit machines] + * which means roughly speaking you can handle upto 2536-bit RSA keys with these defined without + * trouble. + */ + #undef BN_S_MP_MUL_DIGS_C + #undef BN_S_MP_SQR_C + #undef BN_MP_MONTGOMERY_REDUCE_C +#endif + +#endif + +/* $Source: /root/tcl/repos-to-convert/tcl/libtommath/tommath_superclass.h,v $ */ +/* $Revision: 1.1.1.1.2.2 $ */ +/* $Date: 2005/09/26 20:16:54 $ */ Index: macosx/Makefile ================================================================== --- macosx/Makefile +++ macosx/Makefile @@ -1,11 +1,12 @@ ######################################################################################################## # -# Makefile to build Tcl on Mac OS X packaged as a Framework -# uses standard unix build system in tcl/unix +# Makefile wrapper to build tcl on Mac OS X in a way compatible with the tk/macosx Xcode buildsystem +# uses the standard unix build system in tcl/unix (which can be used directly instead of this +# if you are not using the tk/macosx projects). # -# RCS: @(#) $Id: Makefile,v 1.18 2004/11/19 06:28:29 das Exp $ +# RCS: @(#) $Id: Makefile,v 1.18.2.2 2005/07/12 20:37:06 kennykb Exp $ # ######################################################################################################## #------------------------------------------------------------------------------------------------------- # customizable settings @@ -19,22 +20,18 @@ EXTRA_CONFIGURE_ARGS ?= EXTRA_MAKE_ARGS ?= INSTALL_PATH ?= /Library/Frameworks -PREFIX ?= /usr +PREFIX ?= /usr/local BINDIR ?= ${PREFIX}/bin +LIBDIR ?= ${INSTALL_PATH} MANDIR ?= ${PREFIX}/man # set to non-empty value to install manpages in addition to html help: INSTALL_MANPAGES ?= -TCL_PACKAGE_PATH ?= "~/Library/Tcl /Library/Tcl /Network/Library/Tcl /System/Library/Tcl \ - ~/Library/Frameworks /Library/Frameworks /Network/Library/Frameworks \ - /System/Library/Frameworks" -TCL_MODULE_PATH ?= "~/Library/Tcl /Library/Tcl /Network/Library/Tcl /System/Library/Tcl" - #------------------------------------------------------------------------------------------------------- # meta targets meta := all install embedded install-embedded clean distclean test @@ -47,11 +44,11 @@ install : ${install} install-%: action := install- embedded := ${styles:%=embedded-%} embedded : embedded-deploy -install-embedded := $(embedded:%=install-%) +install-embedded := ${embedded:%=install-%} install-embedded : install-embedded-deploy clean := ${styles:%=clean-%} clean : ${clean} clean-%: action := clean- @@ -66,19 +63,21 @@ targets := $(foreach v,${meta},${$v}) #------------------------------------------------------------------------------------------------------- # build styles +BUILD_STYLE = +CONFIGURE_ARGS = +OBJ_DIR = ${OBJROOT}/${BUILD_STYLE} + develop_make_args := BUILD_STYLE=Development CONFIGURE_ARGS=--enable-symbols -deploy_make_args := BUILD_STYLE=Deployment \ - MAKE_ARGS=INSTALL_PROGRAM="'$$\$${INSTALL} $$\$${INSTALL_STRIP_PROGRAM}'" \ - MAKE_ARGS+=INSTALL_LIBRARY="'$$\$${INSTALL} $$\$${INSTALL_STRIP_LIBRARY}'" \ - MAKE_ARGS+=MEM_DEBUG_FLAGS="-DNDEBUG" +deploy_make_args := BUILD_STYLE=Deployment INSTALL_TARGET=install-strip \ + GENERIC_FLAGS=-DNDEBUG embedded_make_args := EMBEDDED_BUILD=1 install_make_args := INSTALL_BUILD=1 -$(targets): +${targets}: ${MAKE} ${action}${PROJECT} \ $(foreach s,${styles} embedded install,$(if $(findstring $s,$@),${${s}_make_args})) #------------------------------------------------------------------------------------------------------- # project specific settings @@ -85,156 +84,113 @@ PROJECT := tcl PRODUCT_NAME := Tcl UNIX_DIR := ${CURDIR}/../unix -GENERIC_DIR := ${CURDIR}/../generic - -PRODUCT_VERSION := $(shell eval $$(grep '^TCL_VERSION=' ${UNIX_DIR}/configure.in); \ - echo "$${TCL_VERSION}") -PRODUCT_LONGVERSION := $(shell eval $$(grep '^TCL_PATCH_LEVEL=' ${UNIX_DIR}/configure.in); \ - echo "${PRODUCT_VERSION}$${TCL_PATCH_LEVEL}") -YEAR := $(shell date +%Y) - -TARGETS := tclsh tcltest -TCLSH := tclsh${PRODUCT_VERSION} -TCL_EXE ?= ${SYMROOT}/${TCLSH} - -DYLIB_INSTALL_PATH ?= ${INSTALL_PATH} - -LIBDIR := ${INSTALL_PATH}/${PRODUCT_NAME}.framework/Versions/${PRODUCT_VERSION} -DYLIB_INSTALL_DIR := ${DYLIB_INSTALL_PATH}/${PRODUCT_NAME}.framework/Versions/${PRODUCT_VERSION} -INCLUDEDIR := ${LIBDIR}/Headers -PRIVATEINCLUDEDIR := ${LIBDIR}/PrivateHeaders -SCRIPTDIR := ${LIBDIR}/Resources/Scripts -DOCDIR := ${LIBDIR}/Resources/Documentation/Reference -INFOPLIST := ${LIBDIR}/Resources/Info.plist - -BUILD_STYLE = -OBJ_DIR = ${OBJROOT}/${BUILD_STYLE} - -${PROJECT}: override INSTALL_ROOT = ${OBJ_DIR}/ - -MAKE_VARS := INSTALL_ROOT TCL_PACKAGE_PATH TCL_MODULE_PATH DYLIB_INSTALL_DIR -MAKE_ARGS_V = $(foreach v,${MAKE_VARS},$v=${$v}) +VERSION := $(shell awk -F= '/^TCL_VERSION/ {print $$2; nextfile}' ${UNIX_DIR}/configure.in) +TCLSH := tclsh${VERSION} + +BUILD_TARGET := tclsh tcltest +INSTALL_TARGET := install + +override GENERIC_FLAGS := ${GENERIC_FLAGS} -DTCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING export CPPROG := cp -p +INSTALL_TARGETS = install-binaries install-libraries +ifeq (${EMBEDDED_BUILD},) +INSTALL_TARGETS += install-private-headers +endif +ifeq (${INSTALL_BUILD}_${EMBEDDED_BUILD}_${BUILD_STYLE},1__Deployment) +INSTALL_TARGETS += html-tcl +ifneq (${INSTALL_MANPAGES},) +INSTALL_TARGETS += install-doc +endif +endif + +MAKE_VARS := INSTALL_ROOT INSTALL_TARGETS VERSION GENERIC_FLAGS +MAKE_ARGS_V = $(foreach v,${MAKE_VARS},$v='${$v}') + +build-${PROJECT}: target = ${TARGET} +install-${PROJECT}: target = ${INSTALL_TARGET} +clean-${PROJECT} distclean-${PROJECT} test-${PROJECT}: \ + target = $* + +DO_MAKE = +${MAKE} -C ${OBJ_DIR} ${target} ${MAKE_ARGS_V} ${MAKE_ARGS} ${EXTRA_MAKE_ARGS} + #------------------------------------------------------------------------------------------------------- # build rules -${PROJECT}: install-${PROJECT} +${PROJECT}: + ${MAKE} install-${PROJECT} INSTALL_ROOT=${OBJ_DIR}/ ${OBJ_DIR}/Makefile: ${UNIX_DIR}/Makefile.in ${UNIX_DIR}/configure - mkdir -p ${OBJ_DIR} && cd ${OBJ_DIR} && ${UNIX_DIR}/configure \ + mkdir -p ${OBJ_DIR} && cd ${OBJ_DIR} && ${UNIX_DIR}/configure -C \ --prefix=${PREFIX} --bindir=${BINDIR} --libdir=${LIBDIR} \ - --includedir=${INCLUDEDIR} --mandir=${MANDIR} --enable-threads \ - --enable-framework ${CONFIGURE_ARGS} ${EXTRA_CONFIGURE_ARGS} - cd ${OBJ_DIR} && mkdir -p ${PRODUCT_NAME}.framework && \ - ln -fs ../${PRODUCT_NAME} ${PRODUCT_NAME}.framework/${PRODUCT_NAME} + --mandir=${MANDIR} --enable-threads --enable-framework \ + ${CONFIGURE_ARGS} ${EXTRA_CONFIGURE_ARGS} build-${PROJECT}: ${OBJ_DIR}/Makefile - ${MAKE} -C ${OBJ_DIR} ${TARGETS} ${MAKE_ARGS_V} ${MAKE_ARGS} ${EXTRA_MAKE_ARGS} + ${DO_MAKE} # symolic link hackery to trick # 'make install INSTALL_ROOT=${OBJ_DIR}' # into building Tcl.framework and tclsh in ${SYMROOT} - cd ${OBJ_DIR}; mkdir -p $(dir ./${INSTALL_PATH}) $(dir ./${BINDIR}) ${SYMROOT}; \ - rm -f ./${INSTALL_PATH}; ln -fs ${SYMROOT} ./${INSTALL_PATH}; \ - rm -f ./${BINDIR}; ln -fs ${SYMROOT} ./${BINDIR}; \ - ln -fs ${OBJ_DIR}/tcltest ${SYMROOT} - -clean-${PROJECT}: - ${MAKE} -C ${OBJ_DIR} clean ${EXTRA_MAKE_ARGS} - -distclean-${PROJECT}: - ${MAKE} -C ${OBJ_DIR} distclean ${EXTRA_MAKE_ARGS} - rm -rf ${OBJ_DIR} ${PRODUCT_NAME}.framework tclsh${PRODUCT_VERSION} tcltest - -test-${PROJECT}: build-${PROJECT} - ${MAKE} -C ${OBJ_DIR} test ${EXTRA_MAKE_ARGS} + @cd ${OBJ_DIR} && mkdir -p $(dir ./${LIBDIR}) $(dir ./${BINDIR}) ${SYMROOT} && \ + rm -f ./${LIBDIR} ./${BINDIR} && ln -fs ${SYMROOT} ./${LIBDIR} && \ + ln -fs ${SYMROOT} ./${BINDIR} && ln -fs ${OBJ_DIR}/tcltest ${SYMROOT} install-${PROJECT}: build-${PROJECT} -# install to ${INSTALL_ROOT} with optional stripping - ${MAKE} -C ${OBJ_DIR} install-binaries install-libraries install-private-headers \ - SCRIPT_INSTALL_DIR=${INSTALL_ROOT}${SCRIPTDIR} \ - PRIVATE_INCLUDE_INSTALL_DIR=${INSTALL_ROOT}${PRIVATEINCLUDEDIR} \ - ${MAKE_ARGS_V} ${MAKE_ARGS} ${EXTRA_MAKE_ARGS} -ifeq (${BUILD_STYLE},Development) +ifeq (${EMBEDDED_BUILD}_${INSTALL_ROOT},1_) + @echo "Cannot install-embedded with empty INSTALL_ROOT !" && false +endif +ifeq (${EMBEDDED_BUILD},1) + @rm -rf "${INSTALL_ROOT}/${LIBDIR}/Tcl.framework" +endif + ${DO_MAKE} +ifeq (${INSTALL_BUILD},1) +ifeq (${EMBEDDED_BUILD},1) +# if we are embedding frameworks, don't install tclsh + @rm -f "${INSTALL_ROOT}${BINDIR}/${TCLSH}" && \ + rmdir -p "${INSTALL_ROOT}${BINDIR}" 2>&- || true +else +# redo prebinding + @cd ${INSTALL_ROOT}/ && \ + if [ ! -d usr/lib ]; then mkdir -p usr && ln -fs /usr/lib usr/ && RM_USRLIB=1; fi; \ + if [ ! -d System ]; then ln -fs /System . && RM_SYSTEM=1; fi; \ + redo_prebinding -r . "./${LIBDIR}/${PRODUCT_NAME}.framework/Versions/${VERSION}/${PRODUCT_NAME}"; \ + redo_prebinding -r . "./${BINDIR}/${TCLSH}"; \ + if [ -n "$${RM_USRLIB:-}" ]; then rm -f usr/lib; rmdir -p usr 2>&-; fi; \ + if [ -n "$${RM_SYSTEM:-}" ]; then rm -f System; fi +# install tclsh symbolic link + @ln -fs ${TCLSH} ${INSTALL_ROOT}${BINDIR}/tclsh +endif +endif +ifeq (${BUILD_STYLE}_${EMBEDDED_BUILD},Development_) # keep copy of debug library around, so that # Deployment build can be installed on top # of Development build without overwriting # the debug library - cd ${INSTALL_ROOT}${LIBDIR} && ln -f "${PRODUCT_NAME}" "${PRODUCT_NAME}_debug" -endif -# fixup Framework structure - cd ${INSTALL_ROOT}${LIBDIR}/.. && \ - rm -f Current && ln -fs ${PRODUCT_VERSION} Current && \ - cd .. && ln -fs Versions/Current/* . && \ - ln -fs Versions/${PRODUCT_VERSION}/lib*stub* . -ifeq (${INSTALL_BUILD},1) -ifeq (${EMBEDDED_BUILD},1) -# if we are embedding frameworks, don't install tclsh - rm -f "${INSTALL_ROOT}${BINDIR}/${TCLSH}" - -rmdir -p "${INSTALL_ROOT}${BINDIR}" 2>&- -else -# redo prebinding - cd ${INSTALL_ROOT}/; \ - if [ ! -d usr/lib ]; then mkdir -p usr; ln -fs /usr/lib usr/; RM_USRLIB=1; fi; \ - if [ ! -d System ]; then ln -fs /System .; RM_SYSTEM=1; fi; \ - redo_prebinding -r . "./${BINDIR}/${TCLSH}"; \ - if [ -n "$${RM_USRLIB:-}" ]; then rm -f usr/lib; rmdir -p usr 2>&-; fi; \ - if [ -n "$${RM_SYSTEM:-}" ]; then rm -f System; fi -# install tclsh symbolic link - ln -fs ${TCLSH} ${INSTALL_ROOT}${BINDIR}/tclsh -ifeq (${BUILD_STYLE},Deployment) -ifneq (${INSTALL_MANPAGES},) -# install manpages - ${MAKE} -C ${OBJ_DIR} install-doc ${MAKE_ARGS_V} ${MAKE_ARGS} ${EXTRA_MAKE_ARGS} -endif -# build html documentation - export DYLD_FRAMEWORK_PATH=${SYMROOT} && \ - ${MAKE} -C ${OBJ_DIR} html-tcl ${MAKE_ARGS_V} ${MAKE_ARGS} ${EXTRA_MAKE_ARGS} \ - DISTDIR=${INSTALL_ROOT}${DOCDIR} TCL_EXE=${TCL_EXE} && \ - cd ${INSTALL_ROOT}${DOCDIR} && ln -fs contents.htm html/${PRODUCT_NAME}TOC.html && \ - rm -fr "${PRODUCT_NAME}" && mv -f html "${PRODUCT_NAME}" -endif -endif -endif -# write Info.plist file - @printf > ${INSTALL_ROOT}${INFOPLIST} '\ - \n\ - \n\ - \n\ - \n\ - CFBundleDevelopmentRegion\n\ - English\n\ - CFBundleExecutable\n\ - Tcl\n\ - CFBundleGetInfoString\n\ - Tcl Library ${PRODUCT_VERSION}, Copyright © ${YEAR} Tcl Core Team.\n\ - MacOS X Port by Jim Ingham <jingham@apple.com> & Ian Reid, Copyright\ - © 2001-2002, Apple Computer, Inc.\n\ - CFBundleIdentifier\n\ - com.tcltk.tcllibrary\n\ - CFBundleInfoDictionaryVersion\n\ - 6.0\n\ - CFBundleName\n\ - Tcl Library ${PRODUCT_VERSION}\n\ - CFBundlePackageType\n\ - FMWK\n\ - CFBundleShortVersionString\n\ - ${PRODUCT_LONGVERSION}\n\ - CFBundleSignature\n\ - Tcl \n\ - CFBundleVersion\n\ - ${PRODUCT_LONGVERSION}\n\ - \n\ - \n' + @cd ${INSTALL_ROOT}${LIBDIR}/${PRODUCT_NAME}.framework/Versions/${VERSION} && \ + ln -f "${PRODUCT_NAME}" "${PRODUCT_NAME}_debug" +endif + +clean-${PROJECT}: %-${PROJECT}: + ${DO_MAKE} + rm -rf ${SYMROOT}/{${PRODUCT_NAME}.framework,${TCLSH},tcltest} + rm -f ${OBJ_DIR}{${LIBDIR},${BINDIR}} && \ + rmdir -p ${OBJ_DIR}$(dir ${LIBDIR}) 2>&- || true && \ + rmdir -p ${OBJ_DIR}$(dir ${BINDIR}) 2>&- || true + +distclean-${PROJECT}: %-${PROJECT}: clean-${PROJECT} + ${DO_MAKE} + rm -rf ${OBJ_DIR} + +test-${PROJECT}: %-${PROJECT}: build-${PROJECT} + ${DO_MAKE} #------------------------------------------------------------------------------------------------------- .PHONY: ${meta} ${targets} ${PROJECT} build-${PROJECT} install-${PROJECT} \ clean-${PROJECT} distclean-${PROJECT} .NOTPARALLEL: #------------------------------------------------------------------------------------------------------- Index: macosx/README ================================================================== --- macosx/README +++ macosx/README @@ -1,9 +1,9 @@ Tcl MacOSX README ----------------- -RCS: @(#) $Id: README,v 1.2 2003/07/18 02:02:02 das Exp $ +RCS: @(#) $Id: README,v 1.2.4.2 2005/07/12 20:37:06 kennykb Exp $ This is the README file for the Mac OS X native version of Tcl (framework build). 1. General @@ -32,14 +32,14 @@ 2. Using Tcl on MacOSX ---------------------- -- Mac OS X 10.1 (or higher) is required to run Tcl on MacOSX. +- Mac OS X 10.2 (or higher) is required to run Tcl on MacOSX. -- Tcl built on Mac OS X 10.2 or higher will not run on 10.1 due to missing -symbols in libSystem, however Tcl built on 10.1 will run on 10.2 (but without +- Tcl built on Mac OS X 10.3 or higher will not run on 10.2 due to missing +symbols in libSystem, however Tcl built on 10.2 will run on 10.3 (but without prebinding and other optimizations). - Tcl extensions will be found in any of: $HOME/Library/Tcl /Library/Tcl /Network/Library/Tcl /System/Library/Tcl $HOME/Library/Frameworks /Library/Frameworks /Network/Library/Frameworks @@ -49,11 +49,11 @@ This allows building extensions as frameworks with all script files contained in the Resources/Scripts directory of the framework. - The Tcl framework contains documentation in html format in the standard location for frameworks: - Tcl.framework/Resources/English.lproj/Documentation/Reference/Tcl + Tcl.framework/Resources/Documentation/Reference/Tcl No manpages are installed by default. - the framework Tcl.framework can be placed in any of the system's standard framework directories: $HOME/Library/Frameworks /Library/Frameworks @@ -66,23 +66,27 @@ 3. Building Tcl.framework ------------------------- -- Mac OS X 10.1.5 (or higher) is required to build TclMacOSX. +- Mac OS X 10.2 (or higher) is required to build Tcl on MacOSX. -- Apple's Developer Tools CD needs to be installed (the version matching your OS -release, but no earlier than April 2002). This CD should have come with Mac OS X -retail or should be present as a disk image on new macs that came with OSX -preinstalled. It can also be downloaded from http://connect.apple.com (after you -register for free ADC membership). +- Apple's Developer Tools CD needs to be installed (the most recent version +matching your OS release, but no earlier than December 2002). This CD should +have come with Mac OS X retail or should be present as a disk image on new macs +that came with OSX preinstalled. It can also be downloaded from +http://connect.apple.com (after you register for free ADC membership). - Tcl is built as a Mac OS X framework via the Makefile in tcl/macosx, but can -also be built from Apple's ProjectBuilder IDE using the Tcl.pbproj project (which -calls through to the Makefile). +but can also be built directly with the standard unix configure and make +buildsystem in tcl/unix. + +- It is still possible to build with Apple's Xcode IDE using the Tcl.pbproj +project but this is not recommended anymore (currently Tcl.pbproj calls through +to the tcl/macosx/Makefile so there should be no build differences). -- Unpack the tcl archive +- Unpack the tcl source release archive. - The following instructions assume the tcl source tree is named "tcl${ver}", where ${ver} is a shell variable containing the tcl version number (for example '8.4.2'). Setup the shell variable as follows: @@ -92,13 +96,11 @@ archive, if you are building from CVS, the version numbers will be missing; so set ${ver} to the empty string instead: set ver="" ;: if your shell is csh ver="" ;: if your shell is sh -- If you're only interested in _building_ Tcl.framework and don't plan on doing -development with the ProjectBuilder projects, using the Makefile is easiest. -The following steps will build Tcl from the Terminal, assuming you are +- The following steps will build Tcl from the Terminal, assuming you are located in the directory containing the tcl source tree: make -C tcl${ver}/macosx and the following will then install Tcl onto the root volume (admin password required): sudo make -C tcl${ver}/macosx install ADDED macosx/Tcl-Info.plist.in Index: macosx/Tcl-Info.plist.in ================================================================== --- /dev/null +++ macosx/Tcl-Info.plist.in @@ -0,0 +1,27 @@ + + + + + CFBundleDevelopmentRegion + English + CFBundleExecutable + @TCL_LIB_FILE@ + CFBundleGetInfoString + Tcl Library @TCL_VERSION@, Copyright © @TCL_YEAR@ Tcl Core Team. +Initial MacOS X Port by Jim Ingham <jingham@apple.com> & Ian Reid, Copyright © 2001-2002, Apple Computer, Inc. + CFBundleIdentifier + com.tcltk.tcllibrary + CFBundleInfoDictionaryVersion + 6.0 + CFBundleName + Tcl Library @TCL_VERSION@ + CFBundlePackageType + FMWK + CFBundleShortVersionString + @TCL_VERSION@@TCL_PATCH_LEVEL@ + CFBundleSignature + Tcl + CFBundleVersion + @TCL_VERSION@@TCL_PATCH_LEVEL@ + + Index: macosx/tclMacOSXBundle.c ================================================================== --- macosx/tclMacOSXBundle.c +++ macosx/tclMacOSXBundle.c @@ -1,76 +1,72 @@ /* * tclMacOSXBundle.c -- * - * This file implements functions that inspect CFBundle structures - * on MacOS X. - * - * Copyright 2001, Apple Computer, Inc. - * - * The following terms apply to all files originating from Apple - * Computer, Inc. ("Apple") and associated with the software - * unless explicitly disclaimed in individual files. - * - * - * Apple hereby grants permission to use, copy, modify, - * distribute, and license this software and its documentation - * for any purpose, provided that existing copyright notices are - * retained in all copies and that this notice is included - * verbatim in any distributions. No written agreement, license, - * or royalty fee is required for any of the authorized - * uses. Modifications to this software may be copyrighted by - * their authors and need not follow the licensing terms - * described here, provided that the new terms are clearly - * indicated on the first page of each file where they apply. - * - * - * IN NO EVENT SHALL APPLE, THE AUTHORS OR DISTRIBUTORS OF THE - * SOFTWARE BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, - * INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF - * THIS SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, - * EVEN IF APPLE OR THE AUTHORS HAVE BEEN ADVISED OF THE - * POSSIBILITY OF SUCH DAMAGE. APPLE, THE AUTHORS AND - * DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, INCLUDING, - * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, - * FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS - * SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND APPLE,THE - * AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE - * MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - * - * GOVERNMENT USE: If you are acquiring this software on behalf - * of the U.S. government, the Government shall have only - * "Restricted Rights" in the software and related documentation - * as defined in the Federal Acquisition Regulations (FARs) in - * Clause 52.227.19 (c) (2). If you are acquiring the software - * on behalf of the Department of Defense, the software shall be - * classified as "Commercial Computer Software" and the - * Government shall have only "Restricted Rights" as defined in - * Clause 252.227-7013 (c) (1) of DFARs. Notwithstanding the - * foregoing, the authors grant the U.S. Government and others - * acting in its behalf permission to use and distribute the - * software in accordance with the terms specified in this - * license. + * This file implements functions that inspect CFBundle structures on + * MacOS X. + * + * Copyright 2001, Apple Computer, Inc. + * + * The following terms apply to all files originating from Apple + * Computer, Inc. ("Apple") and associated with the software unless + * explicitly disclaimed in individual files. + * + * Apple hereby grants permission to use, copy, modify, distribute, and + * license this software and its documentation for any purpose, provided + * that existing copyright notices are retained in all copies and that + * this notice is included verbatim in any distributions. No written + * agreement, license, or royalty fee is required for any of the + * authorized uses. Modifications to this software may be copyrighted by + * their authors and need not follow the licensing terms described here, + * provided that the new terms are clearly indicated on the first page of + * each file where they apply. + * + * IN NO EVENT SHALL APPLE, THE AUTHORS OR DISTRIBUTORS OF THE SOFTWARE + * BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR + * CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE, ITS + * DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN IF APPLE OR THE + * AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. APPLE, + * THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF + * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND + * NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND + * APPLE,THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE + * MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + * + * GOVERNMENT USE: If you are acquiring this software on behalf of the + * U.S. government, the Government shall have only "Restricted Rights" in + * the software and related documentation as defined in the Federal + * Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you are + * acquiring the software on behalf of the Department of Defense, the + * software shall be classified as "Commercial Computer Software" and the + * Government shall have only "Restricted Rights" as defined in Clause + * 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the + * authors grant the U.S. Government and others acting in its behalf + * permission to use and distribute the software in accordance with the + * terms specified in this license. */ +#ifdef HAVE_COREFOUNDATION #include #include +#endif /* HAVE_COREFOUNDATION */ + #include "tcl.h" /* *---------------------------------------------------------------------- * * Tcl_MacOSXOpenBundleResources -- * * Given the bundle name for a shared library, this routine sets * libraryPath to the Resources/Scripts directory in the framework - * package. If hasResourceFile is true, it will also open the main + * package. If hasResourceFile is true, it will also open the main * resource file for the bundle. - * * * Results: * TCL_OK if the bundle could be opened, and the Scripts folder found. - * TCL_ERROR otherwise. + * TCL_ERROR otherwise. * * Side effects: * libraryVariableName may be set, and the resource file opened. * *---------------------------------------------------------------------- @@ -78,33 +74,32 @@ int Tcl_MacOSXOpenBundleResources( Tcl_Interp *interp, CONST char *bundleName, - int hasResourceFile, - int maxPathLen, - char *libraryPath) + int hasResourceFile, + int maxPathLen, + char *libraryPath) { return Tcl_MacOSXOpenVersionedBundleResources(interp, bundleName, - NULL, hasResourceFile, maxPathLen, libraryPath); + NULL, hasResourceFile, maxPathLen, libraryPath); } /* *---------------------------------------------------------------------- * * Tcl_MacOSXOpenVersionedBundleResources -- * - * Given the bundle and version name for a shared library (version - * name can be NULL to indicate latest version), this routine sets - * libraryPath to the Resources/Scripts directory in the framework - * package. If hasResourceFile is true, it will also open the main - * resource file for the bundle. - * + * Given the bundle and version name for a shared library (version name + * can be NULL to indicate latest version), this routine sets libraryPath + * to the Resources/Scripts directory in the framework package. If + * hasResourceFile is true, it will also open the main resource file for + * the bundle. * * Results: * TCL_OK if the bundle could be opened, and the Scripts folder found. - * TCL_ERROR otherwise. + * TCL_ERROR otherwise. * * Side effects: * libraryVariableName may be set, and the resource file opened. * *---------------------------------------------------------------------- @@ -113,46 +108,54 @@ int Tcl_MacOSXOpenVersionedBundleResources( Tcl_Interp *interp, CONST char *bundleName, CONST char *bundleVersion, - int hasResourceFile, - int maxPathLen, - char *libraryPath) + int hasResourceFile, + int maxPathLen, + char *libraryPath) { +#ifdef HAVE_COREFOUNDATION CFBundleRef bundleRef; CFStringRef bundleNameRef; CFURLRef libURL; libraryPath[0] = '\0'; - bundleNameRef = CFStringCreateWithCString(NULL, - bundleName, kCFStringEncodingUTF8); + bundleNameRef = CFStringCreateWithCString(NULL, bundleName, + kCFStringEncodingUTF8); bundleRef = CFBundleGetBundleWithIdentifier(bundleNameRef); CFRelease(bundleNameRef); if (bundleVersion && bundleRef) { - /* create bundle from bundleVersion subdirectory of 'Versions' */ - CFBundleRef versionedBundleRef = NULL; + /* + * Create bundle from bundleVersion subdirectory of 'Versions'. + */ + + CFBundleRef versionedBundleRef = NULL; CFURLRef versionedBundleURL = NULL; CFStringRef bundleVersionRef = CFStringCreateWithCString(NULL, bundleVersion, kCFStringEncodingUTF8); CFURLRef bundleURL = CFBundleCopyBundleURL(bundleRef); + if (bundleURL) { CFStringRef bundleTailRef = CFURLCopyLastPathComponent(bundleURL); + if (bundleTailRef) { - if (CFStringCompare(bundleTailRef,bundleVersionRef,0) - == kCFCompareEqualTo) { + if (CFStringCompare(bundleTailRef, bundleVersionRef, + 0) == kCFCompareEqualTo) { versionedBundleRef = bundleRef; } CFRelease(bundleTailRef); } } + if (bundleURL && !versionedBundleRef) { CFURLRef versURL = CFURLCreateCopyAppendingPathComponent(NULL, - bundleURL, CFSTR("Versions"), TRUE); + bundleURL, CFSTR("Versions"), TRUE); + if (versURL) { versionedBundleURL = CFURLCreateCopyAppendingPathComponent( NULL, versURL, bundleVersionRef, TRUE); CFRelease(versURL); } @@ -166,47 +169,66 @@ bundleRef = versionedBundleRef; } if (bundleRef) { if (hasResourceFile) { - /* Dynamically acquire address for CFBundleOpenBundleResourceMap - * symbol, since it is only present in full CoreFoundation - * on Mac OS X and not in CFLite on pure Darwin. */ + /* + * Dynamically acquire address for CFBundleOpenBundleResourceMap + * symbol, since it is only present in full CoreFoundation on Mac + * OS X and not in CFLite on pure Darwin. + */ + static int initialized = FALSE; static short (*openresourcemap)(CFBundleRef) = NULL; - if(!initialized) { + + if (!initialized) { NSSymbol nsSymbol = NULL; - if(NSIsSymbolNameDefinedWithHint("_CFBundleOpenBundleResourceMap", "CoreFoundation")) { - nsSymbol = NSLookupAndBindSymbolWithHint("_CFBundleOpenBundleResourceMap", "CoreFoundation"); - if(nsSymbol) { + if (NSIsSymbolNameDefinedWithHint( + "_CFBundleOpenBundleResourceMap", "CoreFoundation")) { + nsSymbol = NSLookupAndBindSymbolWithHint( + "_CFBundleOpenBundleResourceMap","CoreFoundation"); + if (nsSymbol) { openresourcemap = NSAddressOfSymbol(nsSymbol); } } initialized = TRUE; } + if (openresourcemap) { short refNum; + refNum = openresourcemap(bundleRef); } } - libURL = CFBundleCopyResourceURL(bundleRef, - CFSTR("Scripts"), NULL, NULL); + libURL = CFBundleCopyResourceURL(bundleRef, CFSTR("Scripts"), + NULL, NULL); if (libURL) { /* - * FIXME: This is a quick fix, it is probably not right - * for internationalization. + * FIXME: This is a quick fix, it is probably not right for + * internationalization. */ CFURLGetFileSystemRepresentation(libURL, TRUE, - libraryPath, maxPathLen); + (unsigned char*) libraryPath, maxPathLen); CFRelease(libURL); } } if (libraryPath[0]) { - return TCL_OK; + return TCL_OK; } else { return TCL_ERROR; } +#else /* HAVE_COREFOUNDATION */ + return TCL_ERROR; +#endif /* HAVE_COREFOUNDATION */ } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: macosx/tclMacOSXFCmd.c ================================================================== --- macosx/tclMacOSXFCmd.c +++ macosx/tclMacOSXFCmd.c @@ -1,17 +1,17 @@ /* * tclMacOSXFCmd.c * - * This file implements the MacOSX specific portion of file manipulation - * subcommands of the "file" command. + * This file implements the MacOSX specific portion of file manipulation + * subcommands of the "file" command. * * Copyright (c) 2003 Tcl Core Team. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclMacOSXFCmd.c,v 1.3 2004/11/11 01:16:41 das Exp $ + * RCS: @(#) $Id: tclMacOSXFCmd.c,v 1.3.2.1 2005/08/02 18:16:16 dgp Exp $ */ #include "tclInt.h" #ifdef HAVE_GETATTRLIST @@ -18,12 +18,12 @@ #include #include #endif /* - * Constants for file attributes subcommand. - * Need to be kept in sync with tclUnixFCmd.c ! + * Constants for file attributes subcommand. Need to be kept in sync with + * tclUnixFCmd.c ! */ enum { UNIX_GROUP_ATTRIBUTE, UNIX_OWNER_ATTRIBUTE, @@ -39,266 +39,278 @@ #endif }; typedef u_int32_t OSType; -static int Tcl_GetOSTypeFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - OSType *osTypePtr); -static Tcl_Obj *Tcl_NewOSTypeStringObj(CONST OSType newOSType); +static int Tcl_GetOSTypeFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, OSType *osTypePtr); +static Tcl_Obj * Tcl_NewOSTypeStringObj(CONST OSType newOSType); enum { kFinfoIsInvisible = 0x4000, }; typedef struct fileinfobuf { - u_int32_t info_length; - union { - struct { - u_int32_t type; - u_int32_t creator; - u_int16_t fdFlags; - u_int16_t location; - u_int32_t padding[4]; - } finder; - off_t rsrcForkSize; - } data __attribute__ ((packed)); + u_int32_t info_length; + union { + struct { + u_int32_t type; + u_int32_t creator; + u_int16_t fdFlags; + u_int16_t location; + u_int32_t padding[4]; + } finder; + off_t rsrcForkSize; + } data __attribute__ ((packed)); } fileinfobuf; /* *---------------------------------------------------------------------- * * TclMacOSXGetFileAttribute * - * Gets a MacOSX attribute of a file. Which attribute is - * controlled by objIndex. The object will have ref count 0. + * Gets a MacOSX attribute of a file. Which attribute is controlled by + * objIndex. The object will have ref count 0. * * Results: - * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr - * if there is no error. + * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there + * is no error. * * Side effects: - * A new object is allocated. - * + * A new object is allocated. + * *---------------------------------------------------------------------- */ int TclMacOSXGetFileAttribute(interp, objIndex, fileName, attributePtrPtr) - Tcl_Interp *interp; /* The interp we are using for errors. */ - int objIndex; /* The index of the attribute. */ - Tcl_Obj *fileName; /* The name of the file (UTF-8). */ - Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ + Tcl_Interp *interp; /* The interp we are using for errors. */ + int objIndex; /* The index of the attribute. */ + Tcl_Obj *fileName; /* The name of the file (UTF-8). */ + Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ { #ifdef HAVE_GETATTRLIST int result; Tcl_StatBuf statBuf; struct attrlist alist; fileinfobuf finfo; CONST char *native; - + result = TclpObjStat(fileName, &statBuf); - + if (result != 0) { - Tcl_AppendResult(interp, "could not read \"", + Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } if (S_ISDIR(statBuf.st_mode) && objIndex != MACOSX_HIDDEN_ATTRIBUTE) { - /* Directories only support attribute "-hidden" */ - errno = EISDIR; - Tcl_AppendResult(interp, "invalid attribute: ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; + /* + * Directories only support attribute "-hidden". + */ + + errno = EISDIR; + Tcl_AppendResult(interp, "invalid attribute: ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; } memset(&alist, 0, sizeof(struct attrlist)); alist.bitmapcount = ATTR_BIT_MAP_COUNT; - if(objIndex == MACOSX_RSRCLENGTH_ATTRIBUTE) { - alist.fileattr = ATTR_FILE_RSRCLENGTH; + if (objIndex == MACOSX_RSRCLENGTH_ATTRIBUTE) { + alist.fileattr = ATTR_FILE_RSRCLENGTH; } else { - alist.commonattr = ATTR_CMN_FNDRINFO; + alist.commonattr = ATTR_CMN_FNDRINFO; } native = Tcl_FSGetNativePath(fileName); result = getattrlist(native, &alist, &finfo, sizeof(fileinfobuf), 0); if (result != 0) { - Tcl_AppendResult(interp, "could not read attributes of \"", - Tcl_GetString(fileName), "\": ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "could not read attributes of \"", + Tcl_GetString(fileName), "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; } switch (objIndex) { - case MACOSX_CREATOR_ATTRIBUTE: - *attributePtrPtr = Tcl_NewOSTypeStringObj(finfo.data.finder.creator); - break; - case MACOSX_TYPE_ATTRIBUTE: - *attributePtrPtr = Tcl_NewOSTypeStringObj(finfo.data.finder.type); - break; - case MACOSX_HIDDEN_ATTRIBUTE: - *attributePtrPtr = Tcl_NewBooleanObj( (finfo.data.finder.fdFlags - & kFinfoIsInvisible) != 0); - break; - case MACOSX_RSRCLENGTH_ATTRIBUTE: - *attributePtrPtr = Tcl_NewWideIntObj(finfo.data.rsrcForkSize); - break; + case MACOSX_CREATOR_ATTRIBUTE: + *attributePtrPtr = Tcl_NewOSTypeStringObj(finfo.data.finder.creator); + break; + case MACOSX_TYPE_ATTRIBUTE: + *attributePtrPtr = Tcl_NewOSTypeStringObj(finfo.data.finder.type); + break; + case MACOSX_HIDDEN_ATTRIBUTE: + *attributePtrPtr = Tcl_NewBooleanObj( + (finfo.data.finder.fdFlags & kFinfoIsInvisible) != 0); + break; + case MACOSX_RSRCLENGTH_ATTRIBUTE: + *attributePtrPtr = Tcl_NewWideIntObj(finfo.data.rsrcForkSize); + break; } return TCL_OK; #else Tcl_AppendResult(interp, "Mac OS X file attributes not supported", - (char *) NULL); + (char *) NULL); return TCL_ERROR; #endif } /* *--------------------------------------------------------------------------- * * TclMacOSXSetFileAttribute -- * - * Sets a MacOSX attribute of a file. Which attribute is - * controlled by objIndex. + * Sets a MacOSX attribute of a file. Which attribute is controlled by + * objIndex. * * Results: - * Standard TCL result. + * Standard TCL result. * * Side effects: - * As above. - * + * As above. + * *--------------------------------------------------------------------------- */ int TclMacOSXSetFileAttribute(interp, objIndex, fileName, attributePtr) - Tcl_Interp *interp; /* The interp for error reporting. */ - int objIndex; /* The index of the attribute. */ - Tcl_Obj *fileName; /* The name of the file (UTF-8). */ - Tcl_Obj *attributePtr; /* New owner for file. */ + Tcl_Interp *interp; /* The interp for error reporting. */ + int objIndex; /* The index of the attribute. */ + Tcl_Obj *fileName; /* The name of the file (UTF-8). */ + Tcl_Obj *attributePtr; /* New owner for file. */ { #ifdef HAVE_GETATTRLIST int result; Tcl_StatBuf statBuf; struct attrlist alist; fileinfobuf finfo; CONST char *native; - + result = TclpObjStat(fileName, &statBuf); - + if (result != 0) { - Tcl_AppendResult(interp, "could not read \"", + Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } if (S_ISDIR(statBuf.st_mode) && objIndex != MACOSX_HIDDEN_ATTRIBUTE) { - /* Directories only support attribute "-hidden" */ - errno = EISDIR; - Tcl_AppendResult(interp, "invalid attribute: ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; + /* + * Directories only support attribute "-hidden". + */ + + errno = EISDIR; + Tcl_AppendResult(interp, "invalid attribute: ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; } memset(&alist, 0, sizeof(struct attrlist)); alist.bitmapcount = ATTR_BIT_MAP_COUNT; - if(objIndex == MACOSX_RSRCLENGTH_ATTRIBUTE) { - alist.fileattr = ATTR_FILE_RSRCLENGTH; + if (objIndex == MACOSX_RSRCLENGTH_ATTRIBUTE) { + alist.fileattr = ATTR_FILE_RSRCLENGTH; } else { - alist.commonattr = ATTR_CMN_FNDRINFO; + alist.commonattr = ATTR_CMN_FNDRINFO; } native = Tcl_FSGetNativePath(fileName); result = getattrlist(native, &alist, &finfo, sizeof(fileinfobuf), 0); if (result != 0) { - Tcl_AppendResult(interp, "could not read attributes of \"", - Tcl_GetString(fileName), "\": ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "could not read attributes of \"", + Tcl_GetString(fileName), "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; } if (objIndex != MACOSX_RSRCLENGTH_ATTRIBUTE) { - switch (objIndex) { - case MACOSX_CREATOR_ATTRIBUTE: - if (Tcl_GetOSTypeFromObj(interp, attributePtr, - &finfo.data.finder.creator) != TCL_OK) { - return TCL_ERROR; - } - break; - case MACOSX_TYPE_ATTRIBUTE: - if (Tcl_GetOSTypeFromObj(interp, attributePtr, - &finfo.data.finder.type) != TCL_OK) { - return TCL_ERROR; - } - break; - case MACOSX_HIDDEN_ATTRIBUTE: - { - int hidden; - if (Tcl_GetBooleanFromObj(interp, attributePtr, &hidden) - != TCL_OK) { - return TCL_ERROR; - } - if (hidden) { - finfo.data.finder.fdFlags |= kFinfoIsInvisible; - } else { - finfo.data.finder.fdFlags &= ~kFinfoIsInvisible; - } - } - break; - } - result = setattrlist(native, &alist, &finfo.data, sizeof(finfo.data), 0); - - if (result != 0) { - Tcl_AppendResult(interp, "could not set attributes of \"", - Tcl_GetString(fileName), "\": ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - } else { - off_t newRsrcForkSize; - - if (Tcl_GetWideIntFromObj(interp, attributePtr, - &newRsrcForkSize) != TCL_OK) { - return TCL_ERROR; - } - - if(newRsrcForkSize != finfo.data.rsrcForkSize) { - Tcl_DString ds; - /* - * Only setting rsrclength to 0 to strip - * a file's resource fork is supported. - */ - if(newRsrcForkSize != 0) { - Tcl_AppendResult(interp, - "setting nonzero rsrclength not supported", - (char *) NULL); - return TCL_ERROR; - } - - /* construct path to resource fork */ - Tcl_DStringInit(&ds); - Tcl_DStringAppend(&ds, native, -1); - Tcl_DStringAppend(&ds, _PATH_RSRCFORKSPEC, -1); - - result = truncate(Tcl_DStringValue(&ds), (off_t)0); - - Tcl_DStringFree(&ds); - - if (result != 0) { - Tcl_AppendResult(interp, - "could not truncate resource fork of \"", - Tcl_GetString(fileName), "\": ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - } + switch (objIndex) { + case MACOSX_CREATOR_ATTRIBUTE: + if (Tcl_GetOSTypeFromObj(interp, attributePtr, + &finfo.data.finder.creator) != TCL_OK) { + return TCL_ERROR; + } + break; + case MACOSX_TYPE_ATTRIBUTE: + if (Tcl_GetOSTypeFromObj(interp, attributePtr, + &finfo.data.finder.type) != TCL_OK) { + return TCL_ERROR; + } + break; + case MACOSX_HIDDEN_ATTRIBUTE: { + int hidden; + + if (Tcl_GetBooleanFromObj(interp,attributePtr,&hidden) != TCL_OK) { + return TCL_ERROR; + } + if (hidden) { + finfo.data.finder.fdFlags |= kFinfoIsInvisible; + } else { + finfo.data.finder.fdFlags &= ~kFinfoIsInvisible; + } + break; + } + } + + result = setattrlist(native, &alist, + &finfo.data, sizeof(finfo.data), 0); + + if (result != 0) { + Tcl_AppendResult(interp, "could not set attributes of \"", + Tcl_GetString(fileName), "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + } else { + off_t newRsrcForkSize; + + if (Tcl_GetWideIntFromObj(interp, attributePtr, + &newRsrcForkSize) != TCL_OK) { + return TCL_ERROR; + } + + if (newRsrcForkSize != finfo.data.rsrcForkSize) { + Tcl_DString ds; + + /* + * Only setting rsrclength to 0 to strip a file's resource fork is + * supported. + */ + + if(newRsrcForkSize != 0) { + Tcl_AppendResult(interp, + "setting nonzero rsrclength not supported", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Construct path to resource fork. + */ + + Tcl_DStringInit(&ds); + Tcl_DStringAppend(&ds, native, -1); + Tcl_DStringAppend(&ds, _PATH_RSRCFORKSPEC, -1); + + result = truncate(Tcl_DStringValue(&ds), (off_t)0); + + Tcl_DStringFree(&ds); + + if (result != 0) { + Tcl_AppendResult(interp, + "could not truncate resource fork of \"", + Tcl_GetString(fileName), "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + } } return TCL_OK; #else Tcl_AppendResult(interp, "Mac OS X file attributes not supported", - (char *) NULL); + (char *) NULL); return TCL_ERROR; #endif } /* @@ -311,70 +323,76 @@ * * Results: * Standard Tcl result. * * Side effects: - * MacOSX attributes and resource fork are updated in the new file - * to reflect the old file. + * MacOSX attributes and resource fork are updated in the new file to + * reflect the old file. * *--------------------------------------------------------------------------- */ int -TclMacOSXCopyFileAttributes(src, dst, statBufPtr) +TclMacOSXCopyFileAttributes(src, dst, statBufPtr) CONST char *src; /* Path name of source file (native). */ CONST char *dst; /* Path name of target file (native). */ CONST Tcl_StatBuf *statBufPtr; /* Stat info for source file */ { #ifdef HAVE_GETATTRLIST struct attrlist alist; fileinfobuf finfo; - - memset(&alist, 0, sizeof(struct attrlist)); - alist.bitmapcount = ATTR_BIT_MAP_COUNT; - alist.commonattr = ATTR_CMN_FNDRINFO; - - if (getattrlist(src, &alist, &finfo, sizeof(fileinfobuf), 0)) { - return TCL_ERROR; - } - - if (setattrlist(dst, &alist, &finfo.data, sizeof(finfo.data), 0)) { - return TCL_ERROR; - } - - if (!S_ISDIR(statBufPtr->st_mode)) { - /* only copy non-empty resource fork */ - alist.commonattr = 0; - alist.fileattr = ATTR_FILE_RSRCLENGTH; - - if (getattrlist(src, &alist, &finfo, sizeof(fileinfobuf), 0)) { - return TCL_ERROR; - } - - if(finfo.data.rsrcForkSize > 0) { - int result; - Tcl_DString ds_src, ds_dst; - - /* construct paths to resource forks */ - Tcl_DStringInit(&ds_src); - Tcl_DStringAppend(&ds_src, src, -1); - Tcl_DStringAppend(&ds_src, _PATH_RSRCFORKSPEC, -1); - Tcl_DStringInit(&ds_dst); - Tcl_DStringAppend(&ds_dst, dst, -1); - Tcl_DStringAppend(&ds_dst, _PATH_RSRCFORKSPEC, -1); - - result = TclUnixCopyFile(Tcl_DStringValue(&ds_src), - Tcl_DStringValue(&ds_dst), statBufPtr, 1); - - Tcl_DStringFree(&ds_src); - Tcl_DStringFree(&ds_dst); - - if (result != 0) { - return TCL_ERROR; - } - } + + memset(&alist, 0, sizeof(struct attrlist)); + alist.bitmapcount = ATTR_BIT_MAP_COUNT; + alist.commonattr = ATTR_CMN_FNDRINFO; + + if (getattrlist(src, &alist, &finfo, sizeof(fileinfobuf), 0)) { + return TCL_ERROR; + } + + if (setattrlist(dst, &alist, &finfo.data, sizeof(finfo.data), 0)) { + return TCL_ERROR; + } + + if (!S_ISDIR(statBufPtr->st_mode)) { + /* + * Only copy non-empty resource fork. + */ + + alist.commonattr = 0; + alist.fileattr = ATTR_FILE_RSRCLENGTH; + + if (getattrlist(src, &alist, &finfo, sizeof(fileinfobuf), 0)) { + return TCL_ERROR; + } + + if(finfo.data.rsrcForkSize > 0) { + int result; + Tcl_DString ds_src, ds_dst; + + /* + * Construct paths to resource forks. + */ + + Tcl_DStringInit(&ds_src); + Tcl_DStringAppend(&ds_src, src, -1); + Tcl_DStringAppend(&ds_src, _PATH_RSRCFORKSPEC, -1); + Tcl_DStringInit(&ds_dst); + Tcl_DStringAppend(&ds_dst, dst, -1); + Tcl_DStringAppend(&ds_dst, _PATH_RSRCFORKSPEC, -1); + + result = TclUnixCopyFile(Tcl_DStringValue(&ds_src), + Tcl_DStringValue(&ds_dst), statBufPtr, 1); + + Tcl_DStringFree(&ds_src); + Tcl_DStringFree(&ds_dst); + + if (result != 0) { + return TCL_ERROR; + } + } } return TCL_OK; #else return TCL_ERROR; #endif @@ -386,24 +404,24 @@ * Tcl_GetOSTypeFromObj -- * * Attempt to return an OSType from the Tcl object "objPtr". * * Results: - * Standard TCL result. If an error occurs during conversion, - * an error message is left in interp->objResult. + * Standard TCL result. If an error occurs during conversion, an error + * message is left in interp->objResult. * * Side effects: * The string representation of objPtr will be updated if necessary. * *---------------------------------------------------------------------- */ static int Tcl_GetOSTypeFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr, /* The object from which to get an OSType. */ - OSType *osTypePtr) /* Place to store resulting OSType. */ + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr, /* The object from which to get an OSType. */ + OSType *osTypePtr) /* Place to store resulting OSType. */ { char *string; int length, result = TCL_OK; Tcl_DString ds; Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman"); @@ -410,18 +428,18 @@ string = Tcl_GetStringFromObj(objPtr, &length); Tcl_UtfToExternalDString(encoding, string, length, &ds); if (Tcl_DStringLength(&ds) > sizeof(OSType)) { - Tcl_AppendResult(interp, + Tcl_AppendResult(interp, "expected Macintosh OS type but got \"", string, "\": ", (char *) NULL); - result = TCL_ERROR; + result = TCL_ERROR; } else { memset(osTypePtr, 0, sizeof(OSType)); memcpy(osTypePtr, Tcl_DStringValue(&ds), - (size_t) Tcl_DStringLength(&ds)); + (size_t) Tcl_DStringLength(&ds)); } Tcl_DStringFree(&ds); Tcl_FreeEncoding(encoding); return result; } @@ -452,10 +470,19 @@ Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman"); memcpy(string, &newOSType, sizeof(OSType)); string[sizeof(OSType)] = '\0'; Tcl_ExternalToUtfDString(encoding, string, -1, &ds); - resultPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); + resultPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); Tcl_FreeEncoding(encoding); return resultPtr; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ ADDED macosx/tclMacOSXNotify.c Index: macosx/tclMacOSXNotify.c ================================================================== --- /dev/null +++ macosx/tclMacOSXNotify.c @@ -0,0 +1,1068 @@ +/* + * tclMacOSXNotify.c -- + * + * This file contains the implementation of a merged CFRunLoop/select() + * based notifier, which is the lowest-level part of the Tcl event loop. + * This file works together with generic/tclNotify.c. + * + * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * Copyright 2001, Apple Computer, Inc. + * Copyright 2005, Tcl Core Team. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclMacOSXNotify.c,v 1.3.2.3 2005/08/02 18:16:16 dgp Exp $ + */ + +#ifdef HAVE_COREFOUNDATION /* Traditional unix select-based notifier is + * in tclUnixNotfy.c */ +#include "tclInt.h" +#include +#include + +extern TclStubs tclStubs; +extern Tcl_NotifierProcs tclOriginalNotifier; + +/* + * This structure is used to keep track of the notifier info for a registered + * file. + */ + +typedef struct FileHandler { + int fd; + int mask; /* Mask of desired events: TCL_READABLE, + * etc. */ + int readyMask; /* Mask of events that have been seen since + * the last time file handlers were invoked + * for this file. */ + Tcl_FileProc *proc; /* Function to call, in the style of + * Tcl_CreateFileHandler. */ + ClientData clientData; /* Argument to pass to proc. */ + struct FileHandler *nextPtr;/* Next in list of all files we care about. */ +} FileHandler; + +/* + * The following structure is what is added to the Tcl event queue when file + * handlers are ready to fire. + */ + +typedef struct FileHandlerEvent { + Tcl_Event header; /* Information that is standard for all + * events. */ + int fd; /* File descriptor that is ready. Used to find + * the FileHandler structure for the file + * (can't point directly to the FileHandler + * structure because it could go away while + * the event is queued). */ +} FileHandlerEvent; + +/* + * The following structure contains a set of select() masks to track readable, + * writable, and exceptional conditions. + */ + +typedef struct SelectMasks { + fd_set readable; + fd_set writable; + fd_set exceptional; +} SelectMasks; + +/* + * The following static structure contains the state information for the + * select based implementation of the Tcl notifier. One of these structures is + * created for each thread that is using the notifier. + */ + +typedef struct ThreadSpecificData { + FileHandler *firstFileHandlerPtr; + /* Pointer to head of file handler list. */ + SelectMasks checkMasks; /* This structure is used to build up the + * masks to be used in the next call to + * select. Bits are set in response to calls + * to Tcl_CreateFileHandler. */ + SelectMasks readyMasks; /* This array reflects the readable/writable + * conditions that were found to exist by the + * last call to select. */ + int numFdBits; /* Number of valid bits in checkMasks (one + * more than highest fd for which + * Tcl_WatchFile has been called). */ + int onList; /* True if it is in this list */ + unsigned int pollState; /* pollState is used to implement a polling + * handshake between each thread and the + * notifier thread. Bits defined below. */ + struct ThreadSpecificData *nextPtr, *prevPtr; + /* All threads that are currently waiting on + * an event have their ThreadSpecificData + * structure on a doubly-linked listed formed + * from these pointers. You must hold the + * notifierLock before accessing these + * fields. */ + CFRunLoopSourceRef runLoopSource; + /* Any other thread alerts a notifier that an + * event is ready to be processed by signaling + * this CFRunLoopSource. */ + CFRunLoopRef runLoop; /* This thread's CFRunLoop, needs to be woken + * up whenever the runLoopSource is + * signaled. */ + int eventReady; /* True if an event is ready to be + * processed. */ +} ThreadSpecificData; + +static Tcl_ThreadDataKey dataKey; + +/* + * The following static indicates the number of threads that have initialized + * notifiers. + * + * You must hold the notifierInitLock before accessing this variable. + */ + +static int notifierCount = 0; + +/* + * The following variable points to the head of a doubly-linked list of + * ThreadSpecificData structures for all threads that are currently waiting on + * an event. + * + * You must hold the notifierLock before accessing this list. + */ + +static ThreadSpecificData *waitingListPtr = NULL; + +/* + * The notifier thread spends all its time in select() waiting for a file + * descriptor associated with one of the threads on the waitingListPtr list to + * do something interesting. But if the contents of the waitingListPtr list + * ever changes, we need to wake up and restart the select() system call. You + * can wake up the notifier thread by writing a single byte to the file + * descriptor defined below. This file descriptor is the input-end of a pipe + * and the notifier thread is listening for data on the output-end of the same + * pipe. Hence writing to this file descriptor will cause the select() system + * call to return and wake up the notifier thread. + * + * You must hold the notifierLock lock before writing to the pipe. + */ + +static int triggerPipe = -1; +static int receivePipe = -1; /* Output end of triggerPipe */ + +/* + * We use Darwin-native spinlocks instead of pthread mutexes for notifier + * locking: this radically simplifies the implementation and lowers overhead. + * Note that these are not pure spinlocks, they employ various strategies to + * back off, making them immune to most priority-inversion livelocks (c.f. man + * 3 OSSpinLockLock). + */ + +#if defined(HAVE_LIBKERN_OSATOMIC_H) && defined(HAVE_OSSPINLOCKLOCK) +/* + * Use OSSpinLock API where available (Tiger or later). + */ + +#include + +#else +/* + * Otherwise, use commpage spinlock SPI directly. + */ + +typedef uint32_t OSSpinLock; +extern void _spin_lock(OSSpinLock *lock); +extern void _spin_unlock(OSSpinLock *lock); +#define OSSpinLockLock(p) _spin_lock(p) +#define OSSpinLockUnlock(p) _spin_unlock(p) + +#endif /* HAVE_LIBKERN_OSATOMIC_H && HAVE_OSSPINLOCKLOCK */ + +/* + * These spinlocks lock access to the global notifier state. + */ + +static OSSpinLock notifierInitLock = 0; +static OSSpinLock notifierLock = 0; + +/* + * Macros abstracting notifier locking/unlocking + */ + +#define LOCK_NOTIFIER_INIT OSSpinLockLock(¬ifierInitLock) +#define UNLOCK_NOTIFIER_INIT OSSpinLockUnlock(¬ifierInitLock) +#define LOCK_NOTIFIER OSSpinLockLock(¬ifierLock) +#define UNLOCK_NOTIFIER OSSpinLockUnlock(¬ifierLock) + +/* + * The pollState bits + * POLL_WANT is set by each thread before it waits on its condition + * variable. It is checked by the notifier before it does select. + * POLL_DONE is set by the notifier if it goes into select after seeing + * POLL_WANT. The idea is to ensure it tries a select with the + * same bits the initial thread had set. + */ + +#define POLL_WANT 0x1 +#define POLL_DONE 0x2 + +/* + * This is the thread ID of the notifier thread that does select. + */ + +static pthread_t notifierThread; + +/* + * Static routines defined in this file. + */ + +static void NotifierThreadProc(ClientData clientData); +static int FileHandlerEventProc(Tcl_Event *evPtr, int flags); + +/* + *---------------------------------------------------------------------- + * + * Tcl_InitNotifier -- + * + * Initializes the platform specific notifier state. + * + * Results: + * Returns a handle to the notifier state for this thread.. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tcl_InitNotifier() +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + tsdPtr->eventReady = 0; + + /* + * Initialize CFRunLoopSource and add it to CFRunLoop of this thread + */ + + if (!tsdPtr->runLoop) { + CFRunLoopRef runLoop = CFRunLoopGetCurrent(); + CFRunLoopSourceRef runLoopSource; + CFRunLoopSourceContext runLoopSourceContext; + + bzero(&runLoopSourceContext, sizeof(CFRunLoopSourceContext)); + runLoopSourceContext.info = tsdPtr; + runLoopSource = CFRunLoopSourceCreate(NULL, 0, &runLoopSourceContext); + if (!runLoopSource) { + Tcl_Panic("Tcl_InitNotifier: could not create CFRunLoopSource."); + } + CFRunLoopAddSource(runLoop, runLoopSource, kCFRunLoopCommonModes); + tsdPtr->runLoopSource = runLoopSource; + tsdPtr->runLoop = runLoop; + } + + /* + * Initialize trigger pipe and start the Notifier thread if necessary. + */ + + LOCK_NOTIFIER_INIT; + if (notifierCount == 0) { + int fds[2], status, result; + pthread_attr_t attr; + + if (pipe(fds) != 0) { + Tcl_Panic("Tcl_InitNotifier: could not create trigger pipe."); + } + + status = fcntl(fds[0], F_GETFL); + status |= O_NONBLOCK; + if (fcntl(fds[0], F_SETFL, status) < 0) { + Tcl_Panic("Tcl_InitNotifier: could not make receive pipe non blocking."); + } + status = fcntl(fds[1], F_GETFL); + status |= O_NONBLOCK; + if (fcntl(fds[1], F_SETFL, status) < 0) { + Tcl_Panic("Tcl_InitNotifier: could not make trigger pipe non blocking."); + } + + receivePipe = fds[0]; + triggerPipe = fds[1]; + + pthread_attr_init(&attr); + pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM); + pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_JOINABLE); + pthread_attr_setstacksize(&attr, 60 * 1024); + result = pthread_create(¬ifierThread, &attr, + (void * (*)(void *))NotifierThreadProc, NULL); + pthread_attr_destroy(&attr); + if (result) { + Tcl_Panic("Tcl_InitNotifier: unable to start notifier thread."); + } + } + notifierCount++; + UNLOCK_NOTIFIER_INIT; + + return (ClientData) tsdPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FinalizeNotifier -- + * + * This function is called to cleanup the notifier state before a thread + * is terminated. + * + * Results: + * None. + * + * Side effects: + * May terminate the background notifier thread if this is the last + * notifier instance. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_FinalizeNotifier(clientData) + ClientData clientData; /* Not used. */ +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + LOCK_NOTIFIER_INIT; + notifierCount--; + + /* + * If this is the last thread to use the notifier, close the notifier pipe + * and wait for the background thread to terminate. + */ + + if (notifierCount == 0) { + int result; + + if (triggerPipe < 0) { + Tcl_Panic("Tcl_FinalizeNotifier: notifier pipe not initialized."); + } + + /* + * Send "q" message to the notifier thread so that it will terminate. + * The notifier will return from its call to select() and notice that + * a "q" message has arrived, it will then close its side of the pipe + * and terminate its thread. Note the we can not just close the pipe + * and check for EOF in the notifier thread because if a background + * child process was created with exec, select() would not register + * the EOF on the pipe until the child processes had terminated. [Bug: + * 4139] + */ + + write(triggerPipe, "q", 1); + close(triggerPipe); + + result = pthread_join(notifierThread, NULL); + if (result) { + Tcl_Panic("Tcl_FinalizeNotifier: unable to join notifier thread."); + } + + close(receivePipe); + triggerPipe = -1; + } + UNLOCK_NOTIFIER_INIT; + + LOCK_NOTIFIER; /* for concurrency with Tcl_AlertNotifier */ + if (tsdPtr->runLoop) { + tsdPtr->runLoop = NULL; + + /* + * Remove runLoopSource from all CFRunLoops and release it. + */ + + CFRunLoopSourceInvalidate(tsdPtr->runLoopSource); + CFRelease(tsdPtr->runLoopSource); + tsdPtr->runLoopSource = NULL; + } + UNLOCK_NOTIFIER; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AlertNotifier -- + * + * Wake up the specified notifier from any thread. This routine is called + * by the platform independent notifier code whenever the Tcl_ThreadAlert + * routine is called. This routine is guaranteed not to be called on a + * given notifier after Tcl_FinalizeNotifier is called for that notifier. + * + * Results: + * None. + * + * Side effects: + * Signals the notifier condition variable for the specified notifier. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AlertNotifier(clientData) + ClientData clientData; +{ + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; + + LOCK_NOTIFIER; + if (tsdPtr->runLoop) { + tsdPtr->eventReady = 1; + CFRunLoopSourceSignal(tsdPtr->runLoopSource); + CFRunLoopWakeUp(tsdPtr->runLoop); + } + UNLOCK_NOTIFIER; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetTimer -- + * + * This function sets the current notifier timer value. This interface is + * not implemented in this notifier because we are always running inside + * of Tcl_DoOneEvent. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetTimer(timePtr) + Tcl_Time *timePtr; /* Timeout value, may be NULL. */ +{ + /* + * The interval timer doesn't do anything in this implementation, because + * the only event loop is via Tcl_DoOneEvent, which passes timeout values + * to Tcl_WaitForEvent. + */ + + if (tclStubs.tcl_SetTimer != tclOriginalNotifier.setTimerProc) { + tclStubs.tcl_SetTimer(timePtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ServiceModeHook -- + * + * This function is invoked whenever the service mode changes. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_ServiceModeHook(mode) + int mode; /* Either TCL_SERVICE_ALL, or + * TCL_SERVICE_NONE. */ +{ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateFileHandler -- + * + * This function registers a file handler with the select notifier. + * + * Results: + * None. + * + * Side effects: + * Creates a new file handler structure. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CreateFileHandler(fd, mask, proc, clientData) + int fd; /* Handle of stream to watch. */ + int mask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION: indicates + * conditions under which proc should be + * called. */ + Tcl_FileProc *proc; /* Function to call for each + * selected event. */ + ClientData clientData; /* Arbitrary data to pass to proc. */ +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + FileHandler *filePtr; + + if (tclStubs.tcl_CreateFileHandler != + tclOriginalNotifier.createFileHandlerProc) { + tclStubs.tcl_CreateFileHandler(fd, mask, proc, clientData); + return; + } + + for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL; + filePtr = filePtr->nextPtr) { + if (filePtr->fd == fd) { + break; + } + } + if (filePtr == NULL) { + filePtr = (FileHandler*) ckalloc(sizeof(FileHandler)); + filePtr->fd = fd; + filePtr->readyMask = 0; + filePtr->nextPtr = tsdPtr->firstFileHandlerPtr; + tsdPtr->firstFileHandlerPtr = filePtr; + } + filePtr->proc = proc; + filePtr->clientData = clientData; + filePtr->mask = mask; + + /* + * Update the check masks for this file. + */ + + if (mask & TCL_READABLE) { + FD_SET(fd, &(tsdPtr->checkMasks.readable)); + } else { + FD_CLR(fd, &(tsdPtr->checkMasks.readable)); + } + if (mask & TCL_WRITABLE) { + FD_SET(fd, &(tsdPtr->checkMasks.writable)); + } else { + FD_CLR(fd, &(tsdPtr->checkMasks.writable)); + } + if (mask & TCL_EXCEPTION) { + FD_SET(fd, &(tsdPtr->checkMasks.exceptional)); + } else { + FD_CLR(fd, &(tsdPtr->checkMasks.exceptional)); + } + if (tsdPtr->numFdBits <= fd) { + tsdPtr->numFdBits = fd+1; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteFileHandler -- + * + * Cancel a previously-arranged callback arrangement for a file. + * + * Results: + * None. + * + * Side effects: + * If a callback was previously registered on file, remove it. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteFileHandler(fd) + int fd; /* Stream id for which to remove callback + * function. */ +{ + FileHandler *filePtr, *prevPtr; + int i; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (tclStubs.tcl_DeleteFileHandler != + tclOriginalNotifier.deleteFileHandlerProc) { + tclStubs.tcl_DeleteFileHandler(fd); + return; + } + + /* + * Find the entry for the given file (and return if there isn't one). + */ + + for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ; + prevPtr = filePtr, filePtr = filePtr->nextPtr) { + if (filePtr == NULL) { + return; + } + if (filePtr->fd == fd) { + break; + } + } + + /* + * Update the check masks for this file. + */ + + if (filePtr->mask & TCL_READABLE) { + FD_CLR(fd, &(tsdPtr->checkMasks.readable)); + } + if (filePtr->mask & TCL_WRITABLE) { + FD_CLR(fd, &(tsdPtr->checkMasks.writable)); + } + if (filePtr->mask & TCL_EXCEPTION) { + FD_CLR(fd, &(tsdPtr->checkMasks.exceptional)); + } + + /* + * Find current max fd. + */ + + if (fd+1 == tsdPtr->numFdBits) { + tsdPtr->numFdBits = 0; + for (i = fd-1; i >= 0; i--) { + if (FD_ISSET(i, &(tsdPtr->checkMasks.readable)) + || FD_ISSET(i, &(tsdPtr->checkMasks.writable)) + || FD_ISSET(i, &(tsdPtr->checkMasks.exceptional))) { + tsdPtr->numFdBits = i+1; + break; + } + } + } + + /* + * Clean up information in the callback record. + */ + + if (prevPtr == NULL) { + tsdPtr->firstFileHandlerPtr = filePtr->nextPtr; + } else { + prevPtr->nextPtr = filePtr->nextPtr; + } + ckfree((char *) filePtr); +} + +/* + *---------------------------------------------------------------------- + * + * FileHandlerEventProc -- + * + * This function is called by Tcl_ServiceEvent when a file event reaches + * the front of the event queue. This function is responsible for + * actually handling the event by invoking the callback for the file + * handler. + * + * Results: + * Returns 1 if the event was handled, meaning it should be removed from + * the queue. Returns 0 if the event was not handled, meaning it should + * stay on the queue. The only time the event isn't handled is if the + * TCL_FILE_EVENTS flag bit isn't set. + * + * Side effects: + * Whatever the file handler's callback function does. + * + *---------------------------------------------------------------------- + */ + +static int +FileHandlerEventProc(evPtr, flags) + Tcl_Event *evPtr; /* Event to service. */ + int flags; /* Flags that indicate what events to handle, + * such as TCL_FILE_EVENTS. */ +{ + int mask; + FileHandler *filePtr; + FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr; + ThreadSpecificData *tsdPtr; + + if (!(flags & TCL_FILE_EVENTS)) { + return 0; + } + + /* + * Search through the file handlers to find the one whose handle matches + * the event. We do this rather than keeping a pointer to the file handler + * directly in the event, so that the handler can be deleted while the + * event is queued without leaving a dangling pointer. + */ + + tsdPtr = TCL_TSD_INIT(&dataKey); + for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL; + filePtr = filePtr->nextPtr) { + if (filePtr->fd != fileEvPtr->fd) { + continue; + } + + /* + * The code is tricky for two reasons: + * 1. The file handler's desired events could have changed since the + * time when the event was queued, so AND the ready mask with the + * desired mask. + * 2. The file could have been closed and re-opened since the time + * when the event was queued. This is why the ready mask is stored + * in the file handler rather than the queued event: it will be + * zeroed when a new file handler is created for the newly opened + * file. + */ + + mask = filePtr->readyMask & filePtr->mask; + filePtr->readyMask = 0; + if (mask != 0) { + (*filePtr->proc)(filePtr->clientData, mask); + } + break; + } + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_WaitForEvent -- + * + * This function is called by Tcl_DoOneEvent to wait for new events on + * the message queue. If the block time is 0, then Tcl_WaitForEvent just + * polls without blocking. + * + * Results: + * Returns -1 if the select would block forever, otherwise returns 0. + * + * Side effects: + * Queues file events that are detected by the select. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_WaitForEvent(timePtr) + Tcl_Time *timePtr; /* Maximum block time, or NULL. */ +{ + FileHandler *filePtr; + FileHandlerEvent *fileEvPtr; + int mask; + Tcl_Time myTime; + int waitForFiles; + Tcl_Time *myTimePtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (tclStubs.tcl_WaitForEvent != tclOriginalNotifier.waitForEventProc) { + return tclStubs.tcl_WaitForEvent(timePtr); + } + + if (timePtr != NULL) { + /* + * TIP #233 (Virtualized Time). Is virtual time in effect? And do we + * actually have something to scale? If yes to both then we call the + * handler to do this scaling. + */ + + myTime.sec = timePtr->sec; + myTime.usec = timePtr->usec; + + if (myTime.sec != 0 || myTime.usec != 0) { + (*tclScaleTimeProcPtr) (&myTime, tclTimeClientData); + } + + myTimePtr = &myTime; + } else { + myTimePtr = NULL; + } + + /* + * Place this thread on the list of interested threads, signal the + * notifier thread, and wait for a response or a timeout. + */ + + LOCK_NOTIFIER; + + waitForFiles = (tsdPtr->numFdBits > 0); + if (myTimePtr != NULL && myTimePtr->sec == 0 && myTimePtr->usec == 0) { + /* + * Cannot emulate a polling select with a polling condition variable. + * Instead, pretend to wait for files and tell the notifier thread + * what we are doing. The notifier thread makes sure it goes through + * select with its select mask in the same state as ours currently is. + * We block until that happens. + */ + + waitForFiles = 1; + tsdPtr->pollState = POLL_WANT; + myTimePtr = NULL; + } else { + tsdPtr->pollState = 0; + } + + if (waitForFiles) { + /* + * Add the ThreadSpecificData structure of this thread to the list of + * ThreadSpecificData structures of all threads that are waiting on + * file events. + */ + + tsdPtr->nextPtr = waitingListPtr; + if (waitingListPtr) { + waitingListPtr->prevPtr = tsdPtr; + } + tsdPtr->prevPtr = 0; + waitingListPtr = tsdPtr; + tsdPtr->onList = 1; + + write(triggerPipe, "", 1); + } + + FD_ZERO(&(tsdPtr->readyMasks.readable)); + FD_ZERO(&(tsdPtr->readyMasks.writable)); + FD_ZERO(&(tsdPtr->readyMasks.exceptional)); + + if (!tsdPtr->eventReady) { + CFTimeInterval waitTime; + + if (myTimePtr == NULL) { + waitTime = 1.0e10; /* Wait forever, as per CFRunLoop.c */ + } else { + waitTime = myTimePtr->sec + 1.0e-6 * myTimePtr->usec; + } + UNLOCK_NOTIFIER; + CFRunLoopRunInMode(kCFRunLoopDefaultMode, waitTime, TRUE); + LOCK_NOTIFIER; + } + tsdPtr->eventReady = 0; + + if (waitForFiles && tsdPtr->onList) { + /* + * Remove the ThreadSpecificData structure of this thread from the + * waiting list. Alert the notifier thread to recompute its select + * masks - skipping this caused a hang when trying to close a pipe + * which the notifier thread was still doing a select on. + */ + + if (tsdPtr->prevPtr) { + tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; + } else { + waitingListPtr = tsdPtr->nextPtr; + } + if (tsdPtr->nextPtr) { + tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; + } + tsdPtr->nextPtr = tsdPtr->prevPtr = NULL; + tsdPtr->onList = 0; + write(triggerPipe, "", 1); + } + + /* + * Queue all detected file events before returning. + */ + + for (filePtr = tsdPtr->firstFileHandlerPtr; (filePtr != NULL); + filePtr = filePtr->nextPtr) { + + mask = 0; + if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.readable))) { + mask |= TCL_READABLE; + } + if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.writable))) { + mask |= TCL_WRITABLE; + } + if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.exceptional))) { + mask |= TCL_EXCEPTION; + } + + if (!mask) { + continue; + } + + /* + * Don't bother to queue an event if the mask was previously non-zero + * since an event must still be on the queue. + */ + + if (filePtr->readyMask == 0) { + fileEvPtr = (FileHandlerEvent *) ckalloc(sizeof(FileHandlerEvent)); + fileEvPtr->header.proc = FileHandlerEventProc; + fileEvPtr->fd = filePtr->fd; + Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); + } + filePtr->readyMask = mask; + } + UNLOCK_NOTIFIER; + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * NotifierThreadProc -- + * + * This routine is the initial (and only) function executed by the + * special notifier thread. Its job is to wait for file descriptors to + * become readable or writable or to have an exception condition and then + * to notify other threads who are interested in this information by + * signalling a condition variable. Other threads can signal this + * notifier thread of a change in their interests by writing a single + * byte to a special pipe that the notifier thread is monitoring. + * + * Result: + * None. Once started, this routine never exits. It dies with the overall + * process. + * + * Side effects: + * The trigger pipe used to signal the notifier thread is created when + * the notifier thread first starts. + * + *---------------------------------------------------------------------- + */ + +static void +NotifierThreadProc(clientData) + ClientData clientData; /* Not used. */ +{ + ThreadSpecificData *tsdPtr; + fd_set readableMask; + fd_set writableMask; + fd_set exceptionalMask; + int i, numFdBits = 0; + long found; + struct timeval poll = {0., 0.}, *timePtr; + char buf[2]; + + /* + * Look for file events and report them to interested threads. + */ + + while (1) { + FD_ZERO(&readableMask); + FD_ZERO(&writableMask); + FD_ZERO(&exceptionalMask); + + /* + * Compute the logical OR of the select masks from all the waiting + * notifiers. + */ + + LOCK_NOTIFIER; + timePtr = NULL; + for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) { + for (i = tsdPtr->numFdBits-1; i >= 0; --i) { + if (FD_ISSET(i, &(tsdPtr->checkMasks.readable))) { + FD_SET(i, &readableMask); + } + if (FD_ISSET(i, &(tsdPtr->checkMasks.writable))) { + FD_SET(i, &writableMask); + } + if (FD_ISSET(i, &(tsdPtr->checkMasks.exceptional))) { + FD_SET(i, &exceptionalMask); + } + } + if (tsdPtr->numFdBits > numFdBits) { + numFdBits = tsdPtr->numFdBits; + } + if (tsdPtr->pollState & POLL_WANT) { + /* + * Here we make sure we go through select() with the same mask + * bits that were present when the thread tried to poll. + */ + + tsdPtr->pollState |= POLL_DONE; + timePtr = &poll; + } + } + UNLOCK_NOTIFIER; + + /* + * Set up the select mask to include the receive pipe. + */ + + if (receivePipe >= numFdBits) { + numFdBits = receivePipe + 1; + } + FD_SET(receivePipe, &readableMask); + + if (select(numFdBits, &readableMask, &writableMask, &exceptionalMask, + timePtr) == -1) { + /* + * Try again immediately on an error. + */ + + continue; + } + + /* + * Alert any threads that are waiting on a ready file descriptor. + */ + + LOCK_NOTIFIER; + for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) { + found = 0; + + for (i = tsdPtr->numFdBits-1; i >= 0; --i) { + if (FD_ISSET(i, &(tsdPtr->checkMasks.readable)) + && FD_ISSET(i, &readableMask)) { + FD_SET(i, &(tsdPtr->readyMasks.readable)); + found = 1; + } + if (FD_ISSET(i, &(tsdPtr->checkMasks.writable)) + && FD_ISSET(i, &writableMask)) { + FD_SET(i, &(tsdPtr->readyMasks.writable)); + found = 1; + } + if (FD_ISSET(i, &(tsdPtr->checkMasks.exceptional)) + && FD_ISSET(i, &exceptionalMask)) { + FD_SET(i, &(tsdPtr->readyMasks.exceptional)); + found = 1; + } + } + + if (found || (tsdPtr->pollState & POLL_DONE)) { + tsdPtr->eventReady = 1; + if (tsdPtr->onList) { + /* + * Remove the ThreadSpecificData structure of this thread + * from the waiting list. This prevents us from + * continuously spining on select until the other threads + * runs and services the file event. + */ + + if (tsdPtr->prevPtr) { + tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; + } else { + waitingListPtr = tsdPtr->nextPtr; + } + if (tsdPtr->nextPtr) { + tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; + } + tsdPtr->nextPtr = tsdPtr->prevPtr = NULL; + tsdPtr->onList = 0; + tsdPtr->pollState = 0; + } + if (tsdPtr->runLoop) { + CFRunLoopSourceSignal(tsdPtr->runLoopSource); + CFRunLoopWakeUp(tsdPtr->runLoop); + } + } + } + UNLOCK_NOTIFIER; + + /* + * Consume the next byte from the notifier pipe if the pipe was + * readable. Note that there may be multiple bytes pending, but to + * avoid a race condition we only read one at a time. + */ + + if (FD_ISSET(receivePipe, &readableMask)) { + i = read(receivePipe, buf, 1); + + if ((i == 0) || ((i == 1) && (buf[0] == 'q'))) { + /* + * Someone closed the write end of the pipe or sent us a Quit + * message [Bug: 4139] and then closed the write end of the + * pipe so we need to shut down the notifier thread. + */ + + break; + } + } + } + pthread_exit (0); +} +#endif /* HAVE_COREFOUNDATION */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: tests/appendComp.test ================================================================== --- tests/appendComp.test +++ tests/appendComp.test @@ -9,11 +9,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: appendComp.test,v 1.7 2004/09/22 03:19:52 dgp Exp $ +# RCS: @(#) $Id: appendComp.test,v 1.7.2.1 2005/05/05 17:56:14 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -349,11 +349,11 @@ info exists ::result } bar } {0} -test appendComp-8.1 {TCL_OUT_LINE_COMPILE, not TCL_ERROR} -setup { +test appendComp-8.1 {defer error to runtime} -setup { interp create slave } -body { slave eval { proc foo {} { proc append args {} Index: tests/basic.test ================================================================== --- tests/basic.test +++ tests/basic.test @@ -13,11 +13,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: basic.test,v 1.36 2004/11/18 19:22:12 dgp Exp $ +# RCS: @(#) $Id: basic.test,v 1.36.2.2 2005/04/10 23:14:58 kennykb Exp $ # package require tcltest 2 namespace import -force ::tcltest::* @@ -435,10 +435,47 @@ } -cleanup { removeFile test1 interp bgerror {} $handler rename myHandler {} } -result "foo\n while executing\n\"error foo\"" + +test basic-26.2 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} { + # + # Follow the pure-list branch in a manner that + # a - the pure-list internal rep is destroyed by shimmering + # b - the command returns an error + # As the error code in Tcl_EvalObjv accesses the list elements, this will + # cause a segfault if [Bug 1119369] has not been fixed. + # NOTE: a MEM_DEBUG build may be necessary to guarantee the segfault. + # + + set SRC [list foo 1] ;# pure-list command + proc foo str { + # Shimmer pure-list to cmdName, cleanup and error + proc $::SRC {} {}; $::SRC + error "BAD CALL" + } + catch {eval $SRC} +} 1 + +test basic-26.3 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} { + # + # Follow the pure-list branch in a manner that + # a - the pure-list internal rep is destroyed by shimmering + # b - the command accesses its command line + # This will cause a segfault if [Bug 1119369] has not been fixed. + # NOTE: a MEM_DEBUG build may be necessary to guarantee the segfault. + # + + set SRC [list foo 1] ;# pure-list command + proc foo str { + # Shimmer pure-list to cmdName, cleanup and error + proc $::SRC {} {}; $::SRC + info level 0 + } + catch {eval $SRC} +} 0 test basic-27.1 {Tcl_ExprLong} {emptyTest} { } {} test basic-28.1 {Tcl_ExprDouble} {emptyTest} { @@ -565,13 +602,11 @@ } -body { exec [interpreter] $fName } -cleanup { removeFile BREAKtest } -returnCodes error -match glob -result {invoked "break" outside of a loop - while executing -"break" - invoked from within + while executing* "foo \[set a 1] \[break]" (file "*BREAKtest" line 2)} test basic-46.5 {Tcl_AllowExceptions: exception return not allowed} -setup { set fName [makeFile { Index: tests/binary.test ================================================================== --- tests/binary.test +++ tests/binary.test @@ -8,11 +8,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # 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.18 2004/06/23 15:36:55 dkf Exp $ +# RCS: @(#) $Id: binary.test,v 1.18.2.10 2005/10/08 13:44:38 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } @@ -511,13 +511,10 @@ binary format d2 {1.6 3.4 5.6} } \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 test binary-14.11 {Tcl_BinaryObjCmd: format} littleEndian { binary format d2 {1.6 3.4 5.6} } \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 -test binary-14.12 {Tcl_BinaryObjCmd: float overflow} {nonPortable bigEndian} { - binary format d NaN -} \x7f\xff\xff\xff\xff\xff\xff\xff test binary-14.14 {Tcl_BinaryObjCmd: format} { list [catch {binary format d2 {1.6}} msg] $msg } {1 {number of elements in list does not match count}} test binary-14.15 {Tcl_BinaryObjCmd: format} { set a {1.6 3.4} @@ -529,10 +526,14 @@ } \x3f\xf9\x99\x99\x99\x99\x99\x9a test binary-14.17 {Tcl_BinaryObjCmd: format} littleEndian { set a {1.6 3.4} binary format d1 $a } \x9a\x99\x99\x99\x99\x99\xf9\x3f +test binary-14.18 {FormatNumber: Bug 1116542} { + binary scan [binary format d 1.25] d w + set w +} 1.25 test binary-15.1 {Tcl_BinaryObjCmd: format} { list [catch {binary format ax*a "y" "z"} msg] $msg } {1 {cannot use "*" in format string with "x"}} test binary-15.2 {Tcl_BinaryObjCmd: format} { @@ -1069,31 +1070,31 @@ list [catch {binary scan abc f} msg] $msg } {1 {not enough arguments for all format specifiers}} test binary-31.2 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1} list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f* arg1] $arg1 -} {1 {1.60000002384 3.40000009537}} +} {1 {1.600000023841858 3.4000000953674316}} test binary-31.3 {Tcl_BinaryObjCmd: scan} littleEndian { catch {unset arg1} list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f* arg1] $arg1 -} {1 {1.60000002384 3.40000009537}} +} {1 {1.600000023841858 3.4000000953674316}} test binary-31.4 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1} list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f arg1] $arg1 -} {1 1.60000002384} +} {1 1.600000023841858} test binary-31.5 {Tcl_BinaryObjCmd: scan} littleEndian { catch {unset arg1} list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f arg1] $arg1 -} {1 1.60000002384} +} {1 1.600000023841858} test binary-31.6 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1} list [binary scan \x3f\xcc\xcc\xcd f1 arg1] $arg1 -} {1 1.60000002384} +} {1 1.600000023841858} test binary-31.7 {Tcl_BinaryObjCmd: scan} littleEndian { catch {unset arg1} list [binary scan \xcd\xcc\xcc\x3f f1 arg1] $arg1 -} {1 1.60000002384} +} {1 1.600000023841858} test binary-31.8 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1} list [binary scan \x3f\xcc\xcc\xcd f0 arg1] $arg1 } {1 {}} test binary-31.9 {Tcl_BinaryObjCmd: scan} littleEndian { @@ -1101,15 +1102,15 @@ list [binary scan \xcd\xcc\xcc\x3f f0 arg1] $arg1 } {1 {}} test binary-31.10 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1} list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f2 arg1] $arg1 -} {1 {1.60000002384 3.40000009537}} +} {1 {1.600000023841858 3.4000000953674316}} test binary-31.11 {Tcl_BinaryObjCmd: scan} littleEndian { catch {unset arg1} list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f2 arg1] $arg1 -} {1 {1.60000002384 3.40000009537}} +} {1 {1.600000023841858 3.4000000953674316}} test binary-31.12 {Tcl_BinaryObjCmd: scan} { catch {unset arg1} set arg1 foo list [binary scan \x52 f1 arg1] $arg1 } {0 foo} @@ -1121,17 +1122,17 @@ test binary-31.14 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1 arg2} set arg1 foo set arg2 bar list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a\x05 f2c* arg1 arg2] $arg1 $arg2 -} {2 {1.60000002384 3.40000009537} 5} +} {2 {1.600000023841858 3.4000000953674316} 5} test binary-31.15 {Tcl_BinaryObjCmd: scan} littleEndian { catch {unset arg1 arg2} set arg1 foo set arg2 bar list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40\x05 f2c* arg1 arg2] $arg1 $arg2 -} {2 {1.60000002384 3.40000009537} 5} +} {2 {1.600000023841858 3.4000000953674316} 5} test binary-32.1 {Tcl_BinaryObjCmd: scan} { list [catch {binary scan abc d} msg] $msg } {1 {not enough arguments for all format specifiers}} test binary-32.2 {Tcl_BinaryObjCmd: scan} bigEndian { @@ -1382,36 +1383,25 @@ test binary-39.5 {ScanNumber: sign extension} { catch {unset arg1} list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 I5 arg1] $arg1 } {1 {16843010 -2130640639 25297153 16876033 16843137}} -test binary-40.1 {ScanNumber: floating point overflow} {nonPortable bigEndian} { - catch {unset arg1} - list [binary scan \xff\xff\xff\xff f1 arg1] $arg1 -} {1 -NaN} -test binary-40.3 {ScanNumber: floating point overflow} {littleEndian win} { - catch {unset arg1} - set result [binary scan \xff\xff\xff\xff f1 arg1] - if {[string equal $arg1 -1.\#QNAN] || [string equal $arg1 -NAN]} { - lappend result success - } else { - lappend result failure $arg1 - } -} {1 success} -test binary-40.4 {ScanNumber: floating point overflow} {nonPortable bigEndian} { - catch {unset arg1} - list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d1 arg1] $arg1 -} {1 -NaN} -test binary-40.6 {ScanNumber: floating point overflow} {littleEndian win} { - catch {unset arg1} - set result [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d1 arg1] - if {[string equal $arg1 -1.\#QNAN] || [string equal $arg1 -NAN]} { - lappend result success - } else { - lappend result failure $arg1 - } -} {1 success} +test binary-40.3 {ScanNumber: NaN} \ + -body { + catch {unset arg1} + list [binary scan \xff\xff\xff\xff f1 arg1] $arg1 + } \ + -match glob \ + -result {1 -NaN*} + +test binary-40.4 {ScanNumber: NaN} \ + -body { + catch {unset arg1} + list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d arg1] $arg1 + } \ + -match glob \ + -result {1 -NaN*} test binary-41.1 {ScanNumber: word alignment} { catch {unset arg1; unset arg2} list [binary scan \x01\x01\x00 c1s1 arg1 arg2] $arg1 $arg2 } {2 1 1} @@ -1428,15 +1418,15 @@ list [binary scan \x01\x00\x00\x00\x01 c1I1 arg1 arg2] $arg1 $arg2 } {2 1 1} test binary-41.5 {ScanNumber: word alignment} bigEndian { catch {unset arg1; unset arg2} list [binary scan \x01\x3f\xcc\xcc\xcd c1f1 arg1 arg2] $arg1 $arg2 -} {2 1 1.60000002384} +} {2 1 1.600000023841858} test binary-41.6 {ScanNumber: word alignment} littleEndian { catch {unset arg1; unset arg2} list [binary scan \x01\xcd\xcc\xcc\x3f c1f1 arg1 arg2] $arg1 $arg2 -} {2 1 1.60000002384} +} {2 1 1.600000023841858} test binary-41.7 {ScanNumber: word alignment} bigEndian { catch {unset arg1; unset arg2} list [binary scan \x01\x3f\xf9\x99\x99\x99\x99\x99\x9a c1d1 arg1 arg2] $arg1 $arg2 } {2 1 1.6} test binary-41.8 {ScanNumber: word alignment} littleEndian { @@ -1690,16 +1680,10 @@ binary format Q2 {1.6 3.4 5.6} } \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 test binary-51.11 {Tcl_BinaryObjCmd: format} {} { binary format q2 {1.6 3.4 5.6} } \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 -test binary-51.12 {Tcl_BinaryObjCmd: float overflow} {nonPortable bigEndian} { - binary format Q NaN -} \x7f\xff\xff\xff\xff\xff\xff\xff -test binary-51.13 {Tcl_BinaryObjCmd: float overflow} {nonPortable mac} { - binary format Q NaN -} \x7f\xf8\x02\xa0\x00\x00\x00\x00 test binary-51.14 {Tcl_BinaryObjCmd: format} { list [catch {binary format q2 {1.6}} msg] $msg } {1 {number of elements in list does not match count}} test binary-51.15 {Tcl_BinaryObjCmd: format} { set a {1.6 3.4} @@ -1937,29 +1921,10 @@ catch {unset arg1 arg2} set arg1 foo set arg2 bar list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 n2c* arg1 arg2] $arg1 $arg2 } {2 {1386435412 16909060} 5} - -# scan m -test binary-60.1 {Tcl_BinaryObjCmd: scan wide int} bigEndian { - binary scan HelloTcl m x - set x -} 5216694956358656876 -test binary-60.2 {Tcl_BinaryObjCmd: scan wide int} littleEndian { - binary scan lcTolleH m x - set x -} 5216694956358656876 -test binary-60.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} littleEndian { - binary scan [binary format w [expr {wide(3) << 31}]] m x - set x -} 6442450944 -test binary-60.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} bigEndian { - binary scan [binary format W [expr {wide(3) << 31}]] m x - set x -} 6442450944 - # scan Q/q test binary-58.1 {Tcl_BinaryObjCmd: scan} { list [catch {binary scan abc q} msg] $msg } {1 {not enough arguments for all format specifiers}} @@ -2031,31 +1996,31 @@ list [catch {binary scan abc r} msg] $msg } {1 {not enough arguments for all format specifiers}} test binary-59.2 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1} list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R* arg1] $arg1 -} {1 {1.60000002384 3.40000009537}} +} {1 {1.600000023841858 3.4000000953674316}} test binary-59.3 {Tcl_BinaryObjCmd: scan} littleEndian { catch {unset arg1} list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r* arg1] $arg1 -} {1 {1.60000002384 3.40000009537}} +} {1 {1.600000023841858 3.4000000953674316}} test binary-59.4 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1} list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R arg1] $arg1 -} {1 1.60000002384} +} {1 1.600000023841858} test binary-59.5 {Tcl_BinaryObjCmd: scan} littleEndian { catch {unset arg1} list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r arg1] $arg1 -} {1 1.60000002384} +} {1 1.600000023841858} test binary-59.6 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1} list [binary scan \x3f\xcc\xcc\xcd R1 arg1] $arg1 -} {1 1.60000002384} +} {1 1.600000023841858} test binary-59.7 {Tcl_BinaryObjCmd: scan} littleEndian { catch {unset arg1} list [binary scan \xcd\xcc\xcc\x3f r1 arg1] $arg1 -} {1 1.60000002384} +} {1 1.600000023841858} test binary-59.8 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1} list [binary scan \x3f\xcc\xcc\xcd R0 arg1] $arg1 } {1 {}} test binary-59.9 {Tcl_BinaryObjCmd: scan} littleEndian { @@ -2063,15 +2028,15 @@ list [binary scan \xcd\xcc\xcc\x3f r0 arg1] $arg1 } {1 {}} test binary-59.10 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1} list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R2 arg1] $arg1 -} {1 {1.60000002384 3.40000009537}} +} {1 {1.600000023841858 3.4000000953674316}} test binary-59.11 {Tcl_BinaryObjCmd: scan} littleEndian { catch {unset arg1} list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r2 arg1] $arg1 -} {1 {1.60000002384 3.40000009537}} +} {1 {1.600000023841858 3.4000000953674316}} test binary-59.12 {Tcl_BinaryObjCmd: scan} { catch {unset arg1} set arg1 foo list [binary scan \x52 r1 arg1] $arg1 } {0 foo} @@ -2083,16 +2048,200 @@ test binary-59.14 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1 arg2} set arg1 foo set arg2 bar list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a\x05 R2c* arg1 arg2] $arg1 $arg2 -} {2 {1.60000002384 3.40000009537} 5} +} {2 {1.600000023841858 3.4000000953674316} 5} test binary-59.15 {Tcl_BinaryObjCmd: scan} littleEndian { catch {unset arg1 arg2} set arg1 foo set arg2 bar list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40\x05 r2c* arg1 arg2] $arg1 $arg2 -} {2 {1.60000002384 3.40000009537} 5} +} {2 {1.600000023841858 3.4000000953674316} 5} + +test binary-60.1 {[binary format] with NaN} -body { + binary scan [binary format dqQfrR NaN NaN NaN NaN NaN NaN] dqQfrR \ + v1 v2 v3 v4 v5 v6 + list $v1 $v2 $v3 $v4 $v5 $v6 +} -match regexp -result {NaN(\([[:xdigit:]]+\))? NaN(\([[:xdigit:]]+\))? NaN(\([[:xdigit:]]+\))? NaN(\([[:xdigit:]]+\))? NaN(\([[:xdigit:]]+\))? NaN(\([[:xdigit:]]+\))?} + +# scan m +test binary-61.1 {Tcl_BinaryObjCmd: scan wide int} bigEndian { + binary scan HelloTcl m x + set x +} 5216694956358656876 +test binary-61.2 {Tcl_BinaryObjCmd: scan wide int} littleEndian { + binary scan lcTolleH m x + set x +} 5216694956358656876 +test binary-61.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} littleEndian { + binary scan [binary format w [expr {wide(3) << 31}]] m x + set x +} 6442450944 +test binary-61.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} bigEndian { + binary scan [binary format W [expr {wide(3) << 31}]] m x + set x +} 6442450944 + +# 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/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 +} 0.24999999999999997 +test binary-65.2 {smallest significand} ieeeFloatingPoint { + binary scan [binary format w 0x3fd0000000000000] q d + set d +} 0.25 +test binary-65.3 {largest significand} ieeeFloatingPoint { + binary scan [binary format w 0x3fdfffffffffffff] q d + set d +} 0.49999999999999994 +test binary-65.4 {smallest significand} ieeeFloatingPoint { + binary scan [binary format w 0x3fe0000000000000] q d + set d +} 0.5 +test binary-65.5 {largest significand} ieeeFloatingPoint { + binary scan [binary format w 0x3fffffffffffffff] q d + set d +} 1.9999999999999998 +test binary-65.6 {smallest significand} ieeeFloatingPoint { + binary scan [binary format w 0x4000000000000000] q d + set d +} 2.0 +test binary-65.7 {smallest significand} ieeeFloatingPoint { + binary scan [binary format w 0x434fffffffffffff] q d + set d +} 18014398509481982.0 +test binary-65.8 {largest significand} ieeeFloatingPoint { + binary scan [binary format w 0x4350000000000000] q d + set d +} 18014398509481984.0 +test binary-65.8 {largest significand} ieeeFloatingPoint { + binary scan [binary format w 0x4350000000000001] q d + set d +} 18014398509481988.0 # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: ADDED tests/chan.test Index: tests/chan.test ================================================================== --- /dev/null +++ tests/chan.test @@ -0,0 +1,104 @@ +# This file contains a collection of tests for the Tcl built-in 'chan' +# command. Sourcing this file into Tcl runs the tests and generates +# output for errors. No output means no errors were found. +# +# Copyright (c) 2005 Donal K. Fellows +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: chan.test,v 1.4.6.3 2005/08/25 15:46:53 dgp Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* +} + +# +# Note: The tests for the chan methods "create" and "postevent" +# currently reside in the file "ioCmd.test". +# + +test chan-1.1 {chan command general syntax} -body { + chan +} -returnCodes error -result "wrong # args: should be \"chan subcommand ?argument ...?\"" +test chan-1.2 {chan command general syntax} -body { + chan FOOBAR +} -returnCodes error -result "unknown or ambiguous subcommand \"FOOBAR\": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, postevent, puts, read, seek, tell, or truncate" + +test chan-2.1 {chan command: blocked subcommand} -body { + chan blocked foo bar +} -returnCodes error -result "wrong # args: should be \"chan blocked channelId\"" + +test chan-3.1 {chan command: close subcommand} -body { + chan close foo bar +} -returnCodes error -result "wrong # args: should be \"chan close channelId\"" + +test chan-4.1 {chan command: configure subcommand} -body { + chan configure +} -returnCodes error -result "wrong # args: should be \"chan configure channelId ?optionName? ?value? ?optionName value?...\"" + +test chan-5.1 {chan command: copy subcommand} -body { + chan copy foo +} -returnCodes error -result "wrong # args: should be \"chan copy input output ?-size size? ?-command callback?\"" + +test chan-6.1 {chan command: eof subcommand} -body { + chan eof foo bar +} -returnCodes error -result "wrong # args: should be \"chan eof channelId\"" + +test chan-7.1 {chan command: event subcommand} -body { + chan event foo +} -returnCodes error -result "wrong # args: should be \"chan event channelId event ?script?\"" + +test chan-8.1 {chan command: flush subcommand} -body { + chan flush foo bar +} -returnCodes error -result "wrong # args: should be \"chan flush channelId\"" + +test chan-9.1 {chan command: gets subcommand} -body { + chan gets +} -returnCodes error -result "wrong # args: should be \"chan gets channelId ?varName?\"" + +test chan-10.1 {chan command: names subcommand} -body { + chan names foo bar +} -returnCodes error -result "wrong # args: should be \"chan names ?pattern?\"" + +test chan-11.1 {chan command: puts subcommand} -body { + chan puts foo bar foo bar +} -returnCodes error -result "wrong # args: should be \"chan puts ?-nonewline? ?channelId? string\"" + +test chan-12.1 {chan command: read subcommand} -body { + chan read +} -returnCodes error -result "wrong # args: should be \"chan read channelId ?numChars?\" or \"chan read ?-nonewline? channelId\"" + +test chan-13.1 {chan command: seek subcommand} -body { + chan seek foo bar foo bar +} -returnCodes error -result "wrong # args: should be \"chan seek channelId offset ?origin?\"" + +test chan-14.1 {chan command: tell subcommand} -body { + chan tell foo bar +} -returnCodes error -result "wrong # args: should be \"chan tell channelId\"" + +test chan-15.1 {chan command: truncate subcommand} -body { + chan truncate foo bar foo bar +} -returnCodes error -result "wrong \# args: should be \"chan truncate channelId ?length?\"" +test chan-15.2 {chan command: truncate subcommand} -setup { + set file [makeFile {} testTruncate] + set f [open $file w+] + fconfigure $f -translation binary +} -body { + seek $f 0 + puts -nonewline $f 12345 + seek $f 0 + chan truncate $f 2 + read $f +} -result 12 -cleanup { + catch {close $f} + catch {removeFile $file} +} + +cleanupTests +return + +# Local Variables: +# mode: tcl +# End: Index: tests/clock.test ================================================================== --- tests/clock.test +++ tests/clock.test @@ -9,11 +9,11 @@ # Copyright (c) 2004 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: clock.test,v 1.52 2004/11/30 15:45:04 kennykb Exp $ +# RCS: @(#) $Id: clock.test,v 1.52.2.6 2005/10/08 13:44:38 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -40,10 +40,15 @@ } } } package require msgcat 1.4 +::tcltest::testConstraint detroit \ + [expr {![catch {clock format 0 -timezone :America/Detroit -format %z}]}] +::tcltest::testConstraint y2038 \ + [expr {[clock format 2158894800 -format %z -timezone :America/Detroit] eq {-0400}}] + # TEST PLAN # clock-1: # [clock format] - tests of bad and empty arguments # @@ -14772,21 +14777,18 @@ # BEGIN testcases5 # Test formatting of Daylight Saving Time -::tcltest::testConstraint detroit 0 test clock-5.1 {does Detroit exist} { clock format 0 -format {} -timezone :America/Detroit - ::tcltest::testConstraint detroit 1 concat } {} test clock-5.2 {does Detroit have a Y2038 problem} detroit { if { [clock format 2158894800 -format %z -timezone :America/Detroit] ne {-0400} } { concat {y2038 problem} } else { - ::tcltest::testConstraint y2038 1 concat {ok} } } ok test clock-5.3 {time zone boundary case 1904-12-31 23:59:59} detroit { clock format -2051202470 -format {%H:%M:%S %z %Z} \ @@ -15758,2240 +15760,2240 @@ } {01:00:00 -0500 EST} test clock-5.245 {time zone boundary case 2006-10-29 01:00:01} detroit { clock format 1162101601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} -test clock-5.246 {time zone boundary case 2007-04-01 01:59:59} detroit { - clock format 1175410799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.247 {time zone boundary case 2007-04-01 03:00:00} detroit { - clock format 1175410800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.248 {time zone boundary case 2007-04-01 03:00:01} detroit { - clock format 1175410801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.249 {time zone boundary case 2007-10-28 01:59:59} detroit { - clock format 1193551199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.250 {time zone boundary case 2007-10-28 01:00:00} detroit { - clock format 1193551200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.251 {time zone boundary case 2007-10-28 01:00:01} detroit { - clock format 1193551201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.252 {time zone boundary case 2008-04-06 01:59:59} detroit { - clock format 1207465199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.253 {time zone boundary case 2008-04-06 03:00:00} detroit { - clock format 1207465200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.254 {time zone boundary case 2008-04-06 03:00:01} detroit { - clock format 1207465201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.255 {time zone boundary case 2008-10-26 01:59:59} detroit { - clock format 1225000799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.256 {time zone boundary case 2008-10-26 01:00:00} detroit { - clock format 1225000800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.257 {time zone boundary case 2008-10-26 01:00:01} detroit { - clock format 1225000801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.258 {time zone boundary case 2009-04-05 01:59:59} detroit { - clock format 1238914799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.259 {time zone boundary case 2009-04-05 03:00:00} detroit { - clock format 1238914800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.260 {time zone boundary case 2009-04-05 03:00:01} detroit { - clock format 1238914801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.261 {time zone boundary case 2009-10-25 01:59:59} detroit { - clock format 1256450399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.262 {time zone boundary case 2009-10-25 01:00:00} detroit { - clock format 1256450400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.263 {time zone boundary case 2009-10-25 01:00:01} detroit { - clock format 1256450401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.264 {time zone boundary case 2010-04-04 01:59:59} detroit { - clock format 1270364399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.265 {time zone boundary case 2010-04-04 03:00:00} detroit { - clock format 1270364400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.266 {time zone boundary case 2010-04-04 03:00:01} detroit { - clock format 1270364401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.267 {time zone boundary case 2010-10-31 01:59:59} detroit { - clock format 1288504799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.268 {time zone boundary case 2010-10-31 01:00:00} detroit { - clock format 1288504800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.269 {time zone boundary case 2010-10-31 01:00:01} detroit { - clock format 1288504801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.270 {time zone boundary case 2011-04-03 01:59:59} detroit { - clock format 1301813999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.271 {time zone boundary case 2011-04-03 03:00:00} detroit { - clock format 1301814000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.272 {time zone boundary case 2011-04-03 03:00:01} detroit { - clock format 1301814001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.273 {time zone boundary case 2011-10-30 01:59:59} detroit { - clock format 1319954399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.274 {time zone boundary case 2011-10-30 01:00:00} detroit { - clock format 1319954400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.275 {time zone boundary case 2011-10-30 01:00:01} detroit { - clock format 1319954401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.276 {time zone boundary case 2012-04-01 01:59:59} detroit { - clock format 1333263599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.277 {time zone boundary case 2012-04-01 03:00:00} detroit { - clock format 1333263600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.278 {time zone boundary case 2012-04-01 03:00:01} detroit { - clock format 1333263601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.279 {time zone boundary case 2012-10-28 01:59:59} detroit { - clock format 1351403999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.280 {time zone boundary case 2012-10-28 01:00:00} detroit { - clock format 1351404000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.281 {time zone boundary case 2012-10-28 01:00:01} detroit { - clock format 1351404001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.282 {time zone boundary case 2013-04-07 01:59:59} detroit { - clock format 1365317999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.283 {time zone boundary case 2013-04-07 03:00:00} detroit { - clock format 1365318000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.284 {time zone boundary case 2013-04-07 03:00:01} detroit { - clock format 1365318001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.285 {time zone boundary case 2013-10-27 01:59:59} detroit { - clock format 1382853599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.286 {time zone boundary case 2013-10-27 01:00:00} detroit { - clock format 1382853600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.287 {time zone boundary case 2013-10-27 01:00:01} detroit { - clock format 1382853601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.288 {time zone boundary case 2014-04-06 01:59:59} detroit { - clock format 1396767599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.289 {time zone boundary case 2014-04-06 03:00:00} detroit { - clock format 1396767600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.290 {time zone boundary case 2014-04-06 03:00:01} detroit { - clock format 1396767601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.291 {time zone boundary case 2014-10-26 01:59:59} detroit { - clock format 1414303199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.292 {time zone boundary case 2014-10-26 01:00:00} detroit { - clock format 1414303200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.293 {time zone boundary case 2014-10-26 01:00:01} detroit { - clock format 1414303201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.294 {time zone boundary case 2015-04-05 01:59:59} detroit { - clock format 1428217199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.295 {time zone boundary case 2015-04-05 03:00:00} detroit { - clock format 1428217200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.296 {time zone boundary case 2015-04-05 03:00:01} detroit { - clock format 1428217201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.297 {time zone boundary case 2015-10-25 01:59:59} detroit { - clock format 1445752799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.298 {time zone boundary case 2015-10-25 01:00:00} detroit { - clock format 1445752800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.299 {time zone boundary case 2015-10-25 01:00:01} detroit { - clock format 1445752801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.300 {time zone boundary case 2016-04-03 01:59:59} detroit { - clock format 1459666799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.301 {time zone boundary case 2016-04-03 03:00:00} detroit { - clock format 1459666800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.302 {time zone boundary case 2016-04-03 03:00:01} detroit { - clock format 1459666801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.303 {time zone boundary case 2016-10-30 01:59:59} detroit { - clock format 1477807199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.304 {time zone boundary case 2016-10-30 01:00:00} detroit { - clock format 1477807200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.305 {time zone boundary case 2016-10-30 01:00:01} detroit { - clock format 1477807201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.306 {time zone boundary case 2017-04-02 01:59:59} detroit { - clock format 1491116399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.307 {time zone boundary case 2017-04-02 03:00:00} detroit { - clock format 1491116400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.308 {time zone boundary case 2017-04-02 03:00:01} detroit { - clock format 1491116401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.309 {time zone boundary case 2017-10-29 01:59:59} detroit { - clock format 1509256799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.310 {time zone boundary case 2017-10-29 01:00:00} detroit { - clock format 1509256800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.311 {time zone boundary case 2017-10-29 01:00:01} detroit { - clock format 1509256801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.312 {time zone boundary case 2018-04-01 01:59:59} detroit { - clock format 1522565999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.313 {time zone boundary case 2018-04-01 03:00:00} detroit { - clock format 1522566000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.314 {time zone boundary case 2018-04-01 03:00:01} detroit { - clock format 1522566001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.315 {time zone boundary case 2018-10-28 01:59:59} detroit { - clock format 1540706399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.316 {time zone boundary case 2018-10-28 01:00:00} detroit { - clock format 1540706400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.317 {time zone boundary case 2018-10-28 01:00:01} detroit { - clock format 1540706401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.318 {time zone boundary case 2019-04-07 01:59:59} detroit { - clock format 1554620399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.319 {time zone boundary case 2019-04-07 03:00:00} detroit { - clock format 1554620400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.320 {time zone boundary case 2019-04-07 03:00:01} detroit { - clock format 1554620401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.321 {time zone boundary case 2019-10-27 01:59:59} detroit { - clock format 1572155999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.322 {time zone boundary case 2019-10-27 01:00:00} detroit { - clock format 1572156000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.323 {time zone boundary case 2019-10-27 01:00:01} detroit { - clock format 1572156001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.324 {time zone boundary case 2020-04-05 01:59:59} detroit { - clock format 1586069999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.325 {time zone boundary case 2020-04-05 03:00:00} detroit { - clock format 1586070000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.326 {time zone boundary case 2020-04-05 03:00:01} detroit { - clock format 1586070001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.327 {time zone boundary case 2020-10-25 01:59:59} detroit { - clock format 1603605599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.328 {time zone boundary case 2020-10-25 01:00:00} detroit { - clock format 1603605600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.329 {time zone boundary case 2020-10-25 01:00:01} detroit { - clock format 1603605601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.330 {time zone boundary case 2021-04-04 01:59:59} detroit { - clock format 1617519599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.331 {time zone boundary case 2021-04-04 03:00:00} detroit { - clock format 1617519600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.332 {time zone boundary case 2021-04-04 03:00:01} detroit { - clock format 1617519601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.333 {time zone boundary case 2021-10-31 01:59:59} detroit { - clock format 1635659999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.334 {time zone boundary case 2021-10-31 01:00:00} detroit { - clock format 1635660000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.335 {time zone boundary case 2021-10-31 01:00:01} detroit { - clock format 1635660001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.336 {time zone boundary case 2022-04-03 01:59:59} detroit { - clock format 1648969199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.337 {time zone boundary case 2022-04-03 03:00:00} detroit { - clock format 1648969200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.338 {time zone boundary case 2022-04-03 03:00:01} detroit { - clock format 1648969201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.339 {time zone boundary case 2022-10-30 01:59:59} detroit { - clock format 1667109599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.340 {time zone boundary case 2022-10-30 01:00:00} detroit { - clock format 1667109600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.341 {time zone boundary case 2022-10-30 01:00:01} detroit { - clock format 1667109601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.342 {time zone boundary case 2023-04-02 01:59:59} detroit { - clock format 1680418799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.343 {time zone boundary case 2023-04-02 03:00:00} detroit { - clock format 1680418800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.344 {time zone boundary case 2023-04-02 03:00:01} detroit { - clock format 1680418801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.345 {time zone boundary case 2023-10-29 01:59:59} detroit { - clock format 1698559199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.346 {time zone boundary case 2023-10-29 01:00:00} detroit { - clock format 1698559200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.347 {time zone boundary case 2023-10-29 01:00:01} detroit { - clock format 1698559201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.348 {time zone boundary case 2024-04-07 01:59:59} detroit { - clock format 1712473199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.349 {time zone boundary case 2024-04-07 03:00:00} detroit { - clock format 1712473200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.350 {time zone boundary case 2024-04-07 03:00:01} detroit { - clock format 1712473201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.351 {time zone boundary case 2024-10-27 01:59:59} detroit { - clock format 1730008799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.352 {time zone boundary case 2024-10-27 01:00:00} detroit { - clock format 1730008800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.353 {time zone boundary case 2024-10-27 01:00:01} detroit { - clock format 1730008801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.354 {time zone boundary case 2025-04-06 01:59:59} detroit { - clock format 1743922799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.355 {time zone boundary case 2025-04-06 03:00:00} detroit { - clock format 1743922800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.356 {time zone boundary case 2025-04-06 03:00:01} detroit { - clock format 1743922801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.357 {time zone boundary case 2025-10-26 01:59:59} detroit { - clock format 1761458399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.358 {time zone boundary case 2025-10-26 01:00:00} detroit { - clock format 1761458400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.359 {time zone boundary case 2025-10-26 01:00:01} detroit { - clock format 1761458401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.360 {time zone boundary case 2026-04-05 01:59:59} detroit { - clock format 1775372399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.361 {time zone boundary case 2026-04-05 03:00:00} detroit { - clock format 1775372400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.362 {time zone boundary case 2026-04-05 03:00:01} detroit { - clock format 1775372401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.363 {time zone boundary case 2026-10-25 01:59:59} detroit { - clock format 1792907999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.364 {time zone boundary case 2026-10-25 01:00:00} detroit { - clock format 1792908000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.365 {time zone boundary case 2026-10-25 01:00:01} detroit { - clock format 1792908001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.366 {time zone boundary case 2027-04-04 01:59:59} detroit { - clock format 1806821999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.367 {time zone boundary case 2027-04-04 03:00:00} detroit { - clock format 1806822000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.368 {time zone boundary case 2027-04-04 03:00:01} detroit { - clock format 1806822001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.369 {time zone boundary case 2027-10-31 01:59:59} detroit { - clock format 1824962399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.370 {time zone boundary case 2027-10-31 01:00:00} detroit { - clock format 1824962400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.371 {time zone boundary case 2027-10-31 01:00:01} detroit { - clock format 1824962401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.372 {time zone boundary case 2028-04-02 01:59:59} detroit { - clock format 1838271599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.373 {time zone boundary case 2028-04-02 03:00:00} detroit { - clock format 1838271600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.374 {time zone boundary case 2028-04-02 03:00:01} detroit { - clock format 1838271601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.375 {time zone boundary case 2028-10-29 01:59:59} detroit { - clock format 1856411999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.376 {time zone boundary case 2028-10-29 01:00:00} detroit { - clock format 1856412000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.377 {time zone boundary case 2028-10-29 01:00:01} detroit { - clock format 1856412001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.378 {time zone boundary case 2029-04-01 01:59:59} detroit { - clock format 1869721199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.379 {time zone boundary case 2029-04-01 03:00:00} detroit { - clock format 1869721200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.380 {time zone boundary case 2029-04-01 03:00:01} detroit { - clock format 1869721201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.381 {time zone boundary case 2029-10-28 01:59:59} detroit { - clock format 1887861599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.382 {time zone boundary case 2029-10-28 01:00:00} detroit { - clock format 1887861600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.383 {time zone boundary case 2029-10-28 01:00:01} detroit { - clock format 1887861601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.384 {time zone boundary case 2030-04-07 01:59:59} detroit { - clock format 1901775599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.385 {time zone boundary case 2030-04-07 03:00:00} detroit { - clock format 1901775600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.386 {time zone boundary case 2030-04-07 03:00:01} detroit { - clock format 1901775601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.387 {time zone boundary case 2030-10-27 01:59:59} detroit { - clock format 1919311199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.388 {time zone boundary case 2030-10-27 01:00:00} detroit { - clock format 1919311200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.389 {time zone boundary case 2030-10-27 01:00:01} detroit { - clock format 1919311201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.390 {time zone boundary case 2031-04-06 01:59:59} detroit { - clock format 1933225199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.391 {time zone boundary case 2031-04-06 03:00:00} detroit { - clock format 1933225200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.392 {time zone boundary case 2031-04-06 03:00:01} detroit { - clock format 1933225201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.393 {time zone boundary case 2031-10-26 01:59:59} detroit { - clock format 1950760799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.394 {time zone boundary case 2031-10-26 01:00:00} detroit { - clock format 1950760800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.395 {time zone boundary case 2031-10-26 01:00:01} detroit { - clock format 1950760801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.396 {time zone boundary case 2032-04-04 01:59:59} detroit { - clock format 1964674799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.397 {time zone boundary case 2032-04-04 03:00:00} detroit { - clock format 1964674800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.398 {time zone boundary case 2032-04-04 03:00:01} detroit { - clock format 1964674801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.399 {time zone boundary case 2032-10-31 01:59:59} detroit { - clock format 1982815199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.400 {time zone boundary case 2032-10-31 01:00:00} detroit { - clock format 1982815200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.401 {time zone boundary case 2032-10-31 01:00:01} detroit { - clock format 1982815201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.402 {time zone boundary case 2033-04-03 01:59:59} detroit { - clock format 1996124399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.403 {time zone boundary case 2033-04-03 03:00:00} detroit { - clock format 1996124400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.404 {time zone boundary case 2033-04-03 03:00:01} detroit { - clock format 1996124401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.405 {time zone boundary case 2033-10-30 01:59:59} detroit { - clock format 2014264799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.406 {time zone boundary case 2033-10-30 01:00:00} detroit { - clock format 2014264800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.407 {time zone boundary case 2033-10-30 01:00:01} detroit { - clock format 2014264801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.408 {time zone boundary case 2034-04-02 01:59:59} detroit { - clock format 2027573999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.409 {time zone boundary case 2034-04-02 03:00:00} detroit { - clock format 2027574000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.410 {time zone boundary case 2034-04-02 03:00:01} detroit { - clock format 2027574001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.411 {time zone boundary case 2034-10-29 01:59:59} detroit { - clock format 2045714399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.412 {time zone boundary case 2034-10-29 01:00:00} detroit { - clock format 2045714400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.413 {time zone boundary case 2034-10-29 01:00:01} detroit { - clock format 2045714401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.414 {time zone boundary case 2035-04-01 01:59:59} detroit { - clock format 2059023599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.415 {time zone boundary case 2035-04-01 03:00:00} detroit { - clock format 2059023600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.416 {time zone boundary case 2035-04-01 03:00:01} detroit { - clock format 2059023601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.417 {time zone boundary case 2035-10-28 01:59:59} detroit { - clock format 2077163999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.418 {time zone boundary case 2035-10-28 01:00:00} detroit { - clock format 2077164000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.419 {time zone boundary case 2035-10-28 01:00:01} detroit { - clock format 2077164001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.420 {time zone boundary case 2036-04-06 01:59:59} detroit { - clock format 2091077999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.421 {time zone boundary case 2036-04-06 03:00:00} detroit { - clock format 2091078000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.422 {time zone boundary case 2036-04-06 03:00:01} detroit { - clock format 2091078001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.423 {time zone boundary case 2036-10-26 01:59:59} detroit { - clock format 2108613599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.424 {time zone boundary case 2036-10-26 01:00:00} detroit { - clock format 2108613600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.425 {time zone boundary case 2036-10-26 01:00:01} detroit { - clock format 2108613601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.426 {time zone boundary case 2037-04-05 01:59:59} detroit { - clock format 2122527599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.427 {time zone boundary case 2037-04-05 03:00:00} detroit { - clock format 2122527600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.428 {time zone boundary case 2037-04-05 03:00:01} detroit { - clock format 2122527601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.429 {time zone boundary case 2037-10-25 01:59:59} detroit { - clock format 2140063199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.430 {time zone boundary case 2037-10-25 01:00:00} detroit { - clock format 2140063200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.431 {time zone boundary case 2037-10-25 01:00:01} detroit { - clock format 2140063201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.432 {time zone boundary case 2038-04-04 01:59:59} {detroit y2038} { - clock format 2153977199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.433 {time zone boundary case 2038-04-04 03:00:00} {detroit y2038} { - clock format 2153977200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.434 {time zone boundary case 2038-04-04 03:00:01} {detroit y2038} { - clock format 2153977201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.435 {time zone boundary case 2038-10-31 01:59:59} {detroit y2038} { - clock format 2172117599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.436 {time zone boundary case 2038-10-31 01:00:00} {detroit y2038} { - clock format 2172117600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.437 {time zone boundary case 2038-10-31 01:00:01} {detroit y2038} { - clock format 2172117601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.438 {time zone boundary case 2039-04-03 01:59:59} {detroit y2038} { - clock format 2185426799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.439 {time zone boundary case 2039-04-03 03:00:00} {detroit y2038} { - clock format 2185426800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.440 {time zone boundary case 2039-04-03 03:00:01} {detroit y2038} { - clock format 2185426801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.441 {time zone boundary case 2039-10-30 01:59:59} {detroit y2038} { - clock format 2203567199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.442 {time zone boundary case 2039-10-30 01:00:00} {detroit y2038} { - clock format 2203567200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.443 {time zone boundary case 2039-10-30 01:00:01} {detroit y2038} { - clock format 2203567201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.444 {time zone boundary case 2040-04-01 01:59:59} {detroit y2038} { - clock format 2216876399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.445 {time zone boundary case 2040-04-01 03:00:00} {detroit y2038} { - clock format 2216876400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.446 {time zone boundary case 2040-04-01 03:00:01} {detroit y2038} { - clock format 2216876401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.447 {time zone boundary case 2040-10-28 01:59:59} {detroit y2038} { - clock format 2235016799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.448 {time zone boundary case 2040-10-28 01:00:00} {detroit y2038} { - clock format 2235016800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.449 {time zone boundary case 2040-10-28 01:00:01} {detroit y2038} { - clock format 2235016801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.450 {time zone boundary case 2041-04-07 01:59:59} {detroit y2038} { - clock format 2248930799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.451 {time zone boundary case 2041-04-07 03:00:00} {detroit y2038} { - clock format 2248930800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.452 {time zone boundary case 2041-04-07 03:00:01} {detroit y2038} { - clock format 2248930801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.453 {time zone boundary case 2041-10-27 01:59:59} {detroit y2038} { - clock format 2266466399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.454 {time zone boundary case 2041-10-27 01:00:00} {detroit y2038} { - clock format 2266466400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.455 {time zone boundary case 2041-10-27 01:00:01} {detroit y2038} { - clock format 2266466401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.456 {time zone boundary case 2042-04-06 01:59:59} {detroit y2038} { - clock format 2280380399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.457 {time zone boundary case 2042-04-06 03:00:00} {detroit y2038} { - clock format 2280380400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.458 {time zone boundary case 2042-04-06 03:00:01} {detroit y2038} { - clock format 2280380401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.459 {time zone boundary case 2042-10-26 01:59:59} {detroit y2038} { - clock format 2297915999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.460 {time zone boundary case 2042-10-26 01:00:00} {detroit y2038} { - clock format 2297916000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.461 {time zone boundary case 2042-10-26 01:00:01} {detroit y2038} { - clock format 2297916001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.462 {time zone boundary case 2043-04-05 01:59:59} {detroit y2038} { - clock format 2311829999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.463 {time zone boundary case 2043-04-05 03:00:00} {detroit y2038} { - clock format 2311830000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.464 {time zone boundary case 2043-04-05 03:00:01} {detroit y2038} { - clock format 2311830001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.465 {time zone boundary case 2043-10-25 01:59:59} {detroit y2038} { - clock format 2329365599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.466 {time zone boundary case 2043-10-25 01:00:00} {detroit y2038} { - clock format 2329365600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.467 {time zone boundary case 2043-10-25 01:00:01} {detroit y2038} { - clock format 2329365601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.468 {time zone boundary case 2044-04-03 01:59:59} {detroit y2038} { - clock format 2343279599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.469 {time zone boundary case 2044-04-03 03:00:00} {detroit y2038} { - clock format 2343279600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.470 {time zone boundary case 2044-04-03 03:00:01} {detroit y2038} { - clock format 2343279601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.471 {time zone boundary case 2044-10-30 01:59:59} {detroit y2038} { - clock format 2361419999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.472 {time zone boundary case 2044-10-30 01:00:00} {detroit y2038} { - clock format 2361420000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.473 {time zone boundary case 2044-10-30 01:00:01} {detroit y2038} { - clock format 2361420001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.474 {time zone boundary case 2045-04-02 01:59:59} {detroit y2038} { - clock format 2374729199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.475 {time zone boundary case 2045-04-02 03:00:00} {detroit y2038} { - clock format 2374729200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.476 {time zone boundary case 2045-04-02 03:00:01} {detroit y2038} { - clock format 2374729201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.477 {time zone boundary case 2045-10-29 01:59:59} {detroit y2038} { - clock format 2392869599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.478 {time zone boundary case 2045-10-29 01:00:00} {detroit y2038} { - clock format 2392869600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.479 {time zone boundary case 2045-10-29 01:00:01} {detroit y2038} { - clock format 2392869601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.480 {time zone boundary case 2046-04-01 01:59:59} {detroit y2038} { - clock format 2406178799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.481 {time zone boundary case 2046-04-01 03:00:00} {detroit y2038} { - clock format 2406178800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.482 {time zone boundary case 2046-04-01 03:00:01} {detroit y2038} { - clock format 2406178801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.483 {time zone boundary case 2046-10-28 01:59:59} {detroit y2038} { - clock format 2424319199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.484 {time zone boundary case 2046-10-28 01:00:00} {detroit y2038} { - clock format 2424319200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.485 {time zone boundary case 2046-10-28 01:00:01} {detroit y2038} { - clock format 2424319201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.486 {time zone boundary case 2047-04-07 01:59:59} {detroit y2038} { - clock format 2438233199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.487 {time zone boundary case 2047-04-07 03:00:00} {detroit y2038} { - clock format 2438233200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.488 {time zone boundary case 2047-04-07 03:00:01} {detroit y2038} { - clock format 2438233201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.489 {time zone boundary case 2047-10-27 01:59:59} {detroit y2038} { - clock format 2455768799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.490 {time zone boundary case 2047-10-27 01:00:00} {detroit y2038} { - clock format 2455768800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.491 {time zone boundary case 2047-10-27 01:00:01} {detroit y2038} { - clock format 2455768801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.492 {time zone boundary case 2048-04-05 01:59:59} {detroit y2038} { - clock format 2469682799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.493 {time zone boundary case 2048-04-05 03:00:00} {detroit y2038} { - clock format 2469682800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.494 {time zone boundary case 2048-04-05 03:00:01} {detroit y2038} { - clock format 2469682801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.495 {time zone boundary case 2048-10-25 01:59:59} {detroit y2038} { - clock format 2487218399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.496 {time zone boundary case 2048-10-25 01:00:00} {detroit y2038} { - clock format 2487218400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.497 {time zone boundary case 2048-10-25 01:00:01} {detroit y2038} { - clock format 2487218401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.498 {time zone boundary case 2049-04-04 01:59:59} {detroit y2038} { - clock format 2501132399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.499 {time zone boundary case 2049-04-04 03:00:00} {detroit y2038} { - clock format 2501132400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.500 {time zone boundary case 2049-04-04 03:00:01} {detroit y2038} { - clock format 2501132401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.501 {time zone boundary case 2049-10-31 01:59:59} {detroit y2038} { - clock format 2519272799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.502 {time zone boundary case 2049-10-31 01:00:00} {detroit y2038} { - clock format 2519272800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.503 {time zone boundary case 2049-10-31 01:00:01} {detroit y2038} { - clock format 2519272801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.504 {time zone boundary case 2050-04-03 01:59:59} {detroit y2038} { - clock format 2532581999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.505 {time zone boundary case 2050-04-03 03:00:00} {detroit y2038} { - clock format 2532582000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.506 {time zone boundary case 2050-04-03 03:00:01} {detroit y2038} { - clock format 2532582001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.507 {time zone boundary case 2050-10-30 01:59:59} {detroit y2038} { - clock format 2550722399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.508 {time zone boundary case 2050-10-30 01:00:00} {detroit y2038} { - clock format 2550722400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.509 {time zone boundary case 2050-10-30 01:00:01} {detroit y2038} { - clock format 2550722401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.510 {time zone boundary case 2051-04-02 01:59:59} {detroit y2038} { - clock format 2564031599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.511 {time zone boundary case 2051-04-02 03:00:00} {detroit y2038} { - clock format 2564031600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.512 {time zone boundary case 2051-04-02 03:00:01} {detroit y2038} { - clock format 2564031601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.513 {time zone boundary case 2051-10-29 01:59:59} {detroit y2038} { - clock format 2582171999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.514 {time zone boundary case 2051-10-29 01:00:00} {detroit y2038} { - clock format 2582172000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.515 {time zone boundary case 2051-10-29 01:00:01} {detroit y2038} { - clock format 2582172001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.516 {time zone boundary case 2052-04-07 01:59:59} {detroit y2038} { - clock format 2596085999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.517 {time zone boundary case 2052-04-07 03:00:00} {detroit y2038} { - clock format 2596086000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.518 {time zone boundary case 2052-04-07 03:00:01} {detroit y2038} { - clock format 2596086001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.519 {time zone boundary case 2052-10-27 01:59:59} {detroit y2038} { - clock format 2613621599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.520 {time zone boundary case 2052-10-27 01:00:00} {detroit y2038} { - clock format 2613621600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.521 {time zone boundary case 2052-10-27 01:00:01} {detroit y2038} { - clock format 2613621601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.522 {time zone boundary case 2053-04-06 01:59:59} {detroit y2038} { - clock format 2627535599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.523 {time zone boundary case 2053-04-06 03:00:00} {detroit y2038} { - clock format 2627535600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.524 {time zone boundary case 2053-04-06 03:00:01} {detroit y2038} { - clock format 2627535601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.525 {time zone boundary case 2053-10-26 01:59:59} {detroit y2038} { - clock format 2645071199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.526 {time zone boundary case 2053-10-26 01:00:00} {detroit y2038} { - clock format 2645071200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.527 {time zone boundary case 2053-10-26 01:00:01} {detroit y2038} { - clock format 2645071201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.528 {time zone boundary case 2054-04-05 01:59:59} {detroit y2038} { - clock format 2658985199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.529 {time zone boundary case 2054-04-05 03:00:00} {detroit y2038} { - clock format 2658985200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.530 {time zone boundary case 2054-04-05 03:00:01} {detroit y2038} { - clock format 2658985201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.531 {time zone boundary case 2054-10-25 01:59:59} {detroit y2038} { - clock format 2676520799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.532 {time zone boundary case 2054-10-25 01:00:00} {detroit y2038} { - clock format 2676520800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.533 {time zone boundary case 2054-10-25 01:00:01} {detroit y2038} { - clock format 2676520801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.534 {time zone boundary case 2055-04-04 01:59:59} {detroit y2038} { - clock format 2690434799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.535 {time zone boundary case 2055-04-04 03:00:00} {detroit y2038} { - clock format 2690434800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.536 {time zone boundary case 2055-04-04 03:00:01} {detroit y2038} { - clock format 2690434801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.537 {time zone boundary case 2055-10-31 01:59:59} {detroit y2038} { - clock format 2708575199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.538 {time zone boundary case 2055-10-31 01:00:00} {detroit y2038} { - clock format 2708575200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.539 {time zone boundary case 2055-10-31 01:00:01} {detroit y2038} { - clock format 2708575201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.540 {time zone boundary case 2056-04-02 01:59:59} {detroit y2038} { - clock format 2721884399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.541 {time zone boundary case 2056-04-02 03:00:00} {detroit y2038} { - clock format 2721884400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.542 {time zone boundary case 2056-04-02 03:00:01} {detroit y2038} { - clock format 2721884401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.543 {time zone boundary case 2056-10-29 01:59:59} {detroit y2038} { - clock format 2740024799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.544 {time zone boundary case 2056-10-29 01:00:00} {detroit y2038} { - clock format 2740024800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.545 {time zone boundary case 2056-10-29 01:00:01} {detroit y2038} { - clock format 2740024801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.546 {time zone boundary case 2057-04-01 01:59:59} {detroit y2038} { - clock format 2753333999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.547 {time zone boundary case 2057-04-01 03:00:00} {detroit y2038} { - clock format 2753334000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.548 {time zone boundary case 2057-04-01 03:00:01} {detroit y2038} { - clock format 2753334001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.549 {time zone boundary case 2057-10-28 01:59:59} {detroit y2038} { - clock format 2771474399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.550 {time zone boundary case 2057-10-28 01:00:00} {detroit y2038} { - clock format 2771474400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.551 {time zone boundary case 2057-10-28 01:00:01} {detroit y2038} { - clock format 2771474401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.552 {time zone boundary case 2058-04-07 01:59:59} {detroit y2038} { - clock format 2785388399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.553 {time zone boundary case 2058-04-07 03:00:00} {detroit y2038} { - clock format 2785388400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.554 {time zone boundary case 2058-04-07 03:00:01} {detroit y2038} { - clock format 2785388401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.555 {time zone boundary case 2058-10-27 01:59:59} {detroit y2038} { - clock format 2802923999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.556 {time zone boundary case 2058-10-27 01:00:00} {detroit y2038} { - clock format 2802924000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.557 {time zone boundary case 2058-10-27 01:00:01} {detroit y2038} { - clock format 2802924001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.558 {time zone boundary case 2059-04-06 01:59:59} {detroit y2038} { - clock format 2816837999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.559 {time zone boundary case 2059-04-06 03:00:00} {detroit y2038} { - clock format 2816838000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.560 {time zone boundary case 2059-04-06 03:00:01} {detroit y2038} { - clock format 2816838001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.561 {time zone boundary case 2059-10-26 01:59:59} {detroit y2038} { - clock format 2834373599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.562 {time zone boundary case 2059-10-26 01:00:00} {detroit y2038} { - clock format 2834373600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.563 {time zone boundary case 2059-10-26 01:00:01} {detroit y2038} { - clock format 2834373601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.564 {time zone boundary case 2060-04-04 01:59:59} {detroit y2038} { - clock format 2848287599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.565 {time zone boundary case 2060-04-04 03:00:00} {detroit y2038} { - clock format 2848287600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.566 {time zone boundary case 2060-04-04 03:00:01} {detroit y2038} { - clock format 2848287601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.567 {time zone boundary case 2060-10-31 01:59:59} {detroit y2038} { - clock format 2866427999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.568 {time zone boundary case 2060-10-31 01:00:00} {detroit y2038} { - clock format 2866428000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.569 {time zone boundary case 2060-10-31 01:00:01} {detroit y2038} { - clock format 2866428001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.570 {time zone boundary case 2061-04-03 01:59:59} {detroit y2038} { - clock format 2879737199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.571 {time zone boundary case 2061-04-03 03:00:00} {detroit y2038} { - clock format 2879737200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.572 {time zone boundary case 2061-04-03 03:00:01} {detroit y2038} { - clock format 2879737201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.573 {time zone boundary case 2061-10-30 01:59:59} {detroit y2038} { - clock format 2897877599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.574 {time zone boundary case 2061-10-30 01:00:00} {detroit y2038} { - clock format 2897877600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.575 {time zone boundary case 2061-10-30 01:00:01} {detroit y2038} { - clock format 2897877601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.576 {time zone boundary case 2062-04-02 01:59:59} {detroit y2038} { - clock format 2911186799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.577 {time zone boundary case 2062-04-02 03:00:00} {detroit y2038} { - clock format 2911186800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.578 {time zone boundary case 2062-04-02 03:00:01} {detroit y2038} { - clock format 2911186801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.579 {time zone boundary case 2062-10-29 01:59:59} {detroit y2038} { - clock format 2929327199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.580 {time zone boundary case 2062-10-29 01:00:00} {detroit y2038} { - clock format 2929327200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.581 {time zone boundary case 2062-10-29 01:00:01} {detroit y2038} { - clock format 2929327201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.582 {time zone boundary case 2063-04-01 01:59:59} {detroit y2038} { - clock format 2942636399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.583 {time zone boundary case 2063-04-01 03:00:00} {detroit y2038} { - clock format 2942636400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.584 {time zone boundary case 2063-04-01 03:00:01} {detroit y2038} { - clock format 2942636401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.585 {time zone boundary case 2063-10-28 01:59:59} {detroit y2038} { - clock format 2960776799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.586 {time zone boundary case 2063-10-28 01:00:00} {detroit y2038} { - clock format 2960776800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.587 {time zone boundary case 2063-10-28 01:00:01} {detroit y2038} { - clock format 2960776801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.588 {time zone boundary case 2064-04-06 01:59:59} {detroit y2038} { - clock format 2974690799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.589 {time zone boundary case 2064-04-06 03:00:00} {detroit y2038} { - clock format 2974690800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.590 {time zone boundary case 2064-04-06 03:00:01} {detroit y2038} { - clock format 2974690801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.591 {time zone boundary case 2064-10-26 01:59:59} {detroit y2038} { - clock format 2992226399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.592 {time zone boundary case 2064-10-26 01:00:00} {detroit y2038} { - clock format 2992226400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.593 {time zone boundary case 2064-10-26 01:00:01} {detroit y2038} { - clock format 2992226401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.594 {time zone boundary case 2065-04-05 01:59:59} {detroit y2038} { - clock format 3006140399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.595 {time zone boundary case 2065-04-05 03:00:00} {detroit y2038} { - clock format 3006140400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.596 {time zone boundary case 2065-04-05 03:00:01} {detroit y2038} { - clock format 3006140401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.597 {time zone boundary case 2065-10-25 01:59:59} {detroit y2038} { - clock format 3023675999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.598 {time zone boundary case 2065-10-25 01:00:00} {detroit y2038} { - clock format 3023676000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.599 {time zone boundary case 2065-10-25 01:00:01} {detroit y2038} { - clock format 3023676001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.600 {time zone boundary case 2066-04-04 01:59:59} {detroit y2038} { - clock format 3037589999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.601 {time zone boundary case 2066-04-04 03:00:00} {detroit y2038} { - clock format 3037590000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.602 {time zone boundary case 2066-04-04 03:00:01} {detroit y2038} { - clock format 3037590001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.603 {time zone boundary case 2066-10-31 01:59:59} {detroit y2038} { - clock format 3055730399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.604 {time zone boundary case 2066-10-31 01:00:00} {detroit y2038} { - clock format 3055730400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.605 {time zone boundary case 2066-10-31 01:00:01} {detroit y2038} { - clock format 3055730401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.606 {time zone boundary case 2067-04-03 01:59:59} {detroit y2038} { - clock format 3069039599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.607 {time zone boundary case 2067-04-03 03:00:00} {detroit y2038} { - clock format 3069039600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.608 {time zone boundary case 2067-04-03 03:00:01} {detroit y2038} { - clock format 3069039601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.609 {time zone boundary case 2067-10-30 01:59:59} {detroit y2038} { - clock format 3087179999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.610 {time zone boundary case 2067-10-30 01:00:00} {detroit y2038} { - clock format 3087180000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.611 {time zone boundary case 2067-10-30 01:00:01} {detroit y2038} { - clock format 3087180001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.612 {time zone boundary case 2068-04-01 01:59:59} {detroit y2038} { - clock format 3100489199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.613 {time zone boundary case 2068-04-01 03:00:00} {detroit y2038} { - clock format 3100489200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.614 {time zone boundary case 2068-04-01 03:00:01} {detroit y2038} { - clock format 3100489201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.615 {time zone boundary case 2068-10-28 01:59:59} {detroit y2038} { - clock format 3118629599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.616 {time zone boundary case 2068-10-28 01:00:00} {detroit y2038} { - clock format 3118629600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.617 {time zone boundary case 2068-10-28 01:00:01} {detroit y2038} { - clock format 3118629601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.618 {time zone boundary case 2069-04-07 01:59:59} {detroit y2038} { - clock format 3132543599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.619 {time zone boundary case 2069-04-07 03:00:00} {detroit y2038} { - clock format 3132543600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.620 {time zone boundary case 2069-04-07 03:00:01} {detroit y2038} { - clock format 3132543601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.621 {time zone boundary case 2069-10-27 01:59:59} {detroit y2038} { - clock format 3150079199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.622 {time zone boundary case 2069-10-27 01:00:00} {detroit y2038} { - clock format 3150079200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.623 {time zone boundary case 2069-10-27 01:00:01} {detroit y2038} { - clock format 3150079201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.624 {time zone boundary case 2070-04-06 01:59:59} {detroit y2038} { - clock format 3163993199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.625 {time zone boundary case 2070-04-06 03:00:00} {detroit y2038} { - clock format 3163993200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.626 {time zone boundary case 2070-04-06 03:00:01} {detroit y2038} { - clock format 3163993201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.627 {time zone boundary case 2070-10-26 01:59:59} {detroit y2038} { - clock format 3181528799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.628 {time zone boundary case 2070-10-26 01:00:00} {detroit y2038} { - clock format 3181528800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.629 {time zone boundary case 2070-10-26 01:00:01} {detroit y2038} { - clock format 3181528801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.630 {time zone boundary case 2071-04-05 01:59:59} {detroit y2038} { - clock format 3195442799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.631 {time zone boundary case 2071-04-05 03:00:00} {detroit y2038} { - clock format 3195442800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.632 {time zone boundary case 2071-04-05 03:00:01} {detroit y2038} { - clock format 3195442801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.633 {time zone boundary case 2071-10-25 01:59:59} {detroit y2038} { - clock format 3212978399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.634 {time zone boundary case 2071-10-25 01:00:00} {detroit y2038} { - clock format 3212978400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.635 {time zone boundary case 2071-10-25 01:00:01} {detroit y2038} { - clock format 3212978401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.636 {time zone boundary case 2072-04-03 01:59:59} {detroit y2038} { - clock format 3226892399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.637 {time zone boundary case 2072-04-03 03:00:00} {detroit y2038} { - clock format 3226892400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.638 {time zone boundary case 2072-04-03 03:00:01} {detroit y2038} { - clock format 3226892401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.639 {time zone boundary case 2072-10-30 01:59:59} {detroit y2038} { - clock format 3245032799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.640 {time zone boundary case 2072-10-30 01:00:00} {detroit y2038} { - clock format 3245032800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.641 {time zone boundary case 2072-10-30 01:00:01} {detroit y2038} { - clock format 3245032801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.642 {time zone boundary case 2073-04-02 01:59:59} {detroit y2038} { - clock format 3258341999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.643 {time zone boundary case 2073-04-02 03:00:00} {detroit y2038} { - clock format 3258342000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.644 {time zone boundary case 2073-04-02 03:00:01} {detroit y2038} { - clock format 3258342001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.645 {time zone boundary case 2073-10-29 01:59:59} {detroit y2038} { - clock format 3276482399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.646 {time zone boundary case 2073-10-29 01:00:00} {detroit y2038} { - clock format 3276482400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.647 {time zone boundary case 2073-10-29 01:00:01} {detroit y2038} { - clock format 3276482401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.648 {time zone boundary case 2074-04-01 01:59:59} {detroit y2038} { - clock format 3289791599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.649 {time zone boundary case 2074-04-01 03:00:00} {detroit y2038} { - clock format 3289791600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.650 {time zone boundary case 2074-04-01 03:00:01} {detroit y2038} { - clock format 3289791601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.651 {time zone boundary case 2074-10-28 01:59:59} {detroit y2038} { - clock format 3307931999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.652 {time zone boundary case 2074-10-28 01:00:00} {detroit y2038} { - clock format 3307932000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.653 {time zone boundary case 2074-10-28 01:00:01} {detroit y2038} { - clock format 3307932001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.654 {time zone boundary case 2075-04-07 01:59:59} {detroit y2038} { - clock format 3321845999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.655 {time zone boundary case 2075-04-07 03:00:00} {detroit y2038} { - clock format 3321846000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.656 {time zone boundary case 2075-04-07 03:00:01} {detroit y2038} { - clock format 3321846001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.657 {time zone boundary case 2075-10-27 01:59:59} {detroit y2038} { - clock format 3339381599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.658 {time zone boundary case 2075-10-27 01:00:00} {detroit y2038} { - clock format 3339381600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.659 {time zone boundary case 2075-10-27 01:00:01} {detroit y2038} { - clock format 3339381601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.660 {time zone boundary case 2076-04-05 01:59:59} {detroit y2038} { - clock format 3353295599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.661 {time zone boundary case 2076-04-05 03:00:00} {detroit y2038} { - clock format 3353295600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.662 {time zone boundary case 2076-04-05 03:00:01} {detroit y2038} { - clock format 3353295601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.663 {time zone boundary case 2076-10-25 01:59:59} {detroit y2038} { - clock format 3370831199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.664 {time zone boundary case 2076-10-25 01:00:00} {detroit y2038} { - clock format 3370831200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.665 {time zone boundary case 2076-10-25 01:00:01} {detroit y2038} { - clock format 3370831201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.666 {time zone boundary case 2077-04-04 01:59:59} {detroit y2038} { - clock format 3384745199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.667 {time zone boundary case 2077-04-04 03:00:00} {detroit y2038} { - clock format 3384745200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.668 {time zone boundary case 2077-04-04 03:00:01} {detroit y2038} { - clock format 3384745201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.669 {time zone boundary case 2077-10-31 01:59:59} {detroit y2038} { - clock format 3402885599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.670 {time zone boundary case 2077-10-31 01:00:00} {detroit y2038} { - clock format 3402885600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.671 {time zone boundary case 2077-10-31 01:00:01} {detroit y2038} { - clock format 3402885601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.672 {time zone boundary case 2078-04-03 01:59:59} {detroit y2038} { - clock format 3416194799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.673 {time zone boundary case 2078-04-03 03:00:00} {detroit y2038} { - clock format 3416194800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.674 {time zone boundary case 2078-04-03 03:00:01} {detroit y2038} { - clock format 3416194801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.675 {time zone boundary case 2078-10-30 01:59:59} {detroit y2038} { - clock format 3434335199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.676 {time zone boundary case 2078-10-30 01:00:00} {detroit y2038} { - clock format 3434335200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.677 {time zone boundary case 2078-10-30 01:00:01} {detroit y2038} { - clock format 3434335201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.678 {time zone boundary case 2079-04-02 01:59:59} {detroit y2038} { - clock format 3447644399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.679 {time zone boundary case 2079-04-02 03:00:00} {detroit y2038} { - clock format 3447644400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.680 {time zone boundary case 2079-04-02 03:00:01} {detroit y2038} { - clock format 3447644401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.681 {time zone boundary case 2079-10-29 01:59:59} {detroit y2038} { - clock format 3465784799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.682 {time zone boundary case 2079-10-29 01:00:00} {detroit y2038} { - clock format 3465784800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.683 {time zone boundary case 2079-10-29 01:00:01} {detroit y2038} { - clock format 3465784801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.684 {time zone boundary case 2080-04-07 01:59:59} {detroit y2038} { - clock format 3479698799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.685 {time zone boundary case 2080-04-07 03:00:00} {detroit y2038} { - clock format 3479698800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.686 {time zone boundary case 2080-04-07 03:00:01} {detroit y2038} { - clock format 3479698801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.687 {time zone boundary case 2080-10-27 01:59:59} {detroit y2038} { - clock format 3497234399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.688 {time zone boundary case 2080-10-27 01:00:00} {detroit y2038} { - clock format 3497234400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.689 {time zone boundary case 2080-10-27 01:00:01} {detroit y2038} { - clock format 3497234401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.690 {time zone boundary case 2081-04-06 01:59:59} {detroit y2038} { - clock format 3511148399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.691 {time zone boundary case 2081-04-06 03:00:00} {detroit y2038} { - clock format 3511148400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.692 {time zone boundary case 2081-04-06 03:00:01} {detroit y2038} { - clock format 3511148401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.693 {time zone boundary case 2081-10-26 01:59:59} {detroit y2038} { - clock format 3528683999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.694 {time zone boundary case 2081-10-26 01:00:00} {detroit y2038} { - clock format 3528684000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.695 {time zone boundary case 2081-10-26 01:00:01} {detroit y2038} { - clock format 3528684001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.696 {time zone boundary case 2082-04-05 01:59:59} {detroit y2038} { - clock format 3542597999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.697 {time zone boundary case 2082-04-05 03:00:00} {detroit y2038} { - clock format 3542598000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.698 {time zone boundary case 2082-04-05 03:00:01} {detroit y2038} { - clock format 3542598001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.699 {time zone boundary case 2082-10-25 01:59:59} {detroit y2038} { - clock format 3560133599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.700 {time zone boundary case 2082-10-25 01:00:00} {detroit y2038} { - clock format 3560133600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.701 {time zone boundary case 2082-10-25 01:00:01} {detroit y2038} { - clock format 3560133601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.702 {time zone boundary case 2083-04-04 01:59:59} {detroit y2038} { - clock format 3574047599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.703 {time zone boundary case 2083-04-04 03:00:00} {detroit y2038} { - clock format 3574047600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.704 {time zone boundary case 2083-04-04 03:00:01} {detroit y2038} { - clock format 3574047601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.705 {time zone boundary case 2083-10-31 01:59:59} {detroit y2038} { - clock format 3592187999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.706 {time zone boundary case 2083-10-31 01:00:00} {detroit y2038} { - clock format 3592188000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.707 {time zone boundary case 2083-10-31 01:00:01} {detroit y2038} { - clock format 3592188001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.708 {time zone boundary case 2084-04-02 01:59:59} {detroit y2038} { - clock format 3605497199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.709 {time zone boundary case 2084-04-02 03:00:00} {detroit y2038} { - clock format 3605497200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.710 {time zone boundary case 2084-04-02 03:00:01} {detroit y2038} { - clock format 3605497201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.711 {time zone boundary case 2084-10-29 01:59:59} {detroit y2038} { - clock format 3623637599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.712 {time zone boundary case 2084-10-29 01:00:00} {detroit y2038} { - clock format 3623637600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.713 {time zone boundary case 2084-10-29 01:00:01} {detroit y2038} { - clock format 3623637601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.714 {time zone boundary case 2085-04-01 01:59:59} {detroit y2038} { - clock format 3636946799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.715 {time zone boundary case 2085-04-01 03:00:00} {detroit y2038} { - clock format 3636946800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.716 {time zone boundary case 2085-04-01 03:00:01} {detroit y2038} { - clock format 3636946801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.717 {time zone boundary case 2085-10-28 01:59:59} {detroit y2038} { - clock format 3655087199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.718 {time zone boundary case 2085-10-28 01:00:00} {detroit y2038} { - clock format 3655087200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.719 {time zone boundary case 2085-10-28 01:00:01} {detroit y2038} { - clock format 3655087201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.720 {time zone boundary case 2086-04-07 01:59:59} {detroit y2038} { - clock format 3669001199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.721 {time zone boundary case 2086-04-07 03:00:00} {detroit y2038} { - clock format 3669001200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.722 {time zone boundary case 2086-04-07 03:00:01} {detroit y2038} { - clock format 3669001201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.723 {time zone boundary case 2086-10-27 01:59:59} {detroit y2038} { - clock format 3686536799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.724 {time zone boundary case 2086-10-27 01:00:00} {detroit y2038} { - clock format 3686536800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.725 {time zone boundary case 2086-10-27 01:00:01} {detroit y2038} { - clock format 3686536801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.726 {time zone boundary case 2087-04-06 01:59:59} {detroit y2038} { - clock format 3700450799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.727 {time zone boundary case 2087-04-06 03:00:00} {detroit y2038} { - clock format 3700450800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.728 {time zone boundary case 2087-04-06 03:00:01} {detroit y2038} { - clock format 3700450801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.729 {time zone boundary case 2087-10-26 01:59:59} {detroit y2038} { - clock format 3717986399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.730 {time zone boundary case 2087-10-26 01:00:00} {detroit y2038} { - clock format 3717986400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.731 {time zone boundary case 2087-10-26 01:00:01} {detroit y2038} { - clock format 3717986401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.732 {time zone boundary case 2088-04-04 01:59:59} {detroit y2038} { - clock format 3731900399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.733 {time zone boundary case 2088-04-04 03:00:00} {detroit y2038} { - clock format 3731900400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.734 {time zone boundary case 2088-04-04 03:00:01} {detroit y2038} { - clock format 3731900401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.735 {time zone boundary case 2088-10-31 01:59:59} {detroit y2038} { - clock format 3750040799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.736 {time zone boundary case 2088-10-31 01:00:00} {detroit y2038} { - clock format 3750040800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.737 {time zone boundary case 2088-10-31 01:00:01} {detroit y2038} { - clock format 3750040801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.738 {time zone boundary case 2089-04-03 01:59:59} {detroit y2038} { - clock format 3763349999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.739 {time zone boundary case 2089-04-03 03:00:00} {detroit y2038} { - clock format 3763350000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.740 {time zone boundary case 2089-04-03 03:00:01} {detroit y2038} { - clock format 3763350001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.741 {time zone boundary case 2089-10-30 01:59:59} {detroit y2038} { - clock format 3781490399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.742 {time zone boundary case 2089-10-30 01:00:00} {detroit y2038} { - clock format 3781490400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.743 {time zone boundary case 2089-10-30 01:00:01} {detroit y2038} { - clock format 3781490401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.744 {time zone boundary case 2090-04-02 01:59:59} {detroit y2038} { - clock format 3794799599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.745 {time zone boundary case 2090-04-02 03:00:00} {detroit y2038} { - clock format 3794799600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.746 {time zone boundary case 2090-04-02 03:00:01} {detroit y2038} { - clock format 3794799601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.747 {time zone boundary case 2090-10-29 01:59:59} {detroit y2038} { - clock format 3812939999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.748 {time zone boundary case 2090-10-29 01:00:00} {detroit y2038} { - clock format 3812940000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.749 {time zone boundary case 2090-10-29 01:00:01} {detroit y2038} { - clock format 3812940001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.750 {time zone boundary case 2091-04-01 01:59:59} {detroit y2038} { - clock format 3826249199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.751 {time zone boundary case 2091-04-01 03:00:00} {detroit y2038} { - clock format 3826249200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.752 {time zone boundary case 2091-04-01 03:00:01} {detroit y2038} { - clock format 3826249201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.753 {time zone boundary case 2091-10-28 01:59:59} {detroit y2038} { - clock format 3844389599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.754 {time zone boundary case 2091-10-28 01:00:00} {detroit y2038} { - clock format 3844389600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.755 {time zone boundary case 2091-10-28 01:00:01} {detroit y2038} { - clock format 3844389601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.756 {time zone boundary case 2092-04-06 01:59:59} {detroit y2038} { - clock format 3858303599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.757 {time zone boundary case 2092-04-06 03:00:00} {detroit y2038} { - clock format 3858303600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.758 {time zone boundary case 2092-04-06 03:00:01} {detroit y2038} { - clock format 3858303601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.759 {time zone boundary case 2092-10-26 01:59:59} {detroit y2038} { - clock format 3875839199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.760 {time zone boundary case 2092-10-26 01:00:00} {detroit y2038} { - clock format 3875839200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.761 {time zone boundary case 2092-10-26 01:00:01} {detroit y2038} { - clock format 3875839201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.762 {time zone boundary case 2093-04-05 01:59:59} {detroit y2038} { - clock format 3889753199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.763 {time zone boundary case 2093-04-05 03:00:00} {detroit y2038} { - clock format 3889753200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.764 {time zone boundary case 2093-04-05 03:00:01} {detroit y2038} { - clock format 3889753201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.765 {time zone boundary case 2093-10-25 01:59:59} {detroit y2038} { - clock format 3907288799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.766 {time zone boundary case 2093-10-25 01:00:00} {detroit y2038} { - clock format 3907288800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.767 {time zone boundary case 2093-10-25 01:00:01} {detroit y2038} { - clock format 3907288801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.768 {time zone boundary case 2094-04-04 01:59:59} {detroit y2038} { - clock format 3921202799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.769 {time zone boundary case 2094-04-04 03:00:00} {detroit y2038} { - clock format 3921202800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.770 {time zone boundary case 2094-04-04 03:00:01} {detroit y2038} { - clock format 3921202801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.771 {time zone boundary case 2094-10-31 01:59:59} {detroit y2038} { - clock format 3939343199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.772 {time zone boundary case 2094-10-31 01:00:00} {detroit y2038} { - clock format 3939343200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.773 {time zone boundary case 2094-10-31 01:00:01} {detroit y2038} { - clock format 3939343201 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.774 {time zone boundary case 2095-04-03 01:59:59} {detroit y2038} { - clock format 3952652399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.775 {time zone boundary case 2095-04-03 03:00:00} {detroit y2038} { - clock format 3952652400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.776 {time zone boundary case 2095-04-03 03:00:01} {detroit y2038} { - clock format 3952652401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.777 {time zone boundary case 2095-10-30 01:59:59} {detroit y2038} { - clock format 3970792799 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.778 {time zone boundary case 2095-10-30 01:00:00} {detroit y2038} { - clock format 3970792800 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.779 {time zone boundary case 2095-10-30 01:00:01} {detroit y2038} { - clock format 3970792801 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.780 {time zone boundary case 2096-04-01 01:59:59} {detroit y2038} { - clock format 3984101999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.781 {time zone boundary case 2096-04-01 03:00:00} {detroit y2038} { - clock format 3984102000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.782 {time zone boundary case 2096-04-01 03:00:01} {detroit y2038} { - clock format 3984102001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.783 {time zone boundary case 2096-10-28 01:59:59} {detroit y2038} { - clock format 4002242399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.784 {time zone boundary case 2096-10-28 01:00:00} {detroit y2038} { - clock format 4002242400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.785 {time zone boundary case 2096-10-28 01:00:01} {detroit y2038} { - clock format 4002242401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.786 {time zone boundary case 2097-04-07 01:59:59} {detroit y2038} { - clock format 4016156399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.787 {time zone boundary case 2097-04-07 03:00:00} {detroit y2038} { - clock format 4016156400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.788 {time zone boundary case 2097-04-07 03:00:01} {detroit y2038} { - clock format 4016156401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.789 {time zone boundary case 2097-10-27 01:59:59} {detroit y2038} { - clock format 4033691999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.790 {time zone boundary case 2097-10-27 01:00:00} {detroit y2038} { - clock format 4033692000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.791 {time zone boundary case 2097-10-27 01:00:01} {detroit y2038} { - clock format 4033692001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.792 {time zone boundary case 2098-04-06 01:59:59} {detroit y2038} { - clock format 4047605999 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.793 {time zone boundary case 2098-04-06 03:00:00} {detroit y2038} { - clock format 4047606000 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.794 {time zone boundary case 2098-04-06 03:00:01} {detroit y2038} { - clock format 4047606001 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.795 {time zone boundary case 2098-10-26 01:59:59} {detroit y2038} { - clock format 4065141599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.796 {time zone boundary case 2098-10-26 01:00:00} {detroit y2038} { - clock format 4065141600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.797 {time zone boundary case 2098-10-26 01:00:01} {detroit y2038} { - clock format 4065141601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} -test clock-5.798 {time zone boundary case 2099-04-05 01:59:59} {detroit y2038} { - clock format 4079055599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.799 {time zone boundary case 2099-04-05 03:00:00} {detroit y2038} { - clock format 4079055600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.800 {time zone boundary case 2099-04-05 03:00:01} {detroit y2038} { - clock format 4079055601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.801 {time zone boundary case 2099-10-25 01:59:59} {detroit y2038} { - clock format 4096591199 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.802 {time zone boundary case 2099-10-25 01:00:00} {detroit y2038} { - clock format 4096591200 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.803 {time zone boundary case 2099-10-25 01:00:01} {detroit y2038} { - clock format 4096591201 -format {%H:%M:%S %z %Z} \ +test clock-5.246 {time zone boundary case 2007-03-11 01:59:59} detroit { + clock format 1173596399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.247 {time zone boundary case 2007-03-11 03:00:00} detroit { + clock format 1173596400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.248 {time zone boundary case 2007-03-11 03:00:01} detroit { + clock format 1173596401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.249 {time zone boundary case 2007-11-04 01:59:59} detroit { + clock format 1194155999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.250 {time zone boundary case 2007-11-04 01:00:00} detroit { + clock format 1194156000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.251 {time zone boundary case 2007-11-04 01:00:01} detroit { + clock format 1194156001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.252 {time zone boundary case 2008-03-09 01:59:59} detroit { + clock format 1205045999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.253 {time zone boundary case 2008-03-09 03:00:00} detroit { + clock format 1205046000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.254 {time zone boundary case 2008-03-09 03:00:01} detroit { + clock format 1205046001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.255 {time zone boundary case 2008-11-02 01:59:59} detroit { + clock format 1225605599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.256 {time zone boundary case 2008-11-02 01:00:00} detroit { + clock format 1225605600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.257 {time zone boundary case 2008-11-02 01:00:01} detroit { + clock format 1225605601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.258 {time zone boundary case 2009-03-08 01:59:59} detroit { + clock format 1236495599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.259 {time zone boundary case 2009-03-08 03:00:00} detroit { + clock format 1236495600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.260 {time zone boundary case 2009-03-08 03:00:01} detroit { + clock format 1236495601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.261 {time zone boundary case 2009-11-01 01:59:59} detroit { + clock format 1257055199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.262 {time zone boundary case 2009-11-01 01:00:00} detroit { + clock format 1257055200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.263 {time zone boundary case 2009-11-01 01:00:01} detroit { + clock format 1257055201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.264 {time zone boundary case 2010-03-14 01:59:59} detroit { + clock format 1268549999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.265 {time zone boundary case 2010-03-14 03:00:00} detroit { + clock format 1268550000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.266 {time zone boundary case 2010-03-14 03:00:01} detroit { + clock format 1268550001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.267 {time zone boundary case 2010-11-07 01:59:59} detroit { + clock format 1289109599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.268 {time zone boundary case 2010-11-07 01:00:00} detroit { + clock format 1289109600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.269 {time zone boundary case 2010-11-07 01:00:01} detroit { + clock format 1289109601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.270 {time zone boundary case 2011-03-13 01:59:59} detroit { + clock format 1299999599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.271 {time zone boundary case 2011-03-13 03:00:00} detroit { + clock format 1299999600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.272 {time zone boundary case 2011-03-13 03:00:01} detroit { + clock format 1299999601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.273 {time zone boundary case 2011-11-06 01:59:59} detroit { + clock format 1320559199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.274 {time zone boundary case 2011-11-06 01:00:00} detroit { + clock format 1320559200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.275 {time zone boundary case 2011-11-06 01:00:01} detroit { + clock format 1320559201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.276 {time zone boundary case 2012-03-11 01:59:59} detroit { + clock format 1331449199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.277 {time zone boundary case 2012-03-11 03:00:00} detroit { + clock format 1331449200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.278 {time zone boundary case 2012-03-11 03:00:01} detroit { + clock format 1331449201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.279 {time zone boundary case 2012-11-04 01:59:59} detroit { + clock format 1352008799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.280 {time zone boundary case 2012-11-04 01:00:00} detroit { + clock format 1352008800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.281 {time zone boundary case 2012-11-04 01:00:01} detroit { + clock format 1352008801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.282 {time zone boundary case 2013-03-10 01:59:59} detroit { + clock format 1362898799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.283 {time zone boundary case 2013-03-10 03:00:00} detroit { + clock format 1362898800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.284 {time zone boundary case 2013-03-10 03:00:01} detroit { + clock format 1362898801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.285 {time zone boundary case 2013-11-03 01:59:59} detroit { + clock format 1383458399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.286 {time zone boundary case 2013-11-03 01:00:00} detroit { + clock format 1383458400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.287 {time zone boundary case 2013-11-03 01:00:01} detroit { + clock format 1383458401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.288 {time zone boundary case 2014-03-09 01:59:59} detroit { + clock format 1394348399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.289 {time zone boundary case 2014-03-09 03:00:00} detroit { + clock format 1394348400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.290 {time zone boundary case 2014-03-09 03:00:01} detroit { + clock format 1394348401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.291 {time zone boundary case 2014-11-02 01:59:59} detroit { + clock format 1414907999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.292 {time zone boundary case 2014-11-02 01:00:00} detroit { + clock format 1414908000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.293 {time zone boundary case 2014-11-02 01:00:01} detroit { + clock format 1414908001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.294 {time zone boundary case 2015-03-08 01:59:59} detroit { + clock format 1425797999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.295 {time zone boundary case 2015-03-08 03:00:00} detroit { + clock format 1425798000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.296 {time zone boundary case 2015-03-08 03:00:01} detroit { + clock format 1425798001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.297 {time zone boundary case 2015-11-01 01:59:59} detroit { + clock format 1446357599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.298 {time zone boundary case 2015-11-01 01:00:00} detroit { + clock format 1446357600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.299 {time zone boundary case 2015-11-01 01:00:01} detroit { + clock format 1446357601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.300 {time zone boundary case 2016-03-13 01:59:59} detroit { + clock format 1457852399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.301 {time zone boundary case 2016-03-13 03:00:00} detroit { + clock format 1457852400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.302 {time zone boundary case 2016-03-13 03:00:01} detroit { + clock format 1457852401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.303 {time zone boundary case 2016-11-06 01:59:59} detroit { + clock format 1478411999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.304 {time zone boundary case 2016-11-06 01:00:00} detroit { + clock format 1478412000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.305 {time zone boundary case 2016-11-06 01:00:01} detroit { + clock format 1478412001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.306 {time zone boundary case 2017-03-12 01:59:59} detroit { + clock format 1489301999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.307 {time zone boundary case 2017-03-12 03:00:00} detroit { + clock format 1489302000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.308 {time zone boundary case 2017-03-12 03:00:01} detroit { + clock format 1489302001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.309 {time zone boundary case 2017-11-05 01:59:59} detroit { + clock format 1509861599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.310 {time zone boundary case 2017-11-05 01:00:00} detroit { + clock format 1509861600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.311 {time zone boundary case 2017-11-05 01:00:01} detroit { + clock format 1509861601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.312 {time zone boundary case 2018-03-11 01:59:59} detroit { + clock format 1520751599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.313 {time zone boundary case 2018-03-11 03:00:00} detroit { + clock format 1520751600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.314 {time zone boundary case 2018-03-11 03:00:01} detroit { + clock format 1520751601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.315 {time zone boundary case 2018-11-04 01:59:59} detroit { + clock format 1541311199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.316 {time zone boundary case 2018-11-04 01:00:00} detroit { + clock format 1541311200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.317 {time zone boundary case 2018-11-04 01:00:01} detroit { + clock format 1541311201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.318 {time zone boundary case 2019-03-10 01:59:59} detroit { + clock format 1552201199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.319 {time zone boundary case 2019-03-10 03:00:00} detroit { + clock format 1552201200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.320 {time zone boundary case 2019-03-10 03:00:01} detroit { + clock format 1552201201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.321 {time zone boundary case 2019-11-03 01:59:59} detroit { + clock format 1572760799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.322 {time zone boundary case 2019-11-03 01:00:00} detroit { + clock format 1572760800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.323 {time zone boundary case 2019-11-03 01:00:01} detroit { + clock format 1572760801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.324 {time zone boundary case 2020-03-08 01:59:59} detroit { + clock format 1583650799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.325 {time zone boundary case 2020-03-08 03:00:00} detroit { + clock format 1583650800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.326 {time zone boundary case 2020-03-08 03:00:01} detroit { + clock format 1583650801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.327 {time zone boundary case 2020-11-01 01:59:59} detroit { + clock format 1604210399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.328 {time zone boundary case 2020-11-01 01:00:00} detroit { + clock format 1604210400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.329 {time zone boundary case 2020-11-01 01:00:01} detroit { + clock format 1604210401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.330 {time zone boundary case 2021-03-14 01:59:59} detroit { + clock format 1615705199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.331 {time zone boundary case 2021-03-14 03:00:00} detroit { + clock format 1615705200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.332 {time zone boundary case 2021-03-14 03:00:01} detroit { + clock format 1615705201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.333 {time zone boundary case 2021-11-07 01:59:59} detroit { + clock format 1636264799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.334 {time zone boundary case 2021-11-07 01:00:00} detroit { + clock format 1636264800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.335 {time zone boundary case 2021-11-07 01:00:01} detroit { + clock format 1636264801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.336 {time zone boundary case 2022-03-13 01:59:59} detroit { + clock format 1647154799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.337 {time zone boundary case 2022-03-13 03:00:00} detroit { + clock format 1647154800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.338 {time zone boundary case 2022-03-13 03:00:01} detroit { + clock format 1647154801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.339 {time zone boundary case 2022-11-06 01:59:59} detroit { + clock format 1667714399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.340 {time zone boundary case 2022-11-06 01:00:00} detroit { + clock format 1667714400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.341 {time zone boundary case 2022-11-06 01:00:01} detroit { + clock format 1667714401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.342 {time zone boundary case 2023-03-12 01:59:59} detroit { + clock format 1678604399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.343 {time zone boundary case 2023-03-12 03:00:00} detroit { + clock format 1678604400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.344 {time zone boundary case 2023-03-12 03:00:01} detroit { + clock format 1678604401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.345 {time zone boundary case 2023-11-05 01:59:59} detroit { + clock format 1699163999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.346 {time zone boundary case 2023-11-05 01:00:00} detroit { + clock format 1699164000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.347 {time zone boundary case 2023-11-05 01:00:01} detroit { + clock format 1699164001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.348 {time zone boundary case 2024-03-10 01:59:59} detroit { + clock format 1710053999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.349 {time zone boundary case 2024-03-10 03:00:00} detroit { + clock format 1710054000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.350 {time zone boundary case 2024-03-10 03:00:01} detroit { + clock format 1710054001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.351 {time zone boundary case 2024-11-03 01:59:59} detroit { + clock format 1730613599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.352 {time zone boundary case 2024-11-03 01:00:00} detroit { + clock format 1730613600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.353 {time zone boundary case 2024-11-03 01:00:01} detroit { + clock format 1730613601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.354 {time zone boundary case 2025-03-09 01:59:59} detroit { + clock format 1741503599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.355 {time zone boundary case 2025-03-09 03:00:00} detroit { + clock format 1741503600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.356 {time zone boundary case 2025-03-09 03:00:01} detroit { + clock format 1741503601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.357 {time zone boundary case 2025-11-02 01:59:59} detroit { + clock format 1762063199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.358 {time zone boundary case 2025-11-02 01:00:00} detroit { + clock format 1762063200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.359 {time zone boundary case 2025-11-02 01:00:01} detroit { + clock format 1762063201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.360 {time zone boundary case 2026-03-08 01:59:59} detroit { + clock format 1772953199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.361 {time zone boundary case 2026-03-08 03:00:00} detroit { + clock format 1772953200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.362 {time zone boundary case 2026-03-08 03:00:01} detroit { + clock format 1772953201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.363 {time zone boundary case 2026-11-01 01:59:59} detroit { + clock format 1793512799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.364 {time zone boundary case 2026-11-01 01:00:00} detroit { + clock format 1793512800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.365 {time zone boundary case 2026-11-01 01:00:01} detroit { + clock format 1793512801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.366 {time zone boundary case 2027-03-14 01:59:59} detroit { + clock format 1805007599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.367 {time zone boundary case 2027-03-14 03:00:00} detroit { + clock format 1805007600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.368 {time zone boundary case 2027-03-14 03:00:01} detroit { + clock format 1805007601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.369 {time zone boundary case 2027-11-07 01:59:59} detroit { + clock format 1825567199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.370 {time zone boundary case 2027-11-07 01:00:00} detroit { + clock format 1825567200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.371 {time zone boundary case 2027-11-07 01:00:01} detroit { + clock format 1825567201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.372 {time zone boundary case 2028-03-12 01:59:59} detroit { + clock format 1836457199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.373 {time zone boundary case 2028-03-12 03:00:00} detroit { + clock format 1836457200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.374 {time zone boundary case 2028-03-12 03:00:01} detroit { + clock format 1836457201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.375 {time zone boundary case 2028-11-05 01:59:59} detroit { + clock format 1857016799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.376 {time zone boundary case 2028-11-05 01:00:00} detroit { + clock format 1857016800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.377 {time zone boundary case 2028-11-05 01:00:01} detroit { + clock format 1857016801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.378 {time zone boundary case 2029-03-11 01:59:59} detroit { + clock format 1867906799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.379 {time zone boundary case 2029-03-11 03:00:00} detroit { + clock format 1867906800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.380 {time zone boundary case 2029-03-11 03:00:01} detroit { + clock format 1867906801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.381 {time zone boundary case 2029-11-04 01:59:59} detroit { + clock format 1888466399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.382 {time zone boundary case 2029-11-04 01:00:00} detroit { + clock format 1888466400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.383 {time zone boundary case 2029-11-04 01:00:01} detroit { + clock format 1888466401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.384 {time zone boundary case 2030-03-10 01:59:59} detroit { + clock format 1899356399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.385 {time zone boundary case 2030-03-10 03:00:00} detroit { + clock format 1899356400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.386 {time zone boundary case 2030-03-10 03:00:01} detroit { + clock format 1899356401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.387 {time zone boundary case 2030-11-03 01:59:59} detroit { + clock format 1919915999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.388 {time zone boundary case 2030-11-03 01:00:00} detroit { + clock format 1919916000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.389 {time zone boundary case 2030-11-03 01:00:01} detroit { + clock format 1919916001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.390 {time zone boundary case 2031-03-09 01:59:59} detroit { + clock format 1930805999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.391 {time zone boundary case 2031-03-09 03:00:00} detroit { + clock format 1930806000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.392 {time zone boundary case 2031-03-09 03:00:01} detroit { + clock format 1930806001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.393 {time zone boundary case 2031-11-02 01:59:59} detroit { + clock format 1951365599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.394 {time zone boundary case 2031-11-02 01:00:00} detroit { + clock format 1951365600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.395 {time zone boundary case 2031-11-02 01:00:01} detroit { + clock format 1951365601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.396 {time zone boundary case 2032-03-14 01:59:59} detroit { + clock format 1962860399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.397 {time zone boundary case 2032-03-14 03:00:00} detroit { + clock format 1962860400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.398 {time zone boundary case 2032-03-14 03:00:01} detroit { + clock format 1962860401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.399 {time zone boundary case 2032-11-07 01:59:59} detroit { + clock format 1983419999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.400 {time zone boundary case 2032-11-07 01:00:00} detroit { + clock format 1983420000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.401 {time zone boundary case 2032-11-07 01:00:01} detroit { + clock format 1983420001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.402 {time zone boundary case 2033-03-13 01:59:59} detroit { + clock format 1994309999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.403 {time zone boundary case 2033-03-13 03:00:00} detroit { + clock format 1994310000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.404 {time zone boundary case 2033-03-13 03:00:01} detroit { + clock format 1994310001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.405 {time zone boundary case 2033-11-06 01:59:59} detroit { + clock format 2014869599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.406 {time zone boundary case 2033-11-06 01:00:00} detroit { + clock format 2014869600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.407 {time zone boundary case 2033-11-06 01:00:01} detroit { + clock format 2014869601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.408 {time zone boundary case 2034-03-12 01:59:59} detroit { + clock format 2025759599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.409 {time zone boundary case 2034-03-12 03:00:00} detroit { + clock format 2025759600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.410 {time zone boundary case 2034-03-12 03:00:01} detroit { + clock format 2025759601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.411 {time zone boundary case 2034-11-05 01:59:59} detroit { + clock format 2046319199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.412 {time zone boundary case 2034-11-05 01:00:00} detroit { + clock format 2046319200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.413 {time zone boundary case 2034-11-05 01:00:01} detroit { + clock format 2046319201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.414 {time zone boundary case 2035-03-11 01:59:59} detroit { + clock format 2057209199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.415 {time zone boundary case 2035-03-11 03:00:00} detroit { + clock format 2057209200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.416 {time zone boundary case 2035-03-11 03:00:01} detroit { + clock format 2057209201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.417 {time zone boundary case 2035-11-04 01:59:59} detroit { + clock format 2077768799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.418 {time zone boundary case 2035-11-04 01:00:00} detroit { + clock format 2077768800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.419 {time zone boundary case 2035-11-04 01:00:01} detroit { + clock format 2077768801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.420 {time zone boundary case 2036-03-09 01:59:59} detroit { + clock format 2088658799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.421 {time zone boundary case 2036-03-09 03:00:00} detroit { + clock format 2088658800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.422 {time zone boundary case 2036-03-09 03:00:01} detroit { + clock format 2088658801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.423 {time zone boundary case 2036-11-02 01:59:59} detroit { + clock format 2109218399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.424 {time zone boundary case 2036-11-02 01:00:00} detroit { + clock format 2109218400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.425 {time zone boundary case 2036-11-02 01:00:01} detroit { + clock format 2109218401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.426 {time zone boundary case 2037-03-08 01:59:59} detroit { + clock format 2120108399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.427 {time zone boundary case 2037-03-08 03:00:00} detroit { + clock format 2120108400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.428 {time zone boundary case 2037-03-08 03:00:01} detroit { + clock format 2120108401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.429 {time zone boundary case 2037-11-01 01:59:59} detroit { + clock format 2140667999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.430 {time zone boundary case 2037-11-01 01:00:00} detroit { + clock format 2140668000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.431 {time zone boundary case 2037-11-01 01:00:01} detroit { + clock format 2140668001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.432 {time zone boundary case 2038-03-14 01:59:59} {detroit y2038} { + clock format 2152162799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.433 {time zone boundary case 2038-03-14 03:00:00} {detroit y2038} { + clock format 2152162800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.434 {time zone boundary case 2038-03-14 03:00:01} {detroit y2038} { + clock format 2152162801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.435 {time zone boundary case 2038-11-07 01:59:59} {detroit y2038} { + clock format 2172722399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.436 {time zone boundary case 2038-11-07 01:00:00} {detroit y2038} { + clock format 2172722400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.437 {time zone boundary case 2038-11-07 01:00:01} {detroit y2038} { + clock format 2172722401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.438 {time zone boundary case 2039-03-13 01:59:59} {detroit y2038} { + clock format 2183612399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.439 {time zone boundary case 2039-03-13 03:00:00} {detroit y2038} { + clock format 2183612400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.440 {time zone boundary case 2039-03-13 03:00:01} {detroit y2038} { + clock format 2183612401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.441 {time zone boundary case 2039-11-06 01:59:59} {detroit y2038} { + clock format 2204171999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.442 {time zone boundary case 2039-11-06 01:00:00} {detroit y2038} { + clock format 2204172000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.443 {time zone boundary case 2039-11-06 01:00:01} {detroit y2038} { + clock format 2204172001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.444 {time zone boundary case 2040-03-11 01:59:59} {detroit y2038} { + clock format 2215061999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.445 {time zone boundary case 2040-03-11 03:00:00} {detroit y2038} { + clock format 2215062000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.446 {time zone boundary case 2040-03-11 03:00:01} {detroit y2038} { + clock format 2215062001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.447 {time zone boundary case 2040-11-04 01:59:59} {detroit y2038} { + clock format 2235621599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.448 {time zone boundary case 2040-11-04 01:00:00} {detroit y2038} { + clock format 2235621600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.449 {time zone boundary case 2040-11-04 01:00:01} {detroit y2038} { + clock format 2235621601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.450 {time zone boundary case 2041-03-10 01:59:59} {detroit y2038} { + clock format 2246511599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.451 {time zone boundary case 2041-03-10 03:00:00} {detroit y2038} { + clock format 2246511600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.452 {time zone boundary case 2041-03-10 03:00:01} {detroit y2038} { + clock format 2246511601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.453 {time zone boundary case 2041-11-03 01:59:59} {detroit y2038} { + clock format 2267071199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.454 {time zone boundary case 2041-11-03 01:00:00} {detroit y2038} { + clock format 2267071200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.455 {time zone boundary case 2041-11-03 01:00:01} {detroit y2038} { + clock format 2267071201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.456 {time zone boundary case 2042-03-09 01:59:59} {detroit y2038} { + clock format 2277961199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.457 {time zone boundary case 2042-03-09 03:00:00} {detroit y2038} { + clock format 2277961200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.458 {time zone boundary case 2042-03-09 03:00:01} {detroit y2038} { + clock format 2277961201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.459 {time zone boundary case 2042-11-02 01:59:59} {detroit y2038} { + clock format 2298520799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.460 {time zone boundary case 2042-11-02 01:00:00} {detroit y2038} { + clock format 2298520800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.461 {time zone boundary case 2042-11-02 01:00:01} {detroit y2038} { + clock format 2298520801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.462 {time zone boundary case 2043-03-08 01:59:59} {detroit y2038} { + clock format 2309410799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.463 {time zone boundary case 2043-03-08 03:00:00} {detroit y2038} { + clock format 2309410800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.464 {time zone boundary case 2043-03-08 03:00:01} {detroit y2038} { + clock format 2309410801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.465 {time zone boundary case 2043-11-01 01:59:59} {detroit y2038} { + clock format 2329970399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.466 {time zone boundary case 2043-11-01 01:00:00} {detroit y2038} { + clock format 2329970400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.467 {time zone boundary case 2043-11-01 01:00:01} {detroit y2038} { + clock format 2329970401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.468 {time zone boundary case 2044-03-13 01:59:59} {detroit y2038} { + clock format 2341465199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.469 {time zone boundary case 2044-03-13 03:00:00} {detroit y2038} { + clock format 2341465200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.470 {time zone boundary case 2044-03-13 03:00:01} {detroit y2038} { + clock format 2341465201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.471 {time zone boundary case 2044-11-06 01:59:59} {detroit y2038} { + clock format 2362024799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.472 {time zone boundary case 2044-11-06 01:00:00} {detroit y2038} { + clock format 2362024800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.473 {time zone boundary case 2044-11-06 01:00:01} {detroit y2038} { + clock format 2362024801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.474 {time zone boundary case 2045-03-12 01:59:59} {detroit y2038} { + clock format 2372914799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.475 {time zone boundary case 2045-03-12 03:00:00} {detroit y2038} { + clock format 2372914800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.476 {time zone boundary case 2045-03-12 03:00:01} {detroit y2038} { + clock format 2372914801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.477 {time zone boundary case 2045-11-05 01:59:59} {detroit y2038} { + clock format 2393474399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.478 {time zone boundary case 2045-11-05 01:00:00} {detroit y2038} { + clock format 2393474400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.479 {time zone boundary case 2045-11-05 01:00:01} {detroit y2038} { + clock format 2393474401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.480 {time zone boundary case 2046-03-11 01:59:59} {detroit y2038} { + clock format 2404364399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.481 {time zone boundary case 2046-03-11 03:00:00} {detroit y2038} { + clock format 2404364400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.482 {time zone boundary case 2046-03-11 03:00:01} {detroit y2038} { + clock format 2404364401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.483 {time zone boundary case 2046-11-04 01:59:59} {detroit y2038} { + clock format 2424923999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.484 {time zone boundary case 2046-11-04 01:00:00} {detroit y2038} { + clock format 2424924000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.485 {time zone boundary case 2046-11-04 01:00:01} {detroit y2038} { + clock format 2424924001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.486 {time zone boundary case 2047-03-10 01:59:59} {detroit y2038} { + clock format 2435813999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.487 {time zone boundary case 2047-03-10 03:00:00} {detroit y2038} { + clock format 2435814000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.488 {time zone boundary case 2047-03-10 03:00:01} {detroit y2038} { + clock format 2435814001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.489 {time zone boundary case 2047-11-03 01:59:59} {detroit y2038} { + clock format 2456373599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.490 {time zone boundary case 2047-11-03 01:00:00} {detroit y2038} { + clock format 2456373600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.491 {time zone boundary case 2047-11-03 01:00:01} {detroit y2038} { + clock format 2456373601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.492 {time zone boundary case 2048-03-08 01:59:59} {detroit y2038} { + clock format 2467263599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.493 {time zone boundary case 2048-03-08 03:00:00} {detroit y2038} { + clock format 2467263600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.494 {time zone boundary case 2048-03-08 03:00:01} {detroit y2038} { + clock format 2467263601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.495 {time zone boundary case 2048-11-01 01:59:59} {detroit y2038} { + clock format 2487823199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.496 {time zone boundary case 2048-11-01 01:00:00} {detroit y2038} { + clock format 2487823200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.497 {time zone boundary case 2048-11-01 01:00:01} {detroit y2038} { + clock format 2487823201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.498 {time zone boundary case 2049-03-14 01:59:59} {detroit y2038} { + clock format 2499317999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.499 {time zone boundary case 2049-03-14 03:00:00} {detroit y2038} { + clock format 2499318000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.500 {time zone boundary case 2049-03-14 03:00:01} {detroit y2038} { + clock format 2499318001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.501 {time zone boundary case 2049-11-07 01:59:59} {detroit y2038} { + clock format 2519877599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.502 {time zone boundary case 2049-11-07 01:00:00} {detroit y2038} { + clock format 2519877600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.503 {time zone boundary case 2049-11-07 01:00:01} {detroit y2038} { + clock format 2519877601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.504 {time zone boundary case 2050-03-13 01:59:59} {detroit y2038} { + clock format 2530767599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.505 {time zone boundary case 2050-03-13 03:00:00} {detroit y2038} { + clock format 2530767600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.506 {time zone boundary case 2050-03-13 03:00:01} {detroit y2038} { + clock format 2530767601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.507 {time zone boundary case 2050-11-06 01:59:59} {detroit y2038} { + clock format 2551327199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.508 {time zone boundary case 2050-11-06 01:00:00} {detroit y2038} { + clock format 2551327200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.509 {time zone boundary case 2050-11-06 01:00:01} {detroit y2038} { + clock format 2551327201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.510 {time zone boundary case 2051-03-12 01:59:59} {detroit y2038} { + clock format 2562217199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.511 {time zone boundary case 2051-03-12 03:00:00} {detroit y2038} { + clock format 2562217200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.512 {time zone boundary case 2051-03-12 03:00:01} {detroit y2038} { + clock format 2562217201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.513 {time zone boundary case 2051-11-05 01:59:59} {detroit y2038} { + clock format 2582776799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.514 {time zone boundary case 2051-11-05 01:00:00} {detroit y2038} { + clock format 2582776800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.515 {time zone boundary case 2051-11-05 01:00:01} {detroit y2038} { + clock format 2582776801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.516 {time zone boundary case 2052-03-10 01:59:59} {detroit y2038} { + clock format 2593666799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.517 {time zone boundary case 2052-03-10 03:00:00} {detroit y2038} { + clock format 2593666800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.518 {time zone boundary case 2052-03-10 03:00:01} {detroit y2038} { + clock format 2593666801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.519 {time zone boundary case 2052-11-03 01:59:59} {detroit y2038} { + clock format 2614226399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.520 {time zone boundary case 2052-11-03 01:00:00} {detroit y2038} { + clock format 2614226400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.521 {time zone boundary case 2052-11-03 01:00:01} {detroit y2038} { + clock format 2614226401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.522 {time zone boundary case 2053-03-09 01:59:59} {detroit y2038} { + clock format 2625116399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.523 {time zone boundary case 2053-03-09 03:00:00} {detroit y2038} { + clock format 2625116400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.524 {time zone boundary case 2053-03-09 03:00:01} {detroit y2038} { + clock format 2625116401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.525 {time zone boundary case 2053-11-02 01:59:59} {detroit y2038} { + clock format 2645675999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.526 {time zone boundary case 2053-11-02 01:00:00} {detroit y2038} { + clock format 2645676000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.527 {time zone boundary case 2053-11-02 01:00:01} {detroit y2038} { + clock format 2645676001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.528 {time zone boundary case 2054-03-08 01:59:59} {detroit y2038} { + clock format 2656565999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.529 {time zone boundary case 2054-03-08 03:00:00} {detroit y2038} { + clock format 2656566000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.530 {time zone boundary case 2054-03-08 03:00:01} {detroit y2038} { + clock format 2656566001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.531 {time zone boundary case 2054-11-01 01:59:59} {detroit y2038} { + clock format 2677125599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.532 {time zone boundary case 2054-11-01 01:00:00} {detroit y2038} { + clock format 2677125600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.533 {time zone boundary case 2054-11-01 01:00:01} {detroit y2038} { + clock format 2677125601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.534 {time zone boundary case 2055-03-14 01:59:59} {detroit y2038} { + clock format 2688620399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.535 {time zone boundary case 2055-03-14 03:00:00} {detroit y2038} { + clock format 2688620400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.536 {time zone boundary case 2055-03-14 03:00:01} {detroit y2038} { + clock format 2688620401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.537 {time zone boundary case 2055-11-07 01:59:59} {detroit y2038} { + clock format 2709179999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.538 {time zone boundary case 2055-11-07 01:00:00} {detroit y2038} { + clock format 2709180000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.539 {time zone boundary case 2055-11-07 01:00:01} {detroit y2038} { + clock format 2709180001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.540 {time zone boundary case 2056-03-12 01:59:59} {detroit y2038} { + clock format 2720069999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.541 {time zone boundary case 2056-03-12 03:00:00} {detroit y2038} { + clock format 2720070000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.542 {time zone boundary case 2056-03-12 03:00:01} {detroit y2038} { + clock format 2720070001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.543 {time zone boundary case 2056-11-05 01:59:59} {detroit y2038} { + clock format 2740629599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.544 {time zone boundary case 2056-11-05 01:00:00} {detroit y2038} { + clock format 2740629600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.545 {time zone boundary case 2056-11-05 01:00:01} {detroit y2038} { + clock format 2740629601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.546 {time zone boundary case 2057-03-11 01:59:59} {detroit y2038} { + clock format 2751519599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.547 {time zone boundary case 2057-03-11 03:00:00} {detroit y2038} { + clock format 2751519600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.548 {time zone boundary case 2057-03-11 03:00:01} {detroit y2038} { + clock format 2751519601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.549 {time zone boundary case 2057-11-04 01:59:59} {detroit y2038} { + clock format 2772079199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.550 {time zone boundary case 2057-11-04 01:00:00} {detroit y2038} { + clock format 2772079200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.551 {time zone boundary case 2057-11-04 01:00:01} {detroit y2038} { + clock format 2772079201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.552 {time zone boundary case 2058-03-10 01:59:59} {detroit y2038} { + clock format 2782969199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.553 {time zone boundary case 2058-03-10 03:00:00} {detroit y2038} { + clock format 2782969200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.554 {time zone boundary case 2058-03-10 03:00:01} {detroit y2038} { + clock format 2782969201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.555 {time zone boundary case 2058-11-03 01:59:59} {detroit y2038} { + clock format 2803528799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.556 {time zone boundary case 2058-11-03 01:00:00} {detroit y2038} { + clock format 2803528800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.557 {time zone boundary case 2058-11-03 01:00:01} {detroit y2038} { + clock format 2803528801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.558 {time zone boundary case 2059-03-09 01:59:59} {detroit y2038} { + clock format 2814418799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.559 {time zone boundary case 2059-03-09 03:00:00} {detroit y2038} { + clock format 2814418800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.560 {time zone boundary case 2059-03-09 03:00:01} {detroit y2038} { + clock format 2814418801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.561 {time zone boundary case 2059-11-02 01:59:59} {detroit y2038} { + clock format 2834978399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.562 {time zone boundary case 2059-11-02 01:00:00} {detroit y2038} { + clock format 2834978400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.563 {time zone boundary case 2059-11-02 01:00:01} {detroit y2038} { + clock format 2834978401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.564 {time zone boundary case 2060-03-14 01:59:59} {detroit y2038} { + clock format 2846473199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.565 {time zone boundary case 2060-03-14 03:00:00} {detroit y2038} { + clock format 2846473200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.566 {time zone boundary case 2060-03-14 03:00:01} {detroit y2038} { + clock format 2846473201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.567 {time zone boundary case 2060-11-07 01:59:59} {detroit y2038} { + clock format 2867032799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.568 {time zone boundary case 2060-11-07 01:00:00} {detroit y2038} { + clock format 2867032800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.569 {time zone boundary case 2060-11-07 01:00:01} {detroit y2038} { + clock format 2867032801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.570 {time zone boundary case 2061-03-13 01:59:59} {detroit y2038} { + clock format 2877922799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.571 {time zone boundary case 2061-03-13 03:00:00} {detroit y2038} { + clock format 2877922800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.572 {time zone boundary case 2061-03-13 03:00:01} {detroit y2038} { + clock format 2877922801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.573 {time zone boundary case 2061-11-06 01:59:59} {detroit y2038} { + clock format 2898482399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.574 {time zone boundary case 2061-11-06 01:00:00} {detroit y2038} { + clock format 2898482400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.575 {time zone boundary case 2061-11-06 01:00:01} {detroit y2038} { + clock format 2898482401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.576 {time zone boundary case 2062-03-12 01:59:59} {detroit y2038} { + clock format 2909372399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.577 {time zone boundary case 2062-03-12 03:00:00} {detroit y2038} { + clock format 2909372400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.578 {time zone boundary case 2062-03-12 03:00:01} {detroit y2038} { + clock format 2909372401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.579 {time zone boundary case 2062-11-05 01:59:59} {detroit y2038} { + clock format 2929931999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.580 {time zone boundary case 2062-11-05 01:00:00} {detroit y2038} { + clock format 2929932000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.581 {time zone boundary case 2062-11-05 01:00:01} {detroit y2038} { + clock format 2929932001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.582 {time zone boundary case 2063-03-11 01:59:59} {detroit y2038} { + clock format 2940821999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.583 {time zone boundary case 2063-03-11 03:00:00} {detroit y2038} { + clock format 2940822000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.584 {time zone boundary case 2063-03-11 03:00:01} {detroit y2038} { + clock format 2940822001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.585 {time zone boundary case 2063-11-04 01:59:59} {detroit y2038} { + clock format 2961381599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.586 {time zone boundary case 2063-11-04 01:00:00} {detroit y2038} { + clock format 2961381600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.587 {time zone boundary case 2063-11-04 01:00:01} {detroit y2038} { + clock format 2961381601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.588 {time zone boundary case 2064-03-09 01:59:59} {detroit y2038} { + clock format 2972271599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.589 {time zone boundary case 2064-03-09 03:00:00} {detroit y2038} { + clock format 2972271600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.590 {time zone boundary case 2064-03-09 03:00:01} {detroit y2038} { + clock format 2972271601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.591 {time zone boundary case 2064-11-02 01:59:59} {detroit y2038} { + clock format 2992831199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.592 {time zone boundary case 2064-11-02 01:00:00} {detroit y2038} { + clock format 2992831200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.593 {time zone boundary case 2064-11-02 01:00:01} {detroit y2038} { + clock format 2992831201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.594 {time zone boundary case 2065-03-08 01:59:59} {detroit y2038} { + clock format 3003721199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.595 {time zone boundary case 2065-03-08 03:00:00} {detroit y2038} { + clock format 3003721200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.596 {time zone boundary case 2065-03-08 03:00:01} {detroit y2038} { + clock format 3003721201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.597 {time zone boundary case 2065-11-01 01:59:59} {detroit y2038} { + clock format 3024280799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.598 {time zone boundary case 2065-11-01 01:00:00} {detroit y2038} { + clock format 3024280800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.599 {time zone boundary case 2065-11-01 01:00:01} {detroit y2038} { + clock format 3024280801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.600 {time zone boundary case 2066-03-14 01:59:59} {detroit y2038} { + clock format 3035775599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.601 {time zone boundary case 2066-03-14 03:00:00} {detroit y2038} { + clock format 3035775600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.602 {time zone boundary case 2066-03-14 03:00:01} {detroit y2038} { + clock format 3035775601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.603 {time zone boundary case 2066-11-07 01:59:59} {detroit y2038} { + clock format 3056335199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.604 {time zone boundary case 2066-11-07 01:00:00} {detroit y2038} { + clock format 3056335200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.605 {time zone boundary case 2066-11-07 01:00:01} {detroit y2038} { + clock format 3056335201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.606 {time zone boundary case 2067-03-13 01:59:59} {detroit y2038} { + clock format 3067225199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.607 {time zone boundary case 2067-03-13 03:00:00} {detroit y2038} { + clock format 3067225200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.608 {time zone boundary case 2067-03-13 03:00:01} {detroit y2038} { + clock format 3067225201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.609 {time zone boundary case 2067-11-06 01:59:59} {detroit y2038} { + clock format 3087784799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.610 {time zone boundary case 2067-11-06 01:00:00} {detroit y2038} { + clock format 3087784800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.611 {time zone boundary case 2067-11-06 01:00:01} {detroit y2038} { + clock format 3087784801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.612 {time zone boundary case 2068-03-11 01:59:59} {detroit y2038} { + clock format 3098674799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.613 {time zone boundary case 2068-03-11 03:00:00} {detroit y2038} { + clock format 3098674800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.614 {time zone boundary case 2068-03-11 03:00:01} {detroit y2038} { + clock format 3098674801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.615 {time zone boundary case 2068-11-04 01:59:59} {detroit y2038} { + clock format 3119234399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.616 {time zone boundary case 2068-11-04 01:00:00} {detroit y2038} { + clock format 3119234400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.617 {time zone boundary case 2068-11-04 01:00:01} {detroit y2038} { + clock format 3119234401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.618 {time zone boundary case 2069-03-10 01:59:59} {detroit y2038} { + clock format 3130124399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.619 {time zone boundary case 2069-03-10 03:00:00} {detroit y2038} { + clock format 3130124400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.620 {time zone boundary case 2069-03-10 03:00:01} {detroit y2038} { + clock format 3130124401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.621 {time zone boundary case 2069-11-03 01:59:59} {detroit y2038} { + clock format 3150683999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.622 {time zone boundary case 2069-11-03 01:00:00} {detroit y2038} { + clock format 3150684000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.623 {time zone boundary case 2069-11-03 01:00:01} {detroit y2038} { + clock format 3150684001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.624 {time zone boundary case 2070-03-09 01:59:59} {detroit y2038} { + clock format 3161573999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.625 {time zone boundary case 2070-03-09 03:00:00} {detroit y2038} { + clock format 3161574000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.626 {time zone boundary case 2070-03-09 03:00:01} {detroit y2038} { + clock format 3161574001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.627 {time zone boundary case 2070-11-02 01:59:59} {detroit y2038} { + clock format 3182133599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.628 {time zone boundary case 2070-11-02 01:00:00} {detroit y2038} { + clock format 3182133600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.629 {time zone boundary case 2070-11-02 01:00:01} {detroit y2038} { + clock format 3182133601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.630 {time zone boundary case 2071-03-08 01:59:59} {detroit y2038} { + clock format 3193023599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.631 {time zone boundary case 2071-03-08 03:00:00} {detroit y2038} { + clock format 3193023600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.632 {time zone boundary case 2071-03-08 03:00:01} {detroit y2038} { + clock format 3193023601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.633 {time zone boundary case 2071-11-01 01:59:59} {detroit y2038} { + clock format 3213583199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.634 {time zone boundary case 2071-11-01 01:00:00} {detroit y2038} { + clock format 3213583200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.635 {time zone boundary case 2071-11-01 01:00:01} {detroit y2038} { + clock format 3213583201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.636 {time zone boundary case 2072-03-13 01:59:59} {detroit y2038} { + clock format 3225077999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.637 {time zone boundary case 2072-03-13 03:00:00} {detroit y2038} { + clock format 3225078000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.638 {time zone boundary case 2072-03-13 03:00:01} {detroit y2038} { + clock format 3225078001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.639 {time zone boundary case 2072-11-06 01:59:59} {detroit y2038} { + clock format 3245637599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.640 {time zone boundary case 2072-11-06 01:00:00} {detroit y2038} { + clock format 3245637600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.641 {time zone boundary case 2072-11-06 01:00:01} {detroit y2038} { + clock format 3245637601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.642 {time zone boundary case 2073-03-12 01:59:59} {detroit y2038} { + clock format 3256527599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.643 {time zone boundary case 2073-03-12 03:00:00} {detroit y2038} { + clock format 3256527600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.644 {time zone boundary case 2073-03-12 03:00:01} {detroit y2038} { + clock format 3256527601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.645 {time zone boundary case 2073-11-05 01:59:59} {detroit y2038} { + clock format 3277087199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.646 {time zone boundary case 2073-11-05 01:00:00} {detroit y2038} { + clock format 3277087200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.647 {time zone boundary case 2073-11-05 01:00:01} {detroit y2038} { + clock format 3277087201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.648 {time zone boundary case 2074-03-11 01:59:59} {detroit y2038} { + clock format 3287977199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.649 {time zone boundary case 2074-03-11 03:00:00} {detroit y2038} { + clock format 3287977200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.650 {time zone boundary case 2074-03-11 03:00:01} {detroit y2038} { + clock format 3287977201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.651 {time zone boundary case 2074-11-04 01:59:59} {detroit y2038} { + clock format 3308536799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.652 {time zone boundary case 2074-11-04 01:00:00} {detroit y2038} { + clock format 3308536800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.653 {time zone boundary case 2074-11-04 01:00:01} {detroit y2038} { + clock format 3308536801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.654 {time zone boundary case 2075-03-10 01:59:59} {detroit y2038} { + clock format 3319426799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.655 {time zone boundary case 2075-03-10 03:00:00} {detroit y2038} { + clock format 3319426800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.656 {time zone boundary case 2075-03-10 03:00:01} {detroit y2038} { + clock format 3319426801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.657 {time zone boundary case 2075-11-03 01:59:59} {detroit y2038} { + clock format 3339986399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.658 {time zone boundary case 2075-11-03 01:00:00} {detroit y2038} { + clock format 3339986400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.659 {time zone boundary case 2075-11-03 01:00:01} {detroit y2038} { + clock format 3339986401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.660 {time zone boundary case 2076-03-08 01:59:59} {detroit y2038} { + clock format 3350876399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.661 {time zone boundary case 2076-03-08 03:00:00} {detroit y2038} { + clock format 3350876400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.662 {time zone boundary case 2076-03-08 03:00:01} {detroit y2038} { + clock format 3350876401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.663 {time zone boundary case 2076-11-01 01:59:59} {detroit y2038} { + clock format 3371435999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.664 {time zone boundary case 2076-11-01 01:00:00} {detroit y2038} { + clock format 3371436000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.665 {time zone boundary case 2076-11-01 01:00:01} {detroit y2038} { + clock format 3371436001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.666 {time zone boundary case 2077-03-14 01:59:59} {detroit y2038} { + clock format 3382930799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.667 {time zone boundary case 2077-03-14 03:00:00} {detroit y2038} { + clock format 3382930800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.668 {time zone boundary case 2077-03-14 03:00:01} {detroit y2038} { + clock format 3382930801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.669 {time zone boundary case 2077-11-07 01:59:59} {detroit y2038} { + clock format 3403490399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.670 {time zone boundary case 2077-11-07 01:00:00} {detroit y2038} { + clock format 3403490400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.671 {time zone boundary case 2077-11-07 01:00:01} {detroit y2038} { + clock format 3403490401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.672 {time zone boundary case 2078-03-13 01:59:59} {detroit y2038} { + clock format 3414380399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.673 {time zone boundary case 2078-03-13 03:00:00} {detroit y2038} { + clock format 3414380400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.674 {time zone boundary case 2078-03-13 03:00:01} {detroit y2038} { + clock format 3414380401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.675 {time zone boundary case 2078-11-06 01:59:59} {detroit y2038} { + clock format 3434939999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.676 {time zone boundary case 2078-11-06 01:00:00} {detroit y2038} { + clock format 3434940000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.677 {time zone boundary case 2078-11-06 01:00:01} {detroit y2038} { + clock format 3434940001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.678 {time zone boundary case 2079-03-12 01:59:59} {detroit y2038} { + clock format 3445829999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.679 {time zone boundary case 2079-03-12 03:00:00} {detroit y2038} { + clock format 3445830000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.680 {time zone boundary case 2079-03-12 03:00:01} {detroit y2038} { + clock format 3445830001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.681 {time zone boundary case 2079-11-05 01:59:59} {detroit y2038} { + clock format 3466389599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.682 {time zone boundary case 2079-11-05 01:00:00} {detroit y2038} { + clock format 3466389600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.683 {time zone boundary case 2079-11-05 01:00:01} {detroit y2038} { + clock format 3466389601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.684 {time zone boundary case 2080-03-10 01:59:59} {detroit y2038} { + clock format 3477279599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.685 {time zone boundary case 2080-03-10 03:00:00} {detroit y2038} { + clock format 3477279600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.686 {time zone boundary case 2080-03-10 03:00:01} {detroit y2038} { + clock format 3477279601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.687 {time zone boundary case 2080-11-03 01:59:59} {detroit y2038} { + clock format 3497839199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.688 {time zone boundary case 2080-11-03 01:00:00} {detroit y2038} { + clock format 3497839200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.689 {time zone boundary case 2080-11-03 01:00:01} {detroit y2038} { + clock format 3497839201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.690 {time zone boundary case 2081-03-09 01:59:59} {detroit y2038} { + clock format 3508729199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.691 {time zone boundary case 2081-03-09 03:00:00} {detroit y2038} { + clock format 3508729200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.692 {time zone boundary case 2081-03-09 03:00:01} {detroit y2038} { + clock format 3508729201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.693 {time zone boundary case 2081-11-02 01:59:59} {detroit y2038} { + clock format 3529288799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.694 {time zone boundary case 2081-11-02 01:00:00} {detroit y2038} { + clock format 3529288800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.695 {time zone boundary case 2081-11-02 01:00:01} {detroit y2038} { + clock format 3529288801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.696 {time zone boundary case 2082-03-08 01:59:59} {detroit y2038} { + clock format 3540178799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.697 {time zone boundary case 2082-03-08 03:00:00} {detroit y2038} { + clock format 3540178800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.698 {time zone boundary case 2082-03-08 03:00:01} {detroit y2038} { + clock format 3540178801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.699 {time zone boundary case 2082-11-01 01:59:59} {detroit y2038} { + clock format 3560738399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.700 {time zone boundary case 2082-11-01 01:00:00} {detroit y2038} { + clock format 3560738400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.701 {time zone boundary case 2082-11-01 01:00:01} {detroit y2038} { + clock format 3560738401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.702 {time zone boundary case 2083-03-14 01:59:59} {detroit y2038} { + clock format 3572233199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.703 {time zone boundary case 2083-03-14 03:00:00} {detroit y2038} { + clock format 3572233200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.704 {time zone boundary case 2083-03-14 03:00:01} {detroit y2038} { + clock format 3572233201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.705 {time zone boundary case 2083-11-07 01:59:59} {detroit y2038} { + clock format 3592792799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.706 {time zone boundary case 2083-11-07 01:00:00} {detroit y2038} { + clock format 3592792800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.707 {time zone boundary case 2083-11-07 01:00:01} {detroit y2038} { + clock format 3592792801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.708 {time zone boundary case 2084-03-12 01:59:59} {detroit y2038} { + clock format 3603682799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.709 {time zone boundary case 2084-03-12 03:00:00} {detroit y2038} { + clock format 3603682800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.710 {time zone boundary case 2084-03-12 03:00:01} {detroit y2038} { + clock format 3603682801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.711 {time zone boundary case 2084-11-05 01:59:59} {detroit y2038} { + clock format 3624242399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.712 {time zone boundary case 2084-11-05 01:00:00} {detroit y2038} { + clock format 3624242400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.713 {time zone boundary case 2084-11-05 01:00:01} {detroit y2038} { + clock format 3624242401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.714 {time zone boundary case 2085-03-11 01:59:59} {detroit y2038} { + clock format 3635132399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.715 {time zone boundary case 2085-03-11 03:00:00} {detroit y2038} { + clock format 3635132400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.716 {time zone boundary case 2085-03-11 03:00:01} {detroit y2038} { + clock format 3635132401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.717 {time zone boundary case 2085-11-04 01:59:59} {detroit y2038} { + clock format 3655691999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.718 {time zone boundary case 2085-11-04 01:00:00} {detroit y2038} { + clock format 3655692000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.719 {time zone boundary case 2085-11-04 01:00:01} {detroit y2038} { + clock format 3655692001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.720 {time zone boundary case 2086-03-10 01:59:59} {detroit y2038} { + clock format 3666581999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.721 {time zone boundary case 2086-03-10 03:00:00} {detroit y2038} { + clock format 3666582000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.722 {time zone boundary case 2086-03-10 03:00:01} {detroit y2038} { + clock format 3666582001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.723 {time zone boundary case 2086-11-03 01:59:59} {detroit y2038} { + clock format 3687141599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.724 {time zone boundary case 2086-11-03 01:00:00} {detroit y2038} { + clock format 3687141600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.725 {time zone boundary case 2086-11-03 01:00:01} {detroit y2038} { + clock format 3687141601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.726 {time zone boundary case 2087-03-09 01:59:59} {detroit y2038} { + clock format 3698031599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.727 {time zone boundary case 2087-03-09 03:00:00} {detroit y2038} { + clock format 3698031600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.728 {time zone boundary case 2087-03-09 03:00:01} {detroit y2038} { + clock format 3698031601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.729 {time zone boundary case 2087-11-02 01:59:59} {detroit y2038} { + clock format 3718591199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.730 {time zone boundary case 2087-11-02 01:00:00} {detroit y2038} { + clock format 3718591200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.731 {time zone boundary case 2087-11-02 01:00:01} {detroit y2038} { + clock format 3718591201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.732 {time zone boundary case 2088-03-14 01:59:59} {detroit y2038} { + clock format 3730085999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.733 {time zone boundary case 2088-03-14 03:00:00} {detroit y2038} { + clock format 3730086000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.734 {time zone boundary case 2088-03-14 03:00:01} {detroit y2038} { + clock format 3730086001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.735 {time zone boundary case 2088-11-07 01:59:59} {detroit y2038} { + clock format 3750645599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.736 {time zone boundary case 2088-11-07 01:00:00} {detroit y2038} { + clock format 3750645600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.737 {time zone boundary case 2088-11-07 01:00:01} {detroit y2038} { + clock format 3750645601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.738 {time zone boundary case 2089-03-13 01:59:59} {detroit y2038} { + clock format 3761535599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.739 {time zone boundary case 2089-03-13 03:00:00} {detroit y2038} { + clock format 3761535600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.740 {time zone boundary case 2089-03-13 03:00:01} {detroit y2038} { + clock format 3761535601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.741 {time zone boundary case 2089-11-06 01:59:59} {detroit y2038} { + clock format 3782095199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.742 {time zone boundary case 2089-11-06 01:00:00} {detroit y2038} { + clock format 3782095200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.743 {time zone boundary case 2089-11-06 01:00:01} {detroit y2038} { + clock format 3782095201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.744 {time zone boundary case 2090-03-12 01:59:59} {detroit y2038} { + clock format 3792985199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.745 {time zone boundary case 2090-03-12 03:00:00} {detroit y2038} { + clock format 3792985200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.746 {time zone boundary case 2090-03-12 03:00:01} {detroit y2038} { + clock format 3792985201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.747 {time zone boundary case 2090-11-05 01:59:59} {detroit y2038} { + clock format 3813544799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.748 {time zone boundary case 2090-11-05 01:00:00} {detroit y2038} { + clock format 3813544800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.749 {time zone boundary case 2090-11-05 01:00:01} {detroit y2038} { + clock format 3813544801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.750 {time zone boundary case 2091-03-11 01:59:59} {detroit y2038} { + clock format 3824434799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.751 {time zone boundary case 2091-03-11 03:00:00} {detroit y2038} { + clock format 3824434800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.752 {time zone boundary case 2091-03-11 03:00:01} {detroit y2038} { + clock format 3824434801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.753 {time zone boundary case 2091-11-04 01:59:59} {detroit y2038} { + clock format 3844994399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.754 {time zone boundary case 2091-11-04 01:00:00} {detroit y2038} { + clock format 3844994400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.755 {time zone boundary case 2091-11-04 01:00:01} {detroit y2038} { + clock format 3844994401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.756 {time zone boundary case 2092-03-09 01:59:59} {detroit y2038} { + clock format 3855884399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.757 {time zone boundary case 2092-03-09 03:00:00} {detroit y2038} { + clock format 3855884400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.758 {time zone boundary case 2092-03-09 03:00:01} {detroit y2038} { + clock format 3855884401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.759 {time zone boundary case 2092-11-02 01:59:59} {detroit y2038} { + clock format 3876443999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.760 {time zone boundary case 2092-11-02 01:00:00} {detroit y2038} { + clock format 3876444000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.761 {time zone boundary case 2092-11-02 01:00:01} {detroit y2038} { + clock format 3876444001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.762 {time zone boundary case 2093-03-08 01:59:59} {detroit y2038} { + clock format 3887333999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.763 {time zone boundary case 2093-03-08 03:00:00} {detroit y2038} { + clock format 3887334000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.764 {time zone boundary case 2093-03-08 03:00:01} {detroit y2038} { + clock format 3887334001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.765 {time zone boundary case 2093-11-01 01:59:59} {detroit y2038} { + clock format 3907893599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.766 {time zone boundary case 2093-11-01 01:00:00} {detroit y2038} { + clock format 3907893600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.767 {time zone boundary case 2093-11-01 01:00:01} {detroit y2038} { + clock format 3907893601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.768 {time zone boundary case 2094-03-14 01:59:59} {detroit y2038} { + clock format 3919388399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.769 {time zone boundary case 2094-03-14 03:00:00} {detroit y2038} { + clock format 3919388400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.770 {time zone boundary case 2094-03-14 03:00:01} {detroit y2038} { + clock format 3919388401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.771 {time zone boundary case 2094-11-07 01:59:59} {detroit y2038} { + clock format 3939947999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.772 {time zone boundary case 2094-11-07 01:00:00} {detroit y2038} { + clock format 3939948000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.773 {time zone boundary case 2094-11-07 01:00:01} {detroit y2038} { + clock format 3939948001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.774 {time zone boundary case 2095-03-13 01:59:59} {detroit y2038} { + clock format 3950837999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.775 {time zone boundary case 2095-03-13 03:00:00} {detroit y2038} { + clock format 3950838000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.776 {time zone boundary case 2095-03-13 03:00:01} {detroit y2038} { + clock format 3950838001 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.777 {time zone boundary case 2095-11-06 01:59:59} {detroit y2038} { + clock format 3971397599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.778 {time zone boundary case 2095-11-06 01:00:00} {detroit y2038} { + clock format 3971397600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.779 {time zone boundary case 2095-11-06 01:00:01} {detroit y2038} { + clock format 3971397601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.780 {time zone boundary case 2096-03-11 01:59:59} {detroit y2038} { + clock format 3982287599 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.781 {time zone boundary case 2096-03-11 03:00:00} {detroit y2038} { + clock format 3982287600 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.782 {time zone boundary case 2096-03-11 03:00:01} {detroit y2038} { + clock format 3982287601 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.783 {time zone boundary case 2096-11-04 01:59:59} {detroit y2038} { + clock format 4002847199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.784 {time zone boundary case 2096-11-04 01:00:00} {detroit y2038} { + clock format 4002847200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.785 {time zone boundary case 2096-11-04 01:00:01} {detroit y2038} { + clock format 4002847201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.786 {time zone boundary case 2097-03-10 01:59:59} {detroit y2038} { + clock format 4013737199 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.787 {time zone boundary case 2097-03-10 03:00:00} {detroit y2038} { + clock format 4013737200 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.788 {time zone boundary case 2097-03-10 03:00:01} {detroit y2038} { + clock format 4013737201 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.789 {time zone boundary case 2097-11-03 01:59:59} {detroit y2038} { + clock format 4034296799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.790 {time zone boundary case 2097-11-03 01:00:00} {detroit y2038} { + clock format 4034296800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.791 {time zone boundary case 2097-11-03 01:00:01} {detroit y2038} { + clock format 4034296801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.792 {time zone boundary case 2098-03-09 01:59:59} {detroit y2038} { + clock format 4045186799 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.793 {time zone boundary case 2098-03-09 03:00:00} {detroit y2038} { + clock format 4045186800 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.794 {time zone boundary case 2098-03-09 03:00:01} {detroit y2038} { + clock format 4045186801 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.795 {time zone boundary case 2098-11-02 01:59:59} {detroit y2038} { + clock format 4065746399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.796 {time zone boundary case 2098-11-02 01:00:00} {detroit y2038} { + clock format 4065746400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.797 {time zone boundary case 2098-11-02 01:00:01} {detroit y2038} { + clock format 4065746401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:01 -0500 EST} +test clock-5.798 {time zone boundary case 2099-03-08 01:59:59} {detroit y2038} { + clock format 4076636399 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0500 EST} +test clock-5.799 {time zone boundary case 2099-03-08 03:00:00} {detroit y2038} { + clock format 4076636400 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:00 -0400 EDT} +test clock-5.800 {time zone boundary case 2099-03-08 03:00:01} {detroit y2038} { + clock format 4076636401 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {03:00:01 -0400 EDT} +test clock-5.801 {time zone boundary case 2099-11-01 01:59:59} {detroit y2038} { + clock format 4097195999 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:59:59 -0400 EDT} +test clock-5.802 {time zone boundary case 2099-11-01 01:00:00} {detroit y2038} { + clock format 4097196000 -format {%H:%M:%S %z %Z} \ + -timezone :America/Detroit +} {01:00:00 -0500 EST} +test clock-5.803 {time zone boundary case 2099-11-01 01:00:01} {detroit y2038} { + clock format 4097196001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} # END testcases5 # Test input conversions. @@ -35327,30 +35329,12 @@ unset env(TZ) } } \ -result {-0500} -test clock-43.1 {regression test - mktime returning -1} \ - -setup { - if { [info exists env(TZ)] } { - set oldTZ $env(TZ) - } - set env(TZ) UTC0 - } \ - -body { - clock scan 1969-12-31T23:59:59 -format %Y-%m-%dT%T -timezone :localtime - } \ - -cleanup { - if { [info exists oldTZ] } { - set env(TZ) $oldTZ - unset oldTZ - } else { - unset env(TZ) - } - } \ - -result {-1} - +# 43.1 was a bad test - mktime returning -1 is an error according to posix. + test clock-44.1 {regression test - time zone name containing hyphen } \ -setup { if { [info exists env(TZ)] } { set oldTZ $env(TZ) } @@ -35372,10 +35356,125 @@ test clock-45.1 {regression test - time zone containing only two digits} \ -body { clock scan 1985-04-12T10:15:30+04 -format %Y-%m-%dT%H:%M:%S%Z } \ -result 482134530 + +test clock-46.1 {regression test - month zero} \ + -body { + clock scan 2004-00-00 -format %Y-%m-%d + } -result [clock scan 2003-11-30 -format %Y-%m-%d] +test clock-46.2 {regression test - month zero} \ + -body { + clock scan 20040000 + } -result [clock scan 2003-11-30 -format %Y-%m-%d] +test clock-46.3 {regression test - month thirteen} \ + -body { + clock scan 2004-13-01 -format %Y-%m-%d + } -result [clock scan 2005-01-01 -format %Y-%m-%d] +test clock-46.4 {regression test - month thirteen} \ + -body { + clock scan 20041301 + } -result [clock scan 2005-01-01 -format %Y-%m-%d] + +test clock-47.1 {regression test - four-digit time} { + clock scan 0012 +} [clock scan 0012 -format %H%M] +test clock-47.2 {regression test - four digit time} { + clock scan 0039 +} [clock scan 0039 -format %H%M] + +test clock-48.1 {Bug 1185933: 'i' destroyed by clock init} -setup { + interp create child +} -body { + interp eval child { + set i 12345 + clock format 0 + list [catch { set i } result] $result + } +} -cleanup { + interp delete child +} -result {0 12345} + +test clock-49.1 {regression test - localtime with negative arg (Bug 1237907)} \ + -body { + list [catch { + clock format -86400 -timezone :localtime -format %Y + } result] $result + } \ + -match regexp \ + -result {0 1969|1 {localtime failed \(clock value may be too large/small to represent\)}} + +test clock-49.2 {regression test - missing time zone file (Bug 1237907)} \ + -constraints win \ + -setup { + # override the registry so that the test takes place in New York time + namespace eval ::tcl::clock { + namespace import -force ::testClock::registry + } + if { [info exists env(TZ)] } { + set oldTZ $env(TZ) + unset env(TZ) + } + if { [info exists env(TCL_TZ)] } { + set oldTclTZ $env(TCL_TZ) + unset env(TCL_TZ) + } + # make it so New York time is a missing file + dict set ::tcl::clock::WinZoneInfo \ + {-18000 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} \ + :No/Such/File + ::tcl::clock::ClearCaches + } \ + -body { + list [::tcl::clock::GuessWindowsTimeZone] \ + [clock format 0 -locale system -format "%X %Z"] \ + [clock format -86400 -format "%Y"] + } \ + -cleanup { + # restore the registry and environment + namespace eval ::tcl::clock { + rename registry {} + } + if { [info exists oldTclTZ] } { + set env(TCL_TZ) $oldTclTZ + } + if { [info exists oldTZ] } { + set env(TZ) $oldTZ + } + # put New York back on the map + dict set ::tcl::clock::WinZoneInfo \ + {-18000 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} \ + :America/New_York + ::tcl::clock::ClearCaches + } \ + -result {<-0500>+05:00:00<-0400>+04:00:00,M4.1.0/02:00:00,M10.5.0/02:00:00 { 7:00:00 PM -0500} 1969} + +test clock-50.1 {format / scan -1 as a local time} { + if {[catch { + clock scan \ + [clock format -1 -format %Y%m%d%H%M%S -timezone :localtime] \ + -format %Y%m%d%H%M%S -timezone :localtime + } result]} { + if { [regexp " too large" $result] } { + set result -1 + } + } + set result +} -1 +test clock-50.2 {format / scan -2 as a local time} { + if {[catch { + clock scan \ + [clock format -2 -format %Y%m%d%H%M%S -timezone :localtime] \ + -format %Y%m%d%H%M%S -timezone :localtime + } result]} { + if { [regexp " too large" $result] } { + set result -2 + } + } + set result +} -2 # cleanup namespace delete ::testClock ::tcl::clock::ClearCaches Index: tests/cmdIL.test ================================================================== --- tests/cmdIL.test +++ tests/cmdIL.test @@ -6,11 +6,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: cmdIL.test,v 1.23 2004/10/14 17:20:11 dkf Exp $ +# RCS: @(#) $Id: cmdIL.test,v 1.23.2.2 2005/07/12 20:37:06 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -21,11 +21,11 @@ test cmdIL-1.1 {Tcl_LsortObjCmd procedure} { list [catch {lsort} msg] $msg } {1 {wrong # args: should be "lsort ?options? list"}} test cmdIL-1.2 {Tcl_LsortObjCmd procedure} { list [catch {lsort -foo {1 3 2 5}} msg] $msg -} {1 {bad option "-foo": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -indices, -integer, -real, or -unique}} +} {1 {bad option "-foo": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -indices, -integer, -nocase, -real, or -unique}} test cmdIL-1.3 {Tcl_LsortObjCmd procedure, default options} { lsort {d e c b a \{ d35 d300} } {a b c d d300 d35 e \{} test cmdIL-1.4 {Tcl_LsortObjCmd procedure, -ascii option} { lsort -integer -ascii {d e c b a d35 d300} @@ -57,11 +57,11 @@ test cmdIL-1.11 {Tcl_LsortObjCmd procedure, -index option} { list [catch {lsort -index {1 3 2 5}} msg] $msg } {1 {"-index" option must be followed by list index}} test cmdIL-1.12 {Tcl_LsortObjCmd procedure, -index option} { list [catch {lsort -index foo {1 3 2 5}} msg] $msg -} {1 {bad index "foo": must be integer or end?-integer?}} +} {1 {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?}} test cmdIL-1.13 {Tcl_LsortObjCmd procedure, -index option} { lsort -index end -integer {{2 25} {10 20 50 100} {3 16 42} 1} } {1 {2 25} {3 16 42} {10 20 50 100}} test cmdIL-1.14 {Tcl_LsortObjCmd procedure, -index option} { lsort -index 1 -integer {{1 25 100} {3 16 42} {10 20 50}} @@ -381,10 +381,16 @@ lsort -dictionary [list AA c CC `] } [list ` AA c CC] test cmdIL-4.33 {DictionaryCompare procedure, chars between Z and a in ASCII} { lsort -dictionary [list AA ! c CC `] } [list ! ` AA c CC] +test cmdIL-4.34 {SortCompare procedure, -ascii option with -nocase option} { + lsort -ascii -nocase {d e c b a d35 d300 100 20} +} {100 20 a b c d d300 d35 e} +test cmdIL-4.35 {SortCompare procedure, -ascii option with -nocase option} { + lsort -ascii -nocase {d E c B a D35 d300 100 20} +} {100 20 a B c d d300 D35 E} test cmdIL-5.1 {lsort with list style index} { lsort -ascii -decreasing -index {0 1} { {{Jim Alpha} 20000410} {{Joe Bravo} 19990320} Index: tests/compExpr-old.test ================================================================== --- tests/compExpr-old.test +++ tests/compExpr-old.test @@ -10,11 +10,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: compExpr-old.test,v 1.11 2004/10/31 18:46:55 dkf Exp $ +# RCS: @(#) $Id: compExpr-old.test,v 1.11.2.4 2005/08/15 18:14:01 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -23,10 +23,68 @@ testConstraint testmathfunctions 0 } else { testConstraint testmathfunctions 1 } +# 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 + } + } +} +::tcltest::testConstraint ieeeFloatingPoint [testIEEE] + # procedures used below proc put_hello_char {c} { global a append a [format %c $c] @@ -65,11 +123,13 @@ } proc do_twelve_days {} { global xxx set xxx "" 12days 1 1 1 - string length $xxx + set result [string length $xxx] + unset xxx + return $result } # start of tests catch {unset a b i x} @@ -141,14 +201,15 @@ test compExpr-old-2.4 {TclCompileExpr: numeric expr string rep == formatted int rep} { expr {0001} } 1 test compExpr-old-3.1 {CompileCondExpr: just lor expr} {expr 3||0} 1 -test compExpr-old-3.2 {CompileCondExpr: error in lor expr} { +test compExpr-old-3.2 {CompileCondExpr: error in lor expr} -body { catch {expr x||3} msg set msg -} {syntax error in expression "x||3": variable references require preceding $} +} -match glob \ + -result {syntax error in expression "x||3": * preceding $*} test compExpr-old-3.3 {CompileCondExpr: test true arm} {expr 3>2?44:66} 44 test compExpr-old-3.4 {CompileCondExpr: error compiling true arm} { catch {expr 3>2?2***3:66} msg set msg } {syntax error in expression "3>2?2***3:66": unexpected operator *} @@ -155,26 +216,23 @@ test compExpr-old-3.5 {CompileCondExpr: test false arm} {expr 2>3?44:66} 66 test compExpr-old-3.6 {CompileCondExpr: error compiling false arm} { catch {expr 2>3?44:2***3} msg set msg } {syntax error in expression "2>3?44:2***3": unexpected operator *} -test compExpr-old-3.7 {CompileCondExpr: long arms & nested cond exprs} {nonPortable} { - puts "Note: doing test compExpr-old-3.7 which can take several minutes to run" +test compExpr-old-3.7 {CompileCondExpr: long arms & nested cond exprs} { hello_world } {Hello world} -catch {unset xxx} -test compExpr-old-3.8 {CompileCondExpr: long arms & nested cond exprs} {nonPortable} { - puts "Note: doing test compExpr-old-3.8 which can take several minutes to run" +test compExpr-old-3.8 {CompileCondExpr: long arms & nested cond exprs} unix { + # Fails with a stack overflow on threaded Windows builds do_twelve_days } 2358 -catch {unset xxx} test compExpr-old-4.1 {CompileLorExpr: just land expr} {expr 1.3&&3.3} 1 -test compExpr-old-4.2 {CompileLorExpr: error in land expr} { +test compExpr-old-4.2 {CompileLorExpr: error in land expr} -body { catch {expr x&&3} msg set msg -} {syntax error in expression "x&&3": variable references require preceding $} +} -match glob -result {syntax error in expression "x&&3": * preceding $*} test compExpr-old-4.3 {CompileLorExpr: simple lor exprs} {expr 0||1.0} 1 test compExpr-old-4.4 {CompileLorExpr: simple lor exprs} {expr 3.0||0.0} 1 test compExpr-old-4.5 {CompileLorExpr: simple lor exprs} {expr 0||0||1} 1 test compExpr-old-4.6 {CompileLorExpr: error compiling lor arm} { catch {expr 2***3||4.0} msg @@ -192,14 +250,14 @@ set i 7 expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} } 1 test compExpr-old-5.1 {CompileLandExpr: just bitor expr} {expr 7|0x13} 23 -test compExpr-old-5.2 {CompileLandExpr: error in bitor expr} { +test compExpr-old-5.2 {CompileLandExpr: error in bitor expr} -body { catch {expr x|3} msg set msg -} {syntax error in expression "x|3": variable references require preceding $} +} -match glob -result {syntax error in expression "x|3": * preceding $*} test compExpr-old-5.3 {CompileLandExpr: simple land exprs} {expr 0&&1.0} 0 test compExpr-old-5.4 {CompileLandExpr: simple land exprs} {expr 0&&0} 0 test compExpr-old-5.5 {CompileLandExpr: simple land exprs} {expr 3.0&&1.2} 1 test compExpr-old-5.6 {CompileLandExpr: simple land exprs} {expr 1&&1&&2} 1 test compExpr-old-5.7 {CompileLandExpr: error compiling land arm} { @@ -218,26 +276,26 @@ set i 7 expr {[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]} } 1 test compExpr-old-6.1 {CompileBitXorExpr: just bitand expr} {expr 7&0x13} 3 -test compExpr-old-6.2 {CompileBitXorExpr: error in bitand expr} { +test compExpr-old-6.2 {CompileBitXorExpr: error in bitand expr} -body { catch {expr x|3} msg set msg -} {syntax error in expression "x|3": variable references require preceding $} +} -match glob -result {syntax error in expression "x|3": * preceding $*} test compExpr-old-6.3 {CompileBitXorExpr: simple bitxor exprs} {expr 7^0x13} 20 test compExpr-old-6.4 {CompileBitXorExpr: simple bitxor exprs} {expr 3^0x10} 19 test compExpr-old-6.5 {CompileBitXorExpr: simple bitxor exprs} {expr 0^7} 7 test compExpr-old-6.6 {CompileBitXorExpr: simple bitxor exprs} {expr -1^7} -8 test compExpr-old-6.7 {CompileBitXorExpr: error compiling bitxor arm} { catch {expr 2***3|6} msg set msg } {syntax error in expression "2***3|6": unexpected operator *} -test compExpr-old-6.8 {CompileBitXorExpr: error compiling bitxor arm} { +test compExpr-old-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body { catch {expr 2^x} msg set msg -} {syntax error in expression "2^x": variable references require preceding $} +} -match glob -result {syntax error in expression "2^x": * preceding $*} test compExpr-old-6.9 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {24.0^3}} msg] $msg } {1 {can't use floating-point value as operand of "^"}} test compExpr-old-6.10 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {"a"^"b"}} msg] $msg @@ -245,26 +303,26 @@ test compExpr-old-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0 test compExpr-old-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1 test compExpr-old-7.3 {CompileBitAndExpr: just equality expr} {expr 3.2!=2.2} 1 test compExpr-old-7.4 {CompileBitAndExpr: just equality expr} {expr {"abc" == "abd"}} 0 -test compExpr-old-7.5 {CompileBitAndExpr: error in equality expr} { +test compExpr-old-7.5 {CompileBitAndExpr: error in equality expr} -body { catch {expr x==3} msg set msg -} {syntax error in expression "x==3": variable references require preceding $} +} -match glob -result {syntax error in expression "x==3": * preceding $*} test compExpr-old-7.6 {CompileBitAndExpr: simple bitand exprs} {expr 7&0x13} 3 test compExpr-old-7.7 {CompileBitAndExpr: simple bitand exprs} {expr 0xf2&0x53} 82 test compExpr-old-7.8 {CompileBitAndExpr: simple bitand exprs} {expr 3&6} 2 test compExpr-old-7.9 {CompileBitAndExpr: simple bitand exprs} {expr -1&-7} -7 test compExpr-old-7.10 {CompileBitAndExpr: error compiling bitand arm} { catch {expr 2***3&6} msg set msg } {syntax error in expression "2***3&6": unexpected operator *} -test compExpr-old-7.11 {CompileBitAndExpr: error compiling bitand arm} { +test compExpr-old-7.11 {CompileBitAndExpr: error compiling bitand arm} -body { catch {expr 2&x} msg set msg -} {syntax error in expression "2&x": variable references require preceding $} +} -match glob -result {syntax error in expression "2&x": * preceding $*} test compExpr-old-7.12 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {24.0&3}} msg] $msg } {1 {can't use floating-point value as operand of "&"}} test compExpr-old-7.13 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {"a"&"b"}} msg] $msg @@ -272,26 +330,26 @@ test compExpr-old-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1 test compExpr-old-8.2 {CompileEqualityExpr: just relational expr} {expr 2<=2.1} 1 test compExpr-old-8.3 {CompileEqualityExpr: just relational expr} {expr 3.2>"2.2"} 1 test compExpr-old-8.4 {CompileEqualityExpr: just relational expr} {expr {"0y"<"0x12"}} 0 -test compExpr-old-8.5 {CompileEqualityExpr: error in relational expr} { +test compExpr-old-8.5 {CompileEqualityExpr: error in relational expr} -body { catch {expr x>3} msg set msg -} {syntax error in expression "x>3": variable references require preceding $} +} -match glob -result {syntax error in expression "x>3": * preceding $*} test compExpr-old-8.6 {CompileEqualityExpr: simple equality exprs} {expr 7==0x13} 0 test compExpr-old-8.7 {CompileEqualityExpr: simple equality exprs} {expr -0xf2!=0x53} 1 test compExpr-old-8.8 {CompileEqualityExpr: simple equality exprs} {expr {"12398712938788234-1298379" != ""}} 1 test compExpr-old-8.9 {CompileEqualityExpr: simple equality exprs} {expr -1!="abc"} 1 test compExpr-old-8.10 {CompileEqualityExpr: error compiling equality arm} { catch {expr 2***3==6} msg set msg } {syntax error in expression "2***3==6": unexpected operator *} -test compExpr-old-8.11 {CompileEqualityExpr: error compiling equality arm} { +test compExpr-old-8.11 {CompileEqualityExpr: error compiling equality arm} -body { catch {expr 2!=x} msg set msg -} {syntax error in expression "2!=x": variable references require preceding $} +} -match glob -result {syntax error in expression "2!=x": * preceding $*} test compExpr-old-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12 test compExpr-old-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63 test compExpr-old-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1 @@ -298,52 +356,54 @@ test compExpr-old-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8 # The following test is different for 32-bit versus 64-bit # architectures because LONG_MIN is different -if {int(0x80000000) > 0} { - test compExpr-old-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} { - expr {1<<63} - } -9223372036854775808 -} else { - test compExpr-old-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} { - expr {1<<31} - } -2147483648 -} -test compExpr-old-9.6 {CompileRelationalExpr: error in shift expr} { +testConstraint longIs32bit [expr {int(0x80000000) < 0}] +testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] + +test compExpr-old-9.5a {CompileRelationalExpr: shift expr producing LONG_MIN} longIs64bit { + expr {1<<63} +} -9223372036854775808 + +test compExpr-old-9.5b {CompileRelationalExpr: shift expr producing LONG_MIN} longIs32bit { + expr {1<<31} +} -2147483648 + +test compExpr-old-9.6 {CompileRelationalExpr: error in shift expr} -body { catch {expr x>>3} msg set msg -} {syntax error in expression "x>>3": variable references require preceding $} +} -match glob -result {syntax error in expression "x>>3": * preceding $*} test compExpr-old-9.7 {CompileRelationalExpr: simple relational exprs} {expr 0xff>=+0x3} 1 test compExpr-old-9.8 {CompileRelationalExpr: simple relational exprs} {expr -0xf2<0x3} 1 test compExpr-old-9.9 {CompileRelationalExpr: error compiling relational arm} { catch {expr 2***3>6} msg set msg } {syntax error in expression "2***3>6": unexpected operator *} -test compExpr-old-9.10 {CompileRelationalExpr: error compiling relational arm} { +test compExpr-old-9.10 {CompileRelationalExpr: error compiling relational arm} -body { catch {expr 2>0x3} 31 test compExpr-old-10.7 {CompileShiftExpr: simple shift exprs} {expr -0xf2<<0x3} -1936 test compExpr-old-10.8 {CompileShiftExpr: error compiling shift arm} { catch {expr 2***3>>6} msg set msg } {syntax error in expression "2***3>>6": unexpected operator *} -test compExpr-old-10.9 {CompileShiftExpr: error compiling shift arm} { +test compExpr-old-10.9 {CompileShiftExpr: error compiling shift arm} -body { catch {expr 2<>43}} msg] $msg } {1 {can't use floating-point value as operand of ">>"}} test compExpr-old-10.11 {CompileShiftExpr: runtime error} { list [catch {expr {"a"<<"b"}} msg] $msg @@ -351,55 +411,58 @@ test compExpr-old-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8 test compExpr-old-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1 test compExpr-old-11.3 {CompileAddExpr: just multiply expr} {expr -1/2} -1 test compExpr-old-11.4 {CompileAddExpr: just multiply expr} {expr 7891%0123} 6 -test compExpr-old-11.5 {CompileAddExpr: error in multiply expr} { +test compExpr-old-11.5 {CompileAddExpr: error in multiply expr} -body { catch {expr x*3} msg set msg -} {syntax error in expression "x*3": variable references require preceding $} +} -match glob -result {syntax error in expression "x*3": * preceding $*} test compExpr-old-11.6 {CompileAddExpr: simple add exprs} {expr 0xff++0x3} 258 test compExpr-old-11.7 {CompileAddExpr: simple add exprs} {expr -0xf2--0x3} -239 test compExpr-old-11.8 {CompileAddExpr: error compiling add arm} { catch {expr 2***3+6} msg set msg } {syntax error in expression "2***3+6": unexpected operator *} -test compExpr-old-11.9 {CompileAddExpr: error compiling add arm} { +test compExpr-old-11.9 {CompileAddExpr: error compiling add arm} -body { catch {expr 2-x} msg set msg -} {syntax error in expression "2-x": variable references require preceding $} +} -match glob -result {syntax error in expression "2-x": * preceding $*} test compExpr-old-11.10 {CompileAddExpr: runtime error} { list [catch {expr {24.0+"xx"}} msg] $msg } {1 {can't use non-numeric string as operand of "+"}} test compExpr-old-11.11 {CompileAddExpr: runtime error} { list [catch {expr {"a"-"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "-"}} test compExpr-old-11.12 {CompileAddExpr: runtime error} { list [catch {expr {3/0}} msg] $msg } {1 {divide by zero}} -test compExpr-old-11.13 {CompileAddExpr: runtime error} { +test compExpr-old-11.13a {CompileAddExpr: runtime error} ieeeFloatingPoint { + list [catch {expr {2.3/0.0}} msg] $msg +} {0 Inf} +test compExpr-old-11.13b {CompileAddExpr: runtime error} !ieeeFloatingPoint { list [catch {expr {2.3/0.0}} msg] $msg } {1 {divide by zero}} test compExpr-old-12.1 {CompileMultiplyExpr: just unary expr} {expr ~4} -5 test compExpr-old-12.2 {CompileMultiplyExpr: just unary expr} {expr --5} 5 test compExpr-old-12.3 {CompileMultiplyExpr: just unary expr} {expr !27} 0 test compExpr-old-12.4 {CompileMultiplyExpr: just unary expr} {expr ~0xff00ff} -16711936 -test compExpr-old-12.5 {CompileMultiplyExpr: error in unary expr} { +test compExpr-old-12.5 {CompileMultiplyExpr: error in unary expr} -body { catch {expr ~x} msg set msg -} {syntax error in expression "~x": variable references require preceding $} +} -match glob -result {syntax error in expression "~x": * preceding $*} test compExpr-old-12.6 {CompileMultiplyExpr: simple multiply exprs} {expr 0xff*0x3} 765 test compExpr-old-12.7 {CompileMultiplyExpr: simple multiply exprs} {expr -0xf2%-0x3} -2 test compExpr-old-12.8 {CompileMultiplyExpr: error compiling multiply arm} { catch {expr 2*3%%6} msg set msg } {syntax error in expression "2*3%%6": unexpected operator %} -test compExpr-old-12.9 {CompileMultiplyExpr: error compiling multiply arm} { +test compExpr-old-12.9 {CompileMultiplyExpr: error compiling multiply arm} -body { catch {expr 2*x} msg set msg -} {syntax error in expression "2*x": variable references require preceding $} +} -match glob -result {syntax error in expression "2*x": * preceding $*} test compExpr-old-12.10 {CompileMultiplyExpr: runtime error} { list [catch {expr {24.0*"xx"}} msg] $msg } {1 {can't use non-numeric string as operand of "*"}} test compExpr-old-12.11 {CompileMultiplyExpr: runtime error} { list [catch {expr {"a"/"b"}} msg] $msg @@ -410,14 +473,14 @@ test compExpr-old-13.3 {CompileUnaryExpr: unary exprs} {expr +--++36} 36 test compExpr-old-13.4 {CompileUnaryExpr: unary exprs} {expr !2} 0 test compExpr-old-13.5 {CompileUnaryExpr: unary exprs} {expr +--+-62.0} -62.0 test compExpr-old-13.6 {CompileUnaryExpr: unary exprs} {expr !0.0} 1 test compExpr-old-13.7 {CompileUnaryExpr: unary exprs} {expr !0xef} 0 -test compExpr-old-13.8 {CompileUnaryExpr: error compiling unary expr} { +test compExpr-old-13.8 {CompileUnaryExpr: error compiling unary expr} -body { catch {expr ~x} msg set msg -} {syntax error in expression "~x": variable references require preceding $} +} -match glob -result {syntax error in expression "~x": * preceding $*} test compExpr-old-13.9 {CompileUnaryExpr: error compiling unary expr} { catch {expr !1.x} msg set msg } {syntax error in expression "!1.x": extra tokens at end of expression} test compExpr-old-13.10 {CompileUnaryExpr: runtime error} { @@ -527,11 +590,11 @@ format %.6g [expr pow(2.0+0.1,3.0+0.1)] } 9.97424 test compExpr-old-14.27 {CompilePrimaryExpr: error in math function primary} -body { catch {expr sinh::(2.0)} msg set errorInfo -} -match glob -result {syntax error in expression "sinh::(2.0)": expected parenthesis enclosing function arguments +} -match glob -result {syntax error in expression "sinh::(2.0)": * function arguments* while *ing "expr sinh::(2.0)"} test compExpr-old-14.28 {CompilePrimaryExpr: subexpression primary} { expr 2+(3*4) } 14 @@ -559,35 +622,35 @@ "expr @"} test compExpr-old-15.1 {CompileMathFuncCall: missing parenthesis} -body { catch {expr sinh2.0)} msg set errorInfo -} -match glob -result {syntax error in expression "sinh2.0)": variable references require preceding $ +} -match glob -result {syntax error in expression "sinh2.0)": * preceding $* while *ing "expr sinh2.0)"} test compExpr-old-15.2 {CompileMathFuncCall: unknown math function} -body { catch {expr whazzathuh(1)} msg set errorInfo -} -match glob -result {unknown math function "whazzathuh" +} -match glob -result {* "*whazzathuh" while *ing "expr whazzathuh(1)"} test compExpr-old-15.3 {CompileMathFuncCall: too many arguments} -body { catch {expr sin(1,2,3)} msg set errorInfo -} -match glob -result {too many arguments for math function +} -match glob -result {too many arguments for math function* while *ing "expr sin(1,2,3)"} test compExpr-old-15.4 {CompileMathFuncCall: ')' found before last required arg} -body { catch {expr sin()} msg set errorInfo -} -match glob -result {too few arguments for math function +} -match glob -result {too few arguments for math function* while *ing "expr sin()"} test compExpr-old-15.5 {CompileMathFuncCall: too few arguments} -body { catch {expr pow(1)} msg set errorInfo -} -match glob -result {too few arguments for math function +} -match glob -result {too few arguments for math function* while *ing "expr pow(1)"} test compExpr-old-15.6 {CompileMathFuncCall: missing ')'} -body { catch {expr sin(1} msg set errorInfo Index: tests/compExpr.test ================================================================== --- tests/compExpr.test +++ tests/compExpr.test @@ -6,11 +6,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: compExpr.test,v 1.8 2004/09/26 16:36:05 msofer Exp $ +# RCS: @(#) $Id: compExpr.test,v 1.8.2.1 2005/03/15 19:41:45 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } @@ -27,13 +27,14 @@ expr 1+2 } 3 test compExpr-1.2 {TclCompileExpr procedure, error parsing expr} { list [catch {expr 1+2+} msg] $msg } {1 {syntax error in expression "1+2+": premature end of expression}} -test compExpr-1.3 {TclCompileExpr procedure, error compiling expr} { +test compExpr-1.3 {TclCompileExpr procedure, error compiling expr} -body { list [catch {expr "foo(123)"} msg] $msg -} {1 {unknown math function "foo"}} +} -match glob -result {1 {* "*foo"}} + test compExpr-1.4 {TclCompileExpr procedure, expr has no operators} { set a {000123} expr {$a} } 83 @@ -92,13 +93,13 @@ expr {5*6} } 30 test compExpr-2.15 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, math function found} { format %.6g [expr {sin(2.0)}] } 0.909297 -test compExpr-2.16 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, math function not found} { +test compExpr-2.16 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, math function not found} -body { list [catch {expr {fred(2.0)}} msg] $msg -} {1 {unknown math function "fred"}} +} -match glob -result {1 {* "*fred"}} test compExpr-2.17 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { expr {4*2} } 8 test compExpr-2.18 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { expr {4/2} @@ -287,34 +288,34 @@ } {0 15} test compExpr-5.1 {CompileMathFuncCall procedure, math function found} { format %.6g [expr atan2(1.0, 2.0)] } 0.463648 -test compExpr-5.2 {CompileMathFuncCall procedure, math function not found} { +test compExpr-5.2 {CompileMathFuncCall procedure, math function not found} -body { list [catch {expr {do_it()}} msg] $msg -} {1 {unknown math function "do_it"}} +} -match glob -result {1 {* "*do_it"}} test compExpr-5.3 {CompileMathFuncCall: call registered math function} testmathfunctions { expr 3*T1()-1 } 368 test compExpr-5.4 {CompileMathFuncCall: call registered math function} testmathfunctions { expr T2()*3 } 1035 -test compExpr-5.5 {CompileMathFuncCall procedure, too few arguments} { +test compExpr-5.5 {CompileMathFuncCall procedure, too few arguments} -body { list [catch {expr {atan2(1.0)}} msg] $msg -} {1 {too few arguments for math function}} +} -match glob -result {1 {too few arguments for math function*}} test compExpr-5.6 {CompileMathFuncCall procedure, complex argument} { format %.6g [expr pow(2.1, 27.5-(24.4*(5%2)))] } 9.97424 test compExpr-5.7 {CompileMathFuncCall procedure, error in argument} { list [catch {expr {sinh(2.*)}} msg] $msg } {1 {syntax error in expression "sinh(2.*)": unexpected close parenthesis}} -test compExpr-5.8 {CompileMathFuncCall procedure, too many arguments} { +test compExpr-5.8 {CompileMathFuncCall procedure, too many arguments} -body { list [catch {expr {sinh(2.0, 3.0)}} msg] $msg -} {1 {too many arguments for math function}} -test compExpr-5.9 {CompileMathFuncCall procedure, too many arguments} { +} -match glob -result {1 {too many arguments for math function*}} +test compExpr-5.9 {CompileMathFuncCall procedure, too many arguments} -body { list [catch {expr {0 <= rand(5.2)}} msg] $msg -} {1 {too many arguments for math function}} +} -match glob -result {1 {too many arguments for math function*}} test compExpr-6.1 {LogSyntaxError procedure, error in expr longer than 60 chars} { list [catch {expr {(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)/} -1 foo 3} msg] $msg } {1 {syntax error in expression "(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+012...": extra tokens at end of expression}} Index: tests/compile.test ================================================================== --- tests/compile.test +++ tests/compile.test @@ -9,11 +9,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: compile.test,v 1.34 2004/12/02 11:10:49 dkf Exp $ +# RCS: @(#) $Id: compile.test,v 1.34.2.3 2005/05/05 17:56:15 kennykb Exp $ package require tcltest 2 namespace import -force ::tcltest::* testConstraint exec [llength [info commands exec]] @@ -234,19 +234,19 @@ set r [list foobar] # command that will add error to result lindex a bogus } list [catch {p} msg] $msg -} {1 {bad index "bogus": must be integer or end?-integer?}} +} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} test compile-11.2 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { proc p {} { set r [list foobar] ; string index a bogus } list [catch {p} msg] $msg -} {1 {bad index "bogus": must be integer or end?-integer?}} +} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} test compile-11.3 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { proc p {} { set r [list foobar] ; string index a 09 } list [catch {p} msg] $msg -} {1 {bad index "09": must be integer or end?-integer? (looks like invalid octal number)}} +} {1 {bad index "09": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}} test compile-11.4 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { proc p {} { set r [list foobar] ; array set var {one two many} } list [catch {p} msg] $msg } {1 {list must have an even number of elements}} test compile-11.5 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { @@ -255,18 +255,18 @@ } {1 {can't read "foo": no such variable}} test compile-11.6 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { proc p {} { set r [list foobar] ; incr foo bogus } list [catch {p} msg] $msg } {1 {expected integer but got "bogus"}} -test compile-11.7 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { +test compile-11.7 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { proc p {} { set r [list foobar] ; expr !a } list [catch {p} msg] $msg -} {1 {syntax error in expression "!a": variable references require preceding $}} -test compile-11.8 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { +} -match glob -result {1 {syntax error in expression "!a": * preceding $*}} +test compile-11.8 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { proc p {} { set r [list foobar] ; expr {!a} } list [catch {p} msg] $msg -} {1 {syntax error in expression "!a": variable references require preceding $}} +} -match glob -result {1 {syntax error in expression "!a": * preceding $*}} test compile-11.9 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { proc p {} { set r [list foobar] ; llength "\{" } list [catch {p} msg] $msg } {1 {unmatched open brace in list}} @@ -318,11 +318,11 @@ puts $array([expr {a+2}]) } crash } -returnCodes error -cleanup { rename crash {} -} -result {syntax error in expression "a+2": variable references require preceding $} +} -match glob -result {syntax error in expression "a+2": * preceding $*} test compile-12.4 {TclCleanupLiteralTable segfault} -body { # Tcl Bug 1001997 # Here, we're trying to test a case that causes a crash in # TclCleanupLiteralTable. The conditions that we're trying to # establish are: @@ -584,14 +584,45 @@ } -cleanup { namespace delete x } -returnCodes ok -result {syntax {}{}} } ;# End of noComp loop + +# These tests are messy because it wrecks the interpreter it runs in! +# They demonstrate issues arising from [FRQ 1101710] +test compile-17.1 {Command interpretation binding for compiled code} -constraints knownBug -setup { + set i [interp create] +} -body { + $i eval { + if 1 { + expr [ + proc expr args {return substituted} + format {[subst compiled]} + ] + } + } +} -cleanup { + interp delete $i +} -result substituted +test compile-17.2 {Command interpretation binding for non-compiled code} -setup { + set i [interp create] +} -body { + $i eval { + if 1 { + [subst expr] [ + proc expr args {return substituted} + format {[subst compiled]} + ] + } + } +} -cleanup { + interp delete $i +} -result substituted # cleanup catch {rename p ""} catch {namespace delete test_ns_compile} catch {unset x} catch {unset y} catch {unset a} ::tcltest::cleanupTests return Index: tests/dict.test ================================================================== --- tests/dict.test +++ tests/dict.test @@ -7,11 +7,11 @@ # # Copyright (c) 2003 Donal K. Fellows # 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.12 2004/10/19 22:20:05 dkf Exp $ +# RCS: @(#) $Id: dict.test,v 1.12.2.2 2005/08/18 21:19:17 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -304,10 +304,28 @@ set dictVar(block) {} set result [list [catch {dict incr dictVar a} msg] $msg] catch {unset dictVar} set result } {1 {can't set "dictVar": variable is array}} +test dict-11.16 {dict incr command: compilation} { + proc dicttest {} { + set v {a 0 b 0 c 0} + dict incr v a + dict incr v b 1 + dict incr v c 2 + dict incr v d 3 + list [dict get $v a] [dict get $v b] [dict get $v c] [dict get $v d] + } + 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} dict lappend dictv a } {a a} @@ -509,10 +527,21 @@ catch {lappend result $accum($k)} } catch {unset accum} set result } {a1 a2 b1 b2 bar foo : a, b, c, d, foo, bar,} +test dict-14.16 {dict for command in compilation context} { + proc dicttest {} { + set res {x x x x x x} + dict for {k v} {a 0 b 1 c 2 d 3 e 4 f 5} { + lset res $v $k + continue + } + return $res + } + dicttest +} {a b c d e f} # There's probably a lot more tests to add here. Really ought to use # a coverage tool for this job... test dict-15.1 {dict set command} { set dictVar {} @@ -966,10 +995,23 @@ dict update a b v1 d v2 f v3 { set v3 g } getOrder $a b d f } {b c d e f g 3} +test dict-21.13 {dict update command: compilation} { + proc dicttest {d} { + while 1 { + dict update d a alpha b beta { + set beta $alpha + unset alpha + break + } + } + return $d + } + getOrder [dicttest {a 1 c 2}] b c +} {b 1 c 2 2} test dict-22.1 {dict with command} -body { dict with } -returnCodes 1 -result {wrong # args: should be "dict with dictVar ?key ...? script"} test dict-22.2 {dict with command} -body { Index: tests/encoding.test ================================================================== --- tests/encoding.test +++ tests/encoding.test @@ -6,11 +6,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: encoding.test,v 1.21 2004/11/30 19:34:51 dgp Exp $ +# RCS: @(#) $Id: encoding.test,v 1.21.2.1 2005/04/25 21:37:28 kennykb Exp $ package require tcltest 2 namespace import -force ::tcltest::* proc toutf {args} { @@ -553,10 +553,23 @@ # Difference should be empty. set diff } {} } } + +testConstraint testgetdefenc [llength [info commands testgetdefenc]] + +test encoding-26.0 {Tcl_GetDefaultEncodingDir} -constraints { + testgetdefenc +} -setup { + set origDir [testgetdefenc] + testsetdefenc slappy +} -body { + testgetdefenc +} -cleanup { + testsetdefenc $origDir +} -result slappy file delete {expand}[glob -directory [temporaryDirectory] *.chars *.tcltestout] # ===> Cut here <=== # EscapeFreeProc, GetTableEncoding, unilen Index: tests/env.test ================================================================== --- tests/env.test +++ tests/env.test @@ -9,11 +9,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: env.test,v 1.20 2004/08/26 17:37:12 das Exp $ +# RCS: @(#) $Id: env.test,v 1.20.2.2 2005/10/08 13:44:38 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -74,11 +74,11 @@ lrem names HOME lrem names COMSPEC lrem names ComSpec lrem names "" } - foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY SHLIB_PATH DYLD_LIBRARY_PATH __CF_USER_TEXT_ENCODING } { + foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY SHLIB_PATH DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH __CF_USER_TEXT_ENCODING } { lrem names $name } foreach p $names { puts "$p=$env($p)" } @@ -104,11 +104,11 @@ } # Added the following lines so that child tcltest can actually find its # library if the initial tcltest is run from a non-standard place. # ('saved' env vars) -foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH DISPLAY SHLIB_PATH DYLD_LIBRARY_PATH} { +foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH DISPLAY SHLIB_PATH DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH} { if {[info exists env2($name)]} { set env($name) $env2($name); } } @@ -230,10 +230,17 @@ test env-5.5 {corner cases - cannot have null entries on Windows} {win} { set env() a catch {set env()} } {1} +test env-6.1 {corner cases - add lots of env variables} {} { + set size [array size env] + for {set i 0} {$i < 100} {incr i} { + set env(BOGUS$i) $i + } + expr {[array size env] - $size} +} 100 # Restore the environment variables at the end of the test. foreach name [array names env] { unset env($name) Index: tests/error.test ================================================================== --- tests/error.test +++ tests/error.test @@ -9,11 +9,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: error.test,v 1.12 2004/09/30 23:06:49 dgp Exp $ +# RCS: @(#) $Id: error.test,v 1.12.2.1 2005/08/02 18:16:23 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } @@ -66,14 +66,18 @@ test error-1.7 {simple errors from commands} { catch {catch a b c d} b set b } {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"} -test error-1.8 {simple errors from commands} {nonPortable} { +test error-1.8 {simple errors from commands} { # This test is non-portable: it generates a memory fault on # machines like DEC Alphas (infinite recursion overflows # stack?) + # + # That claims sounds like a bug to be fixed rather than a portability + # problem. Anyhow, I believe it's out of date (bug's been fixed) so + # this test is re-enabled. proc p {} { uplevel 1 catch p error } p Index: tests/eval.test ================================================================== --- tests/eval.test +++ tests/eval.test @@ -9,11 +9,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: eval.test,v 1.6 2004/05/19 12:23:13 dkf Exp $ +# RCS: @(#) $Id: eval.test,v 1.6.2.1 2005/09/09 18:48:40 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } @@ -55,9 +55,32 @@ invoked from within \"eval { set a 1 error \"test error\" }\"" + +test eval-3.1 {eval and pure lists} { + eval [list list 1 2 3 4 5] +} {1 2 3 4 5} +test eval-3.2 {concatenating eval and pure lists} { + eval [list list 1] [list 2 3 4 5] +} {1 2 3 4 5} +test eval-3.3 {eval and canonical lists} { + set cmd [list list 1 2 3 4 5] + # Force existance of utf-8 rep + set dummy($cmd) $cmd + unset dummy($cmd) + eval $cmd +} {1 2 3 4 5} +test eval-3.4 {concatenating eval and canonical lists} { + set cmd [list list 1] + set cmd2 [list 2 3 4 5] + # Force existance of utf-8 rep + set dummy($cmd) $cmd + set dummy($cmd2) $cmd2 + unset dummy($cmd) dummy($cmd2) + eval $cmd $cmd2 +} {1 2 3 4 5} # cleanup ::tcltest::cleanupTests return Index: tests/exec.test ================================================================== --- tests/exec.test +++ tests/exec.test @@ -9,11 +9,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: exec.test,v 1.22 2004/07/02 23:31:30 hobbs Exp $ +# RCS: @(#) $Id: exec.test,v 1.22.2.1 2005/08/02 18:16:23 dgp Exp $ package require tcltest 2 namespace import -force ::tcltest::* # All tests require the "exec" command. @@ -597,10 +597,38 @@ close $fout set res [list [catch {exec cat $path(fooblah)} msg] $msg] removeFile $f set res } {0 contents} + +# Note that this test cannot be adapted to work on Windows; that platform has +# no kernel support for an analog of O_APPEND. +test exec-19.1 {exec >> uses O_APPEND} { + -constraints {exec unix} + -setup { + set tmpfile [makeFile {0} tmpfile.exec-19.1] + } + -body { + # Note that we have to allow for the current contents of the + # temporary file, which is why the result is 14 and not 12 + exec /bin/sh -c \ + {for a in 1 2 3; do sleep 1; echo $a; done} >>$tmpfile & + exec /bin/sh -c \ + {for a in a b c; do sleep 1; echo $a; done} >>$tmpfile & + # The above two shell invokations take about 3 seconds to + # finish, so allow 5s (in case the machine is busy) + after 5000 + # Check that no bytes have got lost through mixups with + # overlapping appends, which is only guaranteed to work when + # we set O_APPEND on the file descriptor in the [exec >>...] + file size $tmpfile + } + -cleanup { + removeFile $tmpfile + } + -result 14 +} # cleanup foreach file {script gorp.file gorp.file2 echo cat wc sh sleep exit err} { removeFile $file Index: tests/expr-old.test ================================================================== --- tests/expr-old.test +++ tests/expr-old.test @@ -11,11 +11,11 @@ # Copyright (c) 1998-2000 by Scriptics Corporation. # # 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.22 2004/11/03 22:12:51 dgp Exp $ +# RCS: @(#) $Id: expr-old.test,v 1.22.2.11 2005/10/08 13:44:38 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 namespace import -force ::tcltest::* } @@ -24,10 +24,68 @@ testConstraint testmathfunctions 0 } else { testConstraint testmathfunctions 1 } +# 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 + } + } +} +::tcltest::testConstraint ieeeFloatingPoint [testIEEE] + # First, test all of the integer operators individually. test expr-old-1.1 {integer operators} {expr -4} -4 test expr-old-1.2 {integer operators} {expr -(1+4)} -5 test expr-old-1.3 {integer operators} {expr ~3} -4 @@ -89,11 +147,11 @@ # Check the floating-point operators individually, along with # automatic conversion to integers where needed. test expr-old-2.1 {floating-point operators} {expr -4.2} -4.2 -test expr-old-2.2 {floating-point operators} {expr -(1.1+4.2)} -5.3 +test expr-old-2.2 {floating-point operators} {expr -(1.125+4.25)} -5.375 test expr-old-2.3 {floating-point operators} {expr +5.7} 5.7 test expr-old-2.4 {floating-point operators} {expr +--+-62.0} -62.0 test expr-old-2.5 {floating-point operators} {expr !2.1} 0 test expr-old-2.6 {floating-point operators} {expr !0.0} 1 test expr-old-2.7 {floating-point operators} {expr 4.2*6.3} 26.46 @@ -192,16 +250,12 @@ test expr-old-4.24 {string operators} {expr {"" eq ""}} 1 test expr-old-4.25 {string operators} {expr {"abd" ne ""}} 1 test expr-old-4.26 {string operators} {expr {"" ne ""}} 0 test expr-old-4.27 {string operators} {expr {"longerstring" eq "shorter"}} 0 test expr-old-4.28 {string operators} {expr {"longerstring" ne "shorter"}} 1 - -# The following tests are non-portable because on some systems "+" -# and "-" can be parsed as numbers. - -test expr-old-4.29 {string operators} {nonPortable} {expr {"0" == "+"}} 0 -test expr-old-4.30 {string operators} {nonPortable} {expr {"0" == "-"}} 0 +test expr-old-4.29 {string operators} {expr {"0" == "+"}} 0 +test expr-old-4.30 {string operators} {expr {"0" == "-"}} 0 test expr-old-4.31 {string operators} {expr {1?"foo":"bar"}} foo test expr-old-4.32 {string operators} {expr {0?"foo":"bar"}} bar # Operators that aren't legal on string operands. @@ -426,11 +480,11 @@ test expr-old-25.14 {type conversions} {expr {"24.1a" > 24.1}} 1 test expr-old-25.15 {type conversions} {expr {24.1 > "24.1a"}} 0 test expr-old-25.16 {type conversions} {expr 2+2.5} 4.5 test expr-old-25.17 {type conversions} {expr 2+2.5} 4.5 test expr-old-25.18 {type conversions} {expr 2.0e2} 200.0 -test expr-old-25.19 {type conversions} {eformat} {expr 2.0e15} 2e+15 +test expr-old-25.19 {type conversions} {expr 2.0e15} 2000000000000000.0 test expr-old-25.20 {type conversions} {expr 10.0} 10.0 # Various error conditions. test expr-old-26.1 {error conditions} { @@ -460,40 +514,43 @@ list [catch {expr 2/0} msg] $msg $errorCode } {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} test expr-old-26.9 {error conditions} { list [catch {expr 2%0} msg] $msg $errorCode } {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} -test expr-old-26.10 {error conditions} { +test expr-old-26.10a {error conditions} !ieeeFloatingPoint { list [catch {expr 2.0/0.0} msg] $msg $errorCode } {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} +test expr-old-26.10b {error conditions} ieeeFloatingPoint { + list [catch {expr 2.0/0.0} msg] $msg +} {0 Inf} test expr-old-26.11 {error conditions} { list [catch {expr 2#} msg] $msg } {1 {syntax error in expression "2#": extra tokens at end of expression}} -test expr-old-26.12 {error conditions} { +test expr-old-26.12 {error conditions} -body { list [catch {expr a.b} msg] $msg -} {1 {syntax error in expression "a.b": variable references require preceding $}} +} -match glob -result {1 {syntax error in expression "a.b": * preceding $*}} test expr-old-26.13 {error conditions} { list [catch {expr {"a"/"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "/"}} test expr-old-26.14 {error conditions} { list [catch {expr 2:3} msg] $msg } {1 {syntax error in expression "2:3": extra tokens at end of expression}} -test expr-old-26.15 {error conditions} { +test expr-old-26.15 {error conditions} -body { list [catch {expr a@b} msg] $msg -} {1 {syntax error in expression "a@b": variable references require preceding $}} +} -match glob -result {1 {syntax error in expression "a@b": * preceding $*}} test expr-old-26.16 {error conditions} { list [catch {expr a[b} msg] $msg } {1 {missing close-bracket}} -test expr-old-26.17 {error conditions} { +test expr-old-26.17 {error conditions} -body { list [catch {expr a`b} msg] $msg -} {1 {syntax error in expression "a`b": variable references require preceding $}} +} -match glob -result {1 {syntax error in expression "a`b": * preceding $*}} test expr-old-26.18 {error conditions} { list [catch {expr \"a\"\{b} msg] $msg } {1 syntax\ error\ in\ expression\ \"\"a\"\{b\":\ extra\ tokens\ at\ end\ of\ expression} -test expr-old-26.19 {error conditions} { +test expr-old-26.19 {error conditions} -body { list [catch {expr a} msg] $msg -} {1 {syntax error in expression "a": variable references require preceding $}} +} -match glob -result {1 {syntax error in expression "a": * preceding $*}} test expr-old-26.20 {error conditions} { list [catch expr msg] $msg } {1 {wrong # args: should be "expr arg ?arg ...?"}} # Cancelled evaluation. @@ -537,16 +594,16 @@ } {0 1} test expr-old-27.10 {cancelled evaluation} { set x -1.0 list [catch {expr {($x > 0) ? round(log($x)) : 0}} msg] $msg } {0 0} -test expr-old-27.11 {cancelled evaluation} { +test expr-old-27.11 {cancelled evaluation} -body { list [catch {expr {0 && foo}} msg] $msg -} {1 {syntax error in expression "0 && foo": variable references require preceding $}} -test expr-old-27.12 {cancelled evaluation} { +} -match glob -result {1 {syntax error in expression "0 && foo": * preceding $*}} +test expr-old-27.12 {cancelled evaluation} -body { list [catch {expr {0 ? 1 : foo}} msg] $msg -} {1 {syntax error in expression "0 ? 1 : foo": variable references require preceding $}} +} -match glob -result {1 {syntax error in expression "0 ? 1 : foo": * preceding $*}} # Tcl_ExprBool as used in "if" statements test expr-old-28.1 {Tcl_ExprBoolean usage} { set a 1 @@ -725,21 +782,17 @@ } {4} test expr-old-32.24 {math functions in expressions} { format %.6g [expr abs(66)] } {66} -# The following test is different for 32-bit versus 64-bit architectures. - -if {int(0x80000000) > 0} { - test expr-old-32.25a {math functions in expressions} {nonPortable} { - list [catch {expr abs(0x8000000000000000)} msg] $msg - } {1 {integer value too large to represent}} -} else { - test expr-old-32.25b {math functions in expressions} {nonPortable} { - list [catch {expr abs(0x80000000)} msg] $msg - } {1 {integer value too large to represent}} -} +test expr-old-32.25a {math functions in expressions} { + list [catch {expr abs(0x8000000000000000)} msg] $msg +} {1 {integer value too large to represent}} + +test expr-old-32.25b {math functions in expressions} { + expr abs(0x80000000) +} 2147483648 test expr-old-32.26 {math functions in expressions} { expr double(1) } {1.0} test expr-old-32.27 {math functions in expressions} { @@ -797,16 +850,16 @@ expr T2()*3 } 1035 test expr-old-32.45 {math functions in expressions} { expr (0 <= rand()) && (rand() < 1) } {1} -test expr-old-32.46 {math functions in expressions} { +test expr-old-32.46 {math functions in expressions} -body { list [catch {expr rand(24)} msg] $msg -} {1 {too many arguments for math function}} -test expr-old-32.47 {math functions in expressions} { +} -match glob -result {1 {too many arguments for math function*}} +test expr-old-32.47 {math functions in expressions} -body { list [catch {expr srand()} msg] $msg -} {1 {too few arguments for math function}} +} -match glob -result {1 {too few arguments for math function*}} test expr-old-32.48 {math functions in expressions} { list [catch {expr srand(3.79)} msg] $msg } {1 {can't use floating-point value as argument to srand}} test expr-old-32.49 {math functions in expressions} { list [catch {expr srand("")} msg] $msg @@ -839,46 +892,52 @@ } 5.0 test expr-old-33.4 {conversions and fancy args to math functions} { format %.6g [expr cos(acos(0.1))] } 0.1 -test expr-old-34.1 {errors in math functions} { +test expr-old-34.1 {errors in math functions} -body { list [catch {expr func_2(1.0)} msg] $msg -} {1 {unknown math function "func_2"}} -test expr-old-34.2 {errors in math functions} { +} -match glob -result {1 {* "*func_2"}} +test expr-old-34.2 {errors in math functions} -body { list [catch {expr func|(1.0)} msg] $msg -} {1 {syntax error in expression "func|(1.0)": variable references require preceding $}} +} -match glob -result {1 {syntax error in expression "func|(1.0)": * preceding $*}} test expr-old-34.3 {errors in math functions} { list [catch {expr {hypot("a b", 2.0)}} msg] $msg -} {1 {argument to math function didn't have numeric value}} +} {1 {expected floating-point number but got "a b"}} test expr-old-34.4 {errors in math functions} { list [catch {expr hypot(1.0 2.0)} msg] $msg } {1 {syntax error in expression "hypot(1.0 2.0)": missing close parenthesis at end of function call}} test expr-old-34.5 {errors in math functions} { list [catch {expr hypot(1.0, 2.0} msg] $msg } {1 {syntax error in expression "hypot(1.0, 2.0": missing close parenthesis at end of function call}} test expr-old-34.6 {errors in math functions} { list [catch {expr hypot(1.0 ,} msg] $msg } {1 {syntax error in expression "hypot(1.0 ,": premature end of expression}} -test expr-old-34.7 {errors in math functions} { +test expr-old-34.7 {errors in math functions} -body { list [catch {expr hypot(1.0)} msg] $msg -} {1 {too few arguments for math function}} -test expr-old-34.8 {errors in math functions} { +} -match glob -result {1 {too few arguments for math function*}} +test expr-old-34.8 {errors in math functions} -body { list [catch {expr hypot(1.0, 2.0, 3.0)} msg] $msg -} {1 {too many arguments for math function}} +} -match glob -result {1 {too many arguments for math function*}} test expr-old-34.9 {errors in math functions} { list [catch {expr acos(-2.0)} msg] $msg $errorCode } {1 {domain error: argument not in valid range} {ARITH DOMAIN {domain error: argument not in valid range}}} -test expr-old-34.10 {errors in math functions} {nonPortable} { - list [catch {expr pow(-3, 1000001)} msg] $msg $errorCode -} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}} -test expr-old-34.11 {errors in math functions} { +test expr-old-34.10 {errors in math functions} { + list [catch {expr pow(-3, 1000001)} msg] $msg +} {0 -Inf} +test expr-old-34.11a {errors in math functions} !ieeeFloatingPoint { list [catch {expr pow(3, 1000001)} msg] $msg $errorCode } {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}} -test expr-old-34.12 {errors in math functions} { +test expr-old-34.11b {errors in math functions} ieeeFloatingPoint { + list [catch {expr pow(3, 1000001)} msg] $msg +} {0 Inf} +test expr-old-34.12a {errors in math functions} !ieeeFloatingPoint { list [catch {expr -14.0*exp(100000)} msg] $msg $errorCode } {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}} +test expr-old-34.12b {errors in math functions} ieeeFloatingPoint { + list [catch {expr -14.0*exp(100000)} msg] $msg +} {0 -Inf} test expr-old-34.13 {errors in math functions} { list [catch {expr int(1.0e30)} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} test expr-old-34.14 {errors in math functions} { list [catch {expr int(-1.0e30)} msg] $msg $errorCode @@ -887,13 +946,14 @@ list [catch {expr round(1.0e30)} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} test expr-old-34.16 {errors in math functions} { list [catch {expr round(-1.0e30)} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} -test expr-old-34.17 {errors in math functions} testmathfunctions { - list [catch {expr T1(4)} msg] $msg -} {1 {too many arguments for math function}} +test expr-old-34.17 {errors in math functions} -constraints testmathfunctions \ + -body { + list [catch {expr T1(4)} msg] $msg + } -match glob -result {1 {too many arguments for math function*}} test expr-old-36.1 {ExprLooksLikeInt procedure} -body { expr 0289 } -returnCodes error -match glob -result {*invalid octal number*} test expr-old-36.2 {ExprLooksLikeInt procedure} { @@ -913,22 +973,22 @@ } {0 23} test expr-old-36.6 {ExprLooksLikeInt procedure} { set x { -22} list [catch {expr {$x+1}} msg] $msg } {0 -21} -test expr-old-36.7 {ExprLooksLikeInt procedure} {nonPortable unix} { +test expr-old-36.7 {ExprLooksLikeInt procedure} { list [catch {expr nan} msg] $msg } {1 {domain error: argument not in valid range}} test expr-old-36.8 {ExprLooksLikeInt procedure} { list [catch {expr 78e1} msg] $msg } {0 780.0} test expr-old-36.9 {ExprLooksLikeInt procedure} { list [catch {expr 24E1} msg] $msg } {0 240.0} -test expr-old-36.10 {ExprLooksLikeInt procedure} {nonPortable unix} { - list [catch {expr 78e} msg] $msg -} {1 {syntax error in expression "78e"}} +test expr-old-36.10 {ExprLooksLikeInt procedure} -body { + expr 78e +} -returnCodes error -match glob -result {syntax error in expression "78e"*} # test for [Bug #542588] test expr-old-36.11 {ExprLooksLikeInt procedure} { # define a "too large integer"; this one works also for 64bit arith set x 665802003400000000000000 @@ -956,20 +1016,125 @@ set x " 0xffffffffffffffffffffffffffffffffffffff " list [catch {expr {$x+1}} msg] $msg } {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 + testexprlong 4+1 } {This is a result: 5} +#Check for [Bug 1109484] +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 } {5 10.2 1 {syntax error in expression "1+": premature end of expression}} +test expr-old-38.2 {Tcl_ExprString} testexprstring { + # This one is "magical" + testexprstring {} +} 0 +test expr-old-38.3 {Tcl_ExprString} -constraints testexprstring -body { + testexprstring { } +} -returnCodes error -match glob -result * # # Test for bug #908375: rounding numbers that do not fit in a # long but do fit in a wide # @@ -982,10 +1147,52 @@ } set x } {1 1} unset -nocomplain x y +# +# TIP #255 min and max math functions +# + +test expr-old-40.1 {min math function} -body { + expr {min(0)} +} -result 0 +test expr-old-40.2 {min math function} -body { + expr {min(0.0)} +} -result 0.0 +test expr-old-40.3 {min math function} -body { + list [catch {expr {min()}} msg] $msg +} -result {1 {too few arguments to math function "min"}} +test expr-old-40.4 {min math function} -body { + expr {min(wide(-1) << 30, 4.5, -10)} +} -result [expr {wide(-1) << 30}] +test expr-old-40.5 {min math function} -body { + list [catch {expr {min("a", 0)}} msg] $msg +} -result {1 {argument to math function didn't have numeric value}} +test expr-old-40.6 {min math function} -body { + expr {min(300, "0xFF")} +} -result 255 + +test expr-old-41.1 {max math function} -body { + expr {max(0)} +} -result 0 +test expr-old-41.2 {max math function} -body { + expr {max(0.0)} +} -result 0.0 +test expr-old-41.3 {max math function} -body { + list [catch {expr {max()}} msg] $msg +} -result {1 {too few arguments to math function "max"}} +test expr-old-41.4 {max math function} -body { + expr {max(wide(1) << 30, 4.5, -10)} +} -result [expr {wide(1) << 30}] +test expr-old-41.5 {max math function} -body { + list [catch {expr {max("a", 0)}} msg] $msg +} -result {1 {argument to math function didn't have numeric value}} +test expr-old-41.6 {max math function} -body { + expr {max(200, "0xFF")} +} -result 255 + # Special test for Pentium arithmetic bug of 1994: if {(4195835.0 - (4195835.0/3145727.0)*3145727.0) == 256.0} { puts "Warning: this machine contains a defective Pentium processor" puts "that performs arithmetic incorrectly. I recommend that you" @@ -994,5 +1201,9 @@ } # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: Index: tests/expr.test ================================================================== --- tests/expr.test +++ tests/expr.test @@ -8,21 +8,91 @@ # Copyright (c) 1998-2000 by Scriptics Corporation. # # 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.30 2004/11/01 14:38:26 dkf Exp $ +# RCS: @(#) $Id: expr.test,v 1.30.2.24 2005/08/29 18:38:45 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + package require tcltest 2.1 namespace import -force ::tcltest::* } testConstraint testmathfunctions [expr { ([catch {expr T1()} msg] != 1) || ($msg ne {unknown math function "T1"}) }] +# Determine if "long int" type is a 32 bit number and if the wide +# type is a 64 bit number on this machine. + +testConstraint longIs32bit [expr {int(0x80000000) < 0}] +testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] +testConstraint wideIs64bit \ + [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] + +# 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) + binary scan \x00\x00\x00\x00\x00\x00\xf8\xff 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) + binary scan \xff\xf8\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(-NaN) + set ieeeValues(littleEndian) 0 + return 1 + } + default { + return 0 + } + } +} + +testConstraint ieeeFloatingPoint [testIEEE] # procedures used below proc put_hello_char {c} { global a append a [format %c $c] @@ -61,11 +131,13 @@ } proc do_twelve_days {} { global xxx set xxx "" 12days 1 1 1 - string length $xxx + set result [string length $xxx] + unset xxx + return $result } # start of tests catch {unset a b i x} @@ -142,14 +214,14 @@ test expr-2.4 {TclCompileExpr: numeric expr string rep == formatted int rep} { expr {0001} } 1 test expr-3.1 {CompileCondExpr: just lor expr} {expr 3||0} 1 -test expr-3.2 {CompileCondExpr: error in lor expr} { +test expr-3.2 {CompileCondExpr: error in lor expr} -body { catch {expr x||3} msg set msg -} {syntax error in expression "x||3": variable references require preceding $} +} -match glob -result {syntax error in expression "x||3": * preceding $*} test expr-3.3 {CompileCondExpr: test true arm} {expr 3>2?44:66} 44 test expr-3.4 {CompileCondExpr: error compiling true arm} { catch {expr 3>2?2***3:66} msg set msg } {syntax error in expression "3>2?2***3:66": unexpected operator *} @@ -156,26 +228,23 @@ test expr-3.5 {CompileCondExpr: test false arm} {expr 2>3?44:66} 66 test expr-3.6 {CompileCondExpr: error compiling false arm} { catch {expr 2>3?44:2***3} msg set msg } {syntax error in expression "2>3?44:2***3": unexpected operator *} -test expr-3.7 {CompileCondExpr: long arms & nested cond exprs} {unix nonPortable} { - puts "Note: doing test expr-3.7 which can take several minutes to run" +test expr-3.7 {CompileCondExpr: long arms & nested cond exprs} { hello_world } {Hello world} -catch {unset xxx} -test expr-3.8 {CompileCondExpr: long arms & nested cond exprs} {unix nonPortable} { - puts "Note: doing test expr-3.8 which can take several minutes to run" +test expr-3.8 {CompileCondExpr: long arms & nested cond exprs} unix { + # Fails with a stack overflow on threaded Windows builds do_twelve_days } 2358 -catch {unset xxx} test expr-4.1 {CompileLorExpr: just land expr} {expr 1.3&&3.3} 1 -test expr-4.2 {CompileLorExpr: error in land expr} { +test expr-4.2 {CompileLorExpr: error in land expr} -body { catch {expr x&&3} msg set msg -} {syntax error in expression "x&&3": variable references require preceding $} +} -match glob -result {syntax error in expression "x&&3": *preceding $*} test expr-4.3 {CompileLorExpr: simple lor exprs} {expr 0||1.0} 1 test expr-4.4 {CompileLorExpr: simple lor exprs} {expr 3.0||0.0} 1 test expr-4.5 {CompileLorExpr: simple lor exprs} {expr 0||0||1} 1 test expr-4.6 {CompileLorExpr: error compiling lor arm} { catch {expr 2***3||4.0} msg @@ -191,16 +260,25 @@ test expr-4.9 {CompileLorExpr: long lor arm} { set a "abcdefghijkl" set i 7 expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} } 1 +test expr-4.10 {CompileLorExpr: error compiling ! operand} { + list [catch {expr {!"a"}} msg] $msg +} {1 {can't use non-numeric string as operand of "!"}} +test expr-4.11 {CompileLorExpr: error compiling land arms} { + list [catch {expr {"a"||0}} msg] $msg +} {1 {expected boolean value but got "a"}} +test expr-4.12 {CompileLorExpr: error compiling land arms} { + list [catch {expr {0||"a"}} msg] $msg +} {1 {expected boolean value but got "a"}} test expr-5.1 {CompileLandExpr: just bitor expr} {expr 7|0x13} 23 -test expr-5.2 {CompileLandExpr: error in bitor expr} { +test expr-5.2 {CompileLandExpr: error in bitor expr} -body { catch {expr x|3} msg set msg -} {syntax error in expression "x|3": variable references require preceding $} +} -match glob -result {syntax error in expression "x|3": * preceding $*} test expr-5.3 {CompileLandExpr: simple land exprs} {expr 0&&1.0} 0 test expr-5.4 {CompileLandExpr: simple land exprs} {expr 0&&0} 0 test expr-5.5 {CompileLandExpr: simple land exprs} {expr 3.0&&1.2} 1 test expr-5.6 {CompileLandExpr: simple land exprs} {expr 1&&1&&2} 1 test expr-5.7 {CompileLandExpr: error compiling land arm} { @@ -219,26 +297,26 @@ set i 7 expr {[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]} } 1 test expr-6.1 {CompileBitXorExpr: just bitand expr} {expr 7&0x13} 3 -test expr-6.2 {CompileBitXorExpr: error in bitand expr} { +test expr-6.2 {CompileBitXorExpr: error in bitand expr} -body { catch {expr x|3} msg set msg -} {syntax error in expression "x|3": variable references require preceding $} +} -match glob -result {syntax error in expression "x|3": * preceding $*} test expr-6.3 {CompileBitXorExpr: simple bitxor exprs} {expr 7^0x13} 20 test expr-6.4 {CompileBitXorExpr: simple bitxor exprs} {expr 3^0x10} 19 test expr-6.5 {CompileBitXorExpr: simple bitxor exprs} {expr 0^7} 7 test expr-6.6 {CompileBitXorExpr: simple bitxor exprs} {expr -1^7} -8 test expr-6.7 {CompileBitXorExpr: error compiling bitxor arm} { catch {expr 2***3|6} msg set msg } {syntax error in expression "2***3|6": unexpected operator *} -test expr-6.8 {CompileBitXorExpr: error compiling bitxor arm} { +test expr-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body { catch {expr 2^x} msg set msg -} {syntax error in expression "2^x": variable references require preceding $} +} -match glob -result {syntax error in expression "2^x": * preceding $**} test expr-6.9 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {24.0^3}} msg] $msg } {1 {can't use floating-point value as operand of "^"}} test expr-6.10 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {"a"^"b"}} msg] $msg @@ -246,135 +324,168 @@ test expr-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0 test expr-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1 test expr-7.3 {CompileBitAndExpr: just equality expr} {expr 3.2!=2.2} 1 test expr-7.4 {CompileBitAndExpr: just equality expr} {expr {"abc" == "abd"}} 0 -test expr-7.5 {CompileBitAndExpr: error in equality expr} { +test expr-7.5 {CompileBitAndExpr: error in equality expr} -body { catch {expr x==3} msg set msg -} {syntax error in expression "x==3": variable references require preceding $} +} -match glob -result {syntax error in expression "x==3": * preceding $*} test expr-7.6 {CompileBitAndExpr: simple bitand exprs} {expr 7&0x13} 3 test expr-7.7 {CompileBitAndExpr: simple bitand exprs} {expr 0xf2&0x53} 82 test expr-7.8 {CompileBitAndExpr: simple bitand exprs} {expr 3&6} 2 test expr-7.9 {CompileBitAndExpr: simple bitand exprs} {expr -1&-7} -7 test expr-7.10 {CompileBitAndExpr: error compiling bitand arm} { catch {expr 2***3&6} msg set msg } {syntax error in expression "2***3&6": unexpected operator *} -test expr-7.11 {CompileBitAndExpr: error compiling bitand arm} { +test expr-7.11 {CompileBitAndExpr: error compiling bitand arm} -body { catch {expr 2&x} msg set msg -} {syntax error in expression "2&x": variable references require preceding $} +} -match glob -result {syntax error in expression "2&x": * preceding $*} test expr-7.12 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {24.0&3}} msg] $msg } {1 {can't use floating-point value as operand of "&"}} test expr-7.13 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {"a"&"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "&"}} test expr-7.14 {CompileBitAndExpr: equality expr} {expr 3eq2} 0 test expr-7.18 {CompileBitAndExpr: equality expr} {expr {"abc" eq "abd"}} 0 -test expr-7.20 {CompileBitAndExpr: error in equality expr} { +test expr-7.20 {CompileBitAndExpr: error in equality expr} -body { catch {expr xne3} msg set msg -} {syntax error in expression "xne3": variable references require preceding $} +} -match glob -result {syntax error in expression "xne3": * preceding $*} test expr-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1 test expr-8.2 {CompileEqualityExpr: just relational expr} {expr 2<=2.1} 1 test expr-8.3 {CompileEqualityExpr: just relational expr} {expr 3.2>"2.2"} 1 test expr-8.4 {CompileEqualityExpr: just relational expr} {expr {"0y"<"0x12"}} 0 -test expr-8.5 {CompileEqualityExpr: error in relational expr} { +test expr-8.5 {CompileEqualityExpr: error in relational expr} -body { catch {expr x>3} msg set msg -} {syntax error in expression "x>3": variable references require preceding $} +} -match glob -result {syntax error in expression "x>3": * preceding $*} test expr-8.6 {CompileEqualityExpr: simple equality exprs} {expr 7==0x13} 0 test expr-8.7 {CompileEqualityExpr: simple equality exprs} {expr -0xf2!=0x53} 1 test expr-8.8 {CompileEqualityExpr: simple equality exprs} {expr {"12398712938788234-1298379" != ""}} 1 test expr-8.9 {CompileEqualityExpr: simple equality exprs} {expr -1!="abc"} 1 test expr-8.10 {CompileEqualityExpr: error compiling equality arm} { catch {expr 2***3==6} msg set msg } {syntax error in expression "2***3==6": unexpected operator *} -test expr-8.11 {CompileEqualityExpr: error compiling equality arm} { +test expr-8.11 {CompileEqualityExpr: error compiling equality arm} -body { catch {expr 2!=x} msg set msg -} {syntax error in expression "2!=x": variable references require preceding $} +} -match glob -result {syntax error in expression "2!=x": * preceding $*} test expr-8.12 {CompileBitAndExpr: equality expr} {expr {"a"eq"a"}} 1 test expr-8.13 {CompileBitAndExpr: equality expr} {expr {"\374" eq "ü"}} 1 test expr-8.14 {CompileBitAndExpr: equality expr} {expr 3eq2} 0 test expr-8.15 {CompileBitAndExpr: equality expr} {expr 2.0eq2} 0 test expr-8.16 {CompileBitAndExpr: equality expr} {expr 3.2ne2.2} 1 test expr-8.17 {CompileBitAndExpr: equality expr} {expr 01eq1} 0 test expr-8.18 {CompileBitAndExpr: equality expr} {expr {"abc" eq "abd"}} 0 test expr-8.19 {CompileBitAndExpr: equality expr} {expr {"abc" ne "abd"}} 1 -test expr-8.20 {CompileBitAndExpr: error in equality expr} { +test expr-8.20 {CompileBitAndExpr: error in equality expr} -body { catch {expr x ne3} msg set msg -} {syntax error in expression "x ne3": variable references require preceding $} -test expr-8.21 {CompileBitAndExpr: error in equality expr} { +} -match glob -result {syntax error in expression "x ne3": * preceding $*} +test expr-8.21 {CompileBitAndExpr: error in equality expr} -body { # These should be ""ed to avoid the error catch {expr a eq b} msg set msg -} {syntax error in expression "a eq b": variable references require preceding $} +} -match glob -result {syntax error in expression "a eq b": * preceding $*} test expr-8.22 {CompileBitAndExpr: error in equality expr} { catch {expr {false eqfalse}} msg set msg } {syntax error in expression "false eqfalse": extra tokens at end of expression} test expr-8.23 {CompileBitAndExpr: error in equality expr} { catch {expr {false nefalse}} msg set msg } {syntax error in expression "false nefalse": extra tokens at end of expression} +test expr-8.24 {CompileEqualityExpr: simple equality exprs} { + set x 12398712938788234 + expr {$x == 100} +} 0 +test expr-8.25 {CompileEqualityExpr: simple equality exprs} { + expr {"0x12 " == "0x12"} +} 1 +test expr-8.26 {CompileEqualityExpr: simple equality exprs} { + expr {"0x12 " eq "0x12"} +} 0 +test expr-8.27 {CompileEqualityExpr: simple equality exprs} { + expr {"1.0e100000000" == "0.0"} +} 0 +test expr-8.28 {CompileEqualityExpr: just relational expr} { + expr {"0y" == "0x0"} +} 0 +test expr-8.29 {CompileEqualityExpr: just relational expr} { + # Compare original strings from variables. + set v1 "0y" + set v2 "0x12" + expr {$v1 < $v2} +} 0 +test expr-8.30 {CompileEqualityExpr: simple equality exprs} { + expr {"fake" != "bob"} +} 1 +test expr-8.31 {expr edge cases} { + list [catch {expr {1e}} err] $err +} {1 {syntax error in expression "1e": extra tokens at end of expression}} +test expr-8.32 {expr edge cases} { + list [catch {expr {1E}} err] $err +} {1 {syntax error in expression "1E": extra tokens at end of expression}} +test expr-8.33 {expr edge cases} { + list [catch {expr {1e+}} err] $err +} {1 {syntax error in expression "1e+": extra tokens at end of expression}} +test expr-8.34 {expr edge cases} { + list [catch {expr {1E+}} err] $err +} {1 {syntax error in expression "1E+": extra tokens at end of expression}} +test expr-8.35 {expr edge cases} { + list [catch {expr {1ea}} err] $err +} {1 {syntax error in expression "1ea": extra tokens at end of expression}} test expr-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12 test expr-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63 test expr-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1 test expr-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8 - -# The following test is different for 32-bit versus 64-bit -# architectures because LONG_MIN is different - -if {0x80000000 > 0} { - test expr-9.5a {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} { - expr {1<<63} - } -9223372036854775808 -} else { - test expr-9.5b {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} { - expr {1<<31} - } -2147483648 -} -test expr-9.6 {CompileRelationalExpr: error in shift expr} { +test expr-9.5a {CompileRelationalExpr: shift expr producing LONG_MIN} longIs64bit { + expr {1<<63} +} -9223372036854775808 +test expr-9.5b {CompileRelationalExpr: shift expr producing LONG_MIN} longIs32bit { + expr {1<<31} +} -2147483648 +test expr-9.6 {CompileRelationalExpr: error in shift expr} -body { catch {expr x>>3} msg set msg -} {syntax error in expression "x>>3": variable references require preceding $} +} -match glob -result {syntax error in expression "x>>3": * preceding $*} test expr-9.7 {CompileRelationalExpr: simple relational exprs} {expr 0xff>=+0x3} 1 test expr-9.8 {CompileRelationalExpr: simple relational exprs} {expr -0xf2<0x3} 1 test expr-9.9 {CompileRelationalExpr: error compiling relational arm} { catch {expr 2***3>6} msg set msg } {syntax error in expression "2***3>6": unexpected operator *} -test expr-9.10 {CompileRelationalExpr: error compiling relational arm} { +test expr-9.10 {CompileRelationalExpr: error compiling relational arm} -body { catch {expr 2>0x3} 31 test expr-10.7 {CompileShiftExpr: simple shift exprs} {expr -0xf2<<0x3} -1936 test expr-10.8 {CompileShiftExpr: error compiling shift arm} { catch {expr 2***3>>6} msg set msg } {syntax error in expression "2***3>>6": unexpected operator *} -test expr-10.9 {CompileShiftExpr: error compiling shift arm} { +test expr-10.9 {CompileShiftExpr: error compiling shift arm} -body { catch {expr 2<>43}} msg] $msg } {1 {can't use floating-point value as operand of ">>"}} test expr-10.11 {CompileShiftExpr: runtime error} { list [catch {expr {"a"<<"b"}} msg] $msg @@ -382,55 +493,58 @@ test expr-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8 test expr-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1 test expr-11.3 {CompileAddExpr: just multiply expr} {expr -1/2} -1 test expr-11.4 {CompileAddExpr: just multiply expr} {expr 7891%0123} 6 -test expr-11.5 {CompileAddExpr: error in multiply expr} { +test expr-11.5 {CompileAddExpr: error in multiply expr} -body { catch {expr x*3} msg set msg -} {syntax error in expression "x*3": variable references require preceding $} +} -match glob -result {syntax error in expression "x*3": * preceding $*} test expr-11.6 {CompileAddExpr: simple add exprs} {expr 0xff++0x3} 258 test expr-11.7 {CompileAddExpr: simple add exprs} {expr -0xf2--0x3} -239 test expr-11.8 {CompileAddExpr: error compiling add arm} { catch {expr 2***3+6} msg set msg } {syntax error in expression "2***3+6": unexpected operator *} -test expr-11.9 {CompileAddExpr: error compiling add arm} { +test expr-11.9 {CompileAddExpr: error compiling add arm} -body { catch {expr 2-x} msg set msg -} {syntax error in expression "2-x": variable references require preceding $} +} -match glob -result {syntax error in expression "2-x": * preceding $*} test expr-11.10 {CompileAddExpr: runtime error} { list [catch {expr {24.0+"xx"}} msg] $msg } {1 {can't use non-numeric string as operand of "+"}} test expr-11.11 {CompileAddExpr: runtime error} { list [catch {expr {"a"-"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "-"}} test expr-11.12 {CompileAddExpr: runtime error} { list [catch {expr {3/0}} msg] $msg } {1 {divide by zero}} -test expr-11.13 {CompileAddExpr: runtime error} { +test expr-11.13a {CompileAddExpr: runtime error} !ieeeFloatingPoint { list [catch {expr {2.3/0.0}} msg] $msg } {1 {divide by zero}} +test expr-11.13b {CompileAddExpr: runtime error} ieeeFloatingPoint { + list [catch {expr {2.3/0.0}} msg] $msg +} {0 Inf} test expr-12.1 {CompileMultiplyExpr: just unary expr} {expr ~4} -5 test expr-12.2 {CompileMultiplyExpr: just unary expr} {expr --5} 5 test expr-12.3 {CompileMultiplyExpr: just unary expr} {expr !27} 0 test expr-12.4 {CompileMultiplyExpr: just unary expr} {expr ~0xff00ff} -16711936 -test expr-12.5 {CompileMultiplyExpr: error in unary expr} { +test expr-12.5 {CompileMultiplyExpr: error in unary expr} -body { catch {expr ~x} msg set msg -} {syntax error in expression "~x": variable references require preceding $} +} -match glob -result {syntax error in expression "~x": * preceding $*} test expr-12.6 {CompileMultiplyExpr: simple multiply exprs} {expr 0xff*0x3} 765 test expr-12.7 {CompileMultiplyExpr: simple multiply exprs} {expr -0xf2%-0x3} -2 test expr-12.8 {CompileMultiplyExpr: error compiling multiply arm} { catch {expr 2*3%%6} msg set msg } {syntax error in expression "2*3%%6": unexpected operator %} -test expr-12.9 {CompileMultiplyExpr: error compiling multiply arm} { +test expr-12.9 {CompileMultiplyExpr: error compiling multiply arm} -body { catch {expr 2*x} msg set msg -} {syntax error in expression "2*x": variable references require preceding $} +} -match glob -result {syntax error in expression "2*x": * preceding $*} test expr-12.10 {CompileMultiplyExpr: runtime error} { list [catch {expr {24.0*"xx"}} msg] $msg } {1 {can't use non-numeric string as operand of "*"}} test expr-12.11 {CompileMultiplyExpr: runtime error} { list [catch {expr {"a"/"b"}} msg] $msg @@ -441,14 +555,14 @@ test expr-13.3 {CompileUnaryExpr: unary exprs} {expr +--++36} 36 test expr-13.4 {CompileUnaryExpr: unary exprs} {expr !2} 0 test expr-13.5 {CompileUnaryExpr: unary exprs} {expr +--+-62.0} -62.0 test expr-13.6 {CompileUnaryExpr: unary exprs} {expr !0.0} 1 test expr-13.7 {CompileUnaryExpr: unary exprs} {expr !0xef} 0 -test expr-13.8 {CompileUnaryExpr: error compiling unary expr} { +test expr-13.8 {CompileUnaryExpr: error compiling unary expr} -body { catch {expr ~x} msg set msg -} {syntax error in expression "~x": variable references require preceding $} +} -match glob -result {syntax error in expression "~x": * preceding $*} test expr-13.9 {CompileUnaryExpr: error compiling unary expr} { catch {expr !1.x} msg set msg } {syntax error in expression "!1.x": extra tokens at end of expression} test expr-13.10 {CompileUnaryExpr: runtime error} { @@ -563,11 +677,11 @@ format %.6g [expr pow(2.0+0.1,3.0+0.1)] } 9.97424 test expr-14.27 {CompilePrimaryExpr: error in math function primary} -body { catch {expr sinh::(2.0)} msg set errorInfo -} -match glob -result {syntax error in expression "sinh::(2.0)": expected parenthesis enclosing function arguments +} -match glob -result {syntax error in expression "sinh::(2.0)": * function arguments* while *ing "expr sinh::(2.0)"} test expr-14.28 {CompilePrimaryExpr: subexpression primary} { expr 2+(3*4) } 14 @@ -595,35 +709,35 @@ "expr @"} test expr-15.1 {CompileMathFuncCall: missing parenthesis} -body { catch {expr sinh2.0)} msg set errorInfo -} -match glob -result {syntax error in expression "sinh2.0)": variable references require preceding $ +} -match glob -result {syntax error in expression "sinh2.0)": * preceding $* while *ing "expr sinh2.0)"} test expr-15.2 {CompileMathFuncCall: unknown math function} -body { catch {expr whazzathuh(1)} msg set errorInfo -} -match glob -result {unknown math function "whazzathuh" +} -match glob -result {* "*whazzathuh" while *ing "expr whazzathuh(1)"} test expr-15.3 {CompileMathFuncCall: too many arguments} -body { catch {expr sin(1,2,3)} msg set errorInfo -} -match glob -result {too many arguments for math function +} -match glob -result {too many arguments for math function* while *ing "expr sin(1,2,3)"} test expr-15.4 {CompileMathFuncCall: ')' found before last required arg} -body { catch {expr sin()} msg set errorInfo -} -match glob -result {too few arguments for math function +} -match glob -result {too few arguments for math function* while *ing "expr sin()"} test expr-15.5 {CompileMathFuncCall: too few arguments} -body { catch {expr pow(1)} msg set errorInfo -} -match glob -result {too few arguments for math function +} -match glob -result {too few arguments for math function* while *ing "expr pow(1)"} test expr-15.6 {CompileMathFuncCall: missing ')'} -body { catch {expr sin(1} msg set errorInfo @@ -776,39 +890,74 @@ test expr-21.8 {non-numeric boolean literals} {expr !true } 0 test expr-21.9 {non-numeric boolean literals} {expr !off } 1 test expr-21.10 {non-numeric boolean literals} {expr !on } 0 test expr-21.11 {non-numeric boolean literals} {expr !no } 1 test expr-21.12 {non-numeric boolean literals} {expr !yes } 0 +test expr-21.13 {non-numeric boolean literals} { + list [catch {expr !truef} err] $err +} {1 {syntax error in expression "!truef": the word "truef" requires a preceding $ if it's a variable or function arguments if it's a function}} +test expr-21.14 {non-numeric boolean literals} { + list [catch {expr !"truef"} err] $err +} {1 {can't use non-numeric string as operand of "!"}} +test expr-21.15 {non-numeric boolean variables} { + set v truef + list [catch {expr {!$v}} err] $err +} {1 {can't use non-numeric string as operand of "!"}} +test expr-21.16 {non-numeric boolean variables} { + set v "true " + list [catch {expr {!$v}} err] $err +} {1 {can't use non-numeric string as operand of "!"}} +test expr-21.17 {non-numeric boolean variables} { + set v "tru" + list [catch {expr {!$v}} err] $err +} {0 0} +test expr-21.18 {non-numeric boolean variables} { + set v "fal" + list [catch {expr {!$v}} err] $err +} {0 1} +test expr-21.19 {non-numeric boolean variables} { + set v "y" + list [catch {expr {!$v}} err] $err +} {0 0} +test expr-21.20 {non-numeric boolean variables} { + set v "of" + list [catch {expr {!$v}} err] $err +} {0 1} +test expr-21.21 {non-numeric boolean variables} { + set v "o" + list [catch {expr {!$v}} err] $err +} {1 {can't use non-numeric string as operand of "!"}} +test expr-21.22 {non-numeric boolean variables} { + set v "" + list [catch {expr {!$v}} err] $err +} {1 {can't use empty string as operand of "!"}} # Test for non-numeric float handling. -# -# These are non-portable because strtod()-support for "Inf" and "NaN" -# is so wildly variable. This sucks... -test expr-22.1 {non-numeric floats} nonPortable { +test expr-22.1 {non-numeric floats} { list [catch {expr {NaN + 1}} msg] $msg } {1 {can't use non-numeric floating-point value as operand of "+"}} -test expr-22.2 {non-numeric floats} nonPortable { +test expr-22.2 {non-numeric floats} !ieeeFloatingPoint { list [catch {expr {Inf + 1}} msg] $msg } {1 {can't use infinite floating-point value as operand of "+"}} -test expr-22.3 {non-numeric floats} nonPortable { +test expr-22.3 {non-numeric floats} { set nan NaN list [catch {expr {$nan + 1}} msg] $msg } {1 {can't use non-numeric floating-point value as operand of "+"}} -test expr-22.4 {non-numeric floats} nonPortable { +test expr-22.4 {non-numeric floats} !ieeeFloatingPoint { set inf Inf list [catch {expr {$inf + 1}} msg] $msg } {1 {can't use infinite floating-point value as operand of "+"}} -test expr-22.5 {non-numeric floats} nonPortable { +test expr-22.5 {non-numeric floats} { list [catch {expr NaN} msg] $msg } {1 {domain error: argument not in valid range}} -test expr-22.6 {non-numeric floats} nonPortable { +test expr-22.6 {non-numeric floats} !ieeeFloatingPoint { list [catch {expr Inf} msg] $msg } {1 {floating-point value too large to represent}} -test expr-22.7 {non-numeric floats} nonPortable { +test expr-22.7 {non-numeric floats} { list [catch {expr {1 / NaN}} msg] $msg } {1 {can't use non-numeric floating-point value as operand of "/"}} -test expr-22.8 {non-numeric floats} nonPortable { +test expr-22.8 {non-numeric floats} !ieeeFloatingPoint { list [catch {expr {1 / Inf}} msg] $msg } {1 {can't use infinite floating-point value as operand of "/"}} # Make sure [Bug 761471] stays fixed. test expr-22.9 {non-numeric floats: shared object equality and NaN} { set x NaN @@ -818,23 +967,23 @@ # Tests for exponentiation handling test expr-23.1 {CompileExponentialExpr: just exponential expr} {expr 4**2} 16 test expr-23.2 {CompileExponentialExpr: just exponential expr} {expr 0xff**2} 65025 test expr-23.3 {CompileExponentialExpr: just exponential expr} {expr -1**2} 1 test expr-23.4 {CompileExponentialExpr: just exponential expr} {expr 18**07} 612220032 -test expr-23.5 {CompileExponentialExpr: error in exponential expr} { +test expr-23.5 {CompileExponentialExpr: error in exponential expr} -body { catch {expr x**3} msg set msg -} {syntax error in expression "x**3": variable references require preceding $} +} -match glob -result {syntax error in expression "x**3": * preceding $*} test expr-23.6 {CompileExponentialExpr: simple expo exprs} {expr 0xff**0x3} 16581375 test expr-23.7 {CompileExponentialExpr: error compiling expo arm} { catch {expr (-3-)**6} msg set msg } {syntax error in expression "(-3-)**6": unexpected close parenthesis} -test expr-23.8 {CompileExponentialExpr: error compiling expo arm} { +test expr-23.8 {CompileExponentialExpr: error compiling expo arm} -body { catch {expr 2**x} msg set msg -} {syntax error in expression "2**x": variable references require preceding $} +} -match glob -result {syntax error in expression "2**x": * preceding $*} test expr-23.9 {CompileExponentialExpr: runtime error} { list [catch {expr {24.0**"xx"}} msg] $msg } {1 {can't use non-numeric string as operand of "**"}} test expr-23.10 {CompileExponentialExpr: runtime error} { list [catch {expr {"a"**2}} msg] $msg @@ -866,18 +1015,20 @@ test expr-23.29 {INST_EXPON: special cases} {expr {wide(-1)**wide(0)}} 1 test expr-23.30 {INST_EXPON: special cases} {expr {wide(-1)**wide(2)}} 1 test expr-23.31 {INST_EXPON: special cases} {expr {wide(-1)**wide(-1)}} -1 test expr-23.32 {INST_EXPON: special cases} {expr {wide(1)**wide(1234567)}} 1 test expr-23.33 {INST_EXPON: special cases} {expr {wide(2)**wide(-2)}} 0 +test expr-23.34 {INST_EXPON: special cases} {expr {2**0}} 1 +test expr-23.35 {INST_EXPON: special cases} {expr {wide(2)**0}} 1 # Some compilers get this wrong; ensure that we work around it correctly test expr-24.1 {expr edge cases; shifting} {expr int(5)>>32} 0 test expr-24.2 {expr edge cases; shifting} {expr int(5)>>63} 0 test expr-24.3 {expr edge cases; shifting} {expr wide(5)>>32} 0 test expr-24.4 {expr edge cases; shifting} {expr wide(5)>>63} 0 -test expr-24.5 {expr edge cases; shifting} nonPortable {expr int(5)<<32} 0 -test expr-24.6 {expr edge cases; shifting} nonPortable {expr int(5)<<63} 0 +test expr-24.5 {expr edge cases; shifting} longIs32bit {expr int(5)<<32} 0 +test expr-24.6 {expr edge cases; shifting} longIs32bit {expr int(5)<<63} 0 test expr-24.7 {expr edge cases; shifting} {expr wide(5)<<32} 21474836480 test expr-24.8 {expr edge cases; shifting} {expr wide(10)<<63} 0 test expr-24.9 {expr edge cases; shifting} {expr 5>>32} 0 # List membership tests @@ -894,12 +1045,5525 @@ test expr-26.3 {'ni' operator} {expr {"a" ni "b c a"}} 0 test expr-26.4 {'ni' operator} {expr {"a" ni ""}} 1 test expr-26.5 {'ni' operator} {expr {"" ni {a b c ""}}} 0 test expr-26.6 {'ni' operator} {expr {"" ni "a b c"}} 1 test expr-26.7 {'ni' operator} {expr {"" ni ""}} 1 + +foreach op {< <= == != > >=} { + proc test$op {a b} [list expr "\$a $op \$b"] +} + +test expr-27.1 {expr - correct ordering - not compiled} ieeeFloatingPoint { + set problems {} + # Ordering should be: -Infinity < -Normal < Subnormal < -0 + # < +0 < +Subnormal < +Normal < +Infinity + # with equality within each class. + set names { + -Infinity -Normal -Subnormal -0 +0 +Subnormal +Normal +Infinity + } + set weights { + -3 -2 -1 0 0 1 2 3 + } + foreach name1 $names weight1 $weights { + foreach name2 $names weight2 $weights { + foreach op {< <= == != >= >} { + set shouldBe [expr "$weight1 $op $weight2"] + set is [expr "\$ieeeValues($name1) $op \$ieeeValues($name2)"] + if { $is != $shouldBe } { + append problems $name1 { } $op { } $name2 \ + ":result is " $is ", should be $shouldBe" \n + } + } + } + } + set problems +} {} +test expr-27.2 {expr - correct ordering - compiled} ieeeFloatingPoint { + set problems {} + # Ordering should be: -Infinity < -Normal < Subnormal < -0 + # < +0 < +Subnormal < +Normal < +Infinity + # with equality within each class. + set names { + -Infinity -Normal -Subnormal -0 +0 +Subnormal +Normal +Infinity + } + set weights { + -3 -2 -1 0 0 1 2 3 + } + foreach name1 $names weight1 $weights { + foreach name2 $names weight2 $weights { + foreach op {< <= == != >= >} { + set shouldBe [expr "$weight1 $op $weight2"] + set is [test$op $ieeeValues($name1) $ieeeValues($name2)] + if { $is != $shouldBe } { + append problems $name1 { } $op { } $name2 \ + ":result is " $is ", should be $shouldBe" \n + } + } + } + } + set problems +} {} +test expr-27.3 {expr - NaN is unordered - not compiled} { + set problems {} + set names { + -Infinity -Normal -Subnormal -0 +0 +Subnormal +Normal +Infinity NaN + } + foreach name1 $names { + foreach op {< <= == != >= >} sb {0 0 0 1 0 0} { + if "(\$ieeeValues($name1) $op \$ieeeValues(NaN)) != $sb " { + append problems $name1 { } $op { } NaN \ + ": result is 1, should be $sb" \n + } + if "(\$ieeeValues(NaN) $op \$ieeeValues($name1)) != $sb" { + append problems NaN { } $op { } $name1 \ + ": result is 1, should be $sb" \n + } + } + } + set problems +} {} +test expr-27.4 {expr - NaN is unordered - compiled} { + set problems {} + set names { + -Infinity -Normal -Subnormal -0 +0 +Subnormal +Normal +Infinity NaN + } + foreach name1 $names { + foreach op {< <= == != >= >} sb {0 0 0 1 0 0} { + if { [test$op $ieeeValues($name1) $ieeeValues(NaN)] != $sb } { + append problems $ieeeValues($name1) { } $op { } $ieeeValues(NaN) \ + ": result is 1, should be $sb" \n + } + if { [test$op $ieeeValues(NaN) $ieeeValues($name1)] != $sb } { + append problems NaN { } $op { } $ieeeValues($name1) \ + ": result is 1, should be $sb" \n + } + } + } + set problems +} {} + +proc convertToDouble { x } { + variable ieeeValues + binary scan [binary format d $x] c* bytes + set result 0x + if { $ieeeValues(littleEndian) } { + for { set i 7 } { $i >= 0 } { incr i -1 } { + append result [format %02x [expr { [lindex $bytes $i] & 0xff }]] + } + } else { + foreach byte $bytes { + append result [format %02x [expr { $byte & 0xff }]] + } + } + return $result +} + +test expr-28.1 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d ALL 0 E0 OK 00000000000000 E-1023 + convertToDouble 0E0 +} 0x0000000000000000 +test expr-28.2 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d ALL -0 E0 OK -0000000000000 E-1023 + convertToDouble -0E0 +} 0x8000000000000000 +test expr-28.3 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d ALL 1 E0 OK 10000000000000 E0 + convertToDouble 1E0 +} 0x3ff0000000000000 +test expr-28.4 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d ALL 15 E-1 OK 18000000000000 E0 + convertToDouble 15E-1 +} 0x3ff8000000000000 +test expr-28.5 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d ALL 125 E-2 OK 14000000000000 E0 + convertToDouble 125E-2 +} 0x3ff4000000000000 +test expr-28.6 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d ALL 1125 E-3 OK 12000000000000 E0 + convertToDouble 1125E-3 +} 0x3ff2000000000000 +test expr-28.7 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d ALL 10625 E-4 OK 11000000000000 E0 + convertToDouble 10625E-4 +} 0x3ff1000000000000 +test expr-28.8 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d ALL 103125 E-5 OK 10800000000000 E0 + convertToDouble 103125E-5 +} 0x3ff0800000000000 +test expr-28.9 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d ALL 1015625 E-6 OK 10400000000000 E0 + convertToDouble 1015625E-6 +} 0x3ff0400000000000 +test expr-28.10 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d ALL 10078125 E-7 OK 10200000000000 E0 + convertToDouble 10078125E-7 +} 0x3ff0200000000000 +test expr-28.11 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d ALL 100390625 E-8 OK 10100000000000 E0 + convertToDouble 100390625E-8 +} 0x3ff0100000000000 +test expr-28.12 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee ALL 1001953125 E-9 OK 10080000000000 E0 + convertToDouble 1001953125E-9 +} 0x3ff0080000000000 +test expr-28.13 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee ALL 10009765625 E-10 OK 10040000000000 E0 + convertToDouble 10009765625E-10 +} 0x3ff0040000000000 +test expr-28.14 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee ALL 100048828125 E-11 OK 10020000000000 E0 + convertToDouble 100048828125E-11 +} 0x3ff0020000000000 +test expr-28.15 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee ALL 1000244140625 E-12 OK 10010000000000 E0 + convertToDouble 1000244140625E-12 +} 0x3ff0010000000000 +test expr-28.16 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee ALL 10001220703125 E-13 OK 10008000000000 E0 + convertToDouble 10001220703125E-13 +} 0x3ff0008000000000 +test expr-28.17 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee ALL 100006103515625 E-14 OK 10004000000000 E0 + convertToDouble 100006103515625E-14 +} 0x3ff0004000000000 +test expr-28.18 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee ALL 1000030517578125 E-15 OK 10002000000000 E0 + convertToDouble 1000030517578125E-15 +} 0x3ff0002000000000 +test expr-28.19 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee ALL 10000152587890625 E-16 OK 10001000000000 E0 + convertToDouble 10000152587890625E-16 +} 0x3ff0001000000000 +test expr-28.20 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +8 E153 x 1317e5ef3ab327_0000000001& E511 + convertToDouble +8E153 +} 0x5fe317e5ef3ab327 +test expr-28.21 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -1 E153 x -1317e5ef3ab327_0000000001& E508 + convertToDouble -1E153 +} 0xdfb317e5ef3ab327 +test expr-28.22 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +9 E306 x 19a2028368022e_00000000001& E1019 + convertToDouble +9E306 +} 0x7fa9a2028368022e +test expr-28.23 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -2 E153 x -1317e5ef3ab327_0000000001& E509 + convertToDouble -2E153 +} 0xdfc317e5ef3ab327 +test expr-28.24 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +7 E-304 x 1eb8e84fa0b278_00000000001& E-1008 + convertToDouble +7E-304 +} 0x00feb8e84fa0b278 +test expr-28.25 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -3 E-49 x -1c0f92a6276c9d_000000001& E-162 + convertToDouble -3E-49 +} 0xb5dc0f92a6276c9d +test expr-28.26 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +7 E-303 x 13339131c46f8b_00000000001& E-1004 + convertToDouble +7E-303 +} 0x0133339131c46f8b +test expr-28.27 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -6 E-49 x -1c0f92a6276c9d_000000001& E-161 + convertToDouble -6E-49 +} 0xb5ec0f92a6276c9d +test expr-28.28 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +9 E43 x 102498ea6df0c3_11111111110& E146 + convertToDouble +9E43 +} 0x49102498ea6df0c4 +test expr-28.29 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -9 E44 x -142dbf25096cf4_1111111110& E149 + convertToDouble -9E44 +} 0xc9442dbf25096cf5 +test expr-28.30 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +8 E303 x 1754e31cd072d9_1111111110& E1009 + convertToDouble +8E303 +} 0x7f0754e31cd072da +test expr-28.31 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -1 E303 x -1754e31cd072d9_1111111110& E1006 + convertToDouble -1E303 +} 0xfed754e31cd072da +test expr-28.32 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +7 E-287 x 1551603777f798_111111110& E-951 + convertToDouble +7E-287 +} 0x048551603777f799 +test expr-28.33 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -2 E-204 x -1410d9f9b2f7f2_11111110& E-677 + convertToDouble -2E-204 +} 0x95a410d9f9b2f7f3 +test expr-28.34 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +2 E-205 x 100d7b2e28c65b_11111110& E-680 + convertToDouble +2E-205 +} 0x15700d7b2e28c65c +test expr-28.35 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -9 E-47 x -10711fed5b19a3_11111110& E-153 + convertToDouble -9E-47 +} 0xb660711fed5b19a4 +test expr-28.36 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +34 E195 x 1d1c26db7d0dae_000000000001& E652 + convertToDouble +34E195 +} 0x68bd1c26db7d0dae +test expr-28.37 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -68 E195 x -1d1c26db7d0dae_000000000001& E653 + convertToDouble -68E195 +} 0xe8cd1c26db7d0dae +test expr-28.38 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +85 E194 x 1d1c26db7d0dae_000000000001& E650 + convertToDouble +85E194 +} 0x689d1c26db7d0dae +test expr-28.39 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -67 E97 x -139ac1ce2cc95f_000000000001& E328 + convertToDouble -67E97 +} 0xd4739ac1ce2cc95f +test expr-28.40 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +93 E-234 x 127b2e4f210075_0000000000000001& E-771 + convertToDouble +93E-234 +} 0x0fc27b2e4f210075 +test expr-28.41 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -19 E-87 x -12e5f5dfa4fe9d_00000000000001& E-285 + convertToDouble -19E-87 +} 0xae22e5f5dfa4fe9d +test expr-28.42 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +38 E-87 x 12e5f5dfa4fe9d_00000000000001& E-284 + convertToDouble +38E-87 +} 0x2e32e5f5dfa4fe9d +test expr-28.43 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -38 E-88 x -1e3cbc9907fdc8_00000000000001& E-288 + convertToDouble -38E-88 +} 0xadfe3cbc9907fdc8 +test expr-28.44 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -69 E220 x -1e8aa8823a5db3_11111111110& E736 + convertToDouble -69E220 +} 0xedfe8aa8823a5db4 +test expr-28.45 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +18 E43 x 102498ea6df0c3_11111111110& E147 + convertToDouble +18E43 +} 0x49202498ea6df0c4 +test expr-28.46 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -36 E43 x -102498ea6df0c3_11111111110& E148 + convertToDouble -36E43 +} 0xc9302498ea6df0c4 +test expr-28.47 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +61 E-99 x 10ad836f269a16_11111111111110& E-323 + convertToDouble +61E-99 +} 0x2bc0ad836f269a17 +test expr-28.48 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -43 E-92 x -1c0794d9d40e95_111111111111110& E-301 + convertToDouble -43E-92 +} 0xad2c0794d9d40e96 +test expr-28.49 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +86 E-92 x 1c0794d9d40e95_111111111111110& E-300 + convertToDouble +86E-92 +} 0x2d3c0794d9d40e96 +test expr-28.50 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -51 E-74 x -1cd5bee57763e5_1111111111111110& E-241 + convertToDouble -51E-74 +} 0xb0ecd5bee57763e6 +test expr-28.51 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +283 E85 x 16c309024bab4b_00000000000000001& E290 + convertToDouble +283E85 +} 0x5216c309024bab4b +test expr-28.52 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -566 E85 x -16c309024bab4b_00000000000000001& E291 + convertToDouble -566E85 +} 0xd226c309024bab4b +test expr-28.53 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +589 E187 x 1526be9c22eb17_00000000000000001& E630 + convertToDouble +589E187 +} 0x675526be9c22eb17 +test expr-28.54 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -839 E143 x -1ae03f245703e2_000000000000001& E484 + convertToDouble -839E143 +} 0xde3ae03f245703e2 +test expr-28.55 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -744 E-234 x -127b2e4f210075_0000000000000001& E-768 + convertToDouble -744E-234 +} 0x8ff27b2e4f210075 +test expr-28.56 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +930 E-235 x 127b2e4f210075_0000000000000001& E-771 + convertToDouble +930E-235 +} 0x0fc27b2e4f210075 +test expr-28.57 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -186 E-234 x -127b2e4f210075_0000000000000001& E-770 + convertToDouble -186E-234 +} 0x8fd27b2e4f210075 +test expr-28.58 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +604 E175 x 17d93193f78fc5_1111111111111111110& E590 + convertToDouble +604E175 +} 0x64d7d93193f78fc6 +test expr-28.59 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -302 E175 x -17d93193f78fc5_1111111111111111110& E589 + convertToDouble -302E175 +} 0xe4c7d93193f78fc6 +test expr-28.60 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +755 E174 x 17d93193f78fc5_1111111111111111110& E587 + convertToDouble +755E174 +} 0x64a7d93193f78fc6 +test expr-28.61 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -151 E175 x -17d93193f78fc5_1111111111111111110& E588 + convertToDouble -151E175 +} 0xe4b7d93193f78fc6 +test expr-28.62 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +662 E-213 x 1bdb90e62a8cbc_1111111111111110& E-699 + convertToDouble +662E-213 +} 0x144bdb90e62a8cbd +test expr-28.63 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -408 E-74 x -1cd5bee57763e5_1111111111111110& E-238 + convertToDouble -408E-74 +} 0xb11cd5bee57763e6 +test expr-28.64 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +510 E-75 x 1cd5bee57763e5_1111111111111110& E-241 + convertToDouble +510E-75 +} 0x30ecd5bee57763e6 +test expr-28.65 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +6782 E55 x 159bd3ad46e346_0000000000000000001& E195 + convertToDouble +6782E55 +} 0x4c259bd3ad46e346 +test expr-28.66 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -2309 E92 x -1bac6f7d64d119_000000000000000001& E316 + convertToDouble -2309E92 +} 0xd3bbac6f7d64d119 +test expr-28.67 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +7963 E34 x 1df4170f0fdecc_00000000000000000001& E125 + convertToDouble +7963E34 +} 0x47cdf4170f0fdecc +test expr-28.68 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -3391 E55 x -159bd3ad46e346_0000000000000000001& E194 + convertToDouble -3391E55 +} 0xcc159bd3ad46e346 +test expr-28.69 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +7903 E-96 x 107c2d27a5b989_0000000000000000001& E-306 + convertToDouble +7903E-96 +} 0x2cd07c2d27a5b989 +test expr-28.70 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -7611 E-226 x -119b8744033457_0000000000000000001& E-738 + convertToDouble -7611E-226 +} 0x91d19b8744033457 +test expr-28.71 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +4907 E-196 x 11e90a8711440f_000000000000000001& E-639 + convertToDouble +4907E-196 +} 0x1801e90a8711440f +test expr-28.72 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -5547 E-311 x -13f190452a29f4_000000000000000001& E-1021 + convertToDouble -5547E-311 +} 0x8023f190452a29f4 +test expr-28.73 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +5311 E241 x 1f1ce3c887c25f_11111111111111111110& E812 + convertToDouble +5311E241 +} 0x72bf1ce3c887c260 +test expr-28.74 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -5311 E243 x -184e91f4aa0fda_11111111111111111110& E819 + convertToDouble -5311E243 +} 0xf3284e91f4aa0fdb +test expr-28.75 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +5311 E242 x 13720e5d54d97b_11111111111111111110& E816 + convertToDouble +5311E242 +} 0x72f3720e5d54d97c +test expr-28.76 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +9269 E-45 x 19d69455a53bd8_111111111111111111110& E-137 + convertToDouble +9269E-45 +} 0x3769d69455a53bd9 +test expr-28.77 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -8559 E-289 x -104a81d35952fe_11111111111111111110& E-947 + convertToDouble -8559E-289 +} 0x84c04a81d35952ff +test expr-28.78 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +8699 E-276 x 12d2df246ecd2c_1111111111111111111110& E-904 + convertToDouble +8699E-276 +} 0x0772d2df246ecd2d +test expr-28.79 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -8085 E-64 x -14c98fce16152d_1111111111111111110& E-200 + convertToDouble -8085E-64 +} 0xb374c98fce16152e +test expr-28.80 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +74819 E201 x 1dd455061eb3f1_0000000000000000000001& E683 + convertToDouble +74819E201 +} 0x6aadd455061eb3f1 +test expr-28.81 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -82081 E41 x -170105df3d47cb_000000000000000000000000001& E152 + convertToDouble -82081E41 +} 0xc9770105df3d47cb +test expr-28.82 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +51881 E37 x 17d2950dc76da4_000000000000000000001& E138 + convertToDouble +51881E37 +} 0x4897d2950dc76da4 +test expr-28.83 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -55061 E157 x -1394fc0f33536c_000000000000000000001& E537 + convertToDouble -55061E157 +} 0xe18394fc0f33536c +test expr-28.84 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +77402 E-215 x 10492a4a8a37fd_0000000000000000000000001& E-698 + convertToDouble +77402E-215 +} 0x1450492a4a8a37fd +test expr-28.85 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -33891 E-92 x -1592f9932c06bd_00000000000000000000001& E-291 + convertToDouble -33891E-92 +} 0xadc592f9932c06bd +test expr-28.86 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +38701 E-215 x 10492a4a8a37fd_0000000000000000000000001& E-699 + convertToDouble +38701E-215 +} 0x1440492a4a8a37fd +test expr-28.87 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -82139 E-76 x -1d0681489839d5_00000000000000000000001& E-237 + convertToDouble -82139E-76 +} 0xb12d0681489839d5 +test expr-28.88 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +75859 E25 x 132645e1ba93ef_11111111111111111111110& E99 + convertToDouble +75859E25 +} 0x46232645e1ba93f0 +test expr-28.89 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +89509 E140 x 16f02bee68670c_1111111111111111111110& E481 + convertToDouble +89509E140 +} 0x5e06f02bee68670d +test expr-28.90 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -57533 E287 x -1272ed2307f569_1111111111111111111110& E969 + convertToDouble -57533E287 +} 0xfc8272ed2307f56a +test expr-28.91 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +46073 E-32 x 12405b773fbdf2_11111111111111111111110& E-91 + convertToDouble +46073E-32 +} 0x3a42405b773fbdf3 +test expr-28.92 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -92146 E-32 x -12405b773fbdf2_11111111111111111111110& E-90 + convertToDouble -92146E-32 +} 0xba52405b773fbdf3 +test expr-28.93 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +83771 E-74 x 17206bfc4ccabd_11111111111111111111110& E-230 + convertToDouble +83771E-74 +} 0x3197206bfc4ccabe +test expr-28.94 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -34796 E-276 x -12d2df246ecd2c_1111111111111111111110& E-902 + convertToDouble -34796E-276 +} 0x8792d2df246ecd2d +test expr-28.95 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +584169 E229 x 1d657059dc79aa_00000000000000000000000000001& E779 + convertToDouble +584169E229 +} 0x70ad657059dc79aa +test expr-28.96 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +164162 E41 x 170105df3d47cb_000000000000000000000000001& E153 + convertToDouble +164162E41 +} 0x49870105df3d47cb +test expr-28.97 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -328324 E41 x -170105df3d47cb_000000000000000000000000001& E154 + convertToDouble -328324E41 +} 0xc9970105df3d47cb +test expr-28.98 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +209901 E-11 x 119b96f36ec68b_00000000000000000000000001& E-19 + convertToDouble +209901E-11 +} 0x3ec19b96f36ec68b +test expr-28.99 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -419802 E-11 x -119b96f36ec68b_00000000000000000000000001& E-18 + convertToDouble -419802E-11 +} 0xbed19b96f36ec68b +test expr-28.100 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +940189 E-112 x 1b99d6240c1a28_00000000000000000000000001& E-353 + convertToDouble +940189E-112 +} 0x29eb99d6240c1a28 +test expr-28.101 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -892771 E-213 x -125818c7294f27_0000000000000000000000000001& E-688 + convertToDouble -892771E-213 +} 0x94f25818c7294f27 +test expr-28.102 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +757803 E120 x 11e968b555bb80_11111111111111111111111111110& E418 + convertToDouble +757803E120 +} 0x5a11e968b555bb81 +test expr-28.103 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -252601 E120 x -17e1e0f1c7a4ab_11111111111111111111111111110& E416 + convertToDouble -252601E120 +} 0xd9f7e1e0f1c7a4ac +test expr-28.104 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +252601 E121 x 1dda592e398dd6_1111111111111111111111111110& E419 + convertToDouble +252601E121 +} 0x5a2dda592e398dd7 +test expr-28.105 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -505202 E120 x -17e1e0f1c7a4ab_11111111111111111111111111110& E417 + convertToDouble -505202E120 +} 0xda07e1e0f1c7a4ac +test expr-28.106 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +970811 E-264 x 1dda6b965c9629_11111111111111111111111110& E-858 + convertToDouble +970811E-264 +} 0x0a5dda6b965c962a +test expr-28.107 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -654839 E-60 x -100e7db3b3f241_111111111111111111111111110& E-180 + convertToDouble -654839E-60 +} 0xb4b00e7db3b3f242 +test expr-28.108 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +289767 E-178 x 1caad28f23a100_11111111111111111111111110& E-574 + convertToDouble +289767E-178 +} 0x1c1caad28f23a101 +test expr-28.109 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -579534 E-178 x -1caad28f23a100_11111111111111111111111110& E-573 + convertToDouble -579534E-178 +} 0x9c2caad28f23a101 +test expr-28.110 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -8823691 E130 x -1e597c0b94b7ae_00000000000000000000000000000001& E454 + convertToDouble -8823691E130 +} 0xdc5e597c0b94b7ae +test expr-28.111 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +9346704 E229 x 1d657059dc79aa_00000000000000000000000000001& E783 + convertToDouble +9346704E229 +} 0x70ed657059dc79aa +test expr-28.112 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -1168338 E229 x -1d657059dc79aa_00000000000000000000000000001& E780 + convertToDouble -1168338E229 +} 0xf0bd657059dc79aa +test expr-28.113 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -6063369 E-136 x -1ae6148e3902b3_000000000000000000000000000001& E-430 + convertToDouble -6063369E-136 +} 0xa51ae6148e3902b3 +test expr-28.114 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +3865421 E-225 x 15d4fe53afec65_00000000000000000000000000001& E-726 + convertToDouble +3865421E-225 +} 0x1295d4fe53afec65 +test expr-28.115 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -5783893 E-127 x -17e5902ce0e151_000000000000000000000000000000001& E-400 + convertToDouble -5783893E-127 +} 0xa6f7e5902ce0e151 +test expr-28.116 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +2572231 E223 x 10f73be1dff9ac_111111111111111111111111111110& E762 + convertToDouble +2572231E223 +} 0x6f90f73be1dff9ad +test expr-28.117 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -5144462 E223 x -10f73be1dff9ac_111111111111111111111111111110& E763 + convertToDouble -5144462E223 +} 0xefa0f73be1dff9ad +test expr-28.118 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +1817623 E109 x 1d85f96f3fe659_11111111111111111111111111110& E382 + convertToDouble +1817623E109 +} 0x57dd85f96f3fe65a +test expr-28.119 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +6431543 E-97 x 14f6493f34a0bc_11111111111111111111111111110& E-300 + convertToDouble +6431543E-97 +} 0x2d34f6493f34a0bd +test expr-28.120 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -5444097 E-21 x -18849dd33c95ae_11111111111111111111111111110& E-48 + convertToDouble -5444097E-21 +} 0xbcf8849dd33c95af +test expr-28.121 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +8076999 E-121 x 1fd332f7e2e3b2_11111111111111111111111111110& E-380 + convertToDouble +8076999E-121 +} 0x283fd332f7e2e3b3 +test expr-28.122 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -9997649 E-270 x -1425e9d29e558d_1111111111111111111111111110& E-874 + convertToDouble -9997649E-270 +} 0x895425e9d29e558e +test expr-28.123 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +50609263 E157 x 1193aff1f1c8e3_000000000000000000000000000000001& E547 + convertToDouble +50609263E157 +} 0x622193aff1f1c8e3 +test expr-28.124 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +70589528 E130 x 1e597c0b94b7ae_00000000000000000000000000000001& E457 + convertToDouble +70589528E130 +} 0x5c8e597c0b94b7ae +test expr-28.125 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -88236910 E129 x -1e597c0b94b7ae_00000000000000000000000000000001& E454 + convertToDouble -88236910E129 +} 0xdc5e597c0b94b7ae +test expr-28.126 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +87575437 E-310 x 1805c19e680456_0000000000000000000000000000000000001& E-1004 + convertToDouble +87575437E-310 +} 0x013805c19e680456 +test expr-28.127 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -23135572 E-127 x -17e5902ce0e151_000000000000000000000000000000001& E-398 + convertToDouble -23135572E-127 +} 0xa717e5902ce0e151 +test expr-28.128 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +85900881 E177 x 14375b2214e1b4_111111111111111111111111111111110& E614 + convertToDouble +85900881E177 +} 0x6654375b2214e1b5 +test expr-28.129 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -84863171 E113 x -1a4a8e56474b8b_111111111111111111111111111111110& E401 + convertToDouble -84863171E113 +} 0xd90a4a8e56474b8c +test expr-28.130 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +68761586 E232 x 1a662c350f37f2_1111111111111111111111111111110& E796 + convertToDouble +68761586E232 +} 0x71ba662c350f37f3 +test expr-28.131 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -50464069 E286 x -1948dd06de561e_1111111111111111111111111111110& E975 + convertToDouble -50464069E286 +} 0xfce948dd06de561f +test expr-28.132 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +27869147 E-248 x 1dbbac6f83a820_111111111111111111111111111111111110& E-800 + convertToDouble +27869147E-248 +} 0x0dfdbbac6f83a821 +test expr-28.133 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -55738294 E-248 x -1dbbac6f83a820_111111111111111111111111111111111110& E-799 + convertToDouble -55738294E-248 +} 0x8e0dbbac6f83a821 +test expr-28.134 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +70176353 E-53 x 100683a21de854_1111111111111111111111111111111110& E-150 + convertToDouble +70176353E-53 +} 0x36900683a21de855 +test expr-28.135 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -80555086 E-32 x -1f29ca0ff893b0_111111111111111111111111111111110& E-81 + convertToDouble -80555086E-32 +} 0xbaef29ca0ff893b1 +test expr-28.136 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -491080654 E121 x -1c569e968e0944_00000000000000000000000000000000000000001& E430 + convertToDouble -491080654E121 +} 0xdadc569e968e0944 +test expr-28.137 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +526250918 E287 x 14997a298b2f2e_0000000000000000000000000000000000001& E982 + convertToDouble +526250918E287 +} 0x7d54997a298b2f2e +test expr-28.138 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -245540327 E121 x -1c569e968e0944_00000000000000000000000000000000000000001& E429 + convertToDouble -245540327E121 +} 0xdacc569e968e0944 +test expr-28.139 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -175150874 E-310 x -1805c19e680456_0000000000000000000000000000000000001& E-1003 + convertToDouble -175150874E-310 +} 0x814805c19e680456 +test expr-28.140 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +350301748 E-310 x 1805c19e680456_0000000000000000000000000000000000001& E-1002 + convertToDouble +350301748E-310 +} 0x015805c19e680456 +test expr-28.141 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -437877185 E-311 x -1805c19e680456_0000000000000000000000000000000000001& E-1005 + convertToDouble -437877185E-311 +} 0x812805c19e680456 +test expr-28.142 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +458117166 E52 x 16ce94febdc7a4_1111111111111111111111111111111111110& E201 + convertToDouble +458117166E52 +} 0x4c86ce94febdc7a5 +test expr-28.143 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -916234332 E52 x -16ce94febdc7a4_1111111111111111111111111111111111110& E202 + convertToDouble -916234332E52 +} 0xcc96ce94febdc7a5 +test expr-28.144 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +229058583 E52 x 16ce94febdc7a4_1111111111111111111111111111111111110& E200 + convertToDouble +229058583E52 +} 0x4c76ce94febdc7a5 +test expr-28.145 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -525789935 E98 x -16ecdc2a58fc64_11111111111111111111111111111111110& E354 + convertToDouble -525789935E98 +} 0xd616ecdc2a58fc65 +test expr-28.146 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +282926897 E-227 x 1ff5a70d3d2fee_1111111111111111111111111111111111110& E-727 + convertToDouble +282926897E-227 +} 0x128ff5a70d3d2fef +test expr-28.147 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -565853794 E-227 x -1ff5a70d3d2fee_1111111111111111111111111111111111110& E-726 + convertToDouble -565853794E-227 +} 0x929ff5a70d3d2fef +test expr-28.148 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +667284113 E-240 x 109355f8050c01_111111111111111111111111111111111110& E-768 + convertToDouble +667284113E-240 +} 0x0ff09355f8050c02 +test expr-28.149 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -971212611 E-126 x -1397d3c9745d2e_111111111111111111111111111111111111110& E-389 + convertToDouble -971212611E-126 +} 0xa7a397d3c9745d2f +test expr-28.150 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +9981396317 E-182 x 18afe10a2a66aa_0000000000000000000000000000000000000001& E-572 + convertToDouble +9981396317E-182 +} 0x1c38afe10a2a66aa +test expr-28.151 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -5035231965 E-156 x -101891fc4717fd_00000000000000000000000000000000000001& E-486 + convertToDouble -5035231965E-156 +} 0xa1901891fc4717fd +test expr-28.152 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +8336960483 E-153 x 1a06a1024b95e1_000000000000000000000000000000000000001& E-476 + convertToDouble +8336960483E-153 +} 0x223a06a1024b95e1 +test expr-28.153 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -8056371144 E-155 x -101891fc4717fd_00000000000000000000000000000000000001& E-482 + convertToDouble -8056371144E-155 +} 0xa1d01891fc4717fd +test expr-28.154 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +6418488827 E79 x 1021f14ed7b3f9_11111111111111111111111111111111111111110& E295 + convertToDouble +6418488827E79 +} 0x526021f14ed7b3fa +test expr-28.155 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -3981006983 E252 x -102ebaf189d5f1_1111111111111111111111111111111111111110& E869 + convertToDouble -3981006983E252 +} 0xf6402ebaf189d5f2 +test expr-28.156 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +7962013966 E252 x 102ebaf189d5f1_1111111111111111111111111111111111111110& E870 + convertToDouble +7962013966E252 +} 0x76502ebaf189d5f2 +test expr-28.157 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -4713898551 E261 x -11d8813536e0df_11111111111111111111111111111111111110& E899 + convertToDouble -4713898551E261 +} 0xf821d8813536e0e0 +test expr-28.158 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +8715380633 E-58 x 14614c3219891e_11111111111111111111111111111111111111110& E-160 + convertToDouble +8715380633E-58 +} 0x35f4614c3219891f +test expr-28.159 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -9078555839 E-109 x -1fc575867314ed_111111111111111111111111111111111111111111110& E-330 + convertToDouble -9078555839E-109 +} 0xab5fc575867314ee +test expr-28.160 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +9712126110 E-127 x 1397d3c9745d2e_111111111111111111111111111111111111110& E-389 + convertToDouble +9712126110E-127 +} 0x27a397d3c9745d2f +test expr-28.161 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +42333842451 E201 x 10189a26df575f_000000000000000000000000000000000000000000001& E703 + convertToDouble +42333842451E201 +} 0x6be0189a26df575f +test expr-28.162 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -84667684902 E201 x -10189a26df575f_000000000000000000000000000000000000000000001& E704 + convertToDouble -84667684902E201 +} 0xebf0189a26df575f +test expr-28.163 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +23792120709 E-315 x 10b517dc5d3212_00000000000000000000000000000000000000001& E-1012 + convertToDouble +23792120709E-315 +} 0x00b0b517dc5d3212 +test expr-28.164 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -78564021519 E-227 x -1155515fd37265_00000000000000000000000000000000000000000001& E-718 + convertToDouble -78564021519E-227 +} 0x931155515fd37265 +test expr-28.165 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +71812054883 E-188 x 1747b46d78c6fe_00000000000000000000000000000000000000001& E-589 + convertToDouble +71812054883E-188 +} 0x1b2747b46d78c6fe +test expr-28.166 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -30311163631 E-116 x -163ef6f560afe7_00000000000000000000000000000000000000001& E-351 + convertToDouble -30311163631E-116 +} 0xaa063ef6f560afe7 +test expr-28.167 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +71803914657 E292 x 10c0c44cdc2c05_11111111111111111111111111111111111111111110& E1006 + convertToDouble +71803914657E292 +} 0x7ed0c0c44cdc2c06 +test expr-28.168 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +36314223356 E-109 x 1fc575867314ed_111111111111111111111111111111111111111111110& E-328 + convertToDouble +36314223356E-109 +} 0x2b7fc575867314ee +test expr-28.169 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +18157111678 E-109 x 1fc575867314ed_111111111111111111111111111111111111111111110& E-329 + convertToDouble +18157111678E-109 +} 0x2b6fc575867314ee +test expr-28.170 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -45392779195 E-110 x -1fc575867314ed_111111111111111111111111111111111111111111110& E-331 + convertToDouble -45392779195E-110 +} 0xab4fc575867314ee +test expr-28.171 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +778380362293 E218 x 19ab8261990292_0000000000000000000000000000000000000000000000000001& E763 + convertToDouble +778380362293E218 +} 0x6fa9ab8261990292 +test expr-28.172 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -685763015669 E280 x -15fd7aa44d9477_000000000000000000000000000000000000000000000001& E969 + convertToDouble -685763015669E280 +} 0xfc85fd7aa44d9477 +test expr-28.173 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +952918668151 E70 x 14177a9915fbf8_00000000000000000000000000000000000000000000001& E272 + convertToDouble +952918668151E70 +} 0x50f4177a9915fbf8 +test expr-28.174 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -548357443505 E32 x -13abde2775e9b5_0000000000000000000000000000000000000000000001& E145 + convertToDouble -548357443505E32 +} 0xc903abde2775e9b5 +test expr-28.175 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +384865004907 E-285 x 1aa65b58639e69_00000000000000000000000000000000000000000000001& E-909 + convertToDouble +384865004907E-285 +} 0x072aa65b58639e69 +test expr-28.176 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -769730009814 E-285 x -1aa65b58639e69_00000000000000000000000000000000000000000000001& E-908 + convertToDouble -769730009814E-285 +} 0x873aa65b58639e69 +test expr-28.177 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +697015418417 E-93 x 152847dad80453_0000000000000000000000000000000000000000000001& E-270 + convertToDouble +697015418417E-93 +} 0x2f152847dad80453 +test expr-28.178 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -915654049301 E-28 x -1a645598d05989_0000000000000000000000000000000000000000000001& E-54 + convertToDouble -915654049301E-28 +} 0xbc9a645598d05989 +test expr-28.179 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +178548656339 E169 x 1b89d67c5b6d24_111111111111111111111111111111111111111111110& E598 + convertToDouble +178548656339E169 +} 0x655b89d67c5b6d25 +test expr-28.180 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -742522891517 E259 x -1c1c352fc3c308_11111111111111111111111111111111111111111111110& E899 + convertToDouble -742522891517E259 +} 0xf82c1c352fc3c309 +test expr-28.181 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +742522891517 E258 x 167cf7596968d3_11111111111111111111111111111111111111111111110& E896 + convertToDouble +742522891517E258 +} 0x77f67cf7596968d4 +test expr-28.182 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -357097312678 E169 x -1b89d67c5b6d24_111111111111111111111111111111111111111111110& E599 + convertToDouble -357097312678E169 +} 0xe56b89d67c5b6d25 +test expr-28.183 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -3113521449172 E218 x -19ab8261990292_0000000000000000000000000000000000000000000000000001& E765 + convertToDouble -3113521449172E218 +} 0xefc9ab8261990292 +test expr-28.184 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +3891901811465 E217 x 19ab8261990292_0000000000000000000000000000000000000000000000000001& E762 + convertToDouble +3891901811465E217 +} 0x6f99ab8261990292 +test expr-28.185 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -1556760724586 E218 x -19ab8261990292_0000000000000000000000000000000000000000000000000001& E764 + convertToDouble -1556760724586E218 +} 0xefb9ab8261990292 +test expr-28.186 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +9997878507563 E-195 x 153db2fea1ea31_0000000000000000000000000000000000000000000000001& E-605 + convertToDouble +9997878507563E-195 +} 0x1a253db2fea1ea31 +test expr-28.187 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -7247563029154 E-319 x -10493f056e9ef3_0000000000000000000000000000000000000000000000001& E-1017 + convertToDouble -7247563029154E-319 +} 0x8060493f056e9ef3 +test expr-28.188 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +3623781514577 E-319 x 10493f056e9ef3_0000000000000000000000000000000000000000000000001& E-1018 + convertToDouble +3623781514577E-319 +} 0x0050493f056e9ef3 +test expr-28.189 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -3092446298323 E-200 x -113918353bbc47_0000000000000000000000000000000000000000000000001& E-623 + convertToDouble -3092446298323E-200 +} 0x99013918353bbc47 +test expr-28.190 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +6363857920591 E145 x 128a61cf9483b6_1111111111111111111111111111111111111111111111111110& E524 + convertToDouble +6363857920591E145 +} 0x60b28a61cf9483b7 +test expr-28.191 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -8233559360849 E94 x -11f324d11d4861_1111111111111111111111111111111111111111111111110& E355 + convertToDouble -8233559360849E94 +} 0xd621f324d11d4862 +test expr-28.192 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +2689845954547 E49 x 10bd2bfd34f98a_1111111111111111111111111111111111111111111111110& E204 + convertToDouble +2689845954547E49 +} 0x4cb0bd2bfd34f98b +test expr-28.193 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -5379691909094 E49 x -10bd2bfd34f98a_1111111111111111111111111111111111111111111111110& E205 + convertToDouble -5379691909094E49 +} 0xccc0bd2bfd34f98b +test expr-28.194 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +5560322501926 E-301 x 15acc2053064c1_11111111111111111111111111111111111111111111111110& E-958 + convertToDouble +5560322501926E-301 +} 0x0415acc2053064c2 +test expr-28.195 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -7812878489261 E-179 x -126dae7bbeda74_11111111111111111111111111111111111111111111111111110& E-552 + convertToDouble -7812878489261E-179 +} 0x9d726dae7bbeda75 +test expr-28.196 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +8439398533053 E-256 x 170cc285f2d209_1111111111111111111111111111111111111111111111110& E-808 + convertToDouble +8439398533053E-256 +} 0x0d770cc285f2d20a +test expr-28.197 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -2780161250963 E-301 x -15acc2053064c1_11111111111111111111111111111111111111111111111110& E-959 + convertToDouble -2780161250963E-301 +} 0x8405acc2053064c2 +test expr-28.198 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -87605699161665 E155 x -12920f96e7f9ef_00000000000000000000000000000000000000000000000000001& E561 + convertToDouble -87605699161665E155 +} 0xe302920f96e7f9ef +test expr-28.199 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -17521139832333 E156 x -12920f96e7f9ef_00000000000000000000000000000000000000000000000000001& E562 + convertToDouble -17521139832333E156 +} 0xe312920f96e7f9ef +test expr-28.200 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -88218101363513 E-170 x -18395688592faf_0000000000000000000000000000000000000000000000000001& E-519 + convertToDouble -88218101363513E-170 +} 0x9f88395688592faf +test expr-28.201 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +38639244311627 E-115 x 114ef3e205c817_0000000000000000000000000000000000000000000000000001& E-337 + convertToDouble +38639244311627E-115 +} 0x2ae14ef3e205c817 +test expr-28.202 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +35593959807306 E261 x 1072f3819c1320_11111111111111111111111111111111111111111111111111110& E912 + convertToDouble +35593959807306E261 +} 0x78f072f3819c1321 +test expr-28.203 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -53390939710959 E260 x -13bd243521b08d_11111111111111111111111111111111111111111111111111110& E909 + convertToDouble -53390939710959E260 +} 0xf8c3bd243521b08e +test expr-28.204 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +71187919614612 E261 x 1072f3819c1320_11111111111111111111111111111111111111111111111111110& E913 + convertToDouble +71187919614612E261 +} 0x790072f3819c1321 +test expr-28.205 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -88984899518265 E260 x -1072f3819c1320_11111111111111111111111111111111111111111111111111110& E910 + convertToDouble -88984899518265E260 +} 0xf8d072f3819c1321 +test expr-28.206 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +77003665618895 E-73 x 18bf7e7fa6f029_111111111111111111111111111111111111111111111111111111110& E-197 + convertToDouble +77003665618895E-73 +} 0x33a8bf7e7fa6f02a +test expr-28.207 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -15400733123779 E-72 x -18bf7e7fa6f029_111111111111111111111111111111111111111111111111111111110& E-196 + convertToDouble -15400733123779E-72 +} 0xb3b8bf7e7fa6f02a +test expr-28.208 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +61602932495116 E-72 x 18bf7e7fa6f029_111111111111111111111111111111111111111111111111111111110& E-194 + convertToDouble +61602932495116E-72 +} 0x33d8bf7e7fa6f02a +test expr-28.209 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -30801466247558 E-72 x -18bf7e7fa6f029_111111111111111111111111111111111111111111111111111111110& E-195 + convertToDouble -30801466247558E-72 +} 0xb3c8bf7e7fa6f02a +test expr-28.210 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +834735494917063 E-300 x 1fc6c26f899dd1_0000000000000000000000000000000000000000000000000000000001& E-948 + convertToDouble +834735494917063E-300 +} 0x04bfc6c26f899dd1 +test expr-28.211 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -589795149206434 E-151 x -15f2df5e675a0f_0000000000000000000000000000000000000000000000000000000001& E-453 + convertToDouble -589795149206434E-151 +} 0xa3a5f2df5e675a0f +test expr-28.212 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +475603213226859 E-42 x 12d73088f4050a_000000000000000000000000000000000000000000000000000000001& E-91 + convertToDouble +475603213226859E-42 +} 0x3a42d73088f4050a +test expr-28.213 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -294897574603217 E-151 x -15f2df5e675a0f_0000000000000000000000000000000000000000000000000000000001& E-454 + convertToDouble -294897574603217E-151 +} 0xa395f2df5e675a0f +test expr-28.214 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +850813008001913 E93 x 172f7a1831ad70_11111111111111111111111111111111111111111111111111111110& E358 + convertToDouble +850813008001913E93 +} 0x56572f7a1831ad71 +test expr-28.215 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -203449172043339 E185 x -1102b47e4af987_11111111111111111111111111111111111111111111111111111110& E662 + convertToDouble -203449172043339E185 +} 0xe95102b47e4af988 +test expr-28.216 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +406898344086678 E185 x 1102b47e4af987_11111111111111111111111111111111111111111111111111111110& E663 + convertToDouble +406898344086678E185 +} 0x696102b47e4af988 +test expr-28.217 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -813796688173356 E185 x -1102b47e4af987_11111111111111111111111111111111111111111111111111111110& E664 + convertToDouble -813796688173356E185 +} 0xe97102b47e4af988 +test expr-28.218 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +6045338514609393 E244 x 1f746182e6cd5d_00000000000000000000000000000000000000000000000000000000001& E862 + convertToDouble +6045338514609393E244 +} 0x75df746182e6cd5d +test expr-28.219 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -5145963778954906 E142 x -1dfc11fbf46087_00000000000000000000000000000000000000000000000000000000001& E523 + convertToDouble -5145963778954906E142 +} 0xe0adfc11fbf46087 +test expr-28.220 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +2572981889477453 E142 x 1dfc11fbf46087_00000000000000000000000000000000000000000000000000000000001& E522 + convertToDouble +2572981889477453E142 +} 0x609dfc11fbf46087 +test expr-28.221 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -6965949469487146 E74 x -15e2c10ad970b0_0000000000000000000000000000000000000000000000000000000001& E298 + convertToDouble -6965949469487146E74 +} 0xd295e2c10ad970b0 +test expr-28.222 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +6182410494241627 E-119 x 11b96458445d07_0000000000000000000000000000000000000000000000000000000000001& E-343 + convertToDouble +6182410494241627E-119 +} 0x2a81b96458445d07 +test expr-28.223 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -8510309498186985 E-277 x -1acc46749dccfe_000000000000000000000000000000000000000000000000000000000001& E-868 + convertToDouble -8510309498186985E-277 +} 0x89bacc46749dccfe +test expr-28.224 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +6647704637273331 E-212 x 13e07d2c0cb1e9_0000000000000000000000000000000000000000000000000000000000001& E-652 + convertToDouble +6647704637273331E-212 +} 0x1733e07d2c0cb1e9 +test expr-28.225 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -2215901545757777 E-212 x -1a80a6e566428c_000000000000000000000000000000000000000000000000000000000001& E-654 + convertToDouble -2215901545757777E-212 +} 0x971a80a6e566428c +test expr-28.226 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +3771476185376383 E276 x 183010aba78a53_111111111111111111111111111111111111111111111111111111111110& E968 + convertToDouble +3771476185376383E276 +} 0x7c783010aba78a54 +test expr-28.227 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -3729901848043846 E212 x -1f7d6721f7f143_111111111111111111111111111111111111111111111111111111111110& E755 + convertToDouble -3729901848043846E212 +} 0xef2f7d6721f7f144 +test expr-28.228 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +3771476185376383 E277 x 1e3c14d6916ce8_111111111111111111111111111111111111111111111111111111111110& E971 + convertToDouble +3771476185376383E277 +} 0x7cae3c14d6916ce9 +test expr-28.229 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -9977830465649166 E119 x -15f6de9d5d6b5a_111111111111111111111111111111111111111111111111111111111110& E448 + convertToDouble -9977830465649166E119 +} 0xdbf5f6de9d5d6b5b +test expr-28.230 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +8439928496349319 E-142 x 12483a0f125699_111111111111111111111111111111111111111111111111111111111110& E-419 + convertToDouble +8439928496349319E-142 +} 0x25c2483a0f12569a +test expr-28.231 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -8204230082070882 E-59 x -1d460f4fca1d36_1111111111111111111111111111111111111111111111111111111110& E-144 + convertToDouble -8204230082070882E-59 +} 0xb6fd460f4fca1d37 +test expr-28.232 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +8853686434843997 E-244 x 157a340eb5d4f0_11111111111111111111111111111111111111111111111111111111110& E-758 + convertToDouble +8853686434843997E-244 +} 0x10957a340eb5d4f1 +test expr-28.233 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -5553274272288559 E-104 x -1c47d20a19d1ed_1111111111111111111111111111111111111111111111111111111110& E-294 + convertToDouble -5553274272288559E-104 +} 0xad9c47d20a19d1ee +test expr-28.234 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +36149023611096162 E144 x 1491daad0ba280_0000000000000000000000000000000000000000000000000000000000000001& E533 + convertToDouble +36149023611096162E144 +} 0x614491daad0ba280 +test expr-28.235 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -36149023611096162 E147 x -14166f8cfd5cb1_0000000000000000000000000000000000000000000000000000000000000001& E543 + convertToDouble -36149023611096162E147 +} 0xe1e4166f8cfd5cb1 +test expr-28.236 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +18074511805548081 E146 x 1011f2d73116f4_0000000000000000000000000000000000000000000000000000000000000001& E539 + convertToDouble +18074511805548081E146 +} 0x61a011f2d73116f4 +test expr-28.237 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -18074511805548081 E147 x -14166f8cfd5cb1_0000000000000000000000000000000000000000000000000000000000000001& E542 + convertToDouble -18074511805548081E147 +} 0xe1d4166f8cfd5cb1 +test expr-28.238 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +97338774138954421 E-290 x 10d9b828199006_0000000000000000000000000000000000000000000000000000000000000001& E-907 + convertToDouble +97338774138954421E-290 +} 0x0740d9b828199006 +test expr-28.239 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -88133809804950961 E-308 x -119710dc581911_000000000000000000000000000000000000000000000000000000000000001& E-967 + convertToDouble -88133809804950961E-308 +} 0x83819710dc581911 +test expr-28.240 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +94080055902682397 E-243 x 11d467e94b856e_0000000000000000000000000000000000000000000000000000000000000001& E-751 + convertToDouble +94080055902682397E-243 +} 0x1101d467e94b856e +test expr-28.241 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -24691002732654881 E-115 x -159a2783ce70ab_000000000000000000000000000000000000000000000000000000000000001& E-328 + convertToDouble -24691002732654881E-115 +} 0xab759a2783ce70ab +test expr-28.242 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +52306490527514614 E49 x 13de005bd620de_111111111111111111111111111111111111111111111111111111111111111110& E218 + convertToDouble +52306490527514614E49 +} 0x4d93de005bd620df +test expr-28.243 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -26153245263757307 E49 x -13de005bd620de_111111111111111111111111111111111111111111111111111111111111111110& E217 + convertToDouble -26153245263757307E49 +} 0xcd83de005bd620df +test expr-28.244 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +55188692254193604 E165 x 1a999ddec72ac9_11111111111111111111111111111111111111111111111111111111111110& E603 + convertToDouble +55188692254193604E165 +} 0x65aa999ddec72aca +test expr-28.245 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -68985865317742005 E164 x -1a999ddec72ac9_11111111111111111111111111111111111111111111111111111111111110& E600 + convertToDouble -68985865317742005E164 +} 0xe57a999ddec72aca +test expr-28.246 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +27176258005319167 E-261 x 17c0747bd76fa0_11111111111111111111111111111111111111111111111111111111111111110& E-813 + convertToDouble +27176258005319167E-261 +} 0x0d27c0747bd76fa1 +test expr-28.247 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -73169230107256116 E-248 x -122cea327fa99c_1111111111111111111111111111111111111111111111111111111111110& E-768 + convertToDouble -73169230107256116E-248 +} 0x8ff22cea327fa99d +test expr-28.248 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +91461537634070145 E-249 x 122cea327fa99c_1111111111111111111111111111111111111111111111111111111111110& E-771 + convertToDouble +91461537634070145E-249 +} 0x0fc22cea327fa99d +test expr-28.249 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -54352516010638334 E-261 x -17c0747bd76fa0_11111111111111111111111111111111111111111111111111111111111111110& E-812 + convertToDouble -54352516010638334E-261 +} 0x8d37c0747bd76fa1 +test expr-28.250 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +586144289638535878 E280 x 11eccbd6f62709_0000000000000000000000000000000000000000000000000000000000000000001& E989 + convertToDouble +586144289638535878E280 +} 0x7dc1eccbd6f62709 +test expr-28.251 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -601117006785295431 E245 x -1e8b3525b3737e_000000000000000000000000000000000000000000000000000000000000000001& E872 + convertToDouble -601117006785295431E245 +} 0xf67e8b3525b3737e +test expr-28.252 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +293072144819267939 E280 x 11eccbd6f62709_0000000000000000000000000000000000000000000000000000000000000000001& E988 + convertToDouble +293072144819267939E280 +} 0x7db1eccbd6f62709 +test expr-28.253 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -953184713238516652 E272 x -138fd93f1f5342_00000000000000000000000000000000000000000000000000000000000000001& E963 + convertToDouble -953184713238516652E272 +} 0xfc238fd93f1f5342 +test expr-28.254 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +902042358290366539 E-281 x 122dc01ca1cb8c_0000000000000000000000000000000000000000000000000000000000000000001& E-874 + convertToDouble +902042358290366539E-281 +} 0x09522dc01ca1cb8c +test expr-28.255 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -557035730189854663 E-294 x -13bfac6bc4767b_00000000000000000000000000000000000000000000000000000000000000000001& E-918 + convertToDouble -557035730189854663E-294 +} 0x8693bfac6bc4767b +test expr-28.256 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +902042358290366539 E-280 x 16b93023ca3e6f_0000000000000000000000000000000000000000000000000000000000000000001& E-871 + convertToDouble +902042358290366539E-280 +} 0x0986b93023ca3e6f +test expr-28.257 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -354944100507554393 E-238 x -19a91cece6ad07_000000000000000000000000000000000000000000000000000000000000000001& E-733 + convertToDouble -354944100507554393E-238 +} 0x9229a91cece6ad07 +test expr-28.258 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +272104041512242479 E199 x 1f92bacb3cb40b_11111111111111111111111111111111111111111111111111111111111111111111110& E718 + convertToDouble +272104041512242479E199 +} 0x6cdf92bacb3cb40c +test expr-28.259 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -816312124536727437 E199 x -17ae0c186d8708_11111111111111111111111111111111111111111111111111111111111111111111110& E720 + convertToDouble -816312124536727437E199 +} 0xecf7ae0c186d8709 +test expr-28.260 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +544208083024484958 E199 x 1f92bacb3cb40b_11111111111111111111111111111111111111111111111111111111111111111111110& E719 + convertToDouble +544208083024484958E199 +} 0x6cef92bacb3cb40c +test expr-28.261 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -792644927852378159 E78 x -17bff336d8ff05_111111111111111111111111111111111111111111111111111111111111111111110& E318 + convertToDouble -792644927852378159E78 +} 0xd3d7bff336d8ff06 +test expr-28.262 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -679406450132979175 E-263 x -17c0747bd76fa0_11111111111111111111111111111111111111111111111111111111111111110& E-815 + convertToDouble -679406450132979175E-263 +} 0x8d07c0747bd76fa1 +test expr-28.263 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +543525160106383340 E-262 x 17c0747bd76fa0_11111111111111111111111111111111111111111111111111111111111111110& E-812 + convertToDouble +543525160106383340E-262 +} 0x0d37c0747bd76fa1 +test expr-28.264 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +7400253695682920196 E215 x 1dca94e3990085_00000000000000000000000000000000000000000000000000000000000000000000001& E776 + convertToDouble +7400253695682920196E215 +} 0x707dca94e3990085 +test expr-28.265 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -1850063423920730049 E215 x -1dca94e3990085_00000000000000000000000000000000000000000000000000000000000000000000001& E774 + convertToDouble -1850063423920730049E215 +} 0xf05dca94e3990085 +test expr-28.266 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +3700126847841460098 E215 x 1dca94e3990085_00000000000000000000000000000000000000000000000000000000000000000000001& E775 + convertToDouble +3700126847841460098E215 +} 0x706dca94e3990085 +test expr-28.267 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -9250317119603650245 E214 x -1dca94e3990085_00000000000000000000000000000000000000000000000000000000000000000000001& E773 + convertToDouble -9250317119603650245E214 +} 0xf04dca94e3990085 +test expr-28.268 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +8396094300569779681 E-252 x 1ab223efcee35a_0000000000000000000000000000000000000000000000000000000000000000000000001& E-775 + convertToDouble +8396094300569779681E-252 +} 0x0f8ab223efcee35a +test expr-28.269 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -3507665085003296281 E-75 x -160499b881ea50_00000000000000000000000000000000000000000000000000000000000000000000001& E-188 + convertToDouble -3507665085003296281E-75 +} 0xb4360499b881ea50 +test expr-28.270 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +7015330170006592562 E-75 x 160499b881ea50_00000000000000000000000000000000000000000000000000000000000000000000001& E-187 + convertToDouble +7015330170006592562E-75 +} 0x34460499b881ea50 +test expr-28.271 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -7015330170006592562 E-74 x -1b85c026a264e4_00000000000000000000000000000000000000000000000000000000000000000000001& E-184 + convertToDouble -7015330170006592562E-74 +} 0xb47b85c026a264e4 +test expr-28.272 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +7185620434951919351 E205 x 18d92d2bcc7a80_1111111111111111111111111111111111111111111111111111111111111111111111110& E743 + convertToDouble +7185620434951919351E205 +} 0x6e68d92d2bcc7a81 +test expr-28.273 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -1360520207561212395 E198 x -1f92bacb3cb40b_11111111111111111111111111111111111111111111111111111111111111111111110& E717 + convertToDouble -1360520207561212395E198 +} 0xeccf92bacb3cb40c +test expr-28.274 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +2178999185345151731 E-184 x 19b2c4d2a82335_1111111111111111111111111111111111111111111111111111111111111111111110& E-551 + convertToDouble +2178999185345151731E-184 +} 0x1d89b2c4d2a82336 +test expr-28.275 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -8691089486201567102 E-218 x -1a9c42e5b6d89e_1111111111111111111111111111111111111111111111111111111111111111111110& E-662 + convertToDouble -8691089486201567102E-218 +} 0x969a9c42e5b6d89f +test expr-28.276 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +4345544743100783551 E-218 x 1a9c42e5b6d89e_1111111111111111111111111111111111111111111111111111111111111111111110& E-663 + convertToDouble +4345544743100783551E-218 +} 0x168a9c42e5b6d89f +test expr-28.277 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -4357998370690303462 E-184 x -19b2c4d2a82335_1111111111111111111111111111111111111111111111111111111111111111111110& E-550 + convertToDouble -4357998370690303462E-184 +} 0x9d99b2c4d2a82336 +test expr-28.278 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +59825267349106892461 E177 x 199c476d7868df_000000000000000000000000000000000000000000000000000000000000000000000001& E653 + convertToDouble +59825267349106892461E177 +} 0x68c99c476d7868df +test expr-28.279 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -62259110684423957791 E47 x -1d8f2cfc20d6e8_0000000000000000000000000000000000000000000000000000000000000000000000001& E221 + convertToDouble -62259110684423957791E47 +} 0xcdcd8f2cfc20d6e8 +test expr-28.280 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +58380168477038565599 E265 x 1f686e9efbe48d_00000000000000000000000000000000000000000000000000000000000000000000000001& E945 + convertToDouble +58380168477038565599E265 +} 0x7b0f686e9efbe48d +test expr-28.281 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -62259110684423957791 E48 x -12797c1d948651_0000000000000000000000000000000000000000000000000000000000000000000000001& E225 + convertToDouble -62259110684423957791E48 +} 0xce02797c1d948651 +test expr-28.282 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -33584377202279118724 E-252 x -1ab223efcee35a_0000000000000000000000000000000000000000000000000000000000000000000000001& E-773 + convertToDouble -33584377202279118724E-252 +} 0x8faab223efcee35a +test expr-28.283 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -57484963479615354808 E205 x -18d92d2bcc7a80_1111111111111111111111111111111111111111111111111111111111111111111111110& E746 + convertToDouble -57484963479615354808E205 +} 0xee98d92d2bcc7a81 +test expr-28.284 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +71856204349519193510 E204 x 18d92d2bcc7a80_1111111111111111111111111111111111111111111111111111111111111111111111110& E743 + convertToDouble +71856204349519193510E204 +} 0x6e68d92d2bcc7a81 +test expr-28.285 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -14371240869903838702 E205 x -18d92d2bcc7a80_1111111111111111111111111111111111111111111111111111111111111111111111110& E744 + convertToDouble -14371240869903838702E205 +} 0xee78d92d2bcc7a81 +test expr-28.286 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +36992084760177624177 E-318 x 18c5f9551c2f99_111111111111111111111111111111111111111111111111111111111111111111111110& E-992 + convertToDouble +36992084760177624177E-318 +} 0x01f8c5f9551c2f9a +test expr-28.287 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -73984169520355248354 E-318 x -18c5f9551c2f99_111111111111111111111111111111111111111111111111111111111111111111111110& E-991 + convertToDouble -73984169520355248354E-318 +} 0x8208c5f9551c2f9a +test expr-28.288 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +99257763227713890244 E-115 x 15338a554b9ce0_11111111111111111111111111111111111111111111111111111111111111111111110& E-316 + convertToDouble +99257763227713890244E-115 +} 0x2c35338a554b9ce1 +test expr-28.289 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -87336362425182547697 E-280 x -1130304e7d9c32_11111111111111111111111111111111111111111111111111111111111111111111110& E-864 + convertToDouble -87336362425182547697E-280 +} 0x89f130304e7d9c33 +test expr-28.290 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +7 E289 x 1cbb547777a284_10000000001& E962 + convertToDouble +7E289 +} 0x7c1cbb547777a285 +test expr-28.291 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -3 E153 x -1ca3d8e6d80cba_100000001& E509 + convertToDouble -3E153 +} 0xdfcca3d8e6d80cbb +test expr-28.292 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +6 E153 x 1ca3d8e6d80cba_100000001& E510 + convertToDouble +6E153 +} 0x5fdca3d8e6d80cbb +test expr-28.293 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -5 E243 x -176ec98994f488_10000001& E809 + convertToDouble -5E243 +} 0xf2876ec98994f489 +test expr-28.294 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +7 E-161 x 1f7e0db3799aa2_10000000001& E-533 + convertToDouble +7E-161 +} 0x1eaf7e0db3799aa3 +test expr-28.295 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -7 E-172 x -15a4337446ef2a_1000000001& E-569 + convertToDouble -7E-172 +} 0x9c65a4337446ef2b +test expr-28.296 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +8 E-63 x 1a53fc9631d10c_10000001& E-207 + convertToDouble +8E-63 +} 0x330a53fc9631d10d +test expr-28.297 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -7 E-113 x -158c47e6eea282_10000001& E-373 + convertToDouble -7E-113 +} 0xa8a58c47e6eea283 +test expr-28.298 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +8 E126 x 17a2ecc414a03f_0111111111110& E421 + convertToDouble +8E126 +} 0x5a47a2ecc414a03f +test expr-28.299 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -4 E126 x -17a2ecc414a03f_0111111111110& E420 + convertToDouble -4E126 +} 0xda37a2ecc414a03f +test expr-28.300 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +5 E125 x 17a2ecc414a03f_0111111111110& E417 + convertToDouble +5E125 +} 0x5a07a2ecc414a03f +test expr-28.301 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -1 E126 x -17a2ecc414a03f_0111111111110& E418 + convertToDouble -1E126 +} 0xda17a2ecc414a03f +test expr-28.302 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +8 E-163 x 1708d0f84d3de7_011111110& E-539 + convertToDouble +8E-163 +} 0x1e4708d0f84d3de7 +test expr-28.303 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -1 E-163 x -1708d0f84d3de7_011111110& E-542 + convertToDouble -1E-163 +} 0x9e1708d0f84d3de7 +test expr-28.304 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +2 E-163 x 1708d0f84d3de7_011111110& E-541 + convertToDouble +2E-163 +} 0x1e2708d0f84d3de7 +test expr-28.305 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -4 E-163 x -1708d0f84d3de7_011111110& E-540 + convertToDouble -4E-163 +} 0x9e3708d0f84d3de7 +test expr-28.306 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +51 E195 x 15d51d249dca42_1000000000001& E653 + convertToDouble +51E195 +} 0x68c5d51d249dca43 +test expr-28.307 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -37 E46 x -1033d7eca0adee_100000000000001& E158 + convertToDouble -37E46 +} 0xc9d033d7eca0adef +test expr-28.308 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +74 E46 x 1033d7eca0adee_100000000000001& E159 + convertToDouble +74E46 +} 0x49e033d7eca0adef +test expr-28.309 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -56 E289 x -1cbb547777a284_10000000001& E965 + convertToDouble -56E289 +} 0xfc4cbb547777a285 +test expr-28.310 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +69 E-145 x 158a41b31c9a9a_100000000001& E-476 + convertToDouble +69E-145 +} 0x22358a41b31c9a9b +test expr-28.311 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -70 E-162 x -1f7e0db3799aa2_10000000001& E-533 + convertToDouble -70E-162 +} 0x9eaf7e0db3799aa3 +test expr-28.312 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +56 E-161 x 1f7e0db3799aa2_10000000001& E-530 + convertToDouble +56E-161 +} 0x1edf7e0db3799aa3 +test expr-28.313 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -21 E-303 x -1ccd59caa6a750_10000000001& E-1003 + convertToDouble -21E-303 +} 0x814ccd59caa6a751 +test expr-28.314 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +34 E-276 x 12d5a4350d30ff_011111111110& E-912 + convertToDouble +34E-276 +} 0x06f2d5a4350d30ff +test expr-28.315 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -68 E-276 x -12d5a4350d30ff_011111111110& E-911 + convertToDouble -68E-276 +} 0x8702d5a4350d30ff +test expr-28.316 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +85 E-277 x 12d5a4350d30ff_011111111110& E-914 + convertToDouble +85E-277 +} 0x06d2d5a4350d30ff +test expr-28.317 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -87 E-274 x -12d36cf48e7abd_011111111111110& E-904 + convertToDouble -87E-274 +} 0x8772d36cf48e7abd +test expr-28.318 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +829 E102 x 17221a79cdd1d8_1000000000000001& E348 + convertToDouble +829E102 +} 0x55b7221a79cdd1d9 +test expr-28.319 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -623 E100 x -1640a62f3a83de_10000000000000000001& E341 + convertToDouble -623E100 +} 0xd54640a62f3a83df +test expr-28.320 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +723 E-162 x 145457ee24abd2_1000000000000001& E-529 + convertToDouble +723E-162 +} 0x1ee45457ee24abd3 +test expr-28.321 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -457 E-102 x -1ffc81bc29f02a_100000000000000001& E-331 + convertToDouble -457E-102 +} 0xab4ffc81bc29f02b +test expr-28.322 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +914 E-102 x 1ffc81bc29f02a_100000000000000001& E-330 + convertToDouble +914E-102 +} 0x2b5ffc81bc29f02b +test expr-28.323 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -323 E-135 x -1d589ae4d70218_10000000000001& E-441 + convertToDouble -323E-135 +} 0xa46d589ae4d70219 +test expr-28.324 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +151 E176 x 1dcf7df8f573b7_0111111111111111110& E591 + convertToDouble +151E176 +} 0x64edcf7df8f573b7 +test expr-28.325 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -302 E176 x -1dcf7df8f573b7_0111111111111111110& E592 + convertToDouble -302E176 +} 0xe4fdcf7df8f573b7 +test expr-28.326 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +921 E90 x 1c420a45fd70ff_0111111111111110& E308 + convertToDouble +921E90 +} 0x533c420a45fd70ff +test expr-28.327 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -604 E176 x -1dcf7df8f573b7_0111111111111111110& E593 + convertToDouble -604E176 +} 0xe50dcf7df8f573b7 +test expr-28.328 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +823 E-206 x 14a48933c208ad_0111111111111110& E-675 + convertToDouble +823E-206 +} 0x15c4a48933c208ad +test expr-28.329 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -463 E-114 x -11d0c83f6378a5_011111111111110& E-370 + convertToDouble -463E-114 +} 0xa8d1d0c83f6378a5 +test expr-28.330 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +348 E-274 x 12d36cf48e7abd_011111111111110& E-902 + convertToDouble +348E-274 +} 0x0792d36cf48e7abd +test expr-28.331 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +9968 E100 x 1640a62f3a83de_10000000000000000001& E345 + convertToDouble +9968E100 +} 0x558640a62f3a83df +test expr-28.332 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -6230 E99 x -1640a62f3a83de_10000000000000000001& E341 + convertToDouble -6230E99 +} 0xd54640a62f3a83df +test expr-28.333 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +1246 E100 x 1640a62f3a83de_10000000000000000001& E342 + convertToDouble +1246E100 +} 0x555640a62f3a83df +test expr-28.334 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +6676 E-296 x 15519ac5142aaa_1000000000000000000001& E-971 + convertToDouble +6676E-296 +} 0x0345519ac5142aab +test expr-28.335 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -8345 E-297 x -15519ac5142aaa_1000000000000000000001& E-974 + convertToDouble -8345E-297 +} 0x8315519ac5142aab +test expr-28.336 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +1669 E-296 x 15519ac5142aaa_1000000000000000000001& E-973 + convertToDouble +1669E-296 +} 0x0325519ac5142aab +test expr-28.337 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -3338 E-296 x -15519ac5142aaa_1000000000000000000001& E-972 + convertToDouble -3338E-296 +} 0x8335519ac5142aab +test expr-28.338 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +3257 E58 x 1444b34a6fb3eb_01111111111111111110& E204 + convertToDouble +3257E58 +} 0x4cb444b34a6fb3eb +test expr-28.339 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -6514 E58 x -1444b34a6fb3eb_01111111111111111110& E205 + convertToDouble -6514E58 +} 0xccc444b34a6fb3eb +test expr-28.340 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +2416 E176 x 1dcf7df8f573b7_0111111111111111110& E595 + convertToDouble +2416E176 +} 0x652dcf7df8f573b7 +test expr-28.341 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +8085 E-63 x 19fbf3c19b9a79_0111111111111111110& E-197 + convertToDouble +8085E-63 +} 0x33a9fbf3c19b9a79 +test expr-28.342 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -3234 E-62 x -19fbf3c19b9a79_0111111111111111110& E-195 + convertToDouble -3234E-62 +} 0xb3c9fbf3c19b9a79 +test expr-28.343 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +1617 E-62 x 19fbf3c19b9a79_0111111111111111110& E-196 + convertToDouble +1617E-62 +} 0x33b9fbf3c19b9a79 +test expr-28.344 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -6468 E-62 x -19fbf3c19b9a79_0111111111111111110& E-194 + convertToDouble -6468E-62 +} 0xb3d9fbf3c19b9a79 +test expr-28.345 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +53418 E111 x 15b1051df943a8_1000000000000000000001& E384 + convertToDouble +53418E111 +} 0x57f5b1051df943a9 +test expr-28.346 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -60513 E160 x -15043b64e56c72_1000000000000000000001& E547 + convertToDouble -60513E160 +} 0xe225043b64e56c73 +test expr-28.347 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +26709 E111 x 15b1051df943a8_1000000000000000000001& E383 + convertToDouble +26709E111 +} 0x57e5b1051df943a9 +test expr-28.348 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -99447 E166 x -10782189b336ae_1000000000000000000001& E568 + convertToDouble -99447E166 +} 0xe370782189b336af +test expr-28.349 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +12549 E48 x 10c52fe6dc6a1b_011111111111111111111110& E173 + convertToDouble +12549E48 +} 0x4ac0c52fe6dc6a1b +test expr-28.350 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -25098 E48 x -10c52fe6dc6a1b_011111111111111111111110& E174 + convertToDouble -25098E48 +} 0xcad0c52fe6dc6a1b +test expr-28.351 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +50196 E48 x 10c52fe6dc6a1b_011111111111111111111110& E175 + convertToDouble +50196E48 +} 0x4ae0c52fe6dc6a1b +test expr-28.352 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -62745 E47 x -10c52fe6dc6a1b_011111111111111111111110& E172 + convertToDouble -62745E47 +} 0xcab0c52fe6dc6a1b +test expr-28.353 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +83771 E-73 x 1ce886fb5ffd6d_0111111111111111111110& E-227 + convertToDouble +83771E-73 +} 0x31cce886fb5ffd6d +test expr-28.354 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -97451 E-167 x -1c0f220fb1c70d_01111111111111111111110& E-539 + convertToDouble -97451E-167 +} 0x9e4c0f220fb1c70d +test expr-28.355 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +86637 E-203 x 10943edb4e81db_0111111111111111111110& E-658 + convertToDouble +86637E-203 +} 0x16d0943edb4e81db +test expr-28.356 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -75569 E-254 x -15a462d91c6ab3_0111111111111111111111111110& E-828 + convertToDouble -75569E-254 +} 0x8c35a462d91c6ab3 +test expr-28.357 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +473806 E83 x 17d15bf3186080_1000000000000000000000001& E294 + convertToDouble +473806E83 +} 0x5257d15bf3186081 +test expr-28.358 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -947612 E83 x -17d15bf3186080_1000000000000000000000001& E295 + convertToDouble -947612E83 +} 0xd267d15bf3186081 +test expr-28.359 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +292369 E76 x 18a85eb277e644_100000000000000000000000001& E270 + convertToDouble +292369E76 +} 0x50d8a85eb277e645 +test expr-28.360 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -584738 E76 x -18a85eb277e644_100000000000000000000000001& E271 + convertToDouble -584738E76 +} 0xd0e8a85eb277e645 +test expr-28.361 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +933587 E-140 x 1b248728b9c116_100000000000000000000000001& E-446 + convertToDouble +933587E-140 +} 0x241b248728b9c117 +test expr-28.362 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -720919 E-14 x -1ef696965cbf04_10000000000000000000000001& E-28 + convertToDouble -720919E-14 +} 0xbe3ef696965cbf05 +test expr-28.363 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +535001 E-149 x 10b38e07c745ae_1000000000000000000000001& E-476 + convertToDouble +535001E-149 +} 0x2230b38e07c745af +test expr-28.364 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -890521 E-235 x -114828ee39c852_1000000000000000000000001& E-761 + convertToDouble -890521E-235 +} 0x90614828ee39c853 +test expr-28.365 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +548057 E81 x 11a1d9135cca53_0111111111111111111111110& E288 + convertToDouble +548057E81 +} 0x51f1a1d9135cca53 +test expr-28.366 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -706181 E88 x -1b156ac4c2d1e5_0111111111111111111111110& E311 + convertToDouble -706181E88 +} 0xd36b156ac4c2d1e5 +test expr-28.367 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +820997 E106 x 1b4f8b64fa125d_0111111111111111111111110& E371 + convertToDouble +820997E106 +} 0x572b4f8b64fa125d +test expr-28.368 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -320681 E63 x -17ca18a876c5ef_0111111111111111111111110& E227 + convertToDouble -320681E63 +} 0xce27ca18a876c5ef +test expr-28.369 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +928609 E-261 x 1be2dd66200bef_011111111111111111111111111110& E-848 + convertToDouble +928609E-261 +} 0x0afbe2dd66200bef +test expr-28.370 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -302276 E-254 x -15a462d91c6ab3_0111111111111111111111111110& E-826 + convertToDouble -302276E-254 +} 0x8c55a462d91c6ab3 +test expr-28.371 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +151138 E-254 x 15a462d91c6ab3_0111111111111111111111111110& E-827 + convertToDouble +151138E-254 +} 0x0c45a462d91c6ab3 +test expr-28.372 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +4691773 E45 x 19147b9330eaae_1000000000000000000000000001& E171 + convertToDouble +4691773E45 +} 0x4aa9147b9330eaaf +test expr-28.373 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -9383546 E45 x -19147b9330eaae_1000000000000000000000000001& E172 + convertToDouble -9383546E45 +} 0xcab9147b9330eaaf +test expr-28.374 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +3059949 E-243 x 13ecf22ea07862_10000000000000000000000000001& E-786 + convertToDouble +3059949E-243 +} 0x0ed3ecf22ea07863 +test expr-28.375 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -6119898 E-243 x -13ecf22ea07862_10000000000000000000000000001& E-785 + convertToDouble -6119898E-243 +} 0x8ee3ecf22ea07863 +test expr-28.376 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +5356626 E-213 x 1b84252abdf6ba_100000000000000000000000001& E-686 + convertToDouble +5356626E-213 +} 0x151b84252abdf6bb +test expr-28.377 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -4877378 E-199 x -11cd5cd90cb200_100000000000000000000000001& E-639 + convertToDouble -4877378E-199 +} 0x9801cd5cd90cb201 +test expr-28.378 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +7716693 E223 x 1972d9d2cff683_01111111111111111111111111110& E763 + convertToDouble +7716693E223 +} 0x6fa972d9d2cff683 +test expr-28.379 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -5452869 E109 x -16247b136fecc3_01111111111111111111111111110& E384 + convertToDouble -5452869E109 +} 0xd7f6247b136fecc3 +test expr-28.380 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +4590831 E156 x 14689b4a5fa201_011111111111111111111111111110& E540 + convertToDouble +4590831E156 +} 0x61b4689b4a5fa201 +test expr-28.381 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -9181662 E156 x -14689b4a5fa201_011111111111111111111111111110& E541 + convertToDouble -9181662E156 +} 0xe1c4689b4a5fa201 +test expr-28.382 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -3714436 E-261 x -1be2dd66200bef_011111111111111111111111111110& E-846 + convertToDouble -3714436E-261 +} 0x8b1be2dd66200bef +test expr-28.383 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +4643045 E-262 x 1be2dd66200bef_011111111111111111111111111110& E-849 + convertToDouble +4643045E-262 +} 0x0aebe2dd66200bef +test expr-28.384 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -7428872 E-261 x -1be2dd66200bef_011111111111111111111111111110& E-845 + convertToDouble -7428872E-261 +} 0x8b2be2dd66200bef +test expr-28.385 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +52942146 E130 x 16c31d08af89c2_10000000000000000000000000000001& E457 + convertToDouble +52942146E130 +} 0x5c86c31d08af89c3 +test expr-28.386 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -27966061 E145 x -155bcf72fd10f8_1000000000000000000000000000000001& E506 + convertToDouble -27966061E145 +} 0xdf955bcf72fd10f9 +test expr-28.387 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +26471073 E130 x 16c31d08af89c2_10000000000000000000000000000001& E456 + convertToDouble +26471073E130 +} 0x5c76c31d08af89c3 +test expr-28.388 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -55932122 E145 x -155bcf72fd10f8_1000000000000000000000000000000001& E507 + convertToDouble -55932122E145 +} 0xdfa55bcf72fd10f9 +test expr-28.389 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +95412548 E-99 x 18e0bfb98864c8_100000000000000000000000000000001& E-303 + convertToDouble +95412548E-99 +} 0x2d08e0bfb98864c9 +test expr-28.390 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -47706274 E-99 x -18e0bfb98864c8_100000000000000000000000000000001& E-304 + convertToDouble -47706274E-99 +} 0xacf8e0bfb98864c9 +test expr-28.391 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +23853137 E-99 x 18e0bfb98864c8_100000000000000000000000000000001& E-305 + convertToDouble +23853137E-99 +} 0x2ce8e0bfb98864c9 +test expr-28.392 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -78493654 E-301 x -140d76077b648e_10000000000000000000000000000001& E-974 + convertToDouble -78493654E-301 +} 0x83140d76077b648f +test expr-28.393 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +65346417 E29 x 13aa1ad778f23b_0111111111111111111111111111110& E122 + convertToDouble +65346417E29 +} 0x4793aa1ad778f23b +test expr-28.394 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -51083099 E167 x -14a75eb58df47b_0111111111111111111111111111110& E580 + convertToDouble -51083099E167 +} 0xe434a75eb58df47b +test expr-28.395 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +89396333 E264 x 1526f061ca9053_0111111111111111111111111111111110& E903 + convertToDouble +89396333E264 +} 0x786526f061ca9053 +test expr-28.396 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -84863171 E114 x -106e98f5ec8f37_0111111111111111111111111111111110& E405 + convertToDouble -84863171E114 +} 0xd9406e98f5ec8f37 +test expr-28.397 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +59540836 E-251 x 10430c2d075c07_011111111111111111111111111111110& E-808 + convertToDouble +59540836E-251 +} 0x0d70430c2d075c07 +test expr-28.398 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -74426045 E-252 x -10430c2d075c07_011111111111111111111111111111110& E-811 + convertToDouble -74426045E-252 +} 0x8d40430c2d075c07 +test expr-28.399 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +14885209 E-251 x 10430c2d075c07_011111111111111111111111111111110& E-810 + convertToDouble +14885209E-251 +} 0x0d50430c2d075c07 +test expr-28.400 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -29770418 E-251 x -10430c2d075c07_011111111111111111111111111111110& E-809 + convertToDouble -29770418E-251 +} 0x8d60430c2d075c07 +test expr-28.401 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +982161308 E122 x 11b6231e18c5ca_100000000000000000000000000000000000000001& E435 + convertToDouble +982161308E122 +} 0x5b21b6231e18c5cb +test expr-28.402 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -245540327 E122 x -11b6231e18c5ca_100000000000000000000000000000000000000001& E433 + convertToDouble -245540327E122 +} 0xdb01b6231e18c5cb +test expr-28.403 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +491080654 E122 x 11b6231e18c5ca_100000000000000000000000000000000000000001& E434 + convertToDouble +491080654E122 +} 0x5b11b6231e18c5cb +test expr-28.404 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +525452622 E-310 x 12045136ce0340_1000000000000000000000000000000000001& E-1001 + convertToDouble +525452622E-310 +} 0x0162045136ce0341 +test expr-28.405 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -771837113 E-134 x -14e61f991c4ed0_100000000000000000000000000000000001& E-416 + convertToDouble -771837113E-134 +} 0xa5f4e61f991c4ed1 +test expr-28.406 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +820858081 E-150 x 14050669985a86_10000000000000000000000000000000001& E-469 + convertToDouble +820858081E-150 +} 0x22a4050669985a87 +test expr-28.407 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -262726311 E-310 x -12045136ce0340_1000000000000000000000000000000000001& E-1002 + convertToDouble -262726311E-310 +} 0x8152045136ce0341 +test expr-28.408 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +923091487 E209 x 10bc60e6896717_011111111111111111111111111111111110& E724 + convertToDouble +923091487E209 +} 0x6d30bc60e6896717 +test expr-28.409 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -653777767 E273 x -120223f2b3a881_0111111111111111111111111111111111111110& E936 + convertToDouble -653777767E273 +} 0xfa720223f2b3a881 +test expr-28.410 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +842116236 E-53 x 1809c5732cdc7f_0111111111111111111111111111111110& E-147 + convertToDouble +842116236E-53 +} 0x36c809c5732cdc7f +test expr-28.411 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -741111169 E-202 x -15a3e1d1b73099_01111111111111111111111111111111110& E-642 + convertToDouble -741111169E-202 +} 0x97d5a3e1d1b73099 +test expr-28.412 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +839507247 E-284 x 129a1effc50859_0111111111111111111111111111111110& E-914 + convertToDouble +839507247E-284 +} 0x06d29a1effc50859 +test expr-28.413 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -951487269 E-264 x -1c92befccb5f59_0111111111111111111111111111111110& E-848 + convertToDouble -951487269E-264 +} 0x8afc92befccb5f59 +test expr-28.414 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -9821613080 E121 x -11b6231e18c5ca_100000000000000000000000000000000000000001& E435 + convertToDouble -9821613080E121 +} 0xdb21b6231e18c5cb +test expr-28.415 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +6677856011 E-31 x 193a6d11077292_100000000000000000000000000000000000001& E-71 + convertToDouble +6677856011E-31 +} 0x3b893a6d11077293 +test expr-28.416 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -3573796826 E-266 x -112be2041a79fc_100000000000000000000000000000000000001& E-852 + convertToDouble -3573796826E-266 +} 0x8ab12be2041a79fd +test expr-28.417 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +7147593652 E-266 x 112be2041a79fc_100000000000000000000000000000000000001& E-851 + convertToDouble +7147593652E-266 +} 0x0ac12be2041a79fd +test expr-28.418 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -9981396317 E-181 x -1edbd94cb50054_100000000000000000000000000000000000001& E-569 + convertToDouble -9981396317E-181 +} 0x9c6edbd94cb50055 +test expr-28.419 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +3268888835 E272 x 120223f2b3a881_0111111111111111111111111111111111111110& E935 + convertToDouble +3268888835E272 +} 0x7a620223f2b3a881 +test expr-28.420 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -2615111068 E273 x -120223f2b3a881_0111111111111111111111111111111111111110& E938 + convertToDouble -2615111068E273 +} 0xfa920223f2b3a881 +test expr-28.421 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +1307555534 E273 x 120223f2b3a881_0111111111111111111111111111111111111110& E937 + convertToDouble +1307555534E273 +} 0x7a820223f2b3a881 +test expr-28.422 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +2990671154 E-190 x 13db11ac608107_01111111111111111111111111111111111111110& E-600 + convertToDouble +2990671154E-190 +} 0x1a73db11ac608107 +test expr-28.423 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -1495335577 E-190 x -13db11ac608107_01111111111111111111111111111111111111110& E-601 + convertToDouble -1495335577E-190 +} 0x9a63db11ac608107 +test expr-28.424 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +5981342308 E-190 x 13db11ac608107_01111111111111111111111111111111111111110& E-599 + convertToDouble +5981342308E-190 +} 0x1a83db11ac608107 +test expr-28.425 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -7476677885 E-191 x -13db11ac608107_01111111111111111111111111111111111111110& E-602 + convertToDouble -7476677885E-191 +} 0x9a53db11ac608107 +test expr-28.426 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +82259684194 E-202 x 12c3e72d179606_1000000000000000000000000000000000000000001& E-635 + convertToDouble +82259684194E-202 +} 0x1842c3e72d179607 +test expr-28.427 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -93227267727 E-49 x -1960fe08d5847e_100000000000000000000000000000000000000001& E-127 + convertToDouble -93227267727E-49 +} 0xb80960fe08d5847f +test expr-28.428 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +41129842097 E-202 x 12c3e72d179606_1000000000000000000000000000000000000000001& E-636 + convertToDouble +41129842097E-202 +} 0x1832c3e72d179607 +test expr-28.429 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -47584241418 E-314 x -14e25dd3747e96_10000000000000000000000000000000000000001& E-1008 + convertToDouble -47584241418E-314 +} 0x80f4e25dd3747e97 +test expr-28.430 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -79360293406 E92 x -1c58a00bb31863_01111111111111111111111111111111111111110& E341 + convertToDouble -79360293406E92 +} 0xd54c58a00bb31863 +test expr-28.431 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +57332259349 E225 x 120811f528378b_01111111111111111111111111111111111111110& E783 + convertToDouble +57332259349E225 +} 0x70e20811f528378b +test expr-28.432 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -57202326162 E111 x -1626f1c480545b_01111111111111111111111111111111111111110& E404 + convertToDouble -57202326162E111 +} 0xd93626f1c480545b +test expr-28.433 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +86860597053 E-206 x 103b77d2b969d9_0111111111111111111111111111111111111111110& E-648 + convertToDouble +86860597053E-206 +} 0x17703b77d2b969d9 +test expr-28.434 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -53827010643 E-200 x -132fa69a69bd6d_0111111111111111111111111111111111111111110& E-629 + convertToDouble -53827010643E-200 +} 0x98a32fa69a69bd6d +test expr-28.435 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +53587107423 E-61 x 100a19a3ffd981_011111111111111111111111111111111111111111110& E-167 + convertToDouble +53587107423E-61 +} 0x35800a19a3ffd981 +test expr-28.436 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +635007636765 E200 x 1824e73a4f030e_100000000000000000000000000000000000000000001& E703 + convertToDouble +635007636765E200 +} 0x6be824e73a4f030f +test expr-28.437 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +508006109412 E201 x 1824e73a4f030e_100000000000000000000000000000000000000000001& E706 + convertToDouble +508006109412E201 +} 0x6c1824e73a4f030f +test expr-28.438 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -254003054706 E201 x -1824e73a4f030e_100000000000000000000000000000000000000000001& E705 + convertToDouble -254003054706E201 +} 0xec0824e73a4f030f +test expr-28.439 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +561029718715 E-72 x 1cd96a6972a14a_100000000000000000000000000000000000000000001& E-201 + convertToDouble +561029718715E-72 +} 0x336cd96a6972a14b +test expr-28.440 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -897647549944 E-71 x -1cd96a6972a14a_100000000000000000000000000000000000000000001& E-197 + convertToDouble -897647549944E-71 +} 0xb3acd96a6972a14b +test expr-28.441 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +112205943743 E-71 x 1cd96a6972a14a_100000000000000000000000000000000000000000001& E-200 + convertToDouble +112205943743E-71 +} 0x337cd96a6972a14b +test expr-28.442 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -873947086081 E-236 x -19e117541d04e6_1000000000000000000000000000000000000000000001& E-745 + convertToDouble -873947086081E-236 +} 0x9169e117541d04e7 +test expr-28.443 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +809184709177 E116 x 1de27e59fb0679_011111111111111111111111111111111111111111110& E424 + convertToDouble +809184709177E116 +} 0x5a7de27e59fb0679 +test expr-28.444 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -573112917422 E81 x -11958b36c5102b_01111111111111111111111111111111111111111111110& E308 + convertToDouble -573112917422E81 +} 0xd331958b36c5102b +test expr-28.445 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +286556458711 E81 x 11958b36c5102b_01111111111111111111111111111111111111111111110& E307 + convertToDouble +286556458711E81 +} 0x5321958b36c5102b +test expr-28.446 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +952805821491 E-259 x 1551767ef8a9a3_011111111111111111111111111111111111111111110& E-821 + convertToDouble +952805821491E-259 +} 0x0ca551767ef8a9a3 +test expr-28.447 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -132189992873 E-44 x -1b746cf242410b_011111111111111111111111111111111111111111110& E-110 + convertToDouble -132189992873E-44 +} 0xb91b746cf242410b +test expr-28.448 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -173696038493 E-144 x -1f8fefbb3249d3_011111111111111111111111111111111111111111110& E-442 + convertToDouble -173696038493E-144 +} 0xa45f8fefbb3249d3 +test expr-28.449 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +1831132757599 E-107 x 138e6edd48f2a2_1000000000000000000000000000000000000000000000001& E-315 + convertToDouble +1831132757599E-107 +} 0x2c438e6edd48f2a3 +test expr-28.450 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -9155663787995 E-108 x -138e6edd48f2a2_1000000000000000000000000000000000000000000000001& E-316 + convertToDouble -9155663787995E-108 +} 0xac338e6edd48f2a3 +test expr-28.451 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +7324531030396 E-107 x 138e6edd48f2a2_1000000000000000000000000000000000000000000000001& E-313 + convertToDouble +7324531030396E-107 +} 0x2c638e6edd48f2a3 +test expr-28.452 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -9277338894969 E-200 x -19d5a44fd99a6a_1000000000000000000000000000000000000000000000001& E-622 + convertToDouble -9277338894969E-200 +} 0x9919d5a44fd99a6b +test expr-28.453 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +8188292423973 E287 x 1390273bf8f983_0111111111111111111111111111111111111111111111110& E996 + convertToDouble +8188292423973E287 +} 0x7e3390273bf8f983 +test expr-28.454 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -5672557437938 E59 x -148c2bd60a1523_011111111111111111111111111111111111111111111110& E238 + convertToDouble -5672557437938E59 +} 0xced48c2bd60a1523 +test expr-28.455 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +2836278718969 E59 x 148c2bd60a1523_011111111111111111111111111111111111111111111110& E237 + convertToDouble +2836278718969E59 +} 0x4ec48c2bd60a1523 +test expr-28.456 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -9995153153494 E54 x -17ba37c4fbe993_01111111111111111111111111111111111111111111110& E222 + convertToDouble -9995153153494E54 +} 0xcdd7ba37c4fbe993 +test expr-28.457 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +9224786422069 E-291 x 14ee5d56b32957_011111111111111111111111111111111111111111111111110& E-924 + convertToDouble +9224786422069E-291 +} 0x0634ee5d56b32957 +test expr-28.458 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -3142213164987 E-294 x -1d3409dfbca26f_011111111111111111111111111111111111111111111111110& E-936 + convertToDouble -3142213164987E-294 +} 0x857d3409dfbca26f +test expr-28.459 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +6284426329974 E-294 x 1d3409dfbca26f_011111111111111111111111111111111111111111111111110& E-935 + convertToDouble +6284426329974E-294 +} 0x058d3409dfbca26f +test expr-28.460 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -8340483752889 E-301 x -10419183e44b91_01111111111111111111111111111111111111111111111110& E-957 + convertToDouble -8340483752889E-301 +} 0x8420419183e44b91 +test expr-28.461 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +67039371486466 E89 x 17f203339c9628_10000000000000000000000000000000000000000000000000001& E341 + convertToDouble +67039371486466E89 +} 0x5547f203339c9629 +test expr-28.462 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -62150786615239 E197 x -12e79a035b9714_1000000000000000000000000000000000000000000000000001& E700 + convertToDouble -62150786615239E197 +} 0xebb2e79a035b9715 +test expr-28.463 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +33519685743233 E89 x 17f203339c9628_10000000000000000000000000000000000000000000000000001& E340 + convertToDouble +33519685743233E89 +} 0x5537f203339c9629 +test expr-28.464 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -52563419496999 E156 x -1bdb17625bf6e6_1000000000000000000000000000000000000000000000000001& E563 + convertToDouble -52563419496999E156 +} 0xe32bdb17625bf6e7 +test expr-28.465 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +32599460466991 E-65 x 1f395d4c779d8e_1000000000000000000000000000000000000000000000000001& E-172 + convertToDouble +32599460466991E-65 +} 0x353f395d4c779d8f +test expr-28.466 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -41010988798007 E-133 x -152e1c9e04ee06_100000000000000000000000000000000000000000000000001& E-397 + convertToDouble -41010988798007E-133 +} 0xa7252e1c9e04ee07 +test expr-28.467 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +65198920933982 E-65 x 1f395d4c779d8e_1000000000000000000000000000000000000000000000000001& E-171 + convertToDouble +65198920933982E-65 +} 0x354f395d4c779d8f +test expr-28.468 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -82021977596014 E-133 x -152e1c9e04ee06_100000000000000000000000000000000000000000000000001& E-396 + convertToDouble -82021977596014E-133 +} 0xa7352e1c9e04ee07 +test expr-28.469 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +80527976643809 E61 x 1c7c5aea080a49_0111111111111111111111111111111111111111111111111110& E248 + convertToDouble +80527976643809E61 +} 0x4f7c7c5aea080a49 +test expr-28.470 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -74712611505209 E158 x -1eeebe9ea010f3_011111111111111111111111111111111111111111111111110& E570 + convertToDouble -74712611505209E158 +} 0xe39eeebe9ea010f3 +test expr-28.471 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +53390939710959 E261 x 18ac6d426a1cb1_0111111111111111111111111111111111111111111111111110& E912 + convertToDouble +53390939710959E261 +} 0x78f8ac6d426a1cb1 +test expr-28.472 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -69277302659155 E225 x -1547166a3a2b0f_011111111111111111111111111111111111111111111111110& E793 + convertToDouble -69277302659155E225 +} 0xf18547166a3a2b0f +test expr-28.473 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +46202199371337 E-72 x 128f9edfbd341f_0111111111111111111111111111111111111111111111111111111110& E-194 + convertToDouble +46202199371337E-72 +} 0x33d28f9edfbd341f +test expr-28.474 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -23438635467783 E-179 x -1ba485b99e47af_0111111111111111111111111111111111111111111111111110& E-551 + convertToDouble -23438635467783E-179 +} 0x9d8ba485b99e47af +test expr-28.475 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +41921560615349 E-67 x 19b2a5c4041e4b_0111111111111111111111111111111111111111111111111110& E-178 + convertToDouble +41921560615349E-67 +} 0x34d9b2a5c4041e4b +test expr-28.476 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -92404398742674 E-72 x -128f9edfbd341f_0111111111111111111111111111111111111111111111111111111110& E-193 + convertToDouble -92404398742674E-72 +} 0xb3e28f9edfbd341f +test expr-28.477 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +738545606647197 E124 x 13d8886a766a20_100000000000000000000000000000000000000000000000000001& E461 + convertToDouble +738545606647197E124 +} 0x5cc3d8886a766a21 +test expr-28.478 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -972708181182949 E117 x -15ed1f039cebfe_1000000000000000000000000000000000000000000000000000001& E438 + convertToDouble -972708181182949E117 +} 0xdb55ed1f039cebff +test expr-28.479 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -837992143580825 E87 x -17f203339c9628_10000000000000000000000000000000000000000000000000001& E338 + convertToDouble -837992143580825E87 +} 0xd517f203339c9629 +test expr-28.480 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +609610927149051 E-255 x 104273b18918b0_100000000000000000000000000000000000000000000000000000001& E-798 + convertToDouble +609610927149051E-255 +} 0x0e104273b18918b1 +test expr-28.481 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -475603213226859 E-41 x -178cfcab31064c_10000000000000000000000000000000000000000000000000000001& E-88 + convertToDouble -475603213226859E-41 +} 0xba778cfcab31064d +test expr-28.482 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +563002800671023 E-177 x 1035e7b5183922_10000000000000000000000000000000000000000000000000000001& E-539 + convertToDouble +563002800671023E-177 +} 0x1e4035e7b5183923 +test expr-28.483 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -951206426453718 E-41 x -178cfcab31064c_10000000000000000000000000000000000000000000000000000001& E-87 + convertToDouble -951206426453718E-41 +} 0xba878cfcab31064d +test expr-28.484 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +805416432656519 E202 x 175d226331d039_01111111111111111111111111111111111111111111111111111110& E720 + convertToDouble +805416432656519E202 +} 0x6cf75d226331d039 +test expr-28.485 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -530658674694337 E159 x -112a13daa46fe3_0111111111111111111111111111111111111111111111111111110& E577 + convertToDouble -530658674694337E159 +} 0xe4012a13daa46fe3 +test expr-28.486 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +946574173863918 E208 x 1a2fbffdb7580b_011111111111111111111111111111111111111111111111111110& E740 + convertToDouble +946574173863918E208 +} 0x6e3a2fbffdb7580b +test expr-28.487 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -318329953318553 E113 x -178358811cbc95_011111111111111111111111111111111111111111111111111110& E423 + convertToDouble -318329953318553E113 +} 0xda678358811cbc95 +test expr-28.488 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -462021993713370 E-73 x -128f9edfbd341f_0111111111111111111111111111111111111111111111111111111110& E-194 + convertToDouble -462021993713370E-73 +} 0xb3d28f9edfbd341f +test expr-28.489 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +369617594970696 E-72 x 128f9edfbd341f_0111111111111111111111111111111111111111111111111111111110& E-191 + convertToDouble +369617594970696E-72 +} 0x34028f9edfbd341f +test expr-28.490 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +3666156212014994 E233 x 1a37935f3b71c8_100000000000000000000000000000000000000000000000000000001& E825 + convertToDouble +3666156212014994E233 +} 0x738a37935f3b71c9 +test expr-28.491 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -1833078106007497 E233 x -1a37935f3b71c8_100000000000000000000000000000000000000000000000000000001& E824 + convertToDouble -1833078106007497E233 +} 0xf37a37935f3b71c9 +test expr-28.492 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +8301790508624232 E174 x 1dcfee6690ffc6_100000000000000000000000000000000000000000000000000000001& E630 + convertToDouble +8301790508624232E174 +} 0x675dcfee6690ffc7 +test expr-28.493 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -1037723813578029 E174 x -1dcfee6690ffc6_100000000000000000000000000000000000000000000000000000001& E627 + convertToDouble -1037723813578029E174 +} 0xe72dcfee6690ffc7 +test expr-28.494 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +7297662880581139 E-286 x 18ac8c79e1ff18_1000000000000000000000000000000000000000000000000000000000001& E-898 + convertToDouble +7297662880581139E-286 +} 0x07d8ac8c79e1ff19 +test expr-28.495 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -5106185698912191 E-276 x -141934d77659be_1000000000000000000000000000000000000000000000000000000000001& E-865 + convertToDouble -5106185698912191E-276 +} 0x89e41934d77659bf +test expr-28.496 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +7487252720986826 E-165 x 18823a57adbef8_100000000000000000000000000000000000000000000000000000000000001& E-496 + convertToDouble +7487252720986826E-165 +} 0x20f8823a57adbef9 +test expr-28.497 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -3743626360493413 E-165 x -18823a57adbef8_100000000000000000000000000000000000000000000000000000000000001& E-497 + convertToDouble -3743626360493413E-165 +} 0xa0e8823a57adbef9 +test expr-28.498 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +3773057430100257 E230 x 1ba10d818fdafd_0111111111111111111111111111111111111111111111111111111110& E815 + convertToDouble +3773057430100257E230 +} 0x72eba10d818fdafd +test expr-28.499 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -7546114860200514 E230 x -1ba10d818fdafd_0111111111111111111111111111111111111111111111111111111110& E816 + convertToDouble -7546114860200514E230 +} 0xf2fba10d818fdafd +test expr-28.500 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +4321222892463822 E58 x 18750ea732fdad_011111111111111111111111111111111111111111111111111111110& E244 + convertToDouble +4321222892463822E58 +} 0x4f38750ea732fdad +test expr-28.501 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -7793560217139653 E51 x -1280461b856ec5_0111111111111111111111111111111111111111111111111111111110& E222 + convertToDouble -7793560217139653E51 +} 0xcdd280461b856ec5 +test expr-28.502 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +26525993941010681 E112 x 187dcbf6ad5cf8_10000000000000000000000000000000000000000000000000000000000001& E426 + convertToDouble +26525993941010681E112 +} 0x5a987dcbf6ad5cf9 +test expr-28.503 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -53051987882021362 E112 x -187dcbf6ad5cf8_10000000000000000000000000000000000000000000000000000000000001& E427 + convertToDouble -53051987882021362E112 +} 0xdaa87dcbf6ad5cf9 +test expr-28.504 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +72844871414247907 E77 x 1bf00baf60b70c_100000000000000000000000000000000000000000000000000000000001& E311 + convertToDouble +72844871414247907E77 +} 0x536bf00baf60b70d +test expr-28.505 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -88839359596763261 E105 x -1133b1a33a1108_100000000000000000000000000000000000000000000000000000000001& E405 + convertToDouble -88839359596763261E105 +} 0xd94133b1a33a1109 +test expr-28.506 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +18718131802467065 E-166 x 18823a57adbef8_100000000000000000000000000000000000000000000000000000000000001& E-498 + convertToDouble +18718131802467065E-166 +} 0x20d8823a57adbef9 +test expr-28.507 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -14974505441973652 E-165 x -18823a57adbef8_100000000000000000000000000000000000000000000000000000000000001& E-495 + convertToDouble -14974505441973652E-165 +} 0xa108823a57adbef9 +test expr-28.508 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +73429396004640239 E106 x 11c5cb19ef3451_01111111111111111111111111111111111111111111111111111111111110& E408 + convertToDouble +73429396004640239E106 +} 0x5971c5cb19ef3451 +test expr-28.509 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -58483921078398283 E57 x -108ce499519ce3_0111111111111111111111111111111111111111111111111111111111111110& E245 + convertToDouble -58483921078398283E57 +} 0xcf408ce499519ce3 +test expr-28.510 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +41391519190645203 E165 x 13f33667156017_011111111111111111111111111111111111111111111111111111111111110& E603 + convertToDouble +41391519190645203E165 +} 0x65a3f33667156017 +test expr-28.511 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -82783038381290406 E165 x -13f33667156017_011111111111111111111111111111111111111111111111111111111111110& E604 + convertToDouble -82783038381290406E165 +} 0xe5b3f33667156017 +test expr-28.512 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +58767043776702677 E-163 x 12c92fee3a3867_0111111111111111111111111111111111111111111111111111111111110& E-486 + convertToDouble +58767043776702677E-163 +} 0x2192c92fee3a3867 +test expr-28.513 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -90506231831231999 E-129 x -1bdc4114397ff3_01111111111111111111111111111111111111111111111111111111111110& E-373 + convertToDouble -90506231831231999E-129 +} 0xa8abdc4114397ff3 +test expr-28.514 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +64409240769861689 E-159 x 192238f7987779_011111111111111111111111111111111111111111111111111111111111110& E-473 + convertToDouble +64409240769861689E-159 +} 0x22692238f7987779 +test expr-28.515 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -77305427432277771 E-190 x -1e978b7780b613_0111111111111111111111111111111111111111111111111111111111110& E-576 + convertToDouble -77305427432277771E-190 +} 0x9bfe978b7780b613 +test expr-28.516 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +476592356619258326 E273 x 1873cf8ee72812_10000000000000000000000000000000000000000000000000000000000000001& E965 + convertToDouble +476592356619258326E273 +} 0x7c4873cf8ee72813 +test expr-28.517 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -953184713238516652 E273 x -1873cf8ee72812_10000000000000000000000000000000000000000000000000000000000000001& E966 + convertToDouble -953184713238516652E273 +} 0xfc5873cf8ee72813 +test expr-28.518 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +899810892172646163 E283 x 1adf51fa055e02_100000000000000000000000000000000000000000000000000000000000000000001& E999 + convertToDouble +899810892172646163E283 +} 0x7e6adf51fa055e03 +test expr-28.519 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -929167076892018333 E187 x -1da2c42fce2bc4_10000000000000000000000000000000000000000000000000000000000000000001& E680 + convertToDouble -929167076892018333E187 +} 0xea7da2c42fce2bc5 +test expr-28.520 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +647761278967534239 E-312 x 1a7a2476ec0b3e_10000000000000000000000000000000000000000000000000000000000000001& E-978 + convertToDouble +647761278967534239E-312 +} 0x02da7a2476ec0b3f +test expr-28.521 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -644290479820542942 E-180 x -128d1407dfa832_10000000000000000000000000000000000000000000000000000000000000001& E-539 + convertToDouble -644290479820542942E-180 +} 0x9e428d1407dfa833 +test expr-28.522 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +926145344610700019 E-225 x 1307a67f1f69fe_10000000000000000000000000000000000000000000000000000000000000000001& E-688 + convertToDouble +926145344610700019E-225 +} 0x14f307a67f1f69ff +test expr-28.523 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -958507931896511964 E-246 x -17406753df2f0c_10000000000000000000000000000000000000000000000000000000000000001& E-758 + convertToDouble -958507931896511964E-246 +} 0x9097406753df2f0d +test expr-28.524 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +272104041512242479 E200 x 13bbb4bf05f087_011111111111111111111111111111111111111111111111111111111111111111111110& E722 + convertToDouble +272104041512242479E200 +} 0x6d13bbb4bf05f087 +test expr-28.525 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -792644927852378159 E79 x -1daff0048f3ec7_011111111111111111111111111111111111111111111111111111111111111111110& E321 + convertToDouble -792644927852378159E79 +} 0xd40daff0048f3ec7 +test expr-28.526 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +544208083024484958 E200 x 13bbb4bf05f087_011111111111111111111111111111111111111111111111111111111111111111111110& E723 + convertToDouble +544208083024484958E200 +} 0x6d23bbb4bf05f087 +test expr-28.527 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -929963218616126365 E290 x -108dcc0c505461_01111111111111111111111111111111111111111111111111111111111111110& E1023 + convertToDouble -929963218616126365E290 +} 0xffe08dcc0c505461 +test expr-28.528 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +305574339166810102 E-219 x 17f399fe02c4b9_011111111111111111111111111111111111111111111111111111111111111110& E-670 + convertToDouble +305574339166810102E-219 +} 0x1617f399fe02c4b9 +test expr-28.529 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -152787169583405051 E-219 x -17f399fe02c4b9_011111111111111111111111111111111111111111111111111111111111111110& E-671 + convertToDouble -152787169583405051E-219 +} 0x9607f399fe02c4b9 +test expr-28.530 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +611148678333620204 E-219 x 17f399fe02c4b9_011111111111111111111111111111111111111111111111111111111111111110& E-669 + convertToDouble +611148678333620204E-219 +} 0x1627f399fe02c4b9 +test expr-28.531 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -763935847917025255 E-220 x -17f399fe02c4b9_011111111111111111111111111111111111111111111111111111111111111110& E-672 + convertToDouble -763935847917025255E-220 +} 0x95f7f399fe02c4b9 +test expr-28.532 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +7439550220920798612 E158 x 177fe14f40159a_10000000000000000000000000000000000000000000000000000000000000000000001& E587 + convertToDouble +7439550220920798612E158 +} 0x64a77fe14f40159b +test expr-28.533 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -3719775110460399306 E158 x -177fe14f40159a_10000000000000000000000000000000000000000000000000000000000000000000001& E586 + convertToDouble -3719775110460399306E158 +} 0xe4977fe14f40159b +test expr-28.534 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +9299437776150998265 E157 x 177fe14f40159a_10000000000000000000000000000000000000000000000000000000000000000000001& E584 + convertToDouble +9299437776150998265E157 +} 0x64777fe14f40159b +test expr-28.535 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -7120190517612959703 E120 x -13220dcd5899fc_1000000000000000000000000000000000000000000000000000000000000000000000001& E461 + convertToDouble -7120190517612959703E120 +} 0xdcc3220dcd5899fd +test expr-28.536 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +3507665085003296281 E-73 x 11339818257f0e_100000000000000000000000000000000000000000000000000000000000000000000001& E-181 + convertToDouble +3507665085003296281E-73 +} 0x34a1339818257f0f +test expr-28.537 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -7015330170006592562 E-73 x -11339818257f0e_100000000000000000000000000000000000000000000000000000000000000000000001& E-180 + convertToDouble -7015330170006592562E-73 +} 0xb4b1339818257f0f +test expr-28.538 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -6684428762278255956 E-294 x -1d9f82a1a6b1b8_10000000000000000000000000000000000000000000000000000000000000000001& E-915 + convertToDouble -6684428762278255956E-294 +} 0x86cd9f82a1a6b1b9 +test expr-28.539 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -1088416166048969916 E200 x -13bbb4bf05f087_011111111111111111111111111111111111111111111111111111111111111111111110& E724 + convertToDouble -1088416166048969916E200 +} 0xed33bbb4bf05f087 +test expr-28.540 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -8707329328391759328 E200 x -13bbb4bf05f087_011111111111111111111111111111111111111111111111111111111111111111111110& E727 + convertToDouble -8707329328391759328E200 +} 0xed63bbb4bf05f087 +test expr-28.541 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +4439021781608558002 E-65 x 1038168b71e2c9_01111111111111111111111111111111111111111111111111111111111111111110& E-154 + convertToDouble +4439021781608558002E-65 +} 0x365038168b71e2c9 +test expr-28.542 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -8878043563217116004 E-65 x -1038168b71e2c9_01111111111111111111111111111111111111111111111111111111111111111110& E-153 + convertToDouble -8878043563217116004E-65 +} 0xb66038168b71e2c9 +test expr-28.543 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +2219510890804279001 E-65 x 1038168b71e2c9_01111111111111111111111111111111111111111111111111111111111111111110& E-155 + convertToDouble +2219510890804279001E-65 +} 0x364038168b71e2c9 +test expr-28.544 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +33051223951904955802 E55 x 1762068a24fd54_1000000000000000000000000000000000000000000000000000000000000000000000001& E247 + convertToDouble +33051223951904955802E55 +} 0x4f6762068a24fd55 +test expr-28.545 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -56961524140903677624 E120 x -13220dcd5899fc_1000000000000000000000000000000000000000000000000000000000000000000000001& E464 + convertToDouble -56961524140903677624E120 +} 0xdcf3220dcd5899fd +test expr-28.546 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +71201905176129597030 E119 x 13220dcd5899fc_1000000000000000000000000000000000000000000000000000000000000000000000001& E461 + convertToDouble +71201905176129597030E119 +} 0x5cc3220dcd5899fd +test expr-28.547 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +14030660340013185124 E-73 x 11339818257f0e_100000000000000000000000000000000000000000000000000000000000000000000001& E-179 + convertToDouble +14030660340013185124E-73 +} 0x34c1339818257f0f +test expr-28.548 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -17538325425016481405 E-74 x -11339818257f0e_100000000000000000000000000000000000000000000000000000000000000000000001& E-182 + convertToDouble -17538325425016481405E-74 +} 0xb491339818257f0f +test expr-28.549 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +67536228609141569109 E-133 x 10a1b35cf2a635_01111111111111111111111111111111111111111111111111111111111111111111110& E-376 + convertToDouble +67536228609141569109E-133 +} 0x2870a1b35cf2a635 +test expr-28.550 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -35620497849450218807 E-306 x -15b22082529425_0111111111111111111111111111111111111111111111111111111111111111111111110& E-952 + convertToDouble -35620497849450218807E-306 +} 0x8475b22082529425 +test expr-28.551 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN +66550376797582521751 E-126 x 13897c0ede6c69_01111111111111111111111111111111111111111111111111111111111111111111110& E-353 + convertToDouble +66550376797582521751E-126 +} 0x29e3897c0ede6c69 +test expr-28.552 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b d UN -71240995698900437614 E-306 x -15b22082529425_0111111111111111111111111111111111111111111111111111111111111111111111110& E-951 + convertToDouble -71240995698900437614E-306 +} 0x8485b22082529425 +test expr-28.553 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +3 E24 x 13da329b633647_0001& E81 + convertToDouble +3E24 +} 0x4503da329b633647 +test expr-28.554 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -6 E24 x -13da329b633647_0001& E82 + convertToDouble -6E24 +} 0xc513da329b633647 +test expr-28.555 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +6 E26 x 1f04ef12cb04cf_0001& E88 + convertToDouble +6E26 +} 0x457f04ef12cb04cf +test expr-28.556 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -7 E25 x -1cf389cd46047d_0000001& E85 + convertToDouble -7E25 +} 0xc54cf389cd46047d +test expr-28.557 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +1 E-14 x 16849b86a12b9b_00000001& E-47 + convertToDouble +1E-14 +} 0x3d06849b86a12b9b +test expr-28.558 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -2 E-14 x -16849b86a12b9b_00000001& E-46 + convertToDouble -2E-14 +} 0xbd16849b86a12b9b +test expr-28.559 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +4 E-14 x 16849b86a12b9b_00000001& E-45 + convertToDouble +4E-14 +} 0x3d26849b86a12b9b +test expr-28.560 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -8 E-14 x -16849b86a12b9b_00000001& E-44 + convertToDouble -8E-14 +} 0xbd36849b86a12b9b +test expr-28.561 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +5 E26 x 19d971e4fe8401_1110& E88 + convertToDouble +5E26 +} 0x4579d971e4fe8402 +test expr-28.562 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -8 E27 x -19d971e4fe8401_1110& E92 + convertToDouble -8E27 +} 0xc5b9d971e4fe8402 +test expr-28.563 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +1 E27 x 19d971e4fe8401_1110& E89 + convertToDouble +1E27 +} 0x4589d971e4fe8402 +test expr-28.564 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -4 E27 x -19d971e4fe8401_1110& E91 + convertToDouble -4E27 +} 0xc5a9d971e4fe8402 +test expr-28.565 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +9 E-13 x 1faa7ab552a551_111110& E-41 + convertToDouble +9E-13 +} 0x3d6faa7ab552a552 +test expr-28.566 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -7 E-20 x -14a90ceafff9de_11110& E-64 + convertToDouble -7E-20 +} 0xbbf4a90ceafff9df +test expr-28.567 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +56 E25 x 1cf389cd46047d_0000001& E88 + convertToDouble +56E25 +} 0x457cf389cd46047d +test expr-28.568 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -70 E24 x -1cf389cd46047d_0000001& E85 + convertToDouble -70E24 +} 0xc54cf389cd46047d +test expr-28.569 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +51 E26 x 107a9f01fbda8e_0000001& E92 + convertToDouble +51E26 +} 0x45b07a9f01fbda8e +test expr-28.570 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +71 E-17 x 19949819f693d7_00000000001& E-51 + convertToDouble +71E-17 +} 0x3cc9949819f693d7 +test expr-28.571 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -31 E-5 x -1450efdc9c4da9_00000000001& E-12 + convertToDouble -31E-5 +} 0xbf3450efdc9c4da9 +test expr-28.572 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +62 E-5 x 1450efdc9c4da9_00000000001& E-11 + convertToDouble +62E-5 +} 0x3f4450efdc9c4da9 +test expr-28.573 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -94 E-8 x -1f8a89dc374df5_0000000001& E-21 + convertToDouble -94E-8 +} 0xbeaf8a89dc374df5 +test expr-28.574 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +67 E27 x 1b0fa33bba7231_11111110& E95 + convertToDouble +67E27 +} 0x45eb0fa33bba7232 +test expr-28.575 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -81 E24 x -10c01ab31bb5cb_1111110& E86 + convertToDouble -81E24 +} 0xc550c01ab31bb5cc +test expr-28.576 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +54 E23 x 11ddfa58a6173f_111110& E82 + convertToDouble +54E23 +} 0x4511ddfa58a61740 +test expr-28.577 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -54 E25 x -1bead72a838453_111110& E88 + convertToDouble -54E25 +} 0xc57bead72a838454 +test expr-28.578 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +63 E-22 x 1dc03b8fd70169_11111111110& E-68 + convertToDouble +63E-22 +} 0x3bbdc03b8fd7016a +test expr-28.579 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -63 E-23 x -17ccfc73126787_11111111110& E-71 + convertToDouble -63E-23 +} 0xbb87ccfc73126788 +test expr-28.580 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +43 E-4 x 119ce075f6fd21_111111110& E-8 + convertToDouble +43E-4 +} 0x3f719ce075f6fd22 +test expr-28.581 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -86 E-4 x -119ce075f6fd21_111111110& E-7 + convertToDouble -86E-4 +} 0xbf819ce075f6fd22 +test expr-28.582 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +942 E26 x 1306069e8681f3_00000000001& E96 + convertToDouble +942E26 +} 0x45f306069e8681f3 +test expr-28.583 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -471 E25 x -1e700a973d9cb8_0000000001& E91 + convertToDouble -471E25 +} 0xc5ae700a973d9cb8 +test expr-28.584 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +803 E24 x 14c1cee9cd666b_000000000001& E89 + convertToDouble +803E24 +} 0x4584c1cee9cd666b +test expr-28.585 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -471 E26 x -1306069e8681f3_00000000001& E95 + convertToDouble -471E26 +} 0xc5e306069e8681f3 +test expr-28.586 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -409 E-21 x -1e2dcaa4115622_000000000001& E-62 + convertToDouble -409E-21 +} 0xbc1e2dcaa4115622 +test expr-28.587 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +818 E-21 x 1e2dcaa4115622_000000000001& E-61 + convertToDouble +818E-21 +} 0x3c2e2dcaa4115622 +test expr-28.588 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -867 E-8 x -122eabba029aba_000000000001& E-17 + convertToDouble -867E-8 +} 0xbee22eabba029aba +test expr-28.589 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +538 E27 x 1b297cad9f70b5_1111111111111110& E98 + convertToDouble +538E27 +} 0x461b297cad9f70b6 +test expr-28.590 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -857 E24 x -16272678ba603b_11111111110& E89 + convertToDouble -857E24 +} 0xc586272678ba603c +test expr-28.591 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +269 E27 x 1b297cad9f70b5_1111111111111110& E97 + convertToDouble +269E27 +} 0x460b297cad9f70b6 +test expr-28.592 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -403 E26 x -1046ec1e31dd85_1111111110& E95 + convertToDouble -403E26 +} 0xc5e046ec1e31dd86 +test expr-28.593 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +959 E-7 x 1923bd746a3527_11111111111110& E-14 + convertToDouble +959E-7 +} 0x3f1923bd746a3528 +test expr-28.594 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -959 E-6 x -1f6cacd184c271_1111111111110& E-11 + convertToDouble -959E-6 +} 0xbf4f6cacd184c272 +test expr-28.595 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +373 E-27 x 1cdc06b20ef182_1111111111110& E-82 + convertToDouble +373E-27 +} 0x3adcdc06b20ef183 +test expr-28.596 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -746 E-27 x -1cdc06b20ef182_1111111111110& E-81 + convertToDouble -746E-27 +} 0xbaecdc06b20ef183 +test expr-28.597 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +4069 E24 x 1a4b9887fbfe7a_0000000000001& E91 + convertToDouble +4069E24 +} 0x45aa4b9887fbfe7a +test expr-28.598 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -4069 E23 x -150946d32ffec8_0000000000001& E88 + convertToDouble -4069E23 +} 0xc5750946d32ffec8 +test expr-28.599 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -8138 E24 x -1a4b9887fbfe7a_0000000000001& E92 + convertToDouble -8138E24 +} 0xc5ba4b9887fbfe7a +test expr-28.600 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +8294 E-15 x 123d1b5eb1d778_000000000000000001& E-37 + convertToDouble +8294E-15 +} 0x3da23d1b5eb1d778 +test expr-28.601 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -4147 E-14 x -16cc62365e4d56_00000000000000001& E-35 + convertToDouble -4147E-14 +} 0xbdc6cc62365e4d56 +test expr-28.602 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +4147 E-15 x 123d1b5eb1d778_000000000000000001& E-38 + convertToDouble +4147E-15 +} 0x3d923d1b5eb1d778 +test expr-28.603 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -8294 E-14 x -16cc62365e4d56_00000000000000001& E-34 + convertToDouble -8294E-14 +} 0xbdd6cc62365e4d56 +test expr-28.604 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +538 E27 x 1b297cad9f70b5_1111111111111110& E98 + convertToDouble +538E27 +} 0x461b297cad9f70b6 +test expr-28.605 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -2690 E26 x -1b297cad9f70b5_1111111111111110& E97 + convertToDouble -2690E26 +} 0xc60b297cad9f70b6 +test expr-28.606 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +269 E27 x 1b297cad9f70b5_1111111111111110& E97 + convertToDouble +269E27 +} 0x460b297cad9f70b6 +test expr-28.607 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -2152 E27 x -1b297cad9f70b5_1111111111111110& E100 + convertToDouble -2152E27 +} 0xc63b297cad9f70b6 +test expr-28.608 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +1721 E-17 x 136071dcae4564_111111111111110& E-46 + convertToDouble +1721E-17 +} 0x3d136071dcae4565 +test expr-28.609 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -7979 E-27 x -134ac304747faf_111111111111110& E-77 + convertToDouble -7979E-27 +} 0xbb234ac304747fb0 +test expr-28.610 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +6884 E-17 x 136071dcae4564_111111111111110& E-44 + convertToDouble +6884E-17 +} 0x3d336071dcae4565 +test expr-28.611 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -8605 E-18 x -136071dcae4564_111111111111110& E-47 + convertToDouble -8605E-18 +} 0xbd036071dcae4565 +test expr-28.612 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +82854 E27 x 10570ed9e3cecc_00000000000000001& E106 + convertToDouble +82854E27 +} 0x4690570ed9e3cecc +test expr-28.613 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -55684 E24 x -167d9735144ae3_00000000000000001& E95 + convertToDouble -55684E24 +} 0xc5e67d9735144ae3 +test expr-28.614 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +27842 E24 x 167d9735144ae3_00000000000000001& E94 + convertToDouble +27842E24 +} 0x45d67d9735144ae3 +test expr-28.615 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -48959 E25 x -18b7cd6ca56f85_00000000000000001& E98 + convertToDouble -48959E25 +} 0xc618b7cd6ca56f85 +test expr-28.616 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +81921 E-17 x 1cd2c9a6cdd003_000000000000000000001& E-41 + convertToDouble +81921E-17 +} 0x3d6cd2c9a6cdd003 +test expr-28.617 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -76207 E-8 x -18f8b4dd16f1df_0000000000000000001& E-11 + convertToDouble -76207E-8 +} 0xbf48f8b4dd16f1df +test expr-28.618 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +4147 E-15 x 123d1b5eb1d778_000000000000000001& E-38 + convertToDouble +4147E-15 +} 0x3d923d1b5eb1d778 +test expr-28.619 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -41470 E-16 x -123d1b5eb1d778_000000000000000001& E-38 + convertToDouble -41470E-16 +} 0xbd923d1b5eb1d778 +test expr-28.620 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +89309 E24 x 12092ac5f2019e_1111111111111111110& E96 + convertToDouble +89309E24 +} 0x45f2092ac5f2019f +test expr-28.621 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +75859 E26 x 17efd75a2938eb_1111111111111111111110& E102 + convertToDouble +75859E26 +} 0x4657efd75a2938ec +test expr-28.622 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -75859 E25 x -132645e1ba93ef_1111111111111111111110& E99 + convertToDouble -75859E25 +} 0xc6232645e1ba93f0 +test expr-28.623 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +14257 E-23 x 150a246ecd44f2_1111111111111111110& E-63 + convertToDouble +14257E-23 +} 0x3c050a246ecd44f3 +test expr-28.624 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -28514 E-23 x -150a246ecd44f2_1111111111111111110& E-62 + convertToDouble -28514E-23 +} 0xbc150a246ecd44f3 +test expr-28.625 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +57028 E-23 x 150a246ecd44f2_1111111111111111110& E-61 + convertToDouble +57028E-23 +} 0x3c250a246ecd44f3 +test expr-28.626 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -71285 E-24 x -150a246ecd44f2_1111111111111111110& E-64 + convertToDouble -71285E-24 +} 0xbbf50a246ecd44f3 +test expr-28.627 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +344863 E27 x 1100c873963d6d_00000000000000000001& E108 + convertToDouble +344863E27 +} 0x46b100c873963d6d +test expr-28.628 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -951735 E27 x -17764ad224e24a_000000000000000000001& E109 + convertToDouble -951735E27 +} 0xc6c7764ad224e24a +test expr-28.629 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +200677 E23 x 1035e73135b834_0000000000000000001& E94 + convertToDouble +200677E23 +} 0x45d035e73135b834 +test expr-28.630 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -401354 E24 x -144360fd832641_0000000000000000001& E98 + convertToDouble -401354E24 +} 0xc6144360fd832641 +test expr-28.631 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +839604 E-11 x 119b96f36ec68b_00000000000000000000000001& E-17 + convertToDouble +839604E-11 +} 0x3ee19b96f36ec68b +test expr-28.632 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -209901 E-11 x -119b96f36ec68b_00000000000000000000000001& E-19 + convertToDouble -209901E-11 +} 0xbec19b96f36ec68b +test expr-28.633 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +419802 E-11 x 119b96f36ec68b_00000000000000000000000001& E-18 + convertToDouble +419802E-11 +} 0x3ed19b96f36ec68b +test expr-28.634 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -537734 E-24 x -13d6c1088ae40e_0000000000000000000001& E-61 + convertToDouble -537734E-24 +} 0xbc23d6c1088ae40e +test expr-28.635 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +910308 E26 x 11f3e1839eeab0_11111111111111111111110& E106 + convertToDouble +910308E26 +} 0x4691f3e1839eeab1 +test expr-28.636 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -227577 E26 x -11f3e1839eeab0_11111111111111111111110& E104 + convertToDouble -227577E26 +} 0xc671f3e1839eeab1 +test expr-28.637 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +455154 E26 x 11f3e1839eeab0_11111111111111111111110& E105 + convertToDouble +455154E26 +} 0x4681f3e1839eeab1 +test expr-28.638 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -531013 E25 x -10c17d25834171_11111111111111111111110& E102 + convertToDouble -531013E25 +} 0xc650c17d25834172 +test expr-28.639 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +963019 E-21 x 11592429784914_11111111111111111111110& E-50 + convertToDouble +963019E-21 +} 0x3cd1592429784915 +test expr-28.640 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -519827 E-13 x -1be872a8b30d7c_11111111111111111111110& E-25 + convertToDouble -519827E-13 +} 0xbe6be872a8b30d7d +test expr-28.641 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +623402 E-27 x 178d2c97bde2a0_11111111111111111111110& E-71 + convertToDouble +623402E-27 +} 0x3b878d2c97bde2a1 +test expr-28.642 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -311701 E-27 x -178d2c97bde2a0_11111111111111111111110& E-72 + convertToDouble -311701E-27 +} 0xbb778d2c97bde2a1 +test expr-28.643 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +9613651 E26 x 17b31116270d9b_000000000000000000000001& E109 + convertToDouble +9613651E26 +} 0x46c7b31116270d9b +test expr-28.644 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -9191316 E23 x -1733bfae0801fd_0000000000000000000001& E99 + convertToDouble -9191316E23 +} 0xc62733bfae0801fd +test expr-28.645 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +4595658 E23 x 1733bfae0801fd_0000000000000000000001& E98 + convertToDouble +4595658E23 +} 0x461733bfae0801fd +test expr-28.646 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -2297829 E23 x -1733bfae0801fd_0000000000000000000001& E97 + convertToDouble -2297829E23 +} 0xc60733bfae0801fd +test expr-28.647 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -1679208 E-11 x -119b96f36ec68b_00000000000000000000000001& E-16 + convertToDouble -1679208E-11 +} 0xbef19b96f36ec68b +test expr-28.648 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +3379223 E27 x 14d3794ce2fc25_1111111111111111111111110& E111 + convertToDouble +3379223E27 +} 0x46e4d3794ce2fc26 +test expr-28.649 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -6758446 E27 x -14d3794ce2fc25_1111111111111111111111110& E112 + convertToDouble -6758446E27 +} 0xc6f4d3794ce2fc26 +test expr-28.650 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +5444097 E-21 x 18849dd33c95ae_11111111111111111111111111110& E-48 + convertToDouble +5444097E-21 +} 0x3cf8849dd33c95af +test expr-28.651 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -8399969 E-27 x -13d5783e85fcf7_1111111111111111111111110& E-67 + convertToDouble -8399969E-27 +} 0xbbc3d5783e85fcf8 +test expr-28.652 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +8366487 E-16 x 1cbf3d630403af_1111111111111111111111110& E-31 + convertToDouble +8366487E-16 +} 0x3e0cbf3d630403b0 +test expr-28.653 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -8366487 E-15 x -11f7865de2824d_11111111111111111111111110& E-27 + convertToDouble -8366487E-15 +} 0xbe41f7865de2824e +test expr-28.654 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +65060671 E25 x 1009e7d474572a_0000000000000000000000000001& E109 + convertToDouble +65060671E25 +} 0x46c009e7d474572a +test expr-28.655 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +65212389 E23 x 1493d098d37657_000000000000000000000000001& E102 + convertToDouble +65212389E23 +} 0x465493d098d37657 +test expr-28.656 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +55544957 E-13 x 174c1826f3010c_00000000000000000000000000001& E-18 + convertToDouble +55544957E-13 +} 0x3ed74c1826f3010c +test expr-28.657 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -51040905 E-20 x -11f55b23c8bf2d_0000000000000000000000000001& E-41 + convertToDouble -51040905E-20 +} 0xbd61f55b23c8bf2d +test expr-28.658 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +99585767 E-22 x 166cba8699f0f2_0000000000000000000000000001& E-47 + convertToDouble +99585767E-22 +} 0x3d066cba8699f0f2 +test expr-28.659 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -99585767 E-23 x -11f095387b2728_0000000000000000000000000001& E-50 + convertToDouble -99585767E-23 +} 0xbcd1f095387b2728 +test expr-28.660 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +40978393 E26 x 1941401cca2bfd_1111111111111111111111111110& E111 + convertToDouble +40978393E26 +} 0x46e941401cca2bfe +test expr-28.661 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -67488159 E24 x -1a9e90059d12db_11111111111111111111111111110& E105 + convertToDouble -67488159E24 +} 0xc68a9e90059d12dc +test expr-28.662 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +69005339 E23 x 15c634f6ef1f95_111111111111111111111111110& E102 + convertToDouble +69005339E23 +} 0x4655c634f6ef1f96 +test expr-28.663 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -81956786 E26 x -1941401cca2bfd_1111111111111111111111111110& E112 + convertToDouble -81956786E26 +} 0xc6f941401cca2bfe +test expr-28.664 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -87105552 E-21 x -18849dd33c95ae_11111111111111111111111111110& E-44 + convertToDouble -87105552E-21 +} 0xbd38849dd33c95af +test expr-28.665 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +10888194 E-21 x 18849dd33c95ae_11111111111111111111111111110& E-47 + convertToDouble +10888194E-21 +} 0x3d08849dd33c95af +test expr-28.666 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -21776388 E-21 x -18849dd33c95ae_11111111111111111111111111110& E-46 + convertToDouble -21776388E-21 +} 0xbd18849dd33c95af +test expr-28.667 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +635806667 E27 x 1e9cec176c96f8_000000000000000000000000000000001& E118 + convertToDouble +635806667E27 +} 0x475e9cec176c96f8 +test expr-28.668 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -670026614 E25 x -14a593f89f4194_00000000000000000000000000000001& E112 + convertToDouble -670026614E25 +} 0xc6f4a593f89f4194 +test expr-28.669 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +335013307 E26 x 19cef8f6c711f9_0000000000000000000000000000001& E114 + convertToDouble +335013307E26 +} 0x4719cef8f6c711f9 +test expr-28.670 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -335013307 E25 x -14a593f89f4194_00000000000000000000000000000001& E111 + convertToDouble -335013307E25 +} 0xc6e4a593f89f4194 +test expr-28.671 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +371790617 E-24 x 1aca538c61ba9c_000000000000000000000000000000001& E-52 + convertToDouble +371790617E-24 +} 0x3cbaca538c61ba9c +test expr-28.672 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -371790617 E-25 x -156ea93d1afbb0_0000000000000000000000000000000001& E-55 + convertToDouble -371790617E-25 +} 0xbc856ea93d1afbb0 +test expr-28.673 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +743581234 E-24 x 1aca538c61ba9c_000000000000000000000000000000001& E-51 + convertToDouble +743581234E-24 +} 0x3ccaca538c61ba9c +test expr-28.674 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -743581234 E-25 x -156ea93d1afbb0_0000000000000000000000000000000001& E-54 + convertToDouble -743581234E-25 +} 0xbc956ea93d1afbb0 +test expr-28.675 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +202464477 E24 x 13f6ec0435ce24_111111111111111111111111111110& E107 + convertToDouble +202464477E24 +} 0x46a3f6ec0435ce25 +test expr-28.676 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -404928954 E24 x -13f6ec0435ce24_111111111111111111111111111110& E108 + convertToDouble -404928954E24 +} 0xc6b3f6ec0435ce25 +test expr-28.677 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +997853758 E27 x 1805bfa33b98fa_111111111111111111111111111110& E119 + convertToDouble +997853758E27 +} 0x476805bfa33b98fb +test expr-28.678 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -997853758 E26 x -1337cc829613fb_111111111111111111111111111110& E116 + convertToDouble -997853758E26 +} 0xc73337cc829613fc +test expr-28.679 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +405498418 E-17 x 116a8093df66a6_111111111111111111111111111111110& E-28 + convertToDouble +405498418E-17 +} 0x3e316a8093df66a7 +test expr-28.680 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -582579084 E-14 x -186f653140a658_111111111111111111111111111111110& E-18 + convertToDouble -582579084E-14 +} 0xbed86f653140a659 +test expr-28.681 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +608247627 E-18 x 14e633e4a5ae61_111111111111111111111111111111110& E-31 + convertToDouble +608247627E-18 +} 0x3e04e633e4a5ae62 +test expr-28.682 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -291289542 E-14 x -186f653140a658_111111111111111111111111111111110& E-19 + convertToDouble -291289542E-14 +} 0xbec86f653140a659 +test expr-28.683 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -9537100005 E26 x -16f5b11191713a_000000000000000000000000000000001& E119 + convertToDouble -9537100005E26 +} 0xc766f5b11191713a +test expr-28.684 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +6358066670 E27 x 1322138ea3de5b_000000000000000000000000000000001& E122 + convertToDouble +6358066670E27 +} 0x479322138ea3de5b +test expr-28.685 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -1271613334 E27 x -1e9cec176c96f8_000000000000000000000000000000001& E119 + convertToDouble -1271613334E27 +} 0xc76e9cec176c96f8 +test expr-28.686 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +5229646999 E-16 x 118c3b89731f3d_000000000000000000000000000000000001& E-21 + convertToDouble +5229646999E-16 +} 0x3ea18c3b89731f3d +test expr-28.687 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +5229646999 E-17 x 1c13927584fec8_00000000000000000000000000000000001& E-25 + convertToDouble +5229646999E-17 +} 0x3e6c13927584fec8 +test expr-28.688 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +4429943614 E24 x 1b4d37fa06864a_1111111111111111111111111111111110& E111 + convertToDouble +4429943614E24 +} 0x46eb4d37fa06864b +test expr-28.689 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -8859887228 E24 x -1b4d37fa06864a_1111111111111111111111111111111110& E112 + convertToDouble -8859887228E24 +} 0xc6fb4d37fa06864b +test expr-28.690 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +2214971807 E24 x 1b4d37fa06864a_1111111111111111111111111111111110& E110 + convertToDouble +2214971807E24 +} 0x46db4d37fa06864b +test expr-28.691 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -4176887093 E26 x -141c692c5bd07a_111111111111111111111111111111110& E118 + convertToDouble -4176887093E26 +} 0xc7541c692c5bd07b +test expr-28.692 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +4003495257 E-20 x 16026b2e07ec06_111111111111111111111111111111111110& E-35 + convertToDouble +4003495257E-20 +} 0x3dc6026b2e07ec07 +test expr-28.693 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -4361901637 E-23 x -188e29a9d7c5b8_11111111111111111111111111111111110& E-45 + convertToDouble -4361901637E-23 +} 0xbd288e29a9d7c5b9 +test expr-28.694 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +8723803274 E-23 x 188e29a9d7c5b8_11111111111111111111111111111111110& E-44 + convertToDouble +8723803274E-23 +} 0x3d388e29a9d7c5b9 +test expr-28.695 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -8006990514 E-20 x -16026b2e07ec06_111111111111111111111111111111111110& E-34 + convertToDouble -8006990514E-20 +} 0xbdd6026b2e07ec07 +test expr-28.696 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +72835110098 E27 x 1b65c41711fb6d_0000000000000000000000000000000000001& E125 + convertToDouble +72835110098E27 +} 0x47cb65c41711fb6d +test expr-28.697 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -36417555049 E27 x -1b65c41711fb6d_0000000000000000000000000000000000001& E124 + convertToDouble -36417555049E27 +} 0xc7bb65c41711fb6d +test expr-28.698 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +84279630104 E25 x 144a221b1cf62e_000000000000000000000000000000000001& E119 + convertToDouble +84279630104E25 +} 0x47644a221b1cf62e +test expr-28.699 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -84279630104 E24 x -103b4e7c172b58_000000000000000000000000000000000001& E116 + convertToDouble -84279630104E24 +} 0xc7303b4e7c172b58 +test expr-28.700 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +21206176437 E-27 x 1872f563ae0cc9_0000000000000000000000000000000000001& E-56 + convertToDouble +21206176437E-27 +} 0x3c7872f563ae0cc9 +test expr-28.701 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -66461566917 E-22 x -1d3ae83e4322b3_00000000000000000000000000000000000001& E-38 + convertToDouble -66461566917E-22 +} 0xbd9d3ae83e4322b3 +test expr-28.702 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +64808355539 E-16 x 1b2ebe83265fbf_00000000000000000000000000000000000001& E-18 + convertToDouble +64808355539E-16 +} 0x3edb2ebe83265fbf +test expr-28.703 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -84932679673 E-19 x -123d39339f1bf6_00000000000000000000000000000000000001& E-27 + convertToDouble -84932679673E-19 +} 0xbe423d39339f1bf6 +test expr-28.704 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +65205430094 E26 x 139f3e5d7fd76a_1111111111111111111111111111111111110& E122 + convertToDouble +65205430094E26 +} 0x47939f3e5d7fd76b +test expr-28.705 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -68384463429 E25 x -107684982f634e_1111111111111111111111111111111111111110& E119 + convertToDouble -68384463429E25 +} 0xc7607684982f634f +test expr-28.706 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +32602715047 E26 x 139f3e5d7fd76a_1111111111111111111111111111111111110& E121 + convertToDouble +32602715047E26 +} 0x47839f3e5d7fd76b +test expr-28.707 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -62662203426 E27 x -1792269424688d_111111111111111111111111111111111110& E125 + convertToDouble -62662203426E27 +} 0xc7c792269424688e +test expr-28.708 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +58784444678 E-18 x 1f8f45c64b4682_111111111111111111111111111111111111110& E-25 + convertToDouble +58784444678E-18 +} 0x3e6f8f45c64b4683 +test expr-28.709 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -50980203373 E-21 x -1c06d366394440_11111111111111111111111111111111111111111110& E-35 + convertToDouble -50980203373E-21 +} 0xbdcc06d366394441 +test expr-28.710 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +29392222339 E-18 x 1f8f45c64b4682_111111111111111111111111111111111111110& E-26 + convertToDouble +29392222339E-18 +} 0x3e5f8f45c64b4683 +test expr-28.711 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -75529940323 E-27 x -15c5203c0aad52_1111111111111111111111111111111111111110& E-54 + convertToDouble -75529940323E-27 +} 0xbc95c5203c0aad53 +test expr-28.712 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -937495906299 E26 x -11a1e0ebb6af11_000000000000000000000000000000000000000001& E126 + convertToDouble -937495906299E26 +} 0xc7d1a1e0ebb6af11 +test expr-28.713 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +842642485799 E-20 x 121879decdd7cb_000000000000000000000000000000000000000001& E-27 + convertToDouble +842642485799E-20 +} 0x3e421879decdd7cb +test expr-28.714 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -387824150699 E-23 x -110e8302245571_00000000000000000000000000000000000000001& E-38 + convertToDouble -387824150699E-23 +} 0xbd910e8302245571 +test expr-28.715 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +924948814726 E-27 x 10a992d1fc6ded_00000000000000000000000000000000000000001& E-50 + convertToDouble +924948814726E-27 +} 0x3cd0a992d1fc6ded +test expr-28.716 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -775648301398 E-23 x -110e8302245571_00000000000000000000000000000000000000001& E-37 + convertToDouble -775648301398E-23 +} 0xbda10e8302245571 +test expr-28.717 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +547075707432 E25 x 107684982f634e_1111111111111111111111111111111111111110& E122 + convertToDouble +547075707432E25 +} 0x47907684982f634f +test expr-28.718 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +683844634290 E24 x 107684982f634e_1111111111111111111111111111111111111110& E119 + convertToDouble +683844634290E24 +} 0x47607684982f634f +test expr-28.719 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -136768926858 E25 x -107684982f634e_1111111111111111111111111111111111111110& E120 + convertToDouble -136768926858E25 +} 0xc7707684982f634f +test expr-28.720 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +509802033730 E-22 x 1c06d366394440_11111111111111111111111111111111111111111110& E-35 + convertToDouble +509802033730E-22 +} 0x3dcc06d366394441 +test expr-28.721 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +101960406746 E-21 x 1c06d366394440_11111111111111111111111111111111111111111110& E-34 + convertToDouble +101960406746E-21 +} 0x3ddc06d366394441 +test expr-28.722 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -815683253968 E-21 x -1c06d366394440_11111111111111111111111111111111111111111110& E-31 + convertToDouble -815683253968E-21 +} 0xbe0c06d366394441 +test expr-28.723 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +7344124123524 E24 x 1619b519dd6833_00000000000000000000000000000000000000000001& E122 + convertToDouble +7344124123524E24 +} 0x479619b519dd6833 +test expr-28.724 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -9180155154405 E23 x -1619b519dd6833_00000000000000000000000000000000000000000001& E119 + convertToDouble -9180155154405E23 +} 0xc76619b519dd6833 +test expr-28.725 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +6479463327323 E27 x 130a9b3e9bd05e_00000000000000000000000000000000000000000001& E132 + convertToDouble +6479463327323E27 +} 0x48330a9b3e9bd05e +test expr-28.726 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -1836031030881 E24 x -1619b519dd6833_00000000000000000000000000000000000000000001& E120 + convertToDouble -1836031030881E24 +} 0xc77619b519dd6833 +test expr-28.727 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +4337269293039 E-19 x 1d1b5f354c63d6_00000000000000000000000000000000000000000001& E-22 + convertToDouble +4337269293039E-19 +} 0x3e9d1b5f354c63d6 +test expr-28.728 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -4599163554373 E-23 x -1948bf4d34088d_00000000000000000000000000000000000000000001& E-35 + convertToDouble -4599163554373E-23 +} 0xbdc948bf4d34088d +test expr-28.729 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +9198327108746 E-23 x 1948bf4d34088d_00000000000000000000000000000000000000000001& E-34 + convertToDouble +9198327108746E-23 +} 0x3dd948bf4d34088d +test expr-28.730 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +4812803938347 E27 x 1c4980a4ee94ce_111111111111111111111111111111111111111111110& E131 + convertToDouble +4812803938347E27 +} 0x482c4980a4ee94cf +test expr-28.731 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -8412030890011 E23 x -14405075e52db9_11111111111111111111111111111111111111111110& E119 + convertToDouble -8412030890011E23 +} 0xc764405075e52dba +test expr-28.732 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +9625607876694 E27 x 1c4980a4ee94ce_111111111111111111111111111111111111111111110& E132 + convertToDouble +9625607876694E27 +} 0x483c4980a4ee94cf +test expr-28.733 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -4739968828249 E24 x -1c87140cdf8a1d_1111111111111111111111111111111111111111110& E121 + convertToDouble -4739968828249E24 +} 0xc78c87140cdf8a1e +test expr-28.734 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +9697183891673 E-23 x 1aa7c959b6a666_11111111111111111111111111111111111111111111110& E-34 + convertToDouble +9697183891673E-23 +} 0x3ddaa7c959b6a667 +test expr-28.735 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -7368108517543 E-20 x -13c7535bbd85a1_1111111111111111111111111111111111111111111110& E-24 + convertToDouble -7368108517543E-20 +} 0xbe73c7535bbd85a2 +test expr-28.736 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +51461358161422 E25 x 18326f87d4cae0_0000000000000000000000000000000000000000000000001& E128 + convertToDouble +51461358161422E25 +} 0x47f8326f87d4cae0 +test expr-28.737 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -77192037242133 E26 x -16af488f577e32_0000000000000000000000000000000000000000000000001& E132 + convertToDouble -77192037242133E26 +} 0xc836af488f577e32 +test expr-28.738 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +77192037242133 E25 x 1225d3a5df9828_0000000000000000000000000000000000000000000000001& E129 + convertToDouble +77192037242133E25 +} 0x480225d3a5df9828 +test expr-28.739 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -51461358161422 E27 x -12e767221e3e7f_0000000000000000000000000000000000000000000000001& E135 + convertToDouble -51461358161422E27 +} 0xc862e767221e3e7f +test expr-28.740 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +43999661561541 E-21 x 179f4476d372a3_0000000000000000000000000000000000000000000000001& E-25 + convertToDouble +43999661561541E-21 +} 0x3e679f4476d372a3 +test expr-28.741 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -87999323123082 E-21 x -179f4476d372a3_0000000000000000000000000000000000000000000000001& E-24 + convertToDouble -87999323123082E-21 +} 0xbe779f4476d372a3 +test expr-28.742 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +48374886826137 E-26 x 110538f23350d5_00000000000000000000000000000000000000000000001& E-41 + convertToDouble +48374886826137E-26 +} 0x3d610538f23350d5 +test expr-28.743 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -57684246567111 E-23 x -13d1f5c1b8a912_00000000000000000000000000000000000000000000001& E-31 + convertToDouble -57684246567111E-23 +} 0xbe03d1f5c1b8a912 +test expr-28.744 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +87192805957686 E23 x 1a3d16e55a9664_1111111111111111111111111111111111111111111110& E122 + convertToDouble +87192805957686E23 +} 0x479a3d16e55a9665 +test expr-28.745 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -75108713005913 E24 x -1c40b4baa79655_11111111111111111111111111111111111111111111110& E125 + convertToDouble -75108713005913E24 +} 0xc7cc40b4baa79656 +test expr-28.746 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +64233110587487 E27 x 179873e38669a6_1111111111111111111111111111111111111111111110& E135 + convertToDouble +64233110587487E27 +} 0x48679873e38669a7 +test expr-28.747 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -77577471133384 E-23 x -1aa7c959b6a666_11111111111111111111111111111111111111111111110& E-31 + convertToDouble -77577471133384E-23 +} 0xbe0aa7c959b6a667 +test expr-28.748 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +48485919458365 E-24 x 1aa7c959b6a666_11111111111111111111111111111111111111111111110& E-35 + convertToDouble +48485919458365E-24 +} 0x3dcaa7c959b6a667 +test expr-28.749 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -56908598265713 E-26 x -1405deef4bdef5_111111111111111111111111111111111111111111111110& E-41 + convertToDouble -56908598265713E-26 +} 0xbd6405deef4bdef6 +test expr-28.750 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +589722294620133 E23 x 162ed1b287caef_00000000000000000000000000000000000000000000000001& E125 + convertToDouble +589722294620133E23 +} 0x47c62ed1b287caef +test expr-28.751 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +652835804449289 E-22 x 118640e490b087_0000000000000000000000000000000000000000000000000001& E-24 + convertToDouble +652835804449289E-22 +} 0x3e718640e490b087 +test expr-28.752 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -656415363936202 E-23 x -1c315cfe25d201_00000000000000000000000000000000000000000000000001& E-28 + convertToDouble -656415363936202E-23 +} 0xbe3c315cfe25d201 +test expr-28.753 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +579336749585745 E-25 x 1fd9709d9aeb19_00000000000000000000000000000000000000000000000001& E-35 + convertToDouble +579336749585745E-25 +} 0x3dcfd9709d9aeb19 +test expr-28.754 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -381292764980839 E-26 x -10c4f9921c3f8f_00000000000000000000000000000000000000000000000001& E-38 + convertToDouble -381292764980839E-26 +} 0xbd90c4f9921c3f8f +test expr-28.755 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +965265859649698 E23 x 12279607edcb0c_1111111111111111111111111111111111111111111111110& E126 + convertToDouble +965265859649698E23 +} 0x47d2279607edcb0d +test expr-28.756 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -848925235434882 E27 x -137d88ba4b43e3_1111111111111111111111111111111111111111111111111110& E139 + convertToDouble -848925235434882E27 +} 0xc8a37d88ba4b43e4 +test expr-28.757 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +536177612222491 E23 x 142b33dd3acafd_11111111111111111111111111111111111111111111111110& E125 + convertToDouble +536177612222491E23 +} 0x47c42b33dd3acafe +test expr-28.758 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -424462617717441 E27 x -137d88ba4b43e3_1111111111111111111111111111111111111111111111111110& E138 + convertToDouble -424462617717441E27 +} 0xc8937d88ba4b43e4 +test expr-28.759 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +276009279888989 E-27 x 136c242313c288_111111111111111111111111111111111111111111111111110& E-42 + convertToDouble +276009279888989E-27 +} 0x3d536c242313c289 +test expr-28.760 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -608927158043691 E-26 x -1ac7e909c22f09_11111111111111111111111111111111111111111111111110& E-38 + convertToDouble -608927158043691E-26 +} 0xbd9ac7e909c22f0a +test expr-28.761 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +552018559777978 E-27 x 136c242313c288_111111111111111111111111111111111111111111111111110& E-41 + convertToDouble +552018559777978E-27 +} 0x3d636c242313c289 +test expr-28.762 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -425678377667758 E-22 x -16da7aa49bdcd5_1111111111111111111111111111111111111111111111110& E-25 + convertToDouble -425678377667758E-22 +} 0xbe66da7aa49bdcd6 +test expr-28.763 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +8013702726927119 E26 x 126607f8f1b29e_00000000000000000000000000000000000000000000000000001& E139 + convertToDouble +8013702726927119E26 +} 0x48a26607f8f1b29e +test expr-28.764 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +8862627962362001 E27 x 196f3b0e7787c2_00000000000000000000000000000000000000000000000000001& E142 + convertToDouble +8862627962362001E27 +} 0x48d96f3b0e7787c2 +test expr-28.765 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -5068007907757162 E26 x -17456a27848397_00000000000000000000000000000000000000000000000000001& E138 + convertToDouble -5068007907757162E26 +} 0xc897456a27848397 +test expr-28.766 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -7379714799828406 E-23 x -13cf4d2839e036_00000000000000000000000000000000000000000000000000001& E-24 + convertToDouble -7379714799828406E-23 +} 0xbe73cf4d2839e036 +test expr-28.767 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +4114538064016107 E-27 x 12188eda98010c_0000000000000000000000000000000000000000000000000001& E-38 + convertToDouble +4114538064016107E-27 +} 0x3d92188eda98010c +test expr-28.768 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -3689857399914203 E-23 x -13cf4d2839e036_00000000000000000000000000000000000000000000000000001& E-25 + convertToDouble -3689857399914203E-23 +} 0xbe63cf4d2839e036 +test expr-28.769 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +5575954851815478 E23 x 1a37cfbf2ffdb5_1111111111111111111111111111111111111111111111111110& E128 + convertToDouble +5575954851815478E23 +} 0x47fa37cfbf2ffdb6 +test expr-28.770 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +3395700941739528 E27 x 137d88ba4b43e3_1111111111111111111111111111111111111111111111111110& E141 + convertToDouble +3395700941739528E27 +} 0x48c37d88ba4b43e4 +test expr-28.771 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +4115535777581961 E-23 x 1618596be30fe4_111111111111111111111111111111111111111111111111111110& E-25 + convertToDouble +4115535777581961E-23 +} 0x3e6618596be30fe5 +test expr-28.772 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -8231071555163922 E-23 x -1618596be30fe4_111111111111111111111111111111111111111111111111111110& E-24 + convertToDouble -8231071555163922E-23 +} 0xbe7618596be30fe5 +test expr-28.773 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +6550246696190871 E-26 x 1201538b0f8c69_111111111111111111111111111111111111111111111111111110& E-34 + convertToDouble +6550246696190871E-26 +} 0x3dd201538b0f8c6a +test expr-28.774 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -68083046403986701 E27 x -186c70ba8ba28d_000000000000000000000000000000000000000000000000000000001& E145 + convertToDouble -68083046403986701E27 +} 0xc9086c70ba8ba28d +test expr-28.775 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +43566388595783643 E27 x 1f41e1bf48b03f_111111111111111111111111111111111111111111111111111111110& E144 + convertToDouble +43566388595783643E27 +} 0x48ff41e1bf48b040 +test expr-28.776 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -87132777191567286 E27 x -1f41e1bf48b03f_111111111111111111111111111111111111111111111111111111110& E145 + convertToDouble -87132777191567286E27 +} 0xc90f41e1bf48b040 +test expr-28.777 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +59644881059342141 E25 x 1b6338d9d8ae38_11111111111111111111111111111111111111111111111111111110& E138 + convertToDouble +59644881059342141E25 +} 0x489b6338d9d8ae39 +test expr-28.778 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -83852770718576667 E23 x -18a4619ed6f442_111111111111111111111111111111111111111111111111111111110& E132 + convertToDouble -83852770718576667E23 +} 0xc838a4619ed6f443 +test expr-28.779 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +99482967418206961 E-25 x 155d224bfed7ac_11111111111111111111111111111111111111111111111111111111110& E-27 + convertToDouble +99482967418206961E-25 +} 0x3e455d224bfed7ad +test expr-28.780 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -99482967418206961 E-26 x -11174ea3324623_11111111111111111111111111111111111111111111111111111111110& E-30 + convertToDouble -99482967418206961E-26 +} 0xbe11174ea3324624 +test expr-28.781 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +87446669969994614 E-27 x 1809832942376d_11111111111111111111111111111111111111111111111111111110& E-34 + convertToDouble +87446669969994614E-27 +} 0x3dd809832942376e +test expr-28.782 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -43723334984997307 E-27 x -1809832942376d_11111111111111111111111111111111111111111111111111111110& E-35 + convertToDouble -43723334984997307E-27 +} 0xbdc809832942376e +test expr-28.783 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +5 E24 x 108b2a2c280290_1001& E82 + convertToDouble +5E24 +} 0x45108b2a2c280291 +test expr-28.784 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -8 E25 x -108b2a2c280290_1001& E86 + convertToDouble -8E25 +} 0xc5508b2a2c280291 +test expr-28.785 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +1 E25 x 108b2a2c280290_1001& E83 + convertToDouble +1E25 +} 0x45208b2a2c280291 +test expr-28.786 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -4 E25 x -108b2a2c280290_1001& E85 + convertToDouble -4E25 +} 0xc5408b2a2c280291 +test expr-28.787 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +2 E-5 x 14f8b588e368f0_100001& E-16 + convertToDouble +2E-5 +} 0x3ef4f8b588e368f1 +test expr-28.788 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -5 E-6 x -14f8b588e368f0_100001& E-18 + convertToDouble -5E-6 +} 0xbed4f8b588e368f1 +test expr-28.789 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +4 E-5 x 14f8b588e368f0_100001& E-15 + convertToDouble +4E-5 +} 0x3f04f8b588e368f1 +test expr-28.790 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -3 E-20 x -11b578c96db19a_100001& E-65 + convertToDouble -3E-20 +} 0xbbe1b578c96db19b +test expr-28.791 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +3 E27 x 1363156bbee301_0110& E91 + convertToDouble +3E27 +} 0x45a363156bbee301 +test expr-28.792 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -9 E26 x -1743b34e18439b_010& E89 + convertToDouble -9E26 +} 0xc58743b34e18439b +test expr-28.793 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +7 E25 x 1cf389cd46047d_00& E85 + convertToDouble +7E25 +} 0x454cf389cd46047d +test expr-28.794 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -6 E27 x -1363156bbee301_0110& E92 + convertToDouble -6E27 +} 0xc5b363156bbee301 +test expr-28.795 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +2 E-21 x 12e3b40a0e9b4f_0111110& E-69 + convertToDouble +2E-21 +} 0x3ba2e3b40a0e9b4f +test expr-28.796 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -5 E-22 x -12e3b40a0e9b4f_0111110& E-71 + convertToDouble -5E-22 +} 0xbb82e3b40a0e9b4f +test expr-28.797 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -4 E-21 x -12e3b40a0e9b4f_0111110& E-68 + convertToDouble -4E-21 +} 0xbbb2e3b40a0e9b4f +test expr-28.798 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +87 E25 x 167d2d5406637c_10001& E89 + convertToDouble +87E25 +} 0x45867d2d5406637d +test expr-28.799 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -97 E24 x -140f232256e982_1000000001& E86 + convertToDouble -97E24 +} 0xc5540f232256e983 +test expr-28.800 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +82 E-24 x 18c87154dff6c6_1000000001& E-74 + convertToDouble +82E-24 +} 0x3b58c87154dff6c7 +test expr-28.801 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -41 E-24 x -18c87154dff6c6_1000000001& E-75 + convertToDouble -41E-24 +} 0xbb48c87154dff6c7 +test expr-28.802 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +76 E-23 x 1cb644dc1633c0_10000001& E-71 + convertToDouble +76E-23 +} 0x3b8cb644dc1633c1 +test expr-28.803 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +83 E25 x 15747ab143e353_011111111110& E89 + convertToDouble +83E25 +} 0x4585747ab143e353 +test expr-28.804 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -50 E27 x -1431e0fae6d721_0111110& E95 + convertToDouble -50E27 +} 0xc5e431e0fae6d721 +test expr-28.805 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +25 E27 x 1431e0fae6d721_0111110& E94 + convertToDouble +25E27 +} 0x45d431e0fae6d721 +test expr-28.806 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -99 E27 x -13fe2e171cda19_011110& E96 + convertToDouble -99E27 +} 0xc5f3fe2e171cda19 +test expr-28.807 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +97 E-10 x 14d4a1a3157dc7_011111110& E-27 + convertToDouble +97E-10 +} 0x3e44d4a1a3157dc7 +test expr-28.808 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -57 E-20 x -15077f6f3242e7_011111110& E-61 + convertToDouble -57E-20 +} 0xbc25077f6f3242e7 +test expr-28.809 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +997 E23 x 149e12f51c1a3c_10000000001& E86 + convertToDouble +997E23 +} 0x45549e12f51c1a3d +test expr-28.810 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +776 E24 x 140f232256e982_1000000001& E89 + convertToDouble +776E24 +} 0x45840f232256e983 +test expr-28.811 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -388 E24 x -140f232256e982_1000000001& E88 + convertToDouble -388E24 +} 0xc5740f232256e983 +test expr-28.812 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +521 E-10 x 1bf891c92c0890_100000000001& E-25 + convertToDouble +521E-10 +} 0x3e6bf891c92c0891 +test expr-28.813 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -506 E-26 x -1877fa0260beb2_10000000001& E-78 + convertToDouble -506E-26 +} 0xbb1877fa0260beb3 +test expr-28.814 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +739 E-10 x 13d65e8c76722c_10000000001& E-24 + convertToDouble +739E-10 +} 0x3e73d65e8c76722d +test expr-28.815 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -867 E-7 x -16ba56a8834168_100000000001& E-14 + convertToDouble -867E-7 +} 0xbf16ba56a8834169 +test expr-28.816 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -415 E24 x -15747ab143e353_011111111110& E88 + convertToDouble -415E24 +} 0xc575747ab143e353 +test expr-28.817 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +332 E25 x 15747ab143e353_011111111110& E91 + convertToDouble +332E25 +} 0x45a5747ab143e353 +test expr-28.818 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -664 E25 x -15747ab143e353_011111111110& E92 + convertToDouble -664E25 +} 0xc5b5747ab143e353 +test expr-28.819 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +291 E-13 x 1ffeebfc8b81b5_01111111111110& E-36 + convertToDouble +291E-13 +} 0x3dbffeebfc8b81b5 +test expr-28.820 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -982 E-8 x -14981285e98e79_0111111111110& E-17 + convertToDouble -982E-8 +} 0xbee4981285e98e79 +test expr-28.821 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +582 E-13 x 1ffeebfc8b81b5_01111111111110& E-35 + convertToDouble +582E-13 +} 0x3dcffeebfc8b81b5 +test expr-28.822 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -491 E-8 x -14981285e98e79_0111111111110& E-18 + convertToDouble -491E-8 +} 0xbed4981285e98e79 +test expr-28.823 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +4574 E26 x 1717c1a612f954_100000000001& E98 + convertToDouble +4574E26 +} 0x461717c1a612f955 +test expr-28.824 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -8609 E26 x -15bb6f942546ee_1000000000001& E99 + convertToDouble -8609E26 +} 0xc625bb6f942546ef +test expr-28.825 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +2287 E26 x 1717c1a612f954_100000000001& E97 + convertToDouble +2287E26 +} 0x460717c1a612f955 +test expr-28.826 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -4818 E24 x -1f22b65eb419a0_10000000001& E91 + convertToDouble -4818E24 +} 0xc5af22b65eb419a1 +test expr-28.827 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +6529 E-8 x 111d89a8b5c142_100000000000001& E-14 + convertToDouble +6529E-8 +} 0x3f111d89a8b5c143 +test expr-28.828 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -8151 E-21 x -12cb804b61b898_1000000000000001& E-57 + convertToDouble -8151E-21 +} 0xbc62cb804b61b899 +test expr-28.829 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +1557 E-12 x 1abfc227ab1026_10000000000001& E-30 + convertToDouble +1557E-12 +} 0x3e1abfc227ab1027 +test expr-28.830 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -2573 E-18 x -172cef1ebbca44_10000000000001& E-49 + convertToDouble -2573E-18 +} 0xbce72cef1ebbca45 +test expr-28.831 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +4929 E-16 x 1157a604ed019f_0111111111111110& E-41 + convertToDouble +4929E-16 +} 0x3d6157a604ed019f +test expr-28.832 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -3053 E-22 x -1686f435fe6b6b_011111111111110& E-62 + convertToDouble -3053E-22 +} 0xbc1686f435fe6b6b +test expr-28.833 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +9858 E-16 x 1157a604ed019f_0111111111111110& E-40 + convertToDouble +9858E-16 +} 0x3d7157a604ed019f +test expr-28.834 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -7767 E-11 x -14d971170ed055_011111111111110& E-24 + convertToDouble -7767E-11 +} 0xbe74d971170ed055 +test expr-28.835 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +54339 E26 x 1125782ec15cbe_100000000000000001& E102 + convertToDouble +54339E26 +} 0x465125782ec15cbf +test expr-28.836 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -62409 E25 x -1f822c980d4bb2_100000000000000001& E98 + convertToDouble -62409E25 +} 0xc61f822c980d4bb3 +test expr-28.837 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +32819 E27 x 19e3be885fc16a_100000000000001& E104 + convertToDouble +32819E27 +} 0x4679e3be885fc16b +test expr-28.838 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -89849 E27 x -11b8371b6dda04_1000000000000001& E106 + convertToDouble -89849E27 +} 0xc691b8371b6dda05 +test expr-28.839 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +63876 E-20 x 1703856844bdbe_1000000000000000000001& E-51 + convertToDouble +63876E-20 +} 0x3cc703856844bdbf +test expr-28.840 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -15969 E-20 x -1703856844bdbe_1000000000000000000001& E-53 + convertToDouble -15969E-20 +} 0xbca703856844bdbf +test expr-28.841 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +31938 E-20 x 1703856844bdbe_1000000000000000000001& E-52 + convertToDouble +31938E-20 +} 0x3cb703856844bdbf +test expr-28.842 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -79845 E-21 x -1703856844bdbe_1000000000000000000001& E-54 + convertToDouble -79845E-21 +} 0xbc9703856844bdbf +test expr-28.843 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +89306 E27 x 119cccff237e17_011111111111110& E106 + convertToDouble +89306E27 +} 0x46919cccff237e17 +test expr-28.844 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -25487 E24 x -1496968ba07117_01111111111110& E94 + convertToDouble -25487E24 +} 0xc5d496968ba07117 +test expr-28.845 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +79889 E24 x 10222a1c7e27d3_01111111111110& E96 + convertToDouble +79889E24 +} 0x45f0222a1c7e27d3 +test expr-28.846 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -97379 E26 x -1eba3685911519_011111111111111110& E102 + convertToDouble -97379E26 +} 0xc65eba3685911519 +test expr-28.847 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +81002 E-8 x 1a8af0b45d9531_0111111111111111110& E-11 + convertToDouble +81002E-8 +} 0x3f4a8af0b45d9531 +test expr-28.848 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -43149 E-25 x -146064de6ecbed_011111111111111110& E-68 + convertToDouble -43149E-25 +} 0xbbb46064de6ecbed +test expr-28.849 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +40501 E-8 x 1a8af0b45d9531_0111111111111111110& E-12 + convertToDouble +40501E-8 +} 0x3f3a8af0b45d9531 +test expr-28.850 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -60318 E-10 x -194c988f217e51_011111111111111110& E-18 + convertToDouble -60318E-10 +} 0xbed94c988f217e51 +test expr-28.851 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -648299 E27 x -1ff6af0bf00100_10000000000000000001& E108 + convertToDouble -648299E27 +} 0xc6bff6af0bf00101 +test expr-28.852 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +780649 E24 x 13b4d36f9edd18_10000000000000000001& E99 + convertToDouble +780649E24 +} 0x4623b4d36f9edd19 +test expr-28.853 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +720919 E-14 x 1ef696965cbf04_10000000000000000000000001& E-28 + convertToDouble +720919E-14 +} 0x3e3ef696965cbf05 +test expr-28.854 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -629703 E-11 x -1a69626d2629d0_1000000000000000000000001& E-18 + convertToDouble -629703E-11 +} 0xbeda69626d2629d1 +test expr-28.855 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +557913 E24 x 1c2adb44b394bf_01111111111111111110& E98 + convertToDouble +557913E24 +} 0x461c2adb44b394bf +test expr-28.856 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -847899 E23 x -111f88fb93dce9_011111111111111111110& E96 + convertToDouble -847899E23 +} 0xc5f11f88fb93dce9 +test expr-28.857 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +565445 E27 x 1be0eb55770d4d_0111111111111111110& E108 + convertToDouble +565445E27 +} 0x46bbe0eb55770d4d +test expr-28.858 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -736531 E24 x -1297b853d64ac7_01111111111111111110& E99 + convertToDouble -736531E24 +} 0xc62297b853d64ac7 +test expr-28.859 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +680013 E-19 x 13240293e95c3b_01111111111111111111110& E-44 + convertToDouble +680013E-19 +} 0x3d33240293e95c3b +test expr-28.860 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -529981 E-10 x -1bc948d999ac11_011111111111111111110& E-15 + convertToDouble -529981E-10 +} 0xbf0bc948d999ac11 +test expr-28.861 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +382923 E-23 x 11a8c1c10a1fc5_011111111111111111110& E-58 + convertToDouble +382923E-23 +} 0x3c51a8c1c10a1fc5 +test expr-28.862 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -633614 E-18 x -164b166995a9b7_011111111111111111110& E-41 + convertToDouble -633614E-18 +} 0xbd664b166995a9b7 +test expr-28.863 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +2165479 E27 x 1ab10c016c34b8_100000000000000000000001& E110 + convertToDouble +2165479E27 +} 0x46dab10c016c34b9 +test expr-28.864 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -8661916 E27 x -1ab10c016c34b8_100000000000000000000001& E112 + convertToDouble -8661916E27 +} 0xc6fab10c016c34b9 +test expr-28.865 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +4330958 E27 x 1ab10c016c34b8_100000000000000000000001& E111 + convertToDouble +4330958E27 +} 0x46eab10c016c34b9 +test expr-28.866 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -9391993 E22 x -12f78bec748c98_1000000000000000000001& E96 + convertToDouble -9391993E22 +} 0xc5f2f78bec748c99 +test expr-28.867 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -5767352 E-14 x -1ef696965cbf04_10000000000000000000000001& E-25 + convertToDouble -5767352E-14 +} 0xbe6ef696965cbf05 +test expr-28.868 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +7209190 E-15 x 1ef696965cbf04_10000000000000000000000001& E-28 + convertToDouble +7209190E-15 +} 0x3e3ef696965cbf05 +test expr-28.869 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -1441838 E-14 x -1ef696965cbf04_10000000000000000000000001& E-27 + convertToDouble -1441838E-14 +} 0xbe4ef696965cbf05 +test expr-28.870 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +8478990 E22 x 111f88fb93dce9_011111111111111111110& E96 + convertToDouble +8478990E22 +} 0x45f11f88fb93dce9 +test expr-28.871 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +1473062 E24 x 1297b853d64ac7_01111111111111111110& E100 + convertToDouble +1473062E24 +} 0x463297b853d64ac7 +test expr-28.872 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +8366487 E-14 x 167567f55b22e1_0111111111111111111111110& E-24 + convertToDouble +8366487E-14 +} 0x3e767567f55b22e1 +test expr-28.873 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -8399969 E-25 x -1efd8be1b15b43_011111111111111111111110& E-61 + convertToDouble -8399969E-25 +} 0xbc2efd8be1b15b43 +test expr-28.874 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +9366737 E-12 x 13a4ba87ddc13f_011111111111111111111110& E-17 + convertToDouble +9366737E-12 +} 0x3ee3a4ba87ddc13f +test expr-28.875 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -9406141 E-13 x -1f8fd047c84d49_0111111111111111111111110& E-21 + convertToDouble -9406141E-13 +} 0xbeaf8fd047c84d49 +test expr-28.876 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +65970979 E24 x 1a055dd68f3e3c_1000000000000000000000000001& E105 + convertToDouble +65970979E24 +} 0x468a055dd68f3e3d +test expr-28.877 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -65060671 E26 x -140c61c9916cf4_100000000000000000000000001& E112 + convertToDouble -65060671E26 +} 0xc6f40c61c9916cf5 +test expr-28.878 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +54923002 E27 x 1527d37d8b38ea_10000000000000000000000001& E115 + convertToDouble +54923002E27 +} 0x472527d37d8b38eb +test expr-28.879 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -63846927 E25 x -1f7a9d79dad9b4_10000000000000000000000001& E108 + convertToDouble -63846927E25 +} 0xc6bf7a9d79dad9b5 +test expr-28.880 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +99585767 E-21 x 1c07e928406d2e_100000000000000000000000001& E-44 + convertToDouble +99585767E-21 +} 0x3d3c07e928406d2f +test expr-28.881 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +67488159 E25 x 10a31a03822bc9_011111111111111111111111111110& E109 + convertToDouble +67488159E25 +} 0x46c0a31a03822bc9 +test expr-28.882 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -69005339 E24 x -1b37c234aae77b_011111111111111111111111110& E105 + convertToDouble -69005339E24 +} 0xc68b37c234aae77b +test expr-28.883 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +81956786 E27 x 1f919023fcb6fd_0111111111111111111111111110& E115 + convertToDouble +81956786E27 +} 0x472f919023fcb6fd +test expr-28.884 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -40978393 E27 x -1f919023fcb6fd_0111111111111111111111111110& E114 + convertToDouble -40978393E27 +} 0xc71f919023fcb6fd +test expr-28.885 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +77505754 E-12 x 145152b6f85e09_0111111111111111111111111110& E-14 + convertToDouble +77505754E-12 +} 0x3f145152b6f85e09 +test expr-28.886 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -38752877 E-12 x -145152b6f85e09_0111111111111111111111111110& E-15 + convertToDouble -38752877E-12 +} 0xbf045152b6f85e09 +test expr-28.887 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +82772981 E-15 x 16381dae63505f_0111111111111111111111111111110& E-24 + convertToDouble +82772981E-15 +} 0x3e76381dae63505f +test expr-28.888 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -95593517 E-25 x -160ad862d8537d_0111111111111111111111111110& E-57 + convertToDouble -95593517E-25 +} 0xbc660ad862d8537d +test expr-28.889 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +200036989 E25 x 18a80dedbc575e_10000000000000000000000000001& E110 + convertToDouble +200036989E25 +} 0x46d8a80dedbc575f +test expr-28.890 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -772686455 E27 x -129a0c45ceca7a_1000000000000000000000000000001& E119 + convertToDouble -772686455E27 +} 0xc7629a0c45ceca7b +test expr-28.891 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +859139907 E23 x 10f18c4dd0ffe2_10000000000000000000000000001& E106 + convertToDouble +859139907E23 +} 0x4690f18c4dd0ffe3 +test expr-28.892 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -400073978 E25 x -18a80dedbc575e_10000000000000000000000000001& E111 + convertToDouble -400073978E25 +} 0xc6e8a80dedbc575f +test expr-28.893 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +569014327 E-14 x 17ddbeac19d3b2_100000000000000000000000000001& E-18 + convertToDouble +569014327E-14 +} 0x3ed7ddbeac19d3b3 +test expr-28.894 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -794263862 E-15 x -1aa6acb41dfc52_1000000000000000000000000000001& E-21 + convertToDouble -794263862E-15 +} 0xbeaaa6acb41dfc53 +test expr-28.895 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +397131931 E-15 x 1aa6acb41dfc52_1000000000000000000000000000001& E-22 + convertToDouble +397131931E-15 +} 0x3e9aa6acb41dfc53 +test expr-28.896 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -380398957 E-16 x -146c29d8331024_100000000000000000000000000001& E-25 + convertToDouble -380398957E-16 +} 0xbe646c29d8331025 +test expr-28.897 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +567366773 E27 x 1b5155dd5417f9_0111111111111111111111111111110& E118 + convertToDouble +567366773E27 +} 0x475b5155dd5417f9 +test expr-28.898 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -337440795 E24 x -10a31a03822bc9_011111111111111111111111111110& E108 + convertToDouble -337440795E24 +} 0xc6b0a31a03822bc9 +test expr-28.899 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +134976318 E25 x 10a31a03822bc9_011111111111111111111111111110& E110 + convertToDouble +134976318E25 +} 0x46d0a31a03822bc9 +test expr-28.900 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -269952636 E25 x -10a31a03822bc9_011111111111111111111111111110& E111 + convertToDouble -269952636E25 +} 0xc6e0a31a03822bc9 +test expr-28.901 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +932080597 E-20 x 147f25b4941e5b_0111111111111111111111111111110& E-37 + convertToDouble +932080597E-20 +} 0x3da47f25b4941e5b +test expr-28.902 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -331091924 E-15 x -16381dae63505f_0111111111111111111111111111110& E-22 + convertToDouble -331091924E-15 +} 0xbe96381dae63505f +test expr-28.903 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -413864905 E-16 x -16381dae63505f_0111111111111111111111111111110& E-25 + convertToDouble -413864905E-16 +} 0xbe66381dae63505f +test expr-28.904 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +8539246247 E26 x 148eb7813eaeba_10000000000000000000000000000001& E119 + convertToDouble +8539246247E26 +} 0x47648eb7813eaebb +test expr-28.905 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -5859139791 E26 x -1c35f28719d478_10000000000000000000000000000001& E118 + convertToDouble -5859139791E26 +} 0xc75c35f28719d479 +test expr-28.906 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +6105010149 E24 x 12d000fb2b138a_1000000000000000000000000000000001& E112 + convertToDouble +6105010149E24 +} 0x46f2d000fb2b138b +test expr-28.907 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -3090745820 E27 x -129a0c45ceca7a_1000000000000000000000000000001& E121 + convertToDouble -3090745820E27 +} 0xc7829a0c45ceca7b +test expr-28.908 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +3470877773 E-20 x 1314d381f2c31e_1000000000000000000000000000000001& E-35 + convertToDouble +3470877773E-20 +} 0x3dc314d381f2c31f +test expr-28.909 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -6136309089 E-27 x -1c4c799fab4328_1000000000000000000000000000000001& E-58 + convertToDouble -6136309089E-27 +} 0xbc5c4c799fab4329 +test expr-28.910 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +8917758713 E-19 x 1ea424bda7d7f4_100000000000000000000000000000001& E-31 + convertToDouble +8917758713E-19 +} 0x3e0ea424bda7d7f5 +test expr-28.911 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -6941755546 E-20 x -1314d381f2c31e_1000000000000000000000000000000001& E-34 + convertToDouble -6941755546E-20 +} 0xbdd314d381f2c31f +test expr-28.912 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +9194900535 E25 x 11b56f9c090dfb_011111111111111111111111111111111110& E116 + convertToDouble +9194900535E25 +} 0x4731b56f9c090dfb +test expr-28.913 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -1838980107 E26 x -11b56f9c090dfb_011111111111111111111111111111111110& E117 + convertToDouble -1838980107E26 +} 0xc741b56f9c090dfb +test expr-28.914 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +7355920428 E26 x 11b56f9c090dfb_011111111111111111111111111111111110& E119 + convertToDouble +7355920428E26 +} 0x4761b56f9c090dfb +test expr-28.915 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -3677960214 E26 x -11b56f9c090dfb_011111111111111111111111111111111110& E118 + convertToDouble -3677960214E26 +} 0xc751b56f9c090dfb +test expr-28.916 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +8473634343 E-17 x 16bf0984b232b7_0111111111111111111111111111111110& E-24 + convertToDouble +8473634343E-17 +} 0x3e76bf0984b232b7 +test expr-28.917 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -8870766274 E-16 x -1dc3ee22137269_0111111111111111111111111111111110& E-21 + convertToDouble -8870766274E-16 +} 0xbeadc3ee22137269 +test expr-28.918 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +4435383137 E-16 x 1dc3ee22137269_0111111111111111111111111111111110& E-22 + convertToDouble +4435383137E-16 +} 0x3e9dc3ee22137269 +test expr-28.919 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -9598990129 E-15 x -14216b286031e7_01111111111111111111111111111111110& E-17 + convertToDouble -9598990129E-15 +} 0xbee4216b286031e7 +test expr-28.920 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +71563496764 E26 x 15890d1ef6a0da_10000000000000000000000000000000000001& E122 + convertToDouble +71563496764E26 +} 0x4795890d1ef6a0db +test expr-28.921 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -89454370955 E25 x -15890d1ef6a0da_10000000000000000000000000000000000001& E119 + convertToDouble -89454370955E25 +} 0xc765890d1ef6a0db +test expr-28.922 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +17890874191 E26 x 15890d1ef6a0da_10000000000000000000000000000000000001& E120 + convertToDouble +17890874191E26 +} 0x4775890d1ef6a0db +test expr-28.923 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -35781748382 E26 x -15890d1ef6a0da_10000000000000000000000000000000000001& E121 + convertToDouble -35781748382E26 +} 0xc785890d1ef6a0db +test expr-28.924 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +57973447842 E-19 x 18e63f7cf5313c_1000000000000000000000000000000000000001& E-28 + convertToDouble +57973447842E-19 +} 0x3e38e63f7cf5313d +test expr-28.925 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -28986723921 E-19 x -18e63f7cf5313c_1000000000000000000000000000000000000001& E-29 + convertToDouble -28986723921E-19 +} 0xbe28e63f7cf5313d +test expr-28.926 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +76822711313 E-19 x 107f5f8b3bf818_100000000000000000000000000000000001& E-27 + convertToDouble +76822711313E-19 +} 0x3e407f5f8b3bf819 +test expr-28.927 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -97699466874 E-20 x -10c8de34de806e_10000000000000000000000000000000001& E-30 + convertToDouble -97699466874E-20 +} 0xbe10c8de34de806f +test expr-28.928 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +67748656762 E27 x 197bf5559b31fd_01111111111111111111111111111111111110& E125 + convertToDouble +67748656762E27 +} 0x47c97bf5559b31fd +test expr-28.929 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -19394840991 E24 x -1de1ea791a6e7d_0111111111111111111111111111111111110& E113 + convertToDouble -19394840991E24 +} 0xc70de1ea791a6e7d +test expr-28.930 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +38789681982 E24 x 1de1ea791a6e7d_0111111111111111111111111111111111110& E114 + convertToDouble +38789681982E24 +} 0x471de1ea791a6e7d +test expr-28.931 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -33874328381 E27 x -197bf5559b31fd_01111111111111111111111111111111111110& E124 + convertToDouble -33874328381E27 +} 0xc7b97bf5559b31fd +test expr-28.932 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +54323763886 E-27 x 1f50c5c63e5441_0111111111111111111111111111111111110& E-55 + convertToDouble +54323763886E-27 +} 0x3c8f50c5c63e5441 +test expr-28.933 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -58987193887 E-20 x -14449185a4c829_011111111111111111111111111111111111110& E-31 + convertToDouble -58987193887E-20 +} 0xbe04449185a4c829 +test expr-28.934 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +27161881943 E-27 x 1f50c5c63e5441_0111111111111111111111111111111111110& E-56 + convertToDouble +27161881943E-27 +} 0x3c7f50c5c63e5441 +test expr-28.935 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -93042648033 E-19 x -13fb12dc023fd3_0111111111111111111111111111111111110& E-27 + convertToDouble -93042648033E-19 +} 0xbe43fb12dc023fd3 +test expr-28.936 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +520831059055 E27 x 187d469cb69dd0_10000000000000000000000000000000000000001& E128 + convertToDouble +520831059055E27 +} 0x47f87d469cb69dd1 +test expr-28.937 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -768124264394 E25 x -171d6a019edae8_1000000000000000000000000000000000000001& E122 + convertToDouble -768124264394E25 +} 0xc7971d6a019edae9 +test expr-28.938 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +384062132197 E25 x 171d6a019edae8_1000000000000000000000000000000000000001& E121 + convertToDouble +384062132197E25 +} 0x47871d6a019edae9 +test expr-28.939 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +765337749889 E-25 x 158ad6f5d0a854_100000000000000000000000000000000000000001& E-44 + convertToDouble +765337749889E-25 +} 0x3d358ad6f5d0a855 +test expr-28.940 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +794368912771 E25 x 17e79872f2f7ef_01111111111111111111111111111111111111110& E122 + convertToDouble +794368912771E25 +} 0x4797e79872f2f7ef +test expr-28.941 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -994162090146 E23 x -132598f85e658b_011111111111111111111111111111111111110& E116 + convertToDouble -994162090146E23 +} 0xc7332598f85e658b +test expr-28.942 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +781652779431 E26 x 1d670adf52038f_01111111111111111111111111111111111110& E125 + convertToDouble +781652779431E26 +} 0x47cd670adf52038f +test expr-28.943 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +910077190046 E-26 x 147e3ce1871d79_01111111111111111111111111111111111111110& E-47 + convertToDouble +910077190046E-26 +} 0x3d047e3ce1871d79 +test expr-28.944 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -455038595023 E-26 x -147e3ce1871d79_01111111111111111111111111111111111111110& E-48 + convertToDouble -455038595023E-26 +} 0xbcf47e3ce1871d79 +test expr-28.945 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +471897551096 E-20 x 14449185a4c829_011111111111111111111111111111111111110& E-28 + convertToDouble +471897551096E-20 +} 0x3e34449185a4c829 +test expr-28.946 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -906698409911 E-21 x -1f27674f7d5745_0111111111111111111111111111111111111110& E-31 + convertToDouble -906698409911E-21 +} 0xbe0f27674f7d5745 +test expr-28.947 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +8854128003935 E25 x 10a71b8948faac_100000000000000000000000000000000000000001& E126 + convertToDouble +8854128003935E25 +} 0x47d0a71b8948faad +test expr-28.948 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -8146122716299 E27 x -17f0762ac05654_1000000000000000000000000000000000000000001& E132 + convertToDouble -8146122716299E27 +} 0xc837f0762ac05655 +test expr-28.949 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +7083302403148 E26 x 10a71b8948faac_100000000000000000000000000000000000000001& E129 + convertToDouble +7083302403148E26 +} 0x4800a71b8948faad +test expr-28.950 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -3541651201574 E26 x -10a71b8948faac_100000000000000000000000000000000000000001& E128 + convertToDouble -3541651201574E26 +} 0xc7f0a71b8948faad +test expr-28.951 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +8394920649291 E-25 x 1d8978e8c1cc78_100000000000000000000000000000000000000000001& E-41 + convertToDouble +8394920649291E-25 +} 0x3d6d8978e8c1cc79 +test expr-28.952 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -7657975756753 E-22 x -1a5006d695fef0_1000000000000000000000000000000000000000000001& E-31 + convertToDouble -7657975756753E-22 +} 0xbe0a5006d695fef1 +test expr-28.953 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +5473834002228 E-20 x 1d632e1f745624_100000000000000000000000000000000000000000001& E-25 + convertToDouble +5473834002228E-20 +} 0x3e6d632e1f745625 +test expr-28.954 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -6842292502785 E-21 x -1d632e1f745624_100000000000000000000000000000000000000000001& E-28 + convertToDouble -6842292502785E-21 +} 0xbe3d632e1f745625 +test expr-28.955 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -2109568884597 E25 x -1fbdc386609b13_011111111111111111111111111111111111111110& E123 + convertToDouble -2109568884597E25 +} 0xc7afbdc386609b13 +test expr-28.956 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +8438275538388 E25 x 1fbdc386609b13_011111111111111111111111111111111111111110& E125 + convertToDouble +8438275538388E25 +} 0x47cfbdc386609b13 +test expr-28.957 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -4219137769194 E25 x -1fbdc386609b13_011111111111111111111111111111111111111110& E124 + convertToDouble -4219137769194E25 +} 0xc7bfbdc386609b13 +test expr-28.958 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +3200141789841 E-25 x 1684dcea3829f7_0111111111111111111111111111111111111111110& E-42 + convertToDouble +3200141789841E-25 +} 0x3d5684dcea3829f7 +test expr-28.959 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -8655689322607 E-22 x -1dbd9ff5dc8991_011111111111111111111111111111111111111110& E-31 + convertToDouble -8655689322607E-22 +} 0xbe0dbd9ff5dc8991 +test expr-28.960 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +6400283579682 E-25 x 1684dcea3829f7_0111111111111111111111111111111111111111110& E-41 + convertToDouble +6400283579682E-25 +} 0x3d6684dcea3829f7 +test expr-28.961 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -8837719634493 E-21 x -12fa9676d2585b_011111111111111111111111111111111111111110& E-27 + convertToDouble -8837719634493E-21 +} 0xbe42fa9676d2585b +test expr-28.962 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +19428217075297 E24 x 1d3b7a1d154aba_10000000000000000000000000000000000000000000001& E123 + convertToDouble +19428217075297E24 +} 0x47ad3b7a1d154abb +test expr-28.963 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -38856434150594 E24 x -1d3b7a1d154aba_10000000000000000000000000000000000000000000001& E124 + convertToDouble -38856434150594E24 +} 0xc7bd3b7a1d154abb +test expr-28.964 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +77712868301188 E24 x 1d3b7a1d154aba_10000000000000000000000000000000000000000000001& E125 + convertToDouble +77712868301188E24 +} 0x47cd3b7a1d154abb +test expr-28.965 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -77192037242133 E27 x -1c5b1ab32d5dbe_1000000000000000000000000000000000000000000000001& E135 + convertToDouble -77192037242133E27 +} 0xc86c5b1ab32d5dbf +test expr-28.966 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +76579757567530 E-23 x 1a5006d695fef0_1000000000000000000000000000000000000000000001& E-31 + convertToDouble +76579757567530E-23 +} 0x3e0a5006d695fef1 +test expr-28.967 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +15315951513506 E-22 x 1a5006d695fef0_1000000000000000000000000000000000000000000001& E-30 + convertToDouble +15315951513506E-22 +} 0x3e1a5006d695fef1 +test expr-28.968 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -38289878783765 E-23 x -1a5006d695fef0_1000000000000000000000000000000000000000000001& E-32 + convertToDouble -38289878783765E-23 +} 0xbdfa5006d695fef1 +test expr-28.969 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +49378033925202 E25 x 1737aa2567167b_0111111111111111111111111111111111111111111110& E128 + convertToDouble +49378033925202E25 +} 0x47f737aa2567167b +test expr-28.970 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -50940527102367 E24 x -132964f2944b05_0111111111111111111111111111111111111111111111110& E125 + convertToDouble -50940527102367E24 +} 0xc7c32964f2944b05 +test expr-28.971 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +98756067850404 E25 x 1737aa2567167b_0111111111111111111111111111111111111111111110& E129 + convertToDouble +98756067850404E25 +} 0x480737aa2567167b +test expr-28.972 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -99589397544892 E26 x -1d4446075c4933_0111111111111111111111111111111111111111111110& E132 + convertToDouble -99589397544892E26 +} 0xc83d4446075c4933 +test expr-28.973 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -56908598265713 E-25 x -190756ab1ed6b3_011111111111111111111111111111111111111111111110& E-38 + convertToDouble -56908598265713E-25 +} 0xbd990756ab1ed6b3 +test expr-28.974 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +97470695699657 E-22 x 14ee821710e655_01111111111111111111111111111111111111111111110& E-27 + convertToDouble +97470695699657E-22 +} 0x3e44ee821710e655 +test expr-28.975 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -35851901247343 E-25 x -1f8921657e1581_0111111111111111111111111111111111111111111110& E-39 + convertToDouble -35851901247343E-25 +} 0xbd8f8921657e1581 +test expr-28.976 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +154384074484266 E27 x 1c5b1ab32d5dbe_1000000000000000000000000000000000000000000000001& E136 + convertToDouble +154384074484266E27 +} 0x487c5b1ab32d5dbf +test expr-28.977 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -308768148968532 E27 x -1c5b1ab32d5dbe_1000000000000000000000000000000000000000000000001& E137 + convertToDouble -308768148968532E27 +} 0xc88c5b1ab32d5dbf +test expr-28.978 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +910990389005985 E23 x 112242592ae54a_100000000000000000000000000000000000000000000001& E126 + convertToDouble +910990389005985E23 +} 0x47d12242592ae54b +test expr-28.979 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +271742424169201 E-27 x 131f46bcf7b452_10000000000000000000000000000000000000000000000001& E-42 + convertToDouble +271742424169201E-27 +} 0x3d531f46bcf7b453 +test expr-28.980 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -543484848338402 E-27 x -131f46bcf7b452_10000000000000000000000000000000000000000000000001& E-41 + convertToDouble -543484848338402E-27 +} 0xbd631f46bcf7b453 +test expr-28.981 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +162192083357563 E-26 x 1c887b68658760_1000000000000000000000000000000000000000000000001& E-40 + convertToDouble +162192083357563E-26 +} 0x3d7c887b68658761 +test expr-28.982 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -869254552770081 E-23 x -12aac70665485e_1000000000000000000000000000000000000000000000000001& E-27 + convertToDouble -869254552770081E-23 +} 0xbe42aac70665485f +test expr-28.983 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +664831007626046 E24 x 1f429cb67eb075_011111111111111111111111111111111111111111111111110& E128 + convertToDouble +664831007626046E24 +} 0x47ff429cb67eb075 +test expr-28.984 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -332415503813023 E24 x -1f429cb67eb075_011111111111111111111111111111111111111111111111110& E127 + convertToDouble -332415503813023E24 +} 0xc7ef429cb67eb075 +test expr-28.985 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +943701829041427 E24 x 162fb2e38ee461_01111111111111111111111111111111111111111111111110& E129 + convertToDouble +943701829041427E24 +} 0x48062fb2e38ee461 +test expr-28.986 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -101881054204734 E24 x -132964f2944b05_0111111111111111111111111111111111111111111111110& E126 + convertToDouble -101881054204734E24 +} 0xc7d32964f2944b05 +test expr-28.987 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +828027839666967 E-27 x 1d2236349da3cd_011111111111111111111111111111111111111111111111110& E-41 + convertToDouble +828027839666967E-27 +} 0x3d6d2236349da3cd +test expr-28.988 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -280276135608777 E-27 x -13b901892fd0bf_0111111111111111111111111111111111111111111111110& E-42 + convertToDouble -280276135608777E-27 +} 0xbd53b901892fd0bf +test expr-28.989 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +212839188833879 E-21 x 1c91194dc2d40b_0111111111111111111111111111111111111111111111110& E-23 + convertToDouble +212839188833879E-21 +} 0x3e8c91194dc2d40b +test expr-28.990 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -113817196531426 E-25 x -190756ab1ed6b3_011111111111111111111111111111111111111111111110& E-37 + convertToDouble -113817196531426E-25 +} 0xbda90756ab1ed6b3 +test expr-28.991 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +9711553197796883 E27 x 1bdeec25c0f03e_10000000000000000000000000000000000000000000000000001& E142 + convertToDouble +9711553197796883E27 +} 0x48dbdeec25c0f03f +test expr-28.992 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -2739849386524269 E26 x -19295ade212370_1000000000000000000000000000000000000000000000000001& E137 + convertToDouble -2739849386524269E26 +} 0xc889295ade212371 +test expr-28.993 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +5479698773048538 E26 x 19295ade212370_1000000000000000000000000000000000000000000000000001& E138 + convertToDouble +5479698773048538E26 +} 0x4899295ade212371 +test expr-28.994 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +6124568318523113 E-25 x 150b3a2e0aff14_1000000000000000000000000000000000000000000000000000001& E-31 + convertToDouble +6124568318523113E-25 +} 0x3e050b3a2e0aff15 +test expr-28.995 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -1139777988171071 E-24 x -1394cbee428ea4_10000000000000000000000000000000000000000000000000001& E-30 + convertToDouble -1139777988171071E-24 +} 0xbe1394cbee428ea5 +test expr-28.996 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +6322612303128019 E-27 x 1bcea0ec21e250_1000000000000000000000000000000000000000000000000000001& E-38 + convertToDouble +6322612303128019E-27 +} 0x3d9bcea0ec21e251 +test expr-28.997 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -2955864564844617 E-25 x -1450030e26c6dc_10000000000000000000000000000000000000000000000000001& E-32 + convertToDouble -2955864564844617E-25 +} 0xbdf450030e26c6dd +test expr-28.998 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -9994029144998961 E25 x -125b2b7fed4a61_0111111111111111111111111111111111111111111111111110& E136 + convertToDouble -9994029144998961E25 +} 0xc8725b2b7fed4a61 +test expr-28.999 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -2971238324022087 E27 x -110dd7a301db67_0111111111111111111111111111111111111111111111111110& E141 + convertToDouble -2971238324022087E27 +} 0xc8c10dd7a301db67 +test expr-28.1000 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -1656055679333934 E-27 x -1d2236349da3cd_011111111111111111111111111111111111111111111111110& E-40 + convertToDouble -1656055679333934E-27 +} 0xbd7d2236349da3cd +test expr-28.1001 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -1445488709150234 E-26 x -1fc960c59526c7_0111111111111111111111111111111111111111111111110& E-37 + convertToDouble -1445488709150234E-26 +} 0xbdafc960c59526c7 +test expr-28.1002 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +55824717499885172 E27 x 1406b0cd17fd56_1000000000000000000000000000000000000000000000000000000001& E145 + convertToDouble +55824717499885172E27 +} 0x490406b0cd17fd57 +test expr-28.1003 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -69780896874856465 E26 x -1406b0cd17fd56_1000000000000000000000000000000000000000000000000000000001& E142 + convertToDouble -69780896874856465E26 +} 0xc8d406b0cd17fd57 +test expr-28.1004 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +84161538867545199 E25 x 13529217bdce6c_10000000000000000000000000000000000000000000000000000000001& E139 + convertToDouble +84161538867545199E25 +} 0x48a3529217bdce6d +test expr-28.1005 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -27912358749942586 E27 x -1406b0cd17fd56_1000000000000000000000000000000000000000000000000000000001& E144 + convertToDouble -27912358749942586E27 +} 0xc8f406b0cd17fd57 +test expr-28.1006 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +24711112462926331 E-25 x 153a07f6040d22_100000000000000000000000000000000000000000000000000000001& E-29 + convertToDouble +24711112462926331E-25 +} 0x3e253a07f6040d23 +test expr-28.1007 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -12645224606256038 E-27 x -1bcea0ec21e250_1000000000000000000000000000000000000000000000000000001& E-37 + convertToDouble -12645224606256038E-27 +} 0xbdabcea0ec21e251 +test expr-28.1008 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -12249136637046226 E-25 x -150b3a2e0aff14_1000000000000000000000000000000000000000000000000000001& E-30 + convertToDouble -12249136637046226E-25 +} 0xbe150b3a2e0aff15 +test expr-28.1009 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +74874448287465757 E27 x 1adc21d1d50b09_01111111111111111111111111111111111111111111111111111110& E145 + convertToDouble +74874448287465757E27 +} 0x490adc21d1d50b09 +test expr-28.1010 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -35642836832753303 E24 x -1a2fac2b421f53_0111111111111111111111111111111111111111111111111111110& E134 + convertToDouble -35642836832753303E24 +} 0xc85a2fac2b421f53 +test expr-28.1011 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -71285673665506606 E24 x -1a2fac2b421f53_0111111111111111111111111111111111111111111111111111110& E135 + convertToDouble -71285673665506606E24 +} 0xc86a2fac2b421f53 +test expr-28.1012 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +43723334984997307 E-26 x 1e0be3f392c549_01111111111111111111111111111111111111111111111111111110& E-32 + convertToDouble +43723334984997307E-26 +} 0x3dfe0be3f392c549 +test expr-28.1013 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN +10182419849537963 E-24 x 15ddd831ebbe53_011111111111111111111111111111111111111111111111111110& E-27 + convertToDouble +10182419849537963E-24 +} 0x3e45ddd831ebbe53 +test expr-28.1014 {input floating-point conversion} {ieeeFloatingPoint} { + # Ad2b dieee UN -93501703572661982 E-26 x -10103f97ea6e13_0111111111111111111111111111111111111111111111111110& E-30 + convertToDouble -93501703572661982E-26 +} 0xbe10103f97ea6e13 + +test expr-29.1 {smallest representible number} {ieeeFloatingPoint} { + list [catch {convertToDouble 4.9406564584124654e-324} result] \ + $result \ + [catch {convertToDouble 2.4703282292062327e-324} result] \ + $result \ + [catch {convertToDouble 2.47032822920623e-324} result] \ + $result +} {0 0x0000000000000001 0 0x0000000000000001 0 0x0000000000000000} +test expr-29.2 {smallest representible number} {ieeeFloatingPoint} { + list [catch {convertToDouble -4.9406564584124654e-324} result] \ + $result \ + [catch {convertToDouble -2.4703282292062327e-324} result] \ + $result \ + [catch {convertToDouble -2.47032822920623e-324} result] \ + $result +} {0 0x8000000000000001 0 0x8000000000000001 0 0x8000000000000000} +test expr-29.3 {silent underflow on input conversion} {ieeeFloatingPoint} { + set v ? + list [scan 2.47032822920623e-324 %g v] $v +} {1 0.0} +test expr-29.4 {silent underflow on input conversion} {ieeeFloatingPoint} { + set v ? + list [scan -2.47032822920623e-324 %g v] $v +} {1 -0.0} + +test expr-30.1 {largest representible number} {ieeeFloatingPoint} { + list [catch {convertToDouble 1.7976931348623155e+308} result] \ + $result \ + [catch {convertToDouble 1.7976931348623157e+308} result] \ + $result \ + [catch {convertToDouble 1.7976931348623159e+308} result] \ + $result +} {0 0x7feffffffffffffe 0 0x7fefffffffffffff 0 0x7ff0000000000000} +test expr-30.2 {largest representible number} {ieeeFloatingPoint} { + list [catch {convertToDouble -1.7976931348623155e+308} result] \ + $result \ + [catch {convertToDouble -1.7976931348623157e+308} result] \ + $result \ + [catch {convertToDouble -1.7976931348623159e+308} result] \ + $result +} {0 0xffeffffffffffffe 0 0xffefffffffffffff 0 0xfff0000000000000} +test expr-30.3 {silent overflow on input conversion} {ieeeFloatingPoint} { + set v ? + list [scan 1.7976931348623159e+308 %f v] $v +} {1 Inf} +test expr-30.4 {silent overflow on input conversion} {ieeeFloatingPoint} { + set v ? + list [scan -1.7976931348623159e+308 %f v] $v +} {1 -Inf} + +# bool() tests (TIP #182) +set i 0 +foreach s {yes true on} { + test expr-31.$i.0 {boolean conversion} {expr bool($s)} 1 + test expr-31.$i.1 {boolean conversion} {expr bool(!$s)} 0 + test expr-31.$i.2 {boolean conversion} {expr bool("$s")} 1 + test expr-31.$i.3 {boolean conversion} {expr bool(!"$s")} 0 + set j 1 + while {$j < [string length $s]-1} { + test expr-31.$i.4.$j {boolean conversion} { + expr bool([string range $s 0 $j]) + } 1 + test expr-31.$i.5.$j {boolean conversion} { + expr bool("[string range $s 0 $j]") + } 1 + incr j + } + incr i +} +test expr-31.0.4.0 {boolean conversion} {expr bool(y)} 1 +test expr-31.0.5.0 {boolean conversion} {expr bool("y")} 1 +test expr-31.1.4.0 {boolean conversion} {expr bool(t)} 1 +test expr-31.1.5.0 {boolean conversion} {expr bool("t")} 1 +test expr-31.2.4.0 {boolean conversion} -body { + expr bool(o) +} -returnCodes error -match glob -result * +test expr-31.2.5.0 {boolean conversion} -body { + expr bool("o") +} -returnCodes error -match glob -result * +foreach s {no false off} { + test expr-31.$i.0 {boolean conversion} {expr bool($s)} 0 + test expr-31.$i.1 {boolean conversion} {expr bool(!$s)} 1 + test expr-31.$i.2 {boolean conversion} {expr bool("$s")} 0 + test expr-31.$i.3 {boolean conversion} {expr bool(!"$s")} 1 + set j 1 + while {$j < [string length $s]-1} { + test expr-31.$i.4.$j {boolean conversion} { + expr bool([string range $s 0 $j]) + } 0 + test expr-31.$i.5.$j {boolean conversion} { + expr bool("[string range $s 0 $j]") + } 0 + incr j + } + incr i +} +test expr-31.3.4.0 {boolean conversion} {expr bool(n)} 0 +test expr-31.3.5.0 {boolean conversion} {expr bool("n")} 0 +test expr-31.4.4.0 {boolean conversion} {expr bool(f)} 0 +test expr-31.4.5.0 {boolean conversion} {expr bool("f")} 0 +test expr-31.6 {boolean conversion} {expr bool(-1 + 1)} 0 +test expr-31.7 {boolean conversion} {expr bool(0 + 1)} 1 +test expr-31.8 {boolean conversion} {expr bool(0.0)} 0 +test expr-31.9 {boolean conversion} {expr bool(0x0)} 0 +test expr-31.10 {boolean conversion} {expr bool(wide(0))} 0 +test expr-31.11 {boolean conversion} {expr bool(5.0)} 1 +test expr-31.12 {boolean conversion} {expr bool(5)} 1 +test expr-31.13 {boolean conversion} {expr bool(0x5)} 1 +test expr-31.14 {boolean conversion} {expr bool(wide(5))} 1 +test expr-31.15 {boolean conversion} -body { + expr bool("fred") +} -returnCodes error -match glob -result * + +test expr-32.1 {expr mod basics} { + set mod_nums [list \ + {-3 1} {-3 2} {-3 3} {-3 4} {-3 5} \ + {-3 -1} {-3 -2} {-3 -3} {-3 -4} {-3 -5} \ + {-2 1} {-2 2} {-2 3} {-2 4} {-2 5} \ + {-2 -1} {-2 -2} {-2 -3} {-2 -4} {-2 -5} \ + {-1 1} {-1 2} {-1 3} {-1 4} {-1 5} \ + {-1 -1} {-1 -2} {-1 -3} {-1 -4} {-1 -5} \ + {0 -100} {0 -1} {0 1} {0 100} \ + {1 1} {1 2} {1 3} {1 4} {1 5} \ + {1 -1} {1 -2} {1 -3} {1 -4} {1 -5} \ + {2 1} {2 2} {2 3} {2 4} {2 5} \ + {2 -1} {2 -2} {2 -3} {2 -4} {2 -5} \ + {3 1} {3 2} {3 3} {3 4} {3 5} \ + {3 -1} {3 -2} {3 -3} {3 -4} {3 -5} \ + ] + set results [list] + foreach pair $mod_nums { + set dividend [lindex $pair 0] + set divisor [lindex $pair 1] + lappend results [expr {$dividend % $divisor}] + } + set results +} [list \ + 0 1 0 1 2 \ + 0 -1 0 -3 -3 \ + 0 0 1 2 3 \ + 0 0 -2 -2 -2 \ + 0 1 2 3 4 \ + 0 -1 -1 -1 -1 \ + 0 0 0 0 \ + 0 1 1 1 1 \ + 0 -1 -2 -3 -4 \ + 0 0 2 2 2 \ + 0 0 -1 -2 -3 \ + 0 1 0 3 3 \ + 0 -1 0 -1 -2 \ + ] + +test expr-32.2 {expr div basics} { + set mod_nums [list \ + {-3 1} {-3 2} {-3 3} {-3 4} {-3 5} \ + {-3 -1} {-3 -2} {-3 -3} {-3 -4} {-3 -5} \ + {-2 1} {-2 2} {-2 3} {-2 4} {-2 5} \ + {-2 -1} {-2 -2} {-2 -3} {-2 -4} {-2 -5} \ + {-1 1} {-1 2} {-1 3} {-1 4} {-1 5} \ + {-1 -1} {-1 -2} {-1 -3} {-1 -4} {-1 -5} \ + {0 -100} {0 -1} {0 1} {0 100} \ + {1 1} {1 2} {1 3} {1 4} {1 5} \ + {1 -1} {1 -2} {1 -3} {1 -4} {1 -5} \ + {2 1} {2 2} {2 3} {2 4} {2 5} \ + {2 -1} {2 -2} {2 -3} {2 -4} {2 -5} \ + {3 1} {3 2} {3 3} {3 4} {3 5} \ + {3 -1} {3 -2} {3 -3} {3 -4} {3 -5} \ + ] + set results [list] + foreach pair $mod_nums { + set dividend [lindex $pair 0] + set divisor [lindex $pair 1] + lappend results [expr {$dividend / $divisor}] + } + set results +} [list \ + -3 -2 -1 -1 -1 \ + 3 1 1 0 0 \ + -2 -1 -1 -1 -1 \ + 2 1 0 0 0 \ + -1 -1 -1 -1 -1 \ + 1 0 0 0 0 \ + 0 0 0 0 \ + 1 0 0 0 0 \ + -1 -1 -1 -1 -1 \ + 2 1 0 0 0 \ + -2 -1 -1 -1 -1 \ + 3 1 1 0 0 \ + -3 -2 -1 -1 -1 \ + ] + +test expr-33.1 {parse largest long value} {longIs32bit} { + set max_long_str 2147483647 + set max_long_hex "0x7FFFFFFF " + + # Convert to integer (long, not wide) internal rep + set max_long 2147483647 + string is integer $max_long + + list \ + [expr {" $max_long_str "}] \ + [expr {$max_long_str + 0}] \ + [expr {$max_long + 0}] \ + [expr {2147483647 + 0}] \ + [expr {$max_long == $max_long_hex}] \ + [expr {(2147483647 + 1) < 0}] \ + +} {2147483647 2147483647 2147483647 2147483647 1 1} +test expr-33.2 {parse smallest long value} {longIs32bit} { + set min_long_str -2147483648 + set min_long_hex "-0x80000000 " + + set min_long -2147483648 + # This will convert to integer (not wide) internal rep + string is integer $min_long + + # Note: If the final expression returns 0 then the + # expression literal is being promoted to a wide type + # when it should be parsed as a long type. + list \ + [expr {" $min_long_str "}] \ + [expr {$min_long_str + 0}] \ + [expr {$min_long + 0}] \ + [expr {-2147483648 + 0}] \ + [expr {$min_long == $min_long_hex}] \ + [expr {(-2147483648 - 1) == 0x7FFFFFFF}] \ + +} {-2147483648 -2147483648 -2147483648 -2147483648 1 1} +test expr-33.3 {parse largest wide value} {wideIs64bit} { + set max_wide_str 9223372036854775807 + set max_wide_hex "0x7FFFFFFFFFFFFFFF " + + # Convert to wide integer + set max_wide 9223372036854775807 + string is integer $max_wide + + list \ + [expr {" $max_wide_str "}] \ + [expr {$max_wide_str + 0}] \ + [expr {$max_wide + 0}] \ + [expr {9223372036854775807 + 0}] \ + [expr {$max_wide == $max_wide_hex}] \ + [expr {(9223372036854775807 + 1) < 0}] \ + +} {9223372036854775807 9223372036854775807 9223372036854775807 9223372036854775807 1 1} +test expr-33.4 {parse smallest wide value} {wideIs64bit} { + set min_wide_str -9223372036854775808 + set min_wide_hex "-0x8000000000000000 " + + set min_wide -9223372036854775808 + # Convert to wide integer + string is integer $min_wide + + # Note: If the final expression returns 0 then the + # wide integer is not being parsed correctly with + # the leading - sign. + list \ + [expr {" $min_wide_str "}] \ + [expr {$min_wide_str + 0}] \ + [expr {$min_wide + 0}] \ + [expr {-9223372036854775808 + 0}] \ + [expr {$min_wide == $min_wide_hex}] \ + [expr {(-9223372036854775808 - 1) == 0x7FFFFFFFFFFFFFFF}] \ + +} {-9223372036854775808 -9223372036854775808 -9223372036854775808 -9223372036854775808 1 1} + +set min -2147483648 +set max 2147483647 + +test expr-34.1 {expr edge cases} {longIs32bit} { + expr {$min / $min} +} {1} +test expr-34.2 {expr edge cases} {longIs32bit} { + expr {$min % $min} +} {0} +test expr-34.3 {expr edge cases} {longIs32bit} { + expr {$min / ($min + 1)} +} {1} +test expr-34.4 {expr edge cases} {longIs32bit} { + expr {$min % ($min + 1)} +} {-1} +test expr-34.5 {expr edge cases} {longIs32bit} { + expr {$min / ($min + 2)} +} {1} +test expr-34.6 {expr edge cases} {longIs32bit} { + expr {$min % ($min + 2)} +} {-2} +test expr-34.7 {expr edge cases} {longIs32bit} { + expr {$min / ($min + 3)} +} {1} +test expr-34.8 {expr edge cases} {longIs32bit} { + expr {$min % ($min + 3)} +} {-3} +test expr-34.9 {expr edge cases} {longIs32bit} { + expr {$min / -3} +} {715827882} +test expr-34.10 {expr edge cases} {longIs32bit} { + expr {$min % -3} +} {-2} +test expr-34.11 {expr edge cases} {longIs32bit} { + expr {$min / -2} +} {1073741824} +test expr-34.12 {expr edge cases} {longIs32bit} { + expr {$min % -2} +} {0} +test expr-34.13 {expr edge cases} {longIs32bit} { + expr {$min / -1} +} {-2147483648} +test expr-34.14 {expr edge cases} {longIs32bit} { + expr {$min % -1} +} {0} +test expr-34.15 {expr edge cases} {longIs32bit} { + expr {$min * -1} +} $min +test expr-34.16 {expr edge cases} {longIs32bit} { + expr {-$min} +} $min +test expr-34.17 {expr edge cases} {longIs32bit} { + expr {$min / 1} +} $min +test expr-34.18 {expr edge cases} {longIs32bit} { + expr {$min % 1} +} {0} +test expr-34.19 {expr edge cases} {longIs32bit} { + expr {$min / 2} +} {-1073741824} +test expr-34.20 {expr edge cases} {longIs32bit} { + expr {$min % 2} +} {0} +test expr-34.21 {expr edge cases} {longIs32bit} { + expr {$min / 3} +} {-715827883} +test expr-34.22 {expr edge cases} {longIs32bit} { + expr {$min % 3} +} {1} +test expr-34.23 {expr edge cases} {longIs32bit} { + expr {$min / ($max - 3)} +} {-2} +test expr-34.24 {expr edge cases} {longIs32bit} { + expr {$min % ($max - 3)} +} {2147483640} +test expr-34.25 {expr edge cases} {longIs32bit} { + expr {$min / ($max - 2)} +} {-2} +test expr-34.26 {expr edge cases} {longIs32bit} { + expr {$min % ($max - 2)} +} {2147483642} +test expr-34.27 {expr edge cases} {longIs32bit} { + expr {$min / ($max - 1)} +} {-2} +test expr-34.28 {expr edge cases} {longIs32bit} { + expr {$min % ($max - 1)} +} {2147483644} +test expr-34.29 {expr edge cases} {longIs32bit} { + expr {$min / $max} +} {-2} +test expr-34.30 {expr edge cases} {longIs32bit} { + expr {$min % $max} +} {2147483646} +test expr-34.31 {expr edge cases} {longIs32bit} { + expr {$max / $max} +} {1} +test expr-34.32 {expr edge cases} {longIs32bit} { + expr {$max % $max} +} {0} +test expr-34.33 {expr edge cases} {longIs32bit} { + expr {$max / ($max - 1)} +} {1} +test expr-34.34 {expr edge cases} {longIs32bit} { + expr {$max % ($max - 1)} +} {1} +test expr-34.35 {expr edge cases} {longIs32bit} { + expr {$max / ($max - 2)} +} {1} +test expr-34.36 {expr edge cases} {longIs32bit} { + expr {$max % ($max - 2)} +} {2} +test expr-34.37 {expr edge cases} {longIs32bit} { + expr {$max / ($max - 3)} +} {1} +test expr-34.38 {expr edge cases} {longIs32bit} { + expr {$max % ($max - 3)} +} {3} +test expr-34.39 {expr edge cases} {longIs32bit} { + expr {$max / 3} +} {715827882} +test expr-34.40 {expr edge cases} {longIs32bit} { + expr {$max % 3} +} {1} +test expr-34.41 {expr edge cases} {longIs32bit} { + expr {$max / 2} +} {1073741823} +test expr-34.42 {expr edge cases} {longIs32bit} { + expr {$max % 2} +} {1} +test expr-34.43 {expr edge cases} {longIs32bit} { + expr {$max / 1} +} $max +test expr-34.44 {expr edge cases} {longIs32bit} { + expr {$max % 1} +} {0} +test expr-34.45 {expr edge cases} {longIs32bit} { + expr {$max / -1} +} "-$max" +test expr-34.46 {expr edge cases} {longIs32bit} { + expr {$max % -1} +} {0} +test expr-34.47 {expr edge cases} {longIs32bit} { + expr {$max / -2} +} {-1073741824} +test expr-34.48 {expr edge cases} {longIs32bit} { + expr {$max % -2} +} {-1} +test expr-34.49 {expr edge cases} {longIs32bit} { + expr {$max / -3} +} {-715827883} +test expr-34.50 {expr edge cases} {longIs32bit} { + expr {$max % -3} +} {-2} +test expr-34.51 {expr edge cases} {longIs32bit} { + expr {$max / ($min + 3)} +} {-2} +test expr-34.52 {expr edge cases} {longIs32bit} { + expr {$max % ($min + 3)} +} {-2147483643} +test expr-34.53 {expr edge cases} {longIs32bit} { + expr {$max / ($min + 2)} +} {-2} +test expr-34.54 {expr edge cases} {longIs32bit} { + expr {$max % ($min + 2)} +} {-2147483645} +test expr-34.55 {expr edge cases} {longIs32bit} { + expr {$max / ($min + 1)} +} {-1} +test expr-34.56 {expr edge cases} {longIs32bit} { + expr {$max % ($min + 1)} +} {0} +test expr-34.57 {expr edge cases} {longIs32bit} { + expr {$max / $min} +} {-1} +test expr-34.58 {expr edge cases} {longIs32bit} { + expr {$max % $min} +} {-1} +test expr-34.59 {expr edge cases} {longIs32bit} { + expr {($min + 1) / ($max - 1)} +} {-2} +test expr-34.60 {expr edge cases} {longIs32bit} { + expr {($min + 1) % ($max - 1)} +} {2147483645} +test expr-34.61 {expr edge cases} {longIs32bit} { + expr {($max - 1) / ($min + 1)} +} {-1} +test expr-34.62 {expr edge cases} {longIs32bit} { + expr {($max - 1) % ($min + 1)} +} {-1} +test expr-34.63 {expr edge cases} {longIs32bit} { + expr {($max - 1) / $min} +} {-1} +test expr-34.64 {expr edge cases} {longIs32bit} { + expr {($max - 1) % $min} +} {-2} +test expr-34.65 {expr edge cases} {longIs32bit} { + expr {($max - 2) / $min} +} {-1} +test expr-34.66 {expr edge cases} {longIs32bit} { + expr {($max - 2) % $min} +} {-3} +test expr-34.67 {expr edge cases} {longIs32bit} { + expr {($max - 3) / $min} +} {-1} +test expr-34.68 {expr edge cases} {longIs32bit} { + expr {($max - 3) % $min} +} {-4} +test expr-34.69 {expr edge cases} {longIs32bit} { + expr {-3 / $min} +} {0} +test expr-34.70 {expr edge cases} {longIs32bit} { + expr {-3 % $min} +} {-3} +test expr-34.71 {expr edge cases} {longIs32bit} { + expr {-2 / $min} +} {0} +test expr-34.72 {expr edge cases} {longIs32bit} { + expr {-2 % $min} +} {-2} +test expr-34.73 {expr edge cases} {longIs32bit} { + expr {-1 / $min} +} {0} +test expr-34.74 {expr edge cases} {longIs32bit} { + expr {-1 % $min} +} {-1} +test expr-34.75 {expr edge cases} {longIs32bit} { + expr {0 / $min} +} {0} +test expr-34.76 {expr edge cases} {longIs32bit} { + expr {0 % $min} +} {0} +test expr-34.77 {expr edge cases} {longIs32bit} { + expr {0 / ($min + 1)} +} {0} +test expr-34.78 {expr edge cases} {longIs32bit} { + expr {0 % ($min + 1)} +} {0} +test expr-34.79 {expr edge cases} {longIs32bit} { + expr {1 / $min} +} {-1} +test expr-34.80 {expr edge cases} {longIs32bit} { + expr {1 % $min} +} {-2147483647} +test expr-34.81 {expr edge cases} {longIs32bit} { + expr {1 / ($min + 1)} +} {-1} +test expr-34.82 {expr edge cases} {longIs32bit} { + expr {1 % ($min + 1)} +} {-2147483646} +test expr-34.83 {expr edge cases} {longIs32bit} { + expr {2 / $min} +} {-1} +test expr-34.84 {expr edge cases} {longIs32bit} { + expr {2 % $min} +} {-2147483646} +test expr-34.85 {expr edge cases} {longIs32bit} { + expr {2 / ($min + 1)} +} {-1} +test expr-34.86 {expr edge cases} {longIs32bit} { + expr {2 % ($min + 1)} +} {-2147483645} +test expr-34.87 {expr edge cases} {longIs32bit} { + expr {3 / $min} +} {-1} +test expr-34.88 {expr edge cases} {longIs32bit} { + expr {3 % $min} +} {-2147483645} +test expr-34.89 {expr edge cases} {longIs32bit} { + expr {3 / ($min + 1)} +} {-1} +test expr-34.90 {expr edge cases} {longIs32bit} { + expr {3 % ($min + 1)} +} {-2147483644} + +# Euclidean property: +# quotient * divisor + remainder = dividend + +test expr-35.1 {expr edge cases} {longIs32bit} { + set dividend $max + set divisor 2 + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($divisor * $q) + $r}] +} {1073741823 * 2 + 1 = 2147483647} +test expr-35.2 {expr edge cases} {longIs32bit} { + set dividend [expr {$max - 1}] + set divisor 2 + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($q * $divisor) + $r}] +} {1073741823 * 2 + 0 = 2147483646} +test expr-35.3 {expr edge cases} {longIs32bit} { + set dividend [expr {$max - 2}] + set divisor 2 + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($q * $divisor) + $r}] +} {1073741822 * 2 + 1 = 2147483645} +test expr-35.4 {expr edge cases} {longIs32bit} { + set dividend $max + set divisor 3 + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($q * $divisor) + $r}] +} {715827882 * 3 + 1 = 2147483647} +test expr-35.5 {expr edge cases} {longIs32bit} { + set dividend [expr {$max - 1}] + set divisor 3 + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($q * $divisor) + $r}] +} {715827882 * 3 + 0 = 2147483646} +test expr-35.6 {expr edge cases} {longIs32bit} { + set dividend [expr {$max - 2}] + set divisor 3 + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($q * $divisor) + $r}] +} {715827881 * 3 + 2 = 2147483645} +test expr-35.7 {expr edge cases} {longIs32bit} { + set dividend $min + set divisor 2 + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($q * $divisor) + $r}] +} {-1073741824 * 2 + 0 = -2147483648} +test expr-35.8 {expr edge cases} {longIs32bit} { + set dividend [expr {$min + 1}] + set divisor 2 + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($q * $divisor) + $r}] +} {-1073741824 * 2 + 1 = -2147483647} +test expr-35.9 {expr edge cases} {longIs32bit} { + set dividend [expr {$min + 2}] + set divisor 2 + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($q * $divisor) + $r}] +} {-1073741823 * 2 + 0 = -2147483646} +test expr-35.10 {expr edge cases} {longIs32bit} { + # Two things could happen here. The multiplication + # could overflow a 32 bit type, so that when + # 1 is added it overflows again back to min. + # The multiplication could also use a wide type + # to hold ($min - 1) until 1 is added and + # the number becomes $min again. + set dividend $min + set divisor 3 + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($q * $divisor) + $r}] +} {-715827883 * 3 + 1 = -2147483648} +test expr-35.11 {expr edge cases} {longIs32bit} { + set dividend $min + set divisor -3 + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($q * $divisor) + $r}] +} {715827882 * -3 + -2 = -2147483648} +test expr-35.12 {expr edge cases} {longIs32bit} { + set dividend $min + set divisor $min + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($q * $divisor) + $r}] +} {1 * -2147483648 + 0 = -2147483648} +test expr-35.13 {expr edge cases} {longIs32bit} { + set dividend $min + set divisor [expr {$min + 1}] + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($q * $divisor) + $r}] +} {1 * -2147483647 + -1 = -2147483648} +test expr-35.14 {expr edge cases} {longIs32bit} { + set dividend $min + set divisor [expr {$min + 2}] + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($q * $divisor) + $r}] +} {1 * -2147483646 + -2 = -2147483648} + +# 64bit wide integer checks + +set min -9223372036854775808 +set max 9223372036854775807 + +test expr-36.1 {expr edge cases} {wideIs64bit} { + expr {$min / $min} +} {1} +test expr-36.2 {expr edge cases} {wideIs64bit} { + expr {$min % $min} +} {0} +test expr-36.3 {expr edge cases} {wideIs64bit} { + expr {$min / ($min + 1)} +} {1} +test expr-36.4 {expr edge cases} {wideIs64bit} { + expr {$min % ($min + 1)} +} {-1} +test expr-36.5 {expr edge cases} {wideIs64bit} { + expr {$min / ($min + 2)} +} {1} +test expr-36.6 {expr edge cases} {wideIs64bit} { + expr {$min % ($min + 2)} +} {-2} +test expr-36.7 {expr edge cases} {wideIs64bit} { + expr {$min / ($min + 3)} +} {1} +test expr-36.8 {expr edge cases} {wideIs64bit} { + expr {$min % ($min + 3)} +} {-3} +test expr-36.9 {expr edge cases} {wideIs64bit} { + expr {$min / -3} +} {3074457345618258602} +test expr-36.10 {expr edge cases} {wideIs64bit} { + expr {$min % -3} +} {-2} +test expr-36.11 {expr edge cases} {wideIs64bit} { + expr {$min / -2} +} {4611686018427387904} +test expr-36.12 {expr edge cases} {wideIs64bit} { + expr {$min % -2} +} {0} +test expr-36.13 {expr edge cases} {wideIs64bit} { + expr {$min / -1} +} $min +test expr-36.14 {expr edge cases} {wideIs64bit} { + expr {$min % -1} +} {0} +test expr-36.15 {expr edge cases} {wideIs64bit} { + expr {$min * -1} +} $min +test expr-36.16 {expr edge cases} {wideIs64bit} { + expr {-$min} +} $min +test expr-36.17 {expr edge cases} {wideIs64bit} { + expr {$min / 1} +} $min +test expr-36.18 {expr edge cases} {wideIs64bit} { + expr {$min % 1} +} {0} +test expr-36.19 {expr edge cases} {wideIs64bit} { + expr {$min / 2} +} {-4611686018427387904} +test expr-36.20 {expr edge cases} {wideIs64bit} { + expr {$min % 2} +} {0} +test expr-36.21 {expr edge cases} {wideIs64bit} { + expr {$min / 3} +} {-3074457345618258603} +test expr-36.22 {expr edge cases} {wideIs64bit} { + expr {$min % 3} +} {1} +test expr-36.23 {expr edge cases} {wideIs64bit} { + expr {$min / ($max - 3)} +} {-2} +test expr-36.24 {expr edge cases} {wideIs64bit} { + expr {$min % ($max - 3)} +} {9223372036854775800} +test expr-36.25 {expr edge cases} {wideIs64bit} { + expr {$min / ($max - 2)} +} {-2} +test expr-36.26 {expr edge cases} {wideIs64bit} { + expr {$min % ($max - 2)} +} {9223372036854775802} +test expr-36.27 {expr edge cases} {wideIs64bit} { + expr {$min / ($max - 1)} +} {-2} +test expr-36.28 {expr edge cases} {wideIs64bit} { + expr {$min % ($max - 1)} +} {9223372036854775804} +test expr-36.29 {expr edge cases} {wideIs64bit} { + expr {$min / $max} +} {-2} +test expr-36.30 {expr edge cases} {wideIs64bit} { + expr {$min % $max} +} {9223372036854775806} +test expr-36.31 {expr edge cases} {wideIs64bit} { + expr {$max / $max} +} {1} +test expr-36.32 {expr edge cases} {wideIs64bit} { + expr {$max % $max} +} {0} +test expr-36.33 {expr edge cases} {wideIs64bit} { + expr {$max / ($max - 1)} +} {1} +test expr-36.34 {expr edge cases} {wideIs64bit} { + expr {$max % ($max - 1)} +} {1} +test expr-36.35 {expr edge cases} {wideIs64bit} { + expr {$max / ($max - 2)} +} {1} +test expr-36.36 {expr edge cases} {wideIs64bit} { + expr {$max % ($max - 2)} +} {2} +test expr-36.37 {expr edge cases} {wideIs64bit} { + expr {$max / ($max - 3)} +} {1} +test expr-36.38 {expr edge cases} {wideIs64bit} { + expr {$max % ($max - 3)} +} {3} +test expr-36.39 {expr edge cases} {wideIs64bit} { + expr {$max / 3} +} {3074457345618258602} +test expr-36.40 {expr edge cases} {wideIs64bit} { + expr {$max % 3} +} {1} +test expr-36.41 {expr edge cases} {wideIs64bit} { + expr {$max / 2} +} {4611686018427387903} +test expr-36.42 {expr edge cases} {wideIs64bit} { + expr {$max % 2} +} {1} +test expr-36.43 {expr edge cases} {wideIs64bit} { + expr {$max / 1} +} $max +test expr-36.44 {expr edge cases} {wideIs64bit} { + expr {$max % 1} +} {0} +test expr-36.45 {expr edge cases} {wideIs64bit} { + expr {$max / -1} +} "-$max" +test expr-36.46 {expr edge cases} {wideIs64bit} { + expr {$max % -1} +} {0} +test expr-36.47 {expr edge cases} {wideIs64bit} { + expr {$max / -2} +} {-4611686018427387904} +test expr-36.48 {expr edge cases} {wideIs64bit} { + expr {$max % -2} +} {-1} +test expr-36.49 {expr edge cases} {wideIs64bit} { + expr {$max / -3} +} {-3074457345618258603} +test expr-36.50 {expr edge cases} {wideIs64bit} { + expr {$max % -3} +} {-2} +test expr-36.51 {expr edge cases} {wideIs64bit} { + expr {$max / ($min + 3)} +} {-2} +test expr-36.52 {expr edge cases} {wideIs64bit} { + expr {$max % ($min + 3)} +} {-9223372036854775803} +test expr-36.53 {expr edge cases} {wideIs64bit} { + expr {$max / ($min + 2)} +} {-2} +test expr-36.54 {expr edge cases} {wideIs64bit} { + expr {$max % ($min + 2)} +} {-9223372036854775805} +test expr-36.55 {expr edge cases} {wideIs64bit} { + expr {$max / ($min + 1)} +} {-1} +test expr-36.56 {expr edge cases} {wideIs64bit} { + expr {$max % ($min + 1)} +} {0} +test expr-36.57 {expr edge cases} {wideIs64bit} { + expr {$max / $min} +} {-1} +test expr-36.58 {expr edge cases} {wideIs64bit} { + expr {$max % $min} +} {-1} +test expr-36.59 {expr edge cases} {wideIs64bit} { + expr {($min + 1) / ($max - 1)} +} {-2} +test expr-36.60 {expr edge cases} {wideIs64bit} { + expr {($min + 1) % ($max - 1)} +} {9223372036854775805} +test expr-36.61 {expr edge cases} {wideIs64bit} { + expr {($max - 1) / ($min + 1)} +} {-1} +test expr-36.62 {expr edge cases} {wideIs64bit} { + expr {($max - 1) % ($min + 1)} +} {-1} +test expr-36.63 {expr edge cases} {wideIs64bit} { + expr {($max - 1) / $min} +} {-1} +test expr-36.64 {expr edge cases} {wideIs64bit} { + expr {($max - 1) % $min} +} {-2} +test expr-36.65 {expr edge cases} {wideIs64bit} { + expr {($max - 2) / $min} +} {-1} +test expr-36.66 {expr edge cases} {wideIs64bit} { + expr {($max - 2) % $min} +} {-3} +test expr-36.67 {expr edge cases} {wideIs64bit} { + expr {($max - 3) / $min} +} {-1} +test expr-36.68 {expr edge cases} {wideIs64bit} { + expr {($max - 3) % $min} +} {-4} +test expr-36.69 {expr edge cases} {wideIs64bit} { + expr {-3 / $min} +} {0} +test expr-36.70 {expr edge cases} {wideIs64bit} { + expr {-3 % $min} +} {-3} +test expr-36.71 {expr edge cases} {wideIs64bit} { + expr {-2 / $min} +} {0} +test expr-36.72 {expr edge cases} {wideIs64bit} { + expr {-2 % $min} +} {-2} +test expr-36.73 {expr edge cases} {wideIs64bit} { + expr {-1 / $min} +} {0} +test expr-36.74 {expr edge cases} {wideIs64bit} { + expr {-1 % $min} +} {-1} +test expr-36.75 {expr edge cases} {wideIs64bit} { + expr {0 / $min} +} {0} +test expr-36.76 {expr edge cases} {wideIs64bit} { + expr {0 % $min} +} {0} +test expr-36.77 {expr edge cases} {wideIs64bit} { + expr {0 / ($min + 1)} +} {0} +test expr-36.78 {expr edge cases} {wideIs64bit} { + expr {0 % ($min + 1)} +} {0} +test expr-36.79 {expr edge cases} {wideIs64bit} { + expr {1 / $min} +} {-1} +test expr-36.80 {expr edge cases} {wideIs64bit} { + expr {1 % $min} +} {-9223372036854775807} +test expr-36.81 {expr edge cases} {wideIs64bit} { + expr {1 / ($min + 1)} +} {-1} +test expr-36.82 {expr edge cases} {wideIs64bit} { + expr {1 % ($min + 1)} +} {-9223372036854775806} +test expr-36.83 {expr edge cases} {wideIs64bit} { + expr {2 / $min} +} {-1} +test expr-36.84 {expr edge cases} {wideIs64bit} { + expr {2 % $min} +} {-9223372036854775806} +test expr-36.85 {expr edge cases} {wideIs64bit} { + expr {2 / ($min + 1)} +} {-1} +test expr-36.86 {expr edge cases} {wideIs64bit} { + expr {2 % ($min + 1)} +} {-9223372036854775805} +test expr-36.87 {expr edge cases} {wideIs64bit} { + expr {3 / $min} +} {-1} +test expr-36.88 {expr edge cases} {wideIs64bit} { + expr {3 % $min} +} {-9223372036854775805} +test expr-36.89 {expr edge cases} {wideIs64bit} { + expr {3 / ($min + 1)} +} {-1} +test expr-36.90 {expr edge cases} {wideIs64bit} { + expr {3 % ($min + 1)} +} {-9223372036854775804} + +test expr-37.1 {expr edge cases} {wideIs64bit} { + set dividend $max + set divisor 2 + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($divisor * $q) + $r}] +} {4611686018427387903 * 2 + 1 = 9223372036854775807} +test expr-37.2 {expr edge cases} {wideIs64bit} { + set dividend [expr {$max - 1}] + set divisor 2 + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($q * $divisor) + $r}] +} {4611686018427387903 * 2 + 0 = 9223372036854775806} +test expr-37.3 {expr edge cases} {wideIs64bit} { + set dividend [expr {$max - 2}] + set divisor 2 + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($q * $divisor) + $r}] +} {4611686018427387902 * 2 + 1 = 9223372036854775805} +test expr-37.4 {expr edge cases} {wideIs64bit} { + set dividend $max + set divisor 3 + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($q * $divisor) + $r}] +} {3074457345618258602 * 3 + 1 = 9223372036854775807} +test expr-37.5 {expr edge cases} {wideIs64bit} { + set dividend [expr {$max - 1}] + set divisor 3 + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($q * $divisor) + $r}] +} {3074457345618258602 * 3 + 0 = 9223372036854775806} +test expr-37.6 {expr edge cases} {wideIs64bit} { + set dividend [expr {$max - 2}] + set divisor 3 + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($q * $divisor) + $r}] +} {3074457345618258601 * 3 + 2 = 9223372036854775805} +test expr-37.7 {expr edge cases} {wideIs64bit} { + set dividend $min + set divisor 2 + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($q * $divisor) + $r}] +} {-4611686018427387904 * 2 + 0 = -9223372036854775808} +test expr-37.8 {expr edge cases} {wideIs64bit} { + set dividend [expr {$min + 1}] + set divisor 2 + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($q * $divisor) + $r}] +} {-4611686018427387904 * 2 + 1 = -9223372036854775807} +test expr-37.9 {expr edge cases} {wideIs64bit} { + set dividend [expr {$min + 2}] + set divisor 2 + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($q * $divisor) + $r}] +} {-4611686018427387903 * 2 + 0 = -9223372036854775806} +test expr-37.10 {expr edge cases} {wideIs64bit} { + # Multiplication overflows 64 bit type here, + # so when the 1 is added it overflows + # again and we end up back at min. + set dividend $min + set divisor 3 + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($q * $divisor) + $r}] +} {-3074457345618258603 * 3 + 1 = -9223372036854775808} +test expr-37.11 {expr edge cases} {wideIs64bit} { + set dividend $min + set divisor -3 + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($q * $divisor) + $r}] +} {3074457345618258602 * -3 + -2 = -9223372036854775808} +test expr-37.12 {expr edge cases} {wideIs64bit} { + set dividend $min + set divisor $min + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($q * $divisor) + $r}] +} {1 * -9223372036854775808 + 0 = -9223372036854775808} +test expr-37.13 {expr edge cases} {wideIs64bit} { + set dividend $min + set divisor [expr {$min + 1}] + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($q * $divisor) + $r}] +} {1 * -9223372036854775807 + -1 = -9223372036854775808} +test expr-37.14 {expr edge cases} {wideIs64bit} { + set dividend $min + set divisor [expr {$min + 2}] + set q [expr {$dividend / $divisor}] + set r [expr {$dividend % $divisor}] + list $q * $divisor + $r = [expr {($q * $divisor) + $r}] +} {1 * -9223372036854775806 + -2 = -9223372036854775808} + +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 +test expr-46.2 {round() rounds to +-infinity} { + expr round(1.5) +} 2 +test expr-46.3 {round() rounds to +-infinity} { + expr round(-0.5) +} -1 +test expr-46.4 {round() rounds to +-infinity} { + expr round(-1.5) +} -2 +test expr-46.5 {round() overflow} { + list [catch {expr round(9.2233720368547758e+018)} result] $result +} {1 {integer value too large to represent}} +test expr-46.6 {round() overflow} { + list [catch {expr round(-9.2233720368547758e+018)} result] $result +} {1 {integer value too large to represent}} +test expr-46.7 {round() bad value} { + set x trash + list [catch {expr {round($x)}} result] $result +} {1 {argument to math function didn't have numeric value}} +test expr-46.8 {round() already an integer} { + set x 123456789012 + incr x + expr round($x) +} 123456789013 +test expr-46.9 {round() boundary case - 1/2 - 1 ulp} { + set x 0.25 + set bit 0.125 + while 1 { + set newx [expr {$x + $bit}] + if { $newx == $x || $newx == 0.5 } break + set x $newx + set bit [expr { $bit / 2.0 }] + } + expr {round($x)} +} 0 +test expr-46.10 {round() boundary case - 1/2 + 1 ulp} { + set x 0.75 + set bit 0.125 + while 1 { + set newx [expr {$x - $bit}] + if { $newx == $x || $newx == 0.5 } break + set x $newx + set bit [expr { $bit / 2.0 }] + } + expr {round($x)} +} 1 +test expr-46.11 {round() boundary case - -1/2 - 1 ulp} { + set x -0.75 + set bit 0.125 + while 1 { + set newx [expr {$x + $bit}] + if { $newx == $x || $newx == -0.5 } break + set x $newx + set bit [expr { $bit / 2.0 }] + } + expr {round($x)} +} -1 +test expr-46.12 {round() boundary case - -1/2 + 1 ulp} { + set x -0.25 + set bit 0.125 + while 1 { + set newx [expr {$x - $bit}] + if { $newx == $x || $newx == -0.5 } break + set x $newx + set bit [expr { $bit / 2.0 }] + } + expr {round($x)} +} 0 # cleanup if {[info exists a]} { unset a } +catch {unset min} +catch {unset max} ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: Index: tests/fCmd.test ================================================================== --- tests/fCmd.test +++ tests/fCmd.test @@ -8,11 +8,11 @@ # Copyright (c) 1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: fCmd.test,v 1.44 2004/11/11 01:14:29 das Exp $ +# RCS: @(#) $Id: fCmd.test,v 1.44.2.2 2005/10/08 13:44:38 dgp Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* @@ -1633,11 +1633,11 @@ set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]] file delete -force tfa tfad set result } {1} test fCmd-18.10 {TclFileRenameCmd: rename dir on top of a non-empty dir w/ -force} \ - {notRoot} { + {notRoot notNetworkFilesystem} { catch {file delete -force -- tfa tfad} file mkdir tfa tfad/tfa/file set r1 [catch {file rename -force tfa tfad}] set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]] file delete -force tfa tfad @@ -1764,11 +1764,11 @@ test fCmd-20.2 {TraverseUnixTree : recursive delete of large directory: Bug 1034337} \ {unix notRoot} { catch {file delete -force -- tfa} file mkdir tfa - for {set i 1} {$i <= 200} {incr i} {createfile tfa/testfile_$i} + for {set i 1} {$i <= 300} {incr i} {createfile tfa/testfile_$i} set result [catch {file delete -force tfa} msg] while {[catch {file delete -force tfa}]} {} list $result $msg } {0 {}} Index: tests/fileName.test ================================================================== --- tests/fileName.test +++ tests/fileName.test @@ -8,11 +8,11 @@ # Copyright (c) 1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: fileName.test,v 1.45 2004/11/11 01:16:05 das Exp $ +# RCS: @(#) $Id: fileName.test,v 1.45.2.2 2005/08/02 18:16:40 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } @@ -664,15 +664,15 @@ if {[testConstraint testsetplatform]} { testsetplatform $platform } -test filename-10.23 {Tcl_TranslateFileName} {unix nonPortable} { +test filename-10.23 {Tcl_TranslateFileName} {nonPortable} { # this test fails if ~ouster is not /home/ouster list [catch {testtranslatefilename ~ouster} msg] $msg } {0 /home/ouster} -test filename-10.24 {Tcl_TranslateFileName} {unix nonPortable} { +test filename-10.24 {Tcl_TranslateFileName} {nonPortable} { # this test fails if ~ouster is not /home/ouster list [catch {testtranslatefilename ~ouster/foo} msg] $msg } {0 /home/ouster/foo} @@ -1516,10 +1516,17 @@ removeFile execglob/abc.exe removeFile execglob/abc.notexecutable removeDirectory execglob set res } {abc.exe} + +test fileName-18.1 {windows - split ADS name correctly} {win} { + # bug 1194458 + set x [file split c:/c:d] + set y [eval [linsert $x 0 file join]] + list $x $y +} {{c:/ ./c:d} c:/c:d} # cleanup catch {file delete -force C:/globTest} cd [temporaryDirectory] file delete -force globTest Index: tests/fileSystem.test ================================================================== --- tests/fileSystem.test +++ tests/fileSystem.test @@ -911,17 +911,68 @@ } file delete -force dgp cd $origdir set res } {test test} -test filesystem-9.6 {path objects and file tail and object rep} {winOnly} { +test filesystem-9.6 {path objects and file tail and object rep} win { set res {} set p "C:\\toto" lappend res [file join $p toto] file isdirectory $p lappend res [file join $p toto] } {C:/toto/toto C:/toto/toto} +test filesystem-9.7 {path objects and glob and file tail and tilde} { + set res {} + set origdir [pwd] + cd [tcltest::temporaryDirectory] + file mkdir tilde + close [open tilde/~testNotExist w] + cd tilde + set file [lindex [glob *test*] 0] + lappend res [file exists $file] [catch {file tail $file} r] $r + lappend res $file + lappend res [file exists $file] [catch {file tail $file} r] $r + lappend res [catch {file tail $file} r] $r + cd .. + file delete -force tilde + cd $origdir + set res +} {0 1 {user "testNotExist" doesn't exist} ~testNotExist 0 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}} +test filesystem-9.8 {path objects and glob and file tail and tilde} { + set res {} + set origdir [pwd] + cd [tcltest::temporaryDirectory] + file mkdir tilde + close [open tilde/~testNotExist w] + cd tilde + set file1 [lindex [glob *test*] 0] + set file2 "~testNotExist" + lappend res $file1 $file2 + lappend res [catch {file tail $file1} r] $r + lappend res [catch {file tail $file2} r] $r + cd .. + file delete -force tilde + cd $origdir + set res +} {~testNotExist ~testNotExist 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}} +test filesystem-9.9 {path objects and glob and file tail and tilde} { + set res {} + set origdir [pwd] + cd [tcltest::temporaryDirectory] + file mkdir tilde + close [open tilde/~testNotExist w] + cd tilde + set file1 [lindex [glob *test*] 0] + set file2 "~testNotExist" + lappend res [catch {file exists $file1} r] $r + lappend res [catch {file exists $file2} r] $r + lappend res [string equal $file1 $file2] + cd .. + file delete -force tilde + cd $origdir + set res +} {0 0 0 0 1} cleanupTests unset -nocomplain drive } namespace delete ::tcl::test::fileSystem Index: tests/for.test ================================================================== --- tests/for.test +++ tests/for.test @@ -7,11 +7,11 @@ # Copyright (c) 1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: for.test,v 1.10 2004/09/26 16:36:06 msofer Exp $ +# RCS: @(#) $Id: for.test,v 1.10.2.2 2005/07/12 20:37:09 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -657,14 +657,14 @@ while *ing "set" ("for" initial command) invoked from within "$z {set} {$i < 5} {incr i} {body}"}} -test for-6.7 {Tcl_ForObjCmd: error in test expression} { +test for-6.7 {Tcl_ForObjCmd: error in test expression} -match glob -body { set z for list [catch {$z {set i 0} {i < 5} {incr i} {body}} msg] $msg $errorInfo -} {1 {syntax error in expression "i < 5": variable references require preceding $} {syntax error in expression "i < 5": variable references require preceding $ +} -result {1 {syntax error in expression "i < 5": * preceding $*} {syntax error in expression "i < 5": * preceding $* while executing "$z {set i 0} {i < 5} {incr i} {body}"}} test for-6.8 {Tcl_ForObjCmd: test expression is enclosed in quotes} { set z for set i 0 @@ -761,11 +761,60 @@ test for-6.16 {Tcl_ForObjCmd: for command result} { set z for set a [$z {set i 0} {$i < 5} {incr i} {if $i==3 break}] set a } {} - +test for-6.17 {Tcl_ForObjCmd: for command result} { + list \ + [catch {for {break} {1} {} {}} err] $err \ + [catch {for {continue} {1} {} {}} err] $err \ + [catch {for {} {[break]} {} {}} err] $err \ + [catch {for {} {[continue]} {} {}} err] $err \ + [catch {for {} {1} {break} {}} err] $err \ + [catch {for {} {1} {continue} {}} err] $err \ +} [list \ + 3 {} \ + 4 {} \ + 3 {} \ + 4 {} \ + 0 {} \ + 4 {} \ + ] +test for-6.18 {Tcl_ForObjCmd: for command result} { + proc p6181 {} { + for {break} {1} {} {} + } + proc p6182 {} { + for {continue} {1} {} {} + } + proc p6183 {} { + for {} {[break]} {} {} + } + proc p6184 {} { + for {} {[continue]} {} {} + } + proc p6185 {} { + for {} {1} {break} {} + } + proc p6186 {} { + for {} {1} {continue} {} + } + list \ + [catch {p6181} err] $err \ + [catch {p6182} err] $err \ + [catch {p6183} err] $err \ + [catch {p6184} err] $err \ + [catch {p6185} err] $err \ + [catch {p6186} err] $err +} [list \ + 1 {invoked "break" outside of a loop} \ + 1 {invoked "continue" outside of a loop} \ + 1 {invoked "break" outside of a loop} \ + 1 {invoked "continue" outside of a loop} \ + 0 {} \ + 1 {invoked "continue" outside of a loop} \ + ] # cleanup ::tcltest::cleanupTests return Index: tests/format.test ================================================================== --- tests/format.test +++ tests/format.test @@ -8,36 +8,34 @@ # Copyright (c) 1994-1998 Sun Microsystems, Inc. # # 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.19 2004/10/27 17:56:22 kennykb Exp $ +# RCS: @(#) $Id: format.test,v 1.19.2.3 2005/08/22 12:55:10 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } -# The following code is needed because some versions of SCO Unix have -# a round-off error in sprintf which would cause some of the tests to -# fail. Someday I hope this code shouldn't be necessary (code added -# 9/9/91). - -testConstraint roundOffBug [expr {"[format %7.1e 68.514]" != "6.8e+01"}] - test format-1.1 {integer formatting} { format "%*d %d %d %d" 6 34 16923 -12 -1 } { 34 16923 -12 -1} -test format-1.2 {integer formatting} {nonPortable} { +test format-1.2 {integer formatting} { format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12 } { 6 34 16923 -12 -1 0xe 0XC} # %u output depends on word length, so this test is not portable. +testConstraint longIs32bit [expr {int(0x80000000) < 0}] +testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] -test format-1.3 {integer formatting} {nonPortable} { +test format-1.3 {integer formatting} longIs32bit { format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0 } { 6 34 16923 4294967284 -1 0} +test format-1.3.1 {integer formatting} longIs64bit { + format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0 +} { 6 34 16923 18446744073709551604 -1 0} test format-1.4 {integer formatting} { format "%-4d %-4i %-4d %-4ld" 6 34 16923 -12 -1 } {6 34 16923 -12 } test format-1.5 {integer formatting} { format "%04d %04d %04d %04i" 6 34 16923 -12 -1 @@ -47,25 +45,40 @@ } {000034} # Printing negative numbers in hex or octal format depends on word # length, so these tests are not portable. -test format-1.7 {integer formatting} {nonPortable} { +test format-1.7 {integer formatting} longIs32bit { format "%4x %4x %4x %4x" 6 34 16923 -12 -1 } { 6 22 421b fffffff4} -test format-1.8 {integer formatting} {nonPortable} { +test format-1.7.1 {integer formatting} longIs64bit { + format "%4x %4x %4x %4x" 6 34 16923 -12 -1 +} { 6 22 421b fffffffffffffff4} +test format-1.8 {integer formatting} longIs32bit { format "%#x %#X %#X %#x" 6 34 16923 -12 -1 } {0x6 0X22 0X421B 0xfffffff4} -test format-1.9 {integer formatting} {nonPortable} { +test format-1.8.1 {integer formatting} longIs64bit { + format "%#x %#X %#X %#x" 6 34 16923 -12 -1 +} {0x6 0X22 0X421B 0xfffffffffffffff4} +test format-1.9 {integer formatting} longIs32bit { format "%#20x %#20x %#20x %#20x" 6 34 16923 -12 -1 } { 0x6 0x22 0x421b 0xfffffff4} -test format-1.10 {integer formatting} {nonPortable} { +test format-1.9.1 {integer formatting} longIs64bit { + format "%#20x %#20x %#20x %#20x" 6 34 16923 -12 -1 +} { 0x6 0x22 0x421b 0xfffffffffffffff4} +test format-1.10 {integer formatting} longIs32bit { format "%-#20x %-#20x %-#20x %-#20x" 6 34 16923 -12 -1 } {0x6 0x22 0x421b 0xfffffff4 } -test format-1.11 {integer formatting} {nonPortable} { +test format-1.10.1 {integer formatting} longIs64bit { + format "%-#20x %-#20x %-#20x %-#20x" 6 34 16923 -12 -1 +} {0x6 0x22 0x421b 0xfffffffffffffff4 } +test format-1.11 {integer formatting} longIs32bit { format "%-#20o %#-20o %#-20o %#-20o" 6 34 16923 -12 -1 } {06 042 041033 037777777764 } +test format-1.11.1 {integer formatting} longIs64bit { + format "%-#20o %#-20o %#-20o %#-20o" 6 34 16923 -12 -1 +} {06 042 041033 01777777777777777777764} test format-2.1 {string formatting} { format "%s %s %c %s" abcd {This is a very long test string.} 120 x } {abcd This is a very long test string. x x} test format-2.2 {string formatting} { @@ -128,23 +141,23 @@ format "%e %e %e %e" 34.2e12 68.514 -.125 -16000. .000053 } {3.420000e+13 6.851400e+01 -1.250000e-01 -1.600000e+04} test format-4.2 {e and f formats} {eformat} { format "%20e %20e %20e %20e" 34.2e12 68.514 -.125 -16000. .000053 } { 3.420000e+13 6.851400e+01 -1.250000e-01 -1.600000e+04} -test format-4.3 {e and f formats} {eformat roundOffBug} { +test format-4.3 {e and f formats} {eformat} { format "%.1e %.1e %.1e %.1e" 34.2e12 68.514 -.126 -16000. .000053 } {3.4e+13 6.9e+01 -1.3e-01 -1.6e+04} -test format-4.4 {e and f formats} {eformat roundOffBug} { +test format-4.4 {e and f formats} {eformat} { format "%020e %020e %020e %020e" 34.2e12 68.514 -.126 -16000. .000053 } {000000003.420000e+13 000000006.851400e+01 -00000001.260000e-01 -00000001.600000e+04} -test format-4.5 {e and f formats} {eformat roundOffBug} { +test format-4.5 {e and f formats} {eformat} { format "%7.1e %7.1e %7.1e %7.1e" 34.2e12 68.514 -.126 -16000. .000053 } {3.4e+13 6.9e+01 -1.3e-01 -1.6e+04} -test format-4.6 {e and f formats roundOffBug} { +test format-4.6 {e and f formats} { format "%f %f %f %f" 34.2e12 68.514 -.125 -16000. .000053 } {34200000000000.000000 68.514000 -0.125000 -16000.000000} -test format-4.7 {e and f formats} {nonPortable} { +test format-4.7 {e and f formats} { format "%.4f %.4f %.4f %.4f %.4f" 34.2e12 68.514 -.125 -16000. .000053 } {34200000000000.0000 68.5140 -0.1250 -16000.0000 0.0001} test format-4.8 {e and f formats} {eformat} { format "%.4e %.5e %.6e" -9.99996 -9.99996 9.99996 } {-1.0000e+01 -9.99996e+00 9.999960e+00} @@ -353,19 +366,23 @@ test format-9.1 {long result} { set a {1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} format {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG %s %s} $a $a } {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} -test format-10.1 {"h" format specifier} {nonPortable} { +test format-10.1 {"h" format specifier} { format %hd 0xffff } -1 -test format-10.2 {"h" format specifier} {nonPortable} { +test format-10.2 {"h" format specifier} { format %hx 0x10fff } fff -test format-10.3 {"h" format specifier} {nonPortable} { +test format-10.3 {"h" format specifier} { format %hd 0x10000 } 0 +test format-10.4 {"h" format specifier} { + # Bug 1154163: This is minimal behaviour for %hx specifier! + format %hx 1 +} 1 test format-11.1 {XPG3 %$n specifiers} { format {%2$d %1$d} 4 5 } {5 4} test format-11.2 {XPG3 %$n specifiers} { @@ -484,22 +501,22 @@ format {%s} $b } $b append b "x" } -::tcltest::testConstraint 64bitInts \ - [expr {0x80000000 > 0}] -::tcltest::testConstraint wideIntExpressions \ +::tcltest::testConstraint wideIs64bit \ + [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] +::tcltest::testConstraint wideBiggerThanInt \ [expr {wide(0x80000000) != int(0x80000000)}] -test format-17.1 {testing %d with wide} {64bitInts wideIntExpressions} { +test format-17.1 {testing %d with wide} {wideIs64bit wideBiggerThanInt} { list [catch {format %d 7810179016327718216} msg] $msg } {1 {integer value too large to represent}} -test format-17.2 {testing %ld with wide} {64bitInts} { +test format-17.2 {testing %ld with wide} {wideIs64bit} { format %ld 7810179016327718216 } 7810179016327718216 -test format-17.3 {testing %ld with non-wide} {64bitInts} { +test format-17.3 {testing %ld with non-wide} {wideIs64bit} { format %ld 42 } 42 test format-17.4 {testing %l with non-integer} { format %lf 1 } 1.000000 @@ -519,11 +536,11 @@ lappend result [expr {$a == $b}] format %08x $b lappend result [expr {$a == $b}] } {1 1 1 1} -test format-18.2 {do not demote existing numeric values} {wideIntExpressions} { +test format-18.2 {do not demote existing numeric values} {wideBiggerThanInt} { set a [expr {0xaaaaaaaaaa + 1}] set b 0xaaaaaaaaab list [catch {format %08x $a} msg] $msg [expr {$a == $b}] } {1 {integer value too large to represent} 1} Index: tests/get.test ================================================================== --- tests/get.test +++ tests/get.test @@ -8,19 +8,20 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: get.test,v 1.9 2004/05/19 10:38:24 dkf Exp $ +# RCS: @(#) $Id: get.test,v 1.9.2.2 2005/08/15 18:14:01 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } testConstraint testgetint [llength [info commands testgetint]] -testConstraint intsAre64bit [expr {int(0x80000000) > 0}] +testConstraint longIs32bit [expr {int(0x80000000) < 0}] +testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] test get-1.1 {Tcl_GetInt procedure} testgetint { testgetint 44 { 22} } {66} test get-1.2 {Tcl_GetInt procedure} testgetint { @@ -36,32 +37,32 @@ list [catch {testgetint 44 {16 }} msg] $msg } {0 60} test get-1.6 {Tcl_GetInt procedure} testgetint { list [catch {testgetint 44 {16 x}} msg] $msg } {1 {expected integer but got "16 x"}} -test get-1.7 {Tcl_GetInt procedure} {testgetint intsAre64bit} { +test get-1.7 {Tcl_GetInt procedure} {testgetint longIs64bit} { list [catch {testgetint 44 18446744073709551616} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} -test get-1.8 {Tcl_GetInt procedure} {testgetint intsAre64bit} { +test get-1.8 {Tcl_GetInt procedure} {testgetint longIs64bit} { list [catch {testgetint 18446744073709551614} msg] $msg } {0 -2} -test get-1.9 {Tcl_GetInt procedure} {testgetint intsAre64bit} { +test get-1.9 {Tcl_GetInt procedure} {testgetint longIs64bit} { list [catch {testgetint +18446744073709551614} msg] $msg } {0 -2} -test get-1.10 {Tcl_GetInt procedure} {testgetint intsAre64bit} { +test get-1.10 {Tcl_GetInt procedure} {testgetint longIs64bit} { list [catch {testgetint -18446744073709551614} msg] $msg } {0 2} -test get-1.11 {Tcl_GetInt procedure} {testgetint && !intsAre64bit} { +test get-1.11 {Tcl_GetInt procedure} {testgetint longIs32bit} { list [catch {testgetint 44 4294967296} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} -test get-1.12 {Tcl_GetInt procedure} {testgetint && !intsAre64bit} { +test get-1.12 {Tcl_GetInt procedure} {testgetint longIs32bit} { list [catch {testgetint 4294967294} msg] $msg } {0 -2} -test get-1.13 {Tcl_GetInt procedure} {testgetint && !intsAre64bit} { +test get-1.13 {Tcl_GetInt procedure} {testgetint longIs32bit} { list [catch {testgetint +4294967294} msg] $msg } {0 -2} -test get-1.14 {Tcl_GetInt procedure} {testgetint && !intsAre64bit} { +test get-1.14 {Tcl_GetInt procedure} {testgetint longIs32bit} { list [catch {testgetint -4294967294} msg] $msg } {0 2} test get-2.1 {Tcl_GetInt procedure} { format %g 1.23 @@ -70,13 +71,13 @@ format %g { 1.23 } } {1.23} test get-2.3 {Tcl_GetInt procedure} { list [catch {format %g clip} msg] $msg } {1 {expected floating-point number but got "clip"}} -test get-2.4 {Tcl_GetInt procedure} {nonPortable} { - list [catch {format %g .000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001} msg] $msg $errorCode -} {1 {floating-point value too small to represent} {ARITH UNDERFLOW {floating-point value too small to represent}}} +test get-2.4 {Tcl_GetInt procedure} { + format %g .000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001 +} 0 test get-3.1 {Tcl_GetInt(FromObj), bad numbers} { # SF bug #634856 set result "" set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1" "+12345678987654321" "++12345678987654321"] Index: tests/http.test ================================================================== --- tests/http.test +++ tests/http.test @@ -10,11 +10,11 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # -# RCS: @(#) $Id: http.test,v 1.38 2004/05/25 22:56:33 hobbs Exp $ +# RCS: @(#) $Id: http.test,v 1.38.2.1 2005/10/08 13:44:39 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -481,19 +481,19 @@ http::formatQuery lines "line1\nline2\nline3" } {lines=line1%0d%0aline2%0d%0aline3} test http-5.4 {http::formatQuery} { http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2 -} {name1=%7ebwelch&name2=%c2%a1%c2%a2%c2%a2} +} {name1=~bwelch&name2=%c2%a1%c2%a2%c2%a2} test http-5.5 {http::formatQuery} { set enc [http::config -urlencoding] http::config -urlencoding iso8859-1 set res [http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2] http::config -urlencoding $enc set res -} {name1=%7ebwelch&name2=%a1%a2%a2} +} {name1=~bwelch&name2=%a1%a2%a2} test http-6.1 {http::ProxyRequired} { http::config -proxyhost [info hostname] -proxyport $port set token [http::geturl $url] http::wait $token Index: tests/info.test ================================================================== --- tests/info.test +++ tests/info.test @@ -9,14 +9,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: info.test,v 1.29 2004/11/24 19:28:42 dgp Exp $ +# RCS: @(#) $Id: info.test,v 1.29.2.3 2005/10/08 13:44:39 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + package require tcltest 2 namespace import -force ::tcltest::* } # Set up namespaces needed to test operation of "info args", "info body", # "info default", and "info procs" with imported procedures. @@ -149,10 +149,11 @@ catch {rename _t1_ {}} catch {rename _t2_ {}} test info-4.5 {info commands option} { list [catch {info commands a b} msg] $msg } {1 {wrong # args: should be "info commands ?pattern?"}} +# Also some tests in namespace.test test info-5.1 {info complete option} { list [catch {info complete} msg] $msg } {1 {wrong # args: should be "info complete command"}} test info-5.2 {info complete option} { @@ -289,10 +290,23 @@ } {1 {wrong # args: should be "info globals ?pattern?"}} test info-8.4 {info globals option: may have leading namespace qualifiers} { set x 0 list [info globals x] [info globals :x] [info globals ::x] [info globals :::x] [info globals ::::x] } {x {} x x x} +test info-8.5 {info globals option: only return existing global variables} { + -setup { + catch {unset ::NO_SUCH_VAR} + proc evalInProc script {eval $script} + } + -body { + evalInProc {global NO_SUCH_VAR; info globals NO_SUCH_VAR} + } + -cleanup { + rename evalInProc {} + } + -result {} +} test info-9.1 {info level option} { info level } 0 test info-9.2 {info level option} { @@ -611,13 +625,13 @@ namespace delete x } -result {} # Check whether the extra testing functions are defined... if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} { - set functions {abs acos asin atan atan2 ceil cos cosh double exp floor fmod hypot int log log10 pow rand round sin sinh sqrt srand tan tanh wide} + set functions {abs acos asin atan atan2 bool ceil cos cosh double exp floor fmod hypot int log log10 max min pow rand round sin sinh sqrt srand tan tanh wide} } else { - set functions {T1 T2 T3 abs acos asin atan atan2 ceil cos cosh double exp floor fmod hypot int log log10 pow rand round sin sinh sqrt srand tan tanh wide} + set functions {T1 T2 T3 abs acos asin atan atan2 bool ceil cos cosh double exp floor fmod hypot int log log10 max min pow rand round sin sinh sqrt srand tan tanh wide} } test info-20.1 {info functions option} {info functions sin} sin test info-20.2 {info functions option} {lsort [info functions]} $functions test info-20.3 {info functions option} { lsort [info functions a*] Index: tests/init.test ================================================================== --- tests/init.test +++ tests/init.test @@ -8,11 +8,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: init.test,v 1.13 2004/10/26 16:46:16 dgp Exp $ +# RCS: @(#) $Id: init.test,v 1.13.2.1 2005/07/12 20:37:11 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -193,14 +193,27 @@ string equal $first $second } 1 incr count } + +test init-5.0 {return options passed through ::unknown} -setup { + catch {rename xxx {}} + set ::auto_index(::xxx) {proc ::xxx {} { + return -code error -level 2 xxx + }} +} -body { + set code [catch {::xxx} foo bar] + set code2 [catch {::xxx} foo2 bar2] + list $code $foo $bar $code2 $foo2 $bar2 +} -cleanup { + unset ::auto_index(::xxx) +} -result {2 xxx {-code 1 -level 1} 2 xxx {-code 1 -level 1}} cleanupTests } ;# End of [interp eval $testInterp] # cleanup interp delete $testInterp ::tcltest::cleanupTests return Index: tests/interp.test ================================================================== --- tests/interp.test +++ tests/interp.test @@ -8,11 +8,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: interp.test,v 1.43 2004/11/18 21:00:51 dgp Exp $ +# RCS: @(#) $Id: interp.test,v 1.43.2.2 2005/07/12 20:37:11 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 namespace import -force ::tcltest::* } @@ -3073,10 +3073,48 @@ list $n [interp exists $i] } -result {4 0} -cleanup { rename cb3 {} rename cb4 {} } +# Bug 1085023 +test interp-34.8 {time limits trigger in vwaits} -body { + set i [interp create] + interp limit $i time -seconds [expr {[clock seconds]+1}] -granularity 1 + $i eval { + set x {} + vwait x + } +} -cleanup { + interp delete $i +} -returnCodes error -result {limit exceeded} +test interp-34.9 {time limits trigger in blocking after} { + set i [interp create] + set t0 [clock seconds] + interp limit $i time -seconds [expr {$t0 + 1}] -granularity 1 + set code [catch { + $i eval {after 10000} + } msg] + set t1 [clock seconds] + interp delete $i + list $code $msg [expr {($t1-$t0) < 3 ? "OK" : $t1-$t0}] +} {1 {time limit exceeded} OK} +test interp-34.10 {time limits trigger in vwaits: Bug 1221395} -body { + set i [interp create] + # Assume someone hasn't set the clock to early 1970! + $i limit time -seconds 1 -granularity 4 + interp alias $i log {} lappend result + set result {} + catch { + $i eval { + log 1 + after 100 + log 2 + } + } msg + interp delete $i + lappend result $msg +} -result {1 {time limit exceeded}} test interp-35.1 {interp limit syntax} -body { interp limit } -returnCodes error -result {wrong # args: should be "interp limit path limitType ?options?"} test interp-35.2 {interp limit syntax} -body { Index: tests/io.test ================================================================== --- tests/io.test +++ tests/io.test @@ -1,5 +1,6 @@ +# -*- tcl -*- # Functionality covered: operation of all IO commands, and all procedures # defined in generic/tclIO.c. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and @@ -10,11 +11,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: io.test,v 1.65 2004/11/18 19:22:12 dgp Exp $ +# RCS: @(#) $Id: io.test,v 1.65.2.3 2005/08/25 15:46:53 dgp Exp $ if {[catch {package require tcltest 2}]} { puts stderr "Skipping tests in [info script]. tcltest 2 required." return } @@ -26,18 +27,18 @@ namespace import ::tcltest::removeFile namespace import ::tcltest::test namespace import ::tcltest::testConstraint namespace import ::tcltest::viewFile -testConstraint testchannel [llength [info commands testchannel]] -testConstraint exec [llength [info commands exec]] -testConstraint openpipe 1 -testConstraint fileevent [llength [info commands fileevent]] -testConstraint fcopy [llength [info commands fcopy]] -testConstraint testfevent [llength [info commands testfevent]] +testConstraint testchannel [llength [info commands testchannel]] +testConstraint exec [llength [info commands exec]] +testConstraint openpipe 1 +testConstraint fileevent [llength [info commands fileevent]] +testConstraint fcopy [llength [info commands fcopy]] +testConstraint testfevent [llength [info commands testfevent]] testConstraint testchannelevent [llength [info commands testchannelevent]] -testConstraint testmainthread [llength [info commands testmainthread]] +testConstraint testmainthread [llength [info commands testmainthread]] # You need a *very* special environment to do some tests. In # particular, many file systems do not support large-files... testConstraint largefileSupport 0 @@ -1702,10 +1703,16 @@ } close $f set f [open "|[list [interpreter] $path(script) [array get path]]" r] set c [gets $f] close $f + # Added delay to give Windows time to stop the spawned process and clean + # up its grip on the file test1. Added delete as proper test cleanup. + # The failing tests were 18.1 and 18.2 as first re-users of file "test1". + after 10000 + file delete $path(script) + file delete $path(test1) set c } hello test io-15.1 {Tcl_CreateCloseHandler} emptyTest { } {} @@ -4784,11 +4791,11 @@ lappend l [fconfigure $f -buffersize] fconfigure $f -buffersize 10000000 lappend l [fconfigure $f -buffersize] close $f set l -} {4096 10000 10000 10000 10000 100000 100000} +} {4096 10000 1 1 1 100000 100000} test io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads} { # This test crashes the interp if Bug #427196 is not fixed set chan [open [info script] r] fconfigure $chan -buffersize 10 @@ -7103,14 +7110,274 @@ set res } -cleanup { removeFile eofchar } -result {77 = 23431} + +# Test the cutting and splicing of channels, this is incidentially the +# attach/detach facility of package Thread, but __without any +# safeguards__. It can also be used to emulate transfer of channels +# between threads, and is used for that here. + +test io-70.0 {Cutting & Splicing channels} {testchannel} { + set f [makeFile {... dummy ...} cutsplice] + set c [open $f r] + + set res {} + lappend res [catch {seek $c 0 start}] + testchannel cut $c + + lappend res [catch {seek $c 0 start}] + testchannel splice $c + + lappend res [catch {seek $c 0 start}] + close $c + + removeFile cutsplice + + set res +} {0 1 0} + + +# Duplicate of code in "thread.test". Find a better way of doing this +# without duplication. Maybe placement into a proc which transforms to +# nop after the first call, and placement of its defintion in a +# central location. + +testConstraint testthread [expr {[info commands testthread] != {}}] + +if {[testConstraint testthread]} { + testthread errorproc ThreadError + + proc ThreadError {id info} { + global threadError + set threadError $info + } + + proc ThreadNullError {id info} { + # ignore + } +} + +test io-70.1 {Transfer channel} {testchannel testthread} { + set f [makeFile {... dummy ...} cutsplice] + set c [open $f r] + + set res {} + lappend res [catch {seek $c 0 start}] + testchannel cut $c + lappend res [catch {seek $c 0 start}] + + set tid [testthread create] + testthread send $tid [list set c $c] + lappend res [testthread send $tid { + testchannel splice $c + set res [catch {seek $c 0 start}] + close $c + set res + }] + + tcltest::threadReap + removeFile cutsplice + + set res +} {0 1 0} + +# ### ### ### ######### ######### ######### + +foreach {n msg expected} { + 0 {} {} + 1 {{message only}} {{message only}} + 2 {-options x} {-options x} + 3 {-options {x y} {the message}} {-options {x y} {the message}} + + 4 {-code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 5 {-code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 6 {-code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 7 {-code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 8 {-code error -level 0 -f ba snarf} {-code error -level 0 -f ba snarf} + 9 {-code ok -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 10 {-code error -level 5 -f ba snarf} {-code error -level 0 -f ba snarf} + 11 {-code ok -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 12 {-code boss -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 13 {-code boss -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 14 {-code 1 -level 0 -f ba} {-code 1 -level 0 -f ba} + 15 {-code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} + 16 {-code 1 -level 5 -f ba} {-code 1 -level 0 -f ba} + 17 {-code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} + 18 {-code error -level 0 -f ba} {-code error -level 0 -f ba} + 19 {-code ok -level 0 -f ba} {-code 1 -level 0 -f ba} + 20 {-code error -level 5 -f ba} {-code error -level 0 -f ba} + 21 {-code ok -level 5 -f ba} {-code 1 -level 0 -f ba} + 22 {-code boss -level 0 -f ba} {-code 1 -level 0 -f ba} + 23 {-code boss -level 5 -f ba} {-code 1 -level 0 -f ba} + 24 {-code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 25 {-code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 26 {-code error -level X -f ba snarf} {-code error -level 0 -f ba snarf} + 27 {-code ok -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 28 {-code boss -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 29 {-code 1 -level X -f ba} {-code 1 -level 0 -f ba} + 30 {-code 0 -level X -f ba} {-code 1 -level 0 -f ba} + 31 {-code error -level X -f ba} {-code error -level 0 -f ba} + 32 {-code ok -level X -f ba} {-code 1 -level 0 -f ba} + 33 {-code boss -level X -f ba} {-code 1 -level 0 -f ba} + + 34 {-code 1 -code 1 -level 0 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} + 35 {-code 1 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 36 {-code 1 -code 1 -level 5 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} + 37 {-code 1 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 38 {-code 1 -code error -level 0 -f ba snarf} {-code 1 -code error -level 0 -f ba snarf} + 39 {-code 1 -code ok -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 40 {-code 1 -code error -level 5 -f ba snarf} {-code 1 -code error -level 0 -f ba snarf} + 41 {-code 1 -code ok -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 42 {-code 1 -code boss -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 43 {-code 1 -code boss -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 44 {-code 1 -code 1 -level 0 -f ba} {-code 1 -code 1 -level 0 -f ba} + 45 {-code 1 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} + 46 {-code 1 -code 1 -level 5 -f ba} {-code 1 -code 1 -level 0 -f ba} + 47 {-code 1 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} + 48 {-code 1 -code error -level 0 -f ba} {-code 1 -code error -level 0 -f ba} + 49 {-code 1 -code ok -level 0 -f ba} {-code 1 -level 0 -f ba} + 50 {-code 1 -code error -level 5 -f ba} {-code 1 -code error -level 0 -f ba} + 51 {-code 1 -code ok -level 5 -f ba} {-code 1 -level 0 -f ba} + 52 {-code 1 -code boss -level 0 -f ba} {-code 1 -level 0 -f ba} + 53 {-code 1 -code boss -level 5 -f ba} {-code 1 -level 0 -f ba} + 54 {-code 1 -code 1 -level X -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} + 55 {-code 1 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 56 {-code 1 -code error -level X -f ba snarf} {-code 1 -code error -level 0 -f ba snarf} + 57 {-code 1 -code ok -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 58 {-code 1 -code boss -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 59 {-code 1 -code 1 -level X -f ba} {-code 1 -code 1 -level 0 -f ba} + 60 {-code 1 -code 0 -level X -f ba} {-code 1 -level 0 -f ba} + 61 {-code 1 -code error -level X -f ba} {-code 1 -code error -level 0 -f ba} + 62 {-code 1 -code ok -level X -f ba} {-code 1 -level 0 -f ba} + 63 {-code 1 -code boss -level X -f ba} {-code 1 -level 0 -f ba} + + 64 {-code 0 -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 65 {-code 0 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 66 {-code 0 -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 67 {-code 0 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 68 {-code 0 -code error -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 69 {-code 0 -code ok -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 70 {-code 0 -code error -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 71 {-code 0 -code ok -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 72 {-code 0 -code boss -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 73 {-code 0 -code boss -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 74 {-code 0 -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba} + 75 {-code 0 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} + 76 {-code 0 -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba} + 77 {-code 0 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} + 78 {-code 0 -code error -level 0 -f ba} {-code 1 -level 0 -f ba} + 79 {-code 0 -code ok -level 0 -f ba} {-code 1 -level 0 -f ba} + 80 {-code 0 -code error -level 5 -f ba} {-code 1 -level 0 -f ba} + 81 {-code 0 -code ok -level 5 -f ba} {-code 1 -level 0 -f ba} + 82 {-code 0 -code boss -level 0 -f ba} {-code 1 -level 0 -f ba} + 83 {-code 0 -code boss -level 5 -f ba} {-code 1 -level 0 -f ba} + 84 {-code 0 -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 85 {-code 0 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 86 {-code 0 -code error -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 87 {-code 0 -code ok -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 88 {-code 0 -code boss -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 89 {-code 0 -code 1 -level X -f ba} {-code 1 -level 0 -f ba} + 90 {-code 0 -code 0 -level X -f ba} {-code 1 -level 0 -f ba} + 91 {-code 0 -code error -level X -f ba} {-code 1 -level 0 -f ba} + 92 {-code 0 -code ok -level X -f ba} {-code 1 -level 0 -f ba} + 93 {-code 0 -code boss -level X -f ba} {-code 1 -level 0 -f ba} + + 94 {-code 1 -code 1 -level 0 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} + 95 {-code 0 -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 96 {-code 1 -code 1 -level 5 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} + 97 {-code 0 -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 98 {-code error -code 1 -level 0 -f ba snarf} {-code error -code 1 -level 0 -f ba snarf} + 99 {-code ok -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + a0 {-code error -code 1 -level 5 -f ba snarf} {-code error -code 1 -level 0 -f ba snarf} + a1 {-code ok -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + a2 {-code boss -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + a3 {-code boss -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + a4 {-code 1 -code 1 -level 0 -f ba} {-code 1 -code 1 -level 0 -f ba} + a5 {-code 0 -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba} + a6 {-code 1 -code 1 -level 5 -f ba} {-code 1 -code 1 -level 0 -f ba} + a7 {-code 0 -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba} + a8 {-code error -code 1 -level 0 -f ba} {-code error -code 1 -level 0 -f ba} + a9 {-code ok -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba} + b0 {-code error -code 1 -level 5 -f ba} {-code error -code 1 -level 0 -f ba} + b1 {-code ok -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba} + b2 {-code boss -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba} + b3 {-code boss -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba} + b4 {-code 1 -code 1 -level X -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} + b5 {-code 0 -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + b6 {-code error -code 1 -level X -f ba snarf} {-code error -code 1 -level 0 -f ba snarf} + b7 {-code ok -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + b8 {-code boss -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + b9 {-code 1 -code 1 -level X -f ba} {-code 1 -code 1 -level 0 -f ba} + c0 {-code 0 -code 1 -level X -f ba} {-code 1 -level 0 -f ba} + c1 {-code error -code 1 -level X -f ba} {-code error -code 1 -level 0 -f ba} + c2 {-code ok -code 1 -level X -f ba} {-code 1 -level 0 -f ba} + c3 {-code boss -code 1 -level X -f ba} {-code 1 -level 0 -f ba} + + c4 {-code 1 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + c5 {-code 0 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + c6 {-code 1 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + c7 {-code 0 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + c8 {-code error -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + c9 {-code ok -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + d0 {-code error -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + d1 {-code ok -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + d2 {-code boss -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + d3 {-code boss -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + d4 {-code 1 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} + d5 {-code 0 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} + d6 {-code 1 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} + d7 {-code 0 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} + d8 {-code error -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} + d9 {-code ok -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} + e0 {-code error -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} + e1 {-code ok -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} + e2 {-code boss -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} + e3 {-code boss -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} + e4 {-code 1 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + e5 {-code 0 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + e6 {-code error -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + e7 {-code ok -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + e8 {-code boss -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + e9 {-code 1 -code 0 -level X -f ba} {-code 1 -level 0 -f ba} + f0 {-code 0 -code 0 -level X -f ba} {-code 1 -level 0 -f ba} + f1 {-code error -code 0 -level X -f ba} {-code 1 -level 0 -f ba} + f2 {-code ok -code 0 -level X -f ba} {-code 1 -level 0 -f ba} + f3 {-code boss -code 0 -level X -f ba} {-code 1 -level 0 -f ba} +} { + test io-71.$n {Tcl_SetChannelError} {testchannel} { + + set f [makeFile {... dummy ...} cutsplice] + set c [open $f r] + + set res [testchannel setchannelerror $c [lrange $msg 0 end]] + close $c + removeFile cutsplice + + set res + } [lrange $expected 0 end] + + test io-72.$n {Tcl_SetChannelErrorInterp} {testchannel} { + + set f [makeFile {... dummy ...} cutsplice] + set c [open $f r] + + set res [testchannel setchannelerrorinterp $c [lrange $msg 0 end]] + close $c + removeFile cutsplice + + set res + } [lrange $expected 0 end] +} + +# ### ### ### ######### ######### ######### + # cleanup foreach file [list fooBar longfile script output test1 pipe my_script foo \ bar test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] { removeFile $file } cleanupTests } namespace delete ::tcl::test::io return Index: tests/ioCmd.test ================================================================== --- tests/ioCmd.test +++ tests/ioCmd.test @@ -1,5 +1,6 @@ +# -*- tcl -*- # Commands covered: open, close, gets, read, puts, seek, tell, eof, flush, # fblocked, fconfigure, open, channel, fcopy # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and @@ -10,11 +11,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: ioCmd.test,v 1.21 2004/06/23 15:36:57 dkf Exp $ +# RCS: @(#) $Id: ioCmd.test,v 1.21.2.2 2005/08/25 15:46:53 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } @@ -424,15 +425,40 @@ while processing open access modes \"FOO {BAR BAZ\" invoked from within \"open \$path(test3) \"FOO \\{BAR BAZ\"\"" test iocmd-12.7 {POSIX open access modes: errors} { list [catch {open $path(test3) {FOO BAR BAZ}} msg] $msg -} {1 {invalid access mode "FOO": must be RDONLY, WRONLY, RDWR, APPEND, CREAT EXCL, NOCTTY, NONBLOCK, or TRUNC}} +} {1 {invalid access mode "FOO": must be RDONLY, WRONLY, RDWR, APPEND, BINARY, CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC}} test iocmd-12.8 {POSIX open access modes: errors} { list [catch {open $path(test3) {TRUNC CREAT}} msg] $msg } {1 {access mode must include either RDONLY, WRONLY, or RDWR}} close [open $path(test3) w] +test iocmd-12.9 {POSIX open access modes: BINARY} { + list [catch {open $path(test1) BINARY} msg] $msg +} {1 {access mode must include either RDONLY, WRONLY, or RDWR}} +test iocmd-12.10 {POSIX open access modes: BINARY} { + set f [open $path(test1) {WRONLY BINARY TRUNC}] + puts $f a + puts $f b + puts -nonewline $f c ;# contents are now 5 bytes: a\nb\nc + close $f + set f [open $path(test1) r] + fconfigure $f -translation binary + set result [string length [read $f]] + close $f + set result +} 5 +test iocmd-12.11 {POSIX open access modes: BINARY} { + set f [open $path(test1) {WRONLY BINARY TRUNC}] + puts $f \u0248 ;# gets truncated to \u0048 + close $f + set f [open $path(test1) r] + fconfigure $f -translation binary + set result [read -nonewline $f] + close $f + set result +} \u0048 test iocmd-13.1 {errors in open command} { list [catch {open} msg] $msg } {1 {wrong # args: should be "open fileName ?access? ?permissions?"}} test iocmd-13.2 {errors in open command} { @@ -450,10 +476,19 @@ test iocmd-13.6 {errors in open command} { set msg [list [catch {open _non_existent_} msg] $msg $errorCode] regsub [file join {} _non_existent_] $msg "_non_existent_" msg string tolower $msg } {1 {couldn't open "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}} +test iocmd-13.7 {errors in open command} { + list [catch {open $path(test1) b} msg] $msg +} {1 {illegal access mode "b"}} +test iocmd-13.8 {errors in open command} { + list [catch {open $path(test1) rbb} msg] $msg +} {1 {illegal access mode "rbb"}} +test iocmd-13.9 {errors in open command} { + list [catch {open $path(test1) r++} msg] $msg +} {1 {illegal access mode "r++"}} test iocmd-14.1 {file id parsing errors} { list [catch {eof gorp} msg] $msg $errorCode } {1 {can not find channel named "gorp"} NONE} test iocmd-14.2 {file id parsing errors} { @@ -536,10 +571,3085 @@ } {1 {expected integer but got "foo"}} close $rfile close $wfile +# ### ### ### ######### ######### ######### +## Testing the reflected channel. + +test iocmd-20.0 {chan, wrong#args} { + catch {chan} msg + set msg +} {wrong # args: should be "chan subcommand ?argument ...?"} + +test iocmd-20.1 {chan, unknown method} { + catch {chan foo} msg + set msg +} {unknown or ambiguous subcommand "foo": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, postevent, puts, read, seek, tell, or truncate} + +# --- --- --- --------- --------- --------- +# chan create, and method "initalize" + +test iocmd-21.0 {chan create, wrong#args, not enough} { + catch {chan create} msg + set msg +} {wrong # args: should be "chan create mode cmdprefix"} + +test iocmd-21.1 {chan create, wrong#args, too many} { + catch {chan create a b c} msg + set msg +} {wrong # args: should be "chan create mode cmdprefix"} + +test iocmd-21.2 {chan create, invalid r/w mode, empty} { + proc foo {} {} + catch {chan create {} foo} msg + rename foo {} + set msg +} {bad mode list: is empty} + +test iocmd-21.3 {chan create, invalid r/w mode, bad string} { + proc foo {} {} + catch {chan create {c} foo} msg + rename foo {} + set msg +} {bad mode "c": must be read or write} + +test iocmd-21.4 {chan create, bad handler, not a list} { + catch {chan create {r w} "foo \{"} msg + set msg +} {unmatched open brace in list} + +test iocmd-21.5 {chan create, bad handler, not a command} { + catch {chan create {r w} foo} msg + set msg +} {Initialize failure: invalid command name "foo"} + +test iocmd-21.6 {chan create, initialize failed, bad signature} { + proc foo {} {} + catch {chan create {r w} foo} msg + rename foo {} + set msg +} {Initialize failure: wrong # args: should be "foo"} + +test iocmd-21.7 {chan create, initialize failed, bad signature} { + proc foo {} {} + catch {chan create {r w} ::foo} msg + rename foo {} + set msg +} {Initialize failure: wrong # args: should be "::foo"} + +test iocmd-21.8 {chan create, initialize failed, bad result, not a list} { + proc foo {args} {return "\{"} + catch {chan create {r w} foo} msg + rename foo {} + set msg +} {Initialize failure: unmatched open brace in list} + +test iocmd-21.9 {chan create, initialize failed, bad result, not a list} { + proc foo {args} {return \{\{\}} + catch {chan create {r w} foo} msg + rename foo {} + set msg +} {Initialize failure: unmatched open brace in list} + +test iocmd-21.10 {chan create, initialize failed, bad result, empty list} { + proc foo {args} {} + catch {chan create {r w} foo} msg + rename foo {} + set msg +} {Initialize failure: Not all required methods supported} + +test iocmd-21.11 {chan create, initialize failed, bad result, bogus method name} { + proc foo {args} {return 1} + catch {chan create {r w} foo} msg + rename foo {} + set msg +} {Initialize failure: bad method "1": must be blocking, cget, cgetall, configure, finalize, initialize, read, seek, watch, or write} + +test iocmd-21.12 {chan create, initialize failed, bad result, ambiguous method name} { + proc foo {args} {return {a b c}} + catch {chan create {r w} foo} msg + rename foo {} + set msg +} {Initialize failure: ambiguous method "c": must be blocking, cget, cgetall, configure, finalize, initialize, read, seek, watch, or write} + +test iocmd-21.13 {chan create, initialize failed, bad result, required methods missing} { + proc foo {args} {return {initialize finalize}} + catch {chan create {r w} foo} msg + rename foo {} + set msg +} {Initialize failure: Not all required methods supported} + +test iocmd-21.14 {chan create, initialize failed, bad result, mode/handler mismatch} { + proc foo {args} {return {initialize finalize watch read}} + catch {chan create {r w} foo} msg + rename foo {} + set msg +} {Initialize failure: Writing not supported, but requested} + +test iocmd-21.15 {chan create, initialize failed, bad result, mode/handler mismatch} { + proc foo {args} {return {initialize finalize watch write}} + catch {chan create {r w} foo} msg + rename foo {} + set msg +} {Initialize failure: Reading not supported, but requested} + +test iocmd-21.16 {chan create, initialize failed, bad result, cget(all) mismatch} { + proc foo {args} {return {initialize finalize watch cget write read}} + catch {chan create {r w} foo} msg + rename foo {} + set msg +} {Initialize failure: 'cgetall' not supported, but should be, as 'cget' is} + +test iocmd-21.17 {chan create, initialize failed, bad result, cget(all) mismatch} { + proc foo {args} {return {initialize finalize watch cgetall read write}} + catch {chan create {r w} foo} msg + rename foo {} + set msg +} {Initialize failure: 'cget' not supported, but should be, as 'cgetall' is} + +test iocmd-21.18 {chan create, initialize ok, creates channel} -match glob -body { + proc foo {args} { + global res + lappend res $args + if {[lindex $args 0] ne "initialize"} {return} + return {initialize finalize watch read write} + } + set res {} + lappend res [file channel rc*] + lappend res [chan create {r w} foo] + lappend res [close [lindex $res end]] + lappend res [file channel rc*] + rename foo {} + set res +} -result {{} {initialize rc* {read write}} rc* {finalize rc*} {} {}} + +test iocmd-21.19 {chan create, init failure -> no channel, no finalize} -match glob -body { + proc foo {args} { + global res + lappend res $args + return {} + } + set res {} + lappend res [file channel rc*] + lappend res [catch {chan create {r w} foo} msg] + lappend res $msg + lappend res [file channel rc*] + rename foo {} + set res +} -result {{} {initialize rc* {read write}} 1 {Initialize failure: Not all required methods supported} {}} + +# --- --- --- --------- --------- --------- +# Helper commands to record the arguments to handler methods. + +proc note {item} {global res ; lappend res $item ; return} +proc track {} {upvar args item ; note $item; return} +proc notes {items} {foreach i $items {note $i}} + +# Helper command, canned result for 'initialize' method. +# Gets the optional methods as arguments. Use return features +# to post the result higher up. + +proc init {args} { + lappend args initialize finalize watch read write + return -code return $args +} + +proc oninit {args} { + upvar args hargs + if {[lindex $hargs 0] ne "initialize"} {return} + lappend args initialize finalize watch read write + return -code return $args +} + +proc onfinal {} { + upvar args hargs + if {[lindex $hargs 0] ne "finalize"} {return} + return -code return "" +} + +# --- --- --- --------- --------- --------- +# method finalize + +test iocmd-22.1 {chan finalize, handler destruction has no effect on channel} -match glob -body { + set res {} + proc foo {args} {track ; oninit; return} + note [set c [chan create {r w} foo]] + + rename foo {} + + note [file channels rc*] + note [catch {close $c} msg] ; note $msg + note [file channels rc*] + + set res +} -result {{initialize rc* {read write}} rc* rc* 1 {invalid command name "foo"} {}} + +test iocmd-22.2 {chan finalize, for close} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return {}} + note [set c [chan create {r w} foo]] + + close $c + + # Close deleted the channel. + note [file channels rc*] + + # Channel destruction does not kill handler command! + note [info command foo] + + rename foo {} + set res +} -result {{initialize rc* {read write}} rc* {finalize rc*} {} foo} + +test iocmd-22.3 {chan finalize, for close, error, close error} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return -code error 5} + note [set c [chan create {r w} foo]] + + note [catch {close $c} msg] ; note $msg + # Channel is gone despite error. + note [file channels rc*] + + rename foo {} + set res +} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 5 {}} + +test iocmd-22.4 {chan finalize, for close, error, close error} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; error FOO} + note [set c [chan create {r w} foo]] + + note [catch {close $c} msg] ; note $msg + + rename foo {} + set res +} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 FOO} + +test iocmd-22.5 {chan finalize, for close, arbitrary result, ignored} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return SOMETHING} + note [set c [chan create {r w} foo]] + + note [catch {close $c} msg]; note $msg + + rename foo {} + set res +} -result {{initialize rc* {read write}} rc* {finalize rc*} 0 {}} + +test iocmd-22.6 {chan finalize, for close, break, close error} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return -code 3} + note [set c [chan create {r w} foo]] + + note [catch {close $c} msg] ; note $msg + + rename foo {} + set res +} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 {}} + +test iocmd-22.7 {chan finalize, for close, continue, close error} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return -code 4} + note [set c [chan create {r w} foo]] + + note [catch {close $c} msg] ; note $msg + + rename foo {} + set res +} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 {}} + +test iocmd-22.8 {chan finalize, for close, custom code, close error} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return -code 777 BANG} + note [set c [chan create {r w} foo]] + + note [catch {close $c} msg] ; note $msg + + rename foo {} + set res +} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 BANG} + +test iocmd-22.9 {chan finalize, for close, ignore level, close error} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return -level 5 -code 777 BANG} + note [set c [chan create {r w} foo]] + + note [catch {close $c} msg opt] ; note $msg ; note $opt + + rename foo {} + set res +} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} + +# --- === *** ########################### +# method read + +test iocmd-23.1 {chan read, regular data return} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return snarf + } + set c [chan create {r w} foo] + + note [read $c 10] + close $c + + rename foo {} + set res +} -result {{read rc* 4096} {read rc* 4096} snarfsnarf} + +test iocmd-23.2 {chan read, bad data return, to much} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return [string repeat snarf 1000] + } + set c [chan create {r w} foo] + + note [catch {read $c 2} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{read rc* 4096} 1 {read delivered more than requested}} + +test iocmd-23.3 {chan read, for non-readable channel} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + note MUST_NOT_HAPPEN + } + set c [chan create {w} foo] + + note [catch {read $c 2} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {1 {channel "rc*" wasn't opened for reading}} + +test iocmd-23.4 {chan read, error return} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return -code error BOOM! + } + set c [chan create {r w} foo] + note [catch {read $c 2} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{read rc* 4096} 1 BOOM!} + +test iocmd-23.5 {chan read, break return is error} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return -code break BOOM! + } + set c [chan create {r w} foo] + note [catch {read $c 2} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{read rc* 4096} 1 BOOM!} + +test iocmd-23.6 {chan read, continue return is error} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return -code continue BOOM! + } + set c [chan create {r w} foo] + note [catch {read $c 2} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{read rc* 4096} 1 BOOM!} + +test iocmd-23.7 {chan read, custom return is error} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return -code 777 BOOM! + } + set c [chan create {r w} foo] + note [catch {read $c 2} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{read rc* 4096} 1 BOOM!} + +test iocmd-23.8 {chan read, level is squashed} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return -level 55 -code 777 BOOM! + } + set c [chan create {r w} foo] + note [catch {read $c 2} msg opt] ; note $msg ; note $opt + close $c + + rename foo {} + set res +} -result {{read rc* 4096} 1 BOOM! {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BOOM!}} + +# --- === *** ########################### +# method write + +test iocmd-24.1 {chan write, regular write} -match glob -body { + set res {} + proc foo {args} { + oninit; onfinal ; track + set written [string length [lindex $args 2]] + note $written + return $written + } + set c [chan create {r w} foo] + + puts -nonewline $c snarf ; flush $c + close $c + + rename foo {} + set res +} -result {{write rc* snarf} 5} + +test iocmd-24.2 {chan write, partial write is ok} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + set written [string length [lindex $args 2]] + if {$written > 10} {set written [expr {$written / 2}]} + note $written + return $written + } + set c [chan create {r w} foo] + + puts -nonewline $c snarfsnarfsnarf ; flush $c + close $c + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 7 {write rc* arfsnarf} 8} + +test iocmd-24.3 {chan write, failed write} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note -1 ; return -1} + + set c [chan create {r w} foo] + puts -nonewline $c snarfsnarfsnarf ; flush $c + close $c + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} -1} + +test iocmd-24.4 {chan write, non-writable channel} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r} foo] + + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {1 {channel "rc*" wasn't opened for writing}} + +test iocmd-24.5 {chan write, bad result, more written than data} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return 10000} + set c [chan create {r w} foo] + + note [catch {puts -nonewline $c snarf ; flush $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{write rc* snarf} 1 {write wrote more than requested}} + +test iocmd-24.6 {chan write, bad result, zero-length write} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return 0} + set c [chan create {r w} foo] + + note [catch {puts -nonewline $c snarf ; flush $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{write rc* snarf} 1 {write wrote more than requested}} + +test iocmd-24.7 {chan write, failed write, error return} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return -code error BOOM!} + set c [chan create {r w} foo] + + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] + note $msg + close $c + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} + +test iocmd-24.8 {chan write, failed write, error return} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; error BOOM!} + set c [chan create {r w} foo] + + notes [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] + note $msg + close $c + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} + +test iocmd-24.9 {chan write, failed write, break return is error} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return -code break BOOM!} + set c [chan create {r w} foo] + + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] + note $msg + close $c + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} + +test iocmd-24.10 {chan write, failed write, continue return is error} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return -code continue BOOM!} + set c [chan create {r w} foo] + + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] + note $msg + close $c + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} + +test iocmd-24.11 {chan write, failed write, custom return is error} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return -code 777 BOOM!} + set c [chan create {r w} foo] + + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] + note $msg + close $c + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} + +test iocmd-24.12 {chan write, failed write, non-numeric return is error} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return BANG} + set c [chan create {r w} foo] + + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] + note $msg + close $c + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 {expected integer but got "BANG"}} + +test iocmd-24.13 {chan write, failed write, level is ignored} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return -level 55 -code 777 BOOM!} + set c [chan create {r w} foo] + + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg opt] + note $msg + note $opt + close $c + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 BOOM! {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BOOM!}} + +# --- === *** ########################### +# method cgetall + +test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r w} foo] + + note [fconfigure $c] + close $c + + rename foo {} + set res +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} + +test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { + set res {} + proc foo {args} {oninit cget cgetall ; onfinal ; track ; return ""} + set c [chan create {r w} foo] + + note [fconfigure $c] + close $c + + rename foo {} + set res +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} + +test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return "-bar foo -snarf x" + } + set c [chan create {r w} foo] + + note [fconfigure $c] + close $c + + rename foo {} + set res +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}} + +test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return "-bar" + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{cgetall rc*} 1 {Expected list with even number of elements, got 1 element instead}} + +test iocmd-25.5 {chan configure, cgetall, bad result, not a list} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return "\{" + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{cgetall rc*} 1 {unmatched open brace in list}} + +test iocmd-25.6 {chan configure, cgetall, error return} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code error BOOM! + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{cgetall rc*} 1 BOOM!} + +test iocmd-25.7 {chan configure, cgetall, break return is error} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code break BOOM! + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{cgetall rc*} 1 BOOM!} + +test iocmd-25.8 {chan configure, cgetall, continue return is error} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code continue BOOM! + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{cgetall rc*} 1 BOOM!} + +test iocmd-25.9 {chan configure, cgetall, custom return is error} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code 777 BOOM! + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{cgetall rc*} 1 BOOM!} + +test iocmd-25.10 {chan configure, cgetall, level is ignored} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -level 55 -code 777 BANG + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c} msg opt] ; note $msg ; note $opt + close $c + + rename foo {} + set res +} -result {{cgetall rc*} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} + +# --- === *** ########################### +# method configure + +test iocmd-26.1 {chan configure, set standard option} -match glob -body { + set res {} + proc foo {args} { + oninit configure ; onfinal ; track ; note MUST_NOT_HAPPEN + return + } + set c [chan create {r w} foo] + + note [fconfigure $c -translation lf] + close $c + + rename foo {} + set res +} -result {{}} + +test iocmd-26.2 {chan configure, set option, error return} -match glob -body { + set res {} + proc foo {args} { + oninit configure ; onfinal ; track + return -code error BOOM! + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{configure rc* -rc-foo bar} 1 BOOM!} + +test iocmd-26.3 {chan configure, set option, ok return} -match glob -body { + set res {} + proc foo {args} {oninit configure ; onfinal ; track ; return} + set c [chan create {r w} foo] + + note [fconfigure $c -rc-foo bar] + close $c + + rename foo {} + set res +} -result {{configure rc* -rc-foo bar} {}} + +test iocmd-26.4 {chan configure, set option, break return is error} -match glob -body { + set res {} + proc foo {args} { + oninit configure ; onfinal ; track + return -code break BOOM! + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{configure rc* -rc-foo bar} 1 BOOM!} + +test iocmd-26.5 {chan configure, set option, continue return is error} -match glob -body { + set res {} + proc foo {args} { + oninit configure ; onfinal ; track + return -code continue BOOM! + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{configure rc* -rc-foo bar} 1 BOOM!} + +test iocmd-26.6 {chan configure, set option, custom return is error} -match glob -body { + set res {} + proc foo {args} { + oninit configure ; onfinal ; track + return -code 444 BOOM! + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{configure rc* -rc-foo bar} 1 BOOM!} + +test iocmd-26.7 {chan configure, set option, level is ignored} -match glob -body { + set res {} + proc foo {args} { + oninit configure ; onfinal ; track + return -level 55 -code 444 BANG + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c -rc-foo bar} msg opt] ; note $msg ; note $opt + close $c + + rename foo {} + set res +} -result {{configure rc* -rc-foo bar} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} + +# --- === *** ########################### +# method cget + +test iocmd-27.1 {chan configure, get option, ok return} -match glob -body { + set res {} + proc foo {args} {oninit cget cgetall ; onfinal ; track ; return foo} + set c [chan create {r w} foo] + + note [fconfigure $c -rc-foo] + close $c + + rename foo {} + set res +} -result {{cget rc* -rc-foo} foo} + +test iocmd-27.2 {chan configure, get option, error return} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code error BOOM! + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c -rc-foo} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{cget rc* -rc-foo} 1 BOOM!} + +test iocmd-27.3 {chan configure, get option, break return is error} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code error BOOM! + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c -rc-foo} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{cget rc* -rc-foo} 1 BOOM!} + +test iocmd-27.4 {chan configure, get option, continue return is error} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code continue BOOM! + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c -rc-foo} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{cget rc* -rc-foo} 1 BOOM!} + +test iocmd-27.5 {chan configure, get option, custom return is error} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code 333 BOOM! + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c -rc-foo} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{cget rc* -rc-foo} 1 BOOM!} + +test iocmd-27.6 {chan configure, get option, level is ignored} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -level 77 -code 333 BANG + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c -rc-foo} msg opt] ; note $msg ; note $opt + close $c + + rename foo {} + set res +} -result {{cget rc* -rc-foo} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} + +# --- === *** ########################### +# method seek + +test iocmd-28.1 {chan tell, not supported by handler} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r w} foo] + + note [tell $c] + close $c + + rename foo {} + set res +} -result {-1} + +test iocmd-28.2 {chan tell, error return} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code error BOOM!} + set c [chan create {r w} foo] + + note [catch {tell $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 BOOM!} + +test iocmd-28.3 {chan tell, break return is error} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code break BOOM!} + set c [chan create {r w} foo] + + note [catch {tell $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 BOOM!} + +test iocmd-28.4 {chan tell, continue return is error} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code continue BOOM!} + set c [chan create {r w} foo] + + note [catch {tell $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 BOOM!} + +test iocmd-28.5 {chan tell, custom return is error} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code 222 BOOM!} + set c [chan create {r w} foo] + + note [catch {tell $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 BOOM!} + +test iocmd-28.6 {chan tell, level is ignored} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -level 11 -code 222 BANG} + set c [chan create {r w} foo] + + note [catch {tell $c} msg opt] ; note $msg ; note $opt + close $c + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} + +test iocmd-28.7 {chan tell, regular return} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return 88} + set c [chan create {r w} foo] + + note [tell $c] + close $c + + rename foo {} + set res +} -result {{seek rc* 0 current} 88} + +test iocmd-28.8 {chan tell, negative return} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -1} + set c [chan create {r w} foo] + + note [catch {tell $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 {Tried to seek before origin}} + +test iocmd-28.9 {chan tell, string return} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return BOGUS} + set c [chan create {r w} foo] + + note [catch {tell $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 {expected integer but got "BOGUS"}} + +test iocmd-28.10 {chan seek, not supported by handler} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r w} foo] + + note [catch {seek $c 0 start} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {1 {error during seek on "rc*": invalid argument}} + +test iocmd-28.11 {chan seek, error return} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code error BOOM!} + set c [chan create {r w} foo] + + note [catch {seek $c 0 start} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 BOOM!} + +test iocmd-28.12 {chan seek, break return is error} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code break BOOM!} + set c [chan create {r w} foo] + + note [catch {seek $c 0 start} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 BOOM!} + +test iocmd-28.13 {chan seek, continue return is error} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code continue BOOM!} + set c [chan create {r w} foo] + + note [catch {seek $c 0 start} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 BOOM!} + +test iocmd-28.14 {chan seek, custom return is error} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code 99 BOOM!} + set c [chan create {r w} foo] + + note [catch {seek $c 0 start} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 BOOM!} + +test iocmd-28.15 {chan seek, level is ignored} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -level 33 -code 99 BANG} + set c [chan create {r w} foo] + + note [catch {seek $c 0 start} msg opt] ; note $msg ; note $opt + close $c + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} + +test iocmd-28.16 {chan seek, bogus return, negative location} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -45} + set c [chan create {r w} foo] + + note [catch {seek $c 0 start} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 {Tried to seek before origin}} + +test iocmd-28.17 {chan seek, bogus return, string return} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return BOGUS} + set c [chan create {r w} foo] + + note [catch {seek $c 0 start} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 {expected integer but got "BOGUS"}} + +test iocmd-28.18 {chan seek, ok result} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return 23} + set c [chan create {r w} foo] + + note [seek $c 0 current] + close $c + + rename foo {} + set res +} -result {{seek rc* 0 current} {}} + +foreach {n code} { + 0 start + 1 current + 2 end +} { + test iocmd-28.19.$n "chan seek, base conversion, $code" -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return 0} + + set c [chan create {r w} foo] + note [seek $c 0 $code] + close $c + + rename foo {} + set res + } -result [list [list seek rc* 0 $code] {}] +} + +# --- === *** ########################### +# method blocking + +test iocmd-29.1 {chan blocking, no handler support} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r w} foo] + + note [fconfigure $c -blocking] + close $c + + rename foo {} + set res +} -result {1} + +test iocmd-29.2 {chan blocking, no handler support} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r w} foo] + + note [fconfigure $c -blocking 0] + note [fconfigure $c -blocking] + close $c + + rename foo {} + set res +} -result {{} 0} + +test iocmd-29.3 {chan blocking, retrieval, handler support} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r w} foo] + + note [fconfigure $c -blocking] + close $c + + rename foo {} + set res +} -result {1} + +test iocmd-29.4 {chan blocking, resetting, handler support} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return} + set c [chan create {r w} foo] + + note [fconfigure $c -blocking 0] + note [fconfigure $c -blocking] + close $c + + rename foo {} + set res +} -result {{blocking rc* 0} {} 0} + +test iocmd-29.5 {chan blocking, setting, handler support} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return} + set c [chan create {r w} foo] + + note [fconfigure $c -blocking 1] + note [fconfigure $c -blocking] + close $c + + rename foo {} + set res +} -result {{blocking rc* 1} {} 1} + +test iocmd-29.6 {chan blocking, error return} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; error BOOM!} + + set c [chan create {r w} foo] + + note [catch {fconfigure $c -blocking 0} msg] ; note $msg + + # Catch the close. It changes blocking mode internally, and runs into the error result. + catch {close $c} + rename foo {} + set res +} -result {{blocking rc* 0} 1 BOOM!} + +test iocmd-29.7 {chan blocking, break return is error} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return -code break BOOM!} + set c [chan create {r w} foo] + + note [catch {fconfigure $c -blocking 0} msg] ; note $msg + + catch {close $c} + rename foo {} + set res +} -result {{blocking rc* 0} 1 BOOM!} + +test iocmd-29.8 {chan blocking, continue return is error} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return -code continue BOOM!} + set c [chan create {r w} foo] + + note [catch {fconfigure $c -blocking 0} msg] ; note $msg + + catch {close $c} + rename foo {} + set res +} -result {{blocking rc* 0} 1 BOOM!} + +test iocmd-29.9 {chan blocking, custom return is error} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return -code 44 BOOM!} + set c [chan create {r w} foo] + + note [catch {fconfigure $c -blocking 0} msg] ; note $msg + + catch {close $c} + rename foo {} + set res +} -result {{blocking rc* 0} 1 BOOM!} + +test iocmd-29.10 {chan blocking, level is ignored} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return -level 99 -code 44 BANG} + set c [chan create {r w} foo] + + note [catch {fconfigure $c -blocking 0} msg opt] ; note $msg ; note $opt + + catch {close $c} + rename foo {} + set res +} -result {{blocking rc* 0} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} + +test iocmd-29.11 {chan blocking, regular return ok, value ignored} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return BOGUS} + set c [chan create {r w} foo] + + note [catch {fconfigure $c -blocking 0} msg] ; note $msg + + catch {close $c} + rename foo {} + set res +} -result {{blocking rc* 0} 0 {}} + +# --- === *** ########################### +# method watch + +test iocmd-30.1 {chan watch, read interest, some return} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return IGNORED} + set c [chan create {r w} foo] + + note [fileevent $c readable {set tick $tick}] + close $c ;# 2nd watch, interest zero. + + rename foo {} + set res +} -result {{watch rc* read} {} {watch rc* {}}} + +test iocmd-30.2 {chan watch, write interest, error return} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return -code error BOOM!_IGNORED} + set c [chan create {r w} foo] + + note [fileevent $c writable {set tick $tick}] + note [fileevent $c writable {}] + close $c + + rename foo {} + set res +} -result {{watch rc* write} {} {watch rc* {}} {}} + +test iocmd-30.3 {chan watch, accumulated interests} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return} + set c [chan create {r w} foo] + + note [fileevent $c writable {set tick $tick}] + note [fileevent $c readable {set tick $tick}] + note [fileevent $c writable {}] + note [fileevent $c readable {}] + close $c + + rename foo {} + set res +} -result {{watch rc* write} {} {watch rc* {read write}} {} {watch rc* read} {} {watch rc* {}} {}} + +test iocmd-30.4 {chan watch, unchanged interest not forwarded} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return} + set c [chan create {r w} foo] + + note [fileevent $c writable {set tick $tick}] + note [fileevent $c readable {set tick $tick}] ;# Script is changing, + note [fileevent $c readable {set tock $tock}] ;# interest does not. + + close $c ;# 3rd and 4th watch, removing the event handlers. + rename foo {} + set res +} -result {{watch rc* write} {} {watch rc* {read write}} {} {} {watch rc* write} {watch rc* {}}} + +# --- === *** ########################### +# chan postevent + +test iocmd-31.1 {chan postevent, restricted to reflected channels} -match glob -body { + set c [open [makeFile {} goo] r] + + catch {chan postevent $c {r w}} msg + + close $c + removeFile goo + set msg +} -result {channel "file*" is not a reflected channel} + +test iocmd-31.2 {chan postevent, unwanted events} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return} + set c [chan create {r w} foo] + + catch {chan postevent $c {r w}} msg ; note $msg + close $c + + rename foo {} + set res +} -result {{tried to post events channel "rc*" is not interested in}} + +test iocmd-31.3 {chan postevent, bad input, empty list} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return} + set c [chan create {r w} foo] + + catch {chan postevent $c {}} msg ; note $msg + close $c + + rename foo {} + set res +} -result {{bad event list: is empty}} + +test iocmd-31.4 {chan postevent, bad input, illlegal keyword} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return} + set c [chan create {r w} foo] + + catch {chan postevent $c goo} msg ; note $msg + close $c + + rename foo {} + set res +} -result {{bad event "goo": must be read or write}} + +test iocmd-31.5 {chan postevent, bad input, not a list} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return} + set c [chan create {r w} foo] + + catch {chan postevent $c "\{"} msg ; note $msg + close $c + + rename foo {} + set res +} -result {{unmatched open brace in list}} + +test iocmd-31.6 {chan postevent, posted events do happen} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return} + set c [chan create {r w} foo] + + note [fileevent $c readable {note TOCK}] + + set stop [after 10000 {note TIMEOUT}] + after 1000 {note [chan postevent $c r]} + vwait ::res + catch {after cancel $stop} + close $c + + rename foo {} + set res +} -result {{watch rc* read} {} TOCK {} {watch rc* {}}} + +test iocmd-31.7 {chan postevent, posted events do happen} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return} + set c [chan create {r w} foo] + + note [fileevent $c writable {note TOCK}] + + set stop [after 10000 {note TIMEOUT}] + after 1000 {note [chan postevent $c w]} + vwait ::res + catch {after cancel $stop} + close $c + + rename foo {} + set res +} -result {{watch rc* write} {} TOCK {} {watch rc* {}}} + +# ### ### ### ######### ######### ######### +## Same tests as above, but exercising the code forwarding and +## receiving driver operations to the originator thread. + +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Testing the reflected channel (Thread forwarding). +# +## The id numbers refer to the original test without thread +## forwarding, and gaps due to tests not applicable to forwarding are +## left to keep this asociation. + +testConstraint testchannel [llength [info commands testchannel]] + +# Duplicate of code in "thread.test". Find a better way of doing this +# without duplication. Maybe placement into a proc which transforms to +# nop after the first call, and placement of its defintion in a +# central location. + +testConstraint testthread [expr {[info commands testthread] != {}}] + +if {[testConstraint testthread]} { + testthread errorproc ThreadError + + proc ThreadError {id info} { + global threadError + set threadError $info + } + + proc ThreadNullError {id info} { + # ignore + } +} + +# ### ### ### ######### ######### ######### +## Helper command. Runs a script in a separate thread and returns the +## result. A channel is transfered into the thread as well, and list of +## configuation variables + +proc inthread {chan script args} { + + # Test thread. + + set tid [testthread create] + + # Init thread configuration. + # - Listed variables + # - Id of main thread + # - A number of helper commands + + foreach v $args { + upvar 1 $v x + testthread send $tid [list set $v $x] + } + testthread send $tid [list set mid $tcltest::mainThread] + testthread send $tid { + proc note {item} {global notes ; lappend notes $item} + proc notes {} {global notes ; return $notes} + } + testthread send $tid [list proc s {} [list uplevel 1 $script]] ; # (*) + + # Transfer channel (cut/splice aka detach/attach) + + testchannel cut $chan + testthread send $tid [list testchannel splice $chan] + + # Run test script, also run local event loop! + # The local event loop waits for the result to come back. + # It is also necessary for the execution of forwarded channel + # operations. + + set ::tres "" + testthread send -async $tid { + after 500 + catch {s} res ; # This runs the script, 's' was defined at (*) + testthread send -async $mid [list set ::tres $res] + } + vwait ::tres + # Remove test thread, and return the captured result. + + tcltest::threadReap + return $::tres +} + +# ### ### ### ######### ######### ######### + +# ### ### ### ######### ######### ######### + +test iocmd.tf-22.2 {chan finalize, for close} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return {}} + note [set c [chan create {r w} foo]] + + note [inthread $c { + close $c + # Close the deleted the channel. + file channels rc* + } c] + + # Channel destruction does not kill handler command! + note [info command foo] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} {} foo} + +test iocmd.tf-22.3 {chan finalize, for close, error, close error} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return -code error 5} + note [set c [chan create {r w} foo]] + + notes [inthread $c { + note [catch {close $c} msg] ; note $msg + # Channel is gone despite error. + note [file channels rc*] + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 5 {}} + +test iocmd.tf-22.4 {chan finalize, for close, error, close errror} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; error FOO} + note [set c [chan create {r w} foo]] + + notes [inthread $c { + note [catch {close $c} msg] ; note $msg + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 FOO} + +test iocmd.tf-22.5 {chan finalize, for close, arbitrary result} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return SOMETHING} + note [set c [chan create {r w} foo]] + + notes [inthread $c { + note [catch {close $c} msg]; note $msg + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 0 {}} + +test iocmd.tf-22.6 {chan finalize, for close, break, close error} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return -code 3} + note [set c [chan create {r w} foo]] + + notes [inthread $c { + note [catch {close $c} msg] ; note $msg + notes + } c] + + rename foo {} + set res +} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 {}} \ + -constraints {testchannel testthread} + +test iocmd.tf-22.7 {chan finalize, for close, continue, close error} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return -code 4} + note [set c [chan create {r w} foo]] + + notes [inthread $c { + note [catch {close $c} msg] ; note $msg + notes + } c] + + rename foo {} + set res +} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 {}} \ + -constraints {testchannel testthread} + +test iocmd.tf-22.8 {chan finalize, for close, custom code, close error} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return -code 777 BANG} + note [set c [chan create {r w} foo]] + + notes [inthread $c { + note [catch {close $c} msg] ; note $msg + notes + } c] + + rename foo {} + set res +} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 BANG} \ + -constraints {testchannel testthread} + +test iocmd.tf-22.9 {chan finalize, for close, ignore level, close error} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return -level 5 -code 777 BANG} + note [set c [chan create {r w} foo]] + + notes [inthread $c { + note [catch {close $c} msg opt] ; note $msg ; note $opt + notes + } c] + + rename foo {} + set res +} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \ + -constraints {testchannel testthread} + +# --- === *** ########################### +# method read + +test iocmd.tf-23.1 {chan read, regular data return} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return snarf + } + set c [chan create {r w} foo] + notes [inthread $c { + note [read $c 10] + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{read rc* 4096} {read rc* 4096} snarfsnarf} + +test iocmd.tf-23.2 {chan read, bad data return, to much} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return [string repeat snarf 1000] + } + set c [chan create {r w} foo] + notes [inthread $c { + note [catch {[read $c 2]} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{read rc* 4096} 1 {read delivered more than requested}} + +test iocmd.tf-23.3 {chan read, for non-readable channel} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + note MUST_NOT_HAPPEN + } + set c [chan create {w} foo] + notes [inthread $c { + note [catch {[read $c 2]} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {1 {channel "rc*" wasn't opened for reading}} + +test iocmd.tf-23.4 {chan read, error return} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return -code error BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {read $c 2} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{read rc* 4096} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-23.5 {chan read, break return is error} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return -code break BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {read $c 2} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{read rc* 4096} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-23.6 {chan read, continue return is error} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return -code continue BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {read $c 2} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{read rc* 4096} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-23.7 {chan read, custom return is error} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return -code 777 BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {read $c 2} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{read rc* 4096} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-23.8 {chan read, level is squashed} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return -level 55 -code 777 BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {read $c 2} msg opt] ; note $msg ; note $opt + close $c + notes + } c] + + rename foo {} + set res +} -result {{read rc* 4096} 1 BOOM! {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BOOM!}} \ + -constraints {testchannel testthread} + +# --- === *** ########################### +# method write + +test iocmd.tf-24.1 {chan write, regular write} -match glob -body { + set res {} + proc foo {args} { + oninit; onfinal ; track + set written [string length [lindex $args 2]] + note $written + return $written + } + set c [chan create {r w} foo] + + inthread $c { + puts -nonewline $c snarf ; flush $c + close $c + } c + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{write rc* snarf} 5} + +test iocmd.tf-24.2 {chan write, ack partial writes} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + set written [string length [lindex $args 2]] + if {$written > 10} {set written [expr {$written / 2}]} + note $written + return $written + } + set c [chan create {r w} foo] + + inthread $c { + puts -nonewline $c snarfsnarfsnarf ; flush $c + close $c + } c + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{write rc* snarfsnarfsnarf} 7 {write rc* arfsnarf} 8} + +test iocmd.tf-24.3 {chan write, failed write} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note -1 ; return -1} + set c [chan create {r w} foo] + + inthread $c { + puts -nonewline $c snarfsnarfsnarf ; flush $c + close $c + } c + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{write rc* snarfsnarfsnarf} -1} + +test iocmd.tf-24.4 {chan write, non-writable channel} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r} foo] + + notes [inthread $c { + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {1 {channel "rc*" wasn't opened for writing}} + +test iocmd.tf-24.5 {chan write, bad result, more written than data} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return 10000} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {puts -nonewline $c snarf ; flush $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{write rc* snarf} 1 {write wrote more than requested}} + +test iocmd.tf-24.6 {chan write, zero writes} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return 0} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {puts -nonewline $c snarf ; flush $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{write rc* snarf} 1 {write wrote more than requested}} + +test iocmd.tf-24.7 {chan write, failed write, error return} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return -code error BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] + note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-24.8 {chan write, failed write, error return} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; error BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] + note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-24.9 {chan write, failed write, break return is error} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return -code break BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] + note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-24.10 {chan write, failed write, continue return is error} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return -code continue BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] + note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-24.11 {chan write, failed write, custom return is error} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return -code 777 BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] + note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-24.12 {chan write, failed write, non-numeric return is error} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return BANG} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] + note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 {expected integer but got "BANG"}} \ + -constraints {testchannel testthread} + +test iocmd.tf-24.13 {chan write, failed write, level is ignored} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return -level 55 -code 777 BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg opt] + note $msg + note $opt + close $c + notes + } c] + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 BOOM! {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BOOM!}} \ + -constraints {testchannel testthread} + +# --- === *** ########################### +# method cgetall + +test iocmd.tf-25.1 {chan configure, cgetall, standard options} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r w} foo] + + notes [inthread $c { + note [fconfigure $c] + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} \ + -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} + +test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body { + set res {} + proc foo {args} {oninit cget cgetall ; onfinal ; track ; return ""} + set c [chan create {r w} foo] + + notes [inthread $c { + note [fconfigure $c] + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} \ + -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} + +test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return "-bar foo -snarf x" + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [fconfigure $c] + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} \ + -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}} + +test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return "-bar" + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{cgetall rc*} 1 {Expected list with even number of elements, got 1 element instead}} + +test iocmd.tf-25.5 {chan configure, cgetall, bad result, not a list} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return "\{" + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{cgetall rc*} 1 {unmatched open brace in list}} + +test iocmd.tf-25.6 {chan configure, cgetall, error return} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code error BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{cgetall rc*} 1 BOOM!} + +test iocmd.tf-25.7 {chan configure, cgetall, break return is error} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code break BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{cgetall rc*} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-25.8 {chan configure, cgetall, continue return is error} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code continue BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{cgetall rc*} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-25.9 {chan configure, cgetall, custom return is error} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code 777 BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{cgetall rc*} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-25.10 {chan configure, cgetall, level is ignored} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -level 55 -code 777 BANG + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c} msg opt] ; note $msg ; note $opt + close $c + notes + } c] + + rename foo {} + set res +} -result {{cgetall rc*} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \ + -constraints {testchannel testthread} + +# --- === *** ########################### +# method configure + +test iocmd.tf-26.1 {chan configure, set standard option} -match glob -body { + set res {} + proc foo {args} { + oninit configure ; onfinal ; track ; note MUST_NOT_HAPPEN + return + } + + set c [chan create {r w} foo] + notes [inthread $c { + note [fconfigure $c -translation lf] + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{}} + +test iocmd.tf-26.2 {chan configure, set option, error return} -match glob -body { + set res {} + proc foo {args} { + oninit configure ; onfinal ; track + return -code error BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{configure rc* -rc-foo bar} 1 BOOM!} + +test iocmd.tf-26.3 {chan configure, set option, ok return} -match glob -body { + set res {} + proc foo {args} {oninit configure ; onfinal ; track ; return} + set c [chan create {r w} foo] + + notes [inthread $c { + note [fconfigure $c -rc-foo bar] + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{configure rc* -rc-foo bar} {}} + +test iocmd.tf-26.4 {chan configure, set option, break return is error} -match glob -body { + set res {} + proc foo {args} { + oninit configure ; onfinal ; track + return -code break BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{configure rc* -rc-foo bar} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-26.5 {chan configure, set option, continue return is error} -match glob -body { + set res {} + proc foo {args} { + oninit configure ; onfinal ; track + return -code continue BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{configure rc* -rc-foo bar} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-26.6 {chan configure, set option, custom return is error} -match glob -body { + set res {} + proc foo {args} { + oninit configure ; onfinal ; track + return -code 444 BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{configure rc* -rc-foo bar} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-26.7 {chan configure, set option, level is ignored} -match glob -body { + set res {} + proc foo {args} { + oninit configure ; onfinal ; track + return -level 55 -code 444 BANG + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -rc-foo bar} msg opt] ; note $msg ; note $opt + close $c + notes + } c] + + rename foo {} + set res +} -result {{configure rc* -rc-foo bar} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \ + -constraints {testchannel testthread} + +# --- === *** ########################### +# method cget + +test iocmd.tf-27.1 {chan configure, get option, ok return} -match glob -body { + set res {} + proc foo {args} {oninit cget cgetall ; onfinal ; track ; return foo} + set c [chan create {r w} foo] + + notes [inthread $c { + note [fconfigure $c -rc-foo] + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{cget rc* -rc-foo} foo} + +test iocmd.tf-27.2 {chan configure, get option, error return} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code error BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -rc-foo} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{cget rc* -rc-foo} 1 BOOM!} + +test iocmd.tf-27.3 {chan configure, get option, break return is error} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code error BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -rc-foo} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{cget rc* -rc-foo} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-27.4 {chan configure, get option, continue return is error} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code continue BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -rc-foo} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{cget rc* -rc-foo} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-27.5 {chan configure, get option, custom return is error} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code 333 BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -rc-foo} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{cget rc* -rc-foo} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-27.6 {chan configure, get option, level is ignored} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -level 77 -code 333 BANG + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -rc-foo} msg opt] ; note $msg ; note $opt + close $c + notes + } c] + + rename foo {} + set res +} -result {{cget rc* -rc-foo} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \ + -constraints {testchannel testthread} + +# --- === *** ########################### +# method seek + +test iocmd.tf-28.1 {chan tell, not supported by handler} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r w} foo] + + notes [inthread $c { + note [tell $c] + close $c + notes + } c] + + rename foo {} + set res +} -result {-1} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.2 {chan tell, error return} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code error BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {tell $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.3 {chan tell, break return is error} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code break BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {tell $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.4 {chan tell, continue return is error} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code continue BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {tell $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.5 {chan tell, custom return is error} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code 222 BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {tell $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.6 {chan tell, level is ignored} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -level 11 -code 222 BANG} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {tell $c} msg opt] ; note $msg ; note $opt + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.7 {chan tell, regular return} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return 88} + set c [chan create {r w} foo] + + notes [inthread $c { + note [tell $c] + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 current} 88} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.8 {chan tell, negative return} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -1} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {tell $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 {Tried to seek before origin}} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.9 {chan tell, string return} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return BOGUS} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {tell $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 {expected integer but got "BOGUS"}} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.10 {chan seek, not supported by handler} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {seek $c 0 start} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {1 {error during seek on "rc*": invalid argument}} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.11 {chan seek, error return} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code error BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {seek $c 0 start} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.12 {chan seek, break return is error} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code break BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {seek $c 0 start} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.13 {chan seek, continue return is error} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code continue BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {seek $c 0 start} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.14 {chan seek, custom return is error} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code 99 BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {seek $c 0 start} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.15 {chan seek, level is ignored} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -level 33 -code 99 BANG} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {seek $c 0 start} msg opt] ; note $msg ; note $opt + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.16 {chan seek, bogus return, negative location} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -45} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {seek $c 0 start} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 {Tried to seek before origin}} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.17 {chan seek, bogus return, string return} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return BOGUS} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {seek $c 0 start} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 {expected integer but got "BOGUS"}} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.18 {chan seek, ok result} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return 23} + set c [chan create {r w} foo] + + notes [inthread $c { + note [seek $c 0 current] + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 current} {}} \ + -constraints {testchannel testthread} + +foreach {n code} { + 0 start + 1 current + 2 end +} { + test iocmd.tf-28.19.$n "chan seek, base conversion, $code" -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return 0} + set c [chan create {r w} foo] + + notes [inthread $c { + note [seek $c 0 $code] + close $c + notes + } c code] + + rename foo {} + set res + } -result [list [list seek rc* 0 $code] {}] \ + -constraints {testchannel testthread} +} + +# --- === *** ########################### +# method blocking + +test iocmd.tf-29.1 {chan blocking, no handler support} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r w} foo] + + notes [inthread $c { + note [fconfigure $c -blocking] + close $c + notes + } c] + + rename foo {} + set res +} -result {1} \ + -constraints {testchannel testthread} + +test iocmd.tf-29.2 {chan blocking, no handler support} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r w} foo] + + notes [inthread $c { + note [fconfigure $c -blocking 0] + note [fconfigure $c -blocking] + close $c + notes + } c] + + rename foo {} + set res +} -result {{} 0} \ + -constraints {testchannel testthread} + +test iocmd.tf-29.3 {chan blocking, retrieval, handler support} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r w} foo] + + notes [inthread $c { + note [fconfigure $c -blocking] + close $c + notes + } c] + + rename foo {} + set res +} -result {1} \ + -constraints {testchannel testthread} + +test iocmd.tf-29.4 {chan blocking, resetting, handler support} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return} + set c [chan create {r w} foo] + + notes [inthread $c { + note [fconfigure $c -blocking 0] + note [fconfigure $c -blocking] + close $c + notes + } c] + + rename foo {} + set res +} -result {{blocking rc* 0} {} 0} \ + -constraints {testchannel testthread} + +test iocmd.tf-29.5 {chan blocking, setting, handler support} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return} + set c [chan create {r w} foo] + + notes [inthread $c { + note [fconfigure $c -blocking 1] + note [fconfigure $c -blocking] + close $c + notes + } c] + + rename foo {} + set res +} -result {{blocking rc* 1} {} 1} \ + -constraints {testchannel testthread} + +test iocmd.tf-29.6 {chan blocking, error return} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; error BOOM!} + + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -blocking 0} msg] ; note $msg + # Catch the close. It changes blocking mode internally, and runs into the error result. + catch {close $c} + notes + } c] + + rename foo {} + set res +} -result {{blocking rc* 0} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-29.7 {chan blocking, break return is error} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return -code break BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -blocking 0} msg] ; note $msg + catch {close $c} + notes + } c] + + rename foo {} + set res +} -result {{blocking rc* 0} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-29.8 {chan blocking, continue return is error} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return -code continue BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -blocking 0} msg] ; note $msg + catch {close $c} + notes + } c] + + rename foo {} + set res +} -result {{blocking rc* 0} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-29.9 {chan blocking, custom return is error} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return -code 44 BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -blocking 0} msg] ; note $msg + catch {close $c} + notes + } c] + + rename foo {} + set res +} -result {{blocking rc* 0} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-29.10 {chan blocking, level is ignored} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return -level 99 -code 44 BANG} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -blocking 0} msg opt] ; note $msg ; note $opt + catch {close $c} + notes + } c] + + rename foo {} + set res +} -result {{blocking rc* 0} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \ + -constraints {testchannel testthread} + +test iocmd.tf-29.11 {chan blocking, regular return ok, value ignored} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return BOGUS} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -blocking 0} msg] ; note $msg + catch {close $c} + notes + } c] + + rename foo {} + set res +} -result {{blocking rc* 0} 0 {}} \ + -constraints {testchannel testthread} + +# --- === *** ########################### +# method watch + +test iocmd.tf-30.1 {chan watch, read interest, some return} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return IGNORED} + set c [chan create {r w} foo] + + notes [inthread $c { + note [fileevent $c readable {set tick $tick}] + close $c ;# 2nd watch, interest zero. + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{watch rc* read} {watch rc* {}} {}} + +test iocmd.tf-30.2 {chan watch, write interest, error return} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return -code error BOOM!_IGNORED} + set c [chan create {r w} foo] + + notes [inthread $c { + note [fileevent $c writable {set tick $tick}] + note [fileevent $c writable {}] + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{watch rc* write} {watch rc* {}} {} {}} + +test iocmd.tf-30.3 {chan watch, accumulated interests} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return} + set c [chan create {r w} foo] + + notes [inthread $c { + note [fileevent $c writable {set tick $tick}] + note [fileevent $c readable {set tick $tick}] + note [fileevent $c writable {}] + note [fileevent $c readable {}] + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} \ + -result {{watch rc* write} {watch rc* {read write}} {watch rc* read} {watch rc* {}} {} {} {} {}} + +test iocmd.tf-30.4 {chan watch, unchanged interest not forwarded} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return} + set c [chan create {r w} foo] + + notes [inthread $c { + note [fileevent $c writable {set tick $tick}] + note [fileevent $c readable {set tick $tick}] ;# Script is changing, + note [fileevent $c readable {set tock $tock}] ;# interest does not. + close $c ;# 3rd and 4th watch, removing the event handlers. + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} \ + -result {{watch rc* write} {watch rc* {read write}} {watch rc* write} {watch rc* {}} {} {} {}} + +# --- === *** ########################### +# postevent +# Not possible from a thread not containing the command handler. +# Check that this is rejected. + +test iocmd.tf-31.8 {chan postevent, bad input} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return} + set c [chan create {r w} foo] + + notes [inthread $c { + catch {chan postevent $c r} msg ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} \ + -result {{postevent for channel "rc*" called from outside interpreter}} + + +# ### ### ### ######### ######### ######### + +# ### ### ### ######### ######### ######### + +rename track {} # cleanup foreach file [list test1 test2 test3 test4] { removeFile $file } # delay long enough for background processes to finish Index: tests/iogt.test ================================================================== --- tests/iogt.test +++ tests/iogt.test @@ -8,11 +8,11 @@ # # Copyright (c) 2000 Ajuba Solutions. # Copyright (c) 2000 Andreas Kupries. # All rights reserved. # -# RCS: @(#) $Id: iogt.test,v 1.11 2004/06/23 15:36:57 dkf Exp $ +# RCS: @(#) $Id: iogt.test,v 1.11.2.1 2005/04/25 21:37:29 kennykb Exp $ if {[catch {package require tcltest 2.1}]} { puts stderr "Skipping tests in [info script]. tcltest 2.1 required." return } @@ -496,11 +496,11 @@ set ain [list] ; set aout [list] audit_ops ain -attach $fin audit_ops aout -attach $fout fconfigure $fin -buffersize 10 - fconfigure $fout -buffersize 5 + fconfigure $fout -buffersize 10 fcopy $fin $fout close $fin close $fout @@ -546,11 +546,11 @@ set ain [list] ; set aout [list] audit_flow ain -attach $fin audit_flow aout -attach $fout fconfigure $fin -buffersize 10 - fconfigure $fout -buffersize 5 + fconfigure $fout -buffersize 10 fcopy $fin $fout close $fin close $fout Index: tests/lindex.test ================================================================== --- tests/lindex.test +++ tests/lindex.test @@ -10,11 +10,11 @@ # Copyright (c) 2001 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: lindex.test,v 1.11 2003/11/14 20:44:46 dgp Exp $ +# RCS: @(#) $Id: lindex.test,v 1.11.2.1 2005/05/05 17:56:17 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } @@ -47,11 +47,11 @@ } {f f} test lindex-2.4 {malformed index list} testevalex { set x \{ list [catch { testevalex {lindex {a b c} $x} } result] $result -} {1 bad\ index\ \"\{\":\ must\ be\ integer\ or\ end?-integer?} +} {1 bad\ index\ \"\{\":\ must\ be\ integer?\[+-\]integer?\ or\ end?\[+-\]integer?} # Indices that are integers or convertible to integers test lindex-3.1 {integer -1} testevalex { set x ${minus}1 @@ -74,16 +74,16 @@ } {{} {}} test lindex-3.5 {bad octal} testevalex { set x 08 list [catch { testevalex {lindex {a b c} $x} } result] $result -} "1 {bad index \"08\": must be integer or end?-integer? (looks like invalid octal number)}" +} {1 {bad index "08": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}} test lindex-3.6 {bad octal} testevalex { set x -09 list [catch { testevalex {lindex {a b c} $x} } result] $result -} "1 {bad index \"-09\": must be integer or end?-integer? (looks like invalid octal number)}" +} {1 {bad index "-09": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}} test lindex-3.7 {indexes don't shimmer wide ints} { set x [expr {(wide(1)<<31) - 2}] list $x [lindex {1 2 3} $x] [incr x] [incr x] } {2147483646 {} 2147483647 2147483648} @@ -116,35 +116,35 @@ } {{} {}} test lindex-4.6 {bad octal} testevalex { set x end-08 list [catch { testevalex {lindex {a b c} $x} } result] $result -} "1 {bad index \"end-08\": must be integer or end?-integer? (looks like invalid octal number)}" +} {1 {bad index "end-08": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}} test lindex-4.7 {bad octal} testevalex { set x end--09 list [catch { testevalex {lindex {a b c} $x} } result] $result -} "1 {bad index \"end--09\": must be integer or end?-integer?}" +} {1 {bad index "end--09": must be integer?[+-]integer? or end?[+-]integer?}} test lindex-4.8 {bad integer, not octal} testevalex { set x end-0a2 list [catch { testevalex {lindex {a b c} $x} } result] $result -} "1 {bad index \"end-0a2\": must be integer or end?-integer?}" +} {1 {bad index "end-0a2": must be integer?[+-]integer? or end?[+-]integer?}} -test lindex-4.9 {incomplete end} testevalex { - set x en +test lindex-4.9 {obsolete test} testevalex { + set x end list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] } {c c} test lindex-4.10 {incomplete end-} testevalex { set x end- list [catch { testevalex {lindex {a b c} $x} } result] $result -} "1 {bad index \"end-\": must be integer or end?-integer?}" +} {1 {bad index "end-": must be integer?[+-]integer? or end?[+-]integer?}} test lindex-5.1 {bad second index} testevalex { list [catch { testevalex {lindex {a b c} 0 0a2} } result] $result -} "1 {bad index \"0a2\": must be integer or end?-integer?}" +} {1 {bad index "0a2": must be integer?[+-]integer? or end?[+-]integer?}} test lindex-5.2 {good second index} testevalex { testevalex {lindex {{a b c} {d e f} {g h i}} 1 2} } f @@ -243,11 +243,11 @@ } {f f} test lindex-10.4 {malformed index list} { set x \{ list [catch { lindex {a b c} $x } result] $result -} {1 bad\ index\ \"\{\":\ must\ be\ integer\ or\ end?-integer?} +} {1 bad\ index\ \"\{\":\ must\ be\ integer?\[+-\]integer?\ or\ end?\[+-\]integer?} # Indices that are integers or convertible to integers test lindex-11.1 {integer -1} { set x ${minus}1 @@ -282,16 +282,16 @@ } {{} {}} test lindex-11.5 {bad octal} { set x 08 list [catch { lindex {a b c} $x } result] $result -} "1 {bad index \"08\": must be integer or end?-integer? (looks like invalid octal number)}" +} {1 {bad index "08": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}} test lindex-11.6 {bad octal} { set x -09 list [catch { lindex {a b c} $x } result] $result -} "1 {bad index \"-09\": must be integer or end?-integer? (looks like invalid octal number)}" +} {1 {bad index "-09": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}} # Indices relative to end test lindex-12.1 {index = end} { set x end @@ -334,38 +334,38 @@ } {{} {}} test lindex-12.6 {bad octal} { set x end-08 list [catch { lindex {a b c} $x } result] $result -} "1 {bad index \"end-08\": must be integer or end?-integer? (looks like invalid octal number)}" +} {1 {bad index "end-08": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}} test lindex-12.7 {bad octal} { set x end--09 list [catch { lindex {a b c} $x } result] $result -} "1 {bad index \"end--09\": must be integer or end?-integer?}" +} {1 {bad index "end--09": must be integer?[+-]integer? or end?[+-]integer?}} test lindex-12.8 {bad integer, not octal} { set x end-0a2 list [catch { lindex {a b c} $x } result] $result -} "1 {bad index \"end-0a2\": must be integer or end?-integer?}" +} {1 {bad index "end-0a2": must be integer?[+-]integer? or end?[+-]integer?}} -test lindex-12.9 {incomplete end} { - set x en +test lindex-12.9 {obsolete test} { + set x end catch { list [lindex {a b c} $x] [lindex {a b c} $x] } result set result } {c c} test lindex-12.10 {incomplete end-} { set x end- list [catch { lindex {a b c} $x } result] $result -} "1 {bad index \"end-\": must be integer or end?-integer?}" +} {1 {bad index "end-": must be integer?[+-]integer? or end?[+-]integer?}} test lindex-13.1 {bad second index} { list [catch { lindex {a b c} 0 0a2 } result] $result -} "1 {bad index \"0a2\": must be integer or end?-integer?}" +} {1 {bad index "0a2": must be integer?[+-]integer? or end?[+-]integer?}} test lindex-13.2 {good second index} { catch { lindex {{a b c} {d e f} {g h i}} 1 2 } result Index: tests/link.test ================================================================== --- tests/link.test +++ tests/link.test @@ -9,11 +9,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: link.test,v 1.7 2002/06/22 04:19:47 dgp Exp $ +# RCS: @(#) $Id: link.test,v 1.7.6.1 2005/09/09 18:48:40 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -24,239 +24,259 @@ foreach i {int real bool string} { catch {unset $i} } test link-1.1 {reading C variables from Tcl} {testlink} { testlink delete - testlink set 43 1.23 4 - 12341234 - testlink create 1 1 1 1 1 + testlink set 43 1.23 4 - 12341234 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 + testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 list $int $real $bool $string $wide } {43 1.23 1 NULL 12341234} test link-1.2 {reading C variables from Tcl} {testlink} { testlink delete - testlink create 1 1 1 1 1 - testlink set -3 2 0 "A long string with spaces" 43214321 + testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + testlink set -3 2 0 "A long string with spaces" 43214321 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 list $int $real $bool $string $wide $int $real $bool $string $wide } {-3 2.0 0 {A long string with spaces} 43214321 -3 2.0 0 {A long string with spaces} 43214321} test link-2.1 {writing C variables from Tcl} {testlink} { testlink delete - testlink set 43 1.21 4 - 56785678 - testlink create 1 1 1 1 1 + testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234 + testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 set int "00721" set real -10.5 set bool true set string abcdef set wide 135135 - concat [testlink get] $int $real $bool $string $wide -} {465 -10.5 1 abcdef 135135 00721 -10.5 true abcdef 135135} + set char 79 + set uchar 161 + set short 8000 + set ushort 40000 + set uint 0xc001babe + set long 34543 + set ulong 567890 + set float 1.0987654321 + set uwide 357357357357 + concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide +} {465 -10.5 1 abcdef 135135 79 161 8000 40000 -1073628482 34543 567890 1.0987653732299805 357357357357 | 00721 -10.5 true abcdef 135135 79 161 8000 40000 0xc001babe 34543 567890 1.0987654321 357357357357} test link-2.2 {writing bad values into variables} {testlink} { testlink delete - testlink set 43 1.23 4 - 56785678 - testlink create 1 1 1 1 1 + testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 + testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 list [catch {set int 09a} msg] $msg $int } {1 {can't set "int": variable must have integer value} 43} test link-2.3 {writing bad values into variables} {testlink} { testlink delete - testlink set 43 1.23 4 - 56785678 - testlink create 1 1 1 1 1 + testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 + testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 list [catch {set real 1.x3} msg] $msg $real } {1 {can't set "real": variable must have real value} 1.23} test link-2.4 {writing bad values into variables} {testlink} { testlink delete - testlink set 43 1.23 4 - 56785678 - testlink create 1 1 1 1 1 + testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 + testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 list [catch {set bool gorp} msg] $msg $bool } {1 {can't set "bool": variable must have boolean value} 1} test link-2.5 {writing bad values into variables} {testlink} { testlink delete - testlink set 43 1.23 4 - 56785678 - testlink create 1 1 1 1 1 + testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 + testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 list [catch {set wide gorp} msg] $msg $bool } {1 {can't set "wide": variable must have integer value} 1} test link-3.1 {read-only variables} {testlink} { testlink delete - testlink set 43 1.23 4 - 56785678 - testlink create 0 1 1 0 0 + testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 + testlink create 0 1 1 0 0 0 0 0 0 0 0 0 0 0 list [catch {set int 4} msg] $msg $int \ [catch {set real 10.6} msg] $msg $real \ [catch {set bool no} msg] $msg $bool \ [catch {set string "new value"} msg] $msg $string \ [catch {set wide 12341234} msg] $msg $wide } {1 {can't set "int": linked variable is read-only} 43 0 10.6 10.6 0 no no 1 {can't set "string": linked variable is read-only} NULL 1 {can't set "wide": linked variable is read-only} 56785678} test link-3.2 {read-only variables} {testlink} { testlink delete - testlink set 43 1.23 4 - 56785678 - testlink create 1 0 0 1 1 + testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 + testlink create 1 0 0 1 1 0 0 0 0 0 0 0 0 0 list [catch {set int 4} msg] $msg $int \ [catch {set real 10.6} msg] $msg $real \ [catch {set bool no} msg] $msg $bool \ [catch {set string "new value"} msg] $msg $string\ [catch {set wide 12341234} msg] $msg $wide } {0 4 4 1 {can't set "real": linked variable is read-only} 1.23 1 {can't set "bool": linked variable is read-only} 1 0 {new value} {new value} 0 12341234 12341234} test link-4.1 {unsetting linked variables} {testlink} { testlink delete - testlink set -6 -2.5 0 stringValue 13579 - testlink create 1 1 1 1 1 + testlink set -6 -2.5 0 stringValue 13579 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 + testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 unset int real bool string wide list [catch {set int} msg] $msg [catch {set real} msg] $msg \ [catch {set bool} msg] $msg [catch {set string} msg] $msg \ [catch {set wide} msg] $msg } {0 -6 0 -2.5 0 0 0 stringValue 0 13579} test link-4.2 {unsetting linked variables} {testlink} { testlink delete - testlink set -6 -2.1 0 stringValue 97531 - testlink create 1 1 1 1 1 + testlink set -6 -2.1 0 stringValue 97531 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 + testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 unset int real bool string wide set int 102 set real 16 set bool true set string newValue set wide 333555 - testlink get + lrange [testlink get] 0 4 } {102 16.0 1 newValue 333555} test link-5.1 {unlinking variables} {testlink} { testlink delete - testlink set -6 -2.25 0 stringValue 13579 + testlink set -6 -2.25 0 stringValue 13579 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 testlink delete set int xx1 set real qrst set bool bogus set string 12345 set wide 875421 + set char skjdf + set uchar dslfjk + set short slkf + set ushort skrh + set uint sfdkfkh + set long srkjh + set ulong sjkg + set float dskjfbjfd + set uwide isdfsngs testlink get -} {-6 -2.25 0 stringValue 13579} +} {-6 -2.25 0 stringValue 13579 64 250 30000 60000 -1091585346 12321 32123 3.25 1231231234} test link-5.2 {unlinking variables} {testlink} { testlink delete - testlink set -6 -2.25 0 stringValue 97531 - testlink create 1 1 1 1 1 + testlink set -6 -2.25 0 stringValue 97531 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 + testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 testlink delete - testlink set 25 14.7 7 - 999999 - list $int $real $bool $string $wide -} {-6 -2.25 0 stringValue 97531} + testlink set 25 14.7 7 - 999999 65 251 30001 60001 0xbabebeef 12322 32124 3.125 12312312340 + list $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide +} {-6 -2.25 0 stringValue 97531 64 250 30000 60000 3203381950 12321 32123 3.25 1231231234} test link-6.1 {errors in setting up link} {testlink} { testlink delete catch {unset int} set int(44) 1 - list [catch {testlink create 1 1 1 1 1} msg] $msg + list [catch {testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1} msg] $msg } {1 {can't set "int": variable is array}} catch {unset int} test link-7.1 {access to linked variables via upvar} {testlink} { proc x {} { upvar int y unset y } testlink delete - testlink create 1 0 0 0 0 - testlink set 14 {} {} {} {} + testlink create 1 0 0 0 0 0 0 0 0 0 0 0 0 0 + testlink set 14 {} {} {} {} {} {} {} {} {} {} {} {} {} x list [catch {set int} msg] $msg } {0 14} test link-7.2 {access to linked variables via upvar} {testlink} { proc x {} { upvar int y return [set y] } testlink delete - testlink create 1 0 0 0 0 - testlink set 0 {} {} {} {} + testlink create 1 0 0 0 0 0 0 0 0 0 0 0 0 0 + testlink set 0 {} {} {} {} {} {} {} {} {} {} {} {} {} set int - testlink set 23 {} {} {} {} + testlink set 23 {} {} {} {} {} {} {} {} {} {} {} {} {} x list [x] $int } {23 23} test link-7.3 {access to linked variables via upvar} {testlink} { proc x {} { upvar int y set y 44 } testlink delete - testlink create 0 0 0 0 0 - testlink set 11 {} {} {} {} + testlink create 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + testlink set 11 {} {} {} {} {} {} {} {} {} {} {} {} {} list [catch x msg] $msg $int } {1 {can't set "y": linked variable is read-only} 11} test link-7.4 {access to linked variables via upvar} {testlink} { proc x {} { upvar int y set y abc } testlink delete - testlink create 1 1 1 1 1 - testlink set -4 {} {} {} {} + testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + testlink set -4 {} {} {} {} {} {} {} {} {} {} {} {} {} list [catch x msg] $msg $int } {1 {can't set "y": variable must have integer value} -4} test link-7.5 {access to linked variables via upvar} {testlink} { proc x {} { upvar real y set y abc } testlink delete - testlink create 1 1 1 1 1 - testlink set -4 16.75 {} {} {} + testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + testlink set -4 16.75 {} {} {} {} {} {} {} {} {} {} {} {} list [catch x msg] $msg $real } {1 {can't set "y": variable must have real value} 16.75} test link-7.6 {access to linked variables via upvar} {testlink} { proc x {} { upvar bool y set y abc } testlink delete - testlink create 1 1 1 1 1 - testlink set -4 16.3 1 {} {} + testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + testlink set -4 16.3 1 {} {} {} {} {} {} {} {} {} {} {} list [catch x msg] $msg $bool } {1 {can't set "y": variable must have boolean value} 1} test link-7.7 {access to linked variables via upvar} {testlink} { proc x {} { upvar wide y set y abc } testlink delete - testlink create 1 1 1 1 1 - testlink set -4 16.3 1 {} 778899 + testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + testlink set -4 16.3 1 {} 778899 {} {} {} {} {} {} {} {} {} list [catch x msg] $msg $wide } {1 {can't set "y": variable must have integer value} 778899} test link-8.1 {Tcl_UpdateLinkedVar procedure} {testlink} { proc x args { global x int real bool string wide lappend x $args $int $real $bool $string $wide } set x {} - testlink create 1 1 1 1 1 - testlink set 14 -2.0 0 xyzzy 995511 + testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + testlink set 14 -2.0 0 xyzzy 995511 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 trace var int w x - testlink update 32 4.0 3 abcd 113355 + testlink update 32 4.0 3 abcd 113355 65 251 30001 60001 0xbabebeef 12322 32124 3.125 12312312340 trace vdelete int w x set x } {{int {} w} 32 -2.0 0 xyzzy 995511} test link-8.2 {Tcl_UpdateLinkedVar procedure} {testlink} { proc x args { global x int real bool string wide lappend x $args $int $real $bool $string $wide } set x {} - testlink create 1 1 1 1 1 - testlink set 14 -2.0 0 xyzzy 995511 + testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + testlink set 14 -2.0 0 xyzzy 995511 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 testlink delete trace var int w x - testlink update 32 4.0 6 abcd 113355 + testlink update 32 4.0 6 abcd 113355 65 251 30001 60001 0xbabebeef 12322 32124 3.125 12312312340 trace vdelete int w x set x } {} test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} { - testlink create 0 0 0 0 0 - list [catch {testlink update 47 {} {} {} {}} msg] $msg $int + testlink create 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + list [catch { + testlink update 47 {} {} {} {} {} {} {} {} {} {} {} {} {} + } msg] $msg $int } {0 {} 47} -catch {testlink set 0 0 0 - 0} +catch {testlink set 0 0 0 - 0 0 0 0 0 0 0 0 0 0} catch {testlink delete} foreach i {int real bool string wide} { catch {unset $i} } # cleanup ::tcltest::cleanupTests return Index: tests/linsert.test ================================================================== --- tests/linsert.test +++ tests/linsert.test @@ -9,11 +9,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: linsert.test,v 1.8 2000/04/10 17:19:01 ericm Exp $ +# RCS: @(#) $Id: linsert.test,v 1.8.28.1 2005/05/05 17:56:18 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } @@ -88,11 +88,11 @@ test linsert-2.2 {linsert errors} { list [catch {linsert a b} msg] $msg } {1 {wrong # args: should be "linsert list index element ?element ...?"}} test linsert-2.3 {linsert errors} { list [catch {linsert a 12x 2} msg] $msg -} {1 {bad index "12x": must be integer or end?-integer?}} +} {1 {bad index "12x": must be integer?[+-]integer? or end?[+-]integer?}} test linsert-2.4 {linsert errors} { list [catch {linsert \{ 12 2} msg] $msg } {1 {unmatched open brace in list}} test linsert-3.1 {linsert won't modify shared argument objects} { Index: tests/listObj.test ================================================================== --- tests/listObj.test +++ tests/listObj.test @@ -9,25 +9,22 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: listObj.test,v 1.6 2004/05/19 12:15:04 dkf Exp $ +# RCS: @(#) $Id: listObj.test,v 1.6.2.2 2005/08/02 18:16:41 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } -testConstraint testobj [llength [info commands testobj]] - catch {unset x} -test listobj-1.1 {Tcl_GetListObjType} testobj { - set t [testobj types] - set first [string first "list" $t] - set result [expr {$first != -1}] -} {1} +test listobj-1.1 {Tcl_GetListObjType} emptyTest { + # Test removed; tested an internal detail + # that's no longer correct, and duplicated test obj-1.1 +} {} test listobj-2.1 {Tcl_SetListObj, use in lappend} { catch {unset x} list [lappend x 1 abc def] [lappend x 1 ghi jkl] $x } {{1 abc def} {1 abc def 1 ghi jkl} {1 abc def 1 ghi jkl}} Index: tests/load.test ================================================================== --- tests/load.test +++ tests/load.test @@ -8,11 +8,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: load.test,v 1.13 2004/06/19 00:42:35 dgp Exp $ +# RCS: @(#) $Id: load.test,v 1.13.2.1 2005/08/02 18:16:41 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -127,12 +127,14 @@ set result } [list [list [file join $testDir pkga$ext] Pkga]] # On some platforms, like SunOS 4.1.3, these tests can't be run because # they cause the process to exit. +# +# As of 2005, such ancient broken systems no longer matter. -test load-6.1 {errors loading file} [list $dll $loaded nonPortable] { +test load-6.1 {errors loading file} [list $dll $loaded] { catch {load foo foo} } {1} test load-7.1 {Tcl_StaticPackage procedure} [list teststaticpkg] { set x "not loaded" Index: tests/lrange.test ================================================================== --- tests/lrange.test +++ tests/lrange.test @@ -9,11 +9,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: lrange.test,v 1.7 2000/04/10 17:19:01 ericm Exp $ +# RCS: @(#) $Id: lrange.test,v 1.7.28.1 2005/05/05 17:56:18 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } @@ -41,11 +41,11 @@ } {a b c} test lrange-1.8 {range of list elements} { lrange {a b c d e} -2 -1 } {} test lrange-1.9 {range of list elements} { - lrange {a b c d e} -2 e + lrange {a b c d e} -2 end } {a b c d e} test lrange-1.10 {range of list elements} { lrange "a b\{c d" 1 2 } "b\\{c d" test lrange-1.11 {range of list elements} { @@ -53,11 +53,11 @@ } d test lrange-1.12 {range of list elements} { lrange "a b c d" end 100000 } d test lrange-1.13 {range of list elements} { - lrange "a b c d" e 3 + lrange "a b c d" end 3 } d test lrange-1.14 {range of list elements} { lrange "a b c d" end 2 } {} test lrange-1.15 {range of list elements} { @@ -73,14 +73,14 @@ test lrange-2.2 {error conditions} { list [catch {lrange a b 6 7} msg] $msg } {1 {wrong # args: should be "lrange list first last"}} test lrange-2.3 {error conditions} { list [catch {lrange a b 6} msg] $msg -} {1 {bad index "b": must be integer or end?-integer?}} +} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}} test lrange-2.4 {error conditions} { list [catch {lrange a 0 enigma} msg] $msg -} {1 {bad index "enigma": must be integer or end?-integer?}} +} {1 {bad index "enigma": must be integer?[+-]integer? or end?[+-]integer?}} test lrange-2.5 {error conditions} { list [catch {lrange "a \{b c" 3 4} msg] $msg } {1 {unmatched open brace in list}} test lrange-2.6 {error conditions} { list [catch {lrange "a b c \{ d e" 1 4} msg] $msg Index: tests/lreplace.test ================================================================== --- tests/lreplace.test +++ tests/lreplace.test @@ -9,11 +9,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: lreplace.test,v 1.7 2000/04/10 17:19:01 ericm Exp $ +# RCS: @(#) $Id: lreplace.test,v 1.7.28.1 2005/05/05 17:56:18 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } @@ -108,17 +108,17 @@ test lreplace-2.2 {lreplace errors} { list [catch {lreplace a b} msg] $msg } {1 {wrong # args: should be "lreplace list first last ?element element ...?"}} test lreplace-2.3 {lreplace errors} { list [catch {lreplace x a 10} msg] $msg -} {1 {bad index "a": must be integer or end?-integer?}} +} {1 {bad index "a": must be integer?[+-]integer? or end?[+-]integer?}} test lreplace-2.4 {lreplace errors} { list [catch {lreplace x 10 x} msg] $msg -} {1 {bad index "x": must be integer or end?-integer?}} +} {1 {bad index "x": must be integer?[+-]integer? or end?[+-]integer?}} test lreplace-2.5 {lreplace errors} { list [catch {lreplace x 10 1x} msg] $msg -} {1 {bad index "1x": must be integer or end?-integer?}} +} {1 {bad index "1x": must be integer?[+-]integer? or end?[+-]integer?}} test lreplace-2.6 {lreplace errors} { list [catch {lreplace x 3 2} msg] $msg } {1 {list doesn't contain element 3}} test lreplace-2.7 {lreplace errors} { list [catch {lreplace x 1 1} msg] $msg Index: tests/lsearch.test ================================================================== --- tests/lsearch.test +++ tests/lsearch.test @@ -9,11 +9,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: lsearch.test,v 1.13 2003/10/15 13:15:45 dkf Exp $ +# RCS: @(#) $Id: lsearch.test,v 1.13.2.2 2005/07/12 20:37:11 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } @@ -59,24 +59,42 @@ test lsearch-2.9 {search modes} { lsearch -glob {b.x ^bc xy bcx} ^bc } 1 test lsearch-2.10 {search modes} { list [catch {lsearch -glib {b.x bx xy bcx} b.x} msg] $msg -} {1 {bad option "-glib": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -not, -real, -regexp, -sorted, -start, or -subindices}} +} {1 {bad option "-glib": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}} +test lsearch-2.11 {search modes with -nocase} { + lsearch -exact -nocase {a b c A B C} A +} 0 +test lsearch-2.12 {search modes with -nocase} { + lsearch -glob -nocase {a b c A B C} A* +} 0 +test lsearch-2.13 {search modes with -nocase} { + lsearch -regexp -nocase {a b c A B C} ^A\$ +} 0 +test lsearch-2.14 {search modes without -nocase} { + lsearch -exact {a b c A B C} A +} 3 +test lsearch-2.15 {search modes without -nocase} { + lsearch -glob {a b c A B C} A* +} 3 +test lsearch-2.16 {search modes without -nocase} { + lsearch -regexp {a b c A B C} ^A\$ +} 3 test lsearch-3.1 {lsearch errors} { list [catch lsearch msg] $msg } {1 {wrong # args: should be "lsearch ?options? list pattern"}} test lsearch-3.2 {lsearch errors} { list [catch {lsearch a} msg] $msg } {1 {wrong # args: should be "lsearch ?options? list pattern"}} test lsearch-3.3 {lsearch errors} { list [catch {lsearch a b c} msg] $msg -} {1 {bad option "a": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -not, -real, -regexp, -sorted, -start, or -subindices}} +} {1 {bad option "a": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}} test lsearch-3.4 {lsearch errors} { list [catch {lsearch a b c d} msg] $msg -} {1 {bad option "a": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -not, -real, -regexp, -sorted, -start, or -subindices}} +} {1 {bad option "a": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}} test lsearch-3.5 {lsearch errors} { list [catch {lsearch "\{" b} msg] $msg } {1 {unmatched open brace in list}} test lsearch-3.6 {lsearch errors} { list [catch {lsearch -index a b} msg] $msg @@ -282,11 +300,11 @@ test lsearch-10.3 {offset searching} { lsearch -start end-4 {a b c a b c} a } 3 test lsearch-10.4 {offset searching} { list [catch {lsearch -start foobar {a b c a b c} a} msg] $msg -} {1 {bad index "foobar": must be integer or end?-integer?}} +} {1 {bad index "foobar": must be integer?[+-]integer? or end?[+-]integer?}} test lsearch-10.5 {offset searching} { list [catch {lsearch -start 1 2} msg] $msg } {1 {missing starting index}} test lsearch-10.6 {binary search with offset} { set res {} @@ -318,10 +336,19 @@ lsearch -all {a b a c a d} 1 } {} test lsearch-13.2 {search for all matches} { lsearch -all {a b a c a d} a } {0 2 4} +test lsearch-13.3 {search for all matches with -nocase} { + lsearch -all -exact -nocase {a b c A B C} A +} {0 3} +test lsearch-13.4 {search for all matches with -nocase} { + lsearch -all -glob -nocase {a b c A B C} A* +} {0 3} +test lsearch-13.5 {search for all matches with -nocase} { + lsearch -all -regexp -nocase {a b c A B C} ^A\$ +} {0 3} test lsearch-14.1 {combinations: -all and -inline} { lsearch -all -inline -glob {a1 b2 a3 c4 a5 d6} a* } {a1 a3 a5} test lsearch-14.2 {combinations: -all, -inline and -not} { @@ -413,11 +440,11 @@ test lsearch-20.1 {lsearch -index option, index larger than sublists} { list [catch {lsearch -index 2 {{a c} {a b} {a a}} a} msg] $msg } {1 {element 2 missing from sublist "a c"}} test lsearch-20.2 {lsearch -index option, malformed index} { list [catch {lsearch -index foo {{a c} {a b} {a a}} a} msg] $msg -} {1 {bad index "foo": must be integer or end?-integer?}} +} {1 {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?}} test lsearch-20.3 {lsearch -index option, malformed index} { list [catch {lsearch -index \{ {{a c} {a b} {a a}} a} msg] $msg } {1 {unmatched open brace in list}} # cleanup Index: tests/lset.test ================================================================== --- tests/lset.test +++ tests/lset.test @@ -49,11 +49,11 @@ test lset-2.2 {lset, not compiled, 3 args, second arg neither index nor list} testevalex { set x {0 1 2} list [catch { testevalex {lset x {{bad}1} 3} } msg] $msg -} "1 {bad index \"{bad}1\": must be integer or end?-integer?}" +} {1 {bad index "{bad}1": must be integer?[+-]integer? or end?[+-]integer?}} test lset-3.1 {lset, not compiled, 3 args, data duplicated} testevalex { set x {0 1 2} list [testevalex {lset x 0 $x}] $x } {{{0 1 2} 1 2} {{0 1 2} 1 2}} @@ -97,11 +97,11 @@ test lset-4.2 {lset, not compiled, 3 args, bad index} testevalex { set a {x y z} list [catch { testevalex {lset a [list 2a2] w} } msg] $msg -} {1 {bad index "2a2": must be integer or end?-integer?}} +} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}} test lset-4.3 {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { testevalex {lset a [list -1] w} @@ -139,11 +139,11 @@ test lset-4.8 {lset, not compiled, 3 args, bad index} testevalex { set a {x y z} list [catch { testevalex {lset a 2a2 w} } msg] $msg -} {1 {bad index "2a2": must be integer or end?-integer?}} +} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}} test lset-4.9 {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { testevalex {lset a -1 w} @@ -298,16 +298,16 @@ } {1 {unmatched open brace in list}} test lset-8.3 {lset, not compiled, bad second index} testevalex { set a {{b c} {d e}} list [catch {testevalex {lset a 0 2a2 f}} msg] $msg -} {1 {bad index "2a2": must be integer or end?-integer?}} +} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}} test lset-8.4 {lset, not compiled, bad second index} testevalex { set a {{b c} {d e}} list [catch {testevalex {lset a {0 2a2} f}} msg] $msg -} {1 {bad index "2a2": must be integer or end?-integer?}} +} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}} test lset-8.5 {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} list [catch {testevalex {lset a 2 -1 h}} msg] $msg } {1 {list index out of range}} Index: tests/main.test ================================================================== --- tests/main.test +++ tests/main.test @@ -1,8 +1,8 @@ # This file contains a collection of tests for generic/tclMain.c. # -# RCS: @(#) $Id: main.test,v 1.15 2003/10/07 21:45:39 dgp Exp $ +# RCS: @(#) $Id: main.test,v 1.15.2.1 2005/05/05 17:56:19 kennykb Exp $ if {[catch {package require tcltest 2.0.2}]} { puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." return } @@ -903,10 +903,26 @@ read $f } -cleanup { close $f file delete result } -result "1\n% " + + test Tcl_Main-6.7 { + [unknown]: interactive auto-completion. + } -constraints { + exec + } -body { + exec [interpreter] << { + proc foo\{ x {} + set tcl_interactive 1 + foo y} >& result + set f [open result] + read $f + } -cleanup { + close $f + file delete result + } -result "1\n% % " # Tests Tcl_Main-7.*: exiting test Tcl_Main-7.1 { Tcl_Main: [exit] defined as no-op -> still have exithandlers Index: tests/msgcat.test ================================================================== --- tests/msgcat.test +++ tests/msgcat.test @@ -10,11 +10,11 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Note that after running these tests, entries will be left behind in the # message catalogs for locales foo, foo_BAR, and foo_BAR_baz. # -# RCS: @(#) $Id: msgcat.test,v 1.16 2004/11/11 01:16:07 das Exp $ +# RCS: @(#) $Id: msgcat.test,v 1.16.2.1 2004/12/08 18:24:36 kennykb Exp $ package require Tcl 8.2 if {[catch {package require tcltest 2}]} { puts stderr "Skipping tests in [info script]. tcltest 2 required." return @@ -394,12 +394,11 @@ if { $loc eq {} } { set msg ROOT } else { set msg [string tolower $loc] } - makeFile [list ::msgcat::mcset $loc abc abc-$loc] $msg.msg \ - [file join [temporaryDirectory] msgdir] + makeFile [list ::msgcat::mcset $loc abc abc-$loc] $msg.msg $msgdir } variable count 1 foreach loc {foo foo_BAR foo_BAR_baz} { test msgcat-5.$count {mcload} -setup { variable locale [mclocale] @@ -492,11 +491,11 @@ if { $loc eq {} } { set msg ROOT } else { set msg [string tolower $loc] } - removeFile $msg.msg msgdir + removeFile $msg.msg $msgdir } removeDirectory msgdir # Tests msgcat-6.*: [mcset], [mc] namespace inheritance # Index: tests/namespace.test ================================================================== --- tests/namespace.test +++ tests/namespace.test @@ -9,11 +9,11 @@ # Copyright (c) 1998-2000 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: namespace.test,v 1.43 2004/10/29 15:39:10 dkf Exp $ +# RCS: @(#) $Id: namespace.test,v 1.43.2.1 2005/07/12 20:37:12 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -242,11 +242,11 @@ } test_ns_import::p } {cmd1: 123} test namespace-9.5 {Tcl_Import, can't redefine cmd unless allowOverwrite!=0} { list [catch {namespace eval test_ns_import {namespace import ::test_ns_export::*}} msg] $msg -} {1 {can't import command "cmd1": already exists}} +} {0 {}} test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} { namespace eval test_ns_import { namespace import -force ::test_ns_export::* cmd1 555 } @@ -836,11 +836,11 @@ catch {namespace delete {expand}[namespace children :: test_ns_*]} list [catch {namespace} msg] $msg } {1 {wrong # args: should be "namespace subcommand ?arg ...?"}} test namespace-20.2 {Tcl_NamespaceObjCmd, bad subcommand} { list [catch {namespace wombat {}} msg] $msg -} {1 {bad option "wombat": must be children, code, current, delete, ensemble, eval, exists, export, forget, import, inscope, origin, parent, qualifiers, tail, or which}} +} {1 {bad option "wombat": must be children, code, current, delete, ensemble, eval, exists, export, forget, import, inscope, origin, parent, path, qualifiers, tail, or which}} test namespace-20.3 {Tcl_NamespaceObjCmd, abbreviations are okay} { namespace ch :: test_ns_* } {} test namespace-21.1 {NamespaceChildrenCmd, no args} { @@ -943,11 +943,11 @@ catch {namespace delete {expand}[namespace children :: test_ns_*]} list [catch {namespace eval} msg] $msg } {1 {wrong # args: should be "namespace eval name arg ?arg...?"}} test namespace-25.2 {NamespaceEvalCmd, bad args} { list [catch {namespace test_ns_1} msg] $msg -} {1 {bad option "test_ns_1": must be children, code, current, delete, ensemble, eval, exists, export, forget, import, inscope, origin, parent, qualifiers, tail, or which}} +} {1 {bad option "test_ns_1": must be children, code, current, delete, ensemble, eval, exists, export, forget, import, inscope, origin, parent, path, qualifiers, tail, or which}} catch {unset v} test namespace-25.3 {NamespaceEvalCmd, new namespace} { set v 123 namespace eval test_ns_1 { variable v 314159 @@ -1922,10 +1922,23 @@ } -result {1 2 1 2} -cleanup { rename a {} rename c {} rename x {} } +test namespace-49.2 {strange delete crash} -body { + namespace eval foo {namespace ensemble create -command ::bar} + trace add command ::bar delete DeleteTrace + proc DeleteTrace {old new op} { + trace remove command ::bar delete DeleteTrace + rename $old "" + # This next line caused a bus error in [Bug 1220058] + namespace delete foo + } + rename ::bar "" +} -result "" -cleanup { + rename DeleteTrace "" +} test namespace-50.1 {ensembles affect proc arguments error messages} -body { namespace ens cre -command a -map {b {bb foo}} proc bb {c d {e f} args} {list $c $args} a b @@ -1953,10 +1966,393 @@ proc e f {} a b d } -returnCodes error -result "wrong # args: should be \"a b\"" -cleanup { rename a {} } + +test namespace-51.1 {name resolution path control} -body { + namespace eval ::test_ns_1 { + namespace eval test_ns_2 { + proc pathtestA {} { + ::return [pathtestB],[pathtestC],[pathtestD],[namespace path] + } + proc pathtestC {} { + ::return 2 + } + } + proc pathtestB {} { + return 1 + } + proc pathtestC {} { + return 1 + } + namespace path ::test_ns_1 + } + proc ::pathtestB {} { + return global + } + proc ::pathtestD {} { + return global + } + test_ns_1::test_ns_2::pathtestA +} -result "global,2,global," -cleanup { + namespace delete ::test_ns_1 + catch {rename ::pathtestB {}} + catch {rename ::pathtestD {}} +} +test namespace-51.2 {name resolution path control} -body { + namespace eval ::test_ns_1 { + namespace eval test_ns_2 { + namespace path ::test_ns_1 + proc pathtestA {} { + ::return [pathtestB],[pathtestC],[pathtestD],[namespace path] + } + proc pathtestC {} { + ::return 2 + } + } + proc pathtestB {} { + return 1 + } + proc pathtestC {} { + return 1 + } + } + proc ::pathtestB {} { + return global + } + proc ::pathtestD {} { + return global + } + ::test_ns_1::test_ns_2::pathtestA +} -result "1,2,global,::test_ns_1" -cleanup { + namespace delete ::test_ns_1 + catch {rename ::pathtestB {}} + catch {rename ::pathtestD {}} +} +test namespace-51.3 {name resolution path control} -body { + namespace eval ::test_ns_1 { + namespace eval test_ns_2 { + proc pathtestA {} { + ::return [pathtestB],[pathtestC],[pathtestD],[namespace path] + } + proc pathtestC {} { + ::return 2 + } + } + proc pathtestB {} { + return 1 + } + proc pathtestC {} { + return 1 + } + } + proc ::pathtestB {} { + return global + } + proc ::pathtestD {} { + return global + } + set result [::test_ns_1::test_ns_2::pathtestA] + namespace eval ::test_ns_1::test_ns_2 { + namespace path ::test_ns_1 + } + lappend result [::test_ns_1::test_ns_2::pathtestA] + rename ::test_ns_1::pathtestB {} + lappend result [::test_ns_1::test_ns_2::pathtestA] +} -result "global,2,global, 1,2,global,::test_ns_1 global,2,global,::test_ns_1" -cleanup { + namespace delete ::test_ns_1 + catch {rename ::pathtestB {}} + catch {rename ::pathtestD {}} +} +test namespace-51.4 {name resolution path control} -body { + namespace eval ::test_ns_1 { + namespace eval test_ns_2 { + proc pathtestA {} { + ::return [pathtestB],[pathtestC],[pathtestD],[namespace path] + } + proc pathtestC {} { + ::return 2 + } + } + proc pathtestB {} { + return 1 + } + proc pathtestC {} { + return 1 + } + } + proc ::pathtestB {} { + return global + } + proc ::pathtestD {} { + return global + } + set result [::test_ns_1::test_ns_2::pathtestA] + namespace eval ::test_ns_1::test_ns_2 { + namespace path ::test_ns_1 + } + lappend result [::test_ns_1::test_ns_2::pathtestA] + namespace eval ::test_ns_1::test_ns_2 { + namespace path {} + } + lappend result [::test_ns_1::test_ns_2::pathtestA] +} -result "global,2,global, 1,2,global,::test_ns_1 global,2,global," -cleanup { + namespace delete ::test_ns_1 + catch {rename ::pathtestB {}} + catch {rename ::pathtestD {}} +} +test namespace-51.5 {name resolution path control} -body { + namespace eval ::test_ns_1 { + namespace eval test_ns_2 { + proc pathtestA {} { + ::return [pathtestB],[pathtestC],[pathtestD],[namespace path] + } + proc pathtestC {} { + ::return 2 + } + namespace path ::test_ns_1 + } + proc pathtestB {} { + return 1 + } + proc pathtestC {} { + return 1 + } + proc pathtestD {} { + return 1 + } + } + proc ::pathtestB {} { + return global + } + proc ::pathtestD {} { + return global + } + set result [::test_ns_1::test_ns_2::pathtestA] + namespace eval ::test_ns_1::test_ns_2 { + namespace path {:: ::test_ns_1} + } + lappend result [::test_ns_1::test_ns_2::pathtestA] + rename ::test_ns_1::test_ns_2::pathtestC {} + lappend result [::test_ns_1::test_ns_2::pathtestA] +} -result "1,2,1,::test_ns_1 {global,2,global,:: ::test_ns_1} {global,1,global,:: ::test_ns_1}" -cleanup { + namespace delete ::test_ns_1 + catch {rename ::pathtestB {}} + catch {rename ::pathtestD {}} +} +test namespace-51.6 {name resolution path control} -body { + namespace eval ::test_ns_1 { + namespace eval test_ns_2 { + proc pathtestA {} { + ::return [pathtestB],[pathtestC],[pathtestD],[namespace path] + } + proc pathtestC {} { + ::return 2 + } + namespace path ::test_ns_1 + } + proc pathtestB {} { + return 1 + } + proc pathtestC {} { + return 1 + } + proc pathtestD {} { + return 1 + } + } + proc ::pathtestB {} { + return global + } + proc ::pathtestD {} { + return global + } + set result [::test_ns_1::test_ns_2::pathtestA] + namespace eval ::test_ns_1::test_ns_2 { + namespace path {:: ::test_ns_1} + } + lappend result [::test_ns_1::test_ns_2::pathtestA] + rename ::test_ns_1::test_ns_2::pathtestC {} + lappend result [::test_ns_1::test_ns_2::pathtestA] + proc ::pathtestC {} { + return global + } + lappend result [::test_ns_1::test_ns_2::pathtestA] +} -result "1,2,1,::test_ns_1 {global,2,global,:: ::test_ns_1} {global,1,global,:: ::test_ns_1} {global,global,global,:: ::test_ns_1}" -cleanup { + namespace delete ::test_ns_1 + catch {rename ::pathtestB {}} + catch {rename ::pathtestD {}} +} +test namespace-51.7 {name resolution path control} -body { + namespace eval ::test_ns_1 { + } + namespace eval ::test_ns_2 { + namespace path ::test_ns_1 + proc getpath {} {namespace path} + } + list [::test_ns_2::getpath] [namespace delete ::test_ns_1] [::test_ns_2::getpath] +} -result {::test_ns_1 {} {}} -cleanup { + catch {namespace delete ::test_ns_1} + namespace delete ::test_ns_2 +} +test namespace-51.8 {name resolution path control} -body { + namespace eval ::test_ns_1 { + } + namespace eval ::test_ns_2 { + } + namespace eval ::test_ns_3 { + } + namespace eval ::test_ns_4 { + namespace path {::test_ns_1 ::test_ns_2 ::test_ns_3} + proc getpath {} {namespace path} + } + list [::test_ns_4::getpath] [namespace delete ::test_ns_2] [::test_ns_4::getpath] +} -result {{::test_ns_1 ::test_ns_2 ::test_ns_3} {} {::test_ns_1 ::test_ns_3}} -cleanup { + catch {namespace delete ::test_ns_1} + catch {namespace delete ::test_ns_2} + catch {namespace delete ::test_ns_3} + catch {namespace delete ::test_ns_4} +} +test namespace-51.9 {name resolution path control} -body { + namespace eval ::test_ns_1 { + } + namespace eval ::test_ns_2 { + } + namespace eval ::test_ns_3 { + } + namespace eval ::test_ns_4 { + namespace path {::test_ns_1 ::test_ns_2 ::test_ns_3} + proc getpath {} {namespace path} + } + list [::test_ns_4::getpath] [namespace delete ::test_ns_2] [namespace eval ::test_ns_2 {}] [::test_ns_4::getpath] +} -result {{::test_ns_1 ::test_ns_2 ::test_ns_3} {} {} {::test_ns_1 ::test_ns_3}} -cleanup { + catch {namespace delete ::test_ns_1} + catch {namespace delete ::test_ns_2} + catch {namespace delete ::test_ns_3} + catch {namespace delete ::test_ns_4} +} +test namespace-51.10 {name resolution path control} -body { + namespace eval ::test_ns_1 { + namespace path does::not::exist + } +} -returnCodes error -result {unknown namespace "does::not::exist"} -cleanup { + catch {namespace delete ::test_ns_1} +} +test namespace-51.11 {name resolution path control} -body { + namespace eval ::test_ns_1 { + proc foo {} {return 1} + } + namespace eval ::test_ns_2 { + proc foo {} {return 2} + } + namespace eval ::test_ns_3 { + namespace path ::test_ns_1 + } + namespace eval ::test_ns_4 { + namespace path {::test_ns_3 ::test_ns_2} + foo + } +} -result 2 -cleanup { + catch {namespace delete ::test_ns_1} + catch {namespace delete ::test_ns_2} + catch {namespace delete ::test_ns_3} + catch {namespace delete ::test_ns_4} +} +test namespace-51.12 {name resolution path control} -body { + namespace eval ::test_ns_1 { + proc foo {} {return 1} + } + namespace eval ::test_ns_2 { + proc foo {} {return 2} + } + namespace eval ::test_ns_3 { + namespace path ::test_ns_1 + } + namespace eval ::test_ns_4 { + namespace path {::test_ns_3 ::test_ns_2} + list [foo] [namespace delete ::test_ns_3] [foo] + } +} -result {2 {} 2} -cleanup { + catch {namespace delete ::test_ns_1} + catch {namespace delete ::test_ns_2} + catch {namespace delete ::test_ns_3} + catch {namespace delete ::test_ns_4} +} +# Fails right now due to unrelated bug... +test namespace-51.13 {name resolution path control} -constraints knownBug -body { + set ::result {} + namespace eval ::test_ns_1 { + proc foo {} {lappend ::result 1} + } + namespace eval ::test_ns_2 { + proc foo {} {lappend ::result 2} + trace add command foo delete {namespace eval ::test_ns_3 foo;#} + } + namespace eval ::test_ns_3 { + proc foo {} { + lappend ::result 3 + namespace delete [namespace current] + ::test_ns_4::bar + } + } + namespace eval ::test_ns_4 { + namespace path {::test_ns_2 ::test_ns_3 ::test_ns_1} + proc bar {} { + list [foo] [namespace delete ::test_ns_2] [foo] + } + bar + } + # Should the result be "2 {} {2 3 1 1}" instead? +} -result {2 {} {2 3 2 1}} -cleanup { + catch {namespace delete ::test_ns_1} + catch {namespace delete ::test_ns_2} + catch {namespace delete ::test_ns_3} + catch {namespace delete ::test_ns_4} +} +test namespace-51.14 {name resolution path control} -body { + proc foo0 {} {} + namespace eval ::test_ns_1 { + proc foo1 {} {} + } + namespace eval ::test_ns_2 { + proc foo2 {} {} + } + namespace eval ::test_ns_3 { + variable result {} + lappend result [info commands foo*] + namespace path {::test_ns_1 ::test_ns_2} + lappend result [info commands foo*] + proc foo2 {} {} + lappend result [info commands foo*] + rename foo2 {} + lappend result [info commands foo*] + namespace delete ::test_ns_1 + lappend result [info commands foo*] + } +} -result {foo0 {foo1 foo2 foo0} {foo2 foo1 foo0} {foo1 foo2 foo0} {foo2 foo0}} -cleanup { + catch {namespace delete ::test_ns_1} + catch {namespace delete ::test_ns_2} + catch {namespace delete ::test_ns_3} +} +test namespace-51.15 {namespace resolution path control} -body { + namespace eval ::test_ns_2 { + proc foo {} {return 2} + } + namespace eval ::test_ns_1 { + namespace eval test_ns_2 { + proc foo {} {return 1_2} + } + namespace eval test_ns_3 { + namespace path ::test_ns_1 + test_ns_2::foo + } + } +} -result 1_2 -cleanup { + namespace delete ::test_ns_1 + namespace delete ::test_ns_2 +} # cleanup catch {rename cmd1 {}} catch {unset l} catch {unset msg} Index: tests/obj.test ================================================================== --- tests/obj.test +++ tests/obj.test @@ -9,56 +9,32 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # 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.11 2004/09/10 21:29:42 dkf Exp $ +# RCS: @(#) $Id: obj.test,v 1.11.2.3 2005/08/02 18:16:41 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } -# Procedure to determine the integer range of the machine -proc int_range {} { - for {set MIN_INT 1} {$MIN_INT > 0} {} { - set MIN_INT [expr {$MIN_INT << 1}] - } - set MAX_INT [expr {~ $MIN_INT}] - return [list $MIN_INT $MAX_INT] -} - -# Procedure to determine the range of wide integers on the machine. -proc wide_range {} { - for {set MIN_WIDE [expr {wide(1)}] } {$MIN_WIDE > wide(0)} {} { - set MIN_WIDE [expr {$MIN_WIDE << 1}] - } - set MAX_WIDE [expr {~ $MIN_WIDE}] - return [list $MIN_WIDE $MAX_WIDE] -} - -foreach {MIN_INT MAX_INT} [int_range] break -foreach {MIN_WIDE MAX_WIDE} [wide_range] break - testConstraint testobj [llength [info commands testobj]] -testConstraint 32bit [expr {$MAX_INT == 0x7fffffff}] -testConstraint wideBiggerThanInt [expr {$MAX_WIDE > wide($MAX_INT)}] +testConstraint longIs32bit [expr {int(0x80000000) < 0}] +testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}] test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj { set r 1 foreach {t} { {array search} - boolean bytearray bytecode - double + cmdName + dict end-offset - index - int - list nsName - procbody + regexp string } { set first [string first $t [testobj types]] set r [expr {$r && ($first != -1)}] } @@ -70,21 +46,23 @@ } {0 1 {no type foo found}} 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 "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] @@ -173,28 +151,28 @@ set result "" lappend result [testobj freeallvars] lappend result [testbooleanobj set 1 0] lappend result [testobj type 1] lappend result [testobj refcount 1] -} {{} 0 boolean 2} +} {{} 0 int 2} test obj-10.1 {Tcl_SetBooleanObj, existing "empty string" object} testobj { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] lappend result [testbooleanobj set 1 0] ;# makes existing obj boolean lappend result [testobj type 1] lappend result [testobj refcount 1] -} {{} {} 0 boolean 2} +} {{} {} 0 int 2} test obj-10.2 {Tcl_SetBooleanObj, existing non-"empty string" object} testobj { set result "" lappend result [testobj freeallvars] lappend result [testintobj set 1 98765] lappend result [testbooleanobj set 1 1] ;# makes existing obj boolean lappend result [testobj type 1] lappend result [testobj refcount 1] -} {{} 98765 1 boolean 2} +} {{} 98765 1 int 2} test obj-11.1 {Tcl_GetBooleanFromObj, existing boolean object} testobj { set result "" lappend result [testbooleanobj set 1 1] lappend result [testbooleanobj not 1] ;# gets existing boolean rep @@ -202,11 +180,11 @@ test obj-11.2 {Tcl_GetBooleanFromObj, convert to boolean} testobj { set result "" lappend result [testintobj set 1 47] lappend result [testbooleanobj not 1] ;# must convert to bool lappend result [testobj type 1] -} {47 0 boolean} +} {47 0 int} test obj-11.3 {Tcl_GetBooleanFromObj, error converting to boolean} testobj { set result "" lappend result [teststringobj set 1 abc] lappend result [catch {testbooleanobj not 1} msg] lappend result $msg @@ -220,17 +198,17 @@ test obj-11.5 {Tcl_GetBooleanFromObj, convert hex to boolean} testobj { set result "" lappend result [teststringobj set 1 0xac] lappend result [testbooleanobj not 1] lappend result [testobj type 1] -} {0xac 0 boolean} +} {0xac 0 int} test obj-11.6 {Tcl_GetBooleanFromObj, convert float to boolean} testobj { set result "" lappend result [teststringobj set 1 5.42] lappend result [testbooleanobj not 1] lappend result [testobj type 1] -} {5.42 0 boolean} +} {5.42 0 int} test obj-12.1 {DupBooleanInternalRep} testobj { set result "" lappend result [testbooleanobj set 1 1] lappend result [testobj duplicate 1 2] ;# uses DupBooleanInternalRep @@ -240,32 +218,32 @@ test obj-13.1 {SetBooleanFromAny, int to boolean special case} testobj { set result "" lappend result [testintobj set 1 1234] lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny lappend result [testobj type 1] -} {1234 0 boolean} +} {1234 0 int} test obj-13.2 {SetBooleanFromAny, double to boolean special case} testobj { set result "" lappend result [testdoubleobj set 1 3.14159] lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny lappend result [testobj type 1] -} {3.14159 0 boolean} +} {3.14159 0 int} test obj-13.3 {SetBooleanFromAny, special case strings representing booleans} testobj { set result "" foreach s {yes no true false on off} { teststringobj set 1 $s lappend result [testbooleanobj not 1] } lappend result [testobj type 1] -} {0 1 0 1 0 1 boolean} +} {0 1 0 1 0 1 int} test obj-13.4 {SetBooleanFromAny, recompute string rep then parse it} testobj { set result "" lappend result [testintobj set 1 456] lappend result [testintobj div10 1] lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny lappend result [testobj type 1] -} {456 45 0 boolean} +} {456 45 0 int} test obj-13.5 {SetBooleanFromAny, error parsing string} testobj { set result "" lappend result [teststringobj set 1 abc] lappend result [catch {testbooleanobj not 1} msg] lappend result $msg @@ -443,11 +421,11 @@ set result "" lappend result [testobj newobj 1] lappend result [catch {testintobj div10 1} msg] lappend result $msg } {{} 1 {expected integer but got ""}} -test obj-23.5 {Tcl_GetIntFromObj, integer too large to represent as non-long error} {testobj nonPortable} { +test obj-23.5 {Tcl_GetIntFromObj, integer too large to represent as non-long error} {testobj} { set result "" lappend result [testobj newobj 1] lappend result [testintobj inttoobigtest 1] } {{} 1} @@ -487,11 +465,11 @@ set result "" lappend result [teststringobj set 1 x17] lappend result [catch {testintobj mult10 1} msg] lappend result $msg } {x17 1 {expected integer but got "x17"}} -test obj-25.6 {SetIntFromAny, integer too large} {testobj nonPortable} { +test obj-25.6 {SetIntFromAny, integer too large} {testobj} { set result "" lappend result [teststringobj set 1 123456789012345678901] lappend result [catch {testintobj mult10 1} msg] lappend result $msg } {123456789012345678901 1 {integer value too large to represent}} @@ -569,11 +547,11 @@ lappend result [testobj refcount 2] lappend result [testbooleanobj set 2 0] ;# must copy on write, now 2 objs lappend result [testobj type 2] lappend result [testobj refcount 1] lappend result [testobj refcount 2] -} {{} 1024 1024 int 4 4 0 boolean 3 2} +} {{} 1024 1024 int 4 4 0 int 3 2} test obj-31.1 {regenerate string rep of "end"} testobj { testobj freeallvars teststringobj set 1 end @@ -602,11 +580,11 @@ testobj freeallvars teststringobj set 1 end--0x7fffffff testobj convert 1 end-offset testobj invalidateStringRep 1 } end--2147483647 -test obj-31.6 {regenerate string rep of "end--bigInteger"} {testobj nonPortable} { +test obj-31.6 {regenerate string rep of "end--bigInteger"} {testobj longIs32bit} { testobj freeallvars teststringobj set 1 end--0x80000000 testobj convert 1 end-offset testobj invalidateStringRep 1 } end--2147483648 @@ -617,35 +595,35 @@ set x [list $x {}] } unset x } {} -test obj-33.1 {integer overflow on input} {32bit wideBiggerThanInt} { +test obj-33.1 {integer overflow on input} {longIs32bit wideBiggerThanInt} { set x 0x8000; append x 0000 list [string is integer $x] [expr { wide($x) }] } {1 2147483648} -test obj-33.2 {integer overflow on input} {32bit wideBiggerThanInt} { +test obj-33.2 {integer overflow on input} {longIs32bit wideBiggerThanInt} { set x 0xffff; append x ffff list [string is integer $x] [expr { wide($x) }] } {1 4294967295} -test obj-33.3 {integer overflow on input} {32bit wideBiggerThanInt} { +test obj-33.3 {integer overflow on input} {longIs32bit wideBiggerThanInt} { set x 0x10000; append x 0000 list [string is integer $x] [expr { wide($x) }] } {0 4294967296} -test obj-33.4 {integer overflow on input} {32bit wideBiggerThanInt} { +test obj-33.4 {integer overflow on input} {longIs32bit wideBiggerThanInt} { set x -0x8000; append x 0000 list [string is integer $x] [expr { wide($x) }] } {1 -2147483648} -test obj-33.5 {integer overflow on input} {32bit wideBiggerThanInt} { +test obj-33.5 {integer overflow on input} {longIs32bit wideBiggerThanInt} { set x -0x8000; append x 0001 list [string is integer $x] [expr { wide($x) }] } {1 -2147483649} -test obj-33.6 {integer overflow on input} {32bit wideBiggerThanInt} { +test obj-33.6 {integer overflow on input} {longIs32bit wideBiggerThanInt} { set x -0xffff; append x ffff list [string is integer $x] [expr { wide($x) }] } {1 -4294967295} -test obj-33.7 {integer overflow on input} {32bit wideBiggerThanInt} { +test obj-33.7 {integer overflow on input} {longIs32bit wideBiggerThanInt} { set x -0x10000; append x 0000 list [string is integer $x] [expr { wide($x) }] } {0 -4294967296} if {[testConstraint testobj]} { Index: tests/parse.test ================================================================== --- tests/parse.test +++ tests/parse.test @@ -6,11 +6,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: parse.test,v 1.19 2004/10/01 03:10:36 dgp Exp $ +# RCS: @(#) $Id: parse.test,v 1.19.2.1 2005/04/10 23:14:59 kennykb Exp $ if {[catch {package require tcltest 2.0.2}]} { puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." return } @@ -941,11 +941,57 @@ test parse-18.30 {Tcl_SubstObj, side effects} { set a 0 catch {subst {foo[incr a; incr a parse error {}{}]bar}} set a } 1 + +test parse-19.1 {Bug 1115904: recursion limit in Tcl_EvalEx} -constraints { + testevalex +} -setup { + interp create i + load {} Tcltest i + i eval {proc {} args {}} + interp recursionlimit i 3 +} -body { + i eval {testevalex {[]}} +} -cleanup { + interp delete i +} + +test parse-19.2 {Bug 1115904: recursion limit in Tcl_EvalEx} -constraints { + testevalex +} -setup { + interp create i + load {} Tcltest i + i eval {proc {} args {}} + interp recursionlimit i 3 +} -body { + i eval {testevalex {[[]]}} +} -cleanup { + interp delete i +} -returnCodes error -match glob -result {too many nested*} + +test parse-19.3 {Bug 1115904: recursion limit in Tcl_EvalEx} -setup { + interp create i + i eval {proc {} args {}} + interp recursionlimit i 3 +} -body { + i eval {subst {[]}} +} -cleanup { + interp delete i +} + +test parse-19.4 {Bug 1115904: recursion limit in Tcl_EvalEx} -setup { + interp create i + i eval {proc {} args {}} + interp recursionlimit i 3 +} -body { + i eval {subst {[[]]}} +} -cleanup { + interp delete i +} -returnCodes error -match glob -result {too many nested*} cleanupTests } namespace delete ::tcl::test::parse return Index: tests/parseExpr.test ================================================================== --- tests/parseExpr.test +++ tests/parseExpr.test @@ -6,11 +6,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: parseExpr.test,v 1.13 2004/06/23 15:36:57 dkf Exp $ +# RCS: @(#) $Id: parseExpr.test,v 1.13.2.3 2005/08/02 18:16:42 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -23,202 +23,294 @@ testConstraint testexprparser [llength [info commands testexprparser]] # Some tests only work if wide integers (>32bit) are not found to be # integers at all. -testConstraint wideIntegerUnparsed [expr {-1 == 0xffffffff}] +testConstraint wideIs32bit [expr {0x80000000 < 0}] + +# 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 + } + } +} +::tcltest::testConstraint ieeeFloatingPoint [testIEEE] ###################################################################### test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} testexprparser { testexprparser [bytestring "1+2\0 +3"] -1 } {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} test parseExpr-1.2 {Tcl_ParseExpr procedure, computing string length} testexprparser { testexprparser "1 + 2" -1 } {- {} 0 subexpr {1 + 2} 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} -test parseExpr-1.3 {Tcl_ParseExpr procedure, error getting initial lexeme} {testexprparser wideIntegerUnparsed} { +test parseExpr-1.3 {Tcl_ParseExpr procedure, error getting initial lexeme} {testexprparser wideIs32bit} { list [catch {testexprparser {12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} -test parseExpr-1.4 {Tcl_ParseExpr procedure, error in conditional expression} testexprparser { - list [catch {testexprparser {foo+} -1} msg] $msg -} {1 {syntax error in expression "foo+": variable references require preceding $}} +test parseExpr-1.4 {Tcl_ParseExpr procedure, error in conditional expression} \ + -constraints testexprparser -body { + list [catch {testexprparser {foo+} -1} msg] $msg + } -match glob \ + -result {1 {syntax error in expression "foo+": *preceding $*}} test parseExpr-1.5 {Tcl_ParseExpr procedure, lexemes after the expression} testexprparser { list [catch {testexprparser {1+2 345} -1} msg] $msg } {1 {syntax error in expression "1+2 345": extra tokens at end of expression}} test parseExpr-2.1 {ParseCondExpr procedure, valid test subexpr} testexprparser { testexprparser {2>3? 1 : 0} -1 } {- {} 0 subexpr {2>3? 1 : 0} 11 operator ? 0 subexpr 2>3 5 operator > 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} -test parseExpr-2.2 {ParseCondExpr procedure, error in test subexpr} testexprparser { - list [catch {testexprparser {0 || foo} -1} msg] $msg -} {1 {syntax error in expression "0 || foo": variable references require preceding $}} +test parseExpr-2.2 {ParseCondExpr procedure, error in test subexpr} \ + -constraints testexprparser -body { + list [catch {testexprparser {0 || foo} -1} msg] $msg + } -match glob \ + -result {1 {syntax error in expression "0 || foo": * preceding $*}} test parseExpr-2.3 {ParseCondExpr procedure, next lexeme isn't "?"} testexprparser { testexprparser {1+2} -1 } {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} test parseExpr-2.4 {ParseCondExpr procedure, next lexeme is "?"} testexprparser { testexprparser {1+2 ? 3 : 4} -1 } {- {} 0 subexpr {1+2 ? 3 : 4} 11 operator ? 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} -test parseExpr-2.5 {ParseCondExpr procedure, bad lexeme after "?"} {testexprparser wideIntegerUnparsed} { +test parseExpr-2.5 {ParseCondExpr procedure, bad lexeme after "?"} {testexprparser wideIs32bit} { list [catch {testexprparser {1+2 ? 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-2.6 {ParseCondExpr procedure, valid "then" subexpression} testexprparser { testexprparser {1? 3 : 4} -1 } {- {} 0 subexpr {1? 3 : 4} 7 operator ? 0 subexpr 1 1 text 1 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} -test parseExpr-2.7 {ParseCondExpr procedure, error in "then" subexpression} testexprparser { - list [catch {testexprparser {1? fred : martha} -1} msg] $msg -} {1 {syntax error in expression "1? fred : martha": variable references require preceding $}} +test parseExpr-2.7 {ParseCondExpr procedure, error in "then" subexpression} \ + -constraints testexprparser -body { + list [catch {testexprparser {1? fred : martha} -1} msg] $msg + } -match glob \ + -result {1 {syntax error in expression "1? fred : martha": *preceding $*}} test parseExpr-2.8 {ParseCondExpr procedure, lexeme after "then" subexpr isn't ":"} testexprparser { list [catch {testexprparser {1? 2 martha 3} -1} msg] $msg } {1 {syntax error in expression "1? 2 martha 3": missing colon from ternary conditional}} test parseExpr-2.9 {ParseCondExpr procedure, valid "else" subexpression} testexprparser { testexprparser {27||3? 3 : 4&&9} -1 } {- {} 0 subexpr {27||3? 3 : 4&&9} 15 operator ? 0 subexpr 27||3 5 operator || 0 subexpr 27 1 text 27 0 subexpr 3 1 text 3 0 subexpr 3 1 text 3 0 subexpr 4&&9 5 operator && 0 subexpr 4 1 text 4 0 subexpr 9 1 text 9 0 {}} -test parseExpr-2.10 {ParseCondExpr procedure, error in "else" subexpression} testexprparser { - list [catch {testexprparser {1? 2 : martha} -1} msg] $msg -} {1 {syntax error in expression "1? 2 : martha": variable references require preceding $}} +test parseExpr-2.10 {ParseCondExpr procedure, error in "else" subexpression} \ + -constraints testexprparser -body { + list [catch {testexprparser {1? 2 : martha} -1} msg] $msg + } -match glob \ + -result {1 {syntax error in expression "1? 2 : martha": * preceding $*}} test parseExpr-3.1 {ParseLorExpr procedure, valid logical and subexpr} testexprparser { testexprparser {1&&2 || 3} -1 } {- {} 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-3.2 {ParseLorExpr procedure, error in logical and subexpr} testexprparser { - list [catch {testexprparser {1&&foo || 3} -1} msg] $msg -} {1 {syntax error in expression "1&&foo || 3": variable references require preceding $}} +test parseExpr-3.2 {ParseLorExpr procedure, error in logical and subexpr} \ + -constraints testexprparser -body { + list [catch {testexprparser {1&&foo || 3} -1} msg] $msg + } -match glob \ + -result {1 {syntax error in expression "1&&foo || 3": * preceding $*}} test parseExpr-3.3 {ParseLorExpr procedure, next lexeme isn't "||"} testexprparser { testexprparser {1&&2? 1 : 0} -1 } {- {} 0 subexpr {1&&2? 1 : 0} 11 operator ? 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} test parseExpr-3.4 {ParseLorExpr procedure, next lexeme is "||"} testexprparser { testexprparser {1&&2 || 3} -1 } {- {} 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-3.5 {ParseLorExpr procedure, bad lexeme after "||"} {testexprparser wideIntegerUnparsed} { +test parseExpr-3.5 {ParseLorExpr procedure, bad lexeme after "||"} {testexprparser wideIs32bit} { list [catch {testexprparser {1&&2 || 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-3.6 {ParseLorExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1&&2 || 3 || 4} -1 } {- {} 0 subexpr {1&&2 || 3 || 4} 13 operator || 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} -test parseExpr-3.7 {ParseLorExpr procedure, error in RHS subexpression} testexprparser { - list [catch {testexprparser {1&&2 || 3 || martha} -1} msg] $msg -} {1 {syntax error in expression "1&&2 || 3 || martha": variable references require preceding $}} +test parseExpr-3.7 {ParseLorExpr procedure, error in RHS subexpression} \ + -constraints testexprparser -body { + list [catch {testexprparser {1&&2 || 3 || martha} -1} msg] $msg + } -match glob \ + -result {1 {syntax error in expression "1&&2 || 3 || martha": * preceding $*}} test parseExpr-4.1 {ParseLandExpr procedure, valid LHS "|" subexpr} testexprparser { testexprparser {1|2 && 3} -1 } {- {} 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-4.2 {ParseLandExpr procedure, error in LHS "|" subexpr} testexprparser { - list [catch {testexprparser {1&&foo && 3} -1} msg] $msg -} {1 {syntax error in expression "1&&foo && 3": variable references require preceding $}} +test parseExpr-4.2 {ParseLandExpr procedure, error in LHS "|" subexpr} \ + -constraints testexprparser -body { + list [catch {testexprparser {1&&foo && 3} -1} msg] $msg + } -match glob \ + -result {1 {syntax error in expression "1&&foo && 3": * preceding $*}} test parseExpr-4.3 {ParseLandExpr procedure, next lexeme isn't "&&"} testexprparser { testexprparser {1|2? 1 : 0} -1 } {- {} 0 subexpr {1|2? 1 : 0} 11 operator ? 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} test parseExpr-4.4 {ParseLandExpr procedure, next lexeme is "&&"} testexprparser { testexprparser {1|2 && 3} -1 } {- {} 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-4.5 {ParseLandExpr procedure, bad lexeme after "&&"} {testexprparser wideIntegerUnparsed} { +test parseExpr-4.5 {ParseLandExpr procedure, bad lexeme after "&&"} {testexprparser wideIs32bit} { list [catch {testexprparser {1|2 && 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-4.6 {ParseLandExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1|2 && 3 && 4} -1 } {- {} 0 subexpr {1|2 && 3 && 4} 13 operator && 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} -test parseExpr-4.7 {ParseLandExpr procedure, error in RHS subexpression} testexprparser { - list [catch {testexprparser {1|2 && 3 && martha} -1} msg] $msg -} {1 {syntax error in expression "1|2 && 3 && martha": variable references require preceding $}} +test parseExpr-4.7 {ParseLandExpr procedure, error in RHS subexpression} \ + -constraints testexprparser -body { + list [catch {testexprparser {1|2 && 3 && martha} -1} msg] $msg + } -match glob \ + -result {1 {syntax error in expression "1|2 && 3 && martha": * preceding $*}} test parseExpr-5.1 {ParseBitOrExpr procedure, valid LHS "^" subexpr} testexprparser { testexprparser {1^2 | 3} -1 } {- {} 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-5.2 {ParseBitOrExpr procedure, error in LHS "^" subexpr} testexprparser { - list [catch {testexprparser {1|foo | 3} -1} msg] $msg -} {1 {syntax error in expression "1|foo | 3": variable references require preceding $}} +test parseExpr-5.2 {ParseBitOrExpr procedure, error in LHS "^" subexpr} \ + -constraints testexprparser -body { + list [catch {testexprparser {1|foo | 3} -1} msg] $msg + } -match glob \ + -result {1 {syntax error in expression "1|foo | 3": * preceding $*}} test parseExpr-5.3 {ParseBitOrExpr procedure, next lexeme isn't "|"} testexprparser { testexprparser {1^2? 1 : 0} -1 } {- {} 0 subexpr {1^2? 1 : 0} 11 operator ? 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} test parseExpr-5.4 {ParseBitOrExpr procedure, next lexeme is "|"} testexprparser { testexprparser {1^2 | 3} -1 } {- {} 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-5.5 {ParseBitOrExpr procedure, bad lexeme after "|"} {testexprparser wideIntegerUnparsed} { +test parseExpr-5.5 {ParseBitOrExpr procedure, bad lexeme after "|"} {testexprparser wideIs32bit} { list [catch {testexprparser {1^2 | 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-5.6 {ParseBitOrExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1^2 | 3 | 4} -1 } {- {} 0 subexpr {1^2 | 3 | 4} 13 operator | 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} -test parseExpr-5.7 {ParseBitOrExpr procedure, error in RHS subexpression} testexprparser { - list [catch {testexprparser {1^2 | 3 | martha} -1} msg] $msg -} {1 {syntax error in expression "1^2 | 3 | martha": variable references require preceding $}} +test parseExpr-5.7 {ParseBitOrExpr procedure, error in RHS subexpression} \ + -constraints testexprparser -body { + list [catch {testexprparser {1^2 | 3 | martha} -1} msg] $msg + } -match glob \ + -result {1 {syntax error in expression "1^2 | 3 | martha": * preceding $*}} test parseExpr-6.1 {ParseBitXorExpr procedure, valid LHS "&" subexpr} testexprparser { testexprparser {1&2 ^ 3} -1 } {- {} 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-6.2 {ParseBitXorExpr procedure, error in LHS "&" subexpr} testexprparser { - list [catch {testexprparser {1^foo ^ 3} -1} msg] $msg -} {1 {syntax error in expression "1^foo ^ 3": variable references require preceding $}} +test parseExpr-6.2 {ParseBitXorExpr procedure, error in LHS "&" subexpr} \ + -constraints testexprparser -body { + list [catch {testexprparser {1^foo ^ 3} -1} msg] $msg + } -match glob \ + -result {1 {syntax error in expression "1^foo ^ 3": * preceding $*}} test parseExpr-6.3 {ParseBitXorExpr procedure, next lexeme isn't "^"} testexprparser { testexprparser {1&2? 1 : 0} -1 } {- {} 0 subexpr {1&2? 1 : 0} 11 operator ? 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} test parseExpr-6.4 {ParseBitXorExpr procedure, next lexeme is "^"} testexprparser { testexprparser {1&2 ^ 3} -1 } {- {} 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-6.5 {ParseBitXorExpr procedure, bad lexeme after "^"} {testexprparser wideIntegerUnparsed} { +test parseExpr-6.5 {ParseBitXorExpr procedure, bad lexeme after "^"} {testexprparser wideIs32bit} { list [catch {testexprparser {1&2 ^ 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-6.6 {ParseBitXorExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1&2 ^ 3 ^ 4} -1 } {- {} 0 subexpr {1&2 ^ 3 ^ 4} 13 operator ^ 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} -test parseExpr-6.7 {ParseBitXorExpr procedure, error in RHS subexpression} testexprparser { - list [catch {testexprparser {1&2 ^ 3 ^ martha} -1} msg] $msg -} {1 {syntax error in expression "1&2 ^ 3 ^ martha": variable references require preceding $}} +test parseExpr-6.7 {ParseBitXorExpr procedure, error in RHS subexpression} \ + -constraints testexprparser -body { + list [catch {testexprparser {1&2 ^ 3 ^ martha} -1} msg] $msg + } -match glob \ + -result {1 {syntax error in expression "1&2 ^ 3 ^ martha": * preceding $*}} test parseExpr-7.1 {ParseBitAndExpr procedure, valid LHS equality subexpr} testexprparser { testexprparser {1==2 & 3} -1 } {- {} 0 subexpr {1==2 & 3} 9 operator & 0 subexpr 1==2 5 operator == 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-7.2 {ParseBitAndExpr procedure, error in LHS equality subexpr} testexprparser { - list [catch {testexprparser {1!=foo & 3} -1} msg] $msg -} {1 {syntax error in expression "1!=foo & 3": variable references require preceding $}} +test parseExpr-7.2 {ParseBitAndExpr procedure, error in LHS equality subexpr} \ + -constraints testexprparser -body { + list [catch {testexprparser {1!=foo & 3} -1} msg] $msg + } -match glob \ + -result {1 {syntax error in expression "1!=foo & 3": * preceding $*}} test parseExpr-7.3 {ParseBitAndExpr procedure, next lexeme isn't "&"} testexprparser { testexprparser {1==2? 1 : 0} -1 } {- {} 0 subexpr {1==2? 1 : 0} 11 operator ? 0 subexpr 1==2 5 operator == 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} test parseExpr-7.4 {ParseBitAndExpr procedure, next lexeme is "&"} testexprparser { testexprparser {1>2 & 3} -1 } {- {} 0 subexpr {1>2 & 3} 9 operator & 0 subexpr 1>2 5 operator > 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-7.5 {ParseBitAndExpr procedure, bad lexeme after "&"} {testexprparser wideIntegerUnparsed} { +test parseExpr-7.5 {ParseBitAndExpr procedure, bad lexeme after "&"} {testexprparser wideIs32bit} { list [catch {testexprparser {1==2 & 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-7.6 {ParseBitAndExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1<2 & 3 & 4} -1 } {- {} 0 subexpr {1<2 & 3 & 4} 13 operator & 0 subexpr {1<2 & 3} 9 operator & 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} -test parseExpr-7.7 {ParseBitAndExpr procedure, error in RHS subexpression} testexprparser { - list [catch {testexprparser {1==2 & 3>2 & martha} -1} msg] $msg -} {1 {syntax error in expression "1==2 & 3>2 & martha": variable references require preceding $}} +test parseExpr-7.7 {ParseBitAndExpr procedure, error in RHS subexpression} \ + -constraints testexprparser -body { + list [catch {testexprparser {1==2 & 3>2 & martha} -1} msg] $msg + } -match glob \ + -result {1 {syntax error in expression "1==2 & 3>2 & martha": * preceding $*}} test parseExpr-8.1 {ParseEqualityExpr procedure, valid LHS relational subexpr} testexprparser { testexprparser {1<2 == 3} -1 } {- {} 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-8.2 {ParseEqualityExpr procedure, error in LHS relational subexpr} testexprparser { - list [catch {testexprparser {1>=foo == 3} -1} msg] $msg -} {1 {syntax error in expression "1>=foo == 3": variable references require preceding $}} +test parseExpr-8.2 {ParseEqualityExpr procedure, error in LHS relational subexpr} \ + -constraints testexprparser -body { + list [catch {testexprparser {1>=foo == 3} -1} msg] $msg + } -match glob \ + -result {1 {syntax error in expression "1>=foo == 3": * preceding $*}} test parseExpr-8.3 {ParseEqualityExpr procedure, next lexeme isn't "==" or "!="} testexprparser { testexprparser {1<2? 1 : 0} -1 } {- {} 0 subexpr {1<2? 1 : 0} 11 operator ? 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} test parseExpr-8.4 {ParseEqualityExpr procedure, next lexeme is "==" or "!="} testexprparser { testexprparser {1<2 == 3} -1 } {- {} 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-8.5 {ParseEqualityExpr procedure, next lexeme is "==" or "!="} testexprparser { testexprparser {1<2 != 3} -1 } {- {} 0 subexpr {1<2 != 3} 9 operator != 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-8.6 {ParseEqualityExpr procedure, bad lexeme after "==" or "!="} {testexprparser wideIntegerUnparsed} { +test parseExpr-8.6 {ParseEqualityExpr procedure, bad lexeme after "==" or "!="} {testexprparser wideIs32bit} { list [catch {testexprparser {1<2 == 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-8.7 {ParseEqualityExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1<2 == 3 == 4} -1 } {- {} 0 subexpr {1<2 == 3 == 4} 13 operator == 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} -test parseExpr-8.8 {ParseEqualityExpr procedure, error in RHS subexpression} testexprparser { - list [catch {testexprparser {1<2 == 3 != martha} -1} msg] $msg -} {1 {syntax error in expression "1<2 == 3 != martha": variable references require preceding $}} +test parseExpr-8.8 {ParseEqualityExpr procedure, error in RHS subexpression} \ + -constraints testexprparser -body { + list [catch {testexprparser {1<2 == 3 != martha} -1} msg] $msg + } -match glob \ + -result {1 {syntax error in expression "1<2 == 3 != martha": * preceding $*}} test parseExpr-9.1 {ParseRelationalExpr procedure, valid LHS shift subexpr} testexprparser { testexprparser {1<<2 < 3} -1 } {- {} 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-9.2 {ParseRelationalExpr procedure, error in LHS shift subexpr} testexprparser { - list [catch {testexprparser {1>=foo < 3} -1} msg] $msg -} {1 {syntax error in expression "1>=foo < 3": variable references require preceding $}} +test parseExpr-9.2 {ParseRelationalExpr procedure, error in LHS shift subexpr} \ + -constraints testexprparser -body { + list [catch {testexprparser {1>=foo < 3} -1} msg] $msg + } -match glob \ + -result {1 {syntax error in expression "1>=foo < 3": * preceding $*}} test parseExpr-9.3 {ParseRelationalExpr procedure, next lexeme isn't relational op} testexprparser { testexprparser {1<<2? 1 : 0} -1 } {- {} 0 subexpr {1<<2? 1 : 0} 11 operator ? 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} test parseExpr-9.4 {ParseRelationalExpr procedure, next lexeme is relational op} testexprparser { testexprparser {1<<2 < 3} -1 @@ -230,99 +322,113 @@ testexprparser {1<<2 <= 3} -1 } {- {} 0 subexpr {1<<2 <= 3} 9 operator <= 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-9.7 {ParseRelationalExpr procedure, next lexeme is relational op} testexprparser { testexprparser {1<<2 >= 3} -1 } {- {} 0 subexpr {1<<2 >= 3} 9 operator >= 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-9.8 {ParseRelationalExpr procedure, bad lexeme after relational op} {testexprparser wideIntegerUnparsed} { +test parseExpr-9.8 {ParseRelationalExpr procedure, bad lexeme after relational op} {testexprparser wideIs32bit} { list [catch {testexprparser {1<<2 < 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-9.9 {ParseRelationalExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1<<2 < 3 < 4} -1 } {- {} 0 subexpr {1<<2 < 3 < 4} 13 operator < 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} -test parseExpr-9.10 {ParseRelationalExpr procedure, error in RHS subexpression} testexprparser { - list [catch {testexprparser {1<<2 < 3 > martha} -1} msg] $msg -} {1 {syntax error in expression "1<<2 < 3 > martha": variable references require preceding $}} +test parseExpr-9.10 {ParseRelationalExpr procedure, error in RHS subexpression} \ + -constraints testexprparser -body { + list [catch {testexprparser {1<<2 < 3 > martha} -1} msg] $msg + } -match glob \ + -result {1 {syntax error in expression "1<<2 < 3 > martha": * preceding $*}} test parseExpr-10.1 {ParseShiftExpr procedure, valid LHS add subexpr} testexprparser { testexprparser {1+2 << 3} -1 } {- {} 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-10.2 {ParseShiftExpr procedure, error in LHS add subexpr} testexprparser { - list [catch {testexprparser {1-foo << 3} -1} msg] $msg -} {1 {syntax error in expression "1-foo << 3": variable references require preceding $}} +test parseExpr-10.2 {ParseShiftExpr procedure, error in LHS add subexpr} \ + -constraints testexprparser -body { + list [catch {testexprparser {1-foo << 3} -1} msg] $msg + } -match glob \ + -result {1 {syntax error in expression "1-foo << 3": * preceding $*}} test parseExpr-10.3 {ParseShiftExpr procedure, next lexeme isn't "<<" or ">>"} testexprparser { testexprparser {1+2? 1 : 0} -1 } {- {} 0 subexpr {1+2? 1 : 0} 11 operator ? 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} test parseExpr-10.4 {ParseShiftExpr procedure, next lexeme is "<<" or ">>"} testexprparser { testexprparser {1+2 << 3} -1 } {- {} 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-10.5 {ParseShiftExpr procedure, next lexeme is "<<" or ">>"} testexprparser { testexprparser {1+2 >> 3} -1 } {- {} 0 subexpr {1+2 >> 3} 9 operator >> 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-10.6 {ParseShiftExpr procedure, bad lexeme after "<<" or ">>"} {testexprparser wideIntegerUnparsed} { +test parseExpr-10.6 {ParseShiftExpr procedure, bad lexeme after "<<" or ">>"} {testexprparser wideIs32bit} { list [catch {testexprparser {1+2 << 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-10.7 {ParseShiftExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1+2 << 3 << 4} -1 } {- {} 0 subexpr {1+2 << 3 << 4} 13 operator << 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} -test parseExpr-10.8 {ParseShiftExpr procedure, error in RHS subexpression} testexprparser { - list [catch {testexprparser {1+2 << 3 >> martha} -1} msg] $msg -} {1 {syntax error in expression "1+2 << 3 >> martha": variable references require preceding $}} +test parseExpr-10.8 {ParseShiftExpr procedure, error in RHS subexpression} \ + -constraints testexprparser -body { + list [catch {testexprparser {1+2 << 3 >> martha} -1} msg] $msg + } -match glob \ + -result {1 {syntax error in expression "1+2 << 3 >> martha": * preceding $*}} test parseExpr-11.1 {ParseAddExpr procedure, valid LHS multiply subexpr} testexprparser { testexprparser {1*2 + 3} -1 } {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-11.2 {ParseAddExpr procedure, error in LHS multiply subexpr} testexprparser { - list [catch {testexprparser {1/foo + 3} -1} msg] $msg -} {1 {syntax error in expression "1/foo + 3": variable references require preceding $}} +test parseExpr-11.2 {ParseAddExpr procedure, error in LHS multiply subexpr} \ + -constraints testexprparser -body { + list [catch {testexprparser {1/foo + 3} -1} msg] $msg + } -match glob \ + -result {1 {syntax error in expression "1/foo + 3": * preceding $*}} test parseExpr-11.3 {ParseAddExpr procedure, next lexeme isn't "+" or "-"} testexprparser { testexprparser {1*2? 1 : 0} -1 } {- {} 0 subexpr {1*2? 1 : 0} 11 operator ? 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} test parseExpr-11.4 {ParseAddExpr procedure, next lexeme is "+" or "-"} testexprparser { testexprparser {1*2 + 3} -1 } {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-11.5 {ParseAddExpr procedure, next lexeme is "+" or "-"} testexprparser { testexprparser {1*2 - 3} -1 } {- {} 0 subexpr {1*2 - 3} 9 operator - 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-11.6 {ParseAddExpr procedure, bad lexeme after "+" or "-"} {testexprparser wideIntegerUnparsed} { +test parseExpr-11.6 {ParseAddExpr procedure, bad lexeme after "+" or "-"} {testexprparser wideIs32bit} { list [catch {testexprparser {1*2 + 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-11.7 {ParseAddExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1*2 + 3 + 4} -1 } {- {} 0 subexpr {1*2 + 3 + 4} 13 operator + 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} -test parseExpr-11.8 {ParseAddExpr procedure, error in RHS subexpression} testexprparser { - list [catch {testexprparser {1*2 + 3 - martha} -1} msg] $msg -} {1 {syntax error in expression "1*2 + 3 - martha": variable references require preceding $}} +test parseExpr-11.8 {ParseAddExpr procedure, error in RHS subexpression} \ + -constraints testexprparser -body { + list [catch {testexprparser {1*2 + 3 - martha} -1} msg] $msg + } -match glob \ + -result {1 {syntax error in expression "1*2 + 3 - martha": * preceding $*}} test parseExpr-12.1 {ParseAddExpr procedure, valid LHS multiply subexpr} testexprparser { testexprparser {1*2 + 3} -1 } {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-12.2 {ParseAddExpr procedure, error in LHS multiply subexpr} testexprparser { - list [catch {testexprparser {1/foo + 3} -1} msg] $msg -} {1 {syntax error in expression "1/foo + 3": variable references require preceding $}} +test parseExpr-12.2 {ParseAddExpr procedure, error in LHS multiply subexpr} \ + -constraints testexprparser -body { + list [catch {testexprparser {1/foo + 3} -1} msg] $msg + } -match glob \ + -result {1 {syntax error in expression "1/foo + 3": * preceding $*}} test parseExpr-12.3 {ParseAddExpr procedure, next lexeme isn't "+" or "-"} testexprparser { testexprparser {1*2? 1 : 0} -1 } {- {} 0 subexpr {1*2? 1 : 0} 11 operator ? 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} test parseExpr-12.4 {ParseAddExpr procedure, next lexeme is "+" or "-"} testexprparser { testexprparser {1*2 + 3} -1 } {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-12.5 {ParseAddExpr procedure, next lexeme is "+" or "-"} testexprparser { testexprparser {1*2 - 3} -1 } {- {} 0 subexpr {1*2 - 3} 9 operator - 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-12.6 {ParseAddExpr procedure, bad lexeme after "+" or "-"} {testexprparser wideIntegerUnparsed} { +test parseExpr-12.6 {ParseAddExpr procedure, bad lexeme after "+" or "-"} {testexprparser wideIs32bit} { list [catch {testexprparser {1*2 + 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-12.7 {ParseAddExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1*2 + 3 + 4} -1 } {- {} 0 subexpr {1*2 + 3 + 4} 13 operator + 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} -test parseExpr-12.8 {ParseAddExpr procedure, error in RHS subexpression} testexprparser { - list [catch {testexprparser {1*2 + 3 - martha} -1} msg] $msg -} {1 {syntax error in expression "1*2 + 3 - martha": variable references require preceding $}} +test parseExpr-12.8 {ParseAddExpr procedure, error in RHS subexpression} \ + -constraints testexprparser -body { + list [catch {testexprparser {1*2 + 3 - martha} -1} msg] $msg + } -match glob \ + -result {1 {syntax error in expression "1*2 + 3 - martha": * preceding $*}} test parseExpr-13.1 {ParseMultiplyExpr procedure, valid LHS unary subexpr} testexprparser { testexprparser {+2 * 3} -1 } {- {} 0 subexpr {+2 * 3} 7 operator * 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} -test parseExpr-13.2 {ParseMultiplyExpr procedure, error in LHS unary subexpr} {testexprparser wideIntegerUnparsed} { +test parseExpr-13.2 {ParseMultiplyExpr procedure, error in LHS unary subexpr} {testexprparser wideIs32bit} { list [catch {testexprparser {-12345678901234567890 * 3} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-13.3 {ParseMultiplyExpr procedure, next lexeme isn't "*", "/", or "%"} testexprparser { testexprparser {+2? 1 : 0} -1 } {- {} 0 subexpr {+2? 1 : 0} 9 operator ? 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} @@ -333,19 +439,21 @@ testexprparser {+-456 / 3} -1 } {- {} 0 subexpr {+-456 / 3} 9 operator / 0 subexpr +-456 5 operator + 0 subexpr -456 3 operator - 0 subexpr 456 1 text 456 0 subexpr 3 1 text 3 0 {}} test parseExpr-13.6 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} testexprparser { testexprparser {+-456 % 3} -1 } {- {} 0 subexpr {+-456 % 3} 9 operator % 0 subexpr +-456 5 operator + 0 subexpr -456 3 operator - 0 subexpr 456 1 text 456 0 subexpr 3 1 text 3 0 {}} -test parseExpr-13.7 {ParseMultiplyExpr procedure, bad lexeme after "*", "/", or "%"} {testexprparser wideIntegerUnparsed} { +test parseExpr-13.7 {ParseMultiplyExpr procedure, bad lexeme after "*", "/", or "%"} {testexprparser wideIs32bit} { list [catch {testexprparser {--++5 / 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-13.8 {ParseMultiplyExpr procedure, valid RHS subexpression} testexprparser { testexprparser {-2 / 3 % 4} -1 } {- {} 0 subexpr {-2 / 3 % 4} 11 operator % 0 subexpr {-2 / 3} 7 operator / 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} -test parseExpr-13.9 {ParseMultiplyExpr procedure, error in RHS subexpression} testexprparser { - list [catch {testexprparser {++2 / 3 * martha} -1} msg] $msg -} {1 {syntax error in expression "++2 / 3 * martha": variable references require preceding $}} +test parseExpr-13.9 {ParseMultiplyExpr procedure, error in RHS subexpression} \ + -constraints testexprparser -body { + list [catch {testexprparser {++2 / 3 * martha} -1} msg] $msg + } -match glob \ + -result {1 {syntax error in expression "++2 / 3 * martha": * preceding $*}} test parseExpr-14.1 {ParseUnaryExpr procedure, first token is unary operator} testexprparser { testexprparser {+2} -1 } {- {} 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 {}} test parseExpr-14.2 {ParseUnaryExpr procedure, first token is unary operator} testexprparser { @@ -355,11 +463,11 @@ testexprparser {~2} -1 } {- {} 0 subexpr ~2 3 operator ~ 0 subexpr 2 1 text 2 0 {}} test parseExpr-14.4 {ParseUnaryExpr procedure, first token is unary operator} testexprparser { testexprparser {!2} -1 } {- {} 0 subexpr !2 3 operator ! 0 subexpr 2 1 text 2 0 {}} -test parseExpr-14.5 {ParseUnaryExpr procedure, error in lexeme after unary op} {testexprparser wideIntegerUnparsed} { +test parseExpr-14.5 {ParseUnaryExpr procedure, error in lexeme after unary op} {testexprparser wideIs32bit} { list [catch {testexprparser {-12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-14.6 {ParseUnaryExpr procedure, simple unary expr after unary op} testexprparser { testexprparser {+"1234"} -1 } {- {} 0 subexpr +\"1234\" 3 operator + 0 subexpr {"1234"} 1 text 1234 0 {}} @@ -376,18 +484,18 @@ testexprparser {123} -1 } {- {} 0 subexpr 123 1 text 123 0 {}} test parseExpr-14.11 {ParseUnaryExpr procedure, not unary expr, complex primary expr} testexprparser { testexprparser {(1+2)} -1 } {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} -test parseExpr-14.12 {ParseUnaryExpr procedure, not unary expr, error in primary expr} {testexprparser wideIntegerUnparsed} { +test parseExpr-14.12 {ParseUnaryExpr procedure, not unary expr, error in primary expr} {testexprparser wideIs32bit} { list [catch {testexprparser {(12345678901234567890)} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-15.1 {ParsePrimaryExpr procedure, just parenthesized subexpr} testexprparser { testexprparser {({abc}/{def})} -1 } {- {} 0 subexpr {{abc}/{def}} 5 operator / 0 subexpr {{abc}} 1 text abc 0 subexpr {{def}} 1 text def 0 {}} -test parseExpr-15.2 {ParsePrimaryExpr procedure, bad lexeme after "("} {testexprparser wideIntegerUnparsed} { +test parseExpr-15.2 {ParsePrimaryExpr procedure, bad lexeme after "("} {testexprparser wideIs32bit} { list [catch {testexprparser {(12345678901234567890)} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-15.3 {ParsePrimaryExpr procedure, valid parenthesized subexpr} testexprparser { testexprparser {({abc}? 2*4 : -6)} -1 } {- {} 0 subexpr {{abc}? 2*4 : -6} 13 operator ? 0 subexpr {{abc}} 1 text abc 0 subexpr 2*4 5 operator * 0 subexpr 2 1 text 2 0 subexpr 4 1 text 4 0 subexpr -6 3 operator - 0 subexpr 6 1 text 6 0 {}} @@ -447,17 +555,19 @@ +123 \}" -1 } {- {} 0 subexpr \{\ \ \\\n\ +123\ \} 4 word \{\ \ \\\n\ +123\ \} 3 text { } 0 backslash \\\n\ 0 text {+123 } 0 {}} test parseExpr-15.22 {ParsePrimaryExpr procedure, primary is function call} testexprparser { testexprparser {foo(123)} -1 } {- {} 0 subexpr foo(123) 3 operator foo 0 subexpr 123 1 text 123 0 {}} -test parseExpr-15.23 {ParsePrimaryExpr procedure, bad lexeme after function name} {testexprparser wideIntegerUnparsed} { +test parseExpr-15.23 {ParsePrimaryExpr procedure, bad lexeme after function name} {testexprparser wideIs32bit} { list [catch {testexprparser {foo 12345678901234567890 123)} -1} msg] $msg } {1 {integer value too large to represent}} -test parseExpr-15.24 {ParsePrimaryExpr procedure, lexeme after function name isn't "("} testexprparser { - list [catch {testexprparser {foo 27.4 123)} -1} msg] $msg -} {1 {syntax error in expression "foo 27.4 123)": variable references require preceding $}} -test parseExpr-15.25 {ParsePrimaryExpr procedure, bad lexeme after "("} {testexprparser wideIntegerUnparsed} { +test parseExpr-15.24 {ParsePrimaryExpr procedure, lexeme after function name isn't "("} \ + -constraints testexprparser -body { + list [catch {testexprparser {foo 27.4 123)} -1} msg] $msg + } -match glob \ + -result {1 {syntax error in expression "foo 27.4 123)": * preceding $*}} +test parseExpr-15.25 {ParsePrimaryExpr procedure, bad lexeme after "("} {testexprparser wideIs32bit} { list [catch {testexprparser {foo(12345678901234567890)} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-15.26 {ParsePrimaryExpr procedure, function call, one arg} testexprparser { testexprparser {foo(27*4)} -1 } {- {} 0 subexpr foo(27*4) 7 operator foo 0 subexpr 27*4 5 operator * 0 subexpr 27 1 text 27 0 subexpr 4 1 text 4 0 {}} @@ -468,17 +578,17 @@ list [catch {testexprparser {foo(*1-2)} -1} msg] $msg } {1 {syntax error in expression "foo(*1-2)": unexpected operator *}} test parseExpr-15.29 {ParsePrimaryExpr procedure, function call, comma after arg} testexprparser { testexprparser {foo(27-2, (-2*[foo]))} -1 } {- {} 0 subexpr {foo(27-2, (-2*[foo]))} 15 operator foo 0 subexpr 27-2 5 operator - 0 subexpr 27 1 text 27 0 subexpr 2 1 text 2 0 subexpr {-2*[foo]} 7 operator * 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 subexpr {[foo]} 1 command {[foo]} 0 {}} -test parseExpr-15.30 {ParsePrimaryExpr procedure, bad lexeme after comma} {testexprparser wideIntegerUnparsed} { +test parseExpr-15.30 {ParsePrimaryExpr procedure, bad lexeme after comma} {testexprparser wideIs32bit} { list [catch {testexprparser {foo(123, 12345678901234567890)} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-15.31 {ParsePrimaryExpr procedure, lexeme not "," or ")" after arg} testexprparser { list [catch {testexprparser {foo(123 [foo])} -1} msg] $msg } {1 {syntax error in expression "foo(123 [foo])": missing close parenthesis at end of function call}} -test parseExpr-15.32 {ParsePrimaryExpr procedure, bad lexeme after primary} {testexprparser wideIntegerUnparsed} { +test parseExpr-15.32 {ParsePrimaryExpr procedure, bad lexeme after primary} {testexprparser wideIs32bit} { list [catch {testexprparser {123 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-15.33 {ParsePrimaryExpr procedure, comma-specific message} testexprparser { list [catch {testexprparser {123+,456} -1} msg] $msg } {1 {syntax error in expression "123+,456": commas can only separate function arguments}} @@ -505,11 +615,11 @@ } -1 } {- {} 0 subexpr 123 1 text 123 0 {}} test parseExpr-16.4 {GetLexeme procedure, integer lexeme} testexprparser { testexprparser {000} -1 } {- {} 0 subexpr 000 1 text 000 0 {}} -test parseExpr-16.5 {GetLexeme procedure, integer lexeme too big} {testexprparser wideIntegerUnparsed} { +test parseExpr-16.5 {GetLexeme procedure, integer lexeme too big} {testexprparser wideIs32bit} { list [catch {testexprparser {12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-16.6 {GetLexeme procedure, bad integer lexeme} -constraints testexprparser -body { testexprparser {0999} -1 } -returnCodes error -match glob -result {*invalid octal number*} @@ -517,19 +627,22 @@ testexprparser {0.999} -1 } {- {} 0 subexpr 0.999 1 text 0.999 0 {}} test parseExpr-16.8 {GetLexeme procedure, double lexeme} testexprparser { testexprparser {.123} -1 } {- {} 0 subexpr .123 1 text .123 0 {}} -test parseExpr-16.9 {GetLexeme procedure, double lexeme} {testexprparser nonPortable unix} { +test parseExpr-16.9 {GetLexeme procedure, double lexeme} {testexprparser unix} { testexprparser {nan} -1 } {- {} 0 subexpr nan 1 text nan 0 {}} -test parseExpr-16.10 {GetLexeme procedure, double lexeme} {testexprparser nonPortable unix} { +test parseExpr-16.10 {GetLexeme procedure, double lexeme} {testexprparser unix} { testexprparser {NaN} -1 } {- {} 0 subexpr NaN 1 text NaN 0 {}} -test parseExpr-16.11 {GetLexeme procedure, bad double lexeme too big} testexprparser { +test parseExpr-16.11a {GetLexeme procedure, bad double lexeme too big} {testexprparser && !ieeeFloatingPoint} { list [catch {testexprparser {123.e+99999999999999} -1} msg] $msg } {1 {floating-point value too large to represent}} +test parseExpr-16.11b {GetLexeme procedure, bad double lexeme too big} {testexprparser && ieeeFloatingPoint} { + list [catch {testexprparser {123.e+99999999999999} -1} msg] $msg +} {0 {- {} 0 subexpr 123.e+99999999999999 1 text 123.e+99999999999999 0 {}}} test parseExpr-16.12 {GetLexeme procedure, bad double lexeme} testexprparser { list [catch {testexprparser {123.4x56} -1} msg] $msg } {1 {syntax error in expression "123.4x56": extra tokens at end of expression}} test parseExpr-16.13 {GetLexeme procedure, lexeme is "["} testexprparser { testexprparser {[foo]} -1 Index: tests/regexp.test ================================================================== --- tests/regexp.test +++ tests/regexp.test @@ -9,11 +9,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: regexp.test,v 1.25 2003/10/14 18:23:31 vincentdarley Exp $ +# RCS: @(#) $Id: regexp.test,v 1.25.2.1 2005/05/05 17:56:19 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -218,11 +218,11 @@ set f1 44 list [catch {regexp abc abc f1(f2)} msg] $msg } {1 {couldn't set variable "f1(f2)"}} test regexp-6.9 {regexp errors, -start bad int check} { list [catch {regexp -start bogus {^$} {}} msg] $msg -} {1 {expected integer but got "bogus"}} +} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} test regexp-7.1 {basic regsub operation} { list [regsub aa+ xaxaaaxaa 111&222 foo] $foo } {1 xax111aaa222xaa} test regexp-7.2 {basic regsub operation} { @@ -375,11 +375,11 @@ set f1 44 list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg } {1 {couldn't set variable "f1(f2)"}} test regexp-11.8 {regsub errors, -start bad int check} { list [catch {regsub -start bogus pattern string rep var} msg] $msg -} {1 {expected integer but got "bogus"}} +} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} test regexp-11.9 {regsub without final variable name returns value} { regsub b abaca X } {aXaca} test regexp-11.10 {regsub without final variable name returns value} { regsub -all a abaca X @@ -465,10 +465,24 @@ list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x] } {0 0} test regexp-15.6 {regexp -start, loss of ^$ behavior} { list [regexp -start 2 {^$} {}] } {0} +test regexp-15.7 {regexp -start, double option} { + regexp -start 2 -start 0 a abc +} 1 +test regexp-15.8 {regexp -start, double option} { + regexp -start 0 -start 2 a abc +} 0 +test regexp-15.9 {regexp -start, end relative index} { + catch {unset x} + list [regexp -start end {\d} 1abc2de3 x] [info exists x] +} {0 0} +test regexp-15.10 {regexp -start, end relative index} { + catch {unset x} + list [regexp -start end-1 {\d} 1abc2de3 x] [info exists x] $x +} {1 1 3} test regexp-16.1 {regsub -start} { catch {unset x} list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x } {4 a1b/2c/3d/4e/5} @@ -483,10 +497,22 @@ test regexp-16.4 {regsub -start, \A behavior} { set out {} lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x } {5 /a/b/c/d/e 3 ab/c/d/e} +test regexp-16.5 {regsub -start, double option} { + list [regsub -start 2 -start 0 a abc c x] $x +} {1 cbc} +test regexp-16.6 {regsub -start, double option} { + list [regsub -start 0 -start 2 a abc c x] $x +} {0 abc} +test regexp-16.7 {regexp -start, end relative index} { + list [regsub -start end a aaa b x] $x +} {0 aaa} +test regexp-16.8 {regexp -start, end relative index} { + list [regsub -start end-1 a aaa b x] $x +} {1 aab} test regexp-17.1 {regexp -inline} { regexp -inline b ababa } {b} test regexp-17.2 {regexp -inline} { Index: tests/regexpComp.test ================================================================== --- tests/regexpComp.test +++ tests/regexpComp.test @@ -299,11 +299,11 @@ } {1 {couldn't set variable "f1(f2)"}} test regexpComp-6.9 {regexp errors, -start bad int check} { evalInProc { list [catch {regexp -start bogus {^$} {}} msg] $msg } -} {1 {expected integer but got "bogus"}} +} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} test regexpComp-7.1 {basic regsub operation} { evalInProc { list [regsub aa+ xaxaaaxaa 111&222 foo] $foo } @@ -540,11 +540,11 @@ } {1 {couldn't set variable "f1(f2)"}} test regexpComp-11.8 {regsub errors, -start bad int check} { evalInProc { list [catch {regsub -start bogus pattern string rep var} msg] $msg } -} {1 {expected integer but got "bogus"}} +} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} # This test crashes on the Mac unless you increase the Stack Space to about 1 # Meg. This is probably bigger than most users want... # 8.2.3 regexp reduced stack space requirements, but this should be # tested again Index: tests/result.test ================================================================== --- tests/result.test +++ tests/result.test @@ -106,9 +106,22 @@ } 1 test result-5.4 {Tcl_SetErrorCode - two args, list quoting} testseterrorcode { catch {testseterrorcode {a b} c} set errorCode } {{a b} c} + +::tcltest::testConstraint testreturn \ + [expr {[info commands testreturn] != {}}] +test result-6.0 {Bug 1209759} -constraints testreturn -body { + # Might panic if bug is not fixed. + proc foo {} {testreturn} + foo +} -returnCodes ok -result {} +test result-6.1 {Bug 1209759} -constraints testreturn -body { + # Might panic if bug is not fixed. + proc foo {} {catch {return -level 2}; testreturn} + foo +} -returnCodes ok -result {} # cleanup ::tcltest::cleanupTests return Index: tests/safe.test ================================================================== --- tests/safe.test +++ tests/safe.test @@ -8,11 +8,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: safe.test,v 1.17 2004/08/18 19:59:08 kennykb Exp $ +# RCS: @(#) $Id: safe.test,v 1.17.2.1 2004/12/08 18:24:36 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } @@ -19,10 +19,13 @@ foreach i [interp slaves] { interp delete $i } +set saveAutoPath $::auto_path +set ::auto_path [info library] + # Force actual loading of the safe package # because we use un exported (and thus un-autoindexed) APIs # in this test result arguments: catch {safe::interpConfigure} @@ -476,8 +479,9 @@ $msg \ [safe::interpDelete $i]; } {1 {wrong # args: should be "encoding convertto ?encoding? data"} {}} +set ::auto_path $saveAutoPath # cleanup ::tcltest::cleanupTests return Index: tests/scan.test ================================================================== --- tests/scan.test +++ tests/scan.test @@ -9,18 +9,19 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # 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.15 2004/08/19 20:59:00 dkf Exp $ +# RCS: @(#) $Id: scan.test,v 1.15.2.5 2005/08/23 18:28:52 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } -::tcltest::testConstraint 64bitInts [expr {0x80000000 > 0}] +::tcltest::testConstraint wideIs64bit \ + [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] test scan-1.1 {BuildCharSet, CharInSet} { list [scan foo {%[^o]} x] $x } {1 f} test scan-1.2 {BuildCharSet, CharInSet} { @@ -338,13 +339,14 @@ } {1 {couldn't set variable "z"couldn't set variable "y"} abc} # 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] } test scan-4.62 {scanning of large and negative octal integers} { @@ -415,11 +417,11 @@ test scan-5.11 {integer scanning} {nonPortable} { set a {}; set b {}; list [scan "4294967280 4294967280" "%u %d" a b] $a \ [expr {$b == -16 || $b == 0x7fffffff}] } {2 4294967280 1} -test scan-5.12 {integer scanning} {64bitInts} { +test scan-5.12 {integer scanning} {wideIs64bit} { set a {}; set b {}; set c {} list [scan "7810179016327718216,6c63546f6c6c6548,661432506755433062510" \ %ld,%lx,%lo a b c] $a $b $c } {3 7810179016327718216 7810179016327718216 7810179016327718216} test scan-5.13 {integer scanning and overflow} { @@ -449,14 +451,14 @@ } {3 1.0 200.0 3.0} test scan-6.5 {floating-point scanning} { set a {}; set b {}; set c {}; set d {} list [scan "4.6 99999.7 876.43e-1 118" "%f %f %f %e" a b c d] $a $b $c $d } {4 4.6 99999.7 87.643 118.0} -test scan-6.6 {floating-point scanning} {eformat} { +test scan-6.6 {floating-point scanning} { set a {}; set b {}; set c {}; set d {} list [scan "1.2345 697.0e-3 124 .00005" "%f %e %f %e" a b c d] $a $b $c $d -} {4 1.2345 0.697 124.0 5e-05} +} {4 1.2345 0.697 124.0 5e-5} test scan-6.7 {floating-point scanning} { set a {}; set b {}; set c {}; set d {} list [scan "4.6abc" "%f %f %f %f" a b c d] $a $b $c $d } {1 4.6 {} {} {}} test scan-6.8 {floating-point scanning} { @@ -676,8 +678,84 @@ test scan-13.8 {Tcl_ScanObjCmd, inline XPG case lots of arguments} { set msg [scan "10 20 30" {%100$d %5$d %200$d}] 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: Index: tests/socket.test ================================================================== --- tests/socket.test +++ tests/socket.test @@ -8,11 +8,11 @@ # Copyright (c) 1998-2000 Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: socket.test,v 1.36 2004/11/18 19:22:14 dgp Exp $ +# RCS: @(#) $Id: socket.test,v 1.36.2.1 2005/08/02 18:16:43 dgp Exp $ # Running socket tests with a remote server: # ------------------------------------------ # # Some tests in socket.test depend on the existence of a remote server to @@ -199,48 +199,38 @@ test socket-1.1 {arg parsing for socket command} {socket} { list [catch {socket -server} msg] $msg } {1 {no argument given for -server option}} test socket-1.2 {arg parsing for socket command} {socket} { list [catch {socket -server foo} msg] $msg -} {1 {wrong # args: should be either: -socket ?-myaddr addr? ?-myport myport? ?-async? host port -socket -server command ?-myaddr addr? port}} +} {1 {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}} test socket-1.3 {arg parsing for socket command} {socket} { list [catch {socket -myaddr} msg] $msg } {1 {no argument given for -myaddr option}} test socket-1.4 {arg parsing for socket command} {socket} { list [catch {socket -myaddr 127.0.0.1} msg] $msg -} {1 {wrong # args: should be either: -socket ?-myaddr addr? ?-myport myport? ?-async? host port -socket -server command ?-myaddr addr? port}} +} {1 {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}} test socket-1.5 {arg parsing for socket command} {socket} { list [catch {socket -myport} msg] $msg } {1 {no argument given for -myport option}} test socket-1.6 {arg parsing for socket command} {socket} { list [catch {socket -myport xxxx} msg] $msg } {1 {expected integer but got "xxxx"}} test socket-1.7 {arg parsing for socket command} {socket} { list [catch {socket -myport 2522} msg] $msg -} {1 {wrong # args: should be either: -socket ?-myaddr addr? ?-myport myport? ?-async? host port -socket -server command ?-myaddr addr? port}} +} {1 {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}} test socket-1.8 {arg parsing for socket command} {socket} { list [catch {socket -froboz} msg] $msg } {1 {bad option "-froboz": must be -async, -myaddr, -myport, or -server}} test socket-1.9 {arg parsing for socket command} {socket} { list [catch {socket -server foo -myport 2521 3333} msg] $msg } {1 {Option -myport is not valid for servers}} test socket-1.10 {arg parsing for socket command} {socket} { list [catch {socket host 2528 -junk} msg] $msg -} {1 {wrong # args: should be either: -socket ?-myaddr addr? ?-myport myport? ?-async? host port -socket -server command ?-myaddr addr? port}} +} {1 {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}} test socket-1.11 {arg parsing for socket command} {socket} { list [catch {socket -server callback 2520 --} msg] $msg -} {1 {wrong # args: should be either: -socket ?-myaddr addr? ?-myport myport? ?-async? host port -socket -server command ?-myaddr addr? port}} +} {1 {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}} test socket-1.12 {arg parsing for socket command} {socket} { list [catch {socket foo badport} msg] $msg } {1 {expected integer but got "badport"}} test socket-1.13 {arg parsing for socket command} {socket} { list [catch {socket -async -server} msg] $msg Index: tests/string.test ================================================================== --- tests/string.test +++ tests/string.test @@ -10,20 +10,21 @@ # Copyright (c) 2001 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: string.test,v 1.43 2004/10/28 00:04:39 dgp Exp $ +# RCS: @(#) $Id: string.test,v 1.43.2.7 2005/08/17 04:57:49 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } # Some tests require the testobj command testConstraint testobj [expr {[info commands testobj] != {}}] +testConstraint testindexobj [expr {[info commands testindexobj] != {}}] test string-1.1 {error conditions} { list [catch {string gorp a b} msg] $msg } {1 {bad option "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart}} test string-1.2 {error conditions} { @@ -173,11 +174,11 @@ test string-4.1 {string first, too few args} { list [catch {string first a} msg] $msg } {1 {wrong # args: should be "string first subString string ?startIndex?"}} test string-4.2 {string first, bad args} { list [catch {string first a b c} msg] $msg -} {1 {bad index "c": must be integer or end?-integer?}} +} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}} test string-4.3 {string first, too many args} { list [catch {string first a b 5 d} msg] $msg } {1 {wrong # args: should be "string first subString string ?startIndex?"}} test string-4.4 {string first} { string first bq abcdefgbcefgbqrs @@ -238,11 +239,11 @@ test string-5.6 {string index} { list [catch {string index abcde -10} msg] $msg } {0 {}} test string-5.7 {string index} { list [catch {string index a xyz} msg] $msg -} {1 {bad index "xyz": must be integer or end?-integer?}} +} {1 {bad index "xyz": must be integer?[+-]integer? or end?[+-]integer?}} test string-5.8 {string index} { string index abc end } c test string-5.9 {string index} { string index abc end-1 @@ -273,14 +274,14 @@ binary scan $str H* dump string compare [string index $str 10] \x00 } 0 test string-5.17 {string index, bad integer} { list [catch {string index "abc" 08} msg] $msg -} {1 {bad index "08": must be integer or end?-integer? (looks like invalid octal number)}} +} {1 {bad index "08": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}} test string-5.18 {string index, bad integer} { list [catch {string index "abc" end-00289} msg] $msg -} {1 {bad index "end-00289": must be integer or end?-integer? (looks like invalid octal number)}} +} {1 {bad index "end-00289": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}} test string-5.19 {string index, bytearray object out of bounds} { string index [binary format I* {0x50515253 0x52}] -1 } {} test string-5.20 {string index, bytearray object out of bounds} { string index [binary format I* {0x50515253 0x52}] 20 @@ -290,11 +291,11 @@ proc largest_int {} { # This will give us what the largest valid int on this machine is, # 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}] } test string-6.1 {string is, too few args} { list [catch {string is} msg] $msg @@ -407,18 +408,17 @@ } {0 0} test string-6.37 {string is double, false on int overflow} { # Make it the largest int recognizable, with one more digit for overflow list [string is double -fail var [largest_int]0] $var } {0 -1} -test string-6.38 {string is double, false on underflow} { - catch {unset var} - list [string is double -fail var 123e-9999] $var -} {0 -1} -test string-6.39 {string is double, false} {nonPortable} { +# string-6.38 removed, underflow on input is no longer an error. +test string-6.39 {string is double, false} { # This test is non-portable because IRIX thinks # that .e1 is a valid double - this is really a bug # on IRIX as .e1 should NOT be a valid double + # + # Portable now. Tcl 8.5 does its own double parsing. list [string is double -fail var .e1] $var } {0 0} test string-6.40 {string is false, true} { string is false false @@ -664,11 +664,11 @@ test string-7.1 {string last, too few args} { list [catch {string last a} msg] $msg } {1 {wrong # args: should be "string last subString string ?startIndex?"}} test string-7.2 {string last, bad args} { list [catch {string last a b c} msg] $msg -} {1 {bad index "c": must be integer or end?-integer?}} +} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}} test string-7.3 {string last, too many args} { list [catch {string last a b c d} msg] $msg } {1 {wrong # args: should be "string last subString string ?startIndex?"}} test string-7.4 {string last} { string la xxx xxxx123xx345x678 @@ -806,11 +806,41 @@ } baroo test string-10.20 {string map, dictionaries can alter map ordering} { set map {aa X a Y} list [string map [dict create aa X a Y] aaa] [string map $map aaa] [dict size $map] [string map $map aaa] } {YYY XY 2 XY} -test string-10.21 {string map, nasty sharing crash from [Bug 1018562]} { +test string-10.21 {string map, ABR checks} { + string map {longstring foob} long +} long +test string-10.22 {string map, ABR checks} { + string map {long foob} long +} foob +test string-10.23 {string map, ABR checks} { + string map {lon foob} long +} foobg +test string-10.24 {string map, ABR checks} { + string map {lon foob} longlo +} foobglo +test string-10.25 {string map, ABR checks} { + string map {lon foob} longlon +} foobgfoob +test string-10.26 {string map, ABR checks} { + string map {longstring foob longstring bar} long +} long +test string-10.27 {string map, ABR checks} { + string map {long foob longstring bar} long +} foob +test string-10.28 {string map, ABR checks} { + string map {lon foob longstring bar} long +} foobg +test string-10.29 {string map, ABR checks} { + string map {lon foob longstring bar} longlo +} foobglo +test string-10.30 {string map, ABR checks} { + string map {lon foob longstring bar} longlon +} foobgfoob +test string-10.31 {string map, nasty sharing crash from [Bug 1018562]} { set a {a b} string map $a $a } {b b} test string-11.1 {string match, too few args} { @@ -1019,11 +1049,11 @@ } {cdefghijklmno} test string-12.5 {string range, last > length} { string range abcdefghijklmnop 7 1000 } {hijklmnop} test string-12.6 {string range} { - string range abcdefghijklmnop 10 e + string range abcdefghijklmnop 10 end } {klmnop} test string-12.7 {string range, last < first} { string range abcdefghijklmnop 10 9 } {} test string-12.8 {string range, first < 0} { @@ -1038,19 +1068,19 @@ test string-12.11 {string range} { string range abcdefghijklmnop -100 end } {abcdefghijklmnop} test string-12.12 {string range} { list [catch {string range abc abc 1} msg] $msg -} {1 {bad index "abc": must be integer or end?-integer?}} +} {1 {bad index "abc": must be integer?[+-]integer? or end?[+-]integer?}} test string-12.13 {string range} { list [catch {string range abc 1 eof} msg] $msg -} {1 {bad index "eof": must be integer or end?-integer?}} +} {1 {bad index "eof": must be integer?[+-]integer? or end?[+-]integer?}} test string-12.14 {string range} { string range abcdefghijklmnop end-1 end } {op} test string-12.15 {string range} { - string range abcdefghijklmnop e 1000 + string range abcdefghijklmnop end 1000 } {p} test string-12.16 {string range} { string range abcdefghijklmnop end end-1 } {} test string-12.17 {string range, unicode} { @@ -1129,11 +1159,11 @@ } {abp} test string-14.6 {string replace} { string replace abcdefghijklmnop 7 1000 } {abcdefg} test string-14.7 {string replace} { - string replace abcdefghijklmnop 10 e + string replace abcdefghijklmnop 10 end } {abcdefghij} test string-14.8 {string replace} { string replace abcdefghijklmnop 10 9 } {abcdefghijklmnop} test string-14.9 {string replace} { @@ -1148,19 +1178,19 @@ test string-14.12 {string replace} { string replace abcdefghijklmnop -100 end } {} test string-14.13 {string replace} { list [catch {string replace abc abc 1} msg] $msg -} {1 {bad index "abc": must be integer or end?-integer?}} +} {1 {bad index "abc": must be integer?[+-]integer? or end?[+-]integer?}} test string-14.14 {string replace} { list [catch {string replace abc 1 eof} msg] $msg -} {1 {bad index "eof": must be integer or end?-integer?}} +} {1 {bad index "eof": must be integer?[+-]integer? or end?[+-]integer?}} test string-14.15 {string replace} { string replace abcdefghijklmnop end-10 end-2 NEW } {abcdeNEWop} test string-14.16 {string replace} { - string replace abcdefghijklmnop 0 e foo + string replace abcdefghijklmnop 0 end foo } {foo} test string-14.17 {string replace} { string replace abcdefghijklmnop end end-1 } {abcdefghijklmnop} @@ -1167,11 +1197,11 @@ test string-15.1 {string tolower too few args} { list [catch {string tolower} msg] $msg } {1 {wrong # args: should be "string tolower string ?first? ?last?"}} test string-15.2 {string tolower bad args} { list [catch {string tolower a b} msg] $msg -} {1 {bad index "b": must be integer or end?-integer?}} +} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}} test string-15.3 {string tolower too many args} { list [catch {string tolower ABC 1 end oops} msg] $msg } {1 {wrong # args: should be "string tolower string ?first? ?last?"}} test string-15.4 {string tolower} { string tolower ABCDeF @@ -1198,11 +1228,11 @@ test string-16.1 {string toupper} { list [catch {string toupper} msg] $msg } {1 {wrong # args: should be "string toupper string ?first? ?last?"}} test string-16.2 {string toupper} { list [catch {string toupper a b} msg] $msg -} {1 {bad index "b": must be integer or end?-integer?}} +} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}} test string-16.3 {string toupper} { list [catch {string toupper a 1 end oops} msg] $msg } {1 {wrong # args: should be "string toupper string ?first? ?last?"}} test string-16.4 {string toupper} { string toupper abCDEf @@ -1229,11 +1259,11 @@ test string-17.1 {string totitle} { list [catch {string totitle} msg] $msg } {1 {wrong # args: should be "string totitle string ?first? ?last?"}} test string-17.2 {string totitle} { list [catch {string totitle a b} msg] $msg -} {1 {bad index "b": must be integer or end?-integer?}} +} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}} test string-17.3 {string totitle} { string totitle abCDEf } {Abcdef} test string-17.4 {string totitle} { string totitle "abc xYz" @@ -1311,11 +1341,11 @@ test string-21.2 {string wordend} { list [catch {string wordend a b c} msg] $msg } {1 {wrong # args: should be "string wordend string index"}} test string-21.3 {string wordend} { list [catch {string wordend a gorp} msg] $msg -} {1 {bad index "gorp": must be integer or end?-integer?}} +} {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}} test string-21.4 {string wordend} { string wordend abc. -1 } 3 test string-21.5 {string wordend} { string wordend abc. 100 @@ -1357,11 +1387,11 @@ test string-22.3 {string wordstart} { list [catch {string wordstart a b c} msg] $msg } {1 {wrong # args: should be "string wordstart string index"}} test string-22.4 {string wordstart} { list [catch {string wordstart a gorp} msg] $msg -} {1 {bad index "gorp": must be integer or end?-integer?}} +} {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}} test string-22.5 {string wordstart} { string wordstart "one two three_words" 400 } 8 test string-22.6 {string wordstart} { string wordstart "one two three_words" 2 @@ -1385,13 +1415,67 @@ string wordstart "ab\uc700\uc700 cdef ghi" 12 } 10 test string-22.13 {string wordstart, unicode} { string wordstart "\uc700\uc700 abc" 8 } 3 + +test string-23.0 {string is boolean, Bug 1187123} testindexobj { + set x 5 + catch {testindexobj $x foo bar soom} + string is boolean $x +} 0 + +test string-23.1 {string is command with empty string} { + set s "" + list \ + [string is alnum $s] \ + [string is alpha $s] \ + [string is ascii $s] \ + [string is control $s] \ + [string is boolean $s] \ + [string is digit $s] \ + [string is double $s] \ + [string is false $s] \ + [string is graph $s] \ + [string is integer $s] \ + [string is lower $s] \ + [string is print $s] \ + [string is punct $s] \ + [string is space $s] \ + [string is true $s] \ + [string is upper $s] \ + [string is wordchar $s] \ + [string is xdigit $s] \ + +} {1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1} + +test string-23.2 {string is command with empty string} { + set s "" + list \ + [string is alnum -strict $s] \ + [string is alpha -strict $s] \ + [string is ascii -strict $s] \ + [string is control -strict $s] \ + [string is boolean -strict $s] \ + [string is digit -strict $s] \ + [string is double -strict $s] \ + [string is false -strict $s] \ + [string is graph -strict $s] \ + [string is integer -strict $s] \ + [string is lower -strict $s] \ + [string is print -strict $s] \ + [string is punct -strict $s] \ + [string is space -strict $s] \ + [string is true -strict $s] \ + [string is upper -strict $s] \ + [string is wordchar -strict $s] \ + [string is xdigit -strict $s] \ + +} {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} # cleanup ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: Index: tests/stringComp.test ================================================================== --- tests/stringComp.test +++ tests/stringComp.test @@ -13,11 +13,11 @@ # Copyright (c) 2001 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: stringComp.test,v 1.8 2004/05/25 18:58:05 dgp Exp $ +# RCS: @(#) $Id: stringComp.test,v 1.8.2.1 2005/05/05 17:56:36 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } @@ -224,11 +224,11 @@ list [catch {foo} msg] $msg } {1 {wrong # args: should be "string first subString string ?startIndex?"}} test stringComp-4.2 {string first, bad args} { proc foo {} {string first a b c} list [catch {foo} msg] $msg -} {1 {bad index "c": must be integer or end?-integer?}} +} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}} test stringComp-4.3 {string first, too many args} { proc foo {} {string first a b 5 d} list [catch {foo} msg] $msg } {1 {wrong # args: should be "string first subString string ?startIndex?"}} test stringComp-4.4 {string first} { @@ -301,11 +301,11 @@ list [catch {foo} msg] $msg } {0 {}} test stringComp-5.7 {string index} { proc foo {} {string index a xyz} list [catch {foo} msg] $msg -} {1 {bad index "xyz": must be integer or end?-integer?}} +} {1 {bad index "xyz": must be integer?[+-]integer? or end?[+-]integer?}} test stringComp-5.8 {string index} { proc foo {} {string index abc end} foo } c test stringComp-5.9 {string index} { @@ -350,15 +350,15 @@ foo } 0 test stringComp-5.17 {string index, bad integer} { proc foo {} {string index "abc" 08} list [catch {foo} msg] $msg -} {1 {bad index "08": must be integer or end?-integer? (looks like invalid octal number)}} +} {1 {bad index "08": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}} test stringComp-5.18 {string index, bad integer} { proc foo {} {string index "abc" end-00289} list [catch {foo} msg] $msg -} {1 {bad index "end-00289": must be integer or end?-integer? (looks like invalid octal number)}} +} {1 {bad index "end-00289": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}} test stringComp-5.19 {string index, bytearray object out of bounds} { proc foo {} {string index [binary format I* {0x50515253 0x52}] -1} foo } {} test stringComp-5.20 {string index, bytearray object out of bounds} { Index: tests/switch.test ================================================================== --- tests/switch.test +++ tests/switch.test @@ -9,11 +9,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: switch.test,v 1.10 2003/12/14 18:32:36 dkf Exp $ +# RCS: @(#) $Id: switch.test,v 1.10.2.2 2005/07/12 20:37:12 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } @@ -37,10 +37,22 @@ switch default a {format 1} default {format 2} c {format 3} default {format 4} } 2 test switch-1.7 {simple patterns} { switch x a {format 1} default {format 2} c {format 3} default {format 4} } 4 +test switch-1.8 {simple patterns with -nocase} { + switch -nocase b a {format 1} b {format 2} c {format 3} default {format 4} +} 2 +test switch-1.9 {simple patterns with -nocase} { + switch -nocase B a {format 1} b {format 2} c {format 3} default {format 4} +} 2 +test switch-1.10 {simple patterns with -nocase} { + switch -nocase b a {format 1} B {format 2} c {format 3} default {format 4} +} 2 +test switch-1.11 {simple patterns with -nocase} { + switch -nocase x a {format 1} default {format 2} c {format 3} default {format 4} +} 4 test switch-2.1 {single-argument form for pattern/command pairs} { switch b { a {format 1} b {format 2} @@ -87,11 +99,75 @@ default {concat none} } } exact test switch-3.6 {-exact vs. -glob vs. -regexp} { list [catch {switch -foo a b c} msg] $msg -} {1 {bad option "-foo": must be -exact, -glob, -indexvar, -matchvar, -regexp, or --}} +} {1 {bad option "-foo": must be -exact, -glob, -indexvar, -matchvar, -nocase, -regexp, or --}} +test switch-3.7 {-exact vs. -glob vs. -regexp with -nocase} { + switch -exact -nocase aaaab { + ^a*b$ {concat regexp} + *b {concat glob} + aaaab {concat exact} + default {concat none} + } +} exact +test switch-3.8 {-exact vs. -glob vs. -regexp with -nocase} { + switch -regexp -nocase aaaab { + ^a*b$ {concat regexp} + *b {concat glob} + aaaab {concat exact} + default {concat none} + } +} regexp +test switch-3.9 {-exact vs. -glob vs. -regexp with -nocase} { + switch -glob -nocase aaaab { + ^a*b$ {concat regexp} + *b {concat glob} + aaaab {concat exact} + default {concat none} + } +} glob +test switch-3.10 {-exact vs. -glob vs. -regexp with -nocase} { + switch -nocase aaaab {^a*b$} {concat regexp} *b {concat glob} \ + aaaab {concat exact} default {concat none} +} exact +test switch-3.11 {-exact vs. -glob vs. -regexp with -nocase} { + switch -nocase -- -glob { + ^g.*b$ {concat regexp} + -* {concat glob} + -glob {concat exact} + default {concat none} + } +} exact + +test switch-3.7 {-exact vs. -glob vs. -regexp} { + list [catch {switch -exa Foo Foo {set result OK}} msg] $msg +} {0 OK} + +test switch-3.8 {-exact vs. -glob vs. -regexp} { + list [catch {switch -gl Foo Fo? {set result OK}} msg] $msg +} {0 OK} + +test switch-3.9 {-exact vs. -glob vs. -regexp} { + list [catch {switch -re Foo Fo. {set result OK}} msg] $msg +} {0 OK} + +test switch-3.10 {-exact vs. -glob vs. -regexp} { + list [catch {switch -exact -exact Foo Foo {set result OK}} msg] $msg +} {1 {bad option "-exact": -exact option already found}} + +test switch-3.11 {-exact vs. -glob vs. -regexp} { + list [catch {switch -exact -glob Foo Foo {set result OK}} msg] $msg +} {1 {bad option "-glob": -exact option already found}} + +test switch-3.12 {-exact vs. -glob vs. -regexp} { + list [catch {switch -glob -regexp Foo Foo {set result OK}} msg] $msg +} {1 {bad option "-regexp": -glob option already found}} + +test switch-3.13 {-exact vs. -glob vs. -regexp} { + list [catch {switch -regexp -glob Foo Foo {set result OK}} msg] $msg +} {1 {bad option "-glob": -regexp option already found}} test switch-4.1 {error in executed command} { list [catch {switch a a {error "Just a test"} default {format 1}} msg] \ $msg $errorInfo } {1 {Just a test} {Just a test @@ -170,19 +246,46 @@ b -foo c - } } msg] $msg } {1 {no body specified for pattern "c"}} +test switch-7.4 {"-" bodies} { + list [catch { + switch a { + a - + b -foo + c {} + } + } msg] $msg +} {1 {invalid command name "-foo"}} test switch-8.1 {empty body} { set msg {} switch {2} { 1 {set msg 1} 2 {} default {set msg 2} } } {} + +proc test_switch_body {} { + return "INVOKED" +} + +test switch-8.2 {weird body text, variable} { + set cmd {test_switch_body} + switch Foo { + Foo $cmd + } +} {INVOKED} + +test switch-8.3 {weird body text, variable} { + set cmd {test_switch_body} + switch Foo { + Foo {$cmd} + } +} {INVOKED} test switch-9.1 {empty pattern/body list} { list [catch {switch x} msg] $msg } {1 {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}} test switch-9.2 {empty pattern/body list} { @@ -254,16 +357,27 @@ switch -glob -- $c { a {incr x} b {incr y} } } + set x [expr {$x*100}]; set y [expr {$y*100}] + foreach c [split $s {}] { + switch -glob -- $c a {incr x} b {incr y} + } return $x,$y } proc iswtest-glob s { - set x 0; set y 0 + set x 0; set y 0; set switch switch + foreach c [split $s {}] { + $switch -glob -- $c { + a {incr x} + b {incr y} + } + } + set x [expr {$x*100}]; set y [expr {$y*100}] foreach c [split $s {}] { - switch -glob -- $c a {incr x} b {incr y} + $switch -glob -- $c a {incr x} b {incr y} } return $x,$y } proc cswtest-exact s { set x 0; set y 0 @@ -271,16 +385,27 @@ switch -exact -- $c { a {incr x} b {incr y} } } + set x [expr {$x*100}]; set y [expr {$y*100}] + foreach c [split $s {}] { + switch -exact -- $c a {incr x} b {incr y} + } return $x,$y } proc iswtest-exact s { - set x 0; set y 0 + set x 0; set y 0; set switch switch + foreach c [split $s {}] { + $switch -exact -- $c { + a {incr x} + b {incr y} + } + } + set x [expr {$x*100}]; set y [expr {$y*100}] foreach c [split $s {}] { - switch -exact -- $c a {incr x} b {incr y} + $switch -exact -- $c a {incr x} b {incr y} } return $x,$y } proc cswtest2-glob s { set x 0; set y 0; set z 0 @@ -289,16 +414,28 @@ a {incr x} b {incr y} default {incr z} } } + set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}] + foreach c [split $s {}] { + switch -glob -- $c a {incr x} b {incr y} default {incr z} + } return $x,$y,$z } proc iswtest2-glob s { - set x 0; set y 0; set z 0 + set x 0; set y 0; set z 0; set switch switch + foreach c [split $s {}] { + $switch -glob -- $c { + a {incr x} + b {incr y} + default {incr z} + } + } + set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}] foreach c [split $s {}] { - switch -glob -- $c a {incr x} b {incr y} default {incr z} + $switch -glob -- $c a {incr x} b {incr y} default {incr z} } return $x,$y,$z } proc cswtest2-exact s { set x 0; set y 0; set z 0 @@ -307,32 +444,44 @@ a {incr x} b {incr y} default {incr z} } } - return $x,$y,$z -} -proc iswtest2-exact s { - set x 0; set y 0; set z 0 + set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}] foreach c [split $s {}] { switch -exact -- $c a {incr x} b {incr y} default {incr z} } return $x,$y,$z } +proc iswtest2-exact s { + set x 0; set y 0; set z 0; set switch switch + foreach c [split $s {}] { + $switch -exact -- $c { + a {incr x} + b {incr y} + default {incr z} + } + } + set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}] + foreach c [split $s {}] { + $switch -exact -- $c a {incr x} b {incr y} default {incr z} + } + return $x,$y,$z +} test switch-10.7 {comparison of compiled and interpreted behaviour of switch, exact matching} { - expr {[cswtest-exact abcb] eq [iswtest-exact abcb]} -} 1 + cswtest-exact abcb +} [iswtest-exact abcb] test switch-10.8 {comparison of compiled and interpreted behaviour of switch, glob matching} { - expr {[cswtest-glob abcb] eq [iswtest-glob abcb]} -} 1 + cswtest-glob abcb +} [iswtest-glob abcb] test switch-10.9 {comparison of compiled and interpreted behaviour of switch, exact matching with default} { - expr {[cswtest2-exact abcb] eq [iswtest2-exact abcb]} -} 1 + cswtest2-exact abcb +} [iswtest2-exact abcb] test switch-10.10 {comparison of compiled and interpreted behaviour of switch, glob matching with default} { - expr {[cswtest2-glob abcb] eq [iswtest2-glob abcb]} -} 1 + cswtest2-glob abcb +} [iswtest2-glob abcb] proc cswtest-default-exact {x} { switch -- $x { a* {return b} aa {return c} default {return d} Index: tests/tcltest.test ================================================================== --- tests/tcltest.test +++ tests/tcltest.test @@ -4,11 +4,11 @@ # # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2000 by Ajuba Solutions # All rights reserved. # -# RCS: @(#) $Id: tcltest.test,v 1.48 2004/11/25 16:17:09 rmax Exp $ +# RCS: @(#) $Id: tcltest.test,v 1.48.2.1 2005/03/09 15:57:19 kennykb Exp $ # Note that there are several places where the value of # tcltest::currentFailure is stored/reset in the -setup/-cleanup # of a test that has a body that runs [test] that will fail. # This is a workaround of using the same tcltest code that we are @@ -697,27 +697,27 @@ removeFile a.tcl removeFile thisdirectoryisafile removeDirectory normaldirectory # -file, -notfile, [matchFiles], [skipFiles] -test tcltest-9.1 {-file a*.tcl} -constraints {unixOrPc} -setup { +test tcltest-9.1 {-file d*.tcl} -constraints {unixOrPc} -setup { set old [testsDirectory] testsDirectory [file dirname [info script]] } -body { - slave msg [file join [testsDirectory] all.tcl] -file a*.test + slave msg [file join [testsDirectory] all.tcl] -file d*.test set msg } -cleanup { testsDirectory $old -} -match regexp -result {assocd\.test} +} -match regexp -result {dstring\.test} -test tcltest-9.2 {-file a*.tcl} -constraints {unixOrPc} -setup { +test tcltest-9.2 {-file d*.tcl} -constraints {unixOrPc} -setup { set old [testsDirectory] testsDirectory [file dirname [info script]] } -body { slave msg [file join [testsDirectory] all.tcl] \ - -file a*.test -notfile assocd* - regexp {assocd\.test} $msg + -file d*.test -notfile dstring* + regexp {dstring\.test} $msg } -cleanup { testsDirectory $old } -result 0 test tcltest-9.3 {matchFiles} { @@ -743,10 +743,25 @@ skipFiles $old list $current $new } -result {foo bar} } + +test tcltest-9.5 {GetMatchingFiles: Bug 1119798} -setup { + set d [makeDirectory tmp] + makeDirectory foo $d + makeFile {} fee $d + file copy [file join [file dirname [info script]] all.tcl] $d +} -body { + slave msg [file join [temporaryDirectory] all.tcl] -file f* + regexp {exiting with errors:} $msg +} -cleanup { + file delete [file join $d all.tcl] + removeFile fee $d + removeDirectory foo $d + removeDirectory tmp +} -result 0 # -preservecore, [preserveCore] set mc [makeFile { package require tcltest namespace import ::tcltest::test Index: tests/tm.test ================================================================== --- tests/tm.test +++ tests/tm.test @@ -4,11 +4,11 @@ # errors. No output means no errors were found. # # Copyright (c) 2004 by Donal K. Fellows. # All rights reserved. # -# RCS: @(#) $Id: tm.test,v 1.5 2004/11/05 09:21:46 dkf Exp $ +# RCS: @(#) $Id: tm.test,v 1.5.2.1 2005/09/09 18:48:40 dgp Exp $ package require Tcl 8.5 if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* @@ -202,12 +202,12 @@ proc genpaths {base} { # Normalizing picks up drive letters on windows [Bug 1053568] set base [file normalize $base] foreach {major minor} [split [info tclversion] .] break set results {} - lappend results [file join $base site-tcl] set base [file join $base tcl$major] + lappend results [file join $base site-tcl] for {set i 0} {$i <= $minor} {incr i} { lappend results [file join $base ${major}.$i] } return $results } Index: tests/trace.test ================================================================== --- tests/trace.test +++ tests/trace.test @@ -9,11 +9,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: trace.test,v 1.37 2004/11/15 21:47:23 dgp Exp $ +# RCS: @(#) $Id: trace.test,v 1.37.2.2 2005/08/02 18:16:43 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } @@ -2202,11 +2202,55 @@ trace variable x w foo trace remove variable x write foo llength [trace info variable x] } 0 -test trace-34.1 {527164: Keep -errorinfo of traces} -setup { +test trace-34.1 {Bug 1201035} { + set ::x [list] + proc foo {} {lappend ::x foo} + proc bar args { + lappend ::x $args + trace remove execution foo leavestep bar + trace remove execution foo enterstep bar + trace add execution foo leavestep bar + trace add execution foo enterstep bar + lappend ::x done + } + trace add execution foo leavestep bar + trace add execution foo enterstep bar + foo + set ::x +} {{{lappend ::x foo} enterstep} done foo} + +test trace-34.2 {Bug 1224585} { + proc foo {} {} + proc bar args {trace remove execution foo leave soom} + trace add execution foo leave bar + trace add execution foo leave soom + foo +} {} + +test trace-34.3 {Bug 1224585} { + proc foo {} {set x {}} + proc bar args {trace remove execution foo enterstep soom} + trace add execution foo enterstep soom + trace add execution foo enterstep bar + foo +} {} + +test trace-34.4 {Bug 1047286} { + variable x notrace + proc callback {old - -} { + variable x "$old exists: [namespace which -command $old]" + } + namespace eval ::foo {proc bar {} {}} + trace add command ::foo::bar delete [namespace code callback] + namespace delete ::foo + set x +} {::foo::bar exists: ::foo::bar} + +test trace-35.1 {527164: Keep -errorinfo of traces} -setup { unset -nocomplain x y } -body { trace add variable x write {error foo;#} trace add variable y write {set x 2;#} list [catch {set y 1} msg opts] $msg [dict get $opts -errorinfo] Index: tests/unixInit.test ================================================================== --- tests/unixInit.test +++ tests/unixInit.test @@ -8,13 +8,13 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: unixInit.test,v 1.44 2004/11/30 19:34:51 dgp Exp $ +# RCS: @(#) $Id: unixInit.test,v 1.44.2.3 2005/05/05 17:56:37 kennykb Exp $ -package require tcltest 2 +package require tcltest 2.2 namespace import -force ::tcltest::* unset -nocomplain path catch {set oldlang $env(LANG)} set env(LANG) C @@ -90,34 +90,25 @@ } else { subst "Expected: `[list 127.0.0.1 localhost $port]', Got `$result'" } } {OK} -proc getlibpath [list [list program [interpreter]]] { - set f [open "|[list $program]" w+] - fconfigure $f -buffering none - puts $f {puts $::tcl::LibPath; exit} - set path [gets $f] - close $f - return $path -} - -# Some tests require the testgetdefenc command - -testConstraint testgetdefenc [llength [info commands testgetdefenc]] - -test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} \ - {unix testgetdefenc} { +# The unixInit-2.* tests were written to test the internal routine, +# TclpInitLibraryPath. That routine no longer does the things it used +# to do so those tests are obsolete. Skip them. + +skip [concat [skip] unixInit-2.*] + +test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} { set origDir [testgetdefenc] testsetdefenc slappy set path [testgetdefenc] testsetdefenc $origDir set path } {slappy} -test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} -constraints { - unix stdio -} -setup { + +test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} -setup { unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { set oldlibrary $env(TCL_LIBRARY) unset env(TCL_LIBRARY) } @@ -136,13 +127,12 @@ if {[info exists oldlibrary]} { set env(TCL_LIBRARY) $oldlibrary unset oldlibrary } } -result {0 0} -test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} -constraints { - unix stdio -} -setup { + +test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} -setup { unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { set oldlibrary $env(TCL_LIBRARY) } } -body { @@ -157,13 +147,12 @@ if {[info exists oldlibrary]} { set env(TCL_LIBRARY) $oldlibrary unset oldlibrary } } -result "sparkly" -test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} -constraints { - unix stdio -} -setup { + +test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} -setup { unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { set oldlibrary $env(TCL_LIBRARY) } } -body { @@ -178,13 +167,12 @@ if {[info exists oldlibrary]} { set env(TCL_LIBRARY) $oldlibrary unset oldlibrary } } -result [list /a/b/tcl1.7 /a/b/tcl[info tclversion]] -test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} -constraints { - unix stdio knownBug -} -setup { + +test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} -setup { if {[info exists env(TCL_LIBRARY)]} { set oldlibrary $env(TCL_LIBRARY) } } -body { # Child process translates env variable from native encoding. @@ -199,17 +187,15 @@ if {[info exists oldlibrary]} { set env(TCL_LIBRARY) $oldlibrary unset oldlibrary } } -result "\xa7" -test unixInit-2.5 {TclpInitLibraryPath: compiled-in library path} \ - {emptyTest unix} { +test unixInit-2.5 {TclpInitLibraryPath: compiled-in library path} { # cannot test } {} -test unixInit-2.6 {TclpInitLibraryPath: executable relative} -constraints { - unix stdio -} -setup { + +test unixInit-2.6 {TclpInitLibraryPath: executable relative} -setup { unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { set oldlibrary $env(TCL_LIBRARY) } set env(TCL_LIBRARY) [info library] @@ -236,27 +222,22 @@ set env(TCL_LIBRARY) $oldlibrary unset oldlibrary } } -result [list [temporaryDirectory]/tmp/sparkly/lib/tcl[info tclversion] [temporaryDirectory]/tmp/lib/tcl[info tclversion]] -test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} \ - {emptyTest unix} { +test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} { # would need test command to get defaultLibDir and compare it to # [lindex $auto_path end] } {} + # # The following two tests write to the directory /tmp/sparkly instead # of to [temporaryDirectory]. This is because the failures tested by # these tests need paths near the "root" of the file system to present # themselves. # -testConstraint noSparkly [expr {![file exists [file join /tmp sparkly]]}] -testConstraint noTmpInstall [expr {![file exists \ - [file join /tmp lib tcl[info tclversion]]]}] -test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} -constraints { - unix noSparkly noTmpInstall -} -setup { +test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} -setup { unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { set oldlibrary $env(TCL_LIBRARY) } set env(TCL_LIBRARY) [info library] @@ -313,14 +294,12 @@ if {[info exists oldlibrary]} { set env(TCL_LIBRARY) $oldlibrary unset oldlibrary } } -result 1 -testConstraint noTmpBuild [expr {![file exists [file join /tmp library]]}] -test unixInit-2.9 {TclpInitLibraryPath: paths relative to executable} -constraints { - unix noSparkly noTmpBuild -} -setup { + +test unixInit-2.9 {TclpInitLibraryPath: paths relative to executable} -setup { # Checking for Bug 438014 unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { set oldlibrary $env(TCL_LIBRARY) } @@ -343,13 +322,11 @@ unset oldlibrary } } -result [list /tmp/lib/tcl[info tclversion] /lib/tcl[info tclversion] \ /tmp/library /library /tcl[info patchlevel]/library] -test unixInit-2.10 {TclpInitLibraryPath: executable relative} -constraints { - unix stdio -} -setup { +test unixInit-2.10 {TclpInitLibraryPath: executable relative} -setup { unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { set oldlibrary $env(TCL_LIBRARY) } set env(TCL_LIBRARY) [info library] @@ -450,16 +427,16 @@ test unixInit-7.1 {closed standard channel: Bug 772288} -constraints { unix stdio } -body { set tclsh [interpreter] - makeFile {puts [open /dev/null]} crash.tcl - makeFile " + set crash [makeFile {puts [open /dev/null]} crash.tcl] + set crashtest [makeFile " close stdin - [list exec $tclsh [file join [temporaryDirectory] crash.tcl]] - " crashtest.tcl - exec $tclsh [file join [temporaryDirectory] crashtest.tcl] + [list exec $tclsh $crash] + " crashtest.tcl] + exec $tclsh $crashtest } -cleanup { removeFile crash.tcl removeFile crashtest.tcl } -returnCodes 0 Index: tests/unixNotfy.test ================================================================== --- tests/unixNotfy.test +++ tests/unixNotfy.test @@ -8,11 +8,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: unixNotfy.test,v 1.17 2004/06/24 10:34:12 dkf Exp $ +# RCS: @(#) $Id: unixNotfy.test,v 1.17.2.1 2005/05/21 15:10:27 kennykb Exp $ # The tests should not be run if you have a notifier which is unable to # detect infinite vwaits, as the tests below will hang. The presence of # the "testthread" command indicates that this is the case. @@ -22,12 +22,14 @@ } # When run in a Tk shell, these tests hang. testConstraint noTk [expr {![info exists tk_version]}] testConstraint testthread [expr {[info commands testthread] != {}}] +# Darwin always uses a threaded notifier testConstraint unthreaded [expr { - ![info exist tcl_platform(threaded)] || !$tcl_platform(threaded) + (![info exist tcl_platform(threaded)] || !$tcl_platform(threaded)) + && $tcl_platform(os) ne "Darwin" }] # The next two tests will hang if threads are enabled because the notifier # will not necessarily wait for ever in this case, so it does not generate # an error. Index: tests/utf.test ================================================================== --- tests/utf.test +++ tests/utf.test @@ -6,11 +6,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: utf.test,v 1.12 2003/10/08 15:24:21 dgp Exp $ +# RCS: @(#) $Id: utf.test,v 1.12.2.1 2005/09/09 18:48:40 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -27,10 +27,13 @@ set x "\xe0" } [bytestring "\xc3\xa0"] test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} { set x "\u4e4e" } [bytestring "\xe4\xb9\x8e"] +test utf-1.5 {Tcl_UniCharToUtf: negative Tcl_UniChar} { + string length [format %c -1] +} 1 test utf-2.1 {Tcl_UtfToUniChar: low ascii} { string length "abc" } {3} test utf-2.2 {Tcl_UtfToUniChar: naked trail bytes} { Index: tests/util.test ================================================================== --- tests/util.test +++ tests/util.test @@ -5,16 +5,84 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: util.test,v 1.14 2004/05/19 20:15:32 dkf Exp $ +# RCS: @(#) $Id: util.test,v 1.14.2.4 2005/05/21 15:10:27 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } + +# 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 + } + } +} +::tcltest::testConstraint ieeeFloatingPoint [testIEEE] + +proc convertDouble { x } { + variable ieeeValues + if { $ieeeValues(littleEndian) } { + binary scan [binary format w $x] d result + } else { + binary scan [binary format W $x] d result + } + return $result +} test util-1.1 {TclFindElement procedure - binary element in middle of list} { lindex {0 foo\x00help 1} 1 } "foo\x00help" test util-1.2 {TclFindElement procedure - binary element at end of list} { @@ -271,60 +339,93 @@ } 0 test util-5.51 {Tcl_StringMatch} { Wrapper_Tcl_StringMatch "" "" } 1 -test util-6.1 {Tcl_PrintDouble - using tcl_precision} { +test util-6.1 {Tcl_PrintDouble - using tcl_precision} -setup { + set old_precision $::tcl_precision + set ::tcl_precision 12 +} -body { concat x[expr 1.4] -} {x1.4} -test util-6.2 {Tcl_PrintDouble - using tcl_precision} { +} -cleanup { + set ::tcl_precision $old_precision +} -result {x1.4} +test util-6.2 {Tcl_PrintDouble - using tcl_precision} -setup { + set old_precision $::tcl_precision + set ::tcl_precision 12 +} -body { concat x[expr 1.39999999999] -} {x1.39999999999} -test util-6.3 {Tcl_PrintDouble - using tcl_precision} { +} -cleanup { + set ::tcl_precision $old_precision +} -result {x1.39999999999} +test util-6.3 {Tcl_PrintDouble - using tcl_precision} -setup { + set old_precision $::tcl_precision + set ::tcl_precision 12 +} -body { concat x[expr 1.399999999999] -} {x1.4} -test util-6.4 {Tcl_PrintDouble - using tcl_precision} { - set tcl_precision 5 +} -cleanup { + set ::tcl_precision $old_precision +} -result {x1.4} +test util-6.4 {Tcl_PrintDouble - using tcl_precision} -setup { + set old_precision $::tcl_precision + set ::tcl_precision 5 +} -body { concat x[expr 1.123412341234] -} {x1.1234} -set tcl_precision 12 +} -cleanup { + set tcl_precision $old_precision +} -result {x1.1234} + test util-6.5 {Tcl_PrintDouble - make sure there's a decimal point} { concat x[expr 2.0] } {x2.0} -test util-6.6 {Tcl_PrintDouble - make sure there's a decimal point} {eformat} { +test util-6.6 {Tcl_PrintDouble - make sure there's a decimal point} { concat x[expr 3.0e98] } {x3e+98} -test util-7.1 {TclPrecTraceProc - unset callbacks} { +test util-7.1 {TclPrecTraceProc - unset callbacks} -setup { + set old_precision $::tcl_precision +} -body { set tcl_precision 7 set x $tcl_precision unset tcl_precision list $x $tcl_precision -} {7 7} -test util-7.2 {TclPrecTraceProc - read traces, sharing among interpreters} { +} -cleanup { + set ::tcl_precision $old_precision +} -result {7 7} +test util-7.2 {TclPrecTraceProc - read traces, sharing among interpreters} -setup { + set old_precision $::tcl_precision +} -body { set tcl_precision 12 interp create child set x [child eval set tcl_precision] child eval {set tcl_precision 6} interp delete child list $x $tcl_precision -} {12 6} -test util-7.3 {TclPrecTraceProc - write traces, safe interpreters} { +} -cleanup { + set ::tcl_precision $old_precision +} -result {12 6} +test util-7.3 {TclPrecTraceProc - write traces, safe interpreters} -setup { + set old_precision $::tcl_precision +} -body { set tcl_precision 12 interp create -safe child set x [child eval { list [catch {set tcl_precision 8} msg] $msg }] interp delete child list $x $tcl_precision -} {{1 {can't set "tcl_precision": can't modify precision from a safe interpreter}} 12} -test util-7.4 {TclPrecTraceProc - write traces, bogus values} { +} -cleanup { + set ::tcl_precision $old_precision +} -result {{1 {can't set "tcl_precision": can't modify precision from a safe interpreter}} 12} +test util-7.4 {TclPrecTraceProc - write traces, bogus values} -setup { + set old_precision $::tcl_precision +} -body { set tcl_precision 12 list [catch {set tcl_precision abc} msg] $msg $tcl_precision -} {1 {can't set "tcl_precision": improper value for precision} 12} - -set tcl_precision 12 +} -cleanup { + set ::tcl_precision $old_precision +} -result {1 {can't set "tcl_precision": improper value for precision} 12} # This test always succeeded in the C locale anyway... test util-8.1 {TclNeedSpace - correct UTF8 handling} { # Bug 411825 # Note that this test relies on the fact that @@ -385,9 +486,629 @@ testdstring append \{ -1 testdstring element foo testdstring append \} -1 list [llength [testdstring get]] [string length [testdstring get]] } {2 9} + +test util-9.0.0 {TclGetIntForIndex} { + string index abcd 0 +} a +test util-9.0.1 {TclGetIntForIndex} { + string index abcd 0x0 +} a +test util-9.0.2 {TclGetIntForIndex} { + string index abcd -0x0 +} a +test util-9.0.3 {TclGetIntForIndex} { + string index abcd { 0 } +} a +test util-9.0.4 {TclGetIntForIndex} { + string index abcd { 0x0 } +} a +test util-9.0.5 {TclGetIntForIndex} { + string index abcd { -0x0 } +} a +test util-9.0.6 {TclGetIntForIndex} { + string index abcd 01 +} b +test util-9.0.7 {TclGetIntForIndex} { + string index abcd { 01 } +} b +test util-9.1.0 {TclGetIntForIndex} { + string index abcd 3 +} d +test util-9.1.1 {TclGetIntForIndex} { + string index abcd { 3 } +} d +test util-9.1.2 {TclGetIntForIndex} { + string index abcdefghijk 0xa +} k +test util-9.1.3 {TclGetIntForIndex} { + string index abcdefghijk { 0xa } +} k +test util-9.2.0 {TclGetIntForIndex} { + string index abcd end +} d +test util-9.2.1 {TclGetIntForIndex} -body { + string index abcd { end} +} -returnCodes error -match glob -result * +test util-9.2.2 {TclGetIntForIndex} -body { + string index abcd {end } +} -returnCodes error -match glob -result * +test util-9.3 {TclGetIntForIndex} { + # Deprecated + string index abcd en +} d +test util-9.4 {TclGetIntForIndex} { + # Deprecated + string index abcd e +} d +test util-9.5.0 {TclGetIntForIndex} { + string index abcd end-1 +} c +test util-9.5.1 {TclGetIntForIndex} { + string index abcd {end-1 } +} c +test util-9.5.2 {TclGetIntForIndex} -body { + string index abcd { end-1} +} -returnCodes error -match glob -result * +test util-9.6 {TclGetIntForIndex} { + string index abcd end+-1 +} c +test util-9.7 {TclGetIntForIndex} { + string index abcd end+1 +} {} +test util-9.8 {TclGetIntForIndex} { + string index abcd end--1 +} {} +test util-9.9.0 {TclGetIntForIndex} { + string index abcd 0+0 +} a +test util-9.9.1 {TclGetIntForIndex} { + string index abcd { 0+0 } +} a +test util-9.10 {TclGetIntForIndex} { + string index abcd 0-0 +} a +test util-9.11 {TclGetIntForIndex} { + string index abcd 1+0 +} b +test util-9.12 {TclGetIntForIndex} { + string index abcd 1-0 +} b +test util-9.13 {TclGetIntForIndex} { + string index abcd 1+1 +} c +test util-9.14 {TclGetIntForIndex} { + string index abcd 1-1 +} a +test util-9.15 {TclGetIntForIndex} { + string index abcd -1+2 +} b +test util-9.16 {TclGetIntForIndex} { + string index abcd -1--2 +} b +test util-9.17 {TclGetIntForIndex} { + string index abcd { -1+2 } +} b +test util-9.18 {TclGetIntForIndex} { + string index abcd { -1--2 } +} b +test util-9.19 {TclGetIntForIndex} -body { + string index a {} +} -returnCodes error -match glob -result * +test util-9.20 {TclGetIntForIndex} -body { + string index a { } +} -returnCodes error -match glob -result * +test util-9.21 {TclGetIntForIndex} -body { + string index a " \r\t\n" +} -returnCodes error -match glob -result * +test util-9.22 {TclGetIntForIndex} -body { + string index a + +} -returnCodes error -match glob -result * +test util-9.23 {TclGetIntForIndex} -body { + string index a - +} -returnCodes error -match glob -result * +test util-9.24 {TclGetIntForIndex} -body { + string index a x +} -returnCodes error -match glob -result * +test util-9.25 {TclGetIntForIndex} -body { + string index a +x +} -returnCodes error -match glob -result * +test util-9.26 {TclGetIntForIndex} -body { + string index a -x +} -returnCodes error -match glob -result * +test util-9.27 {TclGetIntForIndex} -body { + string index a 0y +} -returnCodes error -match glob -result * +test util-9.28 {TclGetIntForIndex} -body { + string index a 1* +} -returnCodes error -match glob -result * +test util-9.29 {TclGetIntForIndex} -body { + string index a 0+ +} -returnCodes error -match glob -result * +test util-9.30 {TclGetIntForIndex} -body { + string index a {0+ } +} -returnCodes error -match glob -result * +test util-9.31 {TclGetIntForIndex} -body { + string index a 0x +} -returnCodes error -match glob -result * +test util-9.32 {TclGetIntForIndex} -body { + string index a 0x1FFFFFFFF+0 +} -returnCodes error -match glob -result * +test util-9.33 {TclGetIntForIndex} -body { + string index a 100000000000+0 +} -returnCodes error -match glob -result * +test util-9.34 {TclGetIntForIndex} -body { + string index a 1.0 +} -returnCodes error -match glob -result * +test util-9.35 {TclGetIntForIndex} -body { + string index a 1e23 +} -returnCodes error -match glob -result * +test util-9.36 {TclGetIntForIndex} -body { + string index a 1.5e2 +} -returnCodes error -match glob -result * +test util-9.37 {TclGetIntForIndex} -body { + string index a 0+x +} -returnCodes error -match glob -result * +test util-9.38 {TclGetIntForIndex} -body { + string index a 0+0x +} -returnCodes error -match glob -result * +test util-9.39 {TclGetIntForIndex} -body { + string index a 0+0xg +} -returnCodes error -match glob -result * +test util-9.40 {TclGetIntForIndex} -body { + string index a 0+0xg +} -returnCodes error -match glob -result * +test util-9.41 {TclGetIntForIndex} -body { + string index a 0+1.0 +} -returnCodes error -match glob -result * +test util-9.42 {TclGetIntForIndex} -body { + string index a 0+1e2 +} -returnCodes error -match glob -result * +test util-9.43 {TclGetIntForIndex} -body { + string index a 0+1.5e1 +} -returnCodes error -match glob -result * +test util-9.44 {TclGetIntForIndex} -body { + string index a 0+1000000000000 +} -returnCodes error -match glob -result * + +test util-10.1 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x0000000000000000 +} {0.0} +test util-10.2 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x8000000000000000 +} {-0.0} +test util-10.3 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x7ef754e31cd072da +} {4e+303} +test util-10.4 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xd08afcef51f0fb5f +} {-1e+80} +test util-10.5 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x7ed754e31cd072da +} {1e+303} +test util-10.6 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xfee754e31cd072da +} {-2e+303} +test util-10.7 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x0afe07b27dd78b14 +} {1e-255} +test util-10.8 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x93ae29e9c56687fe +} {-7e-214} +test util-10.9 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x376be03d0bf225c7 +} {1e-41} +test util-10.10 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xa0ca2fe76a3f9475 +} {-1e-150} +test util-10.11 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x7fa9a2028368022e +} {9e+306} +test util-10.12 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xdfc317e5ef3ab327 +} {-2e+153} +test util-10.13 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x5fd317e5ef3ab327 +} {4e+153} +test util-10.14 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xdfe317e5ef3ab327 +} {-8e+153} +test util-10.15 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x00feb8e84fa0b278 +} {7e-304} +test util-10.16 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x8133339131c46f8b +} {-7e-303} +test util-10.17 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x35dc0f92a6276c9d +} {3e-49} +test util-10.18 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xa445ce1f143d7ad2 +} {-6e-134} +test util-10.19 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x2d2c0794d9d40e96 +} {4.3e-91} +test util-10.20 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xad3c0794d9d40e96 +} {-8.6e-91} +test util-10.21 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x30ecd5bee57763e6 +} {5.1e-73} +test util-10.22 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x68ad1c26db7d0dae +} {1.7e+196} +test util-10.23 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xbfa3f7ced916872b +} {-0.039} +test util-10.24 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x64b7d93193f78fc6 +} {1.51e+177} +test util-10.25 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x98ea82a1631eeb30 +} {-1.19e-188} +test util-10.26 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xd216c309024bab4b +} {-2.83e+87} +test util-10.27 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x0dfdbbac6f83a821 +} {2.7869147e-241} +test util-10.28 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xdadc569e968e0944 +} {-4.91080654e+129} +test util-10.29 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x5acc569e968e0944 +} {2.45540327e+129} +test util-10.30 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xab5fc575867314ee +} {-9.078555839e-100} +test util-10.31 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xdabc569e968e0944 +} {-1.227701635e+129} +test util-10.32 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x2b6fc575867314ee +} {1.8157111678e-99} +test util-10.33 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xb3b8bf7e7fa6f02a +} {-1.5400733123779e-59} +test util-10.34 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xcd83de005bd620df +} {-2.6153245263757307e+65} +test util-10.35 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x6cdf92bacb3cb40c +} {2.7210404151224248e+216} +test util-10.36 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xecef92bacb3cb40c +} {-5.4420808302448496e+216} +test util-10.37 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x49342dbf25096cf5 +} {4.5e+44} +test util-10.38 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xd06afcef51f0fb5f +} {-2.5e+79} +test util-10.39 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x49002498ea6df0c4 +} {4.5e+43} +test util-10.40 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xfeb754e31cd072da +} {-2.5e+302} +test util-10.41 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x1d22deac01e2b4f7 +} {2.5e-168} +test util-10.42 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xaccb1df536c13eee +} {-6.5e-93} +test util-10.43 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x3650711fed5b19a4 +} {4.5e-47} +test util-10.44 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xb6848d67e8b1e00d +} {-4.5e-46} +test util-10.45 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x4bac8c574c0c6be7 +} {3.5e+56} +test util-10.46 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xccd756183c147514 +} {-1.5e+62} +test util-10.47 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x4ca2ab469676c410 +} {1.5e+61} +test util-10.48 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xcf5539684e774b48 +} {-1.5e+74} +test util-10.49 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x2e12e5f5dfa4fe9d +} {9.5e-87} +test util-10.50 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x8b9bdc2417bf7787 +} {-9.5e-253} +test util-10.51 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x00eeb8e84fa0b278 +} {3.5e-304} +test util-10.52 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xadde3cbc9907fdc8 +} {-9.5e-88} +test util-10.53 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x2bb0ad836f269a17 +} {3.05e-98} +test util-10.54 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x950b39ae1909c31b +} {-2.65e-207} +test util-10.55 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x1bfb2ab18615fcc6 +} {6.865e-174} +test util-10.56 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x98f3e1f90a573064 +} {-1.785e-188} +test util-10.57 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x5206c309024bab4b +} {1.415e+87} +test util-10.58 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xcc059bd3ad46e346 +} {-1.6955e+58} +test util-10.59 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x47bdf4170f0fdecc +} {3.9815e+37} +test util-10.60 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x59e7e1e0f1c7a4ac +} {1.263005e+125} +test util-10.61 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xda1dda592e398dd7 +} {-1.263005e+126} +test util-10.62 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xdc4e597c0b94b7ae +} {-4.4118455e+136} +test util-10.63 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x5aac569e968e0944 +} {6.138508175e+128} +test util-10.64 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xdabc569e968e0944 +} {-1.227701635e+129} +test util-10.65 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x6ce7ae0c186d8709 +} {4.081560622683637e+216} +test util-10.66 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x44b52d02c7e14af7 +} {1.0000000000000001e+23} +test util-10.67 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xc589d971e4fe8402 +} {-1e+27} +test util-10.68 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x4599d971e4fe8402 +} {2e+27} +test util-10.69 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xc5a9d971e4fe8402 +} {-4e+27} +test util-10.70 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x3e45798ee2308c3a +} {1e-8} +test util-10.71 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xbe55798ee2308c3a +} {-2e-8} +test util-10.72 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x3e65798ee2308c3a +} {4e-8} +test util-10.73 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xbabef2d0f5da7dd9 +} {-1e-25} +test util-10.74 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x44da784379d99db4 +} {5e+23} +test util-10.75 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xc4fa784379d99db4 +} {-2e+24} +test util-10.76 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x4503da329b633647 +} {3e+24} +test util-10.77 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xc54cf389cd46047d +} {-7e+25} +test util-10.78 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x3fc999999999999a +} {0.2} +test util-10.79 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xbfd3333333333333 +} {-0.3} +test util-10.80 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x3cf6849b86a12b9b +} {5e-15} +test util-10.81 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xbd16849b86a12b9b +} {-2e-14} +test util-10.82 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x3b87ccfc73126788 +} {6.3e-22} +test util-10.83 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xbbbdc03b8fd7016a +} {-6.3e-21} +test util-10.84 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x3fa3f7ced916872b +} {0.039} +test util-10.85 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x460b297cad9f70b6 +} {2.69e+29} +test util-10.86 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xc61b297cad9f70b6 +} {-5.38e+29} +test util-10.87 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x3adcdc06b20ef183 +} {3.73e-25} +test util-10.88 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x45fb297cad9f70b6 +} {1.345e+29} +test util-10.89 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xc60b297cad9f70b6 +} {-2.69e+29} +test util-10.90 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xbc050a246ecd44f3 +} {-1.4257e-19} +test util-10.91 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xbec19b96f36ec68b +} {-2.09901e-6} +test util-10.92 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x3dcc06d366394441 +} {5.0980203373e-11} +test util-10.93 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xc79f58ac4db68c90 +} {-1.04166211811e+37} +test util-10.94 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x4569d971e4fe8402 +} {2.5e+26} +test util-10.95 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xc50dc74be914d16b +} {-4.5e+24} +test util-10.96 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x4534adf4b7320335 +} {2.5e+25} +test util-10.97 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xc54ae22487c1042b +} {-6.5e+25} +test util-10.98 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x3c987fe49aab41e0 +} {8.5e-17} +test util-10.99 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xbc2f5c05e4b23fd7 +} {-8.5e-19} +test util-10.100 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x3d5faa7ab552a552 +} {4.5e-13} +test util-10.101 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xbdbb7cdfd9d7bdbb +} {-2.5e-11} +test util-10.102 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x44f3da329b633647 +} {1.5e+24} +test util-10.103 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xc53cf389cd46047d +} {-3.5e+25} +test util-10.104 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x454f04ef12cb04cf +} {7.5e+25} +test util-10.105 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xc55f04ef12cb04cf +} {-1.5e+26} +test util-10.106 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x3fc3333333333333 +} {0.15} +test util-10.107 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xbdb07e1fe91b0b70 +} {-1.5e-11} +test util-10.108 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x3de49da7e361ce4c +} {1.5e-10} +test util-10.109 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xbe19c511dc3a41df +} {-1.5e-9} +test util-10.110 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xc5caa83d74267822 +} {-1.65e+28} +test util-10.111 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x4588f1d5969453de +} {9.65e+26} +test util-10.112 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x3b91d9bd564dcda6 +} {9.45e-22} +test util-10.113 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xbcfa58973ecbede6 +} {-5.85e-15} +test util-10.114 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x45eb297cad9f70b6 +} {6.725e+28} +test util-10.115 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xc5fb297cad9f70b6 +} {-1.345e+29} +test util-10.116 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x3accdc06b20ef183 +} {1.865e-25} +test util-10.117 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xbd036071dcae4565 +} {-8.605e-15} +test util-10.118 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x462cb968d297dde8 +} {1.137885e+30} +test util-10.119 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0xc661f3e1839eeab1 +} {-1.137885e+31} +test util-10.120 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x474e9cec176c96f8 +} {3.179033335e+35} +test util-10.121 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x3dbc06d366394441 +} {2.54901016865e-11} +test util-10.122 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { + convertDouble 0x478f58ac4db68c90 +} {5.20831059055e+36} + +test util-11.1 {Tcl_PrintDouble - scaling} { + expr 1.1e-5 +} {1.1e-5} +test util-11.2 {Tcl_PrintDouble - scaling} { + expr 1.1e-4 +} {0.00011} +test util-11.3 {Tcl_PrintDouble - scaling} { + expr 1.1e-3 +} {0.0011} +test util-11.4 {Tcl_PrintDouble - scaling} { + expr 1.1e-2 +} {0.011} +test util-11.5 {Tcl_PrintDouble - scaling} { + expr 1.1e-1 +} {0.11} +test util-11.6 {Tcl_PrintDouble - scaling} { + expr 1.1e0 +} {1.1} +test util-11.7 {Tcl_PrintDouble - scaling} { + expr 1.1e1 +} {11.0} +test util-11.8 {Tcl_PrintDouble - scaling} { + expr 1.1e2 +} {110.0} +test util-11.9 {Tcl_PrintDouble - scaling} { + expr 1.1e3 +} {1100.0} +test util-11.10 {Tcl_PrintDouble - scaling} { + expr 1.1e4 +} {11000.0} +test util-11.11 {Tcl_PrintDouble - scaling} { + expr 1.1e5 +} {110000.0} +test util-11.12 {Tcl_PrintDouble - scaling} { + expr 1.1e6 +} {1100000.0} +test util-11.13 {Tcl_PrintDouble - scaling} { + expr 1.1e7 +} {11000000.0} +test util-11.14 {Tcl_PrintDouble - scaling} { + expr 1.1e8 +} {110000000.0} +test util-11.15 {Tcl_PrintDouble - scaling} { + expr 1.1e9 +} {1100000000.0} +test util-11.16 {Tcl_PrintDouble - scaling} { + expr 1.1e10 +} {11000000000.0} +test util-11.17 {Tcl_PrintDouble - scaling} { + expr 1.1e11 +} {110000000000.0} +test util-11.18 {Tcl_PrintDouble - scaling} { + expr 1.1e12 +} {1100000000000.0} +test util-11.19 {Tcl_PrintDouble - scaling} { + expr 1.1e13 +} {11000000000000.0} +test util-11.20 {Tcl_PrintDouble - scaling} { + expr 1.1e14 +} {110000000000000.0} +test util-11.21 {Tcl_PrintDouble - scaling} { + expr 1.1e15 +} {1100000000000000.0} +test util-11.22 {Tcl_PrintDouble - scaling} { + expr 1.1e16 +} {11000000000000000.0} +test util-11.23 {Tcl_PrintDouble - scaling} { + expr 1.1e17 +} {1.1e+17} # cleanup ::tcltest::cleanupTests return Index: tests/winDde.test ================================================================== --- tests/winDde.test +++ tests/winDde.test @@ -7,11 +7,11 @@ # Copyright (c) 1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: winDde.test,v 1.26 2004/12/01 14:02:49 dkf Exp $ +# RCS: @(#) $Id: winDde.test,v 1.26.2.1 2005/01/20 14:53:40 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 #tcltest::configure -verbose {pass start} namespace import -force ::tcltest::* @@ -217,11 +217,11 @@ # ------------------------------------------------------------------------- test winDde-6.1 {DDE servername bad arguments} -constraints {win dde} -body { dde servername -z -z -z -} -returnCodes error -result {unknown option "-z": should be -force, -handler or --} +} -returnCodes error -result {bad option "-z": must be -force, -handler, or --} test winDde-6.2 {DDE servername set name} -constraints {win dde} -body { dde servername -- winDde-6.2 } -result {winDde-6.2} test winDde-6.3 {DDE servername set exact name} -constraints {win dde} -body { dde servername -force winDde-6.3 Index: tests/winFCmd.test ================================================================== --- tests/winFCmd.test +++ tests/winFCmd.test @@ -8,11 +8,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: winFCmd.test,v 1.35 2004/10/07 14:50:23 vincentdarley Exp $ +# RCS: @(#) $Id: winFCmd.test,v 1.35.2.2 2005/04/10 23:15:16 kennykb Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* @@ -1097,10 +1097,67 @@ cd $pwd } -result "permission denied" cd $pwd unset d dd pwd + +test winFCmd-18.1 {Windows reserved path names} -constraints win -body { + file pathtype com1 +} -result "absolute" + +test winFCmd-18.1.2 {Windows reserved path names} -constraints win -body { + file pathtype com4 +} -result "absolute" + +test winFCmd-18.1.3 {Windows reserved path names} -constraints win -body { + file pathtype com5 +} -result "relative" + +test winFCmd-18.1.4 {Windows reserved path names} -constraints win -body { + file pathtype lpt3 +} -result "absolute" + +test winFCmd-18.1.5 {Windows reserved path names} -constraints win -body { + file pathtype lpt4 +} -result "relative" + +test winFCmd-18.1.6 {Windows reserved path names} -constraints win -body { + file pathtype nul +} -result "absolute" + +test winFCmd-18.1.7 {Windows reserved path names} -constraints win -body { + file pathtype null +} -result "relative" + +test winFCmd-18.2 {Windows reserved path names} -constraints win -body { + file pathtype com1: +} -result "absolute" + +test winFCmd-18.3 {Windows reserved path names} -constraints win -body { + file pathtype COM1 +} -result "absolute" + +test winFCmd-18.4 {Windows reserved path names} -constraints win -body { + file pathtype CoM1: +} -result "absolute" + +test winFCmd-18.5 {Windows reserved path names} -constraints win -body { + file normalize com1: +} -result COM1 + +test winFCmd-18.6 {Windows reserved path names} -constraints win -body { + file normalize COM1: +} -result COM1 + +test winFCmd-18.7 {Windows reserved path names} -constraints win -body { + file normalize cOm1 +} -result COM1 + +test winFCmd-18.8 {Windows reserved path names} -constraints win -body { + file normalize cOm1: +} -result COM1 + # This block of code used to occur after the "return" call, so I'm # commenting it out and assuming that this code is still under construction. #foreach source {tef ted tnf tnd "" nul com1} { # foreach chmodsrc {000 755} { Index: tests/winFile.test ================================================================== --- tests/winFile.test +++ tests/winFile.test @@ -8,11 +8,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: winFile.test,v 1.16 2004/11/08 19:19:27 davygrvy Exp $ +# RCS: @(#) $Id: winFile.test,v 1.16.2.1 2005/10/08 13:44:39 dgp Exp $ if {[catch {package require tcltest 2.0.2}]} { puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." return } @@ -110,11 +110,11 @@ set owner "" foreach line [split $dirtext "\n"] { if {[string match -nocase "* $tail" $line]} { set attrs [string range $line \ 0 end-[string length $tail]] - regexp { [A-Z]+\\.*$} $attrs owner + regexp { [^ \\]+\\.*$} $attrs owner set owner [string trim $owner] } } if {"" == "$owner"} { error "getuser: Owner not found in output of dir/q" ADDED tools/fix_tommath_h.tcl Index: tools/fix_tommath_h.tcl ================================================================== --- /dev/null +++ tools/fix_tommath_h.tcl @@ -0,0 +1,54 @@ +# fixtommath.tcl -- +# +# Changes to 'tommath.h' to make it conform with Tcl's linking +# conventions. +# +# Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: fix_tommath_h.tcl,v 1.1.2.1 2005/01/20 19:13:56 kennykb Exp $ +# +#---------------------------------------------------------------------- + +set f [open [lindex $argv 0] r] +set data [read $f] +close $f + +foreach line [split $data \n] { + switch -regexp -- $line { + {#define BN_H_} { + puts $line + puts {} + puts "\#ifdef TCL_TOMMATH" + puts "\#include " + puts "\#endif" + puts "\#ifndef TOMMATH_STORAGE_CLASS" + puts "\#define TOMMATH_STORAGE_CLASS extern" + puts "\#endif" + } + {typedef.*mp_digit;} { + puts "\#ifndef MP_DIGIT_DECLARED" + puts $line + puts "\#define MP_DIGIT_DECLARED" + puts "\#endif" + } + {typedef struct} { + puts "\#ifndef MP_INT_DECLARED" + puts "\#define MP_INT_DECLARED" + puts "typedef struct mp_int mp_int;" + puts "\#endif" + puts "struct mp_int \{" + } + \}\ mp_int\; { + puts "\};" + } + "^(char|int|void)" { + puts "TOMMATH_STORAGE_CLASS $line" + } + default { + puts $line + } + } +} Index: tools/genStubs.tcl ================================================================== --- tools/genStubs.tcl +++ tools/genStubs.tcl @@ -6,11 +6,11 @@ # # Copyright (c) 1998-1999 by Scriptics Corporation. # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: genStubs.tcl,v 1.17 2004/03/17 18:14:18 das Exp $ +# RCS: @(#) $Id: genStubs.tcl,v 1.17.2.1 2005/09/15 20:58:40 dgp Exp $ package require Tcl 8 namespace eval genStubs { # libraryName -- @@ -369,11 +369,11 @@ void { append line "(void)" } TCL_VARARGS { set arg [lindex $args 1] - append line "TCL_VARARGS([lindex $arg 0],[lindex $arg 1])" + append line "([lindex $arg 0][lindex $arg 1], ...)" } default { set sep "(" foreach arg $args { append line $sep @@ -462,17 +462,17 @@ set arg1 [lindex $args 0] if {![string compare $arg1 "TCL_VARARGS"]} { lassign [lindex $args 1] type argName - append text " TCL_VARARGS_DEF($type,$argName)\n\{\n" + append text " ($type$argName, ...)\n\{\n" append text " " $type " var;\n va_list argList;\n" if {[string compare $rtype "void"]} { append text " " $rtype " resultValue;\n" } - append text "\n var = (" $type ") TCL_VARARGS_START(" \ - $type "," $argName ",argList);\n\n " + append text "\n var = (" $type ") (va_start(argList, " \ + $argName "), " $argName ");\n\n " if {[string compare $rtype "void"]} { append text "resultValue = " } append text "(" $name "StubsPtr->" $lfname "VA)(var, argList);\n" append text " va_end(argList);\n" @@ -531,11 +531,11 @@ void { append text "(void)" } TCL_VARARGS { set arg [lindex $args 1] - append text "TCL_VARARGS([lindex $arg 0],[lindex $arg 1])" + append text "([lindex $arg 0][lindex $arg 1], ...)" } default { set sep "(" foreach arg $args { append text $sep [lindex $arg 0] " " [lindex $arg 1] \ Index: tools/loadICU.tcl ================================================================== --- tools/loadICU.tcl +++ tools/loadICU.tcl @@ -24,11 +24,11 @@ # # Copyright (c) 2004 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: loadICU.tcl,v 1.1 2004/08/18 19:59:09 kennykb Exp $ +# RCS: @(#) $Id: loadICU.tcl,v 1.1.4.1 2005/10/08 13:45:04 dgp Exp $ # #---------------------------------------------------------------------- # Calculate the Chinese numerals from zero to ninety-nine. @@ -615,8 +615,8 @@ # Walk the ICU files and create corresponding Tcl message catalogs foreach fileName [glob -directory $icudir *.txt] { set n [file rootname [file tail $fileName]] if { [regexp {^[a-z]{2,3}(_[A-Z]{2,3}(_.*)?)?$} $n] } { - handleLocaleFile $n $fileName [file join $msgdir ${n}.msg] + handleLocaleFile $n $fileName [file join $msgdir [string tolower $n].msg] } } Index: tools/makeTestCases.tcl ================================================================== --- tools/makeTestCases.tcl +++ tools/makeTestCases.tcl @@ -1,10 +1,11 @@ # TODO - When integrating this with the Core, path names will need to be # swizzled here. -package require newclock +package require msgcat set d [file dirname [file dirname [info script]]] +puts "getting transition data from [file join $d library tzdata America Detroit]" source [file join $d library/tzdata/America/Detroit] namespace eval ::tcl::clock { ::msgcat::mcmset en_US_roman { LOCALE_ERAS { @@ -545,21 +546,18 @@ puts $f2 {} set fmt {%H:%M:%S %z %Z} set i 0 - puts $f2 "::tcltest::testConstraint detroit 0" puts $f2 "test clock-5.[incr i] {does Detroit exist} {" puts $f2 " clock format 0 -format {} -timezone :America/Detroit" - puts $f2 " ::tcltest::testConstraint detroit 1" puts $f2 " concat" puts $f2 "} {}" puts $f2 "test clock-5.[incr i] {does Detroit have a Y2038 problem} detroit {" puts $f2 " if { \[clock format 2158894800 -format %z -timezone :America/Detroit\] ne {-0400} } {" puts $f2 " concat {y2038 problem}" puts $f2 " } else {" - puts $f2 " ::tcltest::testConstraint y2038 1" puts $f2 " concat {ok}" puts $f2 " }" puts $f2 "} ok" foreach row $TZData(:America/Detroit) { Index: tools/man2html2.tcl ================================================================== --- tools/man2html2.tcl +++ tools/man2html2.tcl @@ -3,11 +3,11 @@ # This file defines procedures that are used during the second pass of the # man page to html conversion process. It is sourced by man2html.tcl. # # Copyright (c) 1996 by Sun Microsystems, Inc. # -# $Id: man2html2.tcl,v 1.7 2004/11/24 11:24:34 dkf Exp $ +# $Id: man2html2.tcl,v 1.7.2.1 2005/04/10 23:15:16 kennykb Exp $ # package require Tcl 8.4 # Global variables used by these scripts: @@ -717,21 +717,18 @@ # Special case for alternative mechanism for declaring bullets if {[lindex $argList 0] eq "\\(bu"} { nest para UL LI return } - if {$length == 1} { + if {[regexp {^\[\d+\]$} [lindex $argList 0]]} { nest para OL LI return } - if {$length > 1} { - nest para DL DT - formattedText [lindex $argList 0] - puts $file "\n
" - return - } - puts stderr "Bad .IP macro: .IP [join $argList " "]" + nest para DL DT + formattedText [lindex $argList 0] + puts $file "\n
" + return } # TPmacro -- # Index: tools/tcl.wse.in ================================================================== --- tools/tcl.wse.in +++ tools/tcl.wse.in @@ -10,11 +10,11 @@ End Gradient=0 0 0 Windows Flags=00000000000000010010110000001000 Log Pathname=%MAINDIR%\INSTALL.LOG Message Font=MS Sans Serif Font Size=8 - Disk Label=tcl8.5a2 + Disk Label=tcl8.5a4 Disk Filename=setup Patch Flags=0000000000000001 Patch Threshold=85 Patch Memory=4000 Variable Name1=_SYS_ Index: tools/tclZIC.tcl ================================================================== --- tools/tclZIC.tcl +++ tools/tclZIC.tcl @@ -23,17 +23,19 @@ # 'zic' command, and produces Tcl time zone information files suitable # for loading into the 'clock' namespace. # #---------------------------------------------------------------------- # -# Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. +# Copyright (c) 2004 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: tclZIC.tcl,v 1.3 2004/11/02 15:16:38 kennykb Exp $ +# RCS: @(#) $Id: tclZIC.tcl,v 1.3.2.1 2005/04/25 21:37:30 kennykb Exp $ # #---------------------------------------------------------------------- + +package require Tcl 8.5 # Define the names of the Olson files that we need to load. # We avoid the solar time files and the leap seconds. set olsonFiles { @@ -50,44 +52,19 @@ set maxyear 2100 # Determine how big a wide integer is. -set MAXWIDE [expr { wide(1) }] +set MAXWIDE [expr {wide(1)}] while 1 { - set next [expr { $MAXWIDE + $MAXWIDE + 1}] - if { $next < 0 } { + set next [expr {$MAXWIDE + $MAXWIDE + 1}] + if {$next < 0} { break } set MAXWIDE $next } -set MINWIDE [expr { - $MAXWIDE - 1 }] - -#---------------------------------------------------------------------- -# -# K -- -# -# The K combinator returns its first argument. It's used for -# reference count management. -# -# Parameters: -# x - Argument to be unreferenced. -# y - Unused. -# -# Results: -# Returns the first argument. -# -# Side effects: -# None. -# -# The K combinator is used for its effect that [K $x [set x {}]] -# reads out the value of x destructively, giving an unshared Tcl -# object and avoiding 'copy on write' -# -#---------------------------------------------------------------------- - -proc K {x y} {return $x} +set MINWIDE [expr {-$MAXWIDE-1}] #---------------------------------------------------------------------- # # loadFiles -- # @@ -103,11 +80,11 @@ # Calls 'loadZIC' for each continent's data file in turn. # Reports progress on stdout. # #---------------------------------------------------------------------- -proc loadFiles { dir } { +proc loadFiles {dir} { variable olsonFiles foreach file $olsonFiles { puts "loading: [file join $dir $file]" loadZIC [file join $dir $file] } @@ -134,13 +111,14 @@ #---------------------------------------------------------------------- proc checkForwardRuleRefs {} { variable forwardRuleRefs variable rules - foreach { rule where } [array get forwardRuleRefs] { - if { ![info exists rules($rule)] } { - foreach { fileName lno } $where { + + foreach {rule where} [array get forwardRuleRefs] { + if {![info exists rules($rule)]} { + foreach {fileName lno} $where { puts stderr "$fileName:$lno:can't locate rule \"$rule\"" incr errorCount } } } @@ -165,12 +143,11 @@ # the values are 'links from'. The 'parseRule' and 'parseZone' # procedures are called to handle 'Rule' and 'Zone' directives. # #---------------------------------------------------------------------- -proc loadZIC { fileName } { - +proc loadZIC {fileName} { variable errorCount variable links # Suck the text into memory. @@ -184,23 +161,20 @@ foreach line [split $data \n] { incr lno # Break a line of input into words. - regsub {[[:space:]]*(\#.*)?$} $line {} line - if { $line eq {} } { + regsub {\s*(\#.*)?$} $line {} line + if {$line eq ""} { continue } set words {} - if { [regexp {^[[:space:]]+(.*)} $line -> l] } { - lappend words {} - set line $l - } - while {[regexp {^([^[:space:]]+)[[:space:]]*(.*)} $line -> \ - word line]} { - lappend words $word - } + if {[regexp {^\s} $line]} { + # Detect continuations of a zone and flag the list appropriately + lappend words "" + } + lappend words {expand}[regexp -all -inline {\S+} $line] # Switch on the directive switch -exact -- [lindex $words 0] { Rule { @@ -210,16 +184,18 @@ set links([lindex $words 2]) [lindex $words 1] } Zone { set lastZone [lindex $words 1] set until [parseZone $fileName $lno \ - $lastZone [lrange $words 2 end] minimum] + $lastZone [lrange $words 2 end] "minimum"] } - {} { # Continuation of a Zone + {} { set i 0 foreach word $words { - if { [lindex $words $i] ne {} } break + if {[lindex $words $i] ne ""} { + break + } incr i } set words [lrange $words $i end] set until [parseZone $fileName $lno $lastZone $words $until] } @@ -229,11 +205,10 @@ } } } return - } #---------------------------------------------------------------------- # # parseRule -- @@ -252,95 +227,92 @@ # The rule is analyzed and added to the 'rules' array. # Errors are reported and counted. # #---------------------------------------------------------------------- -proc parseRule { fileName lno words } { - +proc parseRule {fileName lno words} { variable rules variable errorCount # Break out the columns - foreach { Rule name from to type in on at save letter } $words {} + lassign $words Rule name from to type in on at save letter # Handle the 'only' keyword - if { $to eq {only} } { + if {$to eq "only"} { set to $from } # Process the start year - set l [string length $from] - if { ![string is integer $from] } { - if { $from ne [string range {minumum} 0 [expr { $l - 1 }]] } { + if {![string is integer $from]} { + if {![string equal -length [string length $from] $from "minimum"]} { puts stderr "$fileName:$lno:FROM field \"$from\" not an integer." incr errorCount return } else { - set from minimum + set from "minimum" } } # Process the end year - set l [string length $to] - if { ![string is integer $to] } { - if { $to ne [string range {maximum} 0 [expr { $l - 1 }]] } { + if {![string is integer $to]} { + if {![string equal -length [string length $to] $to "maximum"]} { puts stderr "$fileName:$lno:TO field \"$to\" not an integer." incr errorCount return } else { - set to maximum + set to "maximum" } } # Process the type of year in which the rule applies - if { $type ne {-} } { + if {$type ne "-"} { puts stderr "$fileName:$lno:year types are not yet supported." incr errorCount return } # Process the month in which the rule starts - if { [catch {lookupMonth $in} in] } { + if {[catch {lookupMonth $in} in]} { puts stderr "$fileName:$lno:$in" incr errorCount return } # Process the day of the month on which the rule starts - if { [catch {parseON $on} on] } { + if {[catch {parseON $on} on]} { puts stderr "$fileName:$lno:$on" incr errorCount return } # Process the time of day on which the rule starts - if { [catch {parseTOD $at} at] } { + if {[catch {parseTOD $at} at]} { puts stderr "$fileName:$lno:$at" incr errorCount return } # Process the DST adder - if { [catch {parseOffsetTime $save} save] } { + if {[catch {parseOffsetTime $save} save]} { puts stderr "$fileName:$lno:$save" incr errorCount return } - + # Process the letter to use for summer time - if { $letter eq {-} } { - set letter {} + if {$letter eq "-"} { + set letter "" } # Accumulate all the data. lappend rules($name) $from $to $type $in $on $at $save $letter @@ -356,11 +328,11 @@ # # Parameters: # on - the ON field from a line in an Olson file. # # Results: -# Returns a partial Tcl command. When the year and number of the +# Returns a partial Tcl command. When the year and number of the # month are appended, the command will return the Julian Day Number # of the desired date. # # Side effects: # None. @@ -372,45 +344,45 @@ # or before (on or after) the given day of the month. # - The word 'last' followed by a weekday name with no intervening # space. This designates the last occurrence of the given weekday # in the month. # -#---------------------------------------------------------------------- +#---------------------------------------------------------------------- -proc parseON { on } { - if { ! [regexp -expanded { +proc parseON {on} { + if {![regexp -expanded { ^(?: # first possibility - simple number - field 1 ([[:digit:]]+) - | + | # second possibility - weekday >= (or <=) number # field 2 - weekday ([[:alpha:]]+) # field 3 - direction ([<>]=) # field 4 - number ([[:digit:]]+) - | + | # third possibility - lastWeekday - field 5 last([[:alpha:]]+) - )$ - } $on -> dom1 wday2 dir2 num2 wday3] } { + )$ + } $on -> dom1 wday2 dir2 num2 wday3]} then { error "can't parse ON field \"$on\"" } - if { $dom1 ne {} } { + if {$dom1 ne ""} { return [list onDayOfMonth $dom1] - } elseif { $wday2 ne {} } { + } elseif {$wday2 ne ""} { set wday2 [lookupDayOfWeek $wday2] return [list onWeekdayInMonth $wday2 $dir2 $num2] - } elseif { $wday3 ne {} } { + } elseif {$wday3 ne ""} { set wday3 [lookupDayOfWeek $wday3] return [list onLastWeekdayInMonth $wday3] } else { error "in parseOn \"$on\": can't happen" } } - + #---------------------------------------------------------------------- # # onDayOfMonth -- # # Find a given day of a given month @@ -426,14 +398,13 @@ # Side effects: # None. # #---------------------------------------------------------------------- -proc onDayOfMonth { day year month } { - set date [dict create era CE year $year month $month dayOfMonth $day] +proc onDayOfMonth {day year month} { set date [::tcl::clock::GetJulianDayFromEraYearMonthDay \ - [K $date [set date {}]]] + [dict create era CE year $year month $month dayOfMonth $day]] return [dict get $date julianDay] } #---------------------------------------------------------------------- # @@ -460,23 +431,21 @@ # like 'Sun>=1' (for the nearest Sunday on or after the first of the month) # or "Mon<=4' (for the Monday on or before the fourth of the month). # #---------------------------------------------------------------------- -proc onWeekdayInMonth { dayOfWeek relation dayOfMonth year month } { - set date [dict create \ - era CE year $year month $month dayOfMonth $dayOfMonth] - set date [::tcl::clock::GetJulianDayFromEraYearMonthDay \ - [K $date [set date {}]]] +proc onWeekdayInMonth {dayOfWeek relation dayOfMonth year month} { + set date [::tcl::clock::GetJulianDayFromEraYearMonthDay [dict create \ + era CE year $year month $month dayOfMonth $dayOfMonth]] switch -exact -- $relation { <= { return [::tcl::clock::WeekdayOnOrBefore $dayOfWeek \ - [dict get $date julianDay]] + [dict get $date julianDay]] } >= { return [::tcl::clock::WeekdayOnOrBefore $dayOfWeek \ - [expr { [dict get $date julianDay] + 6 }]] + [expr {[dict get $date julianDay] + 6}]] } } } #---------------------------------------------------------------------- @@ -497,22 +466,20 @@ # Side effects: # None. # #---------------------------------------------------------------------- -proc onLastWeekdayInMonth { dayOfWeek year month } { +proc onLastWeekdayInMonth {dayOfWeek year month} { incr month # Find day 0 of the following month, which is the last day of # the current month. Yes, it works to ask for day 0 of month 13! - set date [dict create \ - era CE year $year month $month dayOfMonth 0] - set date [::tcl::clock::GetJulianDayFromEraYearMonthDay \ - [K $date [set date {}]]] + set date [::tcl::clock::GetJulianDayFromEraYearMonthDay [dict create \ + era CE year $year month $month dayOfMonth 0]] return [::tcl::clock::WeekdayOnOrBefore $dayOfWeek \ - [dict get $date julianDay]] + [dict get $date julianDay]] } - + #---------------------------------------------------------------------- # # parseTOD -- # # Parses the specification of a time of day in an Olson file. @@ -530,46 +497,42 @@ # Side effects: # Reports and counts an error if the time cannot be parsed. # #---------------------------------------------------------------------- -proc parseTOD { tod } { - if { ![regexp -expanded { - ^ - # field 1 - hour - ([[:digit:]]{1,2}) - (?: - # field 2 - minute - :([[:digit:]]{2}) - (?: - # field 3 - second - :([[:digit:]]{2}) - )? - )? - (?: - # field 4 - type indicator - ([wsugz]) - )? - } $tod -> hour minute second ind] } { +proc parseTOD {tod} { + if {![regexp -expanded { + ^ + ([[:digit:]]{1,2}) # field 1 - hour + (?: + :([[:digit:]]{2}) # field 2 - minute + (?: + :([[:digit:]]{2}) # field 3 - second + )? + )? + (?: + ([wsugz]) # field 4 - type indicator + )? + } $tod -> hour minute second ind]} then { puts stderr "$fileName:$lno:can't parse time field \"$tod\"" incr errorCount } scan $hour %d hour - if { $minute ne {} } { + if {$minute ne ""} { scan $minute %d minute } else { set minute 0 } - if { $second ne {} } { + if {$second ne ""} { scan $second %d second } else { set second 0 } - if { $ind eq {} } { + if {$ind eq ""} { set ind w } - return [list [expr { ( $hour * 60 + $minute ) * 60 + $second }] $ind] + return [list [expr {($hour * 60 + $minute) * 60 + $second}] $ind] } #---------------------------------------------------------------------- # # parseOffsetTime -- @@ -585,42 +548,38 @@ # Side effects: # Reports and counts an error if the time cannot be parsed. # #---------------------------------------------------------------------- -proc parseOffsetTime { offset } { - if { ![regexp -expanded { - ^ - # field 1 - signum - ([-+])? - # field 2 - hour - ([[:digit:]]{1,2}) - (?: - # field 3 - minute - :([[:digit:]]{2}) - (?: - # field 4 - second - :([[:digit:]]{2}) - )? - )? - } $offset -> signum hour minute second] } { +proc parseOffsetTime {offset} { + if {![regexp -expanded { + ^ + ([-+])? # field 1 - signum + ([[:digit:]]{1,2}) # field 2 - hour + (?: + :([[:digit:]]{2}) # field 3 - minute + (?: + :([[:digit:]]{2}) # field 4 - second + )? + )? + } $offset -> signum hour minute second]} then { puts stderr "$fileName:$lno:can't parse offset time \"$offset\"" incr errorCount } append signum 1 scan $hour %d hour - if { $minute ne {} } { + if {$minute ne ""} { scan $minute %d minute } else { set minute 0 } - if { $second ne {} } { + if {$second ne ""} { scan $second %d second } else { set second 0 } - return [expr { ( ( $hour * 60 + $minute ) * 60 + $second ) * $signum }] + return [expr {(($hour * 60 + $minute) * 60 + $second) * $signum}] } #---------------------------------------------------------------------- # @@ -636,17 +595,16 @@ # Side effects: # None. # #---------------------------------------------------------------------- -proc lookupMonth { month } { - +proc lookupMonth {month} { set indx [lsearch -regexp { {} January February March April May June July August September October November December } ${month}.*] - if { $indx < 1 } { + if {$indx < 1} { error "unknown month name \"$month\"" } return $indx } @@ -665,15 +623,15 @@ # Side effects: # None. # #---------------------------------------------------------------------- -proc lookupDayOfWeek { wday } { +proc lookupDayOfWeek {wday} { set indx [lsearch -regexp { {} Monday Tuesday Wednesday Thursday Friday Saturday Sunday } ${wday}.*] - if { $indx < 1 } { + if {$indx < 1} { error "unknown weekday name \"$wday\"" } return $indx } @@ -687,11 +645,11 @@ # fileName -- Name of the file being parsed. # lno -- Line number within the file. # zone -- Name of the time zone # words -- Remaining words on the line. # start -- 'Until' time from the previous line if this is a -# continuation line, or 'minimum' if this is the first line. +# continuation line, or 'minimum' if this is the first line. # # Results: # Returns the 'until' field of the current line # # Side effects: @@ -699,12 +657,12 @@ # The row consists of a start time (year month day tod), a Standard # Time offset from Greenwich, a Daylight Saving Time offset from # Standard Time, and a format for printing the time zone. # # The start time is the result of an earlier call to 'parseUntil' -# or else the keyword 'minimum'. The GMT offset is the -# result of a call to 'parseOffsetTime'. The Daylight Saving +# or else the keyword 'minimum'. The GMT offset is the +# result of a call to 'parseOffsetTime'. The Daylight Saving # Time offset is represented as a partial Tcl command. To the # command will be appended a start time (seconds from epoch) # the current offset of Standard Time from Greenwich, the current # offset of Daylight Saving Time from Greenwich, the default # offset from this line, the name pattern from this line, @@ -712,45 +670,44 @@ # are to be stored. This command is implemented by the 'applyNoRule', # 'applyDSTOffset' and 'applyRules' procedures. # #---------------------------------------------------------------------- -proc parseZone { fileName lno zone words start } { +proc parseZone {fileName lno zone words start} { variable zones variable rules variable errorCount variable forwardRuleRefs - foreach { gmtoff save format } $words break - if { [catch {parseOffsetTime $gmtoff} gmtoff] } { + + lassign $words gmtoff save format + if {[catch {parseOffsetTime $gmtoff} gmtoff]} { puts stderr "$fileName:$lno:$gmtoff" incr errorCount return - } - if { [info exists rules($save)] } { + } + if {[info exists rules($save)]} { set save [list applyRules $save] - } elseif { $save eq {-} } { + } elseif {$save eq "-"} { set save [list applyNoRule] + } elseif {[catch {parseOffsetTime $save} save2]} { + lappend forwardRuleRefs($save) $fileName $lno + set save [list applyRules $save] } else { - if { [catch { parseOffsetTime $save } save2] } { - lappend forwardRuleRefs($save) $fileName $lno - set save [list applyRules $save] - } else { - set save [list applyDSTOffset $save2] - } + set save [list applyDSTOffset $save2] } lappend zones($zone) $start $gmtoff $save $format - if { [llength $words] >= 4 } { + if {[llength $words] >= 4} { return [parseUntil [lrange $words 3 end]] } else { return {} } } #---------------------------------------------------------------------- # # parseUntil -- -# +# # Parses the 'UNTIL' part of a 'Zone' directive. # # Parameters: # words - The 'UNTIL' part of the directie. # @@ -759,34 +716,35 @@ # the time of day. Time of day is represented as the result of # 'parseTOD'. # #---------------------------------------------------------------------- -proc parseUntil { words } { +proc parseUntil {words} { variable firstYear - if { [llength $words] >= 1 } { + + if {[llength $words] >= 1} { set year [lindex $words 0] - if { ![string is integer $year] } { + if {![string is integer $year]} { error "can't parse UNTIL field \"$words\"" } - if { ![info exists firstYear] || $year < $firstYear } { + if {![info exists firstYear] || $year < $firstYear} { set firstYear $year } } else { - set year maximum + set year "maximum" } - if { [llength $words] >= 2 } { + if {[llength $words] >= 2} { set month [lookupMonth [lindex $words 1]] } else { set month 1 } - if { [llength $words] >= 3 } { + if {[llength $words] >= 3} { set day [parseON [lindex $words 2]] } else { set day {onDayOfMonth 1} } - if { [llength $words] >= 4 } { + if {[llength $words] >= 4} { set tod [parseTOD [lindex $words 3]] } else { set tod {0 w} } return [list $year $month $day $tod] @@ -822,29 +780,28 @@ # the offset from GMT, a zero (indicating that DST is not in effect), # and the name of the time zone. # #---------------------------------------------------------------------- -proc applyNoRule { year startSecs stdGMTOffset DSTOffset nextGMTOffset - namePattern until pointsVar } { +proc applyNoRule {year startSecs stdGMTOffset DSTOffset nextGMTOffset + namePattern until pointsVar} { upvar 1 $pointsVar points lappend points $startSecs $nextGMTOffset 0 \ - [convertNamePattern $namePattern -] + [convertNamePattern $namePattern -] return [list $nextGMTOffset 0] - } #---------------------------------------------------------------------- # -# applyNoRule -- +# applyDSTOffset -- # # Generates time zone data for a zone with permanent Daylight # Saving Time. # # Parameters: # nextDSTOffset - Offset of Daylight from Standard while the -# rule is in effect. +# rule is in effect. # year - Year in which the rule applies # startSecs - Time at which the rule starts. # stdGMTOffset - Offset from Greenwich prior to the start of the # rule # DSTOffset - Offset of Daylight from Standard prior to the @@ -864,19 +821,19 @@ # the offset from GMT, a one (indicating that DST is in effect), # and the name of the time zone. # #---------------------------------------------------------------------- -proc applyDSTOffset { nextDSTOffset year startSecs - stdGMTOffset DSTOffset nextGMTOffset - namePattern until pointsVar } { +proc applyDSTOffset {nextDSTOffset year startSecs + stdGMTOffset DSTOffset nextGMTOffset + namePattern until pointsVar} { upvar 1 $pointsVar points lappend points \ - $startSecs \ - [expr { $nextGMTOffset + $nextDSTOffset }] \ - 1 \ - [convertNamePattern $namePattern S] + $startSecs \ + [expr {$nextGMTOffset + $nextDSTOffset}] \ + 1 \ + [convertNamePattern $namePattern S] return [list $nextGMTOffset $nextDSTOffset] } #---------------------------------------------------------------------- # @@ -909,12 +866,12 @@ # in effect after the transition, a flag for whether DST is in # effect, and the name of the time zone. # #---------------------------------------------------------------------- -proc applyRules { ruleSet year startSecs stdGMTOffset DSTOffset nextGMTOffset \ - namePattern until pointsVar } { +proc applyRules {ruleSet year startSecs stdGMTOffset DSTOffset nextGMTOffset + namePattern until pointsVar} { variable done variable rules variable maxyear upvar 1 $pointsVar points @@ -921,145 +878,129 @@ # Extract the rules that apply to the current year, and the number # of rules (now or in future) that will end at a specific year. # Ignore rules entirely in the past. - foreach { - currentRules nSunsetRules - } [divideRules $ruleSet $year] break + lassign [divideRules $ruleSet $year] currentRules nSunsetRules # If the first transition is later than $startSecs, and $stdGMTOffset is # different from $nextGMTOffset, we will need an initial record like: - # lappend points $startSecs $stdGMTOffset 0 \ - # [convertNamePattern $namePattern -] + # lappend points $startSecs $stdGMTOffset 0 \ + # [convertNamePattern $namePattern -] set didTransitionIn false # Determine the letter to use in Standard Time - set prevLetter {} - foreach { + set prevLetter "" + foreach { fromYear toYear yearType monthIn daySpecOn timeAt save letter - } $rules($ruleSet) { - if { $save == 0 } { + } $rules($ruleSet) { + if {$save == 0} { set prevLetter $letter break - } + } } # Walk through each year in turn. This loop will break when - # (a) the 'until' time is passed + # (a) the 'until' time is passed # or (b) the 'until' time is empty and all remaining rules extend to - # the end of time + # the end of time set stdGMTOffset $nextGMTOffset # convert "until" to seconds from epoch in current time zone - if { $until ne {} } { - foreach { - untilYear untilMonth untilDaySpec untilTimeOfDay - } $until break + if {$until ne ""} { + lassign $until untilYear untilMonth untilDaySpec untilTimeOfDay lappend untilDaySpec $untilYear $untilMonth set untilJCD [eval $untilDaySpec] set untilBaseSecs [expr { - wide(86400) * wide($untilJCD) - - 210866803200 }] - set untilSecs [eval [linsert $untilTimeOfDay 0 convertTimeOfDay \ - $untilBaseSecs $stdGMTOffset $DSTOffset]] + wide(86400) * wide($untilJCD) - 210866803200 }] + set untilSecs [convertTimeOfDay $untilBaseSecs $stdGMTOffset \ + $DSTOffset {expand}$untilTimeOfDay] } set origStartSecs $startSecs - while { ( $until ne {} && - $startSecs < $untilSecs ) - || ( $until eq {} && - ( $nSunsetRules > 0 || $year < $maxyear ) ) } { - + while {($until ne "" && $startSecs < $untilSecs) + || ($until eq "" && ($nSunsetRules > 0 || $year < $maxyear))} { set remainingRules $currentRules - while { [llength $remainingRules] > 0 } { - + while {[llength $remainingRules] > 0} { # Find the rule with the earliest start time from among the # active rules that haven't yet been processed. - foreach { - earliestSecs earliestIndex - } [findEarliestRule $remainingRules $year \ - $stdGMTOffset $DSTOffset] break - + lassign [findEarliestRule $remainingRules $year \ + $stdGMTOffset $DSTOffset] earliestSecs earliestIndex + set endi [expr {$earliestIndex + 7}] set rule [lrange $remainingRules $earliestIndex $endi] - foreach { - fromYear toYear yearType monthIn daySpecOn timeAt save letter - } $rule break + lassign $rule fromYear toYear \ + yearType monthIn daySpecOn timeAt save letter # Test if the rule is in effect. - if { $earliestSecs > $startSecs && - ( $until eq {} || $earliestSecs < $untilSecs ) } { - + if { + $earliestSecs > $startSecs && + ($until eq "" || $earliestSecs < $untilSecs) + } then { # Test if the initial transition has been done. # If not, do it now. - if { !$didTransitionIn && $earliestSecs > $origStartSecs } { + if {!$didTransitionIn && $earliestSecs > $origStartSecs} { set nm [convertNamePattern $namePattern $prevLetter] lappend points \ - $origStartSecs \ - [expr { $stdGMTOffset + $DSTOffset }] \ - 0 \ - $nm + $origStartSecs \ + [expr {$stdGMTOffset + $DSTOffset}] \ + 0 \ + $nm set didTransitionIn true } # Add a row to 'points' for the rule set nm [convertNamePattern $namePattern $letter] lappend points \ - $earliestSecs \ - [expr { $stdGMTOffset + $save }] \ - [expr { $save != 0 }] \ - $nm + $earliestSecs \ + [expr {$stdGMTOffset + $save}] \ + [expr {$save != 0}] \ + $nm } # Remove the rule just applied from the queue set remainingRules [lreplace \ - [K $remainingRules \ - [set remainingRules {}]] \ - $earliestIndex $endi] + $remainingRules[set remainingRules {}] \ + $earliestIndex $endi] # Update current DST offset and time zone letter set DSTOffset $save set prevLetter $letter # Reconvert the 'until' time in the current zone. - - if { $until ne {} } { - set untilSecs [eval [linsert $untilTimeOfDay 0 \ - convertTimeOfDay $untilBaseSecs \ - $stdGMTOffset $DSTOffset]] + + if {$until ne ""} { + set untilSecs [convertTimeOfDay $untilBaseSecs \ + $stdGMTOffset $DSTOffset {expand}$untilTimeOfDay] } } # Advance to the next year incr year set date [::tcl::clock::GetJulianDayFromEraYearMonthDay \ - [dict create era CE year $year month 1 dayOfMonth 1]] - set startSecs [expr { [dict get $date julianDay] * wide(86400) \ - -210866803200 }] - set startSecs [expr { $startSecs - $stdGMTOffset - $DSTOffset }] - + [dict create era CE year $year month 1 dayOfMonth 1]] + set startSecs [expr { + [dict get $date julianDay] * wide(86400) - 210866803200 + - $stdGMTOffset - $DSTOffset + }] # Get rules in effect in the new year. - foreach { - currentRules nSunsetRules - } [divideRules $ruleSet $year] break - + lassign [divideRules $ruleSet $year] currentRules nSunsetRules } return [list $stdGMTOffset $DSTOffset] } @@ -1083,28 +1024,27 @@ # Side effects: # None. # #---------------------------------------------------------------------- -proc divideRules { ruleSet year } { - +proc divideRules {ruleSet year} { variable rules set currentRules {} set nSunsetRules 0 - foreach { + foreach { fromYear toYear yearType monthIn daySpecOn timeAt save letter - } $rules($ruleSet) { - if { $toYear ne {maximum} && $year > $toYear } { + } $rules($ruleSet) { + if {$toYear ne "maximum" && $year > $toYear} { # ignore - rule is in the past } else { - if { $fromYear eq {minimum} || $fromYear <= $year } { + if {$fromYear eq "minimum" || $fromYear <= $year} { lappend currentRules $fromYear $toYear $yearType $monthIn \ - $daySpecOn $timeAt $save $letter + $daySpecOn $timeAt $save $letter } - if { $toYear ne {maximum} } { + if {$toYear ne "maximum"} { incr nSunsetRules } } } @@ -1121,11 +1061,11 @@ # Parameters: # remainingRules -- Rules to search # year - Year being processed. # stdGMTOffset - Current offset of standard time from GMT # DSTOffset - Current offset of daylight time from standard, -# if daylight time is in effect. +# if daylight time is in effect. # # Results: # Returns the index in remainingRules of the next rule to # go into effect. # @@ -1132,33 +1072,29 @@ # Side effects: # None. # #---------------------------------------------------------------------- -proc findEarliestRule { remainingRules year stdGMTOffset DSTOffset } { - +proc findEarliestRule {remainingRules year stdGMTOffset DSTOffset} { set earliest $::MAXWIDE set i 0 foreach { fromYear toYear yearType monthIn daySpecOn timeAt save letter } $remainingRules { lappend daySpecOn $year $monthIn set dayIn [eval $daySpecOn] - set secs [expr { - wide(86400) * wide($dayIn) - -210866803200 }] - set secs [eval [linsert $timeAt 0 convertTimeOfDay \ - $secs $stdGMTOffset $DSTOffset]] - if { $secs < $earliest } { + set secs [expr {wide(86400) * wide($dayIn) - 210866803200}] + set secs [convertTimeOfDay $secs \ + $stdGMTOffset $DSTOffset {expand}$timeAt] + if {$secs < $earliest} { set earliest $secs set earliestIdx $i } incr i 8 } return [list $earliest $earliestIdx] - } #---------------------------------------------------------------------- # # convertNamePattern -- @@ -1176,13 +1112,13 @@ # Side effects: # None. # #---------------------------------------------------------------------- -proc convertNamePattern { pattern flag } { - if { [regexp {(.*)/(.*)} $pattern -> standard daylight] } { - if { $flag ne {} } { +proc convertNamePattern {pattern flag} { + if {[regexp {(.*)/(.*)} $pattern -> standard daylight]} { + if {$flag ne ""} { set pattern $daylight } else { set pattern $standard } } @@ -1202,30 +1138,30 @@ # stdGMTOffset - Offset of Standard Time from Greenwich # DSTOffset - Offset of Daylight Time from standard. # timeOfDay - Time of day to convert, in seconds from midnight # flag - Flag indicating whether the time is Greenwich, Standard # or wall-clock. (g, s, or w) -# +# # Results: # Returns the time of day in seconds from the Posix epoch. # # Side effects: # None. # #---------------------------------------------------------------------- -proc convertTimeOfDay { seconds stdGMTOffset DSTOffset timeOfDay flag } { +proc convertTimeOfDay {seconds stdGMTOffset DSTOffset timeOfDay flag} { incr seconds $timeOfDay switch -exact $flag { g - u - z { } w { - incr seconds [expr { -$stdGMTOffset }] - incr seconds [expr { -$DSTOffset }] + incr seconds [expr {-$stdGMTOffset}] + incr seconds [expr {-$DSTOffset}] } z { - incr seconds [expr { -$stdGMTOffset }] + incr seconds [expr {-$stdGMTOffset}] } } return $seconds } @@ -1240,11 +1176,11 @@ # zoneName - Name of the time zone # zoneData - List containing the rows describing the time zone, # obtained from 'parseZone. # # Results: -# Returns a list of rows. Each row consists of a time in +# Returns a list of rows. Each row consists of a time in # seconds from the Posix epoch, an offset from GMT to local # that begins at that time, a flag indicating whether DST # is in effect after that time, and the printable name of the # timezone that goes into effect at that time. # @@ -1251,40 +1187,37 @@ # Side effects: # None. # #---------------------------------------------------------------------- -proc processTimeZone { zoneName zoneData } { - +proc processTimeZone {zoneName zoneData} { set points {} set i 0 - foreach { startTime nextGMTOffset dstRule namePattern } $zoneData { + foreach {startTime nextGMTOffset dstRule namePattern} $zoneData { incr i 4 set until [lindex $zoneData $i] - if {! [info exists stdGMTOffset] } { + if {![info exists stdGMTOffset]} { set stdGMTOffset $nextGMTOffset } - if {! [info exists DSTOffset] } { + if {![info exists DSTOffset]} { set DSTOffset 0 } - if { $startTime eq {minimum} } { + if {$startTime eq "minimum"} { set secs $::MINWIDE set year 0 } else { - foreach { year month dayRule timeOfDay } $startTime break + lassign $startTime year month dayRule timeOfDay lappend dayRule $year $month set startDay [eval $dayRule] - set secs [expr { - wide(86400) * wide($startDay) - -210866803200}] - set secs [eval [linsert $timeOfDay 0 convertTimeOfDay \ - $secs $stdGMTOffset $DSTOffset]] + set secs [expr {wide(86400) * wide($startDay) -210866803200}] + set secs [convertTimeOfDay $secs \ + $stdGMTOffset $DSTOffset {expand}$timeOfDay] } lappend dstRule \ - $year $secs $stdGMTOffset $DSTOffset $nextGMTOffset \ - $namePattern $until points - foreach {stdGMTOffset DSTOffset} [eval $dstRule] break + $year $secs $stdGMTOffset $DSTOffset $nextGMTOffset \ + $namePattern $until points + lassign [eval $dstRule] stdGMTOffset DSTOffset } return $points } #---------------------------------------------------------------------- @@ -1303,12 +1236,11 @@ # Writes the time zone information files; traces what's happening # on the standard output. # #---------------------------------------------------------------------- -proc writeZones { outDir } { - +proc writeZones {outDir} { variable zones # Walk the zones foreach zoneName [lsort -dictionary [array names zones]] { @@ -1316,33 +1248,32 @@ set fileName [eval [list file join $outDir] [file split $zoneName]] # Create directories as needed set dirName [file dirname $fileName] - if { ![file exists $dirName] } { + if {![file exists $dirName]} { puts "creating directory: $dirName" file mkdir $dirName } # Generate data for a zone - set data {} - foreach { - time offset dst name + set data "" + foreach { + time offset dst name } [processTimeZone $zoneName $zones($zoneName)] { - append data \n { } [list [list $time $offset $dst $name]] + append data "\n " [list [list $time $offset $dst $name]] } append data \n # Write the data to the information file set f [open $fileName w] puts $f "\# created by $::argv0 - do not edit" - puts $f {} + puts $f "" puts $f [list set TZData(:$zoneName) $data] close $f - } return } @@ -1360,12 +1291,11 @@ # None. # # Side effects: # Creates a file for each link. -proc writeLinks { outDir } { - +proc writeLinks {outDir} { variable links # Walk the links foreach zoneName [lsort -dictionary [array names links]] { @@ -1373,11 +1303,11 @@ set fileName [eval [list file join $outDir] [file split $zoneName]] # Create directories as needed set dirName [file dirname $fileName] - if { ![file exists $dirName] } { + if {![file exists $dirName]} { puts "creating directory: $dirName" file mkdir $dirName } # Create code for the synonym @@ -1405,36 +1335,36 @@ # #---------------------------------------------------------------------- # Determine directories -foreach { inDir outDir } $argv break +lassign $argv inDir outDir # Initialize count of errors set errorCount 0 # Parse the Olson files loadFiles $inDir -if { $errorCount > 0 } { +if {$errorCount > 0} { exit 1 } # Check that all riles appearing in Zone and Link lines actually exist checkForwardRuleRefs -if { $errorCount > 0 } { +if {$errorCount > 0} { exit 1 } # Write the time zone information files writeZones $outDir writeLinks $outDir -if { $errorCount > 0 } { +if {$errorCount > 0} { exit 1 } # All done! exit Index: tools/tcltk-man2html.tcl ================================================================== --- tools/tcltk-man2html.tcl +++ tools/tcltk-man2html.tcl @@ -79,13 +79,16 @@ set tkdir {} set tcldir {} set webdir ../html set build_tcl 0 set build_tk 0 + # Default search version is a glob pattern + set useversion {{,[8-9].[0-9]{,.[0-9]{,[0-9]}}}} # Handle arguments a la GNU: # --version + # --useversion= # --help # --srcdir=/path # --htmldir=/path foreach option $argv { @@ -101,10 +104,11 @@ puts " --version print version number, then exit" puts " --srcdir=DIR find tcl and tk source below DIR" puts " --htmldir=DIR put generated HTML in DIR" puts " --tcl build tcl help" puts " --tk build tk help" + puts " --useversion version of tcl/tk to search for" exit 0 } --srcdir=* { # length of "--srcdir=" is 9. @@ -113,10 +117,15 @@ --htmldir=* { # length of "--htmldir=" is 10 set webdir [string range $option 10 end] } + + --useversion=* { + # length of "--useversion=" is 13 + set useversion [string range $option 13 end] + } --tcl { set build_tcl 1 } @@ -132,29 +141,29 @@ } if {!$build_tcl && !$build_tk} {set build_tcl 1; set build_tk 1} if {$build_tcl} { - # Find Tcl. - set tcldir [lindex [lsort [glob -nocomplain -tails -type d \ - -directory $tcltkdir {tcl{,[8-9].[0-9]{,.[0-9]}}}]] end] - if {$tcldir == ""} then { - puts stderr "tcltk-man-html: couldn't find Tcl below $tcltkdir" - exit 1 - } - puts "using Tcl source directory $tcldir" + # Find Tcl. + set tcldir [lindex [lsort [glob -nocomplain -tails -type d \ + -directory $tcltkdir tcl$useversion]] end] + if {$tcldir == ""} then { + puts stderr "tcltk-man-html: couldn't find Tcl below $tcltkdir" + exit 1 + } + puts "using Tcl source directory $tcldir" } if {$build_tk} { - # Find Tk. - set tkdir [lindex [lsort [glob -nocomplain -tails -type d \ - -directory $tcltkdir {tk{,[8-9].[0-9]{,.[0-9]}}}]] end] - if {$tkdir == ""} then { - puts stderr "tcltk-man-html: couldn't find Tk below $tcltkdir" - exit 1 - } - puts "using Tk source directory $tkdir" + # Find Tk. + set tkdir [lindex [lsort [glob -nocomplain -tails -type d \ + -directory $tcltkdir tk$useversion]] end] + if {$tkdir == ""} then { + puts stderr "tcltk-man-html: couldn't find Tk below $tcltkdir" + exit 1 + } + puts "using Tk source directory $tkdir" } # the title for the man pages overall global overall_title set overall_title "" Index: unix/Makefile.in ================================================================== --- unix/Makefile.in +++ unix/Makefile.in @@ -3,11 +3,11 @@ # then it is a template for a Makefile; to generate the actual Makefile, # run "./configure", which is a configuration script generated by the # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # -# RCS: @(#) $Id: Makefile.in,v 1.157 2004/11/24 00:10:30 dkf Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.157.2.19 2005/09/23 16:47:35 dgp Exp $ VERSION = @TCL_VERSION@ MAJOR_VERSION = @TCL_MAJOR_VERSION@ MINOR_VERSION = @TCL_MINOR_VERSION@ PATCH_LEVEL = @TCL_PATCH_LEVEL@ @@ -36,14 +36,14 @@ # The following definition can be set to non-null for special systems # like AFS with replication. It allows the pathnames used for installation # to be different than those used for actually reference files at # run-time. INSTALL_ROOT is prepended to $prefix and $exec_prefix # when installing files. -INSTALL_ROOT = +INSTALL_ROOT = $(DESTDIR) # Path for the platform independent Tcl scripting libraries: -TCL_LIBRARY = $(prefix)/lib/tcl$(VERSION) +TCL_LIBRARY = @TCL_LIBRARY@ # Path to use at runtime to refer to LIB_INSTALL_DIR: LIB_RUNTIME_DIR = $(libdir) # Directory in which to install the program tclsh: @@ -56,12 +56,15 @@ SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) # Directory in which to install the include file tcl.h: INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) +# Path to the private tcl header dir: +PRIVATE_INCLUDE_DIR = @PRIVATE_INCLUDE_DIR@ + # Directory in which to (optionally) install the private tcl headers: -PRIVATE_INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) +PRIVATE_INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(PRIVATE_INCLUDE_DIR) # Top-level directory in which to install manual entries: MAN_INSTALL_DIR = $(INSTALL_ROOT)$(mandir) # Directory in which to install manual entry for tclsh: @@ -73,18 +76,21 @@ # Directory in which to install manual entries for the built-in # Tcl commands: MANN_INSTALL_DIR = $(MAN_INSTALL_DIR)/mann +# Path to the html documentation dir: +HTML_DIR = @HTML_DIR@ + +# Directory in which to install html documentation: +HTML_INSTALL_DIR = $(INSTALL_ROOT)$(HTML_DIR) + # Package search path. TCL_PACKAGE_PATH = @TCL_PACKAGE_PATH@ # Tcl Module default path roots (TIP189). -TCL_MODULE_PATH = - -# Libraries built with optimization switches have this additional extension -TCL_DBGX = @TCL_DBGX@ +TCL_MODULE_PATH = @TCL_MODULE_PATH@ # warning flags CFLAGS_WARNING = @CFLAGS_WARNING@ # The default switches for optimization or debugging @@ -106,16 +112,10 @@ # To disable ANSI-C procedure prototypes reverse the comment characters # on the following lines: PROTO_FLAGS = #PROTO_FLAGS = -DNO_PROTOTYPE -# Mathematical functions like sin and atan2 are enabled for expressions -# by default. To disable them, reverse the comment characters on the -# following pairs of lines: -MATH_FLAGS = -#MATH_FLAGS = -DTCL_NO_MATH - # If you use the setenv, putenv, or unsetenv procedures to modify # environment variables in your application and you'd like those # modifications to appear in the "env" Tcl variable, switch the # comments on the two lines below so that Tcl provides these # procedures instead of your standard C library. @@ -164,11 +164,11 @@ # for installing, but there are just too many different versions of # "install" around; better to use the install-sh script that comes # with the distribution, which is slower but guaranteed to work. INSTALL_STRIP_PROGRAM = -s -INSTALL_STRIP_LIBRARY = -S -S +INSTALL_STRIP_LIBRARY = -S -S INSTALL = @srcdir@/install-sh -c INSTALL_PROGRAM = ${INSTALL} INSTALL_LIBRARY = ${INSTALL} INSTALL_DATA = ${INSTALL} -m 644 @@ -187,11 +187,10 @@ # these definitions by hand. STLIB_LD = @STLIB_LD@ SHLIB_LD = @SHLIB_LD@ SHLIB_CFLAGS = @SHLIB_CFLAGS@ -SHLIB_LD_FLAGS = @SHLIB_LD_FLAGS@ SHLIB_LD_LIBS = @SHLIB_LD_LIBS@ TCL_SHLIB_LD_EXTRAS = @TCL_SHLIB_LD_EXTRAS@ SHLIB_SUFFIX = @SHLIB_SUFFIX@ #SHLIB_SUFFIX = @@ -240,10 +239,11 @@ RANLIB = @RANLIB@ SRC_DIR = @srcdir@ TOP_DIR = $(SRC_DIR)/.. BUILD_DIR = @builddir@ GENERIC_DIR = $(TOP_DIR)/generic +TOMMATH_DIR = $(TOP_DIR)/libtommath COMPAT_DIR = $(TOP_DIR)/compat TOOL_DIR = $(TOP_DIR)/tools UNIX_DIR = $(SRC_DIR) MAC_OSX_DIR = $(TOP_DIR)/macosx # Must be absolute because of the cd dltest $(DLTEST_DIR)/configure below. @@ -273,23 +273,23 @@ # either. #---------------------------------------------------------------- CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \ --I${BUILD_DIR} -I${UNIX_DIR} -I${GENERIC_DIR} \ -${AC_FLAGS} ${MATH_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} \ -${NO_DEPRECATED_FLAGS} ${ENV_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} \ -${AC_FLAGS} ${MATH_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} ${ENV_FLAGS} +-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@ DEPEND_SWITCHES = ${CFLAGS} -I${UNIX_DIR} -I${GENERIC_DIR} \ -${AC_FLAGS} ${MATH_FLAGS} \ -${GENERIC_FLAGS} ${PROTO_FLAGS} +${AC_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} @EXTRA_CC_SWITCHES@ TCLSH_OBJS = tclAppInit.o TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \ tclThreadTest.o tclUnixTest.o @@ -301,24 +301,47 @@ tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o tclClock.o \ tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclCompCmds.o tclCompExpr.o \ tclCompile.o tclConfig.o tclDate.o tclDictObj.o tclEncoding.o \ tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \ tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \ - tclIOGT.o tclIOSock.o tclIOUtil.o tclLink.o tclListObj.o \ + tclIORChan.o tclIOGT.o tclIOSock.o tclIOUtil.o tclLink.o tclListObj.o \ tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \ tclObj.o tclPanic.o tclParse.o tclParseExpr.o tclPathObj.o tclPipe.o \ - tclPkg.o tclPkgConfig.o tclPosixStr.o tclPreserve.o tclProc.o tclRegexp.o \ - tclResolve.o tclResult.o tclScan.o tclStringObj.o tclThread.o \ + tclPkg.o tclPkgConfig.o tclPosixStr.o \ + tclPreserve.o tclProc.o tclRegexp.o \ + tclResolve.o tclResult.o tclScan.o tclStringObj.o \ + tclStrToD.o tclThread.o \ tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \ - tclStubLib.o tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o + tclStubLib.o tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.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_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_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_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} -MAC_OSX_OBJS = tclMacOSXBundle.o tclMacOSXFCmd.o +MAC_OSX_OBJS = tclMacOSXBundle.o tclMacOSXFCmd.o tclMacOSXNotify.o -OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${NOTIFY_OBJS} ${COMPAT_OBJS} \ - @DL_OBJS@ @PLAT_OBJS@ +OBJS = ${GENERIC_OBJS} ${TOMMATH_OBJS} ${UNIX_OBJS} ${NOTIFY_OBJS} \ + ${COMPAT_OBJS} @DL_OBJS@ @PLAT_OBJS@ TCL_DECLS = \ $(GENERIC_DIR)/tcl.decls \ $(GENERIC_DIR)/tclInt.decls @@ -367,10 +390,11 @@ $(GENERIC_DIR)/tclIO.c \ $(GENERIC_DIR)/tclIOCmd.c \ $(GENERIC_DIR)/tclIOGT.c \ $(GENERIC_DIR)/tclIOSock.c \ $(GENERIC_DIR)/tclIOUtil.c \ + $(GENERIC_DIR)/tclIORChan.c \ $(GENERIC_DIR)/tclLink.c \ $(GENERIC_DIR)/tclListObj.c \ $(GENERIC_DIR)/tclLiteral.c \ $(GENERIC_DIR)/tclLoad.c \ $(GENERIC_DIR)/tclMain.c \ @@ -391,10 +415,11 @@ $(GENERIC_DIR)/tclResult.c \ $(GENERIC_DIR)/tclScan.c \ $(GENERIC_DIR)/tclStubInit.c \ $(GENERIC_DIR)/tclStubLib.c \ $(GENERIC_DIR)/tclStringObj.c \ + $(GENERIC_DIR)/tclStrToD.c \ $(GENERIC_DIR)/tclTest.c \ $(GENERIC_DIR)/tclTestObj.c \ $(GENERIC_DIR)/tclTestProcBodyObj.c \ $(GENERIC_DIR)/tclThread.c \ $(GENERIC_DIR)/tclThreadAlloc.c \ @@ -406,10 +431,73 @@ $(GENERIC_DIR)/tclVar.c STUB_SRCS = \ $(GENERIC_DIR)/tclStubLib.c +TOMMATH_SRCS = \ + $(TOMMATH_DIR)/bncore.c \ + $(TOMMATH_DIR)/bn_reverse.c \ + $(TOMMATH_DIR)/bn_fast_s_mp_mul_digs.c \ + $(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 \ + $(TOMMATH_DIR)/bn_mp_div.c \ + $(TOMMATH_DIR)/bn_mp_div_d.c \ + $(TOMMATH_DIR)/bn_mp_div_2.c \ + $(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 \ + $(TOMMATH_DIR)/bn_mp_init_multi.c \ + $(TOMMATH_DIR)/bn_mp_init_set.c \ + $(TOMMATH_DIR)/bn_mp_init_size.c \ + $(TOMMATH_DIR)/bn_mp_karatsuba_mul.c \ + $(TOMMATH_DIR)/bn_mp_karatsuba_sqr.c \ + $(TOMMATH_DIR)/bn_mp_lshd.c \ + $(TOMMATH_DIR)/bn_mp_mod.c \ + $(TOMMATH_DIR)/bn_mp_mod_2d.c \ + $(TOMMATH_DIR)/bn_mp_mul.c \ + $(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 \ + $(TOMMATH_DIR)/bn_s_mp_sqr.c \ + $(TOMMATH_DIR)/bn_s_mp_sub.c + UNIX_HDRS = \ $(UNIX_DIR)/tclUnixPort.h # $(UNIX_DIR)/tclConfig.h UNIX_SRCS = \ @@ -416,21 +504,22 @@ $(UNIX_DIR)/tclAppInit.c \ $(UNIX_DIR)/tclUnixChan.c \ $(UNIX_DIR)/tclUnixEvent.c \ $(UNIX_DIR)/tclUnixFCmd.c \ $(UNIX_DIR)/tclUnixFile.c \ - $(UNIX_DIR)/tclUnixNotfy.c \ $(UNIX_DIR)/tclUnixPipe.c \ $(UNIX_DIR)/tclUnixSock.c \ $(UNIX_DIR)/tclUnixTest.c \ $(UNIX_DIR)/tclUnixThrd.c \ $(UNIX_DIR)/tclUnixTime.c \ $(UNIX_DIR)/tclUnixInit.c +NOTIFY_SRCS = \ + $(UNIX_DIR)/tclUnixNotfy.c + DL_SRCS = \ $(UNIX_DIR)/tclLoadAix.c \ - $(UNIX_DIR)/tclLoadAout.c \ $(UNIX_DIR)/tclLoadDl.c \ $(UNIX_DIR)/tclLoadDl2.c \ $(UNIX_DIR)/tclLoadDld.c \ $(UNIX_DIR)/tclLoadDyld.c \ $(GENERIC_DIR)/tclLoadNone.c \ @@ -437,17 +526,20 @@ $(UNIX_DIR)/tclLoadOSF.c \ $(UNIX_DIR)/tclLoadShl.c MAC_OSX_SRCS = \ $(MAC_OSX_DIR)/tclMacOSXBundle.c \ - $(MAC_OSX_DIR)/tclMacOSXFCmd.c + $(MAC_OSX_DIR)/tclMacOSXFCmd.c \ + $(MAC_OSX_DIR)/tclMacOSXNotify.c # Note: don't include DL_SRCS or MAC_OSX_SRCS in SRCS: most of those # files won't compile on the current machine, and they will cause # problems for things like "make depend". -SRCS = $(GENERIC_SRCS) $(UNIX_SRCS) $(STUB_SRCS) +SRCS = $(GENERIC_SRCS) $(TOMMATH_SRCS) \ + $(UNIX_SRCS) $(NOTIFY_SRCS) $(STUB_SRCS) \ + @PLAT_SRCS@ all: binaries libraries doc binaries: ${LIB_FILE} $(STUB_LIB_FILE) $(TCL_BUILD_EXP_FILE) tclsh @@ -499,52 +591,52 @@ # Specifying TESTFLAGS on the command line is the standard way to pass # args to tcltest, ie: # % make test TESTFLAGS="-verbose bps -file fileName.test" test: tcltest - @LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \ + @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \ TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ - ./tcltest $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) $(TCLTESTARGS) + ./tcltest $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) # Useful target to launch a built tcltest with the proper path,... runtest: tcltest - @LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \ + @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \ TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ ./tcltest # Useful target for running the test suite with an unwritable current # directory... ro-test: tcltest - @LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \ + @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \ TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ echo 'exec chmod -w .;package require tcltest;tcltest::temporaryDirectory /tmp;source ../tests/all.tcl;exec chmod +w .' | ./tcltest # This target can be used to run tclsh from the build directory # via `make shell SCRIPT=/tmp/foo.tcl` shell: tclsh - @LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \ + @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \ TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ ./tclsh $(SCRIPT) # This target can be used to run tclsh inside either gdb or insight gdb: tclsh - @echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}" > gdb.run + @echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > gdb.run @echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run $(GDB) ./tclsh --command=gdb.run rm gdb.run # This target can be used to run tclsh inside ddd ddd: tclsh - @echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}" > gdb.run + @echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > gdb.run @echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run $(DDD) -command=gdb.run ./tclsh rm gdb.run valgrind: tclsh tcltest - @LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \ + @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \ TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ - valgrind --num-callers=8 --leak-resolution=high -v --leak-check=yes --show-reachable=yes $(VALGRINDARGS) ./tcltest $(TOP_DIR)/tests/all.tcl -singleproc 1 $(TESTFLAGS) $(TCLTESTARGS) + valgrind --num-callers=8 --leak-resolution=high -v --leak-check=yes --show-reachable=yes $(VALGRINDARGS) ./tcltest $(TOP_DIR)/tests/all.tcl -singleproc 1 $(TESTFLAGS) # The following target outputs the name of the top-level source directory # for Tcl (it is used by Tk's configure script, for example). The # .NO_PARALLEL line is needed to avoid problems under Sun's "pmake". # Note: this target is now obsolete (use the autoconf variable @@ -560,10 +652,11 @@ # The name of the .c file is different than the name of the .y file # so that make doesn't try to automatically regenerate the .c file. gendate: bison --output-file=$(GENERIC_DIR)/tclDate.c \ + --no-lines \ --name-prefix=TclDate \ $(GENERIC_DIR)/tclGetDate.y # yacc -l $(GENERIC_DIR)/tclGetDate.y # sed -e 's/yy/TclDate/g' -e '/^#include /d' \ @@ -573,10 +666,19 @@ # -e '/#include /d' -e 's/const /CONST /g' \ # -e '/#define YYNEW/s/malloc/TclDateAlloc/g' \ # -e '/#define YYENLARGE/,/realloc/s/realloc/TclDateRealloc/g' \ # $(GENERIC_DIR)/tclDate.c # rm y.tab.c + +# The following target generates the file generic/tommath.h. +# It needs to be run (and the results checked) after updating +# to a new release of libtommath. + +gentommath_h: + $(TCL_EXE) "$(TOP_DIR)/tools/fix_tommath_h.tcl" \ + "$(TOMMATH_DIR)/tommath.h" \ + > "$(GENERIC_DIR)/tommath.h" # The following target generates the shared libraries in dltest/ that # are used for testing; they are included as part of the "tcltest" # target (via the BUILD_DLTEST variable) if dynamic loading is supported # on this platform. The Makefile in the dltest subdirectory creates @@ -583,14 +685,16 @@ # the dltest.marker file in this directory after a successful build. dltest.marker: cd dltest ; $(MAKE) -install: install-binaries install-libraries install-doc +INSTALL_TARGETS = install-binaries install-libraries install-doc @EXTRA_INSTALL@ + +install: $(INSTALL_TARGETS) install-strip: - $(MAKE) install \ + $(MAKE) $(INSTALL_TARGETS) \ INSTALL_PROGRAM="$(INSTALL_PROGRAM) ${INSTALL_STRIP_PROGRAM}" \ INSTALL_LIBRARY="$(INSTALL_LIBRARY) ${INSTALL_STRIP_LIBRARY}" # Note: before running ranlib below, must cd to target directory because # some ranlibs write to current directory, and this might not always be @@ -623,10 +727,11 @@ @$(INSTALL_DATA) tclConfig.sh $(LIB_INSTALL_DIR)/tclConfig.sh @if test "$(STUB_LIB_FILE)" != "" ; then \ echo "Installing $(STUB_LIB_FILE) to $(LIB_INSTALL_DIR)/"; \ @INSTALL_STUB_LIB@ ; \ fi + @EXTRA_INSTALL_BINARIES@ install-libraries: libraries install-tzdata install-msgs @for i in $(INCLUDE_INSTALL_DIR) $(SCRIPT_INSTALL_DIR); \ do \ if [ ! -d $$i ] ; then \ @@ -662,21 +767,21 @@ @echo "Installing library http1.0 directory"; @for j in $(TOP_DIR)/library/http1.0/*.tcl ; \ do \ $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/http1.0; \ done; - @echo "Installing package http 2.5.0 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.2/http-2.5.0.tm; + @echo "Installing package http 2.5.1 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.2/http-2.5.1.tm; @echo "Installing library opt0.4 directory"; @for j in $(TOP_DIR)/library/opt/*.tcl ; \ do \ $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/opt0.4; \ done; @echo "Installing package msgcat 1.4.1 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.4.1.tm; - @echo "Installing package tcltest 2.2.7 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.3/tcltest-2.2.7.tm; + @echo "Installing package tcltest 2.2.8 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.3/tcltest-2.2.8.tm; @echo "Installing library encoding directory"; @for i in $(TOP_DIR)/library/encoding/*.enc ; do \ $(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR)/encoding; \ done; @if [ -n "$(TCL_MODULE_PATH)" -a -f $(TOP_DIR)/library/tm.tcl ]; then \ @@ -685,18 +790,18 @@ $(SCRIPT_INSTALL_DIR)/tm.tcl; \ fi install-tzdata: @echo "Installing time zone data" - @@LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \ + @@LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \ TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ ./tclsh $(TOOL_DIR)/installData.tcl \ $(TOP_DIR)/library/tzdata $(SCRIPT_INSTALL_DIR)/tzdata install-msgs: @echo "Installing message catalogs" - @@LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \ + @@LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \ TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ ./tclsh $(TOOL_DIR)/installData.tcl \ $(TOP_DIR)/library/msgs $(SCRIPT_INSTALL_DIR)/msgs install-doc: doc @@ -746,24 +851,27 @@ $(GENERIC_DIR)/tclIntPlatDecls.h $(GENERIC_DIR)/tclPort.h \ $(UNIX_DIR)/tclUnixPort.h; \ do \ $(INSTALL_DATA) $$i $(PRIVATE_INCLUDE_INSTALL_DIR); \ done; + @if test -f tclConfig.h; then\ + $(INSTALL_DATA) tclConfig.h $(PRIVATE_INCLUDE_INSTALL_DIR); \ + fi; Makefile: $(UNIX_DIR)/Makefile.in $(DLTEST_DIR)/Makefile.in $(SHELL) config.status #tclConfig.h: $(UNIX_DIR)/tclConfig.h.in # $(SHELL) config.status clean: rm -f *.a *.o libtcl* core errs *~ \#* TAGS *.E a.out \ - errors tclsh tcltest lib.exp + errors tclsh tcltest lib.exp Tcl cd dltest ; $(MAKE) clean distclean: clean rm -rf Makefile config.status config.cache config.log tclConfig.sh \ - $(PACKAGE).* prototype #tclConfig.h + $(PACKAGE).* prototype tclConfig.h *.plist Tcl.framework cd dltest ; $(MAKE) distclean depend: makedepend -- $(DEPEND_SWITCHES) -- $(SRCS) @@ -915,10 +1023,13 @@ $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIOSock.c tclIOUtil.o: $(GENERIC_DIR)/tclIOUtil.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIOUtil.c +tclIORChan.o: $(GENERIC_DIR)/tclIORChan.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIORChan.c + tclLink.o: $(GENERIC_DIR)/tclLink.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLink.c tclListObj.o: $(GENERIC_DIR)/tclListObj.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclListObj.c @@ -933,13 +1044,10 @@ $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLoad.c tclLoadAix.o: $(UNIX_DIR)/tclLoadAix.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadAix.c -tclLoadAout.o: $(UNIX_DIR)/tclLoadAout.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadAout.c - tclLoadDl.o: $(UNIX_DIR)/tclLoadDl.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadDl.c tclLoadDl2.o: $(UNIX_DIR)/tclLoadDl2.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadDl2.c @@ -1033,10 +1141,13 @@ $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclScan.c tclStringObj.o: $(GENERIC_DIR)/tclStringObj.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStringObj.c +tclStrToD.o: $(GENERIC_DIR)/tclStrToD.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStrToD.c + tclStubInit.o: $(GENERIC_DIR)/tclStubInit.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStubInit.c tclTrace.o: $(GENERIC_DIR)/tclTrace.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTrace.c @@ -1075,10 +1186,196 @@ $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThreadStorage.c tclThreadTest.o: $(GENERIC_DIR)/tclThreadTest.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThreadTest.c +tclTomMathInterface.o: $(GENERIC_DIR)/tclTomMathInterface.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTomMathInterface.c + +bncore.o: $(TOMMATH_DIR)/bncore.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bncore.c + +bn_reverse.o: $(TOMMATH_DIR)/bn_reverse.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_reverse.c + +bn_fast_s_mp_mul_digs.o: $(TOMMATH_DIR)/bn_fast_s_mp_mul_digs.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_fast_s_mp_mul_digs.c + +bn_fast_s_mp_sqr.o: $(TOMMATH_DIR)/bn_fast_s_mp_sqr.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_fast_s_mp_sqr.c + +bn_mp_add.o: $(TOMMATH_DIR)/bn_mp_add.c + $(CC) -c $(CC_SWITCHES) $(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 + +bn_mp_clear.o: $(TOMMATH_DIR)/bn_mp_clear.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_clear.c + +bn_mp_clear_multi.o: $(TOMMATH_DIR)/bn_mp_clear_multi.c + $(CC) -c $(CC_SWITCHES) $(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 + +bn_mp_copy.o: $(TOMMATH_DIR)/bn_mp_copy.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_copy.c + +bn_mp_count_bits.o: $(TOMMATH_DIR)/bn_mp_count_bits.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_count_bits.c + +bn_mp_div.o: $(TOMMATH_DIR)/bn_mp_div.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_div.c + +bn_mp_div_d.o: $(TOMMATH_DIR)/bn_mp_div_d.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_div_d.c + +bn_mp_div_2.o: $(TOMMATH_DIR)/bn_mp_div_2.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_div_2.c + +bn_mp_div_2d.o: $(TOMMATH_DIR)/bn_mp_div_2d.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_div_2d.c + +bn_mp_div_3.o: $(TOMMATH_DIR)/bn_mp_div_3.c + $(CC) -c $(CC_SWITCHES) $(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 + +bn_mp_init.o: $(TOMMATH_DIR)/bn_mp_init.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init.c + +bn_mp_init_copy.o: $(TOMMATH_DIR)/bn_mp_init_copy.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_copy.c + +bn_mp_init_multi.o: $(TOMMATH_DIR)/bn_mp_init_multi.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_multi.c + +bn_mp_init_set.o: $(TOMMATH_DIR)/bn_mp_init_set.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_set.c + +bn_mp_init_size.o:$(TOMMATH_DIR)/bn_mp_init_size.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_size.c + +bn_mp_karatsuba_mul.o: $(TOMMATH_DIR)/bn_mp_karatsuba_mul.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_karatsuba_mul.c + +bn_mp_karatsuba_sqr.o: $(TOMMATH_DIR)/bn_mp_karatsuba_sqr.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_karatsuba_sqr.c + +bn_mp_lshd.o: $(TOMMATH_DIR)/bn_mp_lshd.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_lshd.c + +bn_mp_mod.o: $(TOMMATH_DIR)/bn_mp_mod.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_mod.c + +bn_mp_mod_2d.o: $(TOMMATH_DIR)/bn_mp_mod_2d.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_mod_2d.c + +bn_mp_mul.o: $(TOMMATH_DIR)/bn_mp_mul.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_mul.c + +bn_mp_mul_2.o: $(TOMMATH_DIR)/bn_mp_mul_2.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_mul_2.c + +bn_mp_mul_2d.o: $(TOMMATH_DIR)/bn_mp_mul_2d.c + $(CC) -c $(CC_SWITCHES) $(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 + +bn_mp_radix_smap.o: $(TOMMATH_DIR)/bn_mp_radix_smap.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_radix_smap.c + +bn_mp_read_radix.o: $(TOMMATH_DIR)/bn_mp_read_radix.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_read_radix.c + +bn_mp_rshd.o: $(TOMMATH_DIR)/bn_mp_rshd.c + $(CC) -c $(CC_SWITCHES) $(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 + +bn_mp_toom_sqr.o: $(TOMMATH_DIR)/bn_mp_toom_sqr.c + $(CC) -c $(CC_SWITCHES) $(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 + +bn_s_mp_add.o: $(TOMMATH_DIR)/bn_s_mp_add.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_add.c + +bn_s_mp_mul_digs.o: $(TOMMATH_DIR)/bn_s_mp_mul_digs.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_mul_digs.c + +bn_s_mp_sqr.o: $(TOMMATH_DIR)/bn_s_mp_sqr.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_sqr.c + +bn_s_mp_sub.o: $(TOMMATH_DIR)/bn_s_mp_sub.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_sub.c + tclUnixChan.o: $(UNIX_DIR)/tclUnixChan.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixChan.c tclUnixEvent.o: $(UNIX_DIR)/tclUnixEvent.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixEvent.c @@ -1110,17 +1407,20 @@ tclUnixInit.o: $(UNIX_DIR)/tclUnixInit.c tclConfig.sh $(CC) -c $(CC_SWITCHES) -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \ -DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\"" \ $(UNIX_DIR)/tclUnixInit.c -# This is the CFBundle interface. It is only used on Mac OS X. +# The following are Mac OS X only sources: tclMacOSXBundle.o: $(MAC_OSX_DIR)/tclMacOSXBundle.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tclMacOSXBundle.c tclMacOSXFCmd.o: $(MAC_OSX_DIR)/tclMacOSXFCmd.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tclMacOSXFCmd.c +tclMacOSXNotify.o: $(MAC_OSX_DIR)/tclMacOSXNotify.c + $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tclMacOSXNotify.c + # The following targets are not completely general. They are provide # purely for documentation purposes so people who are interested in # the Xt based notifier can modify them to suit their own installation. xttest: ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \ @@ -1178,11 +1478,10 @@ waitpid.o: $(COMPAT_DIR)/waitpid.c $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/waitpid.c # Stub library binaries, these must be compiled for use in a shared library # even though they will be placed in a static archive - tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclStubLib.c .c.o: @@ -1268,11 +1567,11 @@ rm -rf RPMS THIS.TCL.SPEC # # Target to create a proper Tcl distribution from information in the # master source directory. DISTDIR must be defined to indicate where -# to put the distribution. +# to put the distribution. DISTDIR must be an absolute path name. # DISTROOT = /tmp/dist DISTNAME = tcl${VERSION}${PATCH_LEVEL} ZIPNAME = tcl${MAJOR_VERSION}${MINOR_VERSION}${PATCH_LEVEL}-src.zip @@ -1313,10 +1612,16 @@ mkdir $(DISTDIR)/library/$$i ;\ cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \ done; mkdir $(DISTDIR)/library/encoding cp -p $(TOP_DIR)/library/encoding/*.enc $(DISTDIR)/library/encoding + mkdir $(DISTDIR)/library/msgs + cp -p $(TOP_DIR)/library/msgs/*.msg $(DISTDIR)/library/msgs + ( cd $(TOP_DIR); \ + find library/tzdata -name CVS -prune -o -type f -print ) \ + | ( cd $(TOP_DIR) ; xargs tar cf - ) \ + | ( cd $(DISTDIR) ; tar xfp - ) mkdir $(DISTDIR)/doc cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/doc/*.[13n] \ $(TOP_DIR)/doc/man.macros $(DISTDIR)/doc mkdir $(DISTDIR)/compat cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/compat/*.c \ @@ -1350,11 +1655,11 @@ $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/tcl.ds* cp -p $(TOP_DIR)/win/README $(DISTDIR)/win cp -p $(TOP_DIR)/license.terms $(DISTDIR)/win mkdir $(DISTDIR)/macosx cp -p $(TOP_DIR)/macosx/Makefile \ - $(TOP_DIR)/macosx/*.c \ + $(TOP_DIR)/macosx/*.c $(TOP_DIR)/macosx/*.in \ $(DISTDIR)/macosx mkdir $(DISTDIR)/macosx/Tcl.pbproj cp -p $(TOP_DIR)/macosx/Tcl.pbproj/*.pbx* $(DISTDIR)/macosx/Tcl.pbproj cp -p $(TOP_DIR)/macosx/README $(DISTDIR)/macosx mkdir $(DISTDIR)/unix/dltest @@ -1368,10 +1673,13 @@ $(TOP_DIR)/tools/tcl.wse.in $(TOP_DIR)/tools/*.bmp \ $(TOP_DIR)/tools/tcl.hpj.in \ $(DISTDIR)/tools $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/tools/tcl.hpj.in \ $(DISTDIR)/tools/tcl.wse.in + mkdir $(DISTDIR)/libtommath + cp -p $(TOP_DIR)/libtommath/*.* \ + $(DISTDIR)/libtommath # # The following target can only be used for non-patch releases. Use # the "allpatch" target below for patch releases. # @@ -1400,24 +1708,29 @@ # # This target creates the HTML folder for Tcl & Tk and places it # in DISTDIR/html. It uses the tcltk-man2html.tcl tool from # the Tcl group's tool workspace. It depends on the Tcl & Tk being -# in directories called tcl8.3 & tk8.3 up two directories from the +# in directories called tcl8.* & tk8.* up two directories from the # TOOL_DIR. # html: $(BUILD_HTML) + @EXTRA_BUILD_HTML@ html-tcl: $(BUILD_HTML) --tcl + @EXTRA_BUILD_HTML@ html-tk: $(BUILD_HTML) --tk + @EXTRA_BUILD_HTML@ BUILD_HTML = \ - $(TCL_EXE) $(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(DISTDIR)/html \ - --srcdir=$(TOP_DIR)/.. + @@LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \ + TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ + ./tclsh $(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) \ + --srcdir=$(TOP_DIR)/.. $(BUILD_HTML_FLAGS) # # Targets to build Solaris package of the distribution for the current # architecture. To build stream packages for both sun4 and i86pc # architectures: Index: unix/configure ================================================================== --- unix/configure +++ unix/configure @@ -1,11 +1,10 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.57 for tcl 8.5. +# Generated by GNU Autoconf 2.59 for tcl 8.5. # -# Copyright 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, 2002 -# Free Software Foundation, Inc. +# Copyright (C) 2003 Free Software Foundation, Inc. # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## --------------------- ## ## M4sh Initialization. ## ## --------------------- ## @@ -18,13 +17,14 @@ # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then set -o posix fi +DUALCASE=1; export DUALCASE # for MKS sh # Support unset when possible. -if (FOO=FOO; unset FOO) >/dev/null 2>&1; then +if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then as_unset=unset else as_unset=false fi @@ -39,11 +39,11 @@ for as_var in \ LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ LC_TELEPHONE LC_TIME do - if (set +x; test -n "`(eval $as_var=C; export $as_var) 2>&1`"); then + if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then eval $as_var=C; export $as_var else $as_unset $as_var fi done @@ -216,20 +216,21 @@ rm -f conf$$ conf$$.exe conf$$.file if mkdir -p . 2>/dev/null; then as_mkdir_p=: else + test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_executable_p="test -f" # Sed expression to map a string onto a valid CPP name. -as_tr_cpp="sed y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g" +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. -as_tr_sh="sed y%*+%pp%;s%[^_$as_cr_alnum]%_%g" +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" # IFS # We need space, tab and new line, in precisely that order. as_nl=' @@ -305,11 +306,11 @@ #endif #if HAVE_UNISTD_H # include #endif" -ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS MAN_FLAGS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP TCL_THREADS RANLIB ac_ct_RANLIB AR LIBOBJS TCL_LIBS DL_LIBS DL_OBJS PLAT_OBJS CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING LDFLAGS_DEBUG LDFLAGS_OPTIMIZE CC_SEARCH_FLAGS LD_SEARCH_FLAGS STLIB_LD SHLIB_LD TCL_SHLIB_LD_EXTRAS TK_SHLIB_LD_EXTRAS SHLIB_LD_FLAGS SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX MAKE_LIB MAKE_STUB_LIB INSTALL_LIB INSTALL_STUB_LIB CFLAGS_DEFAULT LDFLAGS_DEFAULT TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL TCL_LIB_FILE TCL_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_SRC_DIR TCL_DBGX CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_EXPORT_FILE_SUFFIX TCL_SHARED_BUILD LD_LIBRARY_PATH_VAR TCL_BUILD_LIB_SPEC TCL_NEEDS_EXP_FILE TCL_BUILD_EXP_FILE TCL_EXP_FILE TCL_LIB_VERSIONS_OK TCL_SHARED_LIB_SUFFIX TCL_UNSHARED_LIB_SUFFIX TCL_HAS_LONGLONG BUILD_DLTEST TCL_PACKAGE_PATH LTLIBOBJS' +ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS MAN_FLAGS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP TCL_THREADS RANLIB ac_ct_RANLIB AR LIBOBJS TCL_LIBS DL_LIBS DL_OBJS PLAT_OBJS PLAT_SRCS CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING LDFLAGS_DEBUG LDFLAGS_OPTIMIZE CC_SEARCH_FLAGS LD_SEARCH_FLAGS STLIB_LD SHLIB_LD TCL_SHLIB_LD_EXTRAS TK_SHLIB_LD_EXTRAS SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX MAKE_LIB MAKE_STUB_LIB INSTALL_LIB INSTALL_STUB_LIB CFLAGS_DEFAULT LDFLAGS_DEFAULT TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL TCL_YEAR TCL_LIB_FILE TCL_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_SRC_DIR CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_EXPORT_FILE_SUFFIX TCL_SHARED_BUILD LD_LIBRARY_PATH_VAR TCL_BUILD_LIB_SPEC TCL_NEEDS_EXP_FILE TCL_BUILD_EXP_FILE TCL_EXP_FILE TCL_LIB_VERSIONS_OK TCL_SHARED_LIB_SUFFIX TCL_UNSHARED_LIB_SUFFIX TCL_HAS_LONGLONG BUILD_DLTEST TCL_PACKAGE_PATH TCL_MODULE_PATH TCL_LIBRARY PRIVATE_INCLUDE_DIR HTML_DIR EXTRA_CC_SWITCHES EXTRA_INSTALL EXTRA_INSTALL_BINARIES EXTRA_BUILD_HTML' ac_subst_files='' # Initialize some variables set by options. ac_init_help= ac_init_version=false @@ -664,11 +665,11 @@ esac done # Be sure to have absolute paths. for ac_var in bindir sbindir libexecdir datadir sysconfdir sharedstatedir \ - localstatedir libdir includedir oldincludedir infodir mandir + localstatedir libdir includedir oldincludedir infodir mandir do eval ac_val=$`echo $ac_var` case $ac_val in [\\/$]* | ?:[\\/]* ) ;; *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 @@ -704,14 +705,14 @@ if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then its parent. ac_confdir=`(dirname "$0") 2>/dev/null || $as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$0" : 'X\(//\)[^/]' \| \ - X"$0" : 'X\(//\)$' \| \ - X"$0" : 'X\(/\)' \| \ - . : '\(.\)' 2>/dev/null || + X"$0" : 'X\(//\)[^/]' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || echo X"$0" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } /^X\(\/\/\)[^/].*/{ s//\1/; q; } /^X\(\/\/\)$/{ s//\1/; q; } /^X\(\/\).*/{ s//\1/; q; } @@ -799,13 +800,13 @@ _ACEOF cat <<_ACEOF Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX - [$ac_default_prefix] + [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX - [PREFIX] + [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. @@ -838,31 +839,36 @@ cat <<\_ACEOF Optional Features: --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] - --enable-man-symlinks use symlinks for the manpages + --enable-man-symlinks use symlinks for the manpages (default: off) --enable-man-compression=PROG - compress the manpages with PROG + compress the manpages with PROG (default: off) --enable-man-suffix=STRING use STRING as a suffix to manpage file names - (default: tcl) - --enable-threads build with threads - --enable-shared build and link with shared libraries --enable-shared - --enable-64bit enable 64bit support (where applicable) - --enable-64bit-vis enable 64bit Sparc VIS support + (default: no, tcl if enabled without + specifying STRING) + --enable-threads build with threads (default: off) + --enable-shared build and link with shared libraries (default: on) + --enable-64bit enable 64bit support (default: off) + --enable-64bit-vis enable 64bit Sparc VIS support (default: off) + --enable-corefoundation use CoreFoundation API on MacOSX (default: yes) --disable-load disallow dynamic loading and "load" command - --enable-symbols build with debugging symbols --disable-symbols - --enable-langinfo use nl_langinfo if possible to determine - encoding at startup, otherwise use old heuristic - --enable-framework package shared libraries in MacOSX frameworks --disable-framework + (default: enabled) + --enable-symbols build with debugging symbols (default: off) + --enable-langinfo use nl_langinfo if possible to determine encoding at + startup, otherwise use old heuristic (default: on) --enable-dll-unloading turn on the 'unload' command (default: on) + --enable-framework package shared libraries in MacOSX frameworks + (default: off) Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) - --with-encoding encoding for configuration values + --with-encoding encoding for configuration values (default: + iso8859-1) Some influential environment variables: CC C compiler command CFLAGS C compiler flags LDFLAGS linker flags, e.g. -L if you have libraries in a @@ -905,16 +911,49 @@ ac_top_srcdir=$srcdir ;; *) # Relative path. ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_builddir$srcdir ;; esac -# Don't blindly perform a `cd "$ac_dir"/$ac_foo && pwd` since $ac_foo can be -# absolute. -ac_abs_builddir=`cd "$ac_dir" && cd $ac_builddir && pwd` -ac_abs_top_builddir=`cd "$ac_dir" && cd ${ac_top_builddir}. && pwd` -ac_abs_srcdir=`cd "$ac_dir" && cd $ac_srcdir && pwd` -ac_abs_top_srcdir=`cd "$ac_dir" && cd $ac_top_srcdir && pwd` + +# Do not use `cd foo && pwd` to compute absolute paths, because +# the directories may not exist. +case `pwd` in +.) ac_abs_builddir="$ac_dir";; +*) + case "$ac_dir" in + .) ac_abs_builddir=`pwd`;; + [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; + *) ac_abs_builddir=`pwd`/"$ac_dir";; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_builddir=${ac_top_builddir}.;; +*) + case ${ac_top_builddir}. in + .) ac_abs_top_builddir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; + *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_srcdir=$ac_srcdir;; +*) + case $ac_srcdir in + .) ac_abs_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; + *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_srcdir=$ac_top_srcdir;; +*) + case $ac_top_srcdir in + .) ac_abs_top_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; + *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; + esac;; +esac cd $ac_dir # Check for guested configure; otherwise get Cygnus style configure. if test -f $ac_srcdir/configure.gnu; then echo @@ -921,11 +960,11 @@ $SHELL $ac_srcdir/configure.gnu --help=recursive elif test -f $ac_srcdir/configure; then echo $SHELL $ac_srcdir/configure --help=recursive elif test -f $ac_srcdir/configure.ac || - test -f $ac_srcdir/configure.in; then + test -f $ac_srcdir/configure.in; then echo $ac_configure --help else echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi @@ -935,14 +974,13 @@ test -n "$ac_init_help" && exit 0 if $ac_init_version; then cat <<\_ACEOF tcl configure 8.5 -generated by GNU Autoconf 2.57 +generated by GNU Autoconf 2.59 -Copyright 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, 2002 -Free Software Foundation, Inc. +Copyright (C) 2003 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit 0 fi @@ -950,11 +988,11 @@ cat >&5 <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by tcl $as_me 8.5, which was -generated by GNU Autoconf 2.57. Invocation command line was +generated by GNU Autoconf 2.59. Invocation command line was $ $0 $@ _ACEOF { @@ -1027,23 +1065,23 @@ case $ac_pass in 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;; 2) ac_configure_args1="$ac_configure_args1 '$ac_arg'" if test $ac_must_keep_next = true; then - ac_must_keep_next=false # Got value, back to normal. + ac_must_keep_next=false # Got value, back to normal. else - case $ac_arg in - *=* | --config-cache | -C | -disable-* | --disable-* \ - | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ - | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ - | -with-* | --with-* | -without-* | --without-* | --x) - case "$ac_configure_args0 " in - "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; - esac - ;; - -* ) ac_must_keep_next=true ;; - esac + case $ac_arg in + *=* | --config-cache | -C | -disable-* | --disable-* \ + | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ + | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ + | -with-* | --with-* | -without-* | --without-* | --x) + case "$ac_configure_args0 " in + "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; + esac + ;; + -* ) ac_must_keep_next=true ;; + esac fi ac_configure_args="$ac_configure_args$ac_sep'$ac_arg'" # Get rid of the leading space. ac_sep=" " ;; @@ -1073,16 +1111,16 @@ { (set) 2>&1 | case `(ac_space='"'"' '"'"'; set | grep ac_space) 2>&1` in *ac_space=\ *) sed -n \ - "s/'"'"'/'"'"'\\\\'"'"''"'"'/g; - s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='"'"'\\2'"'"'/p" + "s/'"'"'/'"'"'\\\\'"'"''"'"'/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='"'"'\\2'"'"'/p" ;; *) sed -n \ - "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" + "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" ;; esac; } echo @@ -1107,11 +1145,11 @@ _ASBOX echo for ac_var in $ac_subst_files do eval ac_val=$`echo $ac_var` - echo "$ac_var='"'"'$ac_val'"'"'" + echo "$ac_var='"'"'$ac_val'"'"'" done | sort echo fi if test -s confdefs.h; then @@ -1126,11 +1164,11 @@ fi test "$ac_signal" != 0 && echo "$as_me: caught signal $ac_signal" echo "$as_me: exit $exit_status" } >&5 - rm -f core core.* *.core && + rm -f core *.core && rm -rf conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal @@ -1206,11 +1244,11 @@ # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in `(set) 2>&1 | - sed -n 's/^ac_env_\([a-zA-Z_0-9]*\)_set=.*/\1/p'`; do + sed -n 's/^ac_env_\([a-zA-Z_0-9]*\)_set=.*/\1/p'`; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val="\$ac_cv_env_${ac_var}_value" eval ac_new_val="\$ac_env_${ac_var}_value" case $ac_old_set,$ac_new_set in @@ -1223,17 +1261,17 @@ echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then - { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5 + { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5 echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} - { echo "$as_me:$LINENO: former value: $ac_old_val" >&5 + { echo "$as_me:$LINENO: former value: $ac_old_val" >&5 echo "$as_me: former value: $ac_old_val" >&2;} - { echo "$as_me:$LINENO: current value: $ac_new_val" >&5 + { echo "$as_me:$LINENO: current value: $ac_new_val" >&5 echo "$as_me: current value: $ac_new_val" >&2;} - ac_cache_corrupted=: + ac_cache_corrupted=: fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in @@ -1286,15 +1324,16 @@ + TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 -TCL_PATCH_LEVEL="a2" +TCL_PATCH_LEVEL="a4" VERSION=${TCL_VERSION} #------------------------------------------------------------------------ # Handle the --prefix=... option #------------------------------------------------------------------------ @@ -1303,68 +1342,71 @@ prefix=/usr/local fi if test "${exec_prefix}" = "NONE"; then exec_prefix=$prefix fi -# libdir must be a fully qualified path and (not ${exec_prefix}/lib) -eval libdir="$libdir" TCL_SRC_DIR=`cd $srcdir/..; pwd` #------------------------------------------------------------------------ # Compress and/or soft link the manpages? #------------------------------------------------------------------------ - - echo "$as_me:$LINENO: checking whether to use symlinks for manpages" >&5 + echo "$as_me:$LINENO: checking whether to use symlinks for manpages" >&5 echo $ECHO_N "checking whether to use symlinks for manpages... $ECHO_C" >&6 - # Check whether --enable-man-symlinks or --disable-man-symlinks was given. + # Check whether --enable-man-symlinks or --disable-man-symlinks was given. if test "${enable_man_symlinks+set}" = set; then enableval="$enable_man_symlinks" test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --symlinks" else enableval="no" fi; - echo "$as_me:$LINENO: result: $enableval" >&5 -echo "${ECHO_T}$enableval" >&6 - - echo "$as_me:$LINENO: checking whether to compress the manpages" >&5 -echo $ECHO_N "checking whether to compress the manpages... $ECHO_C" >&6 - # Check whether --enable-man-compression or --disable-man-compression was given. -if test "${enable_man_compression+set}" = set; then - enableval="$enable_man_compression" - test "$enableval" = "yes" && { { echo "$as_me:$LINENO: error: missing argument to --enable-man-compression" >&5 -echo "$as_me: error: missing argument to --enable-man-compression" >&2;} - { (exit 1); exit 1; }; } - test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --compress $enableval" -else - enableval="no" -fi; - echo "$as_me:$LINENO: result: $enableval" >&5 -echo "${ECHO_T}$enableval" >&6 - if test "$enableval" != "no"; then - echo "$as_me:$LINENO: checking for compressed file suffix" >&5 -echo $ECHO_N "checking for compressed file suffix... $ECHO_C" >&6 - touch TeST - $enableval TeST - Z=`ls TeST* | sed 's/^....//'` - rm -f TeST* - MAN_FLAGS="$MAN_FLAGS --extension $Z" - echo "$as_me:$LINENO: result: $Z" >&5 -echo "${ECHO_T}$Z" >&6 - fi - - echo "$as_me:$LINENO: checking whether to add a package name suffix for the manpages" >&5 -echo $ECHO_N "checking whether to add a package name suffix for the manpages... $ECHO_C" >&6 - # Check whether --enable-man-suffix or --disable-man-suffix was given. -if test "${enable_man_suffix+set}" = set; then - enableval="$enable_man_suffix" - test "$enableval" = "yes" && enableval="tcl" - test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --suffix $enableval" -else - enableval="no" -fi; - echo "$as_me:$LINENO: result: $enableval" >&5 + echo "$as_me:$LINENO: result: $enableval" >&5 +echo "${ECHO_T}$enableval" >&6 + + echo "$as_me:$LINENO: checking whether to compress the manpages" >&5 +echo $ECHO_N "checking whether to compress the manpages... $ECHO_C" >&6 + # Check whether --enable-man-compression or --disable-man-compression was given. +if test "${enable_man_compression+set}" = set; then + enableval="$enable_man_compression" + case $enableval in + yes) { { echo "$as_me:$LINENO: error: missing argument to --enable-man-compression" >&5 +echo "$as_me: error: missing argument to --enable-man-compression" >&2;} + { (exit 1); exit 1; }; };; + no) ;; + *) MAN_FLAGS="$MAN_FLAGS --compress $enableval";; + esac +else + enableval="no" +fi; + echo "$as_me:$LINENO: result: $enableval" >&5 +echo "${ECHO_T}$enableval" >&6 + if test "$enableval" != "no"; then + echo "$as_me:$LINENO: checking for compressed file suffix" >&5 +echo $ECHO_N "checking for compressed file suffix... $ECHO_C" >&6 + touch TeST + $enableval TeST + Z=`ls TeST* | sed 's/^....//'` + rm -f TeST* + MAN_FLAGS="$MAN_FLAGS --extension $Z" + echo "$as_me:$LINENO: result: $Z" >&5 +echo "${ECHO_T}$Z" >&6 + fi + + echo "$as_me:$LINENO: checking whether to add a package name suffix for the manpages" >&5 +echo $ECHO_N "checking whether to add a package name suffix for the manpages... $ECHO_C" >&6 + # Check whether --enable-man-suffix or --disable-man-suffix was given. +if test "${enable_man_suffix+set}" = set; then + enableval="$enable_man_suffix" + case $enableval in + yes) enableval="tcl";; + no) ;; + *) MAN_FLAGS="$MAN_FLAGS --suffix $enableval";; + esac +else + enableval="no" +fi; + echo "$as_me:$LINENO: result: $enableval" >&5 echo "${ECHO_T}$enableval" >&6 @@ -1712,11 +1754,10 @@ ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -1732,12 +1773,12 @@ ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files a.out a.exe b.out" # Try to create an executable without -o first, disregard a.out. # It will help us diagnose broken compilers, and finding out an intuition # of exeext. -echo "$as_me:$LINENO: checking for C compiler default output" >&5 -echo $ECHO_N "checking for C compiler default output... $ECHO_C" >&6 +echo "$as_me:$LINENO: checking for C compiler default output file name" >&5 +echo $ECHO_N "checking for C compiler default output file name... $ECHO_C" >&6 ac_link_default=`echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` if { (eval echo "$as_me:$LINENO: \"$ac_link_default\"") >&5 (eval $ac_link_default) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 @@ -1753,27 +1794,27 @@ for ac_file in a_out.exe a.exe conftest.exe a.out conftest a.* conftest.* b.out do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) - ;; + ;; conftest.$ac_ext ) - # This is the source file. - ;; + # This is the source file. + ;; [ab].out ) - # We found the default executable, but exeext='' is most - # certainly right. - break;; + # We found the default executable, but exeext='' is most + # certainly right. + break;; *.* ) - ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` - # FIXME: I believe we export ac_cv_exeext for Libtool, - # but it would be cool to find out if it's true. Does anybody - # maintain Libtool? --akim. - export ac_cv_exeext - break;; + ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + # FIXME: I believe we export ac_cv_exeext for Libtool, + # but it would be cool to find out if it's true. Does anybody + # maintain Libtool? --akim. + export ac_cv_exeext + break;; * ) - break;; + break;; esac done else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 @@ -1843,12 +1884,12 @@ for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) ;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` - export ac_cv_exeext - break;; + export ac_cv_exeext + break;; * ) break;; esac done else { { echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link @@ -1869,11 +1910,10 @@ echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6 if test "${ac_cv_objext+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -1920,11 +1960,10 @@ echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6 if test "${ac_cv_c_compiler_gnu+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -1940,15 +1979,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -1957,11 +2006,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_compiler_gnu=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu fi echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5 echo "${ECHO_T}$ac_cv_c_compiler_gnu" >&6 @@ -1973,11 +2022,10 @@ echo $ECHO_N "checking whether $CC accepts -g... $ECHO_C" >&6 if test "${ac_cv_prog_cc_g+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -1990,15 +2038,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -2007,11 +2065,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_prog_cc_g=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5 echo "${ECHO_T}$ac_cv_prog_cc_g" >&6 if test "$ac_test_CFLAGS" = set; then CFLAGS=$ac_save_CFLAGS @@ -2034,11 +2092,10 @@ echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_cv_prog_cc_stdc=no ac_save_CC=$CC cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -2062,10 +2119,20 @@ va_start (v,p); s = g (p, va_arg (v,int)); va_end (v); return s; } + +/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has + function prototypes and stuff, but not '\xHH' hex character constants. + These don't provoke an error unfortunately, instead are silently treated + as 'x'. The following induces an error, until -std1 is added to get + proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an + array size at least. It's necessary to write '\x00'==0 to get something + that's true only with -std1. */ +int osf4_cc_array ['\x00' == 0 ? 1 : -1]; + int test (int i, double x); struct s1 {int (*f) (int a);}; struct s2 {int (*f) (double a);}; int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); int argc; @@ -2088,15 +2155,25 @@ for ac_arg in "" -qlanglvl=ansi -std1 -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -2105,11 +2182,11 @@ else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi -rm -f conftest.$ac_objext +rm -f conftest.err conftest.$ac_objext done rm -f conftest.$ac_ext conftest.$ac_objext CC=$ac_save_CC fi @@ -2133,38 +2210,46 @@ choke me #endif _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then for ac_declaration in \ - ''\ - '#include ' \ + '' \ 'extern "C" void std::exit (int) throw (); using std::exit;' \ 'extern "C" void std::exit (int); using std::exit;' \ 'extern "C" void exit (int) throw ();' \ 'extern "C" void exit (int);' \ 'void exit (int);' do cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ -#include $ac_declaration +#include int main () { exit (42); ; @@ -2171,15 +2256,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -2188,13 +2283,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 continue fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -2207,15 +2301,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -2223,11 +2327,11 @@ else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext done rm -f conftest* if test -n "$ac_declaration"; then echo '#ifdef __cplusplus' >>confdefs.h echo $ac_declaration >>confdefs.h @@ -2237,11 +2341,11 @@ else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu @@ -2253,11 +2357,10 @@ # strtod insome versions of SunOS # - some versions of string.h don't declare procedures such # as strstr # Do this early, otherwise an autoconf bug throws errors on configure #-------------------------------------------------------------------- - ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' @@ -2283,11 +2386,10 @@ # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -2294,11 +2396,11 @@ #ifdef __STDC__ # include #else # include #endif - Syntax error + Syntax error _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err @@ -2306,10 +2408,11 @@ cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes @@ -2326,11 +2429,10 @@ rm -f conftest.err conftest.$ac_ext # OK, works on sane cases. Now check whether non-existent headers # can be detected and how. cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -2344,10 +2446,11 @@ cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes @@ -2390,11 +2493,10 @@ # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -2401,11 +2503,11 @@ #ifdef __STDC__ # include #else # include #endif - Syntax error + Syntax error _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err @@ -2413,10 +2515,11 @@ cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes @@ -2433,11 +2536,10 @@ rm -f conftest.err conftest.$ac_ext # OK, works on sane cases. Now check whether non-existent headers # can be detected and how. cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -2451,10 +2553,11 @@ cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes @@ -2511,11 +2614,10 @@ echo $ECHO_N "checking for ANSI C header files... $ECHO_C" >&6 if test "${ac_cv_header_stdc+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -2532,15 +2634,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -2549,16 +2661,15 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_header_stdc=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -2576,11 +2687,10 @@ fi if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -2601,11 +2711,10 @@ # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. if test "$cross_compiling" = yes; then : else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -2613,13 +2722,13 @@ #if ((' ' & 0x0FF) == 0x020) # define ISLOWER(c) ('a' <= (c) && (c) <= 'z') # define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) #else # define ISLOWER(c) \ - (('a' <= (c) && (c) <= 'i') \ - || ('j' <= (c) && (c) <= 'r') \ - || ('s' <= (c) && (c) <= 'z')) + (('a' <= (c) && (c) <= 'i') \ + || ('j' <= (c) && (c) <= 'r') \ + || ('s' <= (c) && (c) <= 'z')) # define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) #endif #define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) int @@ -2626,11 +2735,11 @@ main () { int i; for (i = 0; i < 256; i++) if (XOR (islower (i), ISLOWER (i)) - || toupper (i) != TOUPPER (i)) + || toupper (i) != TOUPPER (i)) exit(2); exit (0); } _ACEOF rm -f conftest$ac_exeext @@ -2651,11 +2760,11 @@ sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) ac_cv_header_stdc=no fi -rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi fi echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5 echo "${ECHO_T}$ac_cv_header_stdc" >&6 @@ -2676,20 +2785,19 @@ for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ - inttypes.h stdint.h unistd.h + inttypes.h stdint.h unistd.h do as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_header" >&5 echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 if eval "test \"\${$as_ac_Header+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -2697,15 +2805,25 @@ #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -2714,11 +2832,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_Header=no" fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 if test `eval echo '${'$as_ac_Header'}'` = yes; then cat >>confdefs.h <<_ACEOF @@ -2731,12 +2849,15 @@ echo "$as_me:$LINENO: checking dirent.h" >&5 echo $ECHO_N "checking dirent.h... $ECHO_C" >&6 - cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" + if test "${tcl_cv_dirent_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + +cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -2768,30 +2889,43 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - tcl_ok=yes + tcl_cv_dirent_h=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -tcl_ok=no +tcl_cv_dirent_h=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi - if test $tcl_ok = no; then + + if test $tcl_cv_dirent_h = no; then cat >>confdefs.h <<\_ACEOF #define NO_DIRENT_H 1 _ACEOF @@ -2810,11 +2944,10 @@ else # Is the header compilable? echo "$as_me:$LINENO: checking errno.h usability" >&5 echo $ECHO_N "checking errno.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -2821,15 +2954,25 @@ $ac_includes_default #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -2838,19 +2981,18 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking errno.h presence" >&5 echo $ECHO_N "checking errno.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -2864,10 +3006,11 @@ cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes @@ -2883,37 +3026,36 @@ rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? -case $ac_header_compiler:$ac_header_preproc in - yes:no ) +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) { echo "$as_me:$LINENO: WARNING: errno.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: errno.h: accepted by the compiler, rejected by the preprocessor!" >&2;} - { echo "$as_me:$LINENO: WARNING: errno.h: proceeding with the preprocessor's result" >&5 -echo "$as_me: WARNING: errno.h: proceeding with the preprocessor's result" >&2;} - ( - cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## -_ASBOX - ) | - sed "s/^/$as_me: WARNING: /" >&2 + { echo "$as_me:$LINENO: WARNING: errno.h: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: errno.h: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes ;; - no:yes ) + no:yes:* ) { echo "$as_me:$LINENO: WARNING: errno.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: errno.h: present but cannot be compiled" >&2;} - { echo "$as_me:$LINENO: WARNING: errno.h: check for missing prerequisite headers?" >&5 -echo "$as_me: WARNING: errno.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: errno.h: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: errno.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: errno.h: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: errno.h: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: errno.h: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: errno.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: errno.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: errno.h: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: errno.h: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: errno.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac @@ -2950,11 +3092,10 @@ else # Is the header compilable? echo "$as_me:$LINENO: checking float.h usability" >&5 echo $ECHO_N "checking float.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -2961,15 +3102,25 @@ $ac_includes_default #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -2978,19 +3129,18 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking float.h presence" >&5 echo $ECHO_N "checking float.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3004,10 +3154,11 @@ cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes @@ -3023,37 +3174,36 @@ rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? -case $ac_header_compiler:$ac_header_preproc in - yes:no ) +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) { echo "$as_me:$LINENO: WARNING: float.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: float.h: accepted by the compiler, rejected by the preprocessor!" >&2;} - { echo "$as_me:$LINENO: WARNING: float.h: proceeding with the preprocessor's result" >&5 -echo "$as_me: WARNING: float.h: proceeding with the preprocessor's result" >&2;} - ( - cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## -_ASBOX - ) | - sed "s/^/$as_me: WARNING: /" >&2 + { echo "$as_me:$LINENO: WARNING: float.h: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: float.h: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes ;; - no:yes ) + no:yes:* ) { echo "$as_me:$LINENO: WARNING: float.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: float.h: present but cannot be compiled" >&2;} - { echo "$as_me:$LINENO: WARNING: float.h: check for missing prerequisite headers?" >&5 -echo "$as_me: WARNING: float.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: float.h: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: float.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: float.h: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: float.h: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: float.h: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: float.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: float.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: float.h: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: float.h: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: float.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac @@ -3090,11 +3240,10 @@ else # Is the header compilable? echo "$as_me:$LINENO: checking values.h usability" >&5 echo $ECHO_N "checking values.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3101,15 +3250,25 @@ $ac_includes_default #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -3118,19 +3277,18 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking values.h presence" >&5 echo $ECHO_N "checking values.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3144,10 +3302,11 @@ cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes @@ -3163,37 +3322,36 @@ rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? -case $ac_header_compiler:$ac_header_preproc in - yes:no ) +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) { echo "$as_me:$LINENO: WARNING: values.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: values.h: accepted by the compiler, rejected by the preprocessor!" >&2;} - { echo "$as_me:$LINENO: WARNING: values.h: proceeding with the preprocessor's result" >&5 -echo "$as_me: WARNING: values.h: proceeding with the preprocessor's result" >&2;} - ( - cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## -_ASBOX - ) | - sed "s/^/$as_me: WARNING: /" >&2 + { echo "$as_me:$LINENO: WARNING: values.h: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: values.h: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes ;; - no:yes ) + no:yes:* ) { echo "$as_me:$LINENO: WARNING: values.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: values.h: present but cannot be compiled" >&2;} - { echo "$as_me:$LINENO: WARNING: values.h: check for missing prerequisite headers?" >&5 -echo "$as_me: WARNING: values.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: values.h: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: values.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: values.h: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: values.h: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: values.h: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: values.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: values.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: values.h: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: values.h: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: values.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac @@ -3230,11 +3388,10 @@ else # Is the header compilable? echo "$as_me:$LINENO: checking limits.h usability" >&5 echo $ECHO_N "checking limits.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3241,15 +3398,25 @@ $ac_includes_default #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -3258,19 +3425,18 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking limits.h presence" >&5 echo $ECHO_N "checking limits.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3284,10 +3450,11 @@ cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes @@ -3303,37 +3470,36 @@ rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? -case $ac_header_compiler:$ac_header_preproc in - yes:no ) +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) { echo "$as_me:$LINENO: WARNING: limits.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: limits.h: accepted by the compiler, rejected by the preprocessor!" >&2;} - { echo "$as_me:$LINENO: WARNING: limits.h: proceeding with the preprocessor's result" >&5 -echo "$as_me: WARNING: limits.h: proceeding with the preprocessor's result" >&2;} - ( - cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## -_ASBOX - ) | - sed "s/^/$as_me: WARNING: /" >&2 + { echo "$as_me:$LINENO: WARNING: limits.h: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: limits.h: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes ;; - no:yes ) + no:yes:* ) { echo "$as_me:$LINENO: WARNING: limits.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: limits.h: present but cannot be compiled" >&2;} - { echo "$as_me:$LINENO: WARNING: limits.h: check for missing prerequisite headers?" >&5 -echo "$as_me: WARNING: limits.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: limits.h: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: limits.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: limits.h: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: limits.h: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: limits.h: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: limits.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: limits.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: limits.h: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: limits.h: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: limits.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac @@ -3374,11 +3540,10 @@ else # Is the header compilable? echo "$as_me:$LINENO: checking stdlib.h usability" >&5 echo $ECHO_N "checking stdlib.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3385,15 +3550,25 @@ $ac_includes_default #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -3402,19 +3577,18 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking stdlib.h presence" >&5 echo $ECHO_N "checking stdlib.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3428,10 +3602,11 @@ cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes @@ -3447,37 +3622,36 @@ rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? -case $ac_header_compiler:$ac_header_preproc in - yes:no ) +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) { echo "$as_me:$LINENO: WARNING: stdlib.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: stdlib.h: accepted by the compiler, rejected by the preprocessor!" >&2;} - { echo "$as_me:$LINENO: WARNING: stdlib.h: proceeding with the preprocessor's result" >&5 -echo "$as_me: WARNING: stdlib.h: proceeding with the preprocessor's result" >&2;} - ( - cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## -_ASBOX - ) | - sed "s/^/$as_me: WARNING: /" >&2 + { echo "$as_me:$LINENO: WARNING: stdlib.h: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: stdlib.h: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes ;; - no:yes ) + no:yes:* ) { echo "$as_me:$LINENO: WARNING: stdlib.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: stdlib.h: present but cannot be compiled" >&2;} - { echo "$as_me:$LINENO: WARNING: stdlib.h: check for missing prerequisite headers?" >&5 -echo "$as_me: WARNING: stdlib.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: stdlib.h: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: stdlib.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: stdlib.h: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: stdlib.h: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: stdlib.h: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: stdlib.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: stdlib.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: stdlib.h: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: stdlib.h: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: stdlib.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac @@ -3498,11 +3672,10 @@ tcl_ok=0 fi cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3516,11 +3689,10 @@ tcl_ok=0 fi rm -f conftest* cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3534,11 +3706,10 @@ tcl_ok=0 fi rm -f conftest* cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3571,11 +3742,10 @@ else # Is the header compilable? echo "$as_me:$LINENO: checking string.h usability" >&5 echo $ECHO_N "checking string.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3582,15 +3752,25 @@ $ac_includes_default #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -3599,19 +3779,18 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking string.h presence" >&5 echo $ECHO_N "checking string.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3625,10 +3804,11 @@ cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes @@ -3644,37 +3824,36 @@ rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? -case $ac_header_compiler:$ac_header_preproc in - yes:no ) +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) { echo "$as_me:$LINENO: WARNING: string.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: string.h: accepted by the compiler, rejected by the preprocessor!" >&2;} - { echo "$as_me:$LINENO: WARNING: string.h: proceeding with the preprocessor's result" >&5 -echo "$as_me: WARNING: string.h: proceeding with the preprocessor's result" >&2;} - ( - cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## -_ASBOX - ) | - sed "s/^/$as_me: WARNING: /" >&2 + { echo "$as_me:$LINENO: WARNING: string.h: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: string.h: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes ;; - no:yes ) + no:yes:* ) { echo "$as_me:$LINENO: WARNING: string.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: string.h: present but cannot be compiled" >&2;} - { echo "$as_me:$LINENO: WARNING: string.h: check for missing prerequisite headers?" >&5 -echo "$as_me: WARNING: string.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: string.h: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: string.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: string.h: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: string.h: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: string.h: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: string.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: string.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: string.h: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: string.h: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: string.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac @@ -3695,11 +3874,10 @@ tcl_ok=0 fi cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3713,11 +3891,10 @@ tcl_ok=0 fi rm -f conftest* cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3755,11 +3932,10 @@ else # Is the header compilable? echo "$as_me:$LINENO: checking sys/wait.h usability" >&5 echo $ECHO_N "checking sys/wait.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3766,15 +3942,25 @@ $ac_includes_default #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -3783,19 +3969,18 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking sys/wait.h presence" >&5 echo $ECHO_N "checking sys/wait.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3809,10 +3994,11 @@ cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes @@ -3828,37 +4014,36 @@ rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? -case $ac_header_compiler:$ac_header_preproc in - yes:no ) +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) { echo "$as_me:$LINENO: WARNING: sys/wait.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: sys/wait.h: accepted by the compiler, rejected by the preprocessor!" >&2;} - { echo "$as_me:$LINENO: WARNING: sys/wait.h: proceeding with the preprocessor's result" >&5 -echo "$as_me: WARNING: sys/wait.h: proceeding with the preprocessor's result" >&2;} - ( - cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## -_ASBOX - ) | - sed "s/^/$as_me: WARNING: /" >&2 + { echo "$as_me:$LINENO: WARNING: sys/wait.h: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: sys/wait.h: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes ;; - no:yes ) + no:yes:* ) { echo "$as_me:$LINENO: WARNING: sys/wait.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: sys/wait.h: present but cannot be compiled" >&2;} - { echo "$as_me:$LINENO: WARNING: sys/wait.h: check for missing prerequisite headers?" >&5 -echo "$as_me: WARNING: sys/wait.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: sys/wait.h: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: sys/wait.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: sys/wait.h: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: sys/wait.h: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: sys/wait.h: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: sys/wait.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: sys/wait.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: sys/wait.h: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: sys/wait.h: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: sys/wait.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac @@ -3895,11 +4080,10 @@ else # Is the header compilable? echo "$as_me:$LINENO: checking dlfcn.h usability" >&5 echo $ECHO_N "checking dlfcn.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3906,15 +4090,25 @@ $ac_includes_default #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -3923,19 +4117,18 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking dlfcn.h presence" >&5 echo $ECHO_N "checking dlfcn.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3949,10 +4142,11 @@ cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes @@ -3968,37 +4162,36 @@ rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? -case $ac_header_compiler:$ac_header_preproc in - yes:no ) +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) { echo "$as_me:$LINENO: WARNING: dlfcn.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: dlfcn.h: accepted by the compiler, rejected by the preprocessor!" >&2;} - { echo "$as_me:$LINENO: WARNING: dlfcn.h: proceeding with the preprocessor's result" >&5 -echo "$as_me: WARNING: dlfcn.h: proceeding with the preprocessor's result" >&2;} - ( - cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## -_ASBOX - ) | - sed "s/^/$as_me: WARNING: /" >&2 + { echo "$as_me:$LINENO: WARNING: dlfcn.h: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: dlfcn.h: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes ;; - no:yes ) + no:yes:* ) { echo "$as_me:$LINENO: WARNING: dlfcn.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: dlfcn.h: present but cannot be compiled" >&2;} - { echo "$as_me:$LINENO: WARNING: dlfcn.h: check for missing prerequisite headers?" >&5 -echo "$as_me: WARNING: dlfcn.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: dlfcn.h: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: dlfcn.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: dlfcn.h: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: dlfcn.h: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: dlfcn.h: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: dlfcn.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: dlfcn.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: dlfcn.h: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: dlfcn.h: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: dlfcn.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac @@ -4041,11 +4234,10 @@ else # Is the header compilable? echo "$as_me:$LINENO: checking $ac_header usability" >&5 echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -4052,15 +4244,25 @@ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -4069,19 +4271,18 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking $ac_header presence" >&5 echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -4095,10 +4296,11 @@ cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes @@ -4114,37 +4316,36 @@ rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? -case $ac_header_compiler:$ac_header_preproc in - yes:no ) +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} - { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 -echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} - ( - cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## -_ASBOX - ) | - sed "s/^/$as_me: WARNING: /" >&2 + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes ;; - no:yes ) + no:yes:* ) { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} - { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 -echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac @@ -4151,11 +4352,11 @@ echo "$as_me:$LINENO: checking for $ac_header" >&5 echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 if eval "test \"\${$as_ac_Header+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else - eval "$as_ac_Header=$ac_header_preproc" + eval "$as_ac_Header=\$ac_header_preproc" fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 fi @@ -4204,17 +4405,10 @@ cat >>confdefs.h <<\_ACEOF #define USE_THREAD_ALLOC 1 _ACEOF - # USE_THREAD_STORAGE tells us to use the new generic thread - # storage subsystem. - -cat >>confdefs.h <<\_ACEOF -#define USE_THREAD_STORAGE 1 -_ACEOF - cat >>confdefs.h <<\_ACEOF #define _REENTRANT 1 _ACEOF @@ -4236,11 +4430,10 @@ echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -4260,15 +4453,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -4277,11 +4480,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread_pthread_mutex_init=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_mutex_init" >&5 echo "${ECHO_T}$ac_cv_lib_pthread_pthread_mutex_init" >&6 if test $ac_cv_lib_pthread_pthread_mutex_init = yes; then @@ -4302,11 +4506,10 @@ echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -4326,15 +4529,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -4343,11 +4556,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread___pthread_mutex_init=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_pthread___pthread_mutex_init" >&5 echo "${ECHO_T}$ac_cv_lib_pthread___pthread_mutex_init" >&6 if test $ac_cv_lib_pthread___pthread_mutex_init = yes; then @@ -4368,11 +4582,10 @@ echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthreads $LIBS" cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -4392,15 +4605,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -4409,11 +4632,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthreads_pthread_mutex_init=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_pthreads_pthread_mutex_init" >&5 echo "${ECHO_T}$ac_cv_lib_pthreads_pthread_mutex_init" >&6 if test $ac_cv_lib_pthreads_pthread_mutex_init = yes; then @@ -4432,11 +4656,10 @@ echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lc $LIBS" cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -4456,15 +4679,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -4473,11 +4706,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_c_pthread_mutex_init=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_c_pthread_mutex_init" >&5 echo "${ECHO_T}$ac_cv_lib_c_pthread_mutex_init" >&6 if test $ac_cv_lib_c_pthread_mutex_init = yes; then @@ -4493,11 +4727,10 @@ echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lc_r $LIBS" cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -4517,15 +4750,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -4534,11 +4777,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_c_r_pthread_mutex_init=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_c_r_pthread_mutex_init" >&5 echo "${ECHO_T}$ac_cv_lib_c_r_pthread_mutex_init" >&6 if test $ac_cv_lib_c_r_pthread_mutex_init = yes; then @@ -4572,25 +4816,32 @@ echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 if eval "test \"\${$as_ac_var+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef $ac_func + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -4617,15 +4868,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -4634,11 +4895,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 if test `eval echo '${'$as_ac_var'}'` = yes; then cat >>confdefs.h <<_ACEOF @@ -4652,25 +4914,32 @@ echo $ECHO_N "checking for pthread_attr_get_np... $ECHO_C" >&6 if test "${ac_cv_func_pthread_attr_get_np+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define pthread_attr_get_np to an innocuous variant, in case declares pthread_attr_get_np. + For example, HP-UX 11i declares gettimeofday. */ +#define pthread_attr_get_np innocuous_pthread_attr_get_np + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char pthread_attr_get_np (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef pthread_attr_get_np + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -4697,15 +4966,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -4714,11 +4993,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_pthread_attr_get_np=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_pthread_attr_get_np" >&5 echo "${ECHO_T}$ac_cv_func_pthread_attr_get_np" >&6 if test $ac_cv_func_pthread_attr_get_np = yes; then tcl_ok=yes @@ -4736,11 +5016,10 @@ echo $ECHO_N "checking for pthread_attr_get_np declaration... $ECHO_C" >&6 if test "${tcl_cv_grep_pthread_attr_get_np+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -4771,25 +5050,32 @@ echo $ECHO_N "checking for pthread_getattr_np... $ECHO_C" >&6 if test "${ac_cv_func_pthread_getattr_np+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define pthread_getattr_np to an innocuous variant, in case declares pthread_getattr_np. + For example, HP-UX 11i declares gettimeofday. */ +#define pthread_getattr_np innocuous_pthread_getattr_np + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char pthread_getattr_np (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef pthread_getattr_np + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -4816,15 +5102,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -4833,11 +5129,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_pthread_getattr_np=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_pthread_getattr_np" >&5 echo "${ECHO_T}$ac_cv_func_pthread_getattr_np" >&6 if test $ac_cv_func_pthread_getattr_np = yes; then tcl_ok=yes @@ -4855,11 +5152,10 @@ echo $ECHO_N "checking for pthread_getattr_np declaration... $ECHO_C" >&6 if test "${tcl_cv_grep_pthread_getattr_np+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -4886,217 +5182,10 @@ fi fi fi LIBS=$ac_saved_libs - -for ac_func in readdir_r -do -as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` -echo "$as_me:$LINENO: checking for $ac_func" >&5 -echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 -if eval "test \"\${$as_ac_var+set}\" = set"; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -/* System header to define __stub macros and hopefully few prototypes, - which can conflict with char $ac_func (); below. - Prefer to if __STDC__ is defined, since - exists even on freestanding compilers. */ -#ifdef __STDC__ -# include -#else -# include -#endif -/* Override any gcc2 internal prototype to avoid an error. */ -#ifdef __cplusplus -extern "C" -{ -#endif -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char $ac_func (); -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined (__stub_$ac_func) || defined (__stub___$ac_func) -choke me -#else -char (*f) () = $ac_func; -#endif -#ifdef __cplusplus -} -#endif - -int -main () -{ -return f != $ac_func; - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - eval "$as_ac_var=yes" -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -eval "$as_ac_var=no" -fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext -fi -echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 -echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 -if test `eval echo '${'$as_ac_var'}'` = yes; then - cat >>confdefs.h <<_ACEOF -#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 -_ACEOF - -fi -done - - if test "x$ac_cv_func_readdir_r" = "xyes"; then - echo "$as_me:$LINENO: checking how many args readdir_r takes" >&5 -echo $ECHO_N "checking how many args readdir_r takes... $ECHO_C" >&6 - # IRIX 5.3 has a 2 arg version of readdir_r - # while other systems have a 3 arg version. - if test "${tcl_cv_two_arg_readdir_r+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include -#include -#ifdef NO_DIRENT_H -# include /* logic from tcl/compat/dirent.h * -# define dirent direct * */ -#else -# include -#endif - -int -main () -{ -readdir_r(NULL, NULL); - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - tcl_cv_two_arg_readdir_r=yes -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -tcl_cv_two_arg_readdir_r=no -fi -rm -f conftest.$ac_objext conftest.$ac_ext -fi - - if test "${tcl_cv_three_arg_readdir_r+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include -#include -#ifdef NO_DIRENT_H -# include /* logic from tcl/compat/dirent.h * -# define dirent direct * */ -#else -# include -#endif - -int -main () -{ -readdir_r(NULL, NULL, NULL); - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - tcl_cv_three_arg_readdir_r=yes -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -tcl_cv_three_arg_readdir_r=no -fi -rm -f conftest.$ac_objext conftest.$ac_ext -fi - - if test "x$tcl_cv_two_arg_readdir_r" = "xyes" ; then - echo "$as_me:$LINENO: result: 2" >&5 -echo "${ECHO_T}2" >&6 - cat >>confdefs.h <<\_ACEOF -#define HAVE_TWO_ARG_READDIR_R 1 -_ACEOF - - elif test "x$tcl_cv_three_arg_readdir_r" = "xyes" ; then - echo "$as_me:$LINENO: result: 3" >&5 -echo "${ECHO_T}3" >&6 - cat >>confdefs.h <<\_ACEOF -#define HAVE_THREE_ARG_READDIR_R 1 -_ACEOF - - else - { { echo "$as_me:$LINENO: error: unknown number of args for readdir_r" >&5 -echo "$as_me: error: unknown number of args for readdir_r" >&2;} - { (exit 1); exit 1; }; } - fi - fi else TCL_THREADS=0 echo "$as_me:$LINENO: result: no (default)" >&5 echo "${ECHO_T}no (default)" >&6 fi @@ -5139,11 +5228,10 @@ echo "$as_me:$LINENO: checking if the compiler understands -pipe" >&5 echo $ECHO_N "checking if the compiler understands -pipe... $ECHO_C" >&6 OLDCC="$CC" CC="$CC -pipe" cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -5156,15 +5244,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -5176,11 +5274,11 @@ CC="$OLDCC" echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi fi #-------------------------------------------------------------------- # Look for libraries that we will need when compiling the Tcl shell @@ -5198,25 +5296,32 @@ echo $ECHO_N "checking for sin... $ECHO_C" >&6 if test "${ac_cv_func_sin+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define sin to an innocuous variant, in case declares sin. + For example, HP-UX 11i declares gettimeofday. */ +#define sin innocuous_sin + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char sin (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef sin + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -5243,15 +5348,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -5260,11 +5375,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_sin=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_sin" >&5 echo "${ECHO_T}$ac_cv_func_sin" >&6 if test $ac_cv_func_sin = yes; then MATH_LIBS="" @@ -5278,11 +5394,10 @@ echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lieee $LIBS" cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -5296,15 +5411,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -5313,11 +5438,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_ieee_main=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_ieee_main" >&5 echo "${ECHO_T}$ac_cv_lib_ieee_main" >&6 if test $ac_cv_lib_ieee_main = yes; then @@ -5336,11 +5462,10 @@ echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-linet $LIBS" cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -5354,15 +5479,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -5371,11 +5506,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_inet_main=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_inet_main" >&5 echo "${ECHO_T}$ac_cv_lib_inet_main" >&6 if test $ac_cv_lib_inet_main = yes; then @@ -5393,11 +5529,10 @@ else # Is the header compilable? echo "$as_me:$LINENO: checking net/errno.h usability" >&5 echo $ECHO_N "checking net/errno.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -5404,15 +5539,25 @@ $ac_includes_default #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -5421,19 +5566,18 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking net/errno.h presence" >&5 echo $ECHO_N "checking net/errno.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -5447,10 +5591,11 @@ cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes @@ -5466,37 +5611,36 @@ rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? -case $ac_header_compiler:$ac_header_preproc in - yes:no ) +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) { echo "$as_me:$LINENO: WARNING: net/errno.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: net/errno.h: accepted by the compiler, rejected by the preprocessor!" >&2;} - { echo "$as_me:$LINENO: WARNING: net/errno.h: proceeding with the preprocessor's result" >&5 -echo "$as_me: WARNING: net/errno.h: proceeding with the preprocessor's result" >&2;} - ( - cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## -_ASBOX - ) | - sed "s/^/$as_me: WARNING: /" >&2 + { echo "$as_me:$LINENO: WARNING: net/errno.h: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: net/errno.h: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes ;; - no:yes ) + no:yes:* ) { echo "$as_me:$LINENO: WARNING: net/errno.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: net/errno.h: present but cannot be compiled" >&2;} - { echo "$as_me:$LINENO: WARNING: net/errno.h: check for missing prerequisite headers?" >&5 -echo "$as_me: WARNING: net/errno.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: net/errno.h: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: net/errno.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: net/errno.h: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: net/errno.h: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: net/errno.h: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: net/errno.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: net/errno.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: net/errno.h: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: net/errno.h: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: net/errno.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac @@ -5545,25 +5689,32 @@ echo $ECHO_N "checking for connect... $ECHO_C" >&6 if test "${ac_cv_func_connect+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define connect to an innocuous variant, in case declares connect. + For example, HP-UX 11i declares gettimeofday. */ +#define connect innocuous_connect + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char connect (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef connect + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -5590,15 +5741,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -5607,11 +5768,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_connect=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_connect" >&5 echo "${ECHO_T}$ac_cv_func_connect" >&6 if test $ac_cv_func_connect = yes; then tcl_checkSocket=0 @@ -5624,25 +5786,32 @@ echo $ECHO_N "checking for setsockopt... $ECHO_C" >&6 if test "${ac_cv_func_setsockopt+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define setsockopt to an innocuous variant, in case declares setsockopt. + For example, HP-UX 11i declares gettimeofday. */ +#define setsockopt innocuous_setsockopt + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char setsockopt (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef setsockopt + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -5669,15 +5838,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -5686,11 +5865,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_setsockopt=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_setsockopt" >&5 echo "${ECHO_T}$ac_cv_func_setsockopt" >&6 if test $ac_cv_func_setsockopt = yes; then : @@ -5701,11 +5881,10 @@ echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lsocket $LIBS" cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -5725,15 +5904,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -5742,11 +5931,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_socket_setsockopt=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_socket_setsockopt" >&5 echo "${ECHO_T}$ac_cv_lib_socket_setsockopt" >&6 if test $ac_cv_lib_socket_setsockopt = yes; then @@ -5765,25 +5955,32 @@ echo $ECHO_N "checking for accept... $ECHO_C" >&6 if test "${ac_cv_func_accept+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define accept to an innocuous variant, in case declares accept. + For example, HP-UX 11i declares gettimeofday. */ +#define accept innocuous_accept + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char accept (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef accept + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -5810,15 +6007,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -5827,11 +6034,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_accept=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_accept" >&5 echo "${ECHO_T}$ac_cv_func_accept" >&6 if test $ac_cv_func_accept = yes; then tcl_checkNsl=0 @@ -5844,25 +6052,32 @@ echo $ECHO_N "checking for gethostbyname... $ECHO_C" >&6 if test "${ac_cv_func_gethostbyname+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define gethostbyname to an innocuous variant, in case declares gethostbyname. + For example, HP-UX 11i declares gettimeofday. */ +#define gethostbyname innocuous_gethostbyname + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char gethostbyname (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef gethostbyname + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -5889,15 +6104,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -5906,11 +6131,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_gethostbyname=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_gethostbyname" >&5 echo "${ECHO_T}$ac_cv_func_gethostbyname" >&6 if test $ac_cv_func_gethostbyname = yes; then : @@ -5921,11 +6147,10 @@ echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lnsl $LIBS" cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -5945,15 +6170,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -5962,11 +6197,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_nsl_gethostbyname=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_nsl_gethostbyname" >&5 echo "${ECHO_T}$ac_cv_lib_nsl_gethostbyname" >&6 if test $ac_cv_lib_nsl_gethostbyname = yes; then @@ -6182,11 +6418,10 @@ echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -6206,15 +6441,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -6223,11 +6468,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_dl_dlopen=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_dl_dlopen" >&5 echo "${ECHO_T}$ac_cv_lib_dl_dlopen" >&6 if test $ac_cv_lib_dl_dlopen = yes; then @@ -6305,37 +6551,36 @@ { (exit 1); exit 1; }; } fi STLIB_LD='${AR} cr' LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH" PLAT_OBJS="" + PLAT_SRCS="" case $system in - AIX-5.*) + AIX-*) if test "${TCL_THREADS}" = "1" -a "$GCC" != "yes" ; then # AIX requires the _r compiler when gcc isn't being used if test "${CC}" != "cc_r" ; then CC=${CC}_r fi echo "$as_me:$LINENO: result: Using $CC for compiling with threads" >&5 echo "${ECHO_T}Using $CC for compiling with threads" >&6 fi LIBS="$LIBS -lc" - # AIX-5 uses ELF style dynamic libraries SHLIB_CFLAGS="" # Note: need the LIBS below, otherwise Tk won't find Tcl's # symbols when dynamically loaded into tclsh. SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" - LD_LIBRARY_PATH_VAR="LIBPATH" - # Check to enable 64-bit flags for compiler/linker - if test "$do64bit" = "yes" ; then + # Check to enable 64-bit flags for compiler/linker on AIX 4+ + if test "$do64bit" = "yes" -a "`uname -v`" -gt "3" ; then if test "$GCC" = "yes" ; then - { echo "$as_me:$LINENO: WARNING: \"64bit mode not supported with GCC on $system\"" >&5 -echo "$as_me: WARNING: \"64bit mode not supported with GCC on $system\"" >&2;} + { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC on $system" >&5 +echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;} else do64bit_ok=yes CFLAGS="$CFLAGS -q64" LDFLAGS_ARCH="-q64" RANLIB="${RANLIB} -X64" @@ -6354,60 +6599,35 @@ else CC_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}' fi LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' else - SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry ${SHLIB_LD_FLAGS}" - DL_LIBS="-ldl" - CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - TCL_NEEDS_EXP_FILE=1 - TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.exp' - fi - ;; - AIX-*) - if test "${TCL_THREADS}" = "1" -a "$GCC" != "yes" ; then - # AIX requires the _r compiler when gcc isn't being used - if test "${CC}" != "cc_r" ; then - CC=${CC}_r - fi - echo "$as_me:$LINENO: result: Using $CC for compiling with threads" >&5 -echo "${ECHO_T}Using $CC for compiling with threads" >&6 - fi - LIBS="$LIBS -lc" - SHLIB_CFLAGS="" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - LD_LIBRARY_PATH_VAR="LIBPATH" - TCL_NEEDS_EXP_FILE=1 - TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.exp' - - # AIX v<=4.1 has some different flags than 4.2+ - if test "$system" = "AIX-4.1" -o "`uname -v`" -lt "4" ; then - LIBOBJS="$LIBOBJS tclLoadAix.$ac_objext" - DL_LIBS="-lld" - fi - - # Check to enable 64-bit flags for compiler/linker - if test "$do64bit" = "yes" ; then - if test "$GCC" = "yes" ; then - { echo "$as_me:$LINENO: WARNING: \"64bit mode not supported with GCC on $system\"" >&5 -echo "$as_me: WARNING: \"64bit mode not supported with GCC on $system\"" >&2;} - else - do64bit_ok=yes - CFLAGS="$CFLAGS -q64" - LDFLAGS_ARCH="-q64" - RANLIB="${RANLIB} -X64" - AR="${AR} -X64" - SHLIB_LD_FLAGS="-b64" - fi - fi - SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry ${SHLIB_LD_FLAGS}" + if test "$GCC" = "yes" ; then + SHLIB_LD="gcc -shared" + else + SHLIB_LD="/bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry" + fi + SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix ${SHLIB_LD} ${SHLIB_LD_FLAGS}" + DL_LIBS="-ldl" + CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' + LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} + TCL_NEEDS_EXP_FILE=1 + TCL_EXPORT_FILE_SUFFIX='${VERSION}.exp' + fi + + # AIX v<=4.1 has some different flags than 4.2+ + if test "$system" = "AIX-4.1" -o "`uname -v`" -lt "4" ; then + case $LIBOBJS in + "tclLoadAix.$ac_objext" | \ + *" tclLoadAix.$ac_objext" | \ + "tclLoadAix.$ac_objext "* | \ + *" tclLoadAix.$ac_objext "* ) ;; + *) LIBOBJS="$LIBOBJS tclLoadAix.$ac_objext" ;; +esac + + DL_LIBS="-lld" + fi # On AIX <=v4 systems, libbsd.a has to be linked in to support # non-blocking file IO. This library has to be linked in after # the MATH_LIBS or it breaks the pow() function. The way to # insure proper sequencing, is to add it to the tail of MATH_LIBS. @@ -6425,11 +6645,10 @@ echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lbsd $LIBS" cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -6449,15 +6668,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -6466,11 +6695,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_bsd_gettimeofday=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_bsd_gettimeofday" >&5 echo "${ECHO_T}$ac_cv_lib_bsd_gettimeofday" >&6 if test $ac_cv_lib_bsd_gettimeofday = yes; then @@ -6507,11 +6737,10 @@ echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lbind $LIBS" cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -6531,15 +6760,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -6548,11 +6787,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_bind_inet_ntoa=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_bind_inet_ntoa" >&5 echo "${ECHO_T}$ac_cv_lib_bind_inet_ntoa" >&6 if test $ac_cv_lib_bind_inet_ntoa = yes; then @@ -6612,11 +6852,10 @@ echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldld $LIBS" cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -6636,15 +6875,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -6653,11 +6902,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_dld_shl_load=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_dld_shl_load" >&5 echo "${ECHO_T}$ac_cv_lib_dld_shl_load" >&6 if test $ac_cv_lib_dld_shl_load = yes; then @@ -6678,12 +6928,11 @@ LD_LIBRARY_PATH_VAR="SHLIB_PATH" fi if test "$GCC" = "yes" ; then SHLIB_LD="gcc -shared" SHLIB_LD_LIBS='${LIBS}' - LD_SEARCH_FLAGS='' - CC_SEARCH_FLAGS='' + LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} fi # Users may want PA-RISC 1.1/2.0 portable code - needs HP cc #CFLAGS="$CFLAGS +DAportable" @@ -6695,12 +6944,12 @@ hppa64*) # 64-bit gcc in use. Fix flags for GNU ld. do64bit_ok=yes SHLIB_LD="gcc -shared" SHLIB_LD_LIBS='${LIBS}' - LD_SEARCH_FLAGS='' - CC_SEARCH_FLAGS='' + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} ;; *) { echo "$as_me:$LINENO: WARNING: \"64bit mode not supported with GCC on $system\"" >&5 echo "$as_me: WARNING: \"64bit mode not supported with GCC on $system\"" >&2;} ;; @@ -6720,11 +6969,10 @@ echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldld $LIBS" cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -6744,15 +6992,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -6761,11 +7019,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_dld_shl_load=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_dld_shl_load" >&5 echo "${ECHO_T}$ac_cv_lib_dld_shl_load" >&6 if test $ac_cv_lib_dld_shl_load = yes; then @@ -6784,22 +7043,10 @@ CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' LD_LIBRARY_PATH_VAR="SHLIB_PATH" fi ;; - IRIX-4.*) - SHLIB_CFLAGS="-G 0" - SHLIB_SUFFIX=".a" - SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" - SHLIB_LD_LIBS='${LIBS}' - DL_OBJS="tclLoadAout.o" - DL_LIBS="" - LDFLAGS="$LDFLAGS -Wl,-D,08000000" - CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a' - ;; IRIX-5.*) SHLIB_CFLAGS="" SHLIB_LD="ld -shared -rdata_shared" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" @@ -6887,11 +7134,10 @@ else # Is the header compilable? echo "$as_me:$LINENO: checking dld.h usability" >&5 echo $ECHO_N "checking dld.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -6898,15 +7144,25 @@ $ac_includes_default #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -6915,19 +7171,18 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking dld.h presence" >&5 echo $ECHO_N "checking dld.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -6941,10 +7196,11 @@ cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes @@ -6960,37 +7216,36 @@ rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? -case $ac_header_compiler:$ac_header_preproc in - yes:no ) +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) { echo "$as_me:$LINENO: WARNING: dld.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: dld.h: accepted by the compiler, rejected by the preprocessor!" >&2;} - { echo "$as_me:$LINENO: WARNING: dld.h: proceeding with the preprocessor's result" >&5 -echo "$as_me: WARNING: dld.h: proceeding with the preprocessor's result" >&2;} - ( - cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## -_ASBOX - ) | - sed "s/^/$as_me: WARNING: /" >&2 + { echo "$as_me:$LINENO: WARNING: dld.h: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: dld.h: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes ;; - no:yes ) + no:yes:* ) { echo "$as_me:$LINENO: WARNING: dld.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: dld.h: present but cannot be compiled" >&2;} - { echo "$as_me:$LINENO: WARNING: dld.h: check for missing prerequisite headers?" >&5 -echo "$as_me: WARNING: dld.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: dld.h: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: dld.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: dld.h: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: dld.h: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: dld.h: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: dld.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: dld.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: dld.h: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: dld.h: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: dld.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac @@ -7063,11 +7318,10 @@ else # Is the header compilable? echo "$as_me:$LINENO: checking dld.h usability" >&5 echo $ECHO_N "checking dld.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -7074,15 +7328,25 @@ $ac_includes_default #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -7091,19 +7355,18 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking dld.h presence" >&5 echo $ECHO_N "checking dld.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -7117,10 +7380,11 @@ cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes @@ -7136,37 +7400,36 @@ rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? -case $ac_header_compiler:$ac_header_preproc in - yes:no ) +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) { echo "$as_me:$LINENO: WARNING: dld.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: dld.h: accepted by the compiler, rejected by the preprocessor!" >&2;} - { echo "$as_me:$LINENO: WARNING: dld.h: proceeding with the preprocessor's result" >&5 -echo "$as_me: WARNING: dld.h: proceeding with the preprocessor's result" >&2;} - ( - cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## -_ASBOX - ) | - sed "s/^/$as_me: WARNING: /" >&2 + { echo "$as_me:$LINENO: WARNING: dld.h: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: dld.h: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes ;; - no:yes ) + no:yes:* ) { echo "$as_me:$LINENO: WARNING: dld.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: dld.h: present but cannot be compiled" >&2;} - { echo "$as_me:$LINENO: WARNING: dld.h: check for missing prerequisite headers?" >&5 -echo "$as_me: WARNING: dld.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: dld.h: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: dld.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: dld.h: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: dld.h: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: dld.h: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: dld.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: dld.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: dld.h: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: dld.h: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: dld.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac @@ -7216,155 +7479,71 @@ LDFLAGS="$LDFLAGS -Wl,-Bexport" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; NetBSD-*|FreeBSD-[1-2].*) - # Not available on all versions: check for include file. - if test "${ac_cv_header_dlfcn_h+set}" = set; then - echo "$as_me:$LINENO: checking for dlfcn.h" >&5 -echo $ECHO_N "checking for dlfcn.h... $ECHO_C" >&6 -if test "${ac_cv_header_dlfcn_h+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -fi -echo "$as_me:$LINENO: result: $ac_cv_header_dlfcn_h" >&5 -echo "${ECHO_T}$ac_cv_header_dlfcn_h" >&6 -else - # Is the header compilable? -echo "$as_me:$LINENO: checking dlfcn.h usability" >&5 -echo $ECHO_N "checking dlfcn.h usability... $ECHO_C" >&6 -cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -$ac_includes_default -#include -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - ac_header_compiler=yes -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -ac_header_compiler=no -fi -rm -f conftest.$ac_objext conftest.$ac_ext -echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 -echo "${ECHO_T}$ac_header_compiler" >&6 - -# Is the header present? -echo "$as_me:$LINENO: checking dlfcn.h presence" >&5 -echo $ECHO_N "checking dlfcn.h presence... $ECHO_C" >&6 -cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include -_ACEOF -if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 - (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } >/dev/null; then - if test -s conftest.err; then - ac_cpp_err=$ac_c_preproc_warn_flag - else - ac_cpp_err= - fi -else - ac_cpp_err=yes -fi -if test -z "$ac_cpp_err"; then - ac_header_preproc=yes -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_header_preproc=no -fi -rm -f conftest.err conftest.$ac_ext -echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 -echo "${ECHO_T}$ac_header_preproc" >&6 - -# So? What about this header? -case $ac_header_compiler:$ac_header_preproc in - yes:no ) - { echo "$as_me:$LINENO: WARNING: dlfcn.h: accepted by the compiler, rejected by the preprocessor!" >&5 -echo "$as_me: WARNING: dlfcn.h: accepted by the compiler, rejected by the preprocessor!" >&2;} - { echo "$as_me:$LINENO: WARNING: dlfcn.h: proceeding with the preprocessor's result" >&5 -echo "$as_me: WARNING: dlfcn.h: proceeding with the preprocessor's result" >&2;} - ( - cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## -_ASBOX - ) | - sed "s/^/$as_me: WARNING: /" >&2 - ;; - no:yes ) - { echo "$as_me:$LINENO: WARNING: dlfcn.h: present but cannot be compiled" >&5 -echo "$as_me: WARNING: dlfcn.h: present but cannot be compiled" >&2;} - { echo "$as_me:$LINENO: WARNING: dlfcn.h: check for missing prerequisite headers?" >&5 -echo "$as_me: WARNING: dlfcn.h: check for missing prerequisite headers?" >&2;} - { echo "$as_me:$LINENO: WARNING: dlfcn.h: proceeding with the preprocessor's result" >&5 -echo "$as_me: WARNING: dlfcn.h: proceeding with the preprocessor's result" >&2;} - ( - cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## -_ASBOX - ) | - sed "s/^/$as_me: WARNING: /" >&2 - ;; -esac -echo "$as_me:$LINENO: checking for dlfcn.h" >&5 -echo $ECHO_N "checking for dlfcn.h... $ECHO_C" >&6 -if test "${ac_cv_header_dlfcn_h+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - ac_cv_header_dlfcn_h=$ac_header_preproc -fi -echo "$as_me:$LINENO: result: $ac_cv_header_dlfcn_h" >&5 -echo "${ECHO_T}$ac_cv_header_dlfcn_h" >&6 - -fi -if test $ac_cv_header_dlfcn_h = yes; then - - # NetBSD/SPARC needs -fPIC, -fpic will not do. - SHLIB_CFLAGS="-fPIC" - SHLIB_LD="ld -Bshareable -x" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' - echo "$as_me:$LINENO: checking for ELF" >&5 + # NetBSD/SPARC needs -fPIC, -fpic will not do. + SHLIB_CFLAGS="-fPIC" + SHLIB_LD="ld -Bshareable -x" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' + echo "$as_me:$LINENO: checking for ELF" >&5 +echo $ECHO_N "checking for ELF... $ECHO_C" >&6 + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +#ifdef __ELF__ + yes +#endif + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "yes" >/dev/null 2>&1; then + echo "$as_me:$LINENO: result: yes" >&5 +echo "${ECHO_T}yes" >&6 + SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so' +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 + SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.1.0' + +fi +rm -f conftest* + + + # Ancient FreeBSD doesn't handle version numbers with dots. + + UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' + TCL_LIB_VERSIONS_OK=nodots + ;; + OpenBSD-*) + # OpenBSD/SPARC[64] needs -fPIC, -fpic will not do. + case `machine` in + sparc|sparc64) + SHLIB_CFLAGS="-fPIC";; + *) + SHLIB_CFLAGS="-fpic";; + esac + SHLIB_LD="${CC} -shared ${SHLIB_CFLAGS}" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} + SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.1.0' + echo "$as_me:$LINENO: checking for ELF" >&5 echo $ECHO_N "checking for ELF... $ECHO_C" >&6 - cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" + cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -7376,80 +7555,22 @@ _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "yes" >/dev/null 2>&1; then echo "$as_me:$LINENO: result: yes" >&5 echo "${ECHO_T}yes" >&6 - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so' -else - echo "$as_me:$LINENO: result: no" >&5 -echo "${ECHO_T}no" >&6 - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0' - -fi -rm -f conftest* - - -else - - SHLIB_CFLAGS="" - SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".a" - DL_OBJS="tclLoadAout.o" - DL_LIBS="" - CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a' - -fi - - - - # FreeBSD doesn't handle version numbers with dots. - - UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a' - TCL_LIB_VERSIONS_OK=nodots - ;; - OpenBSD-*) - SHLIB_LD="${CC} -shared" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - CC_SEARCH_FLAGS="" - LD_SEARCH_FLAGS="" - echo "$as_me:$LINENO: checking for ELF" >&5 -echo $ECHO_N "checking for ELF... $ECHO_C" >&6 - cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ - -#ifdef __ELF__ - yes -#endif - -_ACEOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "yes" >/dev/null 2>&1; then - echo "$as_me:$LINENO: result: yes" >&5 -echo "${ECHO_T}yes" >&6 - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0' -else - echo "$as_me:$LINENO: result: no" >&5 -echo "${ECHO_T}no" >&6 - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0' + LDFLAGS=-Wl,-export-dynamic +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 + LDFLAGS="" fi rm -f conftest* # OpenBSD doesn't do version numbers with dots. - UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a' + UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; FreeBSD-*) # FreeBSD 3.* and greater have ELF. SHLIB_CFLAGS="-fPIC" @@ -7468,39 +7589,486 @@ LDFLAGS="$LDFLAGS -pthread" fi case $system in FreeBSD-3.*) # FreeBSD-3 doesn't handle version numbers with dots. - UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a' - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so' + UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' + SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so' TCL_LIB_VERSIONS_OK=nodots ;; esac ;; - Rhapsody-*|Darwin-*) + Darwin-*) + CFLAGS_OPTIMIZE="-Os" SHLIB_CFLAGS="-fno-common" SHLIB_LD="cc -dynamiclib \${LDFLAGS}" - TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version \${VERSION} -install_name \${DYLIB_INSTALL_DIR}/\${TCL_LIB_FILE} -prebind -seg1addr 0xa000000" - TK_SHLIB_LD_EXTRAS="-compatibility_version ${TK_VERSION} -current_version \${VERSION} -install_name \${DYLIB_INSTALL_DIR}/\${TK_LIB_FILE} -prebind -seg1addr 0xb000000" + echo "$as_me:$LINENO: checking if ld accepts -single_module flag" >&5 +echo $ECHO_N "checking if ld accepts -single_module flag... $ECHO_C" >&6 +if test "${tcl_cv_ld_single_module+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + + hold_ldflags=$LDFLAGS + LDFLAGS="$LDFLAGS -dynamiclib -Wl,-single_module" + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +int +main () +{ +int i; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + tcl_cv_ld_single_module=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_ld_single_module=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + LDFLAGS=$hold_ldflags +fi +echo "$as_me:$LINENO: result: $tcl_cv_ld_single_module" >&5 +echo "${ECHO_T}$tcl_cv_ld_single_module" >&6 + if test $tcl_cv_ld_single_module = yes; then + SHLIB_LD="${SHLIB_LD} -Wl,-single_module" + fi SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".dylib" DL_OBJS="tclLoadDyld.o" - PLAT_OBJS=\$\(MAC\_OSX_OBJS\) DL_LIBS="" - LDFLAGS="$LDFLAGS -prebind" + LDFLAGS="$LDFLAGS -prebind -headerpad_max_install_names" + echo "$as_me:$LINENO: checking if ld accepts -search_paths_first flag" >&5 +echo $ECHO_N "checking if ld accepts -search_paths_first flag... $ECHO_C" >&6 +if test "${tcl_cv_ld_search_paths_first+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + + hold_ldflags=$LDFLAGS + LDFLAGS="$LDFLAGS -Wl,-search_paths_first" + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +int +main () +{ +int i; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + tcl_cv_ld_search_paths_first=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_ld_search_paths_first=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + LDFLAGS=$hold_ldflags +fi +echo "$as_me:$LINENO: result: $tcl_cv_ld_search_paths_first" >&5 +echo "${ECHO_T}$tcl_cv_ld_search_paths_first" >&6 + if test $tcl_cv_ld_search_paths_first = yes; then + LDFLAGS="$LDFLAGS -Wl,-search_paths_first" + fi CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" - CFLAGS_OPTIMIZE="-Os" LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH" + PLAT_OBJS='${MAC_OSX_OBJS}' + PLAT_SRCS='${MAC_OSX_SRCS}' + echo "$as_me:$LINENO: checking whether to use CoreFoundation" >&5 +echo $ECHO_N "checking whether to use CoreFoundation... $ECHO_C" >&6 + # Check whether --enable-corefoundation or --disable-corefoundation was given. +if test "${enable_corefoundation+set}" = set; then + enableval="$enable_corefoundation" + tcl_corefoundation=$enableval +else + tcl_corefoundation=yes +fi; + echo "$as_me:$LINENO: result: $tcl_corefoundation" >&5 +echo "${ECHO_T}$tcl_corefoundation" >&6 + if test $tcl_corefoundation = yes; then + echo "$as_me:$LINENO: checking for CoreFoundation.framework" >&5 +echo $ECHO_N "checking for CoreFoundation.framework... $ECHO_C" >&6 +if test "${tcl_cv_lib_corefoundation+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + + hold_libs=$LIBS + LIBS="$LIBS -framework CoreFoundation" + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +int +main () +{ +CFBundleRef b = CFBundleGetMainBundle(); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + tcl_cv_lib_corefoundation=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_lib_corefoundation=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + LIBS=$hold_libs +fi +echo "$as_me:$LINENO: result: $tcl_cv_lib_corefoundation" >&5 +echo "${ECHO_T}$tcl_cv_lib_corefoundation" >&6 + if test $tcl_cv_lib_corefoundation = yes; then + LIBS="$LIBS -framework CoreFoundation" cat >>confdefs.h <<\_ACEOF -#define MAC_OSX_TCL 1 +#define HAVE_COREFOUNDATION 1 _ACEOF + + fi + fi + +for ac_header in libkern/OSAtomic.h +do +as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 +else + # Is the header compilable? +echo "$as_me:$LINENO: checking $ac_header usability" >&5 +echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +#include <$ac_header> +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_header_compiler=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_header_compiler=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6 + +# Is the header present? +echo "$as_me:$LINENO: checking $ac_header presence" >&5 +echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include <$ac_header> +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_preproc=no +fi +rm -f conftest.err conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6 + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 +echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} + ( + cat <<\_ASBOX +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## +_ASBOX + ) | + sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + eval "$as_ac_Header=\$ac_header_preproc" +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 + +fi +if test `eval echo '${'$as_ac_Header'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 +_ACEOF + +fi + +done + + +for ac_func in OSSpinLockLock +do +as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` +echo "$as_me:$LINENO: checking for $ac_func" >&5 +echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 +if eval "test \"\${$as_ac_var+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $ac_func (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $ac_func + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char $ac_func (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_$ac_func) || defined (__stub___$ac_func) +choke me +#else +char (*f) () = $ac_func; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != $ac_func; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + eval "$as_ac_var=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +eval "$as_ac_var=no" +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 +if test `eval echo '${'$as_ac_var'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 +_ACEOF + +fi +done cat >>confdefs.h <<\_ACEOF -#define HAVE_CFBUNDLE 1 +#define MAC_OSX_TCL 1 _ACEOF cat >>confdefs.h <<\_ACEOF #define USE_VFORK 1 @@ -7509,11 +8077,117 @@ cat >>confdefs.h <<\_ACEOF #define TCL_DEFAULT_ENCODING "utf-8" _ACEOF - LIBS="$LIBS -framework CoreFoundation" + +cat >>confdefs.h <<\_ACEOF +#define MODULE_SCOPE __private_extern__ +_ACEOF + + +cat >>confdefs.h <<\_ACEOF +#define TCL_LOAD_FROM_MEMORY 1 +_ACEOF + + # prior to Darwin 7, realpath is not threadsafe, so don't + # use it when threads are enabled, c.f. bug # 711232: + echo "$as_me:$LINENO: checking for realpath" >&5 +echo $ECHO_N "checking for realpath... $ECHO_C" >&6 +if test "${ac_cv_func_realpath+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define realpath to an innocuous variant, in case declares realpath. + For example, HP-UX 11i declares gettimeofday. */ +#define realpath innocuous_realpath + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char realpath (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef realpath + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char realpath (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_realpath) || defined (__stub___realpath) +choke me +#else +char (*f) () = realpath; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != realpath; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_realpath=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_realpath=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_realpath" >&5 +echo "${ECHO_T}$ac_cv_func_realpath" >&6 + + if test "$ac_cv_func_realpath" = yes -a "${TCL_THREADS}" = 1 \ + -a `uname -r | awk -F. '{print $1}'` -lt 7 ; then + ac_cv_func_realpath=no + fi ;; NEXTSTEP-*) SHLIB_CFLAGS="" SHLIB_LD="cc -nostdlib -r" SHLIB_LD_LIBS="" @@ -7602,21 +8276,10 @@ # dlopen is in -lc on QNX DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; - RISCos-*) - SHLIB_CFLAGS="-G 0" - SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".a" - DL_OBJS="tclLoadAout.o" - DL_LIBS="" - LDFLAGS="$LDFLAGS -Wl,-D,08000000" - CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - ;; SCO_SV-3.2*) # Note, dlopen is available only on SCO 3.2.5 and greater. However, # this test works, since "uname -s" was non-standard in 3.2.4 and # below. if test "$GCC" = "yes" ; then @@ -7657,15 +8320,16 @@ # SunOS can't handle version numbers with dots in them in library # specs, like -ltcl7.5, so use -ltcl75 instead. Also, it # requires an extra version number at the end of .so file names. # So, the library has to have a name like libtcl75.so.1.0 - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0' - UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a' + SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.1.0' + UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; - SunOS-5.[0-6]*) + SunOS-5.[0-6]) + # Careful to not let 5.10+ fall into this case # Note: If _REENTRANT isn't defined, then Solaris # won't define thread-safe library routines. @@ -7697,11 +8361,10 @@ CC_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} fi ;; SunOS-5*) - # Note: If _REENTRANT isn't defined, then Solaris # won't define thread-safe library routines. cat >>confdefs.h <<\_ACEOF @@ -7719,12 +8382,19 @@ # Check to enable 64-bit flags for compiler/linker if test "$do64bit" = "yes" ; then arch=`isainfo` if test "$arch" = "sparcv9 sparc" ; then if test "$GCC" = "yes" ; then - { echo "$as_me:$LINENO: WARNING: \"64bit mode not supported with GCC on $system\"" >&5 -echo "$as_me: WARNING: \"64bit mode not supported with GCC on $system\"" >&2;} + if test "`gcc -dumpversion | awk -F. '{print $1}'`" -lt "3" ; then + { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&5 +echo "$as_me: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&2;} + else + do64bit_ok=yes + CFLAGS="$CFLAGS -m64 -mcpu=v9" + LDFLAGS="$LDFLAGS -m64 -mcpu=v9" + SHLIB_CFLAGS="-fPIC" + fi else do64bit_ok=yes if test "$do64bitVIS" = "yes" ; then CFLAGS="$CFLAGS -xarch=v9a" LDFLAGS_ARCH="-xarch=v9a" @@ -7731,13 +8401,22 @@ else CFLAGS="$CFLAGS -xarch=v9" LDFLAGS_ARCH="-xarch=v9" fi fi + elif test "$arch" = "amd64 i386" ; then + if test "$GCC" = "yes" ; then + { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC on $system" >&5 +echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;} + else + do64bit_ok=yes + CFLAGS="$CFLAGS -xarch=amd64" + LDFLAGS="$LDFLAGS -xarch=amd64" + fi else - { echo "$as_me:$LINENO: WARNING: \"64bit mode only supported sparcv9 system\"" >&5 -echo "$as_me: WARNING: \"64bit mode only supported sparcv9 system\"" >&2;} + { echo "$as_me:$LINENO: WARNING: 64bit mode not supported for $arch" >&5 +echo "$as_me: WARNING: 64bit mode not supported for $arch" >&2;} fi fi # Note: need the LIBS below, otherwise Tk won't find Tcl's # symbols when dynamically loaded into tclsh. @@ -7748,29 +8427,24 @@ DL_LIBS="-ldl" if test "$GCC" = "yes" ; then SHLIB_LD="$CC -shared" CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} + if test "$do64bit_ok" = "yes" ; then + # We need to specify -static-libgcc or we need to + # add the path to the sparv9 libgcc. + SHLIB_LD="$SHLIB_LD -m64 -mcpu=v9 -static-libgcc" + # for finding sparcv9 libgcc, get the regular libgcc + # path, remove so name and append 'sparcv9' + #v9gcclibdir="`gcc -print-file-name=libgcc_s.so` | ..." + #CC_SEARCH_FLAGS="${CC_SEARCH_FLAGS},-R,$v9gcclibdir" + fi else SHLIB_LD="/usr/ccs/bin/ld -G -z text" CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' fi - ;; - ULTRIX-4.*) - SHLIB_CFLAGS="-G 0" - SHLIB_SUFFIX=".a" - SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" - SHLIB_LD_LIBS='${LIBS}' - DL_OBJS="tclLoadAout.o" - DL_LIBS="" - LDFLAGS="$LDFLAGS -Wl,-D,08000000" - CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - if test "$GCC" != "yes" ; then - CFLAGS="$CFLAGS -DHAVE_TZSET -std1" - fi ;; UNIX_SV* | UnixWare-5*) SHLIB_CFLAGS="-KPIC" SHLIB_LD="cc -G" SHLIB_LD_LIBS="" @@ -7782,11 +8456,10 @@ hold_ldflags=$LDFLAGS echo "$as_me:$LINENO: checking for ld accepts -Bexport flag" >&5 echo $ECHO_N "checking for ld accepts -Bexport flag... $ECHO_C" >&6 LDFLAGS="$LDFLAGS -Wl,-Bexport" cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -7799,15 +8472,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -7816,21 +8499,22 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 LDFLAGS=$hold_ldflags found=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext echo "$as_me:$LINENO: result: $found" >&5 echo "${ECHO_T}$found" >&6 CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; esac if test "$do64bit" = "yes" -a "$do64bit_ok" = "no" ; then - { echo "$as_me:$LINENO: WARNING: \"64bit support being disabled -- don\'t know magic for this platform\"" >&5 -echo "$as_me: WARNING: \"64bit support being disabled -- don\'t know magic for this platform\"" >&2;} + { echo "$as_me:$LINENO: WARNING: 64bit support being disabled -- don't know magic for this platform" >&5 +echo "$as_me: WARNING: 64bit support being disabled -- don't know magic for this platform" >&2;} fi if test "$do64bit" = "yes" -a "$do64bit_ok" = "yes" ; then cat >>confdefs.h <<\_ACEOF @@ -7837,211 +8521,11 @@ #define TCL_CFG_DO64BIT 1 _ACEOF fi - # Step 4: If pseudo-static linking is in use (see K. B. Kenny, "Dynamic - # Loading for Tcl -- What Became of It?". Proc. 2nd Tcl/Tk Workshop, - # New Orleans, LA, Computerized Processes Unlimited, 1994), then we need - # to determine which of several header files defines the a.out file - # format (a.out.h, sys/exec.h, or sys/exec_aout.h). At present, we - # support only a file format that is more or less version-7-compatible. - # In particular, - # - a.out files must begin with `struct exec'. - # - the N_TXTOFF on the `struct exec' must compute the seek address - # of the text segment - # - The `struct exec' must contain a_magic, a_text, a_data, a_bss - # and a_entry fields. - # The following compilation should succeed if and only if either sys/exec.h - # or a.out.h is usable for the purpose. - # - # Note that the modified COFF format used on MIPS Ultrix 4.x is usable; the - # `struct exec' includes a second header that contains information that - # duplicates the v7 fields that are needed. - - if test "x$DL_OBJS" = "xtclLoadAout.o" ; then - echo "$as_me:$LINENO: checking sys/exec.h" >&5 -echo $ECHO_N "checking sys/exec.h... $ECHO_C" >&6 - cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include -int -main () -{ - - struct exec foo; - unsigned long seek; - int flag; -#if defined(__mips) || defined(mips) - seek = N_TXTOFF (foo.ex_f, foo.ex_o); -#else - seek = N_TXTOFF (foo); -#endif - flag = (foo.a_magic == OMAGIC); - return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; - - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - tcl_ok=usable -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -tcl_ok=unusable -fi -rm -f conftest.$ac_objext conftest.$ac_ext - echo "$as_me:$LINENO: result: $tcl_ok" >&5 -echo "${ECHO_T}$tcl_ok" >&6 - if test $tcl_ok = usable; then - -cat >>confdefs.h <<\_ACEOF -#define USE_SYS_EXEC_H 1 -_ACEOF - - else - echo "$as_me:$LINENO: checking a.out.h" >&5 -echo $ECHO_N "checking a.out.h... $ECHO_C" >&6 - cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include -int -main () -{ - - struct exec foo; - unsigned long seek; - int flag; -#if defined(__mips) || defined(mips) - seek = N_TXTOFF (foo.ex_f, foo.ex_o); -#else - seek = N_TXTOFF (foo); -#endif - flag = (foo.a_magic == OMAGIC); - return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; - - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - tcl_ok=usable -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -tcl_ok=unusable -fi -rm -f conftest.$ac_objext conftest.$ac_ext - echo "$as_me:$LINENO: result: $tcl_ok" >&5 -echo "${ECHO_T}$tcl_ok" >&6 - if test $tcl_ok = usable; then - -cat >>confdefs.h <<\_ACEOF -#define USE_A_OUT_H 1 -_ACEOF - - else - echo "$as_me:$LINENO: checking sys/exec_aout.h" >&5 -echo $ECHO_N "checking sys/exec_aout.h... $ECHO_C" >&6 - cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include -int -main () -{ - - struct exec foo; - unsigned long seek; - int flag; -#if defined(__mips) || defined(mips) - seek = N_TXTOFF (foo.ex_f, foo.ex_o); -#else - seek = N_TXTOFF (foo); -#endif - flag = (foo.a_midmag == OMAGIC); - return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; - - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - tcl_ok=usable -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -tcl_ok=unusable -fi -rm -f conftest.$ac_objext conftest.$ac_ext - echo "$as_me:$LINENO: result: $tcl_ok" >&5 -echo "${ECHO_T}$tcl_ok" >&6 - if test $tcl_ok = usable; then - -cat >>confdefs.h <<\_ACEOF -#define USE_SYS_EXEC_AOUT_H 1 -_ACEOF - - else - DL_OBJS="" - fi - fi - fi - fi - - # Step 5: disable dynamic loading if requested via a command-line switch. + # Step 4: disable dynamic loading if requested via a command-line switch. # Check whether --enable-load or --disable-load was given. if test "${enable_load+set}" = set; then enableval="$enable_load" tcl_ok=$enableval @@ -8082,11 +8566,11 @@ ;; IRIX*) ;; NetBSD-*|FreeBSD-*) ;; - Rhapsody-*|Darwin-*) + Darwin-*) ;; RISCos-*) ;; SCO_SV-3.2*) ;; @@ -8098,19 +8582,19 @@ esac fi fi if test "$SHARED_LIB_SUFFIX" = "" ; then - SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}${SHLIB_SUFFIX}' + SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}' fi if test "$UNSHARED_LIB_SUFFIX" = "" ; then - UNSHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a' + UNSHARED_LIB_SUFFIX='${VERSION}.a' fi if test "${SHARED_BUILD}" = "1" && test "${SHLIB_SUFFIX}" != "" ; then LIB_SUFFIX=${SHARED_LIB_SUFFIX} - MAKE_LIB='${SHLIB_LD} -o $@ ${SHLIB_LD_FLAGS} ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' + MAKE_LIB='${SHLIB_LD} -o $@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)' else LIB_SUFFIX=${UNSHARED_LIB_SUFFIX} if test "$RANLIB" = "" ; then @@ -8190,14 +8674,14 @@ tcl_ok=$enableval else tcl_ok=no fi; # FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT. + DBGX="" if test "$tcl_ok" = "no"; then CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)' LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)' - DBGX="" echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 cat >>confdefs.h <<\_ACEOF #define TCL_CFG_OPTIMIZED 1 @@ -8204,18 +8688,18 @@ _ACEOF else CFLAGS_DEFAULT='$(CFLAGS_DEBUG)' LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)' - DBGX=g if test "$tcl_ok" = "yes"; then echo "$as_me:$LINENO: result: yes (standard debugging)" >&5 echo "${ECHO_T}yes (standard debugging)" >&6 fi fi + ### FIXME: Surely TCL_CFG_DEBUG should be set to whether we're debugging? cat >>confdefs.h <<\_ACEOF #define TCL_CFG_DEBUG 1 _ACEOF @@ -8226,11 +8710,11 @@ #define TCL_MEM_DEBUG 1 _ACEOF fi - if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then + if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then cat >>confdefs.h <<\_ACEOF #define TCL_COMPILE_DEBUG 1 _ACEOF @@ -8237,11 +8721,11 @@ cat >>confdefs.h <<\_ACEOF #define TCL_COMPILE_STATS 1 _ACEOF - fi + fi if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then if test "$tcl_ok" = "all"; then echo "$as_me:$LINENO: result: enabled symbols mem compile debugging" >&5 echo "${ECHO_T}enabled symbols mem compile debugging" >&6 @@ -8250,12 +8734,10 @@ echo "${ECHO_T}enabled $tcl_ok debugging" >&6 fi fi -TCL_DBGX=${DBGX} - #-------------------------------------------------------------------- # Detect what compiler flags to set for 64-bit support. #-------------------------------------------------------------------- @@ -8265,11 +8747,10 @@ if test "${tcl_cv_flag__isoc99_source+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -8282,15 +8763,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -8298,11 +8789,10 @@ else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -8316,15 +8806,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -8333,13 +8833,13 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_flag__isoc99_source=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "x${tcl_cv_flag__isoc99_source}" = "xyes" ; then cat >>confdefs.h <<\_ACEOF @@ -8351,11 +8851,10 @@ if test "${tcl_cv_flag__largefile64_source+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -8368,15 +8867,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -8384,11 +8893,10 @@ else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -8402,15 +8910,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -8419,13 +8937,13 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_flag__largefile64_source=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "x${tcl_cv_flag__largefile64_source}" = "xyes" ; then cat >>confdefs.h <<\_ACEOF @@ -8432,10 +8950,114 @@ #define _LARGEFILE64_SOURCE 1 _ACEOF tcl_flags="$tcl_flags _LARGEFILE64_SOURCE" fi + + if test "${tcl_cv_flag__largefile_source64+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +int +main () +{ +char *p = (char *)open64; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + tcl_cv_flag__largefile_source64=no +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#define _LARGEFILE_SOURCE64 1 +#include +int +main () +{ +char *p = (char *)open64; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + tcl_cv_flag__largefile_source64=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_flag__largefile_source64=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi + + if test "x${tcl_cv_flag__largefile_source64}" = "xyes" ; then + +cat >>confdefs.h <<\_ACEOF +#define _LARGEFILE_SOURCE64 1 +_ACEOF + + tcl_flags="$tcl_flags _LARGEFILE_SOURCE64" + fi if test "x${tcl_flags}" = "x" ; then echo "$as_me:$LINENO: result: none" >&5 echo "${ECHO_T}none" >&6 else echo "$as_me:$LINENO: result: ${tcl_flags}" >&5 @@ -8450,11 +9072,10 @@ else tcl_cv_type_64bit=none # See if the compiler knows natively about __int64 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -8467,15 +9088,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -8484,16 +9115,15 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_type_64bit="long long" fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext # See if we should use long anyway Note that we substitute in the # type that is our current guess for a 64-bit type inside this check # program, so it should be modified only carefully... cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -8508,15 +9138,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -8524,11 +9164,11 @@ else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "${tcl_cv_type_64bit}" = none ; then cat >>confdefs.h <<\_ACEOF @@ -8552,11 +9192,10 @@ if test "${tcl_cv_struct_dirent64+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -8570,15 +9209,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -8587,11 +9236,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_struct_dirent64=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then cat >>confdefs.h <<\_ACEOF @@ -8607,11 +9256,10 @@ if test "${tcl_cv_struct_stat64+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -8625,15 +9273,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -8642,11 +9300,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_struct_stat64=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "x${tcl_cv_struct_stat64}" = "xyes" ; then cat >>confdefs.h <<\_ACEOF @@ -8655,55 +9313,10 @@ fi echo "$as_me:$LINENO: result: ${tcl_cv_struct_stat64}" >&5 echo "${ECHO_T}${tcl_cv_struct_stat64}" >&6 - echo "$as_me:$LINENO: checking for off64_t" >&5 -echo $ECHO_N "checking for off64_t... $ECHO_C" >&6 - if test "${tcl_cv_type_off64_t+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - - cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include -int -main () -{ -off64_t offset; - - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - tcl_cv_type_off64_t=yes -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -tcl_cv_type_off64_t=no -fi -rm -f conftest.$ac_objext conftest.$ac_ext -fi - for ac_func in open64 lseek64 do as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` @@ -8711,25 +9324,32 @@ echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 if eval "test \"\${$as_ac_var+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef $ac_func + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -8756,15 +9376,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -8773,11 +9403,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 if test `eval echo '${'$as_ac_var'}'` = yes; then cat >>confdefs.h <<_ACEOF @@ -8784,10 +9415,64 @@ #define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done + + echo "$as_me:$LINENO: checking for off64_t" >&5 +echo $ECHO_N "checking for off64_t... $ECHO_C" >&6 + if test "${tcl_cv_type_off64_t+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +int +main () +{ +off64_t offset; + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + tcl_cv_type_off64_t=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_type_off64_t=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi if test "x${tcl_cv_type_off64_t}" = "xyes" && \ test "x${ac_cv_func_lseek64}" = "xyes" && \ test "x${ac_cv_func_open64}" = "xyes" ; then @@ -8813,11 +9498,10 @@ if test "${ac_cv_c_bigendian+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else # See if sys/param.h defines the BYTE_ORDER macro. cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -8835,23 +9519,32 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then # It does; now see whether it defined to BIG_ENDIAN or not. cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -8869,15 +9562,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -8886,21 +9589,20 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_c_bigendian=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 # It does not; compile a test program. if test "$cross_compiling" = yes; then # try to guess the endianness by grepping values into an object file ac_cv_c_bigendian=unknown cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -8918,15 +9620,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -8944,14 +9656,13 @@ else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -8986,14 +9697,14 @@ sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) ac_cv_c_bigendian=yes fi -rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_c_bigendian" >&5 echo "${ECHO_T}$ac_cv_c_bigendian" >&6 case $ac_cv_c_bigendian in yes) @@ -9027,25 +9738,32 @@ echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 if eval "test \"\${$as_ac_var+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef $ac_func + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -9072,15 +9790,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -9089,11 +9817,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 if test `eval echo '${'$as_ac_var'}'` = yes; then cat >>confdefs.h <<_ACEOF @@ -9112,34 +9841,45 @@ # Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really # define USEGETWD even if the posix getcwd exists. Add a test ? -for ac_func in opendir strstr + + + + +for ac_func in opendir strtol strtoll strtoull tmpnam waitpid do as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 if eval "test \"\${$as_ac_var+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef $ac_func + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -9166,15 +9906,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -9183,113 +9933,29 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 if test `eval echo '${'$as_ac_var'}'` = yes; then cat >>confdefs.h <<_ACEOF #define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF else - LIBOBJS="$LIBOBJS $ac_func.$ac_objext" -fi -done - - - - - - - - -for ac_func in strtol strtoll strtoull tmpnam waitpid -do -as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` -echo "$as_me:$LINENO: checking for $ac_func" >&5 -echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 -if eval "test \"\${$as_ac_var+set}\" = set"; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -/* System header to define __stub macros and hopefully few prototypes, - which can conflict with char $ac_func (); below. - Prefer to if __STDC__ is defined, since - exists even on freestanding compilers. */ -#ifdef __STDC__ -# include -#else -# include -#endif -/* Override any gcc2 internal prototype to avoid an error. */ -#ifdef __cplusplus -extern "C" -{ -#endif -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char $ac_func (); -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined (__stub_$ac_func) || defined (__stub___$ac_func) -choke me -#else -char (*f) () = $ac_func; -#endif -#ifdef __cplusplus -} -#endif - -int -main () -{ -return f != $ac_func; - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - eval "$as_ac_var=yes" -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -eval "$as_ac_var=no" -fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext -fi -echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 -echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 -if test `eval echo '${'$as_ac_var'}'` = yes; then - cat >>confdefs.h <<_ACEOF -#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 -_ACEOF - -else - LIBOBJS="$LIBOBJS $ac_func.$ac_objext" + case $LIBOBJS in + "$ac_func.$ac_objext" | \ + *" $ac_func.$ac_objext" | \ + "$ac_func.$ac_objext "* | \ + *" $ac_func.$ac_objext "* ) ;; + *) LIBOBJS="$LIBOBJS $ac_func.$ac_objext" ;; +esac + fi done echo "$as_me:$LINENO: checking for strerror" >&5 @@ -9296,25 +9962,32 @@ echo $ECHO_N "checking for strerror... $ECHO_C" >&6 if test "${ac_cv_func_strerror+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define strerror to an innocuous variant, in case declares strerror. + For example, HP-UX 11i declares gettimeofday. */ +#define strerror innocuous_strerror + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char strerror (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef strerror + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -9341,15 +10014,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -9358,11 +10041,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_strerror=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_strerror" >&5 echo "${ECHO_T}$ac_cv_func_strerror" >&6 if test $ac_cv_func_strerror = yes; then : @@ -9378,25 +10062,32 @@ echo $ECHO_N "checking for getwd... $ECHO_C" >&6 if test "${ac_cv_func_getwd+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define getwd to an innocuous variant, in case declares getwd. + For example, HP-UX 11i declares gettimeofday. */ +#define getwd innocuous_getwd + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char getwd (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef getwd + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -9423,15 +10114,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -9440,11 +10141,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_getwd=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_getwd" >&5 echo "${ECHO_T}$ac_cv_func_getwd" >&6 if test $ac_cv_func_getwd = yes; then : @@ -9460,25 +10162,32 @@ echo $ECHO_N "checking for wait3... $ECHO_C" >&6 if test "${ac_cv_func_wait3+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define wait3 to an innocuous variant, in case declares wait3. + For example, HP-UX 11i declares gettimeofday. */ +#define wait3 innocuous_wait3 + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char wait3 (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef wait3 + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -9505,15 +10214,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -9522,11 +10241,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_wait3=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_wait3" >&5 echo "${ECHO_T}$ac_cv_func_wait3" >&6 if test $ac_cv_func_wait3 = yes; then : @@ -9542,25 +10262,32 @@ echo $ECHO_N "checking for uname... $ECHO_C" >&6 if test "${ac_cv_func_uname+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define uname to an innocuous variant, in case declares uname. + For example, HP-UX 11i declares gettimeofday. */ +#define uname innocuous_uname + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char uname (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef uname + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -9587,15 +10314,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -9604,11 +10341,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_uname=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_uname" >&5 echo "${ECHO_T}$ac_cv_func_uname" >&6 if test $ac_cv_func_uname = yes; then : @@ -9624,25 +10362,32 @@ echo $ECHO_N "checking for realpath... $ECHO_C" >&6 if test "${ac_cv_func_realpath+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define realpath to an innocuous variant, in case declares realpath. + For example, HP-UX 11i declares gettimeofday. */ +#define realpath innocuous_realpath + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char realpath (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef realpath + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -9669,15 +10414,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -9686,11 +10441,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_realpath=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_realpath" >&5 echo "${ECHO_T}$ac_cv_func_realpath" >&6 if test $ac_cv_func_realpath = yes; then : @@ -9725,11 +10481,10 @@ else # Is the header compilable? echo "$as_me:$LINENO: checking $ac_header usability" >&5 echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -9736,15 +10491,25 @@ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -9753,19 +10518,18 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking $ac_header presence" >&5 echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -9779,10 +10543,11 @@ cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes @@ -9798,37 +10563,36 @@ rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? -case $ac_header_compiler:$ac_header_preproc in - yes:no ) +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} - { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 -echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} - ( - cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## -_ASBOX - ) | - sed "s/^/$as_me: WARNING: /" >&2 + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes ;; - no:yes ) + no:yes:* ) { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} - { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 -echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac @@ -9835,11 +10599,11 @@ echo "$as_me:$LINENO: checking for $ac_header" >&5 echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 if eval "test \"\${$as_ac_Header+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else - eval "$as_ac_Header=$ac_header_preproc" + eval "$as_ac_Header=\$ac_header_preproc" fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 fi @@ -9860,11 +10624,10 @@ if test "$cross_compiling" = yes; then tcl_cv_api_serial=no else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -9899,18 +10662,17 @@ sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_api_serial=no fi -rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi if test $tcl_cv_api_serial = no ; then if test "$cross_compiling" = yes; then tcl_cv_api_serial=no else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -9944,19 +10706,18 @@ sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_api_serial=no fi -rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi if test $tcl_cv_api_serial = no ; then if test "$cross_compiling" = yes; then tcl_cv_api_serial=no else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -9991,19 +10752,18 @@ sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_api_serial=no fi -rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi if test $tcl_cv_api_serial = no ; then if test "$cross_compiling" = yes; then tcl_cv_api_serial=no else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -10040,19 +10800,18 @@ sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_api_serial=no fi -rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi if test $tcl_cv_api_serial = no; then if test "$cross_compiling" = yes; then tcl_cv_api_serial=no else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -10088,19 +10847,18 @@ sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_api_serial=no fi -rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi if test $tcl_cv_api_serial = no; then if test "$cross_compiling" = yes; then tcl_cv_api_serial=none else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -10137,11 +10895,11 @@ sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_api_serial=none fi -rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi fi case $tcl_cv_api_serial in @@ -10179,11 +10937,10 @@ echo $ECHO_N "checking for fd_set in sys/types... $ECHO_C" >&6 if test "${tcl_cv_type_fd_set+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -10196,15 +10953,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -10213,11 +10980,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_type_fd_set=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_type_fd_set" >&5 echo "${ECHO_T}$tcl_cv_type_fd_set" >&6 tk_ok=$tcl_cv_type_fd_set @@ -10226,11 +10993,10 @@ echo $ECHO_N "checking for fd_mask in sys/select... $ECHO_C" >&6 if test "${tcl_cv_grep_fd_mask+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -10274,11 +11040,10 @@ echo $ECHO_N "checking whether struct tm is in sys/time.h or time.h... $ECHO_C" >&6 if test "${ac_cv_struct_tm+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -10293,15 +11058,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -10310,11 +11085,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_struct_tm=sys/time.h fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_struct_tm" >&5 echo "${ECHO_T}$ac_cv_struct_tm" >&6 if test $ac_cv_struct_tm = sys/time.h; then @@ -10340,11 +11115,10 @@ else # Is the header compilable? echo "$as_me:$LINENO: checking $ac_header usability" >&5 echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -10351,15 +11125,25 @@ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -10368,19 +11152,18 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking $ac_header presence" >&5 echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -10394,10 +11177,11 @@ cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes @@ -10413,37 +11197,36 @@ rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? -case $ac_header_compiler:$ac_header_preproc in - yes:no ) +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} - { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 -echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} - ( - cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## -_ASBOX - ) | - sed "s/^/$as_me: WARNING: /" >&2 + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes ;; - no:yes ) + no:yes:* ) { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} - { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 -echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac @@ -10450,11 +11233,11 @@ echo "$as_me:$LINENO: checking for $ac_header" >&5 echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 if eval "test \"\${$as_ac_Header+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else - eval "$as_ac_Header=$ac_header_preproc" + eval "$as_ac_Header=\$ac_header_preproc" fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 fi @@ -10471,11 +11254,10 @@ echo $ECHO_N "checking whether time.h and sys/time.h may both be included... $ECHO_C" >&6 if test "${ac_cv_header_time+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -10492,15 +11274,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -10509,11 +11301,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_header_time=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_header_time" >&5 echo "${ECHO_T}$ac_cv_header_time" >&6 if test $ac_cv_header_time = yes; then @@ -10527,11 +11319,10 @@ echo $ECHO_N "checking for struct tm.tm_zone... $ECHO_C" >&6 if test "${ac_cv_member_struct_tm_tm_zone+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -10549,15 +11340,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -10565,11 +11366,10 @@ else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -10587,15 +11387,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -10604,13 +11414,13 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_member_struct_tm_tm_zone=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_member_struct_tm_tm_zone" >&5 echo "${ECHO_T}$ac_cv_member_struct_tm_tm_zone" >&6 if test $ac_cv_member_struct_tm_tm_zone = yes; then @@ -10632,11 +11442,10 @@ echo $ECHO_N "checking for tzname... $ECHO_C" >&6 if test "${ac_cv_var_tzname+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -10653,15 +11462,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -10670,11 +11489,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_var_tzname=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_var_tzname" >&5 echo "${ECHO_T}$ac_cv_var_tzname" >&6 if test $ac_cv_var_tzname = yes; then @@ -10696,25 +11516,32 @@ echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 if eval "test \"\${$as_ac_var+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef $ac_func + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -10741,15 +11568,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -10758,11 +11595,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 if test `eval echo '${'$as_ac_var'}'` = yes; then cat >>confdefs.h <<_ACEOF @@ -10777,11 +11615,10 @@ echo $ECHO_N "checking tm_tzadj in struct tm... $ECHO_C" >&6 if test "${tcl_cv_member_tm_tzadj+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -10794,15 +11631,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -10811,11 +11658,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_member_tm_tzadj=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_member_tm_tzadj" >&5 echo "${ECHO_T}$tcl_cv_member_tm_tzadj" >&6 if test $tcl_cv_member_tm_tzadj = yes ; then @@ -10830,11 +11677,10 @@ echo $ECHO_N "checking tm_gmtoff in struct tm... $ECHO_C" >&6 if test "${tcl_cv_member_tm_gmtoff+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -10847,15 +11693,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -10864,11 +11720,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_member_tm_gmtoff=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_member_tm_gmtoff" >&5 echo "${ECHO_T}$tcl_cv_member_tm_gmtoff" >&6 if test $tcl_cv_member_tm_gmtoff = yes ; then @@ -10887,11 +11743,10 @@ echo $ECHO_N "checking long timezone variable... $ECHO_C" >&6 if test "${tcl_cv_var_timezone+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -10906,15 +11761,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -10923,11 +11788,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_timezone_long=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_timezone_long" >&5 echo "${ECHO_T}$tcl_cv_timezone_long" >&6 if test $tcl_cv_timezone_long = yes ; then @@ -10944,11 +11809,10 @@ echo $ECHO_N "checking time_t timezone variable... $ECHO_C" >&6 if test "${tcl_cv_timezone_time+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -10963,15 +11827,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -10980,11 +11854,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_timezone_time=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_timezone_time" >&5 echo "${ECHO_T}$tcl_cv_timezone_time" >&6 if test $tcl_cv_timezone_time = yes ; then @@ -11006,11 +11880,10 @@ echo $ECHO_N "checking for struct stat.st_blksize... $ECHO_C" >&6 if test "${ac_cv_member_struct_stat_st_blksize+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -11025,15 +11898,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -11041,11 +11924,10 @@ else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -11060,15 +11942,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -11077,13 +11969,13 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_member_struct_stat_st_blksize=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_member_struct_stat_st_blksize" >&5 echo "${ECHO_T}$ac_cv_member_struct_stat_st_blksize" >&6 if test $ac_cv_member_struct_stat_st_blksize = yes; then @@ -11103,25 +11995,32 @@ echo $ECHO_N "checking for fstatfs... $ECHO_C" >&6 if test "${ac_cv_func_fstatfs+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define fstatfs to an innocuous variant, in case declares fstatfs. + For example, HP-UX 11i declares gettimeofday. */ +#define fstatfs innocuous_fstatfs + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char fstatfs (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef fstatfs + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -11148,15 +12047,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -11165,11 +12074,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_fstatfs=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_fstatfs" >&5 echo "${ECHO_T}$ac_cv_func_fstatfs" >&6 if test $ac_cv_func_fstatfs = yes; then : @@ -11193,17 +12103,16 @@ else if test "$cross_compiling" = yes; then ac_cv_func_memcmp_working=no else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ - +$ac_includes_default int main () { /* Some versions of memcmp are not 8-bit clean. */ @@ -11218,16 +12127,16 @@ char foo[21]; char bar[21]; int i; for (i = 0; i < 4; i++) { - char *a = foo + i; - char *b = bar + i; - strcpy (a, "--------01111111"); - strcpy (b, "--------10000000"); - if (memcmp (a, b, 16) >= 0) - exit (1); + char *a = foo + i; + char *b = bar + i; + strcpy (a, "--------01111111"); + strcpy (b, "--------10000000"); + if (memcmp (a, b, 16) >= 0) + exit (1); } exit (0); } ; @@ -11252,16 +12161,23 @@ sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) ac_cv_func_memcmp_working=no fi -rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi echo "$as_me:$LINENO: result: $ac_cv_func_memcmp_working" >&5 echo "${ECHO_T}$ac_cv_func_memcmp_working" >&6 -test $ac_cv_func_memcmp_working = no && LIBOBJS="$LIBOBJS memcmp.$ac_objext" +test $ac_cv_func_memcmp_working = no && case $LIBOBJS in + "memcmp.$ac_objext" | \ + *" memcmp.$ac_objext" | \ + "memcmp.$ac_objext "* | \ + *" memcmp.$ac_objext "* ) ;; + *) LIBOBJS="$LIBOBJS memcmp.$ac_objext" ;; +esac + #-------------------------------------------------------------------- # Some system like SunOS 4 and other BSD like systems # have no memmove (we assume they have bcopy instead). @@ -11271,25 +12187,32 @@ echo $ECHO_N "checking for memmove... $ECHO_C" >&6 if test "${ac_cv_func_memmove+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define memmove to an innocuous variant, in case declares memmove. + For example, HP-UX 11i declares gettimeofday. */ +#define memmove innocuous_memmove + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char memmove (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef memmove + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -11316,15 +12239,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -11333,11 +12266,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_memmove=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_memmove" >&5 echo "${ECHO_T}$ac_cv_func_memmove" >&6 if test $ac_cv_func_memmove = yes; then : @@ -11359,29 +12293,126 @@ #-------------------------------------------------------------------- # On some systems strstr is broken: it returns a pointer even # even if the original string is empty. #-------------------------------------------------------------------- -echo "$as_me:$LINENO: checking proper strstr implementation" >&5 + + echo "$as_me:$LINENO: checking for strstr" >&5 +echo $ECHO_N "checking for strstr... $ECHO_C" >&6 +if test "${ac_cv_func_strstr+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define strstr to an innocuous variant, in case declares strstr. + For example, HP-UX 11i declares gettimeofday. */ +#define strstr innocuous_strstr + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char strstr (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef strstr + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char strstr (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_strstr) || defined (__stub___strstr) +choke me +#else +char (*f) () = strstr; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != strstr; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_strstr=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_strstr=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_strstr" >&5 +echo "${ECHO_T}$ac_cv_func_strstr" >&6 +if test $ac_cv_func_strstr = yes; then + tcl_ok=1 +else + tcl_ok=0 +fi + + if test "$tcl_ok" = 1; then + echo "$as_me:$LINENO: checking proper strstr implementation" >&5 echo $ECHO_N "checking proper strstr implementation... $ECHO_C" >&6 -if test "$cross_compiling" = yes; then - tcl_ok=no + if test "${tcl_cv_strstr_unbroken+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test "$cross_compiling" = yes; then + tcl_cv_strstr_unbroken=unknown else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ - -extern int strstr(); -int main() -{ +int main() { + extern int strstr(); exit(strstr("\0test", "test") ? 1 : 0); } - _ACEOF rm -f conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>&5 ac_status=$? @@ -11390,58 +12421,78 @@ { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - tcl_ok=yes + tcl_cv_strstr_unbroken=ok else echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) -tcl_ok=no -fi -rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext -fi -if test $tcl_ok = yes; then - echo "$as_me:$LINENO: result: yes" >&5 -echo "${ECHO_T}yes" >&6 -else - echo "$as_me:$LINENO: result: broken, using substitute" >&5 -echo "${ECHO_T}broken, using substitute" >&6 - LIBOBJS="$LIBOBJS strstr.$ac_objext" - USE_COMPAT=1 -fi +tcl_cv_strstr_unbroken=broken +fi +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +fi +fi + + echo "$as_me:$LINENO: result: $tcl_cv_strstr_unbroken" >&5 +echo "${ECHO_T}$tcl_cv_strstr_unbroken" >&6 + if test "$tcl_cv_strstr_unbroken" = "ok"; then + tcl_ok=1 + else + tcl_ok=0 + fi + fi + if test "$tcl_ok" = 0; then + case $LIBOBJS in + "strstr.$ac_objext" | \ + *" strstr.$ac_objext" | \ + "strstr.$ac_objext "* | \ + *" strstr.$ac_objext "* ) ;; + *) LIBOBJS="$LIBOBJS strstr.$ac_objext" ;; +esac + + USE_COMPAT=1 + fi #-------------------------------------------------------------------- # Check for strtoul function. This is tricky because under some # versions of AIX strtoul returns an incorrect terminator # pointer for the string "0". #-------------------------------------------------------------------- -echo "$as_me:$LINENO: checking for strtoul" >&5 + + echo "$as_me:$LINENO: checking for strtoul" >&5 echo $ECHO_N "checking for strtoul... $ECHO_C" >&6 if test "${ac_cv_func_strtoul+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define strtoul to an innocuous variant, in case declares strtoul. + For example, HP-UX 11i declares gettimeofday. */ +#define strtoul innocuous_strtoul + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char strtoul (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef strtoul + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -11468,15 +12519,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -11485,42 +12546,40 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_strtoul=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_strtoul" >&5 echo "${ECHO_T}$ac_cv_func_strtoul" >&6 if test $ac_cv_func_strtoul = yes; then tcl_ok=1 else tcl_ok=0 fi -if test "$cross_compiling" = yes; then - tcl_ok=0 + if test "$tcl_ok" = 1; then + echo "$as_me:$LINENO: checking proper strtoul implementation" >&5 +echo $ECHO_N "checking proper strtoul implementation... $ECHO_C" >&6 + if test "${tcl_cv_strtoul_unbroken+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test "$cross_compiling" = yes; then + tcl_cv_strtoul_unbroken=unknown else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ - -extern int strtoul(); -int main() -{ - char *string = "0"; - char *term; - int value; - value = strtoul(string, &term, 0); - if ((value != 0) || (term != (string+1))) { - exit(1); - } - exit(0); +int main() { + extern int strtoul(); + char *term, *string = "0"; + exit(strtoul(string,&term,0) != 0 || term != string+1); } _ACEOF rm -f conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>&5 @@ -11530,53 +12589,77 @@ { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - : + tcl_cv_strtoul_unbroken=ok else echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) -tcl_ok=0 -fi -rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext -fi -if test "$tcl_ok" = 0; then - test -n "$verbose" && echo " Adding strtoul.o." - LIBOBJS="$LIBOBJS strtoul.$ac_objext" - USE_COMPAT=1 -fi +tcl_cv_strtoul_unbroken=broken +fi +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +fi +fi + + echo "$as_me:$LINENO: result: $tcl_cv_strtoul_unbroken" >&5 +echo "${ECHO_T}$tcl_cv_strtoul_unbroken" >&6 + if test "$tcl_cv_strtoul_unbroken" = "ok"; then + tcl_ok=1 + else + tcl_ok=0 + fi + fi + if test "$tcl_ok" = 0; then + case $LIBOBJS in + "strtoul.$ac_objext" | \ + *" strtoul.$ac_objext" | \ + "strtoul.$ac_objext "* | \ + *" strtoul.$ac_objext "* ) ;; + *) LIBOBJS="$LIBOBJS strtoul.$ac_objext" ;; +esac + + USE_COMPAT=1 + fi #-------------------------------------------------------------------- # Check for the strtod function. This is tricky because in some # versions of Linux strtod mis-parses strings starting with "+". #-------------------------------------------------------------------- -echo "$as_me:$LINENO: checking for strtod" >&5 + + echo "$as_me:$LINENO: checking for strtod" >&5 echo $ECHO_N "checking for strtod... $ECHO_C" >&6 if test "${ac_cv_func_strtod+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define strtod to an innocuous variant, in case declares strtod. + For example, HP-UX 11i declares gettimeofday. */ +#define strtod innocuous_strtod + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char strtod (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef strtod + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -11603,15 +12686,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -11620,42 +12713,40 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_strtod=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_strtod" >&5 echo "${ECHO_T}$ac_cv_func_strtod" >&6 if test $ac_cv_func_strtod = yes; then tcl_ok=1 else tcl_ok=0 fi -if test "$cross_compiling" = yes; then - tcl_ok=0 + if test "$tcl_ok" = 1; then + echo "$as_me:$LINENO: checking proper strtod implementation" >&5 +echo $ECHO_N "checking proper strtod implementation... $ECHO_C" >&6 + if test "${tcl_cv_strtod_unbroken+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test "$cross_compiling" = yes; then + tcl_cv_strtod_unbroken=unknown else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ - -extern double strtod(); -int main() -{ - char *string = " +69"; - char *term; - double value; - value = strtod(string, &term); - if ((value != 69) || (term != (string+4))) { - exit(1); - } - exit(0); +int main() { + extern double strtod(); + char *term, *string = " +69"; + exit(strtod(string,&term) != 69 || term != string+4); } _ACEOF rm -f conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>&5 @@ -11665,26 +12756,42 @@ { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - : + tcl_cv_strtod_unbroken=ok else echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) -tcl_ok=0 -fi -rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext -fi -if test "$tcl_ok" = 0; then - test -n "$verbose" && echo " Adding strtod.o." - LIBOBJS="$LIBOBJS strtod.$ac_objext" - USE_COMPAT=1 -fi +tcl_cv_strtod_unbroken=broken +fi +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +fi +fi + + echo "$as_me:$LINENO: result: $tcl_cv_strtod_unbroken" >&5 +echo "${ECHO_T}$tcl_cv_strtod_unbroken" >&6 + if test "$tcl_cv_strtod_unbroken" = "ok"; then + tcl_ok=1 + else + tcl_ok=0 + fi + fi + if test "$tcl_ok" = 0; then + case $LIBOBJS in + "strtod.$ac_objext" | \ + *" strtod.$ac_objext" | \ + "strtod.$ac_objext "* | \ + *" strtod.$ac_objext "* ) ;; + *) LIBOBJS="$LIBOBJS strtod.$ac_objext" ;; +esac + + USE_COMPAT=1 + fi #-------------------------------------------------------------------- # Under Solaris 2.4, strtod returns the wrong value for the # terminating character under some conditions. Check for this # and if the problem exists use a substitute procedure @@ -11696,25 +12803,32 @@ echo $ECHO_N "checking for strtod... $ECHO_C" >&6 if test "${ac_cv_func_strtod+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define strtod to an innocuous variant, in case declares strtod. + For example, HP-UX 11i declares gettimeofday. */ +#define strtod innocuous_strtod + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char strtod (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef strtod + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -11741,15 +12855,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -11758,11 +12882,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_strtod=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_strtod" >&5 echo "${ECHO_T}$ac_cv_func_strtod" >&6 if test $ac_cv_func_strtod = yes; then tcl_strtod=1 @@ -11779,11 +12904,10 @@ if test "$cross_compiling" = yes; then tcl_cv_strtod_buggy=0 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -11826,21 +12950,28 @@ sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_strtod_buggy=0 fi -rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi if test "$tcl_cv_strtod_buggy" = 1; then echo "$as_me:$LINENO: result: ok" >&5 echo "${ECHO_T}ok" >&6 else echo "$as_me:$LINENO: result: buggy" >&5 echo "${ECHO_T}buggy" >&6 - LIBOBJS="$LIBOBJS fixstrtod.$ac_objext" + case $LIBOBJS in + "fixstrtod.$ac_objext" | \ + *" fixstrtod.$ac_objext" | \ + "fixstrtod.$ac_objext "* | \ + *" fixstrtod.$ac_objext "* ) ;; + *) LIBOBJS="$LIBOBJS fixstrtod.$ac_objext" ;; +esac + USE_COMPAT=1 cat >>confdefs.h <<\_ACEOF #define strtod fixstrtod _ACEOF @@ -11858,11 +12989,10 @@ echo $ECHO_N "checking for mode_t... $ECHO_C" >&6 if test "${ac_cv_type_mode_t+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -11878,15 +13008,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -11895,11 +13035,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_type_mode_t=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_type_mode_t" >&5 echo "${ECHO_T}$ac_cv_type_mode_t" >&6 if test $ac_cv_type_mode_t = yes; then : @@ -11915,11 +13055,10 @@ echo $ECHO_N "checking for pid_t... $ECHO_C" >&6 if test "${ac_cv_type_pid_t+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -11935,15 +13074,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -11952,11 +13101,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_type_pid_t=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_type_pid_t" >&5 echo "${ECHO_T}$ac_cv_type_pid_t" >&6 if test $ac_cv_type_pid_t = yes; then : @@ -11972,11 +13121,10 @@ echo $ECHO_N "checking for size_t... $ECHO_C" >&6 if test "${ac_cv_type_size_t+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -11992,15 +13140,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -12009,11 +13167,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_type_size_t=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_type_size_t" >&5 echo "${ECHO_T}$ac_cv_type_size_t" >&6 if test $ac_cv_type_size_t = yes; then : @@ -12029,11 +13187,10 @@ echo $ECHO_N "checking for uid_t in sys/types.h... $ECHO_C" >&6 if test "${ac_cv_type_uid_t+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -12069,11 +13226,10 @@ echo $ECHO_N "checking for socklen_t... $ECHO_C" >&6 if test "${ac_cv_type_socklen_t+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -12117,25 +13273,32 @@ echo $ECHO_N "checking for opendir... $ECHO_C" >&6 if test "${ac_cv_func_opendir+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define opendir to an innocuous variant, in case declares opendir. + For example, HP-UX 11i declares gettimeofday. */ +#define opendir innocuous_opendir + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char opendir (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef opendir + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -12162,15 +13325,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -12179,11 +13352,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_opendir=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_opendir" >&5 echo "${ECHO_T}$ac_cv_func_opendir" >&6 if test $ac_cv_func_opendir = yes; then : @@ -12208,11 +13382,10 @@ echo $ECHO_N "checking union wait... $ECHO_C" >&6 if test "${tcl_cv_union_wait+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -12230,15 +13403,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -12247,11 +13430,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_union_wait=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_union_wait" >&5 echo "${ECHO_T}$tcl_cv_union_wait" >&6 if test $tcl_cv_union_wait = no; then @@ -12272,25 +13456,32 @@ echo $ECHO_N "checking for strncasecmp... $ECHO_C" >&6 if test "${ac_cv_func_strncasecmp+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define strncasecmp to an innocuous variant, in case declares strncasecmp. + For example, HP-UX 11i declares gettimeofday. */ +#define strncasecmp innocuous_strncasecmp + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char strncasecmp (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef strncasecmp + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -12317,15 +13508,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -12334,11 +13535,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_strncasecmp=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_strncasecmp" >&5 echo "${ECHO_T}$ac_cv_func_strncasecmp" >&6 if test $ac_cv_func_strncasecmp = yes; then tcl_ok=1 @@ -12353,11 +13555,10 @@ echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lsocket $LIBS" cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -12377,15 +13578,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -12394,11 +13605,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_socket_strncasecmp=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_socket_strncasecmp" >&5 echo "${ECHO_T}$ac_cv_lib_socket_strncasecmp" >&6 if test $ac_cv_lib_socket_strncasecmp = yes; then @@ -12415,11 +13627,10 @@ echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-linet $LIBS" cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -12439,15 +13650,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -12456,11 +13677,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_inet_strncasecmp=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_inet_strncasecmp" >&5 echo "${ECHO_T}$ac_cv_lib_inet_strncasecmp" >&6 if test $ac_cv_lib_inet_strncasecmp = yes; then @@ -12469,11 +13691,18 @@ tcl_ok=0 fi fi if test "$tcl_ok" = 0; then - LIBOBJS="$LIBOBJS strncasecmp.$ac_objext" + case $LIBOBJS in + "strncasecmp.$ac_objext" | \ + *" strncasecmp.$ac_objext" | \ + "strncasecmp.$ac_objext "* | \ + *" strncasecmp.$ac_objext "* ) ;; + *) LIBOBJS="$LIBOBJS strncasecmp.$ac_objext" ;; +esac + USE_COMPAT=1 fi #-------------------------------------------------------------------- # The code below deals with several issues related to gettimeofday: @@ -12490,25 +13719,32 @@ echo $ECHO_N "checking for BSDgettimeofday... $ECHO_C" >&6 if test "${ac_cv_func_BSDgettimeofday+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define BSDgettimeofday to an innocuous variant, in case declares BSDgettimeofday. + For example, HP-UX 11i declares gettimeofday. */ +#define BSDgettimeofday innocuous_BSDgettimeofday + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char BSDgettimeofday (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef BSDgettimeofday + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -12535,15 +13771,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -12552,11 +13798,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_BSDgettimeofday=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_BSDgettimeofday" >&5 echo "${ECHO_T}$ac_cv_func_BSDgettimeofday" >&6 if test $ac_cv_func_BSDgettimeofday = yes; then @@ -12570,25 +13817,32 @@ echo $ECHO_N "checking for gettimeofday... $ECHO_C" >&6 if test "${ac_cv_func_gettimeofday+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define gettimeofday to an innocuous variant, in case declares gettimeofday. + For example, HP-UX 11i declares gettimeofday. */ +#define gettimeofday innocuous_gettimeofday + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char gettimeofday (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef gettimeofday + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -12615,15 +13869,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -12632,11 +13896,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_gettimeofday=no fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_gettimeofday" >&5 echo "${ECHO_T}$ac_cv_func_gettimeofday" >&6 if test $ac_cv_func_gettimeofday = yes; then : @@ -12655,11 +13920,10 @@ echo $ECHO_N "checking for gettimeofday declaration... $ECHO_C" >&6 if test "${tcl_cv_grep_gettimeofday+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -12697,11 +13961,10 @@ echo $ECHO_N "checking whether char is unsigned... $ECHO_C" >&6 if test "${ac_cv_c_char_unsigned+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -12716,15 +13979,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -12733,11 +14006,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_c_char_unsigned=yes fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_c_char_unsigned" >&5 echo "${ECHO_T}$ac_cv_c_char_unsigned" >&6 if test $ac_cv_c_char_unsigned = yes && test "$GCC" != yes; then cat >>confdefs.h <<\_ACEOF @@ -12750,11 +14023,10 @@ echo $ECHO_N "checking signed char declarations... $ECHO_C" >&6 if test "${tcl_cv_char_signed+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -12770,15 +14042,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -12787,11 +14069,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_char_signed=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_char_signed" >&5 echo "${ECHO_T}$tcl_cv_char_signed" >&6 if test $tcl_cv_char_signed = yes; then @@ -12813,11 +14095,10 @@ else if test "$cross_compiling" = yes; then tcl_cv_putenv_copy=no else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -12859,11 +14140,11 @@ sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_putenv_copy=yes fi -rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi echo "$as_me:$LINENO: result: $tcl_cv_putenv_copy" >&5 @@ -12903,11 +14184,10 @@ else # Is the header compilable? echo "$as_me:$LINENO: checking langinfo.h usability" >&5 echo $ECHO_N "checking langinfo.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -12914,15 +14194,25 @@ $ac_includes_default #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -12931,19 +14221,18 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking langinfo.h presence" >&5 echo $ECHO_N "checking langinfo.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -12957,10 +14246,11 @@ cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes @@ -12976,37 +14266,36 @@ rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? -case $ac_header_compiler:$ac_header_preproc in - yes:no ) +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) { echo "$as_me:$LINENO: WARNING: langinfo.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: langinfo.h: accepted by the compiler, rejected by the preprocessor!" >&2;} - { echo "$as_me:$LINENO: WARNING: langinfo.h: proceeding with the preprocessor's result" >&5 -echo "$as_me: WARNING: langinfo.h: proceeding with the preprocessor's result" >&2;} - ( - cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## -_ASBOX - ) | - sed "s/^/$as_me: WARNING: /" >&2 + { echo "$as_me:$LINENO: WARNING: langinfo.h: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: langinfo.h: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes ;; - no:yes ) + no:yes:* ) { echo "$as_me:$LINENO: WARNING: langinfo.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: langinfo.h: present but cannot be compiled" >&2;} - { echo "$as_me:$LINENO: WARNING: langinfo.h: check for missing prerequisite headers?" >&5 -echo "$as_me: WARNING: langinfo.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: langinfo.h: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: langinfo.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: langinfo.h: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: langinfo.h: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: langinfo.h: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: langinfo.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: langinfo.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: langinfo.h: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: langinfo.h: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: langinfo.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac @@ -13032,11 +14321,10 @@ fi echo "$as_me:$LINENO: checking whether to use nl_langinfo" >&5 echo $ECHO_N "checking whether to use nl_langinfo... $ECHO_C" >&6 if test "$langinfo_ok" = "yes"; then cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -13049,15 +14337,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -13066,11 +14364,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 langinfo_ok=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext if test "$langinfo_ok" = "no"; then langinfo_ok="no (could not compile with nl_langinfo)"; fi if test "$langinfo_ok" = "yes"; then @@ -13096,25 +14394,139 @@ echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 if eval "test \"\${$as_ac_var+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $ac_func (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $ac_func + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char $ac_func (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_$ac_func) || defined (__stub___$ac_func) +choke me +#else +char (*f) () = $ac_func; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != $ac_func; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + eval "$as_ac_var=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +eval "$as_ac_var=no" +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 +if test `eval echo '${'$as_ac_var'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 +_ACEOF + +fi +done + + +#-------------------------------------------------------------------- +# Check for support of getattrlist function (Darwin, HFS+) +#-------------------------------------------------------------------- + + +for ac_func in getattrlist +do +as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` +echo "$as_me:$LINENO: checking for $ac_func" >&5 +echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 +if eval "test \"\${$as_ac_var+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ + #ifdef __STDC__ # include #else # include #endif + +#undef $ac_func + /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif @@ -13141,15 +14553,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 + (eval $ac_link) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -13158,100 +14580,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext -fi -echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 -echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 -if test `eval echo '${'$as_ac_var'}'` = yes; then - cat >>confdefs.h <<_ACEOF -#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 -_ACEOF - -fi -done - - -#-------------------------------------------------------------------- -# Check for support of getattrlist function (Darwin, HFS+) -#-------------------------------------------------------------------- - - -for ac_func in getattrlist -do -as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` -echo "$as_me:$LINENO: checking for $ac_func" >&5 -echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 -if eval "test \"\${$as_ac_var+set}\" = set"; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -/* System header to define __stub macros and hopefully few prototypes, - which can conflict with char $ac_func (); below. - Prefer to if __STDC__ is defined, since - exists even on freestanding compilers. */ -#ifdef __STDC__ -# include -#else -# include -#endif -/* Override any gcc2 internal prototype to avoid an error. */ -#ifdef __cplusplus -extern "C" -{ -#endif -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char $ac_func (); -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined (__stub_$ac_func) || defined (__stub___$ac_func) -choke me -#else -char (*f) () = $ac_func; -#endif -#ifdef __cplusplus -} -#endif - -int -main () -{ -return f != $ac_func; - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -s conftest$ac_exeext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - eval "$as_ac_var=yes" -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -eval "$as_ac_var=no" -fi -rm -f conftest.$ac_objext conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 if test `eval echo '${'$as_ac_var'}'` = yes; then cat >>confdefs.h <<_ACEOF @@ -13285,11 +14619,10 @@ else # Is the header compilable? echo "$as_me:$LINENO: checking $ac_header usability" >&5 echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -13296,15 +14629,25 @@ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -13313,19 +14656,18 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking $ac_header presence" >&5 echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -13339,10 +14681,11 @@ cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes @@ -13358,37 +14701,36 @@ rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? -case $ac_header_compiler:$ac_header_preproc in - yes:no ) +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} - { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 -echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} - ( - cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## -_ASBOX - ) | - sed "s/^/$as_me: WARNING: /" >&2 + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes ;; - no:yes ) + no:yes:* ) { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} - { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 -echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac @@ -13395,11 +14737,11 @@ echo "$as_me:$LINENO: checking for $ac_header" >&5 echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 if eval "test \"\${$as_ac_Header+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else - eval "$as_ac_Header=$ac_header_preproc" + eval "$as_ac_Header=\$ac_header_preproc" fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 fi @@ -13427,11 +14769,10 @@ else # Is the header compilable? echo "$as_me:$LINENO: checking $ac_header usability" >&5 echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -13438,15 +14779,25 @@ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -13455,19 +14806,18 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking $ac_header presence" >&5 echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -13481,10 +14831,11 @@ cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes @@ -13500,37 +14851,36 @@ rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? -case $ac_header_compiler:$ac_header_preproc in - yes:no ) +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} - { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 -echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} - ( - cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## -_ASBOX - ) | - sed "s/^/$as_me: WARNING: /" >&2 + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes ;; - no:yes ) + no:yes:* ) { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} - { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 -echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac @@ -13537,11 +14887,11 @@ echo "$as_me:$LINENO: checking for $ac_header" >&5 echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 if eval "test \"\${$as_ac_Header+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else - eval "$as_ac_Header=$ac_header_preproc" + eval "$as_ac_Header=\$ac_header_preproc" fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 fi @@ -13611,10 +14961,27 @@ echo "$as_me:$LINENO: result: O_NONBLOCK" >&5 echo "${ECHO_T}O_NONBLOCK" >&6 ;; esac + +#------------------------------------------------------------------------ + +# Check whether --enable-dll-unloading or --disable-dll-unloading was given. +if test "${enable_dll_unloading+set}" = set; then + enableval="$enable_dll_unloading" + tcl_ok=$enableval +else + tcl_ok=yes +fi; +if test $tcl_ok = yes; then + +cat >>confdefs.h <<\_ACEOF +#define TCL_UNLOAD_DLLS 1 +_ACEOF + +fi #-------------------------------------------------------------------- # The statements below define a collection of symbols related to # building libtcl as a shared library instead of a static library. #-------------------------------------------------------------------- @@ -13621,10 +14988,26 @@ TCL_UNSHARED_LIB_SUFFIX=${UNSHARED_LIB_SUFFIX} TCL_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX} eval "TCL_LIB_FILE=libtcl${LIB_SUFFIX}" +# tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed +# since on some platforms TCL_LIB_FILE contains shell escapes. +# (See also: TCL_TRIM_DOTS). + +eval "TCL_LIB_FILE=${TCL_LIB_FILE}" + +TCL_LIBRARY='$(prefix)/lib/tcl$(VERSION)' +PRIVATE_INCLUDE_DIR='$(includedir)' +HTML_DIR='$(DISTDIR)/html' + +# Note: in the following variable, it's important to use the absolute +# path name of the Tcl directory rather than "..": this is because +# AIX remembers this path and will attempt to use it at run-time to look +# up the Tcl library. + +if test "`uname -s`" = "Darwin" ; then echo "$as_me:$LINENO: checking how to package libraries" >&5 echo $ECHO_N "checking how to package libraries... $ECHO_C" >&6 # Check whether --enable-framework or --disable-framework was given. if test "${enable_framework+set}" = set; then @@ -13648,59 +15031,83 @@ if test "${SHARED_BUILD}" = "0" ; then { echo "$as_me:$LINENO: WARNING: \"Frameworks can only be built if --enable-shared is yes\"" >&5 echo "$as_me: WARNING: \"Frameworks can only be built if --enable-shared is yes\"" >&2;} FRAMEWORK_BUILD=0 fi + if test $tcl_corefoundation = no; then + { echo "$as_me:$LINENO: WARNING: \"Frameworks can only be used when CoreFoundation is available\"" >&5 +echo "$as_me: WARNING: \"Frameworks can only be used when CoreFoundation is available\"" >&2;} + FRAMEWORK_BUILD=0 + fi else echo "$as_me:$LINENO: result: standard shared library" >&5 echo "${ECHO_T}standard shared library" >&6 FRAMEWORK_BUILD=0 fi - -# tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed -# so that the backslashes quoting the DBX braces are dropped. - -# Trick to replace DBGX with TCL_DBGX -DBGX='${TCL_DBGX}' -eval "TCL_LIB_FILE=${TCL_LIB_FILE}" - -# Note: in the following variable, it's important to use the absolute -# path name of the Tcl directory rather than "..": this is because -# AIX remembers this path and will attempt to use it at run-time to look -# up the Tcl library. + TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version ${TCL_VERSION}`echo ${TCL_PATCH_LEVEL} | awk '{match($0, "\\\.[0-9]+"); print substr($0,RSTART,RLENGTH)}'`" + TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -install_name ${DYLIB_INSTALL_DIR}/${TCL_LIB_FILE} -seg1addr 0xa000000' +fi if test "$FRAMEWORK_BUILD" = "1" ; then - TCL_BUILD_LIB_SPEC="-F`pwd` -framework Tcl" - TCL_LIB_SPEC="-framework Tcl" - TCL_LIB_FILE="Tcl" cat >>confdefs.h <<\_ACEOF #define TCL_FRAMEWORK 1 _ACEOF -elif test "$SHARED_BUILD" = "0" || test "$TCL_NEEDS_EXP_FILE" = "0"; then - if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then - TCL_LIB_FLAG="-ltcl${TCL_VERSION}\${TCL_DBGX}" - else - TCL_LIB_FLAG="-ltcl`echo ${TCL_VERSION} | tr -d .`\${TCL_DBGX}" + ac_config_files="$ac_config_files Tcl-Info.plist:../macosx/Tcl-Info.plist.in" + + # Construct a fake local framework structure to make linking with + # '-framework Tcl' and running of tcltest work + ac_config_commands="$ac_config_commands Tcl.framework" + + LD_LIBRARY_PATH_VAR="DYLD_FRAMEWORK_PATH" + if test "${libdir}" = '${exec_prefix}/lib'; then + # override libdir default + libdir="/Library/Frameworks" fi - TCL_BUILD_LIB_SPEC="-L`pwd` ${TCL_LIB_FLAG}" - TCL_LIB_SPEC="-L${libdir} ${TCL_LIB_FLAG}" -else - TCL_BUILD_EXP_FILE="lib.exp" - eval "TCL_EXP_FILE=libtcl${TCL_EXPORT_FILE_SUFFIX}" - - # Replace DBGX with TCL_DBGX - eval "TCL_EXP_FILE=\"${TCL_EXP_FILE}\"" - - if test "$GCC" = "yes" ; then - TCL_BUILD_LIB_SPEC="-Wl,-bI:`pwd`/${TCL_BUILD_EXP_FILE} -L`pwd`" - TCL_LIB_SPEC="-Wl,-bI:${libdir}/${TCL_EXP_FILE} -L`pwd`" - else - TCL_BUILD_LIB_SPEC="-bI:`pwd`/${TCL_BUILD_EXP_FILE}" - TCL_LIB_SPEC="-bI:${libdir}/${TCL_EXP_FILE}" + TCL_LIB_FILE="Tcl" + TCL_LIB_FLAG="-framework Tcl" + TCL_BUILD_LIB_SPEC="-F`pwd` -framework Tcl" + TCL_LIB_SPEC="-F${libdir} -framework Tcl" + libdir="${libdir}/Tcl.framework/Versions/\${VERSION}" + TCL_LIBRARY="${libdir}/Resources/Scripts" + includedir="${libdir}/Headers" + PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders" + HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl" + EXTRA_INSTALL="install-private-headers html-tcl" + EXTRA_BUILD_HTML='@ln -fs contents.htm $(HTML_INSTALL_DIR)/TclTOC.html' + EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources" && mkdir -p "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"' + EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."' + TCL_YEAR="`date +%Y`" + # Don't use AC_DEFINE for the following as the framework version define + # needs to go into the Makefile even when using autoheader, so that we + # can pick up a potential make override of VERSION. Also, don't put this + # into CFLAGS as it should not go into tclConfig.sh + EXTRA_CC_SWITCHES='-DTCL_FRAMEWORK_VERSION=\"$(VERSION)\"' +else + # libdir must be a fully qualified path and not ${exec_prefix}/lib + eval libdir="$libdir" + if test "$SHARED_BUILD" = "0" || test "$TCL_NEEDS_EXP_FILE" = "0"; then + if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then + TCL_LIB_FLAG="-ltcl${TCL_VERSION}" + else + TCL_LIB_FLAG="-ltcl`echo ${TCL_VERSION} | tr -d .`" + fi + TCL_BUILD_LIB_SPEC="-L`pwd` ${TCL_LIB_FLAG}" + TCL_LIB_SPEC="-L${libdir} ${TCL_LIB_FLAG}" + else + TCL_BUILD_EXP_FILE="lib.exp" + eval "TCL_EXP_FILE=libtcl${TCL_EXPORT_FILE_SUFFIX}" + + if test "$GCC" = "yes" ; then + TCL_BUILD_LIB_SPEC="-Wl,-bI:`pwd`/${TCL_BUILD_EXP_FILE} -L`pwd`" + TCL_LIB_SPEC="-Wl,-bI:${libdir}/${TCL_EXP_FILE} -L`pwd`" + else + TCL_BUILD_LIB_SPEC="-bI:`pwd`/${TCL_BUILD_EXP_FILE}" + TCL_LIB_SPEC="-bI:${libdir}/${TCL_EXP_FILE}" + fi fi fi VERSION='${VERSION}' eval "CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}" eval "CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}" @@ -13713,58 +15120,51 @@ # consists of one directory for machine-dependent binaries and # another for platform-independent scripts. #-------------------------------------------------------------------- if test "$FRAMEWORK_BUILD" = "1" ; then - TCL_PACKAGE_PATH="${libdir}/Resources/Scripts" + TCL_PACKAGE_PATH="~/Library/Tcl /Library/Tcl /Network/Library/Tcl /System/Library/Tcl ~/Library/Frameworks /Library/Frameworks /Network/Library/Frameworks /System/Library/Frameworks" + TCL_MODULE_PATH="~/Library/Tcl /Library/Tcl /Network/Library/Tcl /System/Library/Tcl" elif test "$prefix/lib" != "$libdir"; then TCL_PACKAGE_PATH="${libdir} ${prefix}/lib" else TCL_PACKAGE_PATH="${prefix}/lib" fi + +# If a system share directory like /usr/local/share already exists, then add +# it to the package search path. + +if test -d "${prefix}/share" ; then + TCL_PACKAGE_PATH="${TCL_PACKAGE_PATH} ${prefix}/share" +fi #-------------------------------------------------------------------- # The statements below define various symbols relating to Tcl # stub support. #-------------------------------------------------------------------- # Replace ${VERSION} with contents of ${TCL_VERSION} +# double-eval to account for TCL_TRIM_DOTS. +# eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}" -# Replace DBGX with TCL_DBGX eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\"" +eval "TCL_STUB_LIB_DIR=${libdir}" if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then - TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}\${TCL_DBGX}" + TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}" else - TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`\${TCL_DBGX}" + TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`" fi TCL_BUILD_STUB_LIB_SPEC="-L`pwd` ${TCL_STUB_LIB_FLAG}" -TCL_STUB_LIB_SPEC="-L${libdir} ${TCL_STUB_LIB_FLAG}" +TCL_STUB_LIB_SPEC="-L${TCL_STUB_LIB_DIR} ${TCL_STUB_LIB_FLAG}" TCL_BUILD_STUB_LIB_PATH="`pwd`/${TCL_STUB_LIB_FILE}" -TCL_STUB_LIB_PATH="${libdir}/${TCL_STUB_LIB_FILE}" +TCL_STUB_LIB_PATH="${TCL_STUB_LIB_DIR}/${TCL_STUB_LIB_FILE}" # Install time header dir can be set via --includedir eval "TCL_INCLUDE_SPEC=\"-I${includedir}\"" -#------------------------------------------------------------------------ - -# Check whether --enable-dll-unloading or --disable-dll-unloading was given. -if test "${enable_dll_unloading+set}" = set; then - enableval="$enable_dll_unloading" - tcl_ok=$enableval -else - tcl_ok=yes -fi; -if test $tcl_ok = yes; then - -cat >>confdefs.h <<\_ACEOF -#define TCL_UNLOAD_DLLS 1 -_ACEOF - -fi - #------------------------------------------------------------------------ # tclConfig.sh refers to this by a different name #------------------------------------------------------------------------ TCL_SHARED_BUILD=${SHARED_BUILD} @@ -13786,13 +15186,19 @@ -cat >>confdefs.h <<_ACEOF -#define TCL_DBGX ${TCL_DBGX} -_ACEOF + + + + + + + + + @@ -13812,10 +15218,11 @@ ac_config_files="$ac_config_files Makefile dltest/Makefile tclConfig.sh" + cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. # It is not useful on other systems. If it contains results you don't @@ -13840,17 +15247,17 @@ case `(ac_space=' '; set | grep ac_space) 2>&1` in *ac_space=\ *) # `set' does not quote correctly, so add quotes (double-quote # substitution turns \\\\ into \\, and sed turns \\ into \). sed -n \ - "s/'/'\\\\''/g; - s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" + "s/'/'\\\\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; *) # `set' quotes correctly as required by POSIX, so do not add quotes. sed -n \ - "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" + "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" ;; esac; } | sed ' t clear @@ -13876,17 +15283,17 @@ # VPATH may cause trouble with some makes, so we remove $(srcdir), # ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then - ac_vpsub='/^[ ]*VPATH[ ]*=/{ + ac_vpsub='/^[ ]*VPATH[ ]*=/{ s/:*\$(srcdir):*/:/; s/:*\${srcdir}:*/:/; s/:*@srcdir@:*/:/; -s/^\([^=]*=[ ]*\):*/\1/; +s/^\([^=]*=[ ]*\):*/\1/; s/:*$//; -s/^[^=]*=[ ]*$//; +s/^[^=]*=[ ]*$//; }' fi # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. @@ -13896,17 +15303,17 @@ # take arguments), then we branch to the quote section. Otherwise, # look for a macro that doesn't take arguments. cat >confdef2opt.sed <<\_ACEOF t clear : clear -s,^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\),-D\1=\2,g +s,^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\),-D\1=\2,g t quote -s,^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\),-D\1=\2,g +s,^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\),-D\1=\2,g t quote d : quote -s,[ `~#$^&*(){}\\|;'"<>?],\\&,g +s,[ `~#$^&*(){}\\|;'"<>?],\\&,g s,\[,\\&,g s,\],\\&,g s,\$,$$,g p _ACEOF @@ -13919,24 +15326,10 @@ ac_LF_and_DOT=`echo; echo .` DEFS=`sed -n -f confdef2opt.sed confdefs.h | tr "$ac_LF_and_DOT" ' .'` rm -f confdef2opt.sed -ac_libobjs= -ac_ltlibobjs= -for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue - # 1. Remove the extension, and $U if already installed. - ac_i=`echo "$ac_i" | - sed 's/\$U\././;s/\.o$//;s/\.obj$//'` - # 2. Add them. - ac_libobjs="$ac_libobjs $ac_i\$U.$ac_objext" - ac_ltlibobjs="$ac_ltlibobjs $ac_i"'$U.lo' -done -LIBOBJS=$ac_libobjs - -LTLIBOBJS=$ac_ltlibobjs - : ${CONFIG_STATUS=./config.status} ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" @@ -13968,13 +15361,14 @@ # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then set -o posix fi +DUALCASE=1; export DUALCASE # for MKS sh # Support unset when possible. -if (FOO=FOO; unset FOO) >/dev/null 2>&1; then +if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then as_unset=unset else as_unset=false fi @@ -13989,11 +15383,11 @@ for as_var in \ LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ LC_TELEPHONE LC_TIME do - if (set +x; test -n "`(eval $as_var=C; export $as_var) 2>&1`"); then + if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then eval $as_var=C; export $as_var else $as_unset $as_var fi done @@ -14168,20 +15562,21 @@ rm -f conf$$ conf$$.exe conf$$.file if mkdir -p . 2>/dev/null; then as_mkdir_p=: else + test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_executable_p="test -f" # Sed expression to map a string onto a valid CPP name. -as_tr_cpp="sed y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g" +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. -as_tr_sh="sed y%*+%pp%;s%[^_$as_cr_alnum]%_%g" +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" # IFS # We need space, tab and new line, in precisely that order. as_nl=' @@ -14204,11 +15599,11 @@ _ASBOX } >&5 cat >&5 <<_CSEOF This file was extended by tcl $as_me 8.5, which was -generated by GNU Autoconf 2.57. Invocation command line was +generated by GNU Autoconf 2.59. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS @@ -14248,26 +15643,28 @@ -V, --version print version number, then exit -q, --quiet do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] - instantiate the configuration file FILE + instantiate the configuration file FILE Configuration files: $config_files + +Configuration commands: +$config_commands Report bugs to ." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF ac_cs_version="\\ tcl config.status 8.5 -configured by $0, generated by GNU Autoconf 2.57, +configured by $0, generated by GNU Autoconf 2.59, with options \\"`echo "$ac_configure_args" | sed 's/[\\""\`\$]/\\\\&/g'`\\" -Copyright 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001 -Free Software Foundation, Inc. +Copyright (C) 2003 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." srcdir=$srcdir _ACEOF @@ -14352,22 +15749,31 @@ exec $SHELL $0 $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion fi _ACEOF +cat >>$CONFIG_STATUS <<_ACEOF +# +# INIT-COMMANDS section. +# + +VERSION=${TCL_VERSION} +_ACEOF cat >>$CONFIG_STATUS <<\_ACEOF for ac_config_target in $ac_config_targets do case "$ac_config_target" in # Handling of arguments. + "Tcl-Info.plist" ) CONFIG_FILES="$CONFIG_FILES Tcl-Info.plist:../macosx/Tcl-Info.plist.in" ;; "Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile" ;; "dltest/Makefile" ) CONFIG_FILES="$CONFIG_FILES dltest/Makefile" ;; "tclConfig.sh" ) CONFIG_FILES="$CONFIG_FILES tclConfig.sh" ;; + "Tcl.framework" ) CONFIG_COMMANDS="$CONFIG_COMMANDS Tcl.framework" ;; *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5 echo "$as_me: error: invalid argument: $ac_config_target" >&2;} { (exit 1); exit 1; }; };; esac done @@ -14376,10 +15782,11 @@ # then the envvar interface is used. Set only those that are not. # We use the long form for the default assignment because of an extremely # bizarre bug on SunOS 4.1.3. if $ac_need_defaults; then test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files + test "${CONFIG_COMMANDS+set}" = set || CONFIG_COMMANDS=$config_commands fi # Have a temporary directory for convenience. Make it in the build tree # simply because there is no reason to put it here, and in addition, # creating and moving files from /tmp can sometimes cause problems. @@ -14466,10 +15873,11 @@ s,@LIBOBJS@,$LIBOBJS,;t t s,@TCL_LIBS@,$TCL_LIBS,;t t s,@DL_LIBS@,$DL_LIBS,;t t s,@DL_OBJS@,$DL_OBJS,;t t s,@PLAT_OBJS@,$PLAT_OBJS,;t t +s,@PLAT_SRCS@,$PLAT_SRCS,;t t s,@CFLAGS_DEBUG@,$CFLAGS_DEBUG,;t t s,@CFLAGS_OPTIMIZE@,$CFLAGS_OPTIMIZE,;t t s,@CFLAGS_WARNING@,$CFLAGS_WARNING,;t t s,@LDFLAGS_DEBUG@,$LDFLAGS_DEBUG,;t t s,@LDFLAGS_OPTIMIZE@,$LDFLAGS_OPTIMIZE,;t t @@ -14477,11 +15885,10 @@ s,@LD_SEARCH_FLAGS@,$LD_SEARCH_FLAGS,;t t s,@STLIB_LD@,$STLIB_LD,;t t s,@SHLIB_LD@,$SHLIB_LD,;t t s,@TCL_SHLIB_LD_EXTRAS@,$TCL_SHLIB_LD_EXTRAS,;t t s,@TK_SHLIB_LD_EXTRAS@,$TK_SHLIB_LD_EXTRAS,;t t -s,@SHLIB_LD_FLAGS@,$SHLIB_LD_FLAGS,;t t s,@SHLIB_LD_LIBS@,$SHLIB_LD_LIBS,;t t s,@SHLIB_CFLAGS@,$SHLIB_CFLAGS,;t t s,@SHLIB_SUFFIX@,$SHLIB_SUFFIX,;t t s,@MAKE_LIB@,$MAKE_LIB,;t t s,@MAKE_STUB_LIB@,$MAKE_STUB_LIB,;t t @@ -14491,10 +15898,11 @@ s,@LDFLAGS_DEFAULT@,$LDFLAGS_DEFAULT,;t t s,@TCL_VERSION@,$TCL_VERSION,;t t s,@TCL_MAJOR_VERSION@,$TCL_MAJOR_VERSION,;t t s,@TCL_MINOR_VERSION@,$TCL_MINOR_VERSION,;t t s,@TCL_PATCH_LEVEL@,$TCL_PATCH_LEVEL,;t t +s,@TCL_YEAR@,$TCL_YEAR,;t t s,@TCL_LIB_FILE@,$TCL_LIB_FILE,;t t s,@TCL_LIB_FLAG@,$TCL_LIB_FLAG,;t t s,@TCL_LIB_SPEC@,$TCL_LIB_SPEC,;t t s,@TCL_STUB_LIB_FILE@,$TCL_STUB_LIB_FILE,;t t s,@TCL_STUB_LIB_FLAG@,$TCL_STUB_LIB_FLAG,;t t @@ -14502,11 +15910,10 @@ s,@TCL_STUB_LIB_PATH@,$TCL_STUB_LIB_PATH,;t t s,@TCL_INCLUDE_SPEC@,$TCL_INCLUDE_SPEC,;t t s,@TCL_BUILD_STUB_LIB_SPEC@,$TCL_BUILD_STUB_LIB_SPEC,;t t s,@TCL_BUILD_STUB_LIB_PATH@,$TCL_BUILD_STUB_LIB_PATH,;t t s,@TCL_SRC_DIR@,$TCL_SRC_DIR,;t t -s,@TCL_DBGX@,$TCL_DBGX,;t t s,@CFG_TCL_SHARED_LIB_SUFFIX@,$CFG_TCL_SHARED_LIB_SUFFIX,;t t s,@CFG_TCL_UNSHARED_LIB_SUFFIX@,$CFG_TCL_UNSHARED_LIB_SUFFIX,;t t s,@CFG_TCL_EXPORT_FILE_SUFFIX@,$CFG_TCL_EXPORT_FILE_SUFFIX,;t t s,@TCL_SHARED_BUILD@,$TCL_SHARED_BUILD,;t t s,@LD_LIBRARY_PATH_VAR@,$LD_LIBRARY_PATH_VAR,;t t @@ -14518,11 +15925,18 @@ s,@TCL_SHARED_LIB_SUFFIX@,$TCL_SHARED_LIB_SUFFIX,;t t s,@TCL_UNSHARED_LIB_SUFFIX@,$TCL_UNSHARED_LIB_SUFFIX,;t t s,@TCL_HAS_LONGLONG@,$TCL_HAS_LONGLONG,;t t s,@BUILD_DLTEST@,$BUILD_DLTEST,;t t s,@TCL_PACKAGE_PATH@,$TCL_PACKAGE_PATH,;t t -s,@LTLIBOBJS@,$LTLIBOBJS,;t t +s,@TCL_MODULE_PATH@,$TCL_MODULE_PATH,;t t +s,@TCL_LIBRARY@,$TCL_LIBRARY,;t t +s,@PRIVATE_INCLUDE_DIR@,$PRIVATE_INCLUDE_DIR,;t t +s,@HTML_DIR@,$HTML_DIR,;t t +s,@EXTRA_CC_SWITCHES@,$EXTRA_CC_SWITCHES,;t t +s,@EXTRA_INSTALL@,$EXTRA_INSTALL,;t t +s,@EXTRA_INSTALL_BINARIES@,$EXTRA_INSTALL_BINARIES,;t t +s,@EXTRA_BUILD_HTML@,$EXTRA_BUILD_HTML,;t t CEOF _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF @@ -14548,13 +15962,13 @@ # is no need to browse any of the substitutions). # These are the two extra sed commands mentioned above. (echo ':t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b' && cat $tmp/subs.frag) >$tmp/subs-$ac_sed_frag.sed if test -z "$ac_sed_cmds"; then - ac_sed_cmds="sed -f $tmp/subs-$ac_sed_frag.sed" + ac_sed_cmds="sed -f $tmp/subs-$ac_sed_frag.sed" else - ac_sed_cmds="$ac_sed_cmds | sed -f $tmp/subs-$ac_sed_frag.sed" + ac_sed_cmds="$ac_sed_cmds | sed -f $tmp/subs-$ac_sed_frag.sed" fi ac_sed_frag=`expr $ac_sed_frag + 1` ac_beg=$ac_end ac_end=`expr $ac_end + $ac_max_sed_lines` fi @@ -14568,25 +15982,25 @@ cat >>$CONFIG_STATUS <<\_ACEOF for ac_file in : $CONFIG_FILES; do test "x$ac_file" = x: && continue # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". case $ac_file in - | *:- | *:-:* ) # input from stdin - cat >$tmp/stdin - ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` - ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; + cat >$tmp/stdin + ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` + ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; *:* ) ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` - ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; + ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; * ) ac_file_in=$ac_file.in ;; esac # Compute @srcdir@, @top_srcdir@, and @INSTALL@ for subdirectories. ac_dir=`(dirname "$ac_file") 2>/dev/null || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$ac_file" : 'X\(//\)[^/]' \| \ - X"$ac_file" : 'X\(//\)$' \| \ - X"$ac_file" : 'X\(/\)' \| \ - . : '\(.\)' 2>/dev/null || + X"$ac_file" : 'X\(//\)[^/]' \| \ + X"$ac_file" : 'X\(//\)$' \| \ + X"$ac_file" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || echo X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } /^X\(\/\/\)[^/].*/{ s//\1/; q; } /^X\(\/\/\)$/{ s//\1/; q; } /^X\(\/\).*/{ s//\1/; q; } @@ -14598,14 +16012,197 @@ as_dirs= while test ! -d "$as_dir"; do as_dirs="$as_dir $as_dirs" as_dir=`(dirname "$as_dir") 2>/dev/null || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_dir" : 'X\(//\)[^/]' \| \ - X"$as_dir" : 'X\(//\)$' \| \ - X"$as_dir" : 'X\(/\)' \| \ - . : '\(.\)' 2>/dev/null || + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || +echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } + /^X\(\/\/\)[^/].*/{ s//\1/; q; } + /^X\(\/\/\)$/{ s//\1/; q; } + /^X\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + done + test ! -n "$as_dirs" || mkdir $as_dirs + fi || { { echo "$as_me:$LINENO: error: cannot create directory \"$ac_dir\"" >&5 +echo "$as_me: error: cannot create directory \"$ac_dir\"" >&2;} + { (exit 1); exit 1; }; }; } + + ac_builddir=. + +if test "$ac_dir" != .; then + ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` + # A "../" for each directory in $ac_dir_suffix. + ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'` +else + ac_dir_suffix= ac_top_builddir= +fi + +case $srcdir in + .) # No --srcdir option. We are building in place. + ac_srcdir=. + if test -z "$ac_top_builddir"; then + ac_top_srcdir=. + else + ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'` + fi ;; + [\\/]* | ?:[\\/]* ) # Absolute path. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir ;; + *) # Relative path. + ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_builddir$srcdir ;; +esac + +# Do not use `cd foo && pwd` to compute absolute paths, because +# the directories may not exist. +case `pwd` in +.) ac_abs_builddir="$ac_dir";; +*) + case "$ac_dir" in + .) ac_abs_builddir=`pwd`;; + [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; + *) ac_abs_builddir=`pwd`/"$ac_dir";; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_builddir=${ac_top_builddir}.;; +*) + case ${ac_top_builddir}. in + .) ac_abs_top_builddir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; + *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_srcdir=$ac_srcdir;; +*) + case $ac_srcdir in + .) ac_abs_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; + *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_srcdir=$ac_top_srcdir;; +*) + case $ac_top_srcdir in + .) ac_abs_top_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; + *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; + esac;; +esac + + + + if test x"$ac_file" != x-; then + { echo "$as_me:$LINENO: creating $ac_file" >&5 +echo "$as_me: creating $ac_file" >&6;} + rm -f "$ac_file" + fi + # Let's still pretend it is `configure' which instantiates (i.e., don't + # use $as_me), people would be surprised to read: + # /* config.h. Generated by config.status. */ + if test x"$ac_file" = x-; then + configure_input= + else + configure_input="$ac_file. " + fi + configure_input=$configure_input"Generated from `echo $ac_file_in | + sed 's,.*/,,'` by configure." + + # First look for the input files in the build tree, otherwise in the + # src tree. + ac_file_inputs=`IFS=: + for f in $ac_file_in; do + case $f in + -) echo $tmp/stdin ;; + [\\/$]*) + # Absolute (can't be DOS-style, as IFS=:) + test -f "$f" || { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 +echo "$as_me: error: cannot find input file: $f" >&2;} + { (exit 1); exit 1; }; } + echo "$f";; + *) # Relative + if test -f "$f"; then + # Build tree + echo "$f" + elif test -f "$srcdir/$f"; then + # Source tree + echo "$srcdir/$f" + else + # /dev/null tree + { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 +echo "$as_me: error: cannot find input file: $f" >&2;} + { (exit 1); exit 1; }; } + fi;; + esac + done` || { (exit 1); exit 1; } +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF + sed "$ac_vpsub +$extrasub +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF +:t +/@[a-zA-Z_][a-zA-Z_0-9]*@/!b +s,@configure_input@,$configure_input,;t t +s,@srcdir@,$ac_srcdir,;t t +s,@abs_srcdir@,$ac_abs_srcdir,;t t +s,@top_srcdir@,$ac_top_srcdir,;t t +s,@abs_top_srcdir@,$ac_abs_top_srcdir,;t t +s,@builddir@,$ac_builddir,;t t +s,@abs_builddir@,$ac_abs_builddir,;t t +s,@top_builddir@,$ac_top_builddir,;t t +s,@abs_top_builddir@,$ac_abs_top_builddir,;t t +" $ac_file_inputs | (eval "$ac_sed_cmds") >$tmp/out + rm -f $tmp/stdin + if test x"$ac_file" != x-; then + mv $tmp/out $ac_file + else + cat $tmp/out + rm -f $tmp/out + fi + +done +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF + +# +# CONFIG_COMMANDS section. +# +for ac_file in : $CONFIG_COMMANDS; do test "x$ac_file" = x: && continue + ac_dest=`echo "$ac_file" | sed 's,:.*,,'` + ac_source=`echo "$ac_file" | sed 's,[^:]*:,,'` + ac_dir=`(dirname "$ac_dest") 2>/dev/null || +$as_expr X"$ac_dest" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$ac_dest" : 'X\(//\)[^/]' \| \ + X"$ac_dest" : 'X\(//\)$' \| \ + X"$ac_dest" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || +echo X"$ac_dest" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } + /^X\(\/\/\)[^/].*/{ s//\1/; q; } + /^X\(\/\/\)$/{ s//\1/; q; } + /^X\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + { if $as_mkdir_p; then + mkdir -p "$ac_dir" + else + as_dir="$ac_dir" + as_dirs= + while test ! -d "$as_dir"; do + as_dirs="$as_dir $as_dirs" + as_dir=`(dirname "$as_dir") 2>/dev/null || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } /^X\(\/\/\)[^/].*/{ s//\1/; q; } /^X\(\/\/\)$/{ s//\1/; q; } /^X\(\/\).*/{ s//\1/; q; } @@ -14639,88 +16236,62 @@ ac_top_srcdir=$srcdir ;; *) # Relative path. ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_builddir$srcdir ;; esac -# Don't blindly perform a `cd "$ac_dir"/$ac_foo && pwd` since $ac_foo can be -# absolute. -ac_abs_builddir=`cd "$ac_dir" && cd $ac_builddir && pwd` -ac_abs_top_builddir=`cd "$ac_dir" && cd ${ac_top_builddir}. && pwd` -ac_abs_srcdir=`cd "$ac_dir" && cd $ac_srcdir && pwd` -ac_abs_top_srcdir=`cd "$ac_dir" && cd $ac_top_srcdir && pwd` - - - - if test x"$ac_file" != x-; then - { echo "$as_me:$LINENO: creating $ac_file" >&5 -echo "$as_me: creating $ac_file" >&6;} - rm -f "$ac_file" - fi - # Let's still pretend it is `configure' which instantiates (i.e., don't - # use $as_me), people would be surprised to read: - # /* config.h. Generated by config.status. */ - if test x"$ac_file" = x-; then - configure_input= - else - configure_input="$ac_file. " - fi - configure_input=$configure_input"Generated from `echo $ac_file_in | - sed 's,.*/,,'` by configure." - - # First look for the input files in the build tree, otherwise in the - # src tree. - ac_file_inputs=`IFS=: - for f in $ac_file_in; do - case $f in - -) echo $tmp/stdin ;; - [\\/$]*) - # Absolute (can't be DOS-style, as IFS=:) - test -f "$f" || { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 -echo "$as_me: error: cannot find input file: $f" >&2;} - { (exit 1); exit 1; }; } - echo $f;; - *) # Relative - if test -f "$f"; then - # Build tree - echo $f - elif test -f "$srcdir/$f"; then - # Source tree - echo $srcdir/$f - else - # /dev/null tree - { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 -echo "$as_me: error: cannot find input file: $f" >&2;} - { (exit 1); exit 1; }; } - fi;; - esac - done` || { (exit 1); exit 1; } -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF - sed "$ac_vpsub -$extrasub -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF -:t -/@[a-zA-Z_][a-zA-Z_0-9]*@/!b -s,@configure_input@,$configure_input,;t t -s,@srcdir@,$ac_srcdir,;t t -s,@abs_srcdir@,$ac_abs_srcdir,;t t -s,@top_srcdir@,$ac_top_srcdir,;t t -s,@abs_top_srcdir@,$ac_abs_top_srcdir,;t t -s,@builddir@,$ac_builddir,;t t -s,@abs_builddir@,$ac_abs_builddir,;t t -s,@top_builddir@,$ac_top_builddir,;t t -s,@abs_top_builddir@,$ac_abs_top_builddir,;t t -" $ac_file_inputs | (eval "$ac_sed_cmds") >$tmp/out - rm -f $tmp/stdin - if test x"$ac_file" != x-; then - mv $tmp/out $ac_file - else - cat $tmp/out - rm -f $tmp/out - fi - + +# Do not use `cd foo && pwd` to compute absolute paths, because +# the directories may not exist. +case `pwd` in +.) ac_abs_builddir="$ac_dir";; +*) + case "$ac_dir" in + .) ac_abs_builddir=`pwd`;; + [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; + *) ac_abs_builddir=`pwd`/"$ac_dir";; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_builddir=${ac_top_builddir}.;; +*) + case ${ac_top_builddir}. in + .) ac_abs_top_builddir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; + *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_srcdir=$ac_srcdir;; +*) + case $ac_srcdir in + .) ac_abs_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; + *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_srcdir=$ac_top_srcdir;; +*) + case $ac_top_srcdir in + .) ac_abs_top_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; + *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; + esac;; +esac + + + { echo "$as_me:$LINENO: executing $ac_dest commands" >&5 +echo "$as_me: executing $ac_dest commands" >&6;} + case $ac_dest in + Tcl.framework ) n=Tcl && + f=$n.framework && v=Versions/$VERSION && + rm -rf $f && mkdir -p $f/$v/Resources && + ln -s $v/$n $v/Resources $f && ln -s ../../../$n $f/$v && + ln -s ../../../../$n-Info.plist $f/$v/Resources/Info.plist && + unset n f v + ;; + esac done _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF Index: unix/configure.in ================================================================== --- unix/configure.in +++ unix/configure.in @@ -1,21 +1,25 @@ #! /bin/bash -norc dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run during Tcl installation dnl to configure the system for the local environment. # -# RCS: @(#) $Id: configure.in,v 1.123 2004/11/26 11:18:01 dkf Exp $ +# RCS: @(#) $Id: configure.in,v 1.123.2.8 2005/08/25 15:47:07 dgp Exp $ AC_INIT([tcl],[8.5]) -AC_PREREQ(2.57) +AC_PREREQ(2.59) + dnl AC_CONFIG_HEADERS([tclConfig.h]) -dnl AC_CONFIG_COMMANDS_PRE([DEFS=-DHAVE_TCL_CONFIG_H]) +dnl AC_CONFIG_COMMANDS_PRE([DEFS="-DHAVE_TCL_CONFIG_H -imacros tclConfig.h"]) +dnl AH_TOP([#ifndef _TCLCONFIG +dnl #define _TCLCONFIG]) +dnl AH_BOTTOM([#endif /* _TCLCONFIG */]) TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 -TCL_PATCH_LEVEL="a2" +TCL_PATCH_LEVEL="a4" VERSION=${TCL_VERSION} #------------------------------------------------------------------------ # Handle the --prefix=... option #------------------------------------------------------------------------ @@ -24,12 +28,10 @@ prefix=/usr/local fi if test "${exec_prefix}" = "NONE"; then exec_prefix=$prefix fi -# libdir must be a fully qualified path and (not ${exec_prefix}/lib) -eval libdir="$libdir" TCL_SRC_DIR=`cd $srcdir/..; pwd` #------------------------------------------------------------------------ # Compress and/or soft link the manpages? #------------------------------------------------------------------------ @@ -104,13 +106,11 @@ # after SC_ENABLE_SHARED checks the configure switches. #-------------------------------------------------------------------- SC_CONFIG_CFLAGS -SC_ENABLE_SYMBOLS - -TCL_DBGX=${DBGX} +SC_ENABLE_SYMBOLS(bccdebug) #-------------------------------------------------------------------- # Detect what compiler flags to set for 64-bit support. #-------------------------------------------------------------------- @@ -426,10 +426,20 @@ # On these systems (mostly older ones), use the old BSD-style # FIONBIO approach instead. #-------------------------------------------------------------------- SC_BLOCKING_STYLE + +#------------------------------------------------------------------------ + +AC_ARG_ENABLE(dll-unloading, + AC_HELP_STRING([--enable-dll-unloading], + [turn on the 'unload' command (default: on)]), + [tcl_ok=$enableval], [tcl_ok=yes]) +if test $tcl_ok = yes; then + AC_DEFINE(TCL_UNLOAD_DLLS, 1, [Do we allow unloading of shared libraries?]) +fi #-------------------------------------------------------------------- # The statements below define a collection of symbols related to # building libtcl as a shared library instead of a static library. #-------------------------------------------------------------------- @@ -436,50 +446,89 @@ TCL_UNSHARED_LIB_SUFFIX=${UNSHARED_LIB_SUFFIX} TCL_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX} eval "TCL_LIB_FILE=libtcl${LIB_SUFFIX}" -SC_ENABLE_FRAMEWORK - # tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed -# so that the backslashes quoting the DBX braces are dropped. +# since on some platforms TCL_LIB_FILE contains shell escapes. +# (See also: TCL_TRIM_DOTS). -# Trick to replace DBGX with TCL_DBGX -DBGX='${TCL_DBGX}' eval "TCL_LIB_FILE=${TCL_LIB_FILE}" + +TCL_LIBRARY='$(prefix)/lib/tcl$(VERSION)' +PRIVATE_INCLUDE_DIR='$(includedir)' +HTML_DIR='$(DISTDIR)/html' # Note: in the following variable, it's important to use the absolute # path name of the Tcl directory rather than "..": this is because # AIX remembers this path and will attempt to use it at run-time to look # up the Tcl library. + +if test "`uname -s`" = "Darwin" ; then + SC_ENABLE_FRAMEWORK + TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version ${TCL_VERSION}`echo ${TCL_PATCH_LEVEL} | awk ['{match($0, "\\\.[0-9]+"); print substr($0,RSTART,RLENGTH)}']`" + TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -install_name ${DYLIB_INSTALL_DIR}/${TCL_LIB_FILE} -seg1addr 0xa000000' +fi if test "$FRAMEWORK_BUILD" = "1" ; then - TCL_BUILD_LIB_SPEC="-F`pwd` -framework Tcl" - TCL_LIB_SPEC="-framework Tcl" - TCL_LIB_FILE="Tcl" AC_DEFINE(TCL_FRAMEWORK, 1, [Is Tcl built as a framework?]) -elif test "$SHARED_BUILD" = "0" || test "$TCL_NEEDS_EXP_FILE" = "0"; then - if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then - TCL_LIB_FLAG="-ltcl${TCL_VERSION}\${TCL_DBGX}" - else - TCL_LIB_FLAG="-ltcl`echo ${TCL_VERSION} | tr -d .`\${TCL_DBGX}" + AC_CONFIG_FILES([Tcl-Info.plist:../macosx/Tcl-Info.plist.in]) + # Construct a fake local framework structure to make linking with + # '-framework Tcl' and running of tcltest work + AC_CONFIG_COMMANDS([Tcl.framework], [n=Tcl && + f=$n.framework && v=Versions/$VERSION && + rm -rf $f && mkdir -p $f/$v/Resources && + ln -s $v/$n $v/Resources $f && ln -s ../../../$n $f/$v && + ln -s ../../../../$n-Info.plist $f/$v/Resources/Info.plist && + unset n f v + ], VERSION=${TCL_VERSION}) + LD_LIBRARY_PATH_VAR="DYLD_FRAMEWORK_PATH" + if test "${libdir}" = '${exec_prefix}/lib'; then + # override libdir default + libdir="/Library/Frameworks" fi - TCL_BUILD_LIB_SPEC="-L`pwd` ${TCL_LIB_FLAG}" - TCL_LIB_SPEC="-L${libdir} ${TCL_LIB_FLAG}" -else - TCL_BUILD_EXP_FILE="lib.exp" - eval "TCL_EXP_FILE=libtcl${TCL_EXPORT_FILE_SUFFIX}" - - # Replace DBGX with TCL_DBGX - eval "TCL_EXP_FILE=\"${TCL_EXP_FILE}\"" - - if test "$GCC" = "yes" ; then - TCL_BUILD_LIB_SPEC="-Wl,-bI:`pwd`/${TCL_BUILD_EXP_FILE} -L`pwd`" - TCL_LIB_SPEC="-Wl,-bI:${libdir}/${TCL_EXP_FILE} -L`pwd`" - else - TCL_BUILD_LIB_SPEC="-bI:`pwd`/${TCL_BUILD_EXP_FILE}" - TCL_LIB_SPEC="-bI:${libdir}/${TCL_EXP_FILE}" + TCL_LIB_FILE="Tcl" + TCL_LIB_FLAG="-framework Tcl" + TCL_BUILD_LIB_SPEC="-F`pwd` -framework Tcl" + TCL_LIB_SPEC="-F${libdir} -framework Tcl" + libdir="${libdir}/Tcl.framework/Versions/\${VERSION}" + TCL_LIBRARY="${libdir}/Resources/Scripts" + includedir="${libdir}/Headers" + PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders" + HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl" + EXTRA_INSTALL="install-private-headers html-tcl" + EXTRA_BUILD_HTML='@ln -fs contents.htm $(HTML_INSTALL_DIR)/TclTOC.html' + EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources" && mkdir -p "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"' + EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."' + TCL_YEAR="`date +%Y`" + # Don't use AC_DEFINE for the following as the framework version define + # needs to go into the Makefile even when using autoheader, so that we + # can pick up a potential make override of VERSION. Also, don't put this + # into CFLAGS as it should not go into tclConfig.sh + EXTRA_CC_SWITCHES='-DTCL_FRAMEWORK_VERSION=\"$(VERSION)\"' +else + # libdir must be a fully qualified path and not ${exec_prefix}/lib + eval libdir="$libdir" + if test "$SHARED_BUILD" = "0" || test "$TCL_NEEDS_EXP_FILE" = "0"; then + if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then + TCL_LIB_FLAG="-ltcl${TCL_VERSION}" + else + TCL_LIB_FLAG="-ltcl`echo ${TCL_VERSION} | tr -d .`" + fi + TCL_BUILD_LIB_SPEC="-L`pwd` ${TCL_LIB_FLAG}" + TCL_LIB_SPEC="-L${libdir} ${TCL_LIB_FLAG}" + else + TCL_BUILD_EXP_FILE="lib.exp" + eval "TCL_EXP_FILE=libtcl${TCL_EXPORT_FILE_SUFFIX}" + + if test "$GCC" = "yes" ; then + TCL_BUILD_LIB_SPEC="-Wl,-bI:`pwd`/${TCL_BUILD_EXP_FILE} -L`pwd`" + TCL_LIB_SPEC="-Wl,-bI:${libdir}/${TCL_EXP_FILE} -L`pwd`" + else + TCL_BUILD_LIB_SPEC="-bI:`pwd`/${TCL_BUILD_EXP_FILE}" + TCL_LIB_SPEC="-bI:${libdir}/${TCL_EXP_FILE}" + fi fi fi VERSION='${VERSION}' eval "CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}" eval "CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}" @@ -492,50 +541,51 @@ # consists of one directory for machine-dependent binaries and # another for platform-independent scripts. #-------------------------------------------------------------------- if test "$FRAMEWORK_BUILD" = "1" ; then - TCL_PACKAGE_PATH="${libdir}/Resources/Scripts" + TCL_PACKAGE_PATH="~/Library/Tcl /Library/Tcl /Network/Library/Tcl /System/Library/Tcl ~/Library/Frameworks /Library/Frameworks /Network/Library/Frameworks /System/Library/Frameworks" + TCL_MODULE_PATH="~/Library/Tcl /Library/Tcl /Network/Library/Tcl /System/Library/Tcl" elif test "$prefix/lib" != "$libdir"; then TCL_PACKAGE_PATH="${libdir} ${prefix}/lib" else TCL_PACKAGE_PATH="${prefix}/lib" fi + +# If a system share directory like /usr/local/share already exists, then add +# it to the package search path. + +if test -d "${prefix}/share" ; then + TCL_PACKAGE_PATH="${TCL_PACKAGE_PATH} ${prefix}/share" +fi #-------------------------------------------------------------------- # The statements below define various symbols relating to Tcl # stub support. #-------------------------------------------------------------------- # Replace ${VERSION} with contents of ${TCL_VERSION} +# double-eval to account for TCL_TRIM_DOTS. +# eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}" -# Replace DBGX with TCL_DBGX eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\"" +eval "TCL_STUB_LIB_DIR=${libdir}" if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then - TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}\${TCL_DBGX}" + TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}" else - TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`\${TCL_DBGX}" + TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`" fi TCL_BUILD_STUB_LIB_SPEC="-L`pwd` ${TCL_STUB_LIB_FLAG}" -TCL_STUB_LIB_SPEC="-L${libdir} ${TCL_STUB_LIB_FLAG}" +TCL_STUB_LIB_SPEC="-L${TCL_STUB_LIB_DIR} ${TCL_STUB_LIB_FLAG}" TCL_BUILD_STUB_LIB_PATH="`pwd`/${TCL_STUB_LIB_FILE}" -TCL_STUB_LIB_PATH="${libdir}/${TCL_STUB_LIB_FILE}" +TCL_STUB_LIB_PATH="${TCL_STUB_LIB_DIR}/${TCL_STUB_LIB_FILE}" # Install time header dir can be set via --includedir eval "TCL_INCLUDE_SPEC=\"-I${includedir}\"" -#------------------------------------------------------------------------ - -AC_ARG_ENABLE(dll-unloading, - [ --enable-dll-unloading turn on the 'unload' command (default: on)], - [tcl_ok=$enableval], [tcl_ok=yes]) -if test $tcl_ok = yes; then - AC_DEFINE(TCL_UNLOAD_DLLS, 1, [Do we allow unloading of shared libraries?]) -fi - #------------------------------------------------------------------------ # tclConfig.sh refers to this by a different name #------------------------------------------------------------------------ TCL_SHARED_BUILD=${SHARED_BUILD} @@ -542,10 +592,11 @@ AC_SUBST(TCL_VERSION) AC_SUBST(TCL_MAJOR_VERSION) AC_SUBST(TCL_MINOR_VERSION) AC_SUBST(TCL_PATCH_LEVEL) +AC_SUBST(TCL_YEAR) AC_SUBST(TCL_LIB_FILE) AC_SUBST(TCL_LIB_FLAG) AC_SUBST(TCL_LIB_SPEC) AC_SUBST(TCL_STUB_LIB_FILE) @@ -555,13 +606,10 @@ AC_SUBST(TCL_INCLUDE_SPEC) AC_SUBST(TCL_BUILD_STUB_LIB_SPEC) AC_SUBST(TCL_BUILD_STUB_LIB_PATH) AC_SUBST(TCL_SRC_DIR) -AC_SUBST(TCL_DBGX) -AC_DEFINE_UNQUOTED(TCL_DBGX,${TCL_DBGX}, - [What extra letters do we insert for debugging binary code?]) AC_SUBST(CFG_TCL_SHARED_LIB_SUFFIX) AC_SUBST(CFG_TCL_UNSHARED_LIB_SUFFIX) AC_SUBST(CFG_TCL_EXPORT_FILE_SUFFIX) AC_SUBST(TCL_SHARED_BUILD) @@ -578,7 +626,21 @@ AC_SUBST(TCL_HAS_LONGLONG) AC_SUBST(BUILD_DLTEST) AC_SUBST(TCL_PACKAGE_PATH) +AC_SUBST(TCL_MODULE_PATH) + +AC_SUBST(TCL_LIBRARY) +AC_SUBST(PRIVATE_INCLUDE_DIR) +AC_SUBST(HTML_DIR) + +AC_SUBST(EXTRA_CC_SWITCHES) +AC_SUBST(EXTRA_INSTALL) +AC_SUBST(EXTRA_INSTALL_BINARIES) +AC_SUBST(EXTRA_BUILD_HTML) -AC_OUTPUT([Makefile dltest/Makefile tclConfig.sh]) +dnl Disable the automake-friendly normalization of LIBOBJS +dnl performed by autoconf 2.53 and later. It's not correct for us. +define([_AC_LIBOBJS_NORMALIZE],[]) +AC_CONFIG_FILES([Makefile dltest/Makefile tclConfig.sh]) +AC_OUTPUT Index: unix/dltest/Makefile.in ================================================================== --- unix/dltest/Makefile.in +++ unix/dltest/Makefile.in @@ -1,11 +1,10 @@ # This Makefile is used to create several test cases for Tcl's load # command. It also illustrates how to take advantage of configuration # exported by Tcl to set up Makefiles for shared libraries. -# RCS: @(#) $Id: Makefile.in,v 1.16 2004/11/12 20:27:29 das Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.16.2.1 2005/01/20 14:53:41 kennykb Exp $ -TCL_DBGX = @TCL_DBGX@ CC = @CC@ LIBS = @TCL_BUILD_STUB_LIB_SPEC@ @TCL_LIBS@ AC_FLAGS = @DEFS@ SHLIB_CFLAGS = @SHLIB_CFLAGS@ SHLIB_LD = @SHLIB_LD@ Index: unix/tcl.m4 ================================================================== --- unix/tcl.m4 +++ unix/tcl.m4 @@ -25,16 +25,26 @@ # if test x"${no_tcl}" = x ; then # we reset no_tcl in case something fails here no_tcl=true - AC_ARG_WITH(tcl, [ --with-tcl directory containing tcl configuration (tclConfig.sh)], with_tclconfig=${withval}) + AC_ARG_WITH(tcl, + AC_HELP_STRING([--with-tcl], + [directory containing tcl configuration (tclConfig.sh)]), + with_tclconfig=${withval}) AC_MSG_CHECKING([for Tcl configuration]) AC_CACHE_VAL(ac_cv_c_tclconfig,[ # First check to see if --with-tcl was specified. if test x"${with_tclconfig}" != x ; then + case ${with_tclconfig} in + */tclConfig.sh ) + if test -f ${with_tclconfig}; then + AC_MSG_WARN([--with-tcl argument should refer to directory containing tclConfig.sh, not to tclConfig.sh itself]) + with_tclconfig=`echo ${with_tclconfig} | sed 's!/tclConfig\.sh$!!'` + fi ;; + esac if test -f "${with_tclconfig}/tclConfig.sh" ; then ac_cv_c_tclconfig=`(cd ${with_tclconfig}; pwd)` else AC_MSG_ERROR([${with_tclconfig} directory doesn't contain tclConfig.sh]) fi @@ -129,16 +139,26 @@ # if test x"${no_tk}" = x ; then # we reset no_tk in case something fails here no_tk=true - AC_ARG_WITH(tk, [ --with-tk directory containing tk configuration (tkConfig.sh)], with_tkconfig=${withval}) + AC_ARG_WITH(tk, + AC_HELP_STRING([--with-tk], + [directory containing tk configuration (tkConfig.sh)]), + with_tkconfig=${withval}) AC_MSG_CHECKING([for Tk configuration]) AC_CACHE_VAL(ac_cv_c_tkconfig,[ # First check to see if --with-tkconfig was specified. if test x"${with_tkconfig}" != x ; then + case ${with_tkconfig} in + */tkConfig.sh ) + if test -f ${with_tkconfig}; then + AC_MSG_WARN([--with-tk argument should refer to directory containing tkConfig.sh, not to tkConfig.sh itself]) + with_tkconfig=`echo ${with_tkconfig} | sed 's!/tkConfig\.sh$!!'` + fi ;; + esac if test -f "${with_tkconfig}/tkConfig.sh" ; then ac_cv_c_tkconfig=`(cd ${with_tkconfig}; pwd)` else AC_MSG_ERROR([${with_tkconfig} directory doesn't contain tkConfig.sh]) fi @@ -249,10 +269,11 @@ TCL_STUB_LIB_PATH=${TCL_BUILD_STUB_LIB_PATH} fi # # eval is required to do the TCL_DBGX substitution + # (@@@ Is this still the case?) # eval "TCL_LIB_FILE=\"${TCL_LIB_FILE}\"" eval "TCL_LIB_FLAG=\"${TCL_LIB_FLAG}\"" eval "TCL_LIB_SPEC=\"${TCL_LIB_SPEC}\"" @@ -303,10 +324,83 @@ AC_SUBST(TK_VERSION) AC_SUBST(TK_BIN_DIR) AC_SUBST(TK_SRC_DIR) AC_SUBST(TK_LIB_FILE) ]) + +#------------------------------------------------------------------------ +# SC_PROG_TCLSH +# Locate a tclsh shell installed on the system path. This macro +# will only find a Tcl shell that already exists on the system. +# It will not find a Tcl shell in the Tcl build directory or +# a Tcl shell that has been installed from the Tcl build directory. +# If a Tcl shell can't be located on the PATH, then TCLSH_PROG will +# be set to "". Extensions should take care not to create Makefile +# rules that are run by default and depend on TCLSH_PROG. An +# extension can't assume that an executable Tcl shell exists at +# build time. +# +# Arguments +# none +# +# Results +# Subst's the following values: +# TCLSH_PROG +#------------------------------------------------------------------------ + +AC_DEFUN(SC_PROG_TCLSH, [ + AC_MSG_CHECKING([for tclsh]) + + AC_CACHE_VAL(ac_cv_path_tclsh, [ + search_path=`echo ${PATH} | sed -e 's/:/ /g'` + for dir in $search_path ; do + for j in `ls -r $dir/tclsh[[8-9]]* 2> /dev/null` \ + `ls -r $dir/tclsh* 2> /dev/null` ; do + if test x"$ac_cv_path_tclsh" = x ; then + if test -f "$j" ; then + ac_cv_path_tclsh=$j + break + fi + fi + done + done + ]) + + if test -f "$ac_cv_path_tclsh" ; then + TCLSH_PROG="$ac_cv_path_tclsh" + AC_MSG_RESULT($TCLSH_PROG) + else + # It is not an error if an installed version of Tcl can't be located. + TCLSH_PROG="" + AC_MSG_RESULT([No tclsh found on PATH]) + fi + AC_SUBST(TCLSH_PROG) +]) + +#------------------------------------------------------------------------ +# SC_BUILD_TCLSH +# Determine the fully qualified path name of the tclsh executable +# in the Tcl build directory. This macro will correctly determine +# the name of the tclsh executable even if tclsh has not yet +# been built in the build directory. The build tclsh must be used +# when running tests from an extension build directory. It is not +# correct to use the TCLSH_PROG in cases like this. +# +# Arguments +# none +# +# Results +# Subst's the following values: +# BUILD_TCLSH +#------------------------------------------------------------------------ + +AC_DEFUN(SC_BUILD_TCLSH, [ + AC_MSG_CHECKING([for tclsh in Tcl build directory]) + BUILD_TCLSH=${TCL_BIN_DIR}/tclsh + AC_MSG_RESULT($BUILD_TCLSH) + AC_SUBST(BUILD_TCLSH) +]) #------------------------------------------------------------------------ # SC_ENABLE_SHARED -- # # Allows the building of shared libraries @@ -328,11 +422,12 @@ #------------------------------------------------------------------------ AC_DEFUN(SC_ENABLE_SHARED, [ AC_MSG_CHECKING([how to build libraries]) AC_ARG_ENABLE(shared, - [ --enable-shared build and link with shared libraries [--enable-shared]], + AC_HELP_STRING([--enable-shared], + [build and link with shared libraries (default: on)]), [tcl_ok=$enableval], [tcl_ok=yes]) if test "${enable_shared+set}" = set; then enableval="$enable_shared" tcl_ok=$enableval @@ -368,11 +463,12 @@ #------------------------------------------------------------------------ AC_DEFUN(SC_ENABLE_FRAMEWORK, [ AC_MSG_CHECKING([how to package libraries]) AC_ARG_ENABLE(framework, - [ --enable-framework package shared libraries in MacOSX frameworks [--disable-framework]], + AC_HELP_STRING([--enable-framework], + [package shared libraries in MacOSX frameworks (default: off)]), [tcl_ok=$enableval], [tcl_ok=no]) if test "${enable_framework+set}" = set; then enableval="$enable_framework" tcl_ok=$enableval @@ -384,10 +480,14 @@ AC_MSG_RESULT([framework]) FRAMEWORK_BUILD=1 if test "${SHARED_BUILD}" = "0" ; then AC_MSG_WARN("Frameworks can only be built if --enable-shared is yes") FRAMEWORK_BUILD=0 + fi + if test $tcl_corefoundation = no; then + AC_MSG_WARN("Frameworks can only be used when CoreFoundation is available") + FRAMEWORK_BUILD=0 fi else AC_MSG_RESULT([standard shared library]) FRAMEWORK_BUILD=0 fi @@ -416,11 +516,13 @@ # #------------------------------------------------------------------------ AC_DEFUN(SC_ENABLE_THREADS, [ AC_MSG_CHECKING(for building with threads) - AC_ARG_ENABLE(threads, [ --enable-threads build with threads], + AC_ARG_ENABLE(threads, + AC_HELP_STRING([--enable-threads], + [build with threads (default: off)]), [tcl_ok=$enableval], [tcl_ok=no]) if test "$tcl_ok" = "yes" -o "${TCL_THREADS}" = 1; then if test "${TCL_THREADS}" = 1; then AC_MSG_RESULT([yes (threaded core)]) @@ -431,14 +533,10 @@ AC_DEFINE(TCL_THREADS, 1, [Are we building with threads enabled?]) # USE_THREAD_ALLOC tells us to try the special thread-based # allocator that significantly reduces lock contention AC_DEFINE(USE_THREAD_ALLOC, 1, [Do we want to use the threaded memory allocator?]) - # USE_THREAD_STORAGE tells us to use the new generic thread - # storage subsystem. - AC_DEFINE(USE_THREAD_STORAGE, 1, - [Use the generic thread storage subsystem?]) AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?]) if test "`uname -s`" = "SunOS" ; then AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1, [Do we really want to follow the standard? Yes we do!]) fi @@ -512,47 +610,10 @@ [Is pthread_getattr_np declared in ?]) fi fi fi LIBS=$ac_saved_libs - AC_CHECK_FUNCS(readdir_r) - if test "x$ac_cv_func_readdir_r" = "xyes"; then - AC_MSG_CHECKING([how many args readdir_r takes]) - # IRIX 5.3 has a 2 arg version of readdir_r - # while other systems have a 3 arg version. - AC_CACHE_VAL(tcl_cv_two_arg_readdir_r, - AC_TRY_COMPILE([#include -#include -#ifdef NO_DIRENT_H -# include /* logic from tcl/compat/dirent.h * -# define dirent direct * */ -#else -# include -#endif -], [readdir_r(NULL, NULL);], - tcl_cv_two_arg_readdir_r=yes, tcl_cv_two_arg_readdir_r=no)) - AC_CACHE_VAL(tcl_cv_three_arg_readdir_r, - AC_TRY_COMPILE([#include -#include -#ifdef NO_DIRENT_H -# include /* logic from tcl/compat/dirent.h * -# define dirent direct * */ -#else -# include -#endif -], [readdir_r(NULL, NULL, NULL);], - tcl_cv_three_arg_readdir_r=yes, tcl_cv_three_arg_readdir_r=no)) - if test "x$tcl_cv_two_arg_readdir_r" = "xyes" ; then - AC_MSG_RESULT([2]) - AC_DEFINE(HAVE_TWO_ARG_READDIR_R) - elif test "x$tcl_cv_three_arg_readdir_r" = "xyes" ; then - AC_MSG_RESULT([3]) - AC_DEFINE(HAVE_THREE_ARG_READDIR_R) - else - AC_MSG_ERROR([unknown number of args for readdir_r]) - fi - fi else TCL_THREADS=0 AC_MSG_RESULT([no (default)]) fi AC_SUBST(TCL_THREADS) @@ -582,48 +643,53 @@ # Defines the following vars: # CFLAGS_DEFAULT Sets to $(CFLAGS_DEBUG) if true # Sets to $(CFLAGS_OPTIMIZE) if false # LDFLAGS_DEFAULT Sets to $(LDFLAGS_DEBUG) if true # Sets to $(LDFLAGS_OPTIMIZE) if false -# DBGX Debug library extension +# DBGX Formerly used as debug library extension; +# always blank now. # #------------------------------------------------------------------------ AC_DEFUN(SC_ENABLE_SYMBOLS, [ AC_MSG_CHECKING([for build with symbols]) - AC_ARG_ENABLE(symbols, [ --enable-symbols build with debugging symbols [--disable-symbols]], [tcl_ok=$enableval], [tcl_ok=no]) + AC_ARG_ENABLE(symbols, + AC_HELP_STRING([--enable-symbols], + [build with debugging symbols (default: off)]), + [tcl_ok=$enableval], [tcl_ok=no]) # FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT. + DBGX="" if test "$tcl_ok" = "no"; then CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)' LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)' - DBGX="" AC_MSG_RESULT([no]) AC_DEFINE(TCL_CFG_OPTIMIZED, 1, [Is this an optimized build?]) else CFLAGS_DEFAULT='$(CFLAGS_DEBUG)' LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)' - DBGX=g if test "$tcl_ok" = "yes"; then AC_MSG_RESULT([yes (standard debugging)]) fi fi AC_SUBST(CFLAGS_DEFAULT) AC_SUBST(LDFLAGS_DEFAULT) + ### FIXME: Surely TCL_CFG_DEBUG should be set to whether we're debugging? AC_DEFINE(TCL_CFG_DEBUG, 1, [Is debugging enabled?]) if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then AC_DEFINE(TCL_MEM_DEBUG, 1, [Is memory debugging enabled?]) fi - if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then - AC_DEFINE(TCL_COMPILE_DEBUG, 1, [Is bytecode debugging enabled?]) - AC_DEFINE(TCL_COMPILE_STATS, 1, [Are bytecode statistics enabled?]) - fi + ifelse($1,bccdebug,dnl Only enable 'compile' for the Tcl core itself + if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then + AC_DEFINE(TCL_COMPILE_DEBUG, 1, [Is bytecode debugging enabled?]) + AC_DEFINE(TCL_COMPILE_STATS, 1, [Are bytecode statistics enabled?]) + fi) if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then if test "$tcl_ok" = "all"; then - AC_MSG_RESULT([enabled symbols mem compile debugging]) + AC_MSG_RESULT([enabled symbols mem ]ifelse($1,bccdebug,[compile ])[debugging]) else AC_MSG_RESULT([enabled $tcl_ok debugging]) fi fi ]) @@ -647,12 +713,12 @@ # #------------------------------------------------------------------------ AC_DEFUN(SC_ENABLE_LANGINFO, [ AC_ARG_ENABLE(langinfo, - [ --enable-langinfo use nl_langinfo if possible to determine - encoding at startup, otherwise use old heuristic], + AC_HELP_STRING([--enable-langinfo], + [use nl_langinfo if possible to determine encoding at startup, otherwise use old heuristic (default: on)]), [langinfo_ok=$enableval], [langinfo_ok=yes]) HAVE_LANGINFO=0 if test "$langinfo_ok" = "yes"; then if test "$langinfo_ok" = "yes"; then @@ -697,48 +763,54 @@ # # MAN_FLAGS - The apropriate flags for installManPage # according to the user's selection. # #-------------------------------------------------------------------- + AC_DEFUN(SC_CONFIG_MANPAGES, [ - - AC_MSG_CHECKING([whether to use symlinks for manpages]) - AC_ARG_ENABLE(man-symlinks, - AC_HELP_STRING([--enable-man-symlinks], - [use symlinks for the manpages]), - test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --symlinks", - enableval="no") - AC_MSG_RESULT([$enableval]) - - AC_MSG_CHECKING([whether to compress the manpages]) - AC_ARG_ENABLE(man-compression, - AC_HELP_STRING([--enable-man-compression=PROG], - [compress the manpages with PROG]), - test "$enableval" = "yes" && AC_MSG_ERROR([missing argument to --enable-man-compression]) - test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --compress $enableval", - enableval="no") - AC_MSG_RESULT([$enableval]) - if test "$enableval" != "no"; then - AC_MSG_CHECKING([for compressed file suffix]) - touch TeST - $enableval TeST - Z=`ls TeST* | sed 's/^....//'` - rm -f TeST* - MAN_FLAGS="$MAN_FLAGS --extension $Z" - AC_MSG_RESULT([$Z]) - fi - - AC_MSG_CHECKING([whether to add a package name suffix for the manpages]) - AC_ARG_ENABLE(man-suffix, - AC_HELP_STRING([--enable-man-suffix=STRING], - [use STRING as a suffix to manpage file names (default: AC_PACKAGE_NAME)]), - test "$enableval" = "yes" && enableval="AC_PACKAGE_NAME" - test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --suffix $enableval", - enableval="no") - AC_MSG_RESULT([$enableval]) - - AC_SUBST(MAN_FLAGS) + AC_MSG_CHECKING([whether to use symlinks for manpages]) + AC_ARG_ENABLE(man-symlinks, + AC_HELP_STRING([--enable-man-symlinks], + [use symlinks for the manpages (default: off)]), + test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --symlinks", + enableval="no") + AC_MSG_RESULT([$enableval]) + + AC_MSG_CHECKING([whether to compress the manpages]) + AC_ARG_ENABLE(man-compression, + AC_HELP_STRING([--enable-man-compression=PROG], + [compress the manpages with PROG (default: off)]), + [case $enableval in + yes) AC_MSG_ERROR([missing argument to --enable-man-compression]);; + no) ;; + *) MAN_FLAGS="$MAN_FLAGS --compress $enableval";; + esac], + enableval="no") + AC_MSG_RESULT([$enableval]) + if test "$enableval" != "no"; then + AC_MSG_CHECKING([for compressed file suffix]) + touch TeST + $enableval TeST + Z=`ls TeST* | sed 's/^....//'` + rm -f TeST* + MAN_FLAGS="$MAN_FLAGS --extension $Z" + AC_MSG_RESULT([$Z]) + fi + + AC_MSG_CHECKING([whether to add a package name suffix for the manpages]) + AC_ARG_ENABLE(man-suffix, + AC_HELP_STRING([--enable-man-suffix=STRING], + [use STRING as a suffix to manpage file names (default: no, AC_PACKAGE_NAME if enabled without specifying STRING)]), + [case $enableval in + yes) enableval="AC_PACKAGE_NAME";; + no) ;; + *) MAN_FLAGS="$MAN_FLAGS --suffix $enableval";; + esac], + enableval="no") + AC_MSG_RESULT([$enableval]) + + AC_SUBST(MAN_FLAGS) ]) #-------------------------------------------------------------------- # SC_CONFIG_CFLAGS # @@ -781,13 +853,10 @@ # SHLIB_CFLAGS - Flags to pass to cc when compiling the components # of a shared library (may request position-independent # code, among other things). # SHLIB_LD - Base command to use for combining object files # into a shared library. -# SHLIB_LD_FLAGS -Flags to pass when building a shared library. This -# differes from the SHLIB_CFLAGS as it is not used -# when building object files or executables. # SHLIB_LD_LIBS - Dependent libraries for the linker to scan when # creating shared libraries. This symbol typically # goes at the end of the "ld" commands that build # shared libraries. The value of the symbol is # "${LIBS}" if all of the dependent libraries should @@ -841,11 +910,14 @@ AC_DEFUN(SC_CONFIG_CFLAGS, [ # Step 0.a: Enable 64 bit support? AC_MSG_CHECKING([if 64bit support is requested]) - AC_ARG_ENABLE(64bit,[ --enable-64bit enable 64bit support (where applicable)],,enableval="no") + AC_ARG_ENABLE(64bit, + AC_HELP_STRING([--enable-64bit], + [enable 64bit support (default: off)]), + ,enableval="no") if test "$enableval" = "yes"; then do64bit=yes else do64bit=no @@ -853,11 +925,14 @@ AC_MSG_RESULT($do64bit) # Step 0.b: Enable Solaris 64 bit VIS support? AC_MSG_CHECKING([if 64bit Sparc VIS support is requested]) - AC_ARG_ENABLE(64bit-vis,[ --enable-64bit-vis enable 64bit Sparc VIS support],,enableval="no") + AC_ARG_ENABLE(64bit-vis, + AC_HELP_STRING([--enable-64bit-vis], + [enable 64bit Sparc VIS support (default: off)]), + ,enableval="no") if test "$enableval" = "yes"; then # Force 64bit on with VIS do64bit=yes do64bitVIS=yes @@ -931,35 +1006,34 @@ AC_MSG_ERROR([Required archive tool 'ar' not found on PATH.]) fi STLIB_LD='${AR} cr' LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH" PLAT_OBJS="" + PLAT_SRCS="" case $system in - AIX-5.*) + AIX-*) if test "${TCL_THREADS}" = "1" -a "$GCC" != "yes" ; then # AIX requires the _r compiler when gcc isn't being used if test "${CC}" != "cc_r" ; then CC=${CC}_r fi - AC_MSG_RESULT(Using $CC for compiling with threads) + AC_MSG_RESULT([Using $CC for compiling with threads]) fi LIBS="$LIBS -lc" - # AIX-5 uses ELF style dynamic libraries SHLIB_CFLAGS="" # Note: need the LIBS below, otherwise Tk won't find Tcl's # symbols when dynamically loaded into tclsh. SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" - LD_LIBRARY_PATH_VAR="LIBPATH" - # Check to enable 64-bit flags for compiler/linker - if test "$do64bit" = "yes" ; then + # Check to enable 64-bit flags for compiler/linker on AIX 4+ + if test "$do64bit" = "yes" -a "`uname -v`" -gt "3" ; then if test "$GCC" = "yes" ; then - AC_MSG_WARN("64bit mode not supported with GCC on $system") + AC_MSG_WARN([64bit mode not supported with GCC on $system]) else do64bit_ok=yes CFLAGS="$CFLAGS -q64" LDFLAGS_ARCH="-q64" RANLIB="${RANLIB} -X64" @@ -978,59 +1052,29 @@ else CC_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}' fi LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' else - SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry ${SHLIB_LD_FLAGS}" + if test "$GCC" = "yes" ; then + SHLIB_LD="gcc -shared" + else + SHLIB_LD="/bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry" + fi + SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix ${SHLIB_LD} ${SHLIB_LD_FLAGS}" DL_LIBS="-ldl" CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} TCL_NEEDS_EXP_FILE=1 - TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.exp' - fi - ;; - AIX-*) - if test "${TCL_THREADS}" = "1" -a "$GCC" != "yes" ; then - # AIX requires the _r compiler when gcc isn't being used - if test "${CC}" != "cc_r" ; then - CC=${CC}_r - fi - AC_MSG_RESULT(Using $CC for compiling with threads) - fi - LIBS="$LIBS -lc" - SHLIB_CFLAGS="" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - LD_LIBRARY_PATH_VAR="LIBPATH" - TCL_NEEDS_EXP_FILE=1 - TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.exp' + TCL_EXPORT_FILE_SUFFIX='${VERSION}.exp' + fi # AIX v<=4.1 has some different flags than 4.2+ if test "$system" = "AIX-4.1" -o "`uname -v`" -lt "4" ; then AC_LIBOBJ([tclLoadAix]) DL_LIBS="-lld" fi - # Check to enable 64-bit flags for compiler/linker - if test "$do64bit" = "yes" ; then - if test "$GCC" = "yes" ; then - AC_MSG_WARN("64bit mode not supported with GCC on $system") - else - do64bit_ok=yes - CFLAGS="$CFLAGS -q64" - LDFLAGS_ARCH="-q64" - RANLIB="${RANLIB} -X64" - AR="${AR} -X64" - SHLIB_LD_FLAGS="-b64" - fi - fi - SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry ${SHLIB_LD_FLAGS}" - # On AIX <=v4 systems, libbsd.a has to be linked in to support # non-blocking file IO. This library has to be linked in after # the MATH_LIBS or it breaks the pow() function. The way to # insure proper sequencing, is to add it to the tail of MATH_LIBS. # This library also supplies gettimeofday. @@ -1113,12 +1157,11 @@ LD_LIBRARY_PATH_VAR="SHLIB_PATH" fi if test "$GCC" = "yes" ; then SHLIB_LD="gcc -shared" SHLIB_LD_LIBS='${LIBS}' - LD_SEARCH_FLAGS='' - CC_SEARCH_FLAGS='' + LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} fi # Users may want PA-RISC 1.1/2.0 portable code - needs HP cc #CFLAGS="$CFLAGS +DAportable" @@ -1130,12 +1173,12 @@ hppa64*) # 64-bit gcc in use. Fix flags for GNU ld. do64bit_ok=yes SHLIB_LD="gcc -shared" SHLIB_LD_LIBS='${LIBS}' - LD_SEARCH_FLAGS='' - CC_SEARCH_FLAGS='' + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} ;; *) AC_MSG_WARN("64bit mode not supported with GCC on $system") ;; esac @@ -1159,22 +1202,10 @@ CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' LD_LIBRARY_PATH_VAR="SHLIB_PATH" fi ;; - IRIX-4.*) - SHLIB_CFLAGS="-G 0" - SHLIB_SUFFIX=".a" - SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" - SHLIB_LD_LIBS='${LIBS}' - DL_OBJS="tclLoadAout.o" - DL_LIBS="" - LDFLAGS="$LDFLAGS -Wl,-D,08000000" - CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a' - ;; IRIX-5.*) SHLIB_CFLAGS="" SHLIB_LD="ld -shared -rdata_shared" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" @@ -1320,71 +1351,66 @@ LDFLAGS="$LDFLAGS -Wl,-Bexport" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; NetBSD-*|FreeBSD-[[1-2]].*) - # Not available on all versions: check for include file. - AC_CHECK_HEADER(dlfcn.h, [ - # NetBSD/SPARC needs -fPIC, -fpic will not do. - SHLIB_CFLAGS="-fPIC" - SHLIB_LD="ld -Bshareable -x" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' - AC_MSG_CHECKING(for ELF) - AC_EGREP_CPP(yes, [ + # NetBSD/SPARC needs -fPIC, -fpic will not do. + SHLIB_CFLAGS="-fPIC" + SHLIB_LD="ld -Bshareable -x" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' + AC_MSG_CHECKING(for ELF) + AC_EGREP_CPP(yes, [ #ifdef __ELF__ yes #endif - ], - AC_MSG_RESULT(yes) - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so', - AC_MSG_RESULT(no) - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0' - ) - ], [ - SHLIB_CFLAGS="" - SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".a" - DL_OBJS="tclLoadAout.o" - DL_LIBS="" - CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a' - ]) - - # FreeBSD doesn't handle version numbers with dots. - - UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a' + ], + AC_MSG_RESULT(yes) + SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so', + AC_MSG_RESULT(no) + SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.1.0' + ) + + # Ancient FreeBSD doesn't handle version numbers with dots. + + UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; OpenBSD-*) - SHLIB_LD="${CC} -shared" - SHLIB_LD_LIBS='${LIBS}' + # OpenBSD/SPARC[64] needs -fPIC, -fpic will not do. + case `machine` in + sparc|sparc64) + SHLIB_CFLAGS="-fPIC";; + *) + SHLIB_CFLAGS="-fpic";; + esac + SHLIB_LD="${CC} -shared ${SHLIB_CFLAGS}" + SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" - CC_SEARCH_FLAGS="" - LD_SEARCH_FLAGS="" + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} + SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.1.0' AC_MSG_CHECKING(for ELF) AC_EGREP_CPP(yes, [ #ifdef __ELF__ yes #endif ], - [AC_MSG_RESULT(yes) - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0'], - [AC_MSG_RESULT(no) - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0'] + AC_MSG_RESULT(yes) + [ LDFLAGS=-Wl,-export-dynamic ], + AC_MSG_RESULT(no) + LDFLAGS="" ) # OpenBSD doesn't do version numbers with dots. - UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a' + UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; FreeBSD-*) # FreeBSD 3.* and greater have ELF. SHLIB_CFLAGS="-fPIC" @@ -1403,37 +1429,81 @@ LDFLAGS="$LDFLAGS -pthread" fi case $system in FreeBSD-3.*) # FreeBSD-3 doesn't handle version numbers with dots. - UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a' - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so' + UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' + SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so' TCL_LIB_VERSIONS_OK=nodots ;; esac ;; - Rhapsody-*|Darwin-*) + Darwin-*) + CFLAGS_OPTIMIZE="-Os" SHLIB_CFLAGS="-fno-common" SHLIB_LD="cc -dynamiclib \${LDFLAGS}" - TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version \${VERSION} -install_name \${DYLIB_INSTALL_DIR}/\${TCL_LIB_FILE} -prebind -seg1addr 0xa000000" - TK_SHLIB_LD_EXTRAS="-compatibility_version ${TK_VERSION} -current_version \${VERSION} -install_name \${DYLIB_INSTALL_DIR}/\${TK_LIB_FILE} -prebind -seg1addr 0xb000000" + AC_CACHE_CHECK([if ld accepts -single_module flag], tcl_cv_ld_single_module, [ + hold_ldflags=$LDFLAGS + LDFLAGS="$LDFLAGS -dynamiclib -Wl,-single_module" + AC_TRY_LINK(, [int i;], tcl_cv_ld_single_module=yes, tcl_cv_ld_single_module=no) + LDFLAGS=$hold_ldflags]) + if test $tcl_cv_ld_single_module = yes; then + SHLIB_LD="${SHLIB_LD} -Wl,-single_module" + fi SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".dylib" DL_OBJS="tclLoadDyld.o" - PLAT_OBJS=\$\(MAC\_OSX_OBJS\) DL_LIBS="" - LDFLAGS="$LDFLAGS -prebind" + LDFLAGS="$LDFLAGS -prebind -headerpad_max_install_names" + AC_CACHE_CHECK([if ld accepts -search_paths_first flag], tcl_cv_ld_search_paths_first, [ + hold_ldflags=$LDFLAGS + LDFLAGS="$LDFLAGS -Wl,-search_paths_first" + AC_TRY_LINK(, [int i;], tcl_cv_ld_search_paths_first=yes, tcl_cv_ld_search_paths_first=no) + LDFLAGS=$hold_ldflags]) + if test $tcl_cv_ld_search_paths_first = yes; then + LDFLAGS="$LDFLAGS -Wl,-search_paths_first" + fi CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" - CFLAGS_OPTIMIZE="-Os" LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH" - AC_DEFINE(MAC_OSX_TCL, 1, ["Is this a Mac I see before me?"]) - AC_DEFINE(HAVE_CFBUNDLE, 1, [Do we have access to Mac bundles?]) + PLAT_OBJS='${MAC_OSX_OBJS}' + PLAT_SRCS='${MAC_OSX_SRCS}' + AC_MSG_CHECKING([whether to use CoreFoundation]) + AC_ARG_ENABLE(corefoundation, + AC_HELP_STRING([--enable-corefoundation], + [use CoreFoundation API on MacOSX (default: yes)]), + [tcl_corefoundation=$enableval], [tcl_corefoundation=yes]) + AC_MSG_RESULT([$tcl_corefoundation]) + if test $tcl_corefoundation = yes; then + AC_CACHE_CHECK([for CoreFoundation.framework], tcl_cv_lib_corefoundation, [ + hold_libs=$LIBS + LIBS="$LIBS -framework CoreFoundation" + AC_TRY_LINK([#include ], + [CFBundleRef b = CFBundleGetMainBundle();], + tcl_cv_lib_corefoundation=yes, tcl_cv_lib_corefoundation=no) + LIBS=$hold_libs]) + if test $tcl_cv_lib_corefoundation = yes; then + LIBS="$LIBS -framework CoreFoundation" + AC_DEFINE(HAVE_COREFOUNDATION, 1, + [Do we have access to Darwin CoreFoundation.framework ?]) + fi + fi + AC_CHECK_HEADERS(libkern/OSAtomic.h) + AC_CHECK_FUNCS(OSSpinLockLock) + AC_DEFINE(MAC_OSX_TCL, 1, [Is this a Mac I see before me?]) AC_DEFINE(USE_VFORK, 1, [Should we use vfork() instead of fork()?]) AC_DEFINE(TCL_DEFAULT_ENCODING,"utf-8", [Are we to override what our default encoding is?]) - LIBS="$LIBS -framework CoreFoundation" + AC_DEFINE(MODULE_SCOPE, __private_extern__, [Linker support for module scope symbols]) + AC_DEFINE(TCL_LOAD_FROM_MEMORY, 1, [Can this platform load code from memory?]) + # prior to Darwin 7, realpath is not threadsafe, so don't + # use it when threads are enabled, c.f. bug # 711232: + AC_CHECK_FUNC(realpath) + if test "$ac_cv_func_realpath" = yes -a "${TCL_THREADS}" = 1 \ + -a `uname -r | awk -F. '{print [$]1}'` -lt 7 ; then + ac_cv_func_realpath=no + fi ;; NEXTSTEP-*) SHLIB_CFLAGS="" SHLIB_LD="cc -nostdlib -r" SHLIB_LD_LIBS="" @@ -1519,21 +1589,10 @@ # dlopen is in -lc on QNX DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; - RISCos-*) - SHLIB_CFLAGS="-G 0" - SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".a" - DL_OBJS="tclLoadAout.o" - DL_LIBS="" - LDFLAGS="$LDFLAGS -Wl,-D,08000000" - CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - ;; SCO_SV-3.2*) # Note, dlopen is available only on SCO 3.2.5 and greater. However, # this test works, since "uname -s" was non-standard in 3.2.4 and # below. if test "$GCC" = "yes" ; then @@ -1574,15 +1633,16 @@ # SunOS can't handle version numbers with dots in them in library # specs, like -ltcl7.5, so use -ltcl75 instead. Also, it # requires an extra version number at the end of .so file names. # So, the library has to have a name like libtcl75.so.1.0 - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0' - UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a' + SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.1.0' + UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; - SunOS-5.[[0-6]]*) + SunOS-5.[[0-6]]) + # Careful to not let 5.10+ fall into this case # Note: If _REENTRANT isn't defined, then Solaris # won't define thread-safe library routines. AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?]) @@ -1607,26 +1667,32 @@ CC_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} fi ;; SunOS-5*) - # Note: If _REENTRANT isn't defined, then Solaris # won't define thread-safe library routines. AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?]) AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1, [Do we really want to follow the standard? Yes we do!]) SHLIB_CFLAGS="-KPIC" - + # Check to enable 64-bit flags for compiler/linker if test "$do64bit" = "yes" ; then arch=`isainfo` if test "$arch" = "sparcv9 sparc" ; then if test "$GCC" = "yes" ; then - AC_MSG_WARN("64bit mode not supported with GCC on $system") + if test "`gcc -dumpversion | awk -F. '{print [$]1}'`" -lt "3" ; then + AC_MSG_WARN([64bit mode not supported with GCC < 3.2 on $system]) + else + do64bit_ok=yes + CFLAGS="$CFLAGS -m64 -mcpu=v9" + LDFLAGS="$LDFLAGS -m64 -mcpu=v9" + SHLIB_CFLAGS="-fPIC" + fi else do64bit_ok=yes if test "$do64bitVIS" = "yes" ; then CFLAGS="$CFLAGS -xarch=v9a" LDFLAGS_ARCH="-xarch=v9a" @@ -1633,12 +1699,20 @@ else CFLAGS="$CFLAGS -xarch=v9" LDFLAGS_ARCH="-xarch=v9" fi fi + elif test "$arch" = "amd64 i386" ; then + if test "$GCC" = "yes" ; then + AC_MSG_WARN([64bit mode not supported with GCC on $system]) + else + do64bit_ok=yes + CFLAGS="$CFLAGS -xarch=amd64" + LDFLAGS="$LDFLAGS -xarch=amd64" + fi else - AC_MSG_WARN("64bit mode only supported sparcv9 system") + AC_MSG_WARN([64bit mode not supported for $arch]) fi fi # Note: need the LIBS below, otherwise Tk won't find Tcl's # symbols when dynamically loaded into tclsh. @@ -1649,29 +1723,24 @@ DL_LIBS="-ldl" if test "$GCC" = "yes" ; then SHLIB_LD="$CC -shared" CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} + if test "$do64bit_ok" = "yes" ; then + # We need to specify -static-libgcc or we need to + # add the path to the sparv9 libgcc. + SHLIB_LD="$SHLIB_LD -m64 -mcpu=v9 -static-libgcc" + # for finding sparcv9 libgcc, get the regular libgcc + # path, remove so name and append 'sparcv9' + #v9gcclibdir="`gcc -print-file-name=libgcc_s.so` | ..." + #CC_SEARCH_FLAGS="${CC_SEARCH_FLAGS},-R,$v9gcclibdir" + fi else SHLIB_LD="/usr/ccs/bin/ld -G -z text" CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' fi - ;; - ULTRIX-4.*) - SHLIB_CFLAGS="-G 0" - SHLIB_SUFFIX=".a" - SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" - SHLIB_LD_LIBS='${LIBS}' - DL_OBJS="tclLoadAout.o" - DL_LIBS="" - LDFLAGS="$LDFLAGS -Wl,-D,08000000" - CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - if test "$GCC" != "yes" ; then - CFLAGS="$CFLAGS -DHAVE_TZSET -std1" - fi ;; UNIX_SV* | UnixWare-5*) SHLIB_CFLAGS="-KPIC" SHLIB_LD="cc -G" SHLIB_LD_LIBS="" @@ -1690,100 +1759,22 @@ LD_SEARCH_FLAGS="" ;; esac if test "$do64bit" = "yes" -a "$do64bit_ok" = "no" ; then - AC_MSG_WARN("64bit support being disabled -- don\'t know magic for this platform") + AC_MSG_WARN([64bit support being disabled -- don't know magic for this platform]) fi if test "$do64bit" = "yes" -a "$do64bit_ok" = "yes" ; then AC_DEFINE(TCL_CFG_DO64BIT, 1, [Is this a 64-bit build?]) fi - # Step 4: If pseudo-static linking is in use (see K. B. Kenny, "Dynamic - # Loading for Tcl -- What Became of It?". Proc. 2nd Tcl/Tk Workshop, - # New Orleans, LA, Computerized Processes Unlimited, 1994), then we need - # to determine which of several header files defines the a.out file - # format (a.out.h, sys/exec.h, or sys/exec_aout.h). At present, we - # support only a file format that is more or less version-7-compatible. - # In particular, - # - a.out files must begin with `struct exec'. - # - the N_TXTOFF on the `struct exec' must compute the seek address - # of the text segment - # - The `struct exec' must contain a_magic, a_text, a_data, a_bss - # and a_entry fields. - # The following compilation should succeed if and only if either sys/exec.h - # or a.out.h is usable for the purpose. - # - # Note that the modified COFF format used on MIPS Ultrix 4.x is usable; the - # `struct exec' includes a second header that contains information that - # duplicates the v7 fields that are needed. - - if test "x$DL_OBJS" = "xtclLoadAout.o" ; then - AC_MSG_CHECKING(sys/exec.h) - AC_TRY_COMPILE([#include ],[ - struct exec foo; - unsigned long seek; - int flag; -#if defined(__mips) || defined(mips) - seek = N_TXTOFF (foo.ex_f, foo.ex_o); -#else - seek = N_TXTOFF (foo); -#endif - flag = (foo.a_magic == OMAGIC); - return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; - ], tcl_ok=usable, tcl_ok=unusable) - AC_MSG_RESULT($tcl_ok) - if test $tcl_ok = usable; then - AC_DEFINE(USE_SYS_EXEC_H, 1, - [Should we use when doing dynamic loading?]) - else - AC_MSG_CHECKING(a.out.h) - AC_TRY_COMPILE([#include ],[ - struct exec foo; - unsigned long seek; - int flag; -#if defined(__mips) || defined(mips) - seek = N_TXTOFF (foo.ex_f, foo.ex_o); -#else - seek = N_TXTOFF (foo); -#endif - flag = (foo.a_magic == OMAGIC); - return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; - ], tcl_ok=usable, tcl_ok=unusable) - AC_MSG_RESULT($tcl_ok) - if test $tcl_ok = usable; then - AC_DEFINE(USE_A_OUT_H, 1, - [Should we use when doing dynamic loading?]) - else - AC_MSG_CHECKING(sys/exec_aout.h) - AC_TRY_COMPILE([#include ],[ - struct exec foo; - unsigned long seek; - int flag; -#if defined(__mips) || defined(mips) - seek = N_TXTOFF (foo.ex_f, foo.ex_o); -#else - seek = N_TXTOFF (foo); -#endif - flag = (foo.a_midmag == OMAGIC); - return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; - ], tcl_ok=usable, tcl_ok=unusable) - AC_MSG_RESULT($tcl_ok) - if test $tcl_ok = usable; then - AC_DEFINE(USE_SYS_EXEC_AOUT_H, 1, - [Should we use when doing dynamic loading?]) - else - DL_OBJS="" - fi - fi - fi - fi - - # Step 5: disable dynamic loading if requested via a command-line switch. - - AC_ARG_ENABLE(load, [ --disable-load disallow dynamic loading and "load" command], + # Step 4: disable dynamic loading if requested via a command-line switch. + + AC_ARG_ENABLE(load, + AC_HELP_STRING([--disable-load], + [disallow dynamic loading and "load" command (default: enabled)]), [tcl_ok=$enableval], [tcl_ok=yes]) if test "$tcl_ok" = "no"; then DL_OBJS="" fi @@ -1817,11 +1808,11 @@ ;; IRIX*) ;; NetBSD-*|FreeBSD-*) ;; - Rhapsody-*|Darwin-*) + Darwin-*) ;; RISCos-*) ;; SCO_SV-3.2*) ;; @@ -1833,19 +1824,19 @@ esac fi fi if test "$SHARED_LIB_SUFFIX" = "" ; then - SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}${SHLIB_SUFFIX}' + SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}' fi if test "$UNSHARED_LIB_SUFFIX" = "" ; then - UNSHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a' + UNSHARED_LIB_SUFFIX='${VERSION}.a' fi if test "${SHARED_BUILD}" = "1" && test "${SHLIB_SUFFIX}" != "" ; then LIB_SUFFIX=${SHARED_LIB_SUFFIX} - MAKE_LIB='${SHLIB_LD} -o [$]@ ${SHLIB_LD_FLAGS} ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' + MAKE_LIB='${SHLIB_LD} -o [$]@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)' else LIB_SUFFIX=${UNSHARED_LIB_SUFFIX} if test "$RANLIB" = "" ; then @@ -1895,10 +1886,11 @@ # would use TCL_DL_LIBS instead of TCL_LIBS. AC_SUBST(DL_LIBS) AC_SUBST(DL_OBJS) AC_SUBST(PLAT_OBJS) + AC_SUBST(PLAT_SRCS) AC_SUBST(CFLAGS) AC_SUBST(CFLAGS_DEBUG) AC_SUBST(CFLAGS_OPTIMIZE) AC_SUBST(CFLAGS_WARNING) @@ -1910,11 +1902,10 @@ AC_SUBST(STLIB_LD) AC_SUBST(SHLIB_LD) AC_SUBST(TCL_SHLIB_LD_EXTRAS) AC_SUBST(TK_SHLIB_LD_EXTRAS) - AC_SUBST(SHLIB_LD_FLAGS) AC_SUBST(SHLIB_LD_LIBS) AC_SUBST(SHLIB_CFLAGS) AC_SUBST(SHLIB_SUFFIX) AC_DEFINE_UNQUOTED(TCL_SHLIB_EXT,"${SHLIB_SUFFIX}", [What is the default extension for shared libraries?]) @@ -2076,10 +2067,11 @@ # #-------------------------------------------------------------------- AC_DEFUN(SC_MISSING_POSIX_HEADERS, [ AC_MSG_CHECKING(dirent.h) + AC_CACHE_VAL(tcl_cv_dirent_h, AC_TRY_LINK([#include #include ], [ #ifndef _POSIX_SOURCE # ifdef __Lynx__ /* @@ -2095,13 +2087,13 @@ char *p; d = opendir("foobar"); entryPtr = readdir(d); p = entryPtr->d_name; closedir(d); -], tcl_ok=yes, tcl_ok=no) +], tcl_cv_dirent_h=yes, tcl_cv_dirent_h=no)) - if test $tcl_ok = no; then + if test $tcl_cv_dirent_h = no; then AC_DEFINE(NO_DIRENT_H, 1, [Do we have ?]) fi AC_MSG_RESULT($tcl_ok) AC_CHECK_HEADER(errno.h, , [AC_DEFINE(NO_ERRNO_H, 1, [Do we have ?])]) @@ -2218,10 +2210,11 @@ if test "$XLIBSW" = nope ; then AC_MSG_RESULT(couldn't find any! Using -lX11.) XLIBSW=-lX11 fi ]) + #-------------------------------------------------------------------- # SC_BLOCKING_STYLE # # The statements below check for systems where POSIX-style # non-blocking I/O (O_NONBLOCK) doesn't work or is unimplemented. @@ -2527,10 +2520,12 @@ tcl_flags="" SC_TCL_EARLY_FLAG(_ISOC99_SOURCE,[#include ], [char *p = (char *)strtoll; char *q = (char *)strtoull;]) SC_TCL_EARLY_FLAG(_LARGEFILE64_SOURCE,[#include ], [struct stat64 buf; int i = stat64("/", &buf);]) + SC_TCL_EARLY_FLAG(_LARGEFILE_SOURCE64,[#include ], + [char *p = (char *)open64;]) if test "x${tcl_flags}" = "x" ; then AC_MSG_RESULT(none) else AC_MSG_RESULT(${tcl_flags}) fi]) @@ -2630,11 +2625,14 @@ # TCL_CFGVAL_ENCODING # #-------------------------------------------------------------------- AC_DEFUN(SC_TCL_CFG_ENCODING, [ - AC_ARG_WITH(encoding, [ --with-encoding encoding for configuration values], with_tcencoding=${withval}) + AC_ARG_WITH(encoding, + AC_HELP_STRING([--with-encoding], + [encoding for configuration values (default: iso8859-1)]), + with_tcencoding=${withval}) if test x"${with_tcencoding}" != x ; then AC_DEFINE_UNQUOTED(TCL_CFGVAL_ENCODING,"${with_tcencoding}", [What encoding should be used for embedded configuration info?]) else Index: unix/tcl.spec ================================================================== --- unix/tcl.spec +++ unix/tcl.spec @@ -1,9 +1,9 @@ -# $Id: tcl.spec,v 1.20 2004/03/26 19:47:29 dgp Exp $ +# $Id: tcl.spec,v 1.20.2.2 2005/07/12 20:37:29 kennykb Exp $ # This file is the basis for a binary Tcl RPM for Linux. -%define version 8.5a2 +%define version 8.5a4 %define directory /usr/local Summary: Tcl scripting language development environment Name: tcl Version: %{version} Index: unix/tclAppInit.c ================================================================== --- unix/tclAppInit.c +++ unix/tclAppInit.c @@ -1,19 +1,19 @@ -/* +/* * tclAppInit.c -- * * Provides a default version of the main program and Tcl_AppInit - * procedure for Tcl applications (without Tk). + * function for Tcl applications (without Tk). * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclAppInit.c,v 1.15 2004/11/12 22:52:30 dgp Exp $ + * RCS: @(#) $Id: tclAppInit.c,v 1.15.2.1 2005/08/02 18:16:54 dgp Exp $ */ #include "tcl.h" #ifdef TCL_TEST @@ -38,12 +38,12 @@ * main -- * * This is the main program for the application. * * Results: - * None: Tcl_Main never returns here, so this procedure never - * returns either. + * None: Tcl_Main never returns here, so this function never returns + * either. * * Side effects: * Whatever the application does. * *---------------------------------------------------------------------- @@ -53,18 +53,18 @@ main(argc, argv) int argc; /* Number of command-line arguments. */ char **argv; /* Values of command-line arguments. */ { /* - * The following #if block allows you to change the AppInit - * function by using a #define of TCL_LOCAL_APPINIT instead - * of rewriting this entire file. The #if checks for that - * #define and uses Tcl_AppInit if it doesn't exist. + * The following #if block allows you to change the AppInit function by + * using a #define of TCL_LOCAL_APPINIT instead of rewriting this entire + * file. The #if checks for that #define and uses Tcl_AppInit if it does + * not exist. */ #ifndef TCL_LOCAL_APPINIT -#define TCL_LOCAL_APPINIT Tcl_AppInit +#define TCL_LOCAL_APPINIT Tcl_AppInit #endif extern int TCL_LOCAL_APPINIT _ANSI_ARGS_((Tcl_Interp *interp)); /* * The following #if block allows you to change how Tcl finds the startup @@ -92,17 +92,17 @@ /* *---------------------------------------------------------------------- * * Tcl_AppInit -- * - * This procedure performs application-specific initialization. - * Most applications, especially those that incorporate additional - * packages, will have their own version of this procedure. + * This function performs application-specific initialization. Most + * applications, especially those that incorporate additional packages, + * will have their own version of this function. * * Results: - * Returns a standard Tcl completion code, and leaves an error - * message in the interp's result if an error occurs. + * Returns a standard Tcl completion code, and leaves an error message in + * the interp's result if an error occurs. * * Side effects: * Depends on the startup script. * *---------------------------------------------------------------------- @@ -116,54 +116,64 @@ return TCL_ERROR; } #ifdef TCL_TEST #ifdef TCL_XT_TEST - if (Tclxttest_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } + if (Tclxttest_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } #endif if (Tcltest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, - (Tcl_PackageInitProc *) NULL); + (Tcl_PackageInitProc *) NULL); if (TclObjTest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } if (Procbodytest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage(interp, "procbodytest", Procbodytest_Init, - Procbodytest_SafeInit); + Procbodytest_SafeInit); #endif /* TCL_TEST */ /* - * Call the init procedures for included packages. Each call should - * look like this: + * Call the init functions for included packages. Each call should look + * like this: * * if (Mod_Init(interp) == TCL_ERROR) { * return TCL_ERROR; * } * - * where "Mod" is the name of the module. + * where "Mod" is the name of the module. (Dynamically-loadable packages + * should have the same entry-point name.) */ /* - * Call Tcl_CreateCommand for application-specific commands, if - * they weren't already created by the init procedures called above. + * Call Tcl_CreateCommand for application-specific commands, if they + * weren't already created by the init functions called above. */ /* - * Specify a user-specific startup file to invoke if the application - * is run interactively. Typically the startup file is "~/.apprc" - * where "app" is the name of the application. If this line is deleted - * then no user-specific startup file will be run under any conditions. + * Specify a user-specific startup file to invoke if the application is + * run interactively. Typically the startup file is "~/.apprc" where "app" + * is the name of the application. If this line is deleted then no user- + * specific startup file will be run under any conditions. */ #ifdef DJGPP Tcl_SetVar(interp, "tcl_rcFileName", "~/tclsh.rc", TCL_GLOBAL_ONLY); #else Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclshrc", TCL_GLOBAL_ONLY); #endif + return TCL_OK; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: unix/tclConfig.h.in ================================================================== --- unix/tclConfig.h.in +++ unix/tclConfig.h.in @@ -1,6 +1,9 @@ /* tclConfig.h.in. Generated from configure.in by autoheader. */ + +#ifndef _TCLCONFIG +#define _TCLCONFIG /* Is pthread_attr_get_np() declared in ? */ #undef ATTRGETNP_NOT_DECLARED /* Is pthread_getattr_np declared in ? */ @@ -10,15 +13,15 @@ #undef GETTOD_NOT_DECLARED /* Do we have BSDgettimeofday()? */ #undef HAVE_BSDGETTIMEOFDAY -/* Do we have access to Mac bundles? */ -#undef HAVE_CFBUNDLE - /* Define to 1 if you have the `chflags' function. */ #undef HAVE_CHFLAGS + +/* Do we have access to Darwin CoreFoundation.framework ? */ +#undef HAVE_COREFOUNDATION /* Define to 1 if you have the `getattrlist' function. */ #undef HAVE_GETATTRLIST /* Define to 1 if you have the `getcwd' function. */ @@ -31,27 +34,39 @@ #undef HAVE_INTTYPES_H /* Do we have nl_langinfo()? */ #undef HAVE_LANGINFO +/* Define to 1 if you have the header file. */ +#undef HAVE_LIBKERN_OSATOMIC_H + /* Do we have ? */ #undef HAVE_LIMITS_H /* Define to 1 if you have the `localtime_r' function. */ #undef HAVE_LOCALTIME_R + +/* Define to 1 if you have the `lseek64' function. */ +#undef HAVE_LSEEK64 /* Define to 1 if you have the header file. */ #undef HAVE_MEMORY_H /* Define to 1 if you have the `mktime' function. */ #undef HAVE_MKTIME /* Do we have ? */ #undef HAVE_NET_ERRNO_H + +/* Define to 1 if you have the `open64' function. */ +#undef HAVE_OPEN64 /* Define to 1 if you have the `opendir' function. */ #undef HAVE_OPENDIR + +/* Define to 1 if you have the `OSSpinLockLock' function. */ +#undef HAVE_OSSPINLOCKLOCK /* Do we want a BSD-like thread-attribute interface? */ #undef HAVE_PTHREAD_ATTR_GET_NP /* Define to 1 if you have the `pthread_attr_setstacksize' function. */ @@ -61,13 +76,10 @@ #undef HAVE_PTHREAD_GETATTR_NP /* Does putenv() copy strings or incorporate them by reference? */ #undef HAVE_PUTENV_THAT_COPIES -/* Define to 1 if you have the `readdir_r' function. */ -#undef HAVE_READDIR_R - /* Are characters signed? */ #undef HAVE_SIGNED_CHAR /* Define to 1 if you have the header file. */ #undef HAVE_STDINT_H @@ -79,13 +91,10 @@ #undef HAVE_STRINGS_H /* Define to 1 if you have the header file. */ #undef HAVE_STRING_H -/* Define to 1 if you have the `strstr' function. */ -#undef HAVE_STRSTR - /* Define to 1 if you have the `strtol' function. */ #undef HAVE_STRTOL /* Define to 1 if you have the `strtoll' function. */ #undef HAVE_STRTOLL @@ -160,12 +169,15 @@ #undef HAVE_UNISTD_H /* Define to 1 if you have the `waitpid' function. */ #undef HAVE_WAITPID -/* "Is this a Mac I see before me?" */ +/* Is this a Mac I see before me? */ #undef MAC_OSX_TCL + +/* Linker support for module scope symbols */ +#undef MODULE_SCOPE /* Do we have ? */ #undef NO_DIRENT_H /* Do we have ? */ @@ -262,18 +274,18 @@ #undef TCL_COMPILE_DEBUG /* Are bytecode statistics enabled? */ #undef TCL_COMPILE_STATS -/* What extra letters do we insert for debugging binary code? */ -#undef TCL_DBGX - /* Are we to override what our default encoding is? */ #undef TCL_DEFAULT_ENCODING /* Is Tcl built as a framework? */ #undef TCL_FRAMEWORK + +/* Can this platform load code from memory? */ +#undef TCL_LOAD_FROM_MEMORY /* Is memory debugging enabled? */ #undef TCL_MEM_DEBUG /* What is the default extension for shared libraries? */ @@ -298,13 +310,10 @@ #undef TM_IN_SYS_TIME /* Is getcwd Posix-compliant? */ #undef USEGETWD -/* Should we use when doing dynamic loading? */ -#undef USE_A_OUT_H - /* Do we need a special AIX hack for timezones? */ #undef USE_DELTA_FOR_TZ /* May we include ? */ #undef USE_DIRENT2_H @@ -313,28 +322,19 @@ #undef USE_FIONBIO /* Use the sgtty API for serial lines */ #undef USE_SGTTY -/* Should we use when doing dynamic loading? */ -#undef USE_SYS_EXEC_AOUT_H - -/* Should we use when doing dynamic loading? */ -#undef USE_SYS_EXEC_H - /* Use the termio API for serial lines */ #undef USE_TERMIO /* Use the termios API for serial lines */ #undef USE_TERMIOS /* Do we want to use the threaded memory allocator? */ #undef USE_THREAD_ALLOC -/* Use the generic thread storage subsystem? */ -#undef USE_THREAD_STORAGE - /* Should we use vfork() instead of fork()? */ #undef USE_VFORK /* Define to 1 if your processor stores words with the most significant byte first (like Motorola and SPARC, unlike Intel and VAX). */ @@ -387,5 +387,7 @@ /* Do we want to use the strtod() in compat? */ #undef strtod /* Define to `int' if doesn't define. */ #undef uid_t + +#endif /* _TCLCONFIG */ Index: unix/tclConfig.sh.in ================================================================== --- unix/tclConfig.sh.in +++ unix/tclConfig.sh.in @@ -7,11 +7,11 @@ # for Tcl extensions so that they don't have to figure this all # out for themselves. # # The information in this file is specific to a single platform. # -# RCS: @(#) $Id: tclConfig.sh.in,v 1.19 2004/06/15 20:28:03 hobbs Exp $ +# RCS: @(#) $Id: tclConfig.sh.in,v 1.19.2.1 2005/01/20 14:53:40 kennykb Exp $ # Tcl's version number. TCL_VERSION='@TCL_VERSION@' TCL_MAJOR_VERSION='@TCL_MAJOR_VERSION@' TCL_MINOR_VERSION='@TCL_MINOR_VERSION@' @@ -21,13 +21,13 @@ TCL_CC='@CC@' # -D flags for use with the C compiler. TCL_DEFS='@DEFS@' -# If TCL was built with debugging symbols, generated libraries contain -# this string at the end of the library name (before the extension). -TCL_DBGX=@TCL_DBGX@ +# TCL_DBGX used to be used to distinguish debug vs. non-debug builds. +# This was a righteous pain so the core doesn't do that any more. +TCL_DBGX= # Default flags used in an optimized and debuggable build, respectively. TCL_CFLAGS_DEBUG='@CFLAGS_DEBUG@' TCL_CFLAGS_OPTIMIZE='@CFLAGS_OPTIMIZE@' Index: unix/tclLoadAix.c ================================================================== --- unix/tclLoadAix.c +++ unix/tclLoadAix.c @@ -1,28 +1,28 @@ /* * tclLoadAix.c -- * - * This file implements the dlopen and dlsym APIs under the - * AIX operating system, to enable the Tcl "load" command to - * work. This code was provided by Jens-Uwe Mager. + * This file implements the dlopen and dlsym APIs under the AIX operating + * system, to enable the Tcl "load" command to work. This code was + * provided by Jens-Uwe Mager. * * This file is subject to the following copyright notice, which is - * different from the notice used elsewhere in Tcl. The file has - * been modified to incorporate the file dlfcn.h in-line. + * different from the notice used elsewhere in Tcl. The file has been + * modified to incorporate the file dlfcn.h in-line. * * Copyright (c) 1992,1993,1995,1996, Jens-Uwe Mager, Helios Software GmbH * Not derived from licensed software. - + * * Permission is granted to freely use, copy, modify, and redistribute * this software, provided that the author is not construed to be liable * for any results of using the software, alterations are clearly marked * as such, and this notice is not modified. * - * RCS: @(#) $Id: tclLoadAix.c,v 1.3 1999/04/16 00:48:04 stanton Exp $ + * RCS: @(#) $Id: tclLoadAix.c,v 1.3.38.1 2005/08/02 18:16:54 dgp Exp $ * - * Note: this file has been altered from the original in a few - * ways in order to work properly with Tcl. + * Note: this file has been altered from the original in a few ways in order + * to work properly with Tcl. */ /* * @(#)dlfcn.c 1.7 revision of 95/08/14 19:08:38 * This is an unpublished work copyright (c) 1992 HELIOS Software GmbH @@ -38,512 +38,588 @@ #include #include #include "../compat/dlfcn.h" /* - * We simulate dlopen() et al. through a call to load. Because AIX has - * no call to find an exported symbol we read the loader section of the - * loaded module and build a list of exported symbols and their virtual - * address. + * We simulate dlopen() et al. through a call to load. Because AIX has no call + * to find an exported symbol we read the loader section of the loaded module + * and build a list of exported symbols and their virtual address. */ typedef struct { - char *name; /* the symbols's name */ - void *addr; /* its relocated virtual address */ + char *name; /* The symbols's name. */ + void *addr; /* Its relocated virtual address. */ } Export, *ExportPtr; /* - * xlC uses the following structure to list its constructors and - * destructors. This is gleaned from the output of munch. + * xlC uses the following structure to list its constructors and destructors. + * This is gleaned from the output of munch. */ + typedef struct { - void (*init)(void); /* call static constructors */ - void (*term)(void); /* call static destructors */ + void (*init)(void); /* call static constructors */ + void (*term)(void); /* call static destructors */ } Cdtor, *CdtorPtr; /* * The void * handle returned from dlopen is actually a ModulePtr. */ + typedef struct Module { - struct Module *next; - char *name; /* module name for refcounting */ - int refCnt; /* the number of references */ - void *entry; /* entry point from load */ - struct dl_info *info; /* optional init/terminate functions */ - CdtorPtr cdtors; /* optional C++ constructors */ - int nExports; /* the number of exports found */ - ExportPtr exports; /* the array of exports */ + struct Module *next; + char *name; /* module name for refcounting */ + int refCnt; /* the number of references */ + void *entry; /* entry point from load */ + struct dl_info *info; /* optional init/terminate functions */ + CdtorPtr cdtors; /* optional C++ constructors */ + int nExports; /* the number of exports found */ + ExportPtr exports; /* the array of exports */ } Module, *ModulePtr; /* - * We keep a list of all loaded modules to be able to call the fini - * handlers and destructors at atexit() time. + * We keep a list of all loaded modules to be able to call the fini handlers + * and destructors at atexit() time. */ + static ModulePtr modList; /* - * The last error from one of the dl* routines is kept in static - * variables here. Each error is returned only once to the caller. + * The last error from one of the dl* routines is kept in static variables + * here. Each error is returned only once to the caller. */ + static char errbuf[BUFSIZ]; static int errvalid; static void caterr(char *); static int readExports(ModulePtr); static void terminate(void); static void *findMain(void); - -VOID *dlopen(const char *path, int mode) -{ - register ModulePtr mp; - static void *mainModule; - - /* - * Upon the first call register a terminate handler that will - * close all libraries. Also get a reference to the main module - * for use with loadbind. - */ - if (!mainModule) { - if ((mainModule = findMain()) == NULL) - return NULL; - atexit(terminate); - } - /* - * Scan the list of modules if we have the module already loaded. - */ - for (mp = modList; mp; mp = mp->next) - if (strcmp(mp->name, path) == 0) { - mp->refCnt++; - return (VOID *) mp; - } - if ((mp = (ModulePtr)calloc(1, sizeof(*mp))) == NULL) { - errvalid++; - strcpy(errbuf, "calloc: "); - strcat(errbuf, strerror(errno)); - return (VOID *) NULL; - } - mp->name = malloc((unsigned) (strlen(path) + 1)); - strcpy(mp->name, path); - /* - * load should be declared load(const char *...). Thus we - * cast the path to a normal char *. Ugly. - */ - if ((mp->entry = (void *)load((char *)path, L_NOAUTODEFER, NULL)) == NULL) { - free(mp->name); - free(mp); - errvalid++; - strcpy(errbuf, "dlopen: "); - strcat(errbuf, path); - strcat(errbuf, ": "); - /* - * If AIX says the file is not executable, the error - * can be further described by querying the loader about - * the last error. - */ - if (errno == ENOEXEC) { - char *tmp[BUFSIZ/sizeof(char *)]; - if (loadquery(L_GETMESSAGES, tmp, sizeof(tmp)) == -1) - strcpy(errbuf, strerror(errno)); - else { - char **p; - for (p = tmp; *p; p++) - caterr(*p); - } - } else - strcat(errbuf, strerror(errno)); - return (VOID *) NULL; - } - mp->refCnt = 1; - mp->next = modList; - modList = mp; - if (loadbind(0, mainModule, mp->entry) == -1) { - dlclose(mp); - errvalid++; - strcpy(errbuf, "loadbind: "); - strcat(errbuf, strerror(errno)); - return (VOID *) NULL; - } - /* - * If the user wants global binding, loadbind against all other - * loaded modules. - */ - if (mode & RTLD_GLOBAL) { - register ModulePtr mp1; - for (mp1 = mp->next; mp1; mp1 = mp1->next) - if (loadbind(0, mp1->entry, mp->entry) == -1) { - dlclose(mp); - errvalid++; - strcpy(errbuf, "loadbind: "); - strcat(errbuf, strerror(errno)); - return (VOID *) NULL; - } - } - if (readExports(mp) == -1) { - dlclose(mp); - return (VOID *) NULL; - } - /* - * If there is a dl_info structure, call the init function. - */ - if (mp->info = (struct dl_info *)dlsym(mp, "dl_info")) { - if (mp->info->init) - (*mp->info->init)(); - } else - errvalid = 0; - /* - * If the shared object was compiled using xlC we will need - * to call static constructors (and later on dlclose destructors). - */ - if (mp->cdtors = (CdtorPtr)dlsym(mp, "__cdtors")) { - while (mp->cdtors->init) { - (*mp->cdtors->init)(); - mp->cdtors++; - } - } else - errvalid = 0; - return (VOID *) mp; -} - -/* - * Attempt to decipher an AIX loader error message and append it - * to our static error message buffer. - */ -static void caterr(char *s) -{ - register char *p = s; - - while (*p >= '0' && *p <= '9') - p++; - switch(atoi(s)) { /* INTL: "C", UTF safe. */ - case L_ERROR_TOOMANY: - strcat(errbuf, "to many errors"); - break; - case L_ERROR_NOLIB: - strcat(errbuf, "can't load library"); - strcat(errbuf, p); - break; - case L_ERROR_UNDEF: - strcat(errbuf, "can't find symbol"); - strcat(errbuf, p); - break; - case L_ERROR_RLDBAD: - strcat(errbuf, "bad RLD"); - strcat(errbuf, p); - break; - case L_ERROR_FORMAT: - strcat(errbuf, "bad exec format in"); - strcat(errbuf, p); - break; - case L_ERROR_ERRNO: - strcat(errbuf, strerror(atoi(++p))); /* INTL: "C", UTF safe. */ - break; - default: - strcat(errbuf, s); - break; - } -} - -VOID *dlsym(void *handle, const char *symbol) -{ - register ModulePtr mp = (ModulePtr)handle; - register ExportPtr ep; - register int i; - - /* - * Could speed up the search, but I assume that one assigns - * the result to function pointers anyways. - */ - for (ep = mp->exports, i = mp->nExports; i; i--, ep++) - if (strcmp(ep->name, symbol) == 0) - return ep->addr; - errvalid++; - strcpy(errbuf, "dlsym: undefined symbol "); - strcat(errbuf, symbol); - return NULL; -} - -char *dlerror(void) -{ - if (errvalid) { - errvalid = 0; - return errbuf; - } - return NULL; -} - -int dlclose(void *handle) -{ - register ModulePtr mp = (ModulePtr)handle; - int result; - register ModulePtr mp1; - - if (--mp->refCnt > 0) - return 0; - if (mp->info && mp->info->fini) - (*mp->info->fini)(); - if (mp->cdtors) - while (mp->cdtors->term) { - (*mp->cdtors->term)(); - mp->cdtors++; - } - result = unload(mp->entry); - if (result == -1) { - errvalid++; - strcpy(errbuf, strerror(errno)); - } - if (mp->exports) { - register ExportPtr ep; - register int i; - for (ep = mp->exports, i = mp->nExports; i; i--, ep++) - if (ep->name) - free(ep->name); - free(mp->exports); - } - if (mp == modList) - modList = mp->next; - else { - for (mp1 = modList; mp1; mp1 = mp1->next) - if (mp1->next == mp) { - mp1->next = mp->next; - break; - } - } - free(mp->name); - free(mp); - return result; -} - -static void terminate(void) -{ - while (modList) - dlclose(modList); -} - + +VOID * +dlopen(const char *path, int mode) +{ + register ModulePtr mp; + static void *mainModule; + + /* + * Upon the first call register a terminate handler that will close all + * libraries. Also get a reference to the main module for use with + * loadbind. + */ + + if (!mainModule) { + mainModule = findMain(); + if (mainModule == NULL) { + return NULL; + } + atexit(terminate); + } + + /* + * Scan the list of modules if we have the module already loaded. + */ + + for (mp = modList; mp; mp = mp->next) { + if (strcmp(mp->name, path) == 0) { + mp->refCnt++; + return (VOID *) mp; + } + } + + mp = (ModulePtr) calloc(1, sizeof(*mp)); + if (mp == NULL) { + errvalid++; + strcpy(errbuf, "calloc: "); + strcat(errbuf, strerror(errno)); + return (VOID *) NULL; + } + + mp->name = malloc((unsigned) (strlen(path) + 1)); + strcpy(mp->name, path); + + /* + * load should be declared load(const char *...). Thus we cast the path to + * a normal char *. Ugly. + */ + + mp->entry = (void *) load((char *)path, L_NOAUTODEFER, NULL); + if (mp->entry == NULL) { + free(mp->name); + free(mp); + errvalid++; + strcpy(errbuf, "dlopen: "); + strcat(errbuf, path); + strcat(errbuf, ": "); + + /* + * If AIX says the file is not executable, the error can be further + * described by querying the loader about the last error. + */ + + if (errno == ENOEXEC) { + char *tmp[BUFSIZ/sizeof(char *)], **p; + + if (loadquery(L_GETMESSAGES, tmp, sizeof(tmp)) == -1) { + strcpy(errbuf, strerror(errno)); + } else { + for (p=tmp ; *p ; p++) { + caterr(*p); + } + } + } else { + strcat(errbuf, strerror(errno)); + } + return (VOID *) NULL; + } + + mp->refCnt = 1; + mp->next = modList; + modList = mp; + + if (loadbind(0, mainModule, mp->entry) == -1) { + loadbindFailure: + dlclose(mp); + errvalid++; + strcpy(errbuf, "loadbind: "); + strcat(errbuf, strerror(errno)); + return (VOID *) NULL; + } + + /* + * If the user wants global binding, loadbind against all other loaded + * modules. + */ + + if (mode & RTLD_GLOBAL) { + register ModulePtr mp1; + + for (mp1 = mp->next; mp1; mp1 = mp1->next) { + if (loadbind(0, mp1->entry, mp->entry) == -1) { + goto loadbindFailure; + } + } + } + + if (readExports(mp) == -1) { + dlclose(mp); + return (VOID *) NULL; + } + + /* + * If there is a dl_info structure, call the init function. + */ + + if (mp->info = (struct dl_info *)dlsym(mp, "dl_info")) { + if (mp->info->init) { + (*mp->info->init)(); + } + } else { + errvalid = 0; + } + + /* + * If the shared object was compiled using xlC we will need to call static + * constructors (and later on dlclose destructors). + */ + + if (mp->cdtors = (CdtorPtr) dlsym(mp, "__cdtors")) { + while (mp->cdtors->init) { + (*mp->cdtors->init)(); + mp->cdtors++; + } + } else { + errvalid = 0; + } + + return (VOID *) mp; +} + +/* + * Attempt to decipher an AIX loader error message and append it to our static + * error message buffer. + */ + +static void +caterr(char *s) +{ + register char *p = s; + + while (*p >= '0' && *p <= '9') { + p++; + } + switch (atoi(s)) { /* INTL: "C", UTF safe. */ + case L_ERROR_TOOMANY: + strcat(errbuf, "to many errors"); + break; + case L_ERROR_NOLIB: + strcat(errbuf, "can't load library"); + strcat(errbuf, p); + break; + case L_ERROR_UNDEF: + strcat(errbuf, "can't find symbol"); + strcat(errbuf, p); + break; + case L_ERROR_RLDBAD: + strcat(errbuf, "bad RLD"); + strcat(errbuf, p); + break; + case L_ERROR_FORMAT: + strcat(errbuf, "bad exec format in"); + strcat(errbuf, p); + break; + case L_ERROR_ERRNO: + strcat(errbuf, strerror(atoi(++p))); /* INTL: "C", UTF safe. */ + break; + default: + strcat(errbuf, s); + break; + } +} + +VOID * +dlsym(void *handle, const char *symbol) +{ + register ModulePtr mp = (ModulePtr)handle; + register ExportPtr ep; + register int i; + + /* + * Could speed up the search, but I assume that one assigns the result to + * function pointers anyways. + */ + + for (ep = mp->exports, i = mp->nExports; i; i--, ep++) { + if (strcmp(ep->name, symbol) == 0) { + return ep->addr; + } + } + + errvalid++; + strcpy(errbuf, "dlsym: undefined symbol "); + strcat(errbuf, symbol); + return NULL; +} + +char * +dlerror(void) +{ + if (errvalid) { + errvalid = 0; + return errbuf; + } + return NULL; +} + +int +dlclose(void *handle) +{ + register ModulePtr mp = (ModulePtr)handle; + int result; + register ModulePtr mp1; + + if (--mp->refCnt > 0) { + return 0; + } + + if (mp->info && mp->info->fini) { + (*mp->info->fini)(); + } + + if (mp->cdtors) { + while (mp->cdtors->term) { + (*mp->cdtors->term)(); + mp->cdtors++; + } + } + + result = unload(mp->entry); + if (result == -1) { + errvalid++; + strcpy(errbuf, strerror(errno)); + } + + if (mp->exports) { + register ExportPtr ep; + register int i; + for (ep = mp->exports, i = mp->nExports; i; i--, ep++) { + if (ep->name) { + free(ep->name); + } + } + free(mp->exports); + } + + if (mp == modList) { + modList = mp->next; + } else { + for (mp1 = modList; mp1; mp1 = mp1->next) { + if (mp1->next == mp) { + mp1->next = mp->next; + break; + } + } + } + + free(mp->name); + free(mp); + return result; +} + +static void +terminate(void) +{ + while (modList) { + dlclose(modList); + } +} + /* * Build the export table from the XCOFF .loader section. */ -static int readExports(ModulePtr mp) -{ - LDFILE *ldp = NULL; - SCNHDR sh, shdata; - LDHDR *lhp; - char *ldbuf; - LDSYM *ls; - int i; - ExportPtr ep; - - if ((ldp = ldopen(mp->name, ldp)) == NULL) { - struct ld_info *lp; - char *buf; - int size = 4*1024; - if (errno != ENOENT) { - errvalid++; - strcpy(errbuf, "readExports: "); - strcat(errbuf, strerror(errno)); - return -1; - } - /* - * The module might be loaded due to the LIBPATH - * environment variable. Search for the loaded - * module using L_GETINFO. - */ - if ((buf = malloc(size)) == NULL) { - errvalid++; - strcpy(errbuf, "readExports: "); - strcat(errbuf, strerror(errno)); - return -1; - } - while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) { - free(buf); - size += 4*1024; - if ((buf = malloc(size)) == NULL) { - errvalid++; - strcpy(errbuf, "readExports: "); - strcat(errbuf, strerror(errno)); - return -1; - } - } - if (i == -1) { - errvalid++; - strcpy(errbuf, "readExports: "); - strcat(errbuf, strerror(errno)); - free(buf); - return -1; - } - /* - * Traverse the list of loaded modules. The entry point - * returned by load() does actually point to the data - * segment origin. - */ - lp = (struct ld_info *)buf; - while (lp) { - if (lp->ldinfo_dataorg == mp->entry) { - ldp = ldopen(lp->ldinfo_filename, ldp); - break; - } - if (lp->ldinfo_next == 0) - lp = NULL; - else - lp = (struct ld_info *)((char *)lp + lp->ldinfo_next); - } - free(buf); - if (!ldp) { - errvalid++; - strcpy(errbuf, "readExports: "); - strcat(errbuf, strerror(errno)); - return -1; - } - } - if (TYPE(ldp) != U802TOCMAGIC) { - errvalid++; - strcpy(errbuf, "readExports: bad magic"); - while(ldclose(ldp) == FAILURE) - ; - return -1; - } - /* - * Get the padding for the data section. This is needed for - * AIX 4.1 compilers. This is used when building the final - * function pointer to the exported symbol. - */ - if (ldnshread(ldp, _DATA, &shdata) != SUCCESS) { - errvalid++; - strcpy(errbuf, "readExports: cannot read data section header"); - while(ldclose(ldp) == FAILURE) - ; - return -1; - } - if (ldnshread(ldp, _LOADER, &sh) != SUCCESS) { - errvalid++; - strcpy(errbuf, "readExports: cannot read loader section header"); - while(ldclose(ldp) == FAILURE) - ; - return -1; - } - /* - * We read the complete loader section in one chunk, this makes - * finding long symbol names residing in the string table easier. - */ - if ((ldbuf = (char *)malloc(sh.s_size)) == NULL) { - errvalid++; - strcpy(errbuf, "readExports: "); - strcat(errbuf, strerror(errno)); - while(ldclose(ldp) == FAILURE) - ; - return -1; - } - if (FSEEK(ldp, sh.s_scnptr, BEGINNING) != OKFSEEK) { - errvalid++; - strcpy(errbuf, "readExports: cannot seek to loader section"); - free(ldbuf); - while(ldclose(ldp) == FAILURE) - ; - return -1; - } - if (FREAD(ldbuf, sh.s_size, 1, ldp) != 1) { - errvalid++; - strcpy(errbuf, "readExports: cannot read loader section"); - free(ldbuf); - while(ldclose(ldp) == FAILURE) - ; - return -1; - } - lhp = (LDHDR *)ldbuf; - ls = (LDSYM *)(ldbuf+LDHDRSZ); - /* - * Count the number of exports to include in our export table. - */ - for (i = lhp->l_nsyms; i; i--, ls++) { - if (!LDR_EXPORT(*ls)) - continue; - mp->nExports++; - } - if ((mp->exports = (ExportPtr)calloc(mp->nExports, sizeof(*mp->exports))) == NULL) { - errvalid++; - strcpy(errbuf, "readExports: "); - strcat(errbuf, strerror(errno)); - free(ldbuf); - while(ldclose(ldp) == FAILURE) - ; - return -1; - } - /* - * Fill in the export table. All entries are relative to - * the entry point we got from load. - */ - ep = mp->exports; - ls = (LDSYM *)(ldbuf+LDHDRSZ); - for (i = lhp->l_nsyms; i; i--, ls++) { - char *symname; - char tmpsym[SYMNMLEN+1]; - if (!LDR_EXPORT(*ls)) - continue; - if (ls->l_zeroes == 0) - symname = ls->l_offset+lhp->l_stoff+ldbuf; - else { - /* - * The l_name member is not zero terminated, we - * must copy the first SYMNMLEN chars and make - * sure we have a zero byte at the end. - */ - strncpy(tmpsym, ls->l_name, SYMNMLEN); - tmpsym[SYMNMLEN] = '\0'; - symname = tmpsym; - } - ep->name = malloc((unsigned) (strlen(symname) + 1)); - strcpy(ep->name, symname); - ep->addr = (void *)((unsigned long)mp->entry + - ls->l_value - shdata.s_vaddr); - ep++; - } - free(ldbuf); - while(ldclose(ldp) == FAILURE) - ; - return 0; -} - -/* - * Find the main modules entry point. This is used as export pointer - * for loadbind() to be able to resolve references to the main part. - */ -static void * findMain(void) -{ - struct ld_info *lp; - char *buf; - int size = 4*1024; - int i; - void *ret; - - if ((buf = malloc(size)) == NULL) { - errvalid++; - strcpy(errbuf, "findMain: "); - strcat(errbuf, strerror(errno)); - return NULL; - } - while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) { - free(buf); - size += 4*1024; - if ((buf = malloc(size)) == NULL) { - errvalid++; - strcpy(errbuf, "findMain: "); - strcat(errbuf, strerror(errno)); - return NULL; - } - } - if (i == -1) { - errvalid++; - strcpy(errbuf, "findMain: "); - strcat(errbuf, strerror(errno)); - free(buf); - return NULL; - } - /* - * The first entry is the main module. The entry point - * returned by load() does actually point to the data - * segment origin. - */ - lp = (struct ld_info *)buf; - ret = lp->ldinfo_dataorg; - free(buf); - return ret; -} - + +static int +readExports(ModulePtr mp) +{ + LDFILE *ldp = NULL; + SCNHDR sh, shdata; + LDHDR *lhp; + char *ldbuf; + LDSYM *ls; + int i; + ExportPtr ep; + const char *errMsg; + +#define Error(msg) do{errMsg=(msg);goto error;}while(0) +#define SysErr() Error(strerror(errno)) + + ldp = ldopen(mp->name, ldp); + if (ldp == NULL) { + struct ld_info *lp; + char *buf; + int size = 0; + + if (errno != ENOENT) { + SysErr(); + } + + /* + * The module might be loaded due to the LIBPATH environment variable. + * Search for the loaded module using L_GETINFO. + */ + + while (1) { + size += 4 * 1024; + buf = malloc(size); + if (buf == NULL) { + SysErr(); + } + + i = loadquery(L_GETINFO, buf, size); + + if (i != -1) { + break; + } + free(buf); + if (errno != ENOMEM) { + SysErr(); + } + } + + /* + * Traverse the list of loaded modules. The entry point returned by + * load() does actually point to the data segment origin. + */ + + lp = (struct ld_info *) buf; + while (lp) { + if (lp->ldinfo_dataorg == mp->entry) { + ldp = ldopen(lp->ldinfo_filename, ldp); + break; + } + if (lp->ldinfo_next == 0) { + lp = NULL; + } else { + lp = (struct ld_info *)((char *)lp + lp->ldinfo_next); + } + } + + free(buf); + + if (!ldp) { + SysErr(); + } + } + + if (TYPE(ldp) != U802TOCMAGIC) { + Error("bad magic"); + } + + /* + * Get the padding for the data section. This is needed for AIX 4.1 + * compilers. This is used when building the final function pointer to the + * exported symbol. + */ + + if (ldnshread(ldp, _DATA, &shdata) != SUCCESS) { + Error("cannot read data section header"); + } + + if (ldnshread(ldp, _LOADER, &sh) != SUCCESS) { + Error("cannot read loader section header"); + } + + /* + * We read the complete loader section in one chunk, this makes finding + * long symbol names residing in the string table easier. + */ + + ldbuf = (char *) malloc(sh.s_size); + if (ldbuf == NULL) { + SysErr(); + } + + if (FSEEK(ldp, sh.s_scnptr, BEGINNING) != OKFSEEK) { + free(ldbuf); + Error("cannot seek to loader section"); + } + + if (FREAD(ldbuf, sh.s_size, 1, ldp) != 1) { + free(ldbuf); + Error("cannot read loader section"); + } + + lhp = (LDHDR *) ldbuf; + ls = (LDSYM *)(ldbuf + LDHDRSZ); + + /* + * Count the number of exports to include in our export table. + */ + + for (i = lhp->l_nsyms; i; i--, ls++) { + if (!LDR_EXPORT(*ls)) { + continue; + } + mp->nExports++; + } + + mp->exports = (ExportPtr) calloc(mp->nExports, sizeof(*mp->exports)); + if (mp->exports == NULL) { + free(ldbuf); + SysErr(); + } + + /* + * Fill in the export table. All entries are relative to the entry point + * we got from load. + */ + + ep = mp->exports; + ls = (LDSYM *)(ldbuf + LDHDRSZ); + for (i=lhp->l_nsyms ; i!=0 ; i--,ls++) { + char *symname; + char tmpsym[SYMNMLEN+1]; + + if (!LDR_EXPORT(*ls)) { + continue; + } + + if (ls->l_zeroes == 0) { + symname = ls->l_offset + lhp->l_stoff + ldbuf; + } else { + /* + * The l_name member is not zero terminated, we must copy the + * first SYMNMLEN chars and make sure we have a zero byte at the + * end. + */ + + strncpy(tmpsym, ls->l_name, SYMNMLEN); + tmpsym[SYMNMLEN] = '\0'; + symname = tmpsym; + } + ep->name = malloc((unsigned) (strlen(symname) + 1)); + strcpy(ep->name, symname); + ep->addr = (void *)((unsigned long) + mp->entry + ls->l_value - shdata.s_vaddr); + ep++; + } + free(ldbuf); + while (ldclose(ldp) == FAILURE) { + /* Empty body */ + } + return 0; + + /* + * This is a factoring out of the error-handling code to make the rest of + * the function much simpler to read. + */ + + error: + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, errMsg); + + if (ldp != NULL) { + while (ldclose(ldp) == FAILURE) { + /* Empty body */ + } + } + return -1; +} + +/* + * Find the main modules entry point. This is used as export pointer for + * loadbind() to be able to resolve references to the main part. + */ + +static void * +findMain(void) +{ + struct ld_info *lp; + char *buf; + int size = 4*1024; + int i; + void *ret; + + buf = malloc(size); + if (buf == NULL) { + goto error; + } + + while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) { + free(buf); + size += 4*1024; + buf = malloc(size); + if (buf == NULL) { + goto error; + } + } + + if (i == -1) { + free(buf); + goto error; + } + + /* + * The first entry is the main module. The entry point returned by load() + * does actually point to the data segment origin. + */ + + lp = (struct ld_info *) buf; + ret = lp->ldinfo_dataorg; + free(buf); + return ret; + + error: + errvalid++; + strcpy(errbuf, "findMain: "); + strcat(errbuf, strerror(errno)); + return NULL; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ DELETED unix/tclLoadAout.c Index: unix/tclLoadAout.c ================================================================== --- unix/tclLoadAout.c +++ /dev/null @@ -1,536 +0,0 @@ -/* - * tclLoadAout.c -- - * - * This procedure provides a version of the TclLoadFile that - * provides pseudo-static linking using version-7 compatible - * a.out files described in either sys/exec.h or sys/a.out.h. - * - * Copyright (c) 1995, by General Electric Company. All rights reserved. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * This work was supported in part by the ARPA Manufacturing Automation - * and Design Engineering (MADE) Initiative through ARPA contract - * F33615-94-C-4400. - * - * RCS: @(#) $Id: tclLoadAout.c,v 1.14 2002/10/10 12:25:53 vincentdarley Exp $ - */ - -#include "tclInt.h" -#include -#ifdef HAVE_EXEC_AOUT_H -# include -#endif -#ifdef HAVE_UNISTD_H -# include -#else -# include "../compat/unistd.h" -#endif - -/* - * Some systems describe the a.out header in sys/exec.h, and some in - * a.out.h. - */ - -#ifdef USE_SYS_EXEC_H -#include -#endif -#ifdef USE_A_OUT_H -#include -#endif -#ifdef USE_SYS_EXEC_AOUT_H -#include -#define a_magic a_midmag -#endif - -/* - * TCL_LOADSHIM is the amount by which to shim the break when loading - */ - -#ifndef TCL_LOADSHIM -#define TCL_LOADSHIM 0x4000L -#endif - -/* - * TCL_LOADALIGN must be a power of 2, and is the alignment to which - * to force the origin of load modules - */ - -#ifndef TCL_LOADALIGN -#define TCL_LOADALIGN 0x4000L -#endif - -/* - * TCL_LOADMAX is the maximum size of a load module, and is used as - * a sanity check when loading - */ - -#ifndef TCL_LOADMAX -#define TCL_LOADMAX 2000000L -#endif - -/* - * Kernel calls that appear to be missing from the system .h files: - */ - -extern char * brk _ANSI_ARGS_((char *)); -extern char * sbrk _ANSI_ARGS_((size_t)); - -/* - * The static variable SymbolTableFile contains the file name where the - * result of the last link was stored. The file is kept because doing so - * allows one load module to use the symbols defined in another. - */ - -static char * SymbolTableFile = NULL; - -/* - * Type of the dictionary function that begins each load module. - */ - -typedef Tcl_PackageInitProc * (* DictFn) _ANSI_ARGS_ ((CONST char * symbol)); - -/* - * Prototypes for procedures referenced only in this file: - */ - -static int FindLibraries _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, - Tcl_DString * buf)); -static void UnlinkSymbolTable _ANSI_ARGS_((void)); - -/* - *---------------------------------------------------------------------- - * - * TclpDlopen -- - * - * Dynamically loads a binary code file into memory and returns - * a handle to the new code. - * - * Results: - * A standard Tcl completion code. If an error occurs, an error - * message is left in the interp's result. - * - * Side effects: - * New code suddenly appears in memory. - * - * - * Bugs: - * This function does not attempt to handle the case where the - * BSS segment is not executable. It will therefore fail on - * Encore Multimax, Pyramid 90x, and similar machines. The - * reason is that the mprotect() kernel call, which would - * otherwise be employed to mark the newly-loaded text segment - * executable, results in a system crash on BSD/386. - * - * In an effort to make it fast, this function eschews the - * technique of linking the load module once, reading its header - * to determine its size, allocating memory for it, and linking - * it again. Instead, it `shims out' memory allocation by - * placing the module TCL_LOADSHIM bytes beyond the break, - * and assuming that any malloc() calls required to run the - * linker will not advance the break beyond that point. If - * the break is advanced beyonnd that point, the load will - * fail with an `inconsistent memory allocation' error. - * It perhaps ought to retry the link, but the failure has - * not been observed in two years of daily use of this function. - *---------------------------------------------------------------------- - */ - -int -TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Obj *pathPtr; /* Name of the file containing the desired - * code (UTF-8). */ - Tcl_LoadHandle *loadHandle; /* Filled with token for dynamically loaded - * file which will be passed back to - * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr; - /* Filled with address of Tcl_FSUnloadFileProc - * function which should be used for - * this file. */ -{ - char * inputSymbolTable; /* Name of the file containing the - * symbol table from the last link. */ - Tcl_DString linkCommandBuf; /* Command to do the run-time relocation - * of the module.*/ - char * linkCommand; - char relocatedFileName [L_tmpnam]; - /* Name of the file holding the relocated */ - /* text of the module */ - int relocatedFd; /* File descriptor of the file holding - * relocated text */ - struct exec relocatedHead; /* Header of the relocated text */ - unsigned long relocatedSize;/* Size of the relocated text */ - char * startAddress; /* Starting address of the module */ - int status; /* Status return from Tcl_ calls */ - char * p; - - /* Find the file that contains the symbols for the run-time link. */ - - if (SymbolTableFile != NULL) { - inputSymbolTable = SymbolTableFile; - } else if (tclExecutableName == NULL) { - Tcl_SetResult (interp, "can't find the tclsh executable", TCL_STATIC); - return TCL_ERROR; - } else { - inputSymbolTable = tclExecutableName; - } - - /* Construct the `ld' command that builds the relocated module */ - - tmpnam (relocatedFileName); - Tcl_DStringInit (&linkCommandBuf); - Tcl_DStringAppend (&linkCommandBuf, "exec ld -o ", -1); - Tcl_DStringAppend (&linkCommandBuf, relocatedFileName, -1); -#if defined(__mips) || defined(mips) - Tcl_DStringAppend (&linkCommandBuf, " -G 0 ", -1); -#endif - Tcl_DStringAppend (&linkCommandBuf, " -u TclLoadDictionary_", -1); - TclGuessPackageName(Tcl_GetString(pathPtr), &linkCommandBuf); - Tcl_DStringAppend (&linkCommandBuf, " -A ", -1); - Tcl_DStringAppend (&linkCommandBuf, inputSymbolTable, -1); - Tcl_DStringAppend (&linkCommandBuf, " -N -T XXXXXXXX ", -1); - Tcl_DStringAppend (&linkCommandBuf, Tcl_GetString(pathPtr), -1); - Tcl_DStringAppend (&linkCommandBuf, " ", -1); - - if (FindLibraries (interp, pathPtr, &linkCommandBuf) != TCL_OK) { - Tcl_DStringFree (&linkCommandBuf); - return TCL_ERROR; - } - - linkCommand = Tcl_DStringValue (&linkCommandBuf); - - /* Determine the starting address, and plug it into the command */ - - startAddress = (char *) (((unsigned long) sbrk (0) - + TCL_LOADSHIM + TCL_LOADALIGN - 1) - & (- TCL_LOADALIGN)); - p = strstr (linkCommand, "-T") + 3; - sprintf (p, "%08lx", (long) startAddress); - p [8] = ' '; - - /* Run the linker */ - - status = Tcl_Eval (interp, linkCommand); - Tcl_DStringFree (&linkCommandBuf); - if (status != 0) { - return TCL_ERROR; - } - - /* Open the linker's result file and read the header */ - - relocatedFd = open (relocatedFileName, O_RDONLY); - if (relocatedFd < 0) { - goto ioError; - } - status= read (relocatedFd, (char *) & relocatedHead, sizeof relocatedHead); - if (status < sizeof relocatedHead) { - goto ioError; - } - - /* Check the magic number */ - - if (relocatedHead.a_magic != OMAGIC) { - Tcl_AppendResult (interp, "bad magic number in intermediate file \"", - relocatedFileName, "\"", (char *) NULL); - goto failure; - } - - /* Make sure that memory allocation is still consistent */ - - if ((unsigned long) sbrk (0) > (unsigned long) startAddress) { - Tcl_SetResult (interp, "can't load, memory allocation is inconsistent.", - TCL_STATIC); - goto failure; - } - - /* Make sure that the relocated module's size is reasonable */ - - relocatedSize = relocatedHead.a_text + relocatedHead.a_data - + relocatedHead.a_bss; - if (relocatedSize > TCL_LOADMAX) { - Tcl_SetResult (interp, "module too big to load", TCL_STATIC); - goto failure; - } - - /* Advance the break to protect the loaded module */ - - (void) brk (startAddress + relocatedSize); - - /* - * Seek to the start of the module's text. - * - * Note that this does not really work with large files (i.e. where - * lseek64 exists and is different to lseek), but anyone trying to - * dynamically load a binary that is larger than what can fit in - * addressable memory is in trouble anyway... - */ - -#if defined(__mips) || defined(mips) - status = lseek (relocatedFd, - (off_t) N_TXTOFF (relocatedHead.ex_f, relocatedHead.ex_o), - SEEK_SET); -#else - status = lseek (relocatedFd, (off_t) N_TXTOFF (relocatedHead), SEEK_SET); -#endif - if (status < 0) { - goto ioError; - } - - /* Read in the module's text and data */ - - relocatedSize = relocatedHead.a_text + relocatedHead.a_data; - if (read (relocatedFd, startAddress, relocatedSize) < relocatedSize) { - brk (startAddress); - ioError: - Tcl_AppendResult (interp, "error on intermediate file \"", - relocatedFileName, "\": ", Tcl_PosixError (interp), - (char *) NULL); - failure: - (void) unlink (relocatedFileName); - return TCL_ERROR; - } - - /* Close the intermediate file. */ - - (void) close (relocatedFd); - - /* Arrange things so that intermediate symbol tables eventually get - * deleted. */ - - if (SymbolTableFile != NULL) { - UnlinkSymbolTable (); - } else { - atexit (UnlinkSymbolTable); - } - SymbolTableFile = ckalloc (strlen (relocatedFileName) + 1); - strcpy (SymbolTableFile, relocatedFileName); - - *loadHandle = startAddress; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclpFindSymbol -- - * - * Looks up a symbol, by name, through a handle associated with - * a previously loaded piece of code (shared library). - * - * Results: - * Returns a pointer to the function associated with 'symbol' if - * it is found. Otherwise returns NULL and may leave an error - * message in the interp's result. - * - *---------------------------------------------------------------------- - */ -Tcl_PackageInitProc* -TclpFindSymbol(interp, loadHandle, symbol) - Tcl_Interp *interp; - Tcl_LoadHandle loadHandle; - CONST char *symbol; -{ - /* Look up the entry point in the load module's dictionary. */ - DictFn dictionary = (DictFn) loadHandle; - return (Tcl_PackageInitProc*) dictionary(sym1); -} - - -/* - *------------------------------------------------------------------------ - * - * FindLibraries -- - * - * Find the libraries needed to link a load module at run time. - * - * Results: - * A standard Tcl completion code. If an error occurs, - * an error message is left in the interp's result. The -l and -L - * flags are concatenated onto the dynamic string `buf'. - * - *------------------------------------------------------------------------ - */ - -static int -FindLibraries (interp, pathPtr, buf) - Tcl_Interp * interp; /* Used for error reporting */ - Tcl_Obj * pathPtr; /* Name of the load module */ - Tcl_DString * buf; /* Buffer where the -l an -L flags */ -{ - FILE * f; /* The load module */ - int c = 0; /* Byte from the load module */ - char * p; - CONST char *native; - - char *fileName = Tcl_GetString(pathPtr); - - /* Open the load module */ - - native = Tcl_FSGetNativePath(pathPtr); - f = fopen(native, "rb"); /* INTL: Native. */ - - if (f == NULL) { - Tcl_AppendResult (interp, "couldn't open \"", fileName, "\": ", - Tcl_PosixError (interp), (char *) NULL); - return TCL_ERROR; - } - - /* Search for the library list in the load module */ - - p = "@LIBS: "; - while (*p != '\0' && (c = getc (f)) != EOF) { - if (c == *p) { - ++p; - } - else { - p = "@LIBS: "; - if (c == *p) { - ++p; - } - } - } - - /* No library list -- this must be an ill-formed module */ - - if (c == EOF) { - Tcl_AppendResult (interp, "File \"", fileName, - "\" is not a Tcl load module.", (char *) NULL); - (void) fclose (f); - return TCL_ERROR; - } - - /* Accumulate the library list */ - - while ((c = getc (f)) != '\0' && c != EOF) { - char cc = c; - Tcl_DStringAppend (buf, &cc, 1); - } - (void) fclose (f); - - if (c == EOF) { - Tcl_AppendResult (interp, "Library directory in \"", fileName, - "\" ends prematurely.", (char *) NULL); - return TCL_ERROR; - } - - return TCL_OK; -} - -/* - *------------------------------------------------------------------------ - * - * UnlinkSymbolTable -- - * - * Remove the symbol table file from the last dynamic link. - * - * Results: - * None. - * - * Side effects: - * The symbol table file from the last dynamic link is removed. - * This function is called when (a) a new symbol table is present - * because another dynamic link is complete, or (b) the process - * is exiting. - *------------------------------------------------------------------------ - */ - -static void -UnlinkSymbolTable () -{ - (void) unlink (SymbolTableFile); - ckfree (SymbolTableFile); - SymbolTableFile = NULL; -} - -/* - *---------------------------------------------------------------------- - * - * TclpUnloadFile -- - * - * Unloads a dynamically loaded binary code file from memory. - * Code pointers in the formerly loaded file are no longer valid - * after calling this function. - * - * Results: - * None. - * - * Side effects: - * Does nothing. Can anything be done? - * - *---------------------------------------------------------------------- - */ - -void -TclpUnloadFile(loadHandle) - Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call - * to TclpDlopen(). The loadHandle is - * a token that represents the loaded - * file. */ -{ -} - -/* - *---------------------------------------------------------------------- - * - * TclGuessPackageName -- - * - * If the "load" command is invoked without providing a package - * name, this procedure is invoked to try to figure it out. - * - * Results: - * Always returns 0 to indicate that we couldn't figure out a - * package name; generic code will then try to guess the package - * from the file name. A return value of 1 would have meant that - * we figured out the package name and put it in bufPtr. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclGuessPackageName(fileName, bufPtr) - CONST char *fileName; /* Name of file containing package (already - * translated to local form if needed). */ - Tcl_DString *bufPtr; /* Initialized empty dstring. Append - * package name to this if possible. */ -{ - CONST char *p, *q; - char *r; - - if ((q = strrchr(fileName,'/'))) { - q++; - } else { - q = fileName; - } - if (!strncmp(q,"lib",3)) { - q+=3; - } - p = q; - while ((*p) && (*p != '.') && ((*p<'0') || (*p>'9'))) { - p++; - } - if ((p>q+2) && !strncmp(p-2,"_G0.",4)) { - p-=2; - } - if (p #endif /* - * In some systems, like SunOS 4.1.3, the RTLD_NOW flag isn't defined - * and this argument to dlopen must always be 1. The RTLD_GLOBAL - * flag is needed on some systems (e.g. SCO and UnixWare) but doesn't - * exist on others; if it doesn't exist, set it to 0 so it has no effect. + * In some systems, like SunOS 4.1.3, the RTLD_NOW flag isn't defined and this + * argument to dlopen must always be 1. The RTLD_GLOBAL flag is needed on some + * systems (e.g. SCO and UnixWare) but doesn't exist on others; if it doesn't + * exist, set it to 0 so it has no effect. */ #ifndef RTLD_NOW # define RTLD_NOW 1 #endif @@ -38,16 +37,16 @@ /* *--------------------------------------------------------------------------- * * TclpDlopen -- * - * Dynamically loads a binary code file into memory and returns - * a handle to the new code. + * Dynamically loads a binary code file into memory and returns a handle + * to the new code. * * Results: - * A standard Tcl completion code. If an error occurs, an error - * message is left in the interp's result. + * A standard Tcl completion code. If an error occurs, an error message + * is left in the interp's result. * * Side effects: * New code suddenly appears in memory. * *--------------------------------------------------------------------------- @@ -57,44 +56,46 @@ TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr) Tcl_Interp *interp; /* Used for error reporting. */ Tcl_Obj *pathPtr; /* Name of the file containing the desired * code (UTF-8). */ Tcl_LoadHandle *loadHandle; /* Filled with token for dynamically loaded - * file which will be passed back to + * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr; + Tcl_FSUnloadFileProc **unloadProcPtr; /* Filled with address of Tcl_FSUnloadFileProc - * function which should be used for - * this file. */ + * function which should be used for this + * file. */ { VOID *handle; CONST char *native; - /* - * First try the full path the user gave us. This is particularly - * important if the cwd is inside a vfs, and we are trying to load - * using a relative path. + /* + * First try the full path the user gave us. This is particularly + * important if the cwd is inside a vfs, and we are trying to load using a + * relative path. */ + native = Tcl_FSGetNativePath(pathPtr); handle = dlopen(native, RTLD_NOW | RTLD_GLOBAL); if (handle == NULL) { - /* - * Let the OS loader examine the binary search path for - * whatever string the user gave us which hopefully refers - * to a file on the binary path + /* + * Let the OS loader examine the binary search path for whatever + * string the user gave us which hopefully refers to a file on the + * binary path. */ + Tcl_DString ds; char *fileName = Tcl_GetString(pathPtr); + native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); handle = dlopen(native, RTLD_NOW | RTLD_GLOBAL); Tcl_DStringFree(&ds); } - + if (handle == NULL) { - Tcl_AppendResult(interp, "couldn't load file \"", - Tcl_GetString(pathPtr), - "\": ", dlerror(), (char *) NULL); + Tcl_AppendResult(interp, "couldn't load file \"", + Tcl_GetString(pathPtr), "\": ", dlerror(), (char *) NULL); return TCL_ERROR; } *unloadProcPtr = &TclpUnloadFile; *loadHandle = (Tcl_LoadHandle)handle; @@ -104,39 +105,41 @@ /* *---------------------------------------------------------------------- * * TclpFindSymbol -- * - * Looks up a symbol, by name, through a handle associated with - * a previously loaded piece of code (shared library). + * Looks up a symbol, by name, through a handle associated with a + * previously loaded piece of code (shared library). * * Results: - * Returns a pointer to the function associated with 'symbol' if - * it is found. Otherwise returns NULL and may leave an error - * message in the interp's result. + * Returns a pointer to the function associated with 'symbol' if it is + * found. Otherwise returns NULL and may leave an error message in the + * interp's result. * *---------------------------------------------------------------------- */ + Tcl_PackageInitProc* -TclpFindSymbol(interp, loadHandle, symbol) - Tcl_Interp *interp; - Tcl_LoadHandle loadHandle; - CONST char *symbol; +TclpFindSymbol(interp, loadHandle, symbol) + Tcl_Interp *interp; /* Place to put error messages. */ + Tcl_LoadHandle loadHandle; /* Value from TcpDlopen(). */ + CONST char *symbol; /* Symbol to look up. */ { CONST char *native; Tcl_DString newName, ds; VOID *handle = (VOID*)loadHandle; Tcl_PackageInitProc *proc; - /* + + /* * Some platforms still add an underscore to the beginning of symbol - * names. If we can't find a name without an underscore, try again - * with the underscore. + * names. If we can't find a name without an underscore, try again with + * the underscore. */ native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds); proc = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */ - native); + native); if (proc == NULL) { Tcl_DStringInit(&newName); Tcl_DStringAppend(&newName, "_", 1); native = Tcl_DStringAppend(&newName, native, -1); proc = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */ @@ -151,13 +154,13 @@ /* *---------------------------------------------------------------------- * * TclpUnloadFile -- * - * Unloads a dynamically loaded binary code file from memory. - * Code pointers in the formerly loaded file are no longer valid - * after calling this function. + * Unloads a dynamically loaded binary code file from memory. Code + * pointers in the formerly loaded file are no longer valid after calling + * this function. * * Results: * None. * * Side effects: @@ -166,14 +169,13 @@ *---------------------------------------------------------------------- */ void TclpUnloadFile(loadHandle) - Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call - * to TclpDlopen(). The loadHandle is - * a token that represents the loaded - * file. */ + Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call to + * TclpDlopen(). The loadHandle is a token + * that represents the loaded file. */ { VOID *handle; handle = (VOID *) loadHandle; dlclose(handle); @@ -182,18 +184,18 @@ /* *---------------------------------------------------------------------- * * TclGuessPackageName -- * - * If the "load" command is invoked without providing a package - * name, this procedure is invoked to try to figure it out. + * If the "load" command is invoked without providing a package name, + * this procedure is invoked to try to figure it out. * * Results: - * Always returns 0 to indicate that we couldn't figure out a - * package name; generic code will then try to guess the package - * from the file name. A return value of 1 would have meant that - * we figured out the package name and put it in bufPtr. + * Always returns 0 to indicate that we couldn't figure out a package + * name; generic code will then try to guess the package from the file + * name. A return value of 1 would have meant that we figured out the + * package name and put it in bufPtr. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -201,10 +203,18 @@ int TclGuessPackageName(fileName, bufPtr) CONST char *fileName; /* Name of file containing package (already * translated to local form if needed). */ - Tcl_DString *bufPtr; /* Initialized empty dstring. Append - * package name to this if possible. */ + Tcl_DString *bufPtr; /* Initialized empty dstring. Append package + * name to this if possible. */ { return 0; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: unix/tclLoadDld.c ================================================================== --- unix/tclLoadDld.c +++ unix/tclLoadDld.c @@ -1,28 +1,28 @@ -/* +/* * tclLoadDld.c -- * - * This procedure provides a version of the TclLoadFile that - * works with the "dld_link" and "dld_get_func" library procedures - * for dynamic loading. It has been tested on Linux 1.1.95 and - * dld-3.2.7. This file probably isn't needed anymore, since it - * makes more sense to use "dl_open" etc. + * This procedure provides a version of the TclLoadFile that works with + * the "dld_link" and "dld_get_func" library procedures for dynamic + * loading. It has been tested on Linux 1.1.95 and dld-3.2.7. This file + * probably isn't needed anymore, since it makes more sense to use + * "dl_open" etc. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLoadDld.c,v 1.12 2002/10/10 12:25:53 vincentdarley Exp $ + * RCS: @(#) $Id: tclLoadDld.c,v 1.12.6.1 2005/08/02 18:16:54 dgp Exp $ */ #include "tclInt.h" #include "dld.h" /* - * In some systems, like SunOS 4.1.3, the RTLD_NOW flag isn't defined - * and this argument to dlopen must always be 1. + * In some systems, like SunOS 4.1.3, the RTLD_NOW flag isn't defined and this + * argument to dlopen must always be 1. */ #ifndef RTLD_NOW # define RTLD_NOW 1 #endif @@ -30,16 +30,16 @@ /* *---------------------------------------------------------------------- * * TclpDlopen -- * - * Dynamically loads a binary code file into memory and returns - * a handle to the new code. + * Dynamically loads a binary code file into memory and returns a handle + * to the new code. * * Results: - * A standard Tcl completion code. If an error occurs, an error - * message is left in the interp's result. + * A standard Tcl completion code. If an error occurs, an error message + * is left in the interp's result. * * Side effects: * New code suddenly appears in memory. * *---------------------------------------------------------------------- @@ -49,25 +49,25 @@ TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr) Tcl_Interp *interp; /* Used for error reporting. */ Tcl_Obj *pathPtr; /* Name of the file containing the desired * code (UTF-8). */ Tcl_LoadHandle *loadHandle; /* Filled with token for dynamically loaded - * file which will be passed back to + * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr; + Tcl_FSUnloadFileProc **unloadProcPtr; /* Filled with address of Tcl_FSUnloadFileProc - * function which should be used for - * this file. */ + * function which should be used for this + * file. */ { static int firstTime = 1; int returnCode; char *fileName; CONST char *native; - + /* - * The dld package needs to know the pathname to the tcl binary. - * If that's not known, return an error. + * The dld package needs to know the pathname to the tcl binary. If + * that's not known, return an error. */ if (firstTime) { if (tclExecutableName == NULL) { Tcl_SetResult(interp, @@ -85,29 +85,29 @@ firstTime = 0; } fileName = Tcl_GetString(pathPtr); - /* - * First try the full path the user gave us. This is particularly - * important if the cwd is inside a vfs, and we are trying to load - * using a relative path. + /* + * First try the full path the user gave us. This is particularly + * important if the cwd is inside a vfs, and we are trying to load using a + * relative path. */ + native = Tcl_FSGetNativePath(pathPtr); returnCode = dld_link(native); - + if (returnCode != 0) { Tcl_DString ds; native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); returnCode = dld_link(native); Tcl_DStringFree(&ds); } if (returnCode != 0) { - Tcl_AppendResult(interp, "couldn't load file \"", - fileName, "\": ", - dld_strerror(returnCode), (char *) NULL); + Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ", + dld_strerror(returnCode), (char *) NULL); return TCL_ERROR; } *loadHandle = (Tcl_LoadHandle) strcpy( (char *) ckalloc((unsigned) (strlen(fileName) + 1)), fileName); *unloadProcPtr = &TclpUnloadFile; @@ -117,22 +117,23 @@ /* *---------------------------------------------------------------------- * * TclpFindSymbol -- * - * Looks up a symbol, by name, through a handle associated with - * a previously loaded piece of code (shared library). + * Looks up a symbol, by name, through a handle associated with a + * previously loaded piece of code (shared library). * * Results: - * Returns a pointer to the function associated with 'symbol' if - * it is found. Otherwise returns NULL and may leave an error - * message in the interp's result. + * Returns a pointer to the function associated with 'symbol' if it is + * found. Otherwise returns NULL and may leave an error message in the + * interp's result. * *---------------------------------------------------------------------- */ + Tcl_PackageInitProc* -TclpFindSymbol(interp, loadHandle, symbol) +TclpFindSymbol(interp, loadHandle, symbol) Tcl_Interp *interp; Tcl_LoadHandle loadHandle; CONST char *symbol; { return (Tcl_PackageInitProc *) dld_get_func(symbol); @@ -141,13 +142,13 @@ /* *---------------------------------------------------------------------- * * TclpUnloadFile -- * - * Unloads a dynamically loaded binary code file from memory. - * Code pointers in the formerly loaded file are no longer valid - * after calling this function. + * Unloads a dynamically loaded binary code file from memory. Code + * pointers in the formerly loaded file are no longer valid after calling + * this function. * * Results: * None. * * Side effects: @@ -156,14 +157,13 @@ *---------------------------------------------------------------------- */ void TclpUnloadFile(loadHandle) - Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call - * to TclpDlopen(). The loadHandle is - * a token that represents the loaded - * file. */ + Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call to + * TclpDlopen(). The loadHandle is a token + * that represents the loaded file. */ { char *fileName; handle = (char *) loadHandle; dld_unlink_by_file(handle, 0); @@ -173,18 +173,18 @@ /* *---------------------------------------------------------------------- * * TclGuessPackageName -- * - * If the "load" command is invoked without providing a package - * name, this procedure is invoked to try to figure it out. + * If the "load" command is invoked without providing a package name, + * this procedure is invoked to try to figure it out. * * Results: - * Always returns 0 to indicate that we couldn't figure out a - * package name; generic code will then try to guess the package - * from the file name. A return value of 1 would have meant that - * we figured out the package name and put it in bufPtr. + * Always returns 0 to indicate that we couldn't figure out a package + * name; generic code will then try to guess the package from the file + * name. A return value of 1 would have meant that we figured out the + * package name and put it in bufPtr. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -192,10 +192,18 @@ int TclGuessPackageName(fileName, bufPtr) CONST char *fileName; /* Name of file containing package (already * translated to local form if needed). */ - Tcl_DString *bufPtr; /* Initialized empty dstring. Append - * package name to this if possible. */ + Tcl_DString *bufPtr; /* Initialized empty dstring. Append package + * name to this if possible. */ { return 0; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: unix/tclLoadDyld.c ================================================================== --- unix/tclLoadDyld.c +++ unix/tclLoadDyld.c @@ -1,106 +1,207 @@ -/* +/* * tclLoadDyld.c -- * - * This procedure provides a version of the TclLoadFile that - * works with Apple's dyld dynamic loading. This file - * provided by Wilfredo Sanchez (wsanchez@apple.com). - * This works on Mac OS X. + * This procedure provides a version of the TclLoadFile that works with + * Apple's dyld dynamic loading. + * Original version of his file (now superseded long ago) provided by + * Wilfredo Sanchez (wsanchez@apple.com). * * Copyright (c) 1995 Apple Computer, Inc. + * Copyright (c) 2005 Daniel A. Steffen * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLoadDyld.c,v 1.15 2004/04/06 22:25:56 dgp Exp $ + * RCS: @(#) $Id: tclLoadDyld.c,v 1.15.2.3 2005/08/02 18:16:54 dgp Exp $ */ #include "tclInt.h" #include +#include typedef struct Tcl_DyldModuleHandle { - struct Tcl_DyldModuleHandle *nextModuleHandle; + struct Tcl_DyldModuleHandle *nextPtr; NSModule module; } Tcl_DyldModuleHandle; typedef struct Tcl_DyldLoadHandle { - const struct mach_header *dyld_lib; - Tcl_DyldModuleHandle *firstModuleHandle; + CONST struct mach_header *dyldLibHeader; + Tcl_DyldModuleHandle *modulePtr; } Tcl_DyldLoadHandle; +#ifdef TCL_LOAD_FROM_MEMORY +typedef struct ThreadSpecificData { + int haveLoadMemory; +} ThreadSpecificData; + +static Tcl_ThreadDataKey dataKey; +#endif + +/* + *---------------------------------------------------------------------- + * + * DyldOFIErrorMsg -- + * + * Converts a numerical NSObjectFileImage error into an error message + * string. + * + * Results: + * Error message string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static CONST char* +DyldOFIErrorMsg(int err) { + switch(err) { + case NSObjectFileImageSuccess: + return NULL; + case NSObjectFileImageFailure: + return "object file setup failure"; + case NSObjectFileImageInappropriateFile: + return "not a Mach-O MH_BUNDLE file"; + case NSObjectFileImageArch: + return "no object for this architecture"; + case NSObjectFileImageFormat: + return "bad object file format"; + case NSObjectFileImageAccess: + return "can't read object file"; + default: + return "unknown error"; + } +} + /* *---------------------------------------------------------------------- * * TclpDlopen -- * - * Dynamically loads a binary code file into memory and returns - * a handle to the new code. + * Dynamically loads a binary code file into memory and returns a handle + * to the new code. * * Results: - * A standard Tcl completion code. If an error occurs, an error - * message is left in the interpreter's result. + * A standard Tcl completion code. If an error occurs, an error message + * is left in the interpreter's result. * * Side effects: - * New code suddenly appears in memory. + * New code suddenly appears in memory. * *---------------------------------------------------------------------- */ -int +MODULE_SCOPE int TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr) Tcl_Interp *interp; /* Used for error reporting. */ Tcl_Obj *pathPtr; /* Name of the file containing the desired * code (UTF-8). */ Tcl_LoadHandle *loadHandle; /* Filled with token for dynamically loaded - * file which will be passed back to + * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr; + Tcl_FSUnloadFileProc **unloadProcPtr; /* Filled with address of Tcl_FSUnloadFileProc - * function which should be used for - * this file. */ + * function which should be used for this + * file. */ { Tcl_DyldLoadHandle *dyldLoadHandle; - const struct mach_header *dyld_lib; + CONST struct mach_header *dyldLibHeader; + NSObjectFileImage dyldObjFileImage = NULL; + Tcl_DyldModuleHandle *modulePtr = NULL; CONST char *native; - /* - * First try the full path the user gave us. This is particularly - * important if the cwd is inside a vfs, and we are trying to load - * using a relative path. - */ - native = Tcl_FSGetNativePath(pathPtr); - dyld_lib = NSAddImage(native, - NSADDIMAGE_OPTION_WITH_SEARCHING | - NSADDIMAGE_OPTION_RETURN_ON_ERROR); - - if (!dyld_lib) { - /* - * Let the OS loader examine the binary search path for - * whatever string the user gave us which hopefully refers - * to a file on the binary path - */ - Tcl_DString ds; - char *fileName = Tcl_GetString(pathPtr); - native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); - dyld_lib = NSAddImage(native, - NSADDIMAGE_OPTION_WITH_SEARCHING | - NSADDIMAGE_OPTION_RETURN_ON_ERROR); - Tcl_DStringFree(&ds); - } - - if (!dyld_lib) { - NSLinkEditErrors editError; - char *name, *msg; - NSLinkEditError(&editError, &errno, &name, &msg); - Tcl_AppendResult(interp, msg, (char *) NULL); - return TCL_ERROR; - } - - dyldLoadHandle = (Tcl_DyldLoadHandle *) ckalloc(sizeof(Tcl_DyldLoadHandle)); - if (!dyldLoadHandle) return TCL_ERROR; - dyldLoadHandle->dyld_lib = dyld_lib; - dyldLoadHandle->firstModuleHandle = NULL; + /* + * First try the full path the user gave us. This is particularly + * important if the cwd is inside a vfs, and we are trying to load using a + * relative path. + */ + + native = Tcl_FSGetNativePath(pathPtr); + dyldLibHeader = NSAddImage(native, NSADDIMAGE_OPTION_WITH_SEARCHING | + NSADDIMAGE_OPTION_RETURN_ON_ERROR); + + if (!dyldLibHeader) { + NSLinkEditErrors editError; + int errorNumber; + CONST char *name, *msg, *objFileImageErrMsg = NULL; + + NSLinkEditError(&editError, &errorNumber, &name, &msg); + + if (editError == NSLinkEditFileAccessError) { + /* + * The requested file was not found. Let the OS loader examine the + * binary search path for whatever string the user gave us which + * hopefully refers to a file on the binary path. + */ + + Tcl_DString ds; + char *fileName = Tcl_GetString(pathPtr); + CONST char *native = + Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); + + dyldLibHeader = NSAddImage(native, NSADDIMAGE_OPTION_WITH_SEARCHING + | NSADDIMAGE_OPTION_RETURN_ON_ERROR); + Tcl_DStringFree(&ds); + if (!dyldLibHeader) { + NSLinkEditError(&editError, &errorNumber, &name, &msg); + } + } else if ((editError==NSLinkEditFileFormatError && errorNumber==EBADMACHO) + || editError == NSLinkEditOtherError){ + /* + * The requested file was found but was not of type MH_DYLIB, + * attempt to load it as a MH_BUNDLE. + */ + + NSObjectFileImageReturnCode err = + NSCreateObjectFileImageFromFile(native, &dyldObjFileImage); + objFileImageErrMsg = DyldOFIErrorMsg(err); + } + + if (!dyldLibHeader && !dyldObjFileImage) { + Tcl_AppendResult(interp, msg, (char *) NULL); + if (msg && *msg) { + Tcl_AppendResult(interp, "\n", (char *) NULL); + } + if (objFileImageErrMsg) { + Tcl_AppendResult(interp, + "NSCreateObjectFileImageFromFile() error: ", + objFileImageErrMsg, (char *) NULL); + } + return TCL_ERROR; + } + } + + if (dyldObjFileImage) { + NSModule module; + + module = NSLinkModule(dyldObjFileImage, native, + NSLINKMODULE_OPTION_BINDNOW + | NSLINKMODULE_OPTION_RETURN_ON_ERROR); + NSDestroyObjectFileImage(dyldObjFileImage); + + if (!module) { + NSLinkEditErrors editError; + int errorNumber; + CONST char *name, *msg; + + NSLinkEditError(&editError, &errorNumber, &name, &msg); + Tcl_AppendResult(interp, msg, (char *) NULL); + return TCL_ERROR; + } + + modulePtr = (Tcl_DyldModuleHandle *) + ckalloc(sizeof(Tcl_DyldModuleHandle)); + modulePtr->module = module; + modulePtr->nextPtr = NULL; + } + + dyldLoadHandle = (Tcl_DyldLoadHandle *) + ckalloc(sizeof(Tcl_DyldLoadHandle)); + dyldLoadHandle->dyldLibHeader = dyldLibHeader; + dyldLoadHandle->modulePtr = modulePtr; *loadHandle = (Tcl_LoadHandle) dyldLoadHandle; *unloadProcPtr = &TclpUnloadFile; return TCL_OK; } @@ -107,126 +208,333 @@ /* *---------------------------------------------------------------------- * * TclpFindSymbol -- * - * Looks up a symbol, by name, through a handle associated with - * a previously loaded piece of code (shared library). + * Looks up a symbol, by name, through a handle associated with a + * previously loaded piece of code (shared library). * * Results: - * Returns a pointer to the function associated with 'symbol' if - * it is found. Otherwise returns NULL and may leave an error - * message in the interp's result. + * Returns a pointer to the function associated with 'symbol' if it is + * found. Otherwise returns NULL and may leave an error message in the + * interp's result. * *---------------------------------------------------------------------- */ -Tcl_PackageInitProc* -TclpFindSymbol(interp, loadHandle, symbol) - Tcl_Interp *interp; - Tcl_LoadHandle loadHandle; - CONST char *symbol; + +MODULE_SCOPE Tcl_PackageInitProc* +TclpFindSymbol(interp, loadHandle, symbol) + Tcl_Interp *interp; /* For error reporting. */ + Tcl_LoadHandle loadHandle; /* Handle from TclpDlopen. */ + CONST char *symbol; /* Symbol name to look up. */ { NSSymbol nsSymbol; CONST char *native; Tcl_DString newName, ds; Tcl_PackageInitProc* proc = NULL; Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *) loadHandle; - /* + + /* * dyld adds an underscore to the beginning of symbol names. */ native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds); Tcl_DStringInit(&newName); Tcl_DStringAppend(&newName, "_", 1); native = Tcl_DStringAppend(&newName, native, -1); - nsSymbol = NSLookupSymbolInImage(dyldLoadHandle->dyld_lib, native, - NSLOOKUPSYMBOLINIMAGE_OPTION_BIND_NOW | - NSLOOKUPSYMBOLINIMAGE_OPTION_RETURN_ON_ERROR); - if(nsSymbol) { - Tcl_DyldModuleHandle *dyldModuleHandle; - proc = NSAddressOfSymbol(nsSymbol); - dyldModuleHandle = (Tcl_DyldModuleHandle *) ckalloc(sizeof(Tcl_DyldModuleHandle)); - if (dyldModuleHandle) { - dyldModuleHandle->module = NSModuleForSymbol(nsSymbol); - dyldModuleHandle->nextModuleHandle = dyldLoadHandle->firstModuleHandle; - dyldLoadHandle->firstModuleHandle = dyldModuleHandle; + + if (dyldLoadHandle->dyldLibHeader) { + nsSymbol = NSLookupSymbolInImage(dyldLoadHandle->dyldLibHeader, native, + NSLOOKUPSYMBOLINIMAGE_OPTION_BIND_NOW | + NSLOOKUPSYMBOLINIMAGE_OPTION_RETURN_ON_ERROR); + if (nsSymbol) { + /* + * Until dyld supports unloading of MY_DYLIB binaries, the + * following is not needed. + */ + +#ifdef DYLD_SUPPORTS_DYLIB_UNLOADING + NSModule module = NSModuleForSymbol(nsSymbol); + Tcl_DyldModuleHandle *modulePtr = dyldLoadHandle->modulePtr; + + while (modulePtr != NULL) { + if (module == modulePtr->module) { + break; + } + modulePtr = modulePtr->nextPtr; + } + if (modulePtr == NULL) { + modulePtr = (Tcl_DyldModuleHandle *) + ckalloc(sizeof(Tcl_DyldModuleHandle)); + modulePtr->module = module; + modulePtr->nextPtr = dyldLoadHandle->modulePtr; + dyldLoadHandle->modulePtr = modulePtr; + } +#endif /* DYLD_SUPPORTS_DYLIB_UNLOADING */ + + } else { + NSLinkEditErrors editError; + int errorNumber; + CONST char *name, *msg; + + NSLinkEditError(&editError, &errorNumber, &name, &msg); + Tcl_AppendResult(interp, msg, (char *) NULL); } } else { - NSLinkEditErrors editError; - char *name, *msg; - NSLinkEditError(&editError, &errno, &name, &msg); - Tcl_AppendResult(interp, msg, (char *) NULL); + nsSymbol = NSLookupSymbolInModule(dyldLoadHandle->modulePtr->module, + native); + } + if (nsSymbol) { + proc = NSAddressOfSymbol(nsSymbol); } Tcl_DStringFree(&newName); Tcl_DStringFree(&ds); - + return proc; } - + /* *---------------------------------------------------------------------- * * TclpUnloadFile -- * - * Unloads a dynamically loaded binary code file from memory. - * Code pointers in the formerly loaded file are no longer valid - * after calling this function. + * Unloads a dynamically loaded binary code file from memory. Code + * pointers in the formerly loaded file are no longer valid after calling + * this function. * * Results: - * None. + * None. * * Side effects: - * Code dissapears from memory. - * Note that this is a no-op on older (OpenStep) versions of dyld. + * Code dissapears from memory. Note that dyld currently only supports + * unloading of binaries of type MH_BUNDLE loaded with NSLinkModule() in + * TclpDlopen() above. * *---------------------------------------------------------------------- */ -void +MODULE_SCOPE void TclpUnloadFile(loadHandle) - Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call - * to TclpDlopen(). The loadHandle is - * a token that represents the loaded - * file. */ + Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call to + * TclpDlopen(). The loadHandle is a token + * that represents the loaded file. */ { Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *) loadHandle; - Tcl_DyldModuleHandle *dyldModuleHandle = dyldLoadHandle->firstModuleHandle; - void *ptr; + Tcl_DyldModuleHandle *modulePtr = dyldLoadHandle->modulePtr; + + while (modulePtr != NULL) { + void *ptr; - while (dyldModuleHandle) { - NSUnLinkModule(dyldModuleHandle->module, NSUNLINKMODULE_OPTION_NONE); - ptr = dyldModuleHandle; - dyldModuleHandle = dyldModuleHandle->nextModuleHandle; + NSUnLinkModule(modulePtr->module, + NSUNLINKMODULE_OPTION_RESET_LAZY_REFERENCES); + ptr = modulePtr; + modulePtr = modulePtr->nextPtr; ckfree(ptr); } - ckfree(dyldLoadHandle); + ckfree((char*) dyldLoadHandle); } - + /* *---------------------------------------------------------------------- * * TclGuessPackageName -- * - * If the "load" command is invoked without providing a package - * name, this procedure is invoked to try to figure it out. + * If the "load" command is invoked without providing a package name, + * this procedure is invoked to try to figure it out. + * + * Results: + * Always returns 0 to indicate that we couldn't figure out a package + * name; generic code will then try to guess the package from the file + * name. A return value of 1 would have meant that we figured out the + * package name and put it in bufPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +MODULE_SCOPE int +TclGuessPackageName(fileName, bufPtr) + CONST char *fileName; /* Name of file containing package (already + * translated to local form if needed). */ + Tcl_DString *bufPtr; /* Initialized empty dstring. Append package + * name to this if possible. */ +{ + return 0; +} + +#ifdef TCL_LOAD_FROM_MEMORY +/* + *---------------------------------------------------------------------- + * + * TclpLoadMemoryGetBuffer -- + * + * Allocate a buffer that can be used with TclpLoadMemory() below. + * + * Results: + * Pointer to allocated buffer or NULL if an error occurs. + * + * Side effects: + * Buffer is allocated. + * + *---------------------------------------------------------------------- + */ + +MODULE_SCOPE void* +TclpLoadMemoryGetBuffer(interp, size) + Tcl_Interp *interp; /* Used for error reporting. */ + int size; /* Size of desired buffer. */ +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + void *buffer = NULL; + + if (!tsdPtr->haveLoadMemory) { + /* + * NSCreateObjectFileImageFromMemory is available but always fails + * prior to Darwin 7. + */ + + struct utsname name; + + if (!uname(&name)) { + long release = strtol(name.release, NULL, 10); + tsdPtr->haveLoadMemory = (release >= 7) ? 1 : -1; + } + } + if (tsdPtr->haveLoadMemory > 0) { + /* + * We must allocate the buffer using vm_allocate, because + * NSCreateObjectFileImageFromMemory will dispose of it using + * vm_deallocate. + */ + + if (vm_allocate(mach_task_self(), (vm_address_t *) &buffer, size, 1)) { + buffer = NULL; + } + } + return buffer; +} + +/* + *---------------------------------------------------------------------- + * + * TclpLoadMemory -- + * + * Dynamically loads binary code file from memory and returns a handle to + * the new code. * * Results: - * Always returns 0 to indicate that we couldn't figure out a - * package name; generic code will then try to guess the package - * from the file name. A return value of 1 would have meant that - * we figured out the package name and put it in bufPtr. + * A standard Tcl completion code. If an error occurs, an error message + * is left in the interpreter's result. * * Side effects: - * None. + * New code is loaded from memory. * *---------------------------------------------------------------------- */ -int -TclGuessPackageName(fileName, bufPtr) - CONST char *fileName; /* Name of file containing package (already - * translated to local form if needed). */ - Tcl_DString *bufPtr; /* Initialized empty dstring. Append - * package name to this if possible. */ -{ - return 0; -} +MODULE_SCOPE int +TclpLoadMemory(interp, buffer, size, codeSize, loadHandle, unloadProcPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + void *buffer; /* Buffer containing the desired code + * (allocated with TclpLoadMemoryGetBuffer). */ + int size; /* Allocation size of buffer. */ + int codeSize; /* Size of code data read into buffer or -1 if + * an error occurred and the buffer should + * just be freed. */ + Tcl_LoadHandle *loadHandle; /* Filled with token for dynamically loaded + * file which will be passed back to + * (*unloadProcPtr)() to unload the file. */ + Tcl_FSUnloadFileProc **unloadProcPtr; + /* Filled with address of Tcl_FSUnloadFileProc + * function which should be used for this + * file. */ +{ + Tcl_DyldLoadHandle *dyldLoadHandle; + NSObjectFileImage dyldObjFileImage = NULL; + Tcl_DyldModuleHandle *modulePtr; + NSModule module; + CONST char *objFileImageErrMsg = NULL; + + /* + * Try to create an object file image that we can load from. + */ + + if (codeSize >= 0) { + NSObjectFileImageReturnCode err = NSObjectFileImageSuccess; + +#ifndef __LP64__ + struct mach_header *mh = buffer; + if (codeSize < sizeof(struct mach_header) || mh->magic != MH_MAGIC +#else + struct mach_header_64 *mh = buffer; + if (codeSize < sizeof(struct mach_header_64) || mh->magic != MH_MAGIC_64 +#endif + || mh->filetype != MH_BUNDLE) { + err = NSObjectFileImageInappropriateFile; + } + if (err == NSObjectFileImageSuccess) { + err = NSCreateObjectFileImageFromMemory(buffer, codeSize, + &dyldObjFileImage); + } + objFileImageErrMsg = DyldOFIErrorMsg(err); + } + + /* + * If it went wrong (or we were asked to just deallocate), get rid of the + * memory block and create an error message. + */ + + if (dyldObjFileImage == NULL) { + vm_deallocate(mach_task_self(), (vm_address_t) buffer, size); + if (objFileImageErrMsg != NULL) { + Tcl_AppendResult(interp, + "NSCreateObjectFileImageFromFile() error: ", + objFileImageErrMsg, (char *) NULL); + } + return TCL_ERROR; + } + + /* + * Extract the module we want from the image of the object file. + */ + + module = NSLinkModule(dyldObjFileImage, "[Memory Based Bundle]", + NSLINKMODULE_OPTION_BINDNOW | NSLINKMODULE_OPTION_RETURN_ON_ERROR); + NSDestroyObjectFileImage(dyldObjFileImage); + + if (!module) { + NSLinkEditErrors editError; + int errorNumber; + CONST char *name, *msg; + + NSLinkEditError(&editError, &errorNumber, &name, &msg); + Tcl_AppendResult(interp, msg, (char *) NULL); + return TCL_ERROR; + } + + /* + * Stash the module reference within the load handle we create and return. + */ + + modulePtr = (Tcl_DyldModuleHandle *) ckalloc(sizeof(Tcl_DyldModuleHandle)); + modulePtr->module = module; + modulePtr->nextPtr = NULL; + + dyldLoadHandle = (Tcl_DyldLoadHandle *) + ckalloc(sizeof(Tcl_DyldLoadHandle)); + dyldLoadHandle->dyldLibHeader = NULL; + dyldLoadHandle->modulePtr = modulePtr; + *loadHandle = (Tcl_LoadHandle) dyldLoadHandle; + *unloadProcPtr = &TclpUnloadFile; + return TCL_OK; +} +#endif + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: unix/tclLoadNext.c ================================================================== --- unix/tclLoadNext.c +++ unix/tclLoadNext.c @@ -1,18 +1,17 @@ -/* +/* * tclLoadNext.c -- * - * This procedure provides a version of the TclLoadFile that - * works with NeXTs rld_* dynamic loading. This file provided - * by Pedja Bogdanovich. + * This procedure provides a version of the TclLoadFile that works with + * NeXTs rld_* dynamic loading. This file provided by Pedja Bogdanovich. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLoadNext.c,v 1.11 2002/10/10 12:25:53 vincentdarley Exp $ + * RCS: @(#) $Id: tclLoadNext.c,v 1.11.6.1 2005/08/02 18:16:55 dgp Exp $ */ #include "tclInt.h" #include #include @@ -20,16 +19,16 @@ /* *---------------------------------------------------------------------- * * TclpDlopen -- * - * Dynamically loads a binary code file into memory and returns - * a handle to the new code. + * Dynamically loads a binary code file into memory and returns a handle + * to the new code. * * Results: - * A standard Tcl completion code. If an error occurs, an error - * message is left in the interp's result. + * A standard Tcl completion code. If an error occurs, an error message + * is left in the interp's result. * * Side effects: * New code suddenly appears in memory. * *---------------------------------------------------------------------- @@ -39,105 +38,113 @@ TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr) Tcl_Interp *interp; /* Used for error reporting. */ Tcl_Obj *pathPtr; /* Name of the file containing the desired * code (UTF-8). */ Tcl_LoadHandle *loadHandle; /* Filled with token for dynamically loaded - * file which will be passed back to + * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr; + Tcl_FSUnloadFileProc **unloadProcPtr; /* Filled with address of Tcl_FSUnloadFileProc - * function which should be used for - * this file. */ + * function which should be used for this + * file. */ { struct mach_header *header; char *fileName; char *files[2]; CONST char *native; int result = 1; - + NXStream *errorStream = NXOpenMemory(0,0,NX_READWRITE); - + fileName = Tcl_GetString(pathPtr); - /* + /* * First try the full path the user gave us. This is particularly - * important if the cwd is inside a vfs, and we are trying to load - * using a relative path. + * important if the cwd is inside a vfs, and we are trying to load using a + * relative path. */ + native = Tcl_FSGetNativePath(pathPtr); files = {native,NULL}; result = rld_load(errorStream, &header, files, NULL); - + if (!result) { - /* - * Let the OS loader examine the binary search path for - * whatever string the user gave us which hopefully refers - * to a file on the binary path + /* + * Let the OS loader examine the binary search path for whatever + * string the user gave us which hopefully refers to a file on the + * binary path */ + Tcl_DString ds; + native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); files = {native,NULL}; result = rld_load(errorStream, &header, files, NULL); Tcl_DStringFree(&ds); } - + if (!result) { char *data; int len, maxlen; + NXGetMemoryBuffer(errorStream,&data,&len,&maxlen); - Tcl_AppendResult(interp, "couldn't load file \"", - fileName, "\": ", data, NULL); + Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ", + data, NULL); NXCloseMemory(errorStream, NX_FREEBUFFER); return TCL_ERROR; } NXCloseMemory(errorStream, NX_FREEBUFFER); - + *loadHandle = (Tcl_LoadHandle)1; /* A dummy non-NULL value */ *unloadProcPtr = &TclpUnloadFile; - + return TCL_OK; } /* *---------------------------------------------------------------------- * * TclpFindSymbol -- * - * Looks up a symbol, by name, through a handle associated with - * a previously loaded piece of code (shared library). + * Looks up a symbol, by name, through a handle associated with a + * previously loaded piece of code (shared library). * * Results: - * Returns a pointer to the function associated with 'symbol' if - * it is found. Otherwise returns NULL and may leave an error - * message in the interp's result. + * Returns a pointer to the function associated with 'symbol' if it is + * found. Otherwise returns NULL and may leave an error message in the + * interp's result. * *---------------------------------------------------------------------- */ + Tcl_PackageInitProc* -TclpFindSymbol(interp, loadHandle, symbol) +TclpFindSymbol(interp, loadHandle, symbol) Tcl_Interp *interp; Tcl_LoadHandle loadHandle; CONST char *symbol; { Tcl_PackageInitProc *proc=NULL; - if(symbol) { + if (symbol) { char sym[strlen(symbol)+2]; - sym[0]='_'; sym[1]=0; strcat(sym,symbol); - rld_lookup(NULL,sym,(unsigned long *)&proc); + + sym[0] = '_'; + sym[1] = 0; + strcat(sym,symbol); + rld_lookup(NULL, sym, (unsigned long *)&proc); } return proc; } /* *---------------------------------------------------------------------- * * TclpUnloadFile -- * - * Unloads a dynamically loaded binary code file from memory. - * Code pointers in the formerly loaded file are no longer valid - * after calling this function. + * Unloads a dynamically loaded binary code file from memory. Code + * pointers in the formerly loaded file are no longer valid after calling + * this function. * * Results: * None. * * Side effects: @@ -146,30 +153,29 @@ *---------------------------------------------------------------------- */ void TclpUnloadFile(loadHandle) - Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call - * to TclpDlopen(). The loadHandle is - * a token that represents the loaded - * file. */ + Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call to + * TclpDlopen(). The loadHandle is a token + * that represents the loaded file. */ { } /* *---------------------------------------------------------------------- * * TclGuessPackageName -- * - * If the "load" command is invoked without providing a package - * name, this procedure is invoked to try to figure it out. + * If the "load" command is invoked without providing a package name, + * this procedure is invoked to try to figure it out. * * Results: - * Always returns 0 to indicate that we couldn't figure out a - * package name; generic code will then try to guess the package - * from the file name. A return value of 1 would have meant that - * we figured out the package name and put it in bufPtr. + * Always returns 0 to indicate that we couldn't figure out a package + * name; generic code will then try to guess the package from the file + * name. A return value of 1 would have meant that we figured out the + * package name and put it in bufPtr. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -177,10 +183,18 @@ int TclGuessPackageName(fileName, bufPtr) CONST char *fileName; /* Name of file containing package (already * translated to local form if needed). */ - Tcl_DString *bufPtr; /* Initialized empty dstring. Append - * package name to this if possible. */ + Tcl_DString *bufPtr; /* Initialized empty dstring. Append package + * name to this if possible. */ { return 0; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: unix/tclLoadOSF.c ================================================================== --- unix/tclLoadOSF.c +++ unix/tclLoadOSF.c @@ -1,10 +1,10 @@ -/* +/* * tclLoadOSF.c -- * - * This procedure provides a version of the TclLoadFile that works - * under OSF/1 1.0/1.1/1.2 and related systems, utilizing the old OSF/1 + * This procedure provides a version of the TclLoadFile that works under + * OSF/1 1.0/1.1/1.2 and related systems, utilizing the old OSF/1 * /sbin/loader and /usr/include/loader.h. OSF/1 versions from 1.3 and * on use ELF, rtld, and dlopen()[/usr/include/ldfcn.h]. * * This is useful for: * OSF/1 1.0, 1.1, 1.2 (from OSF) @@ -11,29 +11,29 @@ * includes: MK4 and AD1 (from OSF RI) * OSF/1 1.3 (from OSF) using ROSE * HP OSF/1 1.0 ("Acorn") using COFF * * This is likely to be useful for: - * Paragon OSF/1 (from Intel) - * HI-OSF/1 (from Hitachi) + * Paragon OSF/1 (from Intel) + * HI-OSF/1 (from Hitachi) * * This is NOT to be used on: * Digitial Alpha OSF/1 systems * OSF/1 1.3 or later (from OSF) using ELF * includes: MK6, MK7, AD2, AD3 (from OSF RI) * - * This approach to things was utter @&^#; thankfully, - * OSF/1 eventually supported dlopen(). + * This approach to things was utter @&^#; thankfully, OSF/1 eventually + * supported dlopen(). * * John Robert LoVerso * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLoadOSF.c,v 1.11 2002/10/10 12:25:53 vincentdarley Exp $ + * RCS: @(#) $Id: tclLoadOSF.c,v 1.11.6.1 2005/08/02 18:16:55 dgp Exp $ */ #include "tclInt.h" #include #include @@ -41,16 +41,16 @@ /* *---------------------------------------------------------------------- * * TclpDlopen -- * - * Dynamically loads a binary code file into memory and returns - * a handle to the new code. + * Dynamically loads a binary code file into memory and returns a handle + * to the new code. * * Results: - * A standard Tcl completion code. If an error occurs, an error - * message is left in the interp's result. + * A standard Tcl completion code. If an error occurs, an error message + * is left in the interp's result. * * Side effects: * New code suddenly appears in memory. * *---------------------------------------------------------------------- @@ -60,58 +60,62 @@ TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr) Tcl_Interp *interp; /* Used for error reporting. */ Tcl_Obj *pathPtr; /* Name of the file containing the desired * code (UTF-8). */ Tcl_LoadHandle *loadHandle; /* Filled with token for dynamically loaded - * file which will be passed back to + * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr; + Tcl_FSUnloadFileProc **unloadProcPtr; /* Filled with address of Tcl_FSUnloadFileProc - * function which should be used for - * this file. */ + * function which should be used for this + * file. */ { ldr_module_t lm; char *pkg; char *fileName = Tcl_GetString(pathPtr); CONST char *native; - /* + /* * First try the full path the user gave us. This is particularly - * important if the cwd is inside a vfs, and we are trying to load - * using a relative path. + * important if the cwd is inside a vfs, and we are trying to load using a + * relative path. */ + native = Tcl_FSGetNativePath(pathPtr); lm = (Tcl_PackageInitProc *) load(native, LDR_NOFLAGS); if (lm == LDR_NULL_MODULE) { - /* - * Let the OS loader examine the binary search path for - * whatever string the user gave us which hopefully refers - * to a file on the binary path + /* + * Let the OS loader examine the binary search path for whatever + * string the user gave us which hopefully refers to a file on the + * binary path */ + Tcl_DString ds; + native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); lm = (Tcl_PackageInitProc *) load(native, LDR_NOFLAGS); Tcl_DStringFree(&ds); } - + if (lm == LDR_NULL_MODULE) { - Tcl_AppendResult(interp, "couldn't load file \"", fileName, - "\": ", Tcl_PosixError (interp), (char *) NULL); + Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ", + Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } *clientDataPtr = NULL; - + /* * My convention is to use a [OSF loader] package name the same as shlib, * since the idiots never implemented ldr_lookup() and it is otherwise * impossible to get a package name given a module. * - * I build loadable modules with a makefile rule like + * I build loadable modules with a makefile rule like * ld ... -export $@: -o $@ $(OBJS) */ + if ((pkg = strrchr(fileName, '/')) == NULL) { pkg = fileName; } else { pkg++; } @@ -123,22 +127,22 @@ /* *---------------------------------------------------------------------- * * TclpFindSymbol -- * - * Looks up a symbol, by name, through a handle associated with - * a previously loaded piece of code (shared library). + * Looks up a symbol, by name, through a handle associated with a + * previously loaded piece of code (shared library). * * Results: - * Returns a pointer to the function associated with 'symbol' if - * it is found. Otherwise returns NULL and may leave an error - * message in the interp's result. + * Returns a pointer to the function associated with 'symbol' if it is + * found. Otherwise returns NULL and may leave an error message in the + * interp's result. * *---------------------------------------------------------------------- */ Tcl_PackageInitProc* -TclpFindSymbol(interp, loadHandle, symbol) +TclpFindSymbol(interp, loadHandle, symbol) Tcl_Interp *interp; Tcl_LoadHandle loadHandle; CONST char *symbol; { return ldr_lookup_package((char *)loadHandle, symbol); @@ -147,13 +151,13 @@ /* *---------------------------------------------------------------------- * * TclpUnloadFile -- * - * Unloads a dynamically loaded binary code file from memory. - * Code pointers in the formerly loaded file are no longer valid - * after calling this function. + * Unloads a dynamically loaded binary code file from memory. Code + * pointers in the formerly loaded file are no longer valid after calling + * this function. * * Results: * None. * * Side effects: @@ -162,30 +166,29 @@ *---------------------------------------------------------------------- */ void TclpUnloadFile(loadHandle) - Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call - * to TclpDlopen(). The loadHandle is - * a token that represents the loaded - * file. */ + Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call to + * TclpDlopen(). The loadHandle is a token + * that represents the loaded file. */ { } /* *---------------------------------------------------------------------- * * TclGuessPackageName -- * - * If the "load" command is invoked without providing a package - * name, this procedure is invoked to try to figure it out. + * If the "load" command is invoked without providing a package name, + * this procedure is invoked to try to figure it out. * * Results: - * Always returns 0 to indicate that we couldn't figure out a - * package name; generic code will then try to guess the package - * from the file name. A return value of 1 would have meant that - * we figured out the package name and put it in bufPtr. + * Always returns 0 to indicate that we couldn't figure out a package + * name; generic code will then try to guess the package from the file + * name. A return value of 1 would have meant that we figured out the + * package name and put it in bufPtr. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -193,10 +196,18 @@ int TclGuessPackageName(fileName, bufPtr) CONST char *fileName; /* Name of file containing package (already * translated to local form if needed). */ - Tcl_DString *bufPtr; /* Initialized empty dstring. Append - * package name to this if possible. */ + Tcl_DString *bufPtr; /* Initialized empty dstring. Append package + * name to this if possible. */ { return 0; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: unix/tclLoadShl.c ================================================================== --- unix/tclLoadShl.c +++ unix/tclLoadShl.c @@ -1,18 +1,18 @@ -/* +/* * tclLoadShl.c -- * - * This procedure provides a version of the TclLoadFile that works - * with the "shl_load" and "shl_findsym" library procedures for - * dynamic loading (e.g. for HP machines). + * This procedure provides a version of the TclLoadFile that works with + * the "shl_load" and "shl_findsym" library procedures for dynamic + * loading (e.g. for HP machines). * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLoadShl.c,v 1.13 2002/10/10 12:25:53 vincentdarley Exp $ + * RCS: @(#) $Id: tclLoadShl.c,v 1.13.6.2 2005/10/08 13:45:04 dgp Exp $ */ #include /* @@ -28,16 +28,16 @@ /* *---------------------------------------------------------------------- * * TclpDlopen -- * - * Dynamically loads a binary code file into memory and returns - * a handle to the new code. + * Dynamically loads a binary code file into memory and returns a handle + * to the new code. * * Results: - * A standard Tcl completion code. If an error occurs, an error - * message is left in the interp's result. + * A standard Tcl completion code. If an error occurs, an error message + * is left in the interp's result. * * Side effects: * New code suddenly appears in memory. * *---------------------------------------------------------------------- @@ -47,57 +47,56 @@ TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr) Tcl_Interp *interp; /* Used for error reporting. */ Tcl_Obj *pathPtr; /* Name of the file containing the desired * code (UTF-8). */ Tcl_LoadHandle *loadHandle; /* Filled with token for dynamically loaded - * file which will be passed back to + * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr; + Tcl_FSUnloadFileProc **unloadProcPtr; /* Filled with address of Tcl_FSUnloadFileProc - * function which should be used for - * this file. */ + * function which should be used for this + * file. */ { shl_t handle; CONST char *native; char *fileName = Tcl_GetString(pathPtr); /* - * The flags below used to be BIND_IMMEDIATE; they were changed at - * the suggestion of Wolfgang Kechel (wolfgang@prs.de): "This - * enables verbosity for missing symbols when loading a shared lib - * and allows to load libtk8.0.sl into tclsh8.0 without problems. - * In general, this delays resolving symbols until they are actually - * needed. Shared libs do no longer need all libraries linked in - * when they are build." - */ - - - /* - * First try the full path the user gave us. This is particularly - * important if the cwd is inside a vfs, and we are trying to load - * using a relative path. - */ - native = Tcl_FSGetNativePath(pathPtr); - handle = shl_load(native, - BIND_DEFERRED|BIND_VERBOSE|DYNAMIC_PATH, 0L); - - if (handle == NULL) { - /* - * Let the OS loader examine the binary search path for - * whatever string the user gave us which hopefully refers - * to a file on the binary path - */ - Tcl_DString ds; - native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); - handle = shl_load(native, - BIND_DEFERRED|BIND_VERBOSE|DYNAMIC_PATH, 0L); + * The flags below used to be BIND_IMMEDIATE; they were changed at the + * suggestion of Wolfgang Kechel (wolfgang@prs.de): "This enables + * verbosity for missing symbols when loading a shared lib and allows to + * load libtk8.0.sl into tclsh8.0 without problems. In general, this + * delays resolving symbols until they are actually needed. Shared libs + * do no longer need all libraries linked in when they are build." + */ + + /* + * First try the full path the user gave us. This is particularly + * important if the cwd is inside a vfs, and we are trying to load using a + * relative path. + */ + + native = Tcl_FSGetNativePath(pathPtr); + handle = shl_load(native, BIND_DEFERRED|BIND_VERBOSE, 0L); + + if (handle == NULL) { + /* + * Let the OS loader examine the binary search path for whatever + * string the user gave us which hopefully refers to a file on the + * binary path. + */ + + Tcl_DString ds; + + native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); + handle = shl_load(native, BIND_DEFERRED|BIND_VERBOSE|DYNAMIC_PATH, 0L); Tcl_DStringFree(&ds); } if (handle == NULL) { - Tcl_AppendResult(interp, "couldn't load file \"", fileName, - "\": ", Tcl_PosixError(interp), (char *) NULL); + Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ", + Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } *loadHandle = (Tcl_LoadHandle) handle; *unloadProcPtr = &TclpUnloadFile; return TCL_OK; @@ -106,37 +105,37 @@ /* *---------------------------------------------------------------------- * * TclpFindSymbol -- * - * Looks up a symbol, by name, through a handle associated with - * a previously loaded piece of code (shared library). + * Looks up a symbol, by name, through a handle associated with a + * previously loaded piece of code (shared library). * * Results: - * Returns a pointer to the function associated with 'symbol' if - * it is found. Otherwise returns NULL and may leave an error - * message in the interp's result. + * Returns a pointer to the function associated with 'symbol' if it is + * found. Otherwise returns NULL and may leave an error message in the + * interp's result. * *---------------------------------------------------------------------- */ Tcl_PackageInitProc* -TclpFindSymbol(interp, loadHandle, symbol) +TclpFindSymbol(interp, loadHandle, symbol) Tcl_Interp *interp; Tcl_LoadHandle loadHandle; CONST char *symbol; { Tcl_DString newName; Tcl_PackageInitProc *proc=NULL; shl_t handle = (shl_t)loadHandle; + /* - * Some versions of the HP system software still use "_" at the - * beginning of exported symbols while others don't; try both - * forms of each name. + * Some versions of the HP system software still use "_" at the beginning + * of exported symbols while others don't; try both forms of each name. */ - if (shl_findsym(&handle, symbol, (short) TYPE_PROCEDURE, (void *) &proc) - != 0) { + if (shl_findsym(&handle, symbol, (short) TYPE_PROCEDURE, + (void *) &proc) != 0) { Tcl_DStringInit(&newName); Tcl_DStringAppend(&newName, "_", 1); Tcl_DStringAppend(&newName, symbol, -1); if (shl_findsym(&handle, Tcl_DStringValue(&newName), (short) TYPE_PROCEDURE, (void *) &proc) != 0) { @@ -150,13 +149,13 @@ /* *---------------------------------------------------------------------- * * TclpUnloadFile -- * - * Unloads a dynamically loaded binary code file from memory. - * Code pointers in the formerly loaded file are no longer valid - * after calling this function. + * Unloads a dynamically loaded binary code file from memory. Code + * pointers in the formerly loaded file are no longer valid after calling + * this function. * * Results: * None. * * Side effects: @@ -165,14 +164,13 @@ *---------------------------------------------------------------------- */ void TclpUnloadFile(loadHandle) - Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call - * to TclpDlopen(). The loadHandle is - * a token that represents the loaded - * file. */ + Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call to + * TclpDlopen(). The loadHandle is a token + * that represents the loaded file. */ { shl_t handle; handle = (shl_t) loadHandle; shl_unload(handle); @@ -181,18 +179,18 @@ /* *---------------------------------------------------------------------- * * TclGuessPackageName -- * - * If the "load" command is invoked without providing a package - * name, this procedure is invoked to try to figure it out. + * If the "load" command is invoked without providing a package name, + * this procedure is invoked to try to figure it out. * * Results: - * Always returns 0 to indicate that we couldn't figure out a - * package name; generic code will then try to guess the package - * from the file name. A return value of 1 would have meant that - * we figured out the package name and put it in bufPtr. + * Always returns 0 to indicate that we couldn't figure out a package + * name; generic code will then try to guess the package from the file + * name. A return value of 1 would have meant that we figured out the + * package name and put it in bufPtr. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -200,10 +198,18 @@ int TclGuessPackageName(fileName, bufPtr) CONST char *fileName; /* Name of file containing package (already * translated to local form if needed). */ - Tcl_DString *bufPtr; /* Initialized empty dstring. Append - * package name to this if possible. */ + Tcl_DString *bufPtr; /* Initialized empty dstring. Append package + * name to this if possible. */ { return 0; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: unix/tclUnixChan.c ================================================================== --- unix/tclUnixChan.c +++ unix/tclUnixChan.c @@ -1,28 +1,29 @@ -/* +/* * tclUnixChan.c * - * Common channel driver for Unix channels based on files, command - * pipes and TCP sockets. + * Common channel driver for Unix channels based on files, command pipes + * and TCP sockets. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixChan.c,v 1.53 2004/11/17 02:51:32 hobbs Exp $ + * RCS: @(#) $Id: tclUnixChan.c,v 1.53.2.6 2005/09/09 18:48:40 dgp Exp $ */ #include "tclInt.h" /* Internal definitions for Tcl. */ #include "tclIO.h" /* To get Channel type declaration. */ /* - * sys/ioctl.h has already been included by tclPort.h. Including termios.h - * or termio.h causes a bunch of warning messages because some duplicate - * (but not contradictory) #defines exist in termios.h and/or termio.h + * sys/ioctl.h has already been included by tclPort.h. Including termios.h or + * termio.h causes a bunch of warning messages because some duplicate (but not + * contradictory) #defines exist in termios.h and/or termio.h */ + #undef NL0 #undef NL1 #undef CR0 #undef CR1 #undef CR2 @@ -41,10 +42,17 @@ #undef FLUSHO #undef PENDIN #define SUPPORTS_TTY +#undef DIRECT_BAUD +#ifdef B4800 +# if (B4800 == 4800) +# define DIRECT_BAUD +# endif /* B4800 == 4800 */ +#endif /* B4800 */ + #ifdef USE_TERMIOS # include # ifdef HAVE_SYS_IOCTL_H # include # endif /* HAVE_SYS_IOCTL_H */ @@ -54,20 +62,21 @@ # define IOSTATE struct termios # define GETIOSTATE(fd, statePtr) tcgetattr((fd), (statePtr)) # define SETIOSTATE(fd, statePtr) tcsetattr((fd), TCSADRAIN, (statePtr)) # define GETCONTROL(fd, intPtr) ioctl((fd), TIOCMGET, (intPtr)) # define SETCONTROL(fd, intPtr) ioctl((fd), TIOCMSET, (intPtr)) + /* * TIP #35 introduced a different on exit flush/close behavior that - * doesn't work correctly with standard channels on all systems. - * The problem is tcflush throws away waiting channel data. This may - * be necessary for true serial channels that may block, but isn't - * correct in the standard case. This might be replaced with tcdrain - * instead, but that can block. For now, we revert to making this do - * nothing, and TtyOutputProc being the same old FileOutputProc. - * -- hobbs [Bug #525783] + * doesn't work correctly with standard channels on all systems. The + * problem is tcflush throws away waiting channel data. This may be + * necessary for true serial channels that may block, but isn't correct in + * the standard case. This might be replaced with tcdrain instead, but + * that can block. For now, we revert to making this do nothing, and + * TtyOutputProc being the same old FileOutputProc. - hobbs [Bug #525783] */ + # define BAD_TIP35_FLUSH 0 # if BAD_TIP35_FLUSH # define TTYFLUSH(fd) tcflush((fd), TCIOFLUSH); # else # define TTYFLUSH(fd) @@ -79,14 +88,16 @@ # endif /* FIONREAD */ # ifdef TIOCOUTQ # define GETWRITEQUEUE(fd, int) ioctl((fd), TIOCOUTQ, &(int)) # endif /* TIOCOUTQ */ # if defined(TIOCSBRK) && defined(TIOCCBRK) + /* - * Can't use ?: operator below because that messes up types on either - * Linux or Solaris (the two are mutually exclusive!) + * Can't use ?: operator below because that messes up types on either Linux or + * Solaris (the two are mutually exclusive!) */ + # define SETBREAK(fd, flag) \ if (flag) { \ ioctl((fd), TIOCSBRK, NULL); \ } else { \ ioctl((fd), TIOCCBRK, NULL); \ @@ -134,21 +145,21 @@ * The following structure describes per-instance state of a tty-based * channel. */ typedef struct TtyState { - FileState fs; /* Per-instance state of the file - * descriptor. Must be the first field. */ - int stateUpdated; /* Flag to say if the state has been - * modified and needs resetting. */ - IOSTATE savedState; /* Initial state of device. Used to reset + FileState fs; /* Per-instance state of the file descriptor. + * Must be the first field. */ + int stateUpdated; /* Flag to say if the state has been modified + * and needs resetting. */ + IOSTATE savedState; /* Initial state of device. Used to reset * state when device closed. */ } TtyState; /* - * The following structure is used to set or get the serial port - * attributes in a platform-independant manner. + * The following structure is used to set or get the serial port attributes in + * a platform-independant manner. */ typedef struct TtyAttrs { int baud; int parity; @@ -157,24 +168,24 @@ } TtyAttrs; #endif /* !SUPPORTS_TTY */ #define UNSUPPORTED_OPTION(detail) \ - if (interp) { \ - Tcl_AppendResult(interp, (detail), \ - " not supported for this platform", (char *) NULL); \ - } + if (interp) { \ + Tcl_AppendResult(interp, (detail), \ + " not supported for this platform", (char *) NULL); \ + } /* * This structure describes per-instance state of a tcp based channel. */ typedef struct TcpState { Tcl_Channel channel; /* Channel associated with this file. */ int fd; /* The socket itself. */ - int flags; /* ORed combination of the bitfields - * defined below. */ + int flags; /* ORed combination of the bitfields defined + * below. */ Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ ClientData acceptProcData; /* The data for the accept proc. */ } TcpState; @@ -185,14 +196,14 @@ #define TCP_ASYNC_SOCKET (1<<0) /* Asynchronous socket. */ #define TCP_ASYNC_CONNECT (1<<1) /* Async connect in progress. */ /* - * The following defines the maximum length of the listen queue. This is - * the number of outstanding yet-to-be-serviced requests for a connection - * on a server socket, more than this number of outstanding requests and - * the connection request will fail. + * The following defines the maximum length of the listen queue. This is the + * number of outstanding yet-to-be-serviced requests for a connection on a + * server socket, more than this number of outstanding requests and the + * connection request will fail. */ #ifndef SOMAXCONN # define SOMAXCONN 100 #endif /* SOMAXCONN */ @@ -201,12 +212,12 @@ # undef SOMAXCONN # define SOMAXCONN 100 #endif /* SOMAXCONN < 100 */ /* - * The following defines how much buffer space the kernel should maintain - * for a socket. + * The following defines how much buffer space the kernel should maintain for + * a socket. */ #define SOCKET_BUFSIZE 4096 /* @@ -230,10 +241,16 @@ static int FileOutputProc _ANSI_ARGS_(( ClientData instanceData, CONST char *buf, int toWrite, int *errorCode)); static int FileSeekProc _ANSI_ARGS_((ClientData instanceData, long offset, int mode, int *errorCode)); +#ifdef DEPRECATED +static void FileThreadActionProc _ANSI_ARGS_ (( + ClientData instanceData, int action)); +#endif +static int FileTruncateProc _ANSI_ARGS_ ((ClientData instanceData, + Tcl_WideInt length)); static Tcl_WideInt FileWideSeekProc _ANSI_ARGS_((ClientData instanceData, Tcl_WideInt offset, int mode, int *errorCode)); static void FileWatchProc _ANSI_ARGS_((ClientData instanceData, int mask)); static void TcpAccept _ANSI_ARGS_((ClientData data, int mask)); @@ -255,15 +272,19 @@ #ifdef SUPPORTS_TTY static int TtyCloseProc _ANSI_ARGS_((ClientData instanceData, Tcl_Interp *interp)); static void TtyGetAttributes _ANSI_ARGS_((int fd, TtyAttrs *ttyPtr)); +#ifndef DIRECT_BAUD static int TtyGetBaud _ANSI_ARGS_((unsigned long speed)); +#endif static int TtyGetOptionProc _ANSI_ARGS_((ClientData instanceData, Tcl_Interp *interp, CONST char *optionName, Tcl_DString *dsPtr)); +#ifndef DIRECT_BAUD static unsigned long TtyGetSpeed _ANSI_ARGS_((int baud)); +#endif static FileState * TtyInit _ANSI_ARGS_((int fd, int initialize)); static void TtyModemStatusStr _ANSI_ARGS_((int status, Tcl_DString *dsPtr)); #if BAD_TIP35_FLUSH static int TtyOutputProc _ANSI_ARGS_((ClientData instanceData, @@ -273,11 +294,11 @@ CONST char *mode, int *speedPtr, int *parityPtr, int *dataPtr, int *stopPtr)); static void TtySetAttributes _ANSI_ARGS_((int fd, TtyAttrs *ttyPtr)); static int TtySetOptionProc _ANSI_ARGS_((ClientData instanceData, - Tcl_Interp *interp, CONST char *optionName, + Tcl_Interp *interp, CONST char *optionName, CONST char *value)); #endif /* SUPPORTS_TTY */ static int WaitForConnect _ANSI_ARGS_((TcpState *statePtr, int *errorCodePtr)); static Tcl_Channel MakeTcpClientChannelMode _ANSI_ARGS_( @@ -289,11 +310,11 @@ * This structure describes the channel type structure for file based IO: */ static Tcl_ChannelType fileChannelType = { "file", /* Type name. */ - TCL_CHANNEL_VERSION_3, /* v3 channel */ + TCL_CHANNEL_VERSION_4, /* v4 channel */ FileCloseProc, /* Close proc. */ FileInputProc, /* Input proc. */ FileOutputProc, /* Output proc. */ FileSeekProc, /* Seek proc. */ NULL, /* Set option proc. */ @@ -303,10 +324,16 @@ NULL, /* close2proc. */ FileBlockModeProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ FileWideSeekProc, /* wide seek proc. */ +#ifdef DEPRECATED + FileThreadActionProc, /* thread actions */ +#else + NULL, +#endif + FileTruncateProc, /* truncate proc. */ }; #ifdef SUPPORTS_TTY /* * This structure describes the channel type structure for serial IO. @@ -313,11 +340,11 @@ * Note that this type is a subclass of the "file" type. */ static Tcl_ChannelType ttyChannelType = { "tty", /* Type name. */ - TCL_CHANNEL_VERSION_2, /* v2 channel */ + TCL_CHANNEL_VERSION_4, /* v4 channel */ TtyCloseProc, /* Close proc. */ FileInputProc, /* Input proc. */ #if BAD_TIP35_FLUSH TtyOutputProc, /* Output proc. */ #else /* !BAD_TIP35_FLUSH */ @@ -330,10 +357,13 @@ FileGetHandleProc, /* Get OS handles out of channel. */ NULL, /* close2proc. */ FileBlockModeProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ + NULL, /* wide seek proc. */ + NULL, /* thread action proc. */ + NULL, /* truncate proc. */ }; #endif /* SUPPORTS_TTY */ /* * This structure describes the channel type structure for TCP socket @@ -340,11 +370,11 @@ * based IO: */ static Tcl_ChannelType tcpChannelType = { "tcp", /* Type name. */ - TCL_CHANNEL_VERSION_2, /* v2 channel */ + TCL_CHANNEL_VERSION_4, /* v4 channel */ TcpCloseProc, /* Close proc. */ TcpInputProc, /* Input proc. */ TcpOutputProc, /* Output proc. */ NULL, /* Seek proc. */ NULL, /* Set option proc. */ @@ -353,20 +383,22 @@ TcpGetHandleProc, /* Get OS handles out of channel. */ NULL, /* close2proc. */ TcpBlockModeProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ + NULL, /* wide seek proc. */ + NULL, /* thread action proc. */ + NULL, /* truncate proc. */ }; - /* *---------------------------------------------------------------------- * * FileBlockModeProc -- * - * Helper procedure to set blocking and nonblocking modes on a - * file based channel. Invoked by generic IO level code. + * Helper function to set blocking and nonblocking modes on a file based + * channel. Invoked by generic IO level code. * * Results: * 0 if successful, errno when failed. * * Side effects: @@ -376,14 +408,14 @@ */ /* ARGSUSED */ static int FileBlockModeProc(instanceData, mode) - ClientData instanceData; /* File state. */ - int mode; /* The mode to set. Can be one of - * TCL_MODE_BLOCKING or - * TCL_MODE_NONBLOCKING. */ + ClientData instanceData; /* File state. */ + int mode; /* The mode to set. Can be one of + * TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ { FileState *fsPtr = (FileState *) instanceData; int curStatus; #ifndef USE_FIONBIO @@ -413,12 +445,12 @@ /* *---------------------------------------------------------------------- * * FileInputProc -- * - * This procedure is invoked from the generic IO level to read - * input from a file based channel. + * This function is invoked from the generic IO level to read input from + * a file based channel. * * Results: * The number of bytes read is returned or -1 on error. An output * argument contains a POSIX error code if an error occurs, or zero. * @@ -428,19 +460,19 @@ *---------------------------------------------------------------------- */ static int FileInputProc(instanceData, buf, toRead, errorCodePtr) - ClientData instanceData; /* File state. */ - char *buf; /* Where to store data read. */ - int toRead; /* How much space is available - * in the buffer? */ - int *errorCodePtr; /* Where to store error code. */ + ClientData instanceData; /* File state. */ + char *buf; /* Where to store data read. */ + int toRead; /* How much space is available in the + * buffer? */ + int *errorCodePtr; /* Where to store error code. */ { FileState *fsPtr = (FileState *) instanceData; - int bytesRead; /* How many bytes were actually - * read from the input device? */ + int bytesRead; /* How many bytes were actually read from the + * input device? */ *errorCodePtr = 0; /* * Assume there is always enough input available. This will block @@ -460,41 +492,39 @@ /* *---------------------------------------------------------------------- * * FileOutputProc-- * - * This procedure is invoked from the generic IO level to write - * output to a file channel. + * This function is invoked from the generic IO level to write output to + * a file channel. * * Results: - * The number of bytes written is returned or -1 on error. An - * output argument contains a POSIX error code if an error occurred, - * or zero. + * The number of bytes written is returned or -1 on error. An output + * argument contains a POSIX error code if an error occurred, or zero. * * Side effects: * Writes output on the output device of the channel. * *---------------------------------------------------------------------- */ static int FileOutputProc(instanceData, buf, toWrite, errorCodePtr) - ClientData instanceData; /* File state. */ - CONST char *buf; /* The data buffer. */ - int toWrite; /* How many bytes to write? */ - int *errorCodePtr; /* Where to store error code. */ + ClientData instanceData; /* File state. */ + CONST char *buf; /* The data buffer. */ + int toWrite; /* How many bytes to write? */ + int *errorCodePtr; /* Where to store error code. */ { FileState *fsPtr = (FileState *) instanceData; int written; *errorCodePtr = 0; if (toWrite == 0) { /* - * SF Tcl Bug 465765. - * Do not try to write nothing into a file. STREAM based - * implementations will considers this as EOF (if there is a + * SF Tcl Bug 465765. Do not try to write nothing into a file. STREAM + * based implementations will considers this as EOF (if there is a * pipe behind the file). */ return 0; } @@ -509,11 +539,11 @@ /* *---------------------------------------------------------------------- * * FileCloseProc -- * - * This procedure is called from the generic IO level to perform + * This function is called from the generic IO level to perform * channel-type-specific cleanup when a file based channel is closed. * * Results: * 0 if successful, errno if failed. * @@ -550,12 +580,12 @@ /* *---------------------------------------------------------------------- * * FileSeekProc -- * - * This procedure is called by the generic IO level to move the - * access point in a file based channel. + * This function is called by the generic IO level to move the access + * point in a file based channel. * * Results: * -1 if failed, the new position if successful. An output * argument contains the POSIX error code if an error occurred, * or zero. @@ -579,24 +609,27 @@ Tcl_WideInt oldLoc, newLoc; /* * Save our current place in case we need to roll-back the seek. */ + oldLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) 0, SEEK_CUR); if (oldLoc == Tcl_LongAsWide(-1)) { /* * Bad things are happening. Error out... */ + *errorCodePtr = errno; return -1; } - + newLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) offset, mode); - + /* * Check for expressability in our return type, and roll-back otherwise. */ + if (newLoc > Tcl_LongAsWide(INT_MAX)) { *errorCodePtr = EOVERFLOW; TclOSseek(fsPtr->fd, (Tcl_SeekOffset) oldLoc, SEEK_SET); return -1; } else { @@ -608,13 +641,13 @@ /* *---------------------------------------------------------------------- * * FileWideSeekProc -- * - * This procedure is called by the generic IO level to move the - * access point in a file based channel, with offsets expressed - * as wide integers. + * This function is called by the generic IO level to move the access + * point in a file based channel, with offsets expressed as wide + * integers. * * Results: * -1 if failed, the new position if successful. An output * argument contains the POSIX error code if an error occurred, * or zero. @@ -688,16 +721,16 @@ /* *---------------------------------------------------------------------- * * FileGetHandleProc -- * - * Called from Tcl_GetChannelHandle to retrieve OS handles from - * a file based channel. + * Called from Tcl_GetChannelHandle to retrieve OS handles from a file + * based channel. * * Results: - * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if - * there is no handle for the specified direction. + * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no + * handle for the specified direction. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -717,18 +750,18 @@ } else { return TCL_ERROR; } } -#ifdef SUPPORTS_TTY +#ifdef SUPPORTS_TTY /* *---------------------------------------------------------------------- * * TtyCloseProc -- * - * This procedure is called from the generic IO level to perform + * This function is called from the generic IO level to perform * channel-type-specific cleanup when a tty based channel is closed. * * Results: * 0 if successful, errno if failed. * @@ -743,64 +776,66 @@ Tcl_Interp *interp; /* For error reporting - unused. */ { #if BAD_TIP35_FLUSH TtyState *ttyPtr = (TtyState *) instanceData; #endif /* BAD_TIP35_FLUSH */ + #ifdef TTYFLUSH TTYFLUSH(ttyPtr->fs.fd); #endif /* TTYFLUSH */ + #if 0 /* - * TIP#35 agreed to remove the unsave so that TCL could be used as a - * simple stty. - * It would be cleaner to remove all the stuff related to + * TIP#35 agreed to remove the unsave so that TCL could be used as a + * simple stty. It would be cleaner to remove all the stuff related to * TtyState.stateUpdated * TtyState.savedState - * Then the structure TtyState would be the same as FileState. - * IMO this cleanup could better be done for the final 8.4 release - * after nobody complained about the missing unsave. -- schroedter + * Then the structure TtyState would be the same as FileState. IMO this + * cleanup could better be done for the final 8.4 release after nobody + * complained about the missing unsave. - schroedter */ if (ttyPtr->stateUpdated) { SETIOSTATE(ttyPtr->fs.fd, &ttyPtr->savedState); } #endif + return FileCloseProc(instanceData, interp); } /* *---------------------------------------------------------------------- * * TtyOutputProc-- * - * This procedure is invoked from the generic IO level to write - * output to a TTY channel. + * This function is invoked from the generic IO level to write output to + * a TTY channel. * * Results: - * The number of bytes written is returned or -1 on error. An - * output argument contains a POSIX error code if an error occurred, - * or zero. + * The number of bytes written is returned or -1 on error. An output + * argument contains a POSIX error code if an error occurred, or zero. * * Side effects: - * Writes output on the output device of the channel - * if the channel is not designated to be closed. + * Writes output on the output device of the channel if the channel is + * not designated to be closed. * *---------------------------------------------------------------------- */ #if BAD_TIP35_FLUSH static int TtyOutputProc(instanceData, buf, toWrite, errorCodePtr) - ClientData instanceData; /* File state. */ - CONST char *buf; /* The data buffer. */ - int toWrite; /* How many bytes to write? */ - int *errorCodePtr; /* Where to store error code. */ + ClientData instanceData; /* File state. */ + CONST char *buf; /* The data buffer. */ + int toWrite; /* How many bytes to write? */ + int *errorCodePtr; /* Where to store error code. */ { if (TclInExit()) { /* - * Do not write data during Tcl exit. - * Serial port may block preventing Tcl from exit. + * Do not write data during Tcl exit. Serial port may block + * preventing Tcl from exit. */ + return toWrite; } else { return FileOutputProc(instanceData, buf, toWrite, errorCodePtr); } } @@ -810,14 +845,15 @@ /* *---------------------------------------------------------------------- * * TtyModemStatusStr -- * - * Converts a RS232 modem status list of readable flags + * Converts a RS232 modem status list of readable flags * *---------------------------------------------------------------------- */ + static void TtyModemStatusStr(status, dsPtr) int status; /* RS232 modem status */ Tcl_DString *dsPtr; /* Where to store string */ { @@ -850,17 +886,17 @@ * Results: * A standard Tcl result. Also sets the interp's result on error if * interp is not NULL. * * Side effects: - * May modify an option on a device. - * Sets Error message if needed (by calling Tcl_BadChannelOption). + * May modify an option on a device. Sets Error message if needed (by + * calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ -static int +static int TtySetOptionProc(instanceData, interp, optionName, value) ClientData instanceData; /* File state. */ Tcl_Interp *interp; /* For error reporting - can be NULL. */ CONST char *optionName; /* Which option to set? */ CONST char *value; /* New value for option. */ @@ -883,12 +919,13 @@ if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) { if (TtyParseMode(interp, value, &tty.baud, &tty.parity, &tty.data, &tty.stop) != TCL_OK) { return TCL_ERROR; } + /* - * system calls results should be checked there. -- dl + * system calls results should be checked there. - dl */ TtySetAttributes(fsPtr->fd, &tty); ((TtyState *) fsPtr)->stateUpdated = 1; return TCL_OK; @@ -897,15 +934,16 @@ #ifdef USE_TERMIOS /* * Option -handshake none|xonxoff|rtscts|dtrdsr */ + if ((len > 1) && (strncmp(optionName, "-handshake", len) == 0)) { /* - * Reset all handshake options - * DTR and RTS are ON by default + * Reset all handshake options. DTR and RTS are ON by default. */ + GETIOSTATE(fsPtr->fd, &iostate); iostate.c_iflag &= ~(IXON | IXOFF | IXANY); #ifdef CRTSCTS iostate.c_cflag &= ~CRTSCTS; #endif /* CRTSCTS */ @@ -936,10 +974,11 @@ } /* * Option -xchar {\x11 \x13} */ + if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) { GETIOSTATE(fsPtr->fd, &iostate); if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; } @@ -961,10 +1000,11 @@ } /* * Option -timeout msec */ + if ((len > 2) && (strncmp(optionName, "-timeout", len) == 0)) { int msec; GETIOSTATE(fsPtr->fd, &iostate); if (Tcl_GetInt(interp, value, &msec) != TCL_OK) { @@ -977,10 +1017,11 @@ } /* * Option -ttycontrol {DTR 1 RTS 0 BREAK 0} */ + if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) { int i; if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; } @@ -1059,28 +1100,28 @@ /* *---------------------------------------------------------------------- * * TtyGetOptionProc -- * - * Gets a mode associated with an IO channel. If the optionName arg - * is non NULL, retrieves the value of that option. If the optionName - * arg is NULL, retrieves a list of alternating option names and - * values for the given channel. + * Gets a mode associated with an IO channel. If the optionName arg is + * non NULL, retrieves the value of that option. If the optionName arg is + * NULL, retrieves a list of alternating option names and values for the + * given channel. * * Results: - * A standard Tcl result. Also sets the supplied DString to the - * string value of the option(s) returned. + * A standard Tcl result. Also sets the supplied DString to the string + * value of the option(s) returned. * * Side effects: - * The string returned by this function is in static storage and - * may be reused at any time subsequent to the call. - * Sets Error message if needed (by calling Tcl_BadChannelOption). + * The string returned by this function is in static storage and may be + * reused at any time subsequent to the call. Sets Error message if + * needed (by calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ -static int +static int TtyGetOptionProc(instanceData, interp, optionName, dsPtr) ClientData instanceData; /* File state. */ Tcl_Interp *interp; /* For error reporting - can be NULL. */ CONST char *optionName; /* Option to get. */ Tcl_DString *dsPtr; /* Where to store value(s). */ @@ -1108,10 +1149,11 @@ #ifdef USE_TERMIOS /* * get option -xchar */ + if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-xchar"); Tcl_DStringStartSublist(dsPtr); } if (len==0 || (len>1 && strncmp(optionName, "-xchar", len)==0)) { @@ -1128,13 +1170,14 @@ Tcl_DStringEndSublist(dsPtr); } /* * get option -queue - * option is readonly and returned by [fconfigure chan -queue] - * but not returned by unnamed [fconfigure chan] + * option is readonly and returned by [fconfigure chan -queue] but not + * returned by unnamed [fconfigure chan] */ + if ((len > 1) && (strncmp(optionName, "-queue", len) == 0)) { int inQueue=0, outQueue=0; int inBuffered, outBuffered; valid = 1; #ifdef GETREADQUEUE @@ -1152,12 +1195,12 @@ Tcl_DStringAppendElement(dsPtr, buf); } /* * get option -ttystatus - * option is readonly and returned by [fconfigure chan -ttystatus] - * but not returned by unnamed [fconfigure chan] + * option is readonly and returned by [fconfigure chan -ttystatus] but not + * returned by unnamed [fconfigure chan] */ if ((len > 4) && (strncmp(optionName, "-ttystatus", len) == 0)) { int status; valid = 1; GETCONTROL(fsPtr->fd, &status); @@ -1175,17 +1218,10 @@ "mode"); #endif /* USE_TERMIOS */ } } -#undef DIRECT_BAUD -#ifdef B4800 -# if (B4800 == 4800) -# define DIRECT_BAUD -# endif /* B4800 == 4800 */ -#endif /* B4800 */ - #ifdef DIRECT_BAUD # define TtyGetSpeed(baud) ((unsigned) (baud)) # define TtyGetBaud(speed) ((int) (speed)) #else /* !DIRECT_BAUD */ @@ -1283,13 +1319,13 @@ /* *--------------------------------------------------------------------------- * * TtyGetSpeed -- * - * Given a baud rate, get the mask value that should be stored in - * the termios, termio, or sgttyb structure in order to select that - * baud rate. + * Given a baud rate, get the mask value that should be stored in the + * termios, termio, or sgttyb structure in order to select that baud + * rate. * * Results: * As above. * * Side effects: @@ -1307,12 +1343,12 @@ bestIdx = 0; bestDiff = 1000000; /* * If the baud rate does not correspond to one of the known mask values, - * choose the mask value whose baud rate is closest to the specified - * baud rate. + * choose the mask value whose baud rate is closest to the specified baud + * rate. */ for (i = 0; speeds[i].baud >= 0; i++) { diff = speeds[i].baud - baud; if (diff < 0) { @@ -1329,12 +1365,12 @@ /* *--------------------------------------------------------------------------- * * TtyGetBaud -- * - * Given a speed mask value from a termios, termio, or sgttyb - * structure, get the baus rate that corresponds to that mask value. + * Given a speed mask value from a termios, termio, or sgttyb structure, + * get the baus rate that corresponds to that mask value. * * Results: * As above. If the mask value was not recognized, 0 is returned. * * Side effects: @@ -1376,12 +1412,12 @@ *--------------------------------------------------------------------------- */ static void TtyGetAttributes(fd, ttyPtr) - int fd; /* Open file descriptor for serial port to - * be queried. */ + int fd; /* Open file descriptor for serial port to be + * queried. */ TtyAttrs *ttyPtr; /* Buffer filled with serial port * attributes. */ { IOSTATE iostate; int baud, parity, data, stop; @@ -1392,19 +1428,19 @@ baud = TtyGetBaud(cfgetospeed(&iostate)); parity = 'n'; #ifdef PAREXT switch ((int) (iostate.c_cflag & (PARENB | PARODD | PAREXT))) { - case PARENB : parity = 'e'; break; - case PARENB | PARODD : parity = 'o'; break; - case PARENB | PAREXT : parity = 's'; break; - case PARENB | PARODD | PAREXT : parity = 'm'; break; + case PARENB : parity = 'e'; break; + case PARENB | PARODD : parity = 'o'; break; + case PARENB | PAREXT : parity = 's'; break; + case PARENB | PARODD | PAREXT : parity = 'm'; break; } #else /* !PAREXT */ switch ((int) (iostate.c_cflag & (PARENB | PARODD))) { - case PARENB : parity = 'e'; break; - case PARENB | PARODD : parity = 'o'; break; + case PARENB : parity = 'e'; break; + case PARENB | PARODD : parity = 'o'; break; } #endif /* !PAREXT */ data = iostate.c_cflag & CSIZE; data = (data == CS5) ? 5 : (data == CS6) ? 6 : (data == CS7) ? 7 : 8; @@ -1415,14 +1451,14 @@ #ifdef USE_TERMIO baud = TtyGetBaud(iostate.c_cflag & CBAUD); parity = 'n'; switch (iostate.c_cflag & (PARENB | PARODD | PAREXT)) { - case PARENB : parity = 'e'; break; - case PARENB | PARODD : parity = 'o'; break; - case PARENB | PAREXT : parity = 's'; break; - case PARENB | PARODD | PAREXT : parity = 'm'; break; + case PARENB : parity = 'e'; break; + case PARENB | PARODD : parity = 'o'; break; + case PARENB | PAREXT : parity = 's'; break; + case PARENB | PARODD | PAREXT : parity = 'm'; break; } data = iostate.c_cflag & CSIZE; data = (data == CS5) ? 5 : (data == CS6) ? 6 : (data == CS7) ? 7 : 8; @@ -1453,11 +1489,11 @@ /* *--------------------------------------------------------------------------- * * TtySetAttributes -- * - * Set the current attributes of the specified serial device. + * Set the current attributes of the specified serial device. * * Results: * None. * * Side effects: @@ -1466,14 +1502,14 @@ *--------------------------------------------------------------------------- */ static void TtySetAttributes(fd, ttyPtr) - int fd; /* Open file descriptor for serial port to - * be modified. */ - TtyAttrs *ttyPtr; /* Buffer containing new attributes for - * serial port. */ + int fd; /* Open file descriptor for serial port to be + * modified. */ + TtyAttrs *ttyPtr; /* Buffer containing new attributes for serial + * port. */ { IOSTATE iostate; #ifdef USE_TERMIOS int parity, data, flag; @@ -1559,17 +1595,17 @@ /* *--------------------------------------------------------------------------- * * TtyParseMode -- * - * Parse the "-mode" argument to the fconfigure command. The argument - * is of the form baud,parity,data,stop. + * Parse the "-mode" argument to the fconfigure command. The argument is + * of the form baud,parity,data,stop. * * Results: - * The return value is TCL_OK if the argument was successfully - * parsed, TCL_ERROR otherwise. If TCL_ERROR is returned, an - * error message is left in the interp's result (if interp is non-NULL). + * The return value is TCL_OK if the argument was successfully parsed, + * TCL_ERROR otherwise. If TCL_ERROR is returned, an error message is + * left in the interp's result (if interp is non-NULL). * * Side effects: * None. * *--------------------------------------------------------------------------- @@ -1595,15 +1631,16 @@ Tcl_AppendResult(interp, bad, ": should be baud,parity,data,stop", NULL); } return TCL_ERROR; } + /* - * Only allow setting mark/space parity on platforms that support it - * Make sure to allow for the case where strchr is a macro. - * [Bug: 5089] + * Only allow setting mark/space parity on platforms that support it Make + * sure to allow for the case where strchr is a macro. [Bug: 5089] */ + if ( #if defined(PAREXT) || defined(USE_TERMIO) strchr("noems", parity) == NULL #else strchr("noe", parity) == NULL @@ -1640,33 +1677,32 @@ /* *--------------------------------------------------------------------------- * * TtyInit -- * - * Given file descriptor that refers to a serial port, - * initialize the serial port to a set of sane values so that - * Tcl can talk to a device located on the serial port. - * Note that no initialization happens if the initialize flag - * is not set; this is necessary for the correct handling of - * UNIX console TTYs at startup. + * Given file descriptor that refers to a serial port, initialize the + * serial port to a set of sane values so that Tcl can talk to a device + * located on the serial port. Note that no initialization happens if + * the initialize flag is not set; this is necessary for the correct + * handling of UNIX console TTYs at startup. * * Results: - * A pointer to a FileState suitable for use with Tcl_CreateChannel - * and the ttyChannelType structure. + * A pointer to a FileState suitable for use with Tcl_CreateChannel and + * the ttyChannelType structure. * * Side effects: - * Serial device initialized to non-blocking raw mode, similar to - * sockets (if initialize flag is non-zero.) All other modes can - * be simulated on top of this in Tcl. + * Serial device initialized to non-blocking raw mode, similar to sockets + * (if initialize flag is non-zero.) All other modes can be simulated on + * top of this in Tcl. * *--------------------------------------------------------------------------- */ static FileState * TtyInit(fd, initialize) - int fd; /* Open file descriptor for serial port to - * be initialized. */ + int fd; /* Open file descriptor for serial port to be + * initialized. */ int initialize; { TtyState *ttyPtr; ttyPtr = (TtyState *) ckalloc((unsigned) sizeof(TtyState)); @@ -1700,13 +1736,13 @@ iostate.sg_flags &= (EVENP | ODDP); iostate.sg_flags |= RAW; #endif /* USE_SGTTY */ /* - * Only update if we're changing anything to avoid possible - * blocking. + * Only update if we're changing anything to avoid possible blocking. */ + if (ttyPtr->stateUpdated) { SETIOSTATE(fd, &iostate); } } @@ -1720,17 +1756,17 @@ * TclpOpenFileChannel -- * * Open an file based channel on Unix systems. * * Results: - * The new channel or NULL. If NULL, the output argument - * errorCodePtr is set to a POSIX error and an error message is - * left in the interp's result if interp is not NULL. + * The new channel or NULL. If NULL, the output argument errorCodePtr is + * set to a POSIX error and an error message is left in the interp's + * result if interp is not NULL. * * Side effects: - * May open the channel and may cause creation of a file on the - * file system. + * May open the channel and may cause creation of a file on the file + * system. * *---------------------------------------------------------------------- */ Tcl_Channel @@ -1751,42 +1787,46 @@ #ifdef SUPPORTS_TTY int ctl_tty; #endif /* SUPPORTS_TTY */ switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { - case O_RDONLY: - channelPermissions = TCL_READABLE; - break; - case O_WRONLY: - channelPermissions = TCL_WRITABLE; - break; - case O_RDWR: - channelPermissions = (TCL_READABLE | TCL_WRITABLE); - break; - default: - /* - * This may occurr if modeString was "", for example. - */ - Tcl_Panic("TclpOpenFileChannel: invalid mode value"); - return NULL; + case O_RDONLY: + channelPermissions = TCL_READABLE; + break; + case O_WRONLY: + channelPermissions = TCL_WRITABLE; + break; + case O_RDWR: + channelPermissions = (TCL_READABLE | TCL_WRITABLE); + break; + default: + /* + * This may occurr if modeString was "", for example. + */ + + Tcl_Panic("TclpOpenFileChannel: invalid mode value"); + return NULL; } native = Tcl_FSGetNativePath(pathPtr); if (native == NULL) { return NULL; } + #ifdef DJGPP - mode |= O_BINARY; -#endif + mode |= O_BINARY; +#endif + fd = TclOSopen(native, mode, permissions); + #ifdef SUPPORTS_TTY ctl_tty = (strcmp (native, "/dev/tty") == 0); #endif /* SUPPORTS_TTY */ if (fd < 0) { if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "couldn't open \"", + Tcl_AppendResult(interp, "couldn't open \"", Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), (char *) NULL); } return NULL; } @@ -1801,41 +1841,53 @@ sprintf(channelName, "file%d", fd); #ifdef SUPPORTS_TTY if (!ctl_tty && isatty(fd)) { /* - * Initialize the serial port to a set of sane parameters. - * Especially important if the remote device is set to echo and - * the serial port driver was also set to echo -- as soon as a char - * were sent to the serial port, the remote device would echo it, - * then the serial driver would echo it back to the device, etc. + * Initialize the serial port to a set of sane parameters. Especially + * important if the remote device is set to echo and the serial port + * driver was also set to echo -- as soon as a char were sent to the + * serial port, the remote device would echo it, then the serial + * driver would echo it back to the device, etc. */ translation = "auto crlf"; channelTypePtr = &ttyChannelType; fsPtr = TtyInit(fd, 1); - } else + } else #endif /* SUPPORTS_TTY */ { translation = NULL; channelTypePtr = &fileChannelType; fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState)); } +#ifdef DEPRECATED + if (channelTypePtr == &fileChannelType) { + /* + * TIP #218. Removed the code inserting the new structure into the + * global list. This is now handled in the thread action callbacks, + * and only there. + */ + + fsPtr->nextPtr = NULL; + } +#endif /* DEPRECATED */ + fsPtr->validMask = channelPermissions | TCL_EXCEPTION; fsPtr->fd = fd; fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName, (ClientData) fsPtr, channelPermissions); if (translation != NULL) { /* - * Gotcha. Most modems need a "\r" at the end of the command - * sequence. If you just send "at\n", the modem will not respond - * with "OK" because it never got a "\r" to actually invoke the - * command. So, by default, newlines are translated to "\r\n" on - * output to avoid "bug" reports that the serial port isn't working. + * Gotcha. Most modems need a "\r" at the end of the command sequence. + * If you just send "at\n", the modem will not respond with "OK" + * because it never got a "\r" to actually invoke the command. So, by + * default, newlines are translated to "\r\n" on output to avoid "bug" + * reports that the serial port isn't working. */ if (Tcl_SetChannelOption(interp, fsPtr->channel, "-translation", translation) != TCL_OK) { Tcl_Close(NULL, fsPtr->channel); @@ -1887,12 +1939,12 @@ channelTypePtr = &ttyChannelType; sprintf(channelName, "serial%d", fd); } else #endif /* SUPPORTS_TTY */ if (getsockname(fd, (struct sockaddr *)&sockaddr, &sockaddrLen) == 0 - && sockaddrLen > 0 - && sockaddr.sa_family == AF_INET) { + && sockaddrLen > 0 + && sockaddr.sa_family == AF_INET) { return MakeTcpClientChannelMode((ClientData) fd, mode); } else { channelTypePtr = &fileChannelType; fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState)); sprintf(channelName, "file%d", fd); @@ -1909,12 +1961,12 @@ /* *---------------------------------------------------------------------- * * TcpBlockModeProc -- * - * This procedure is invoked by the generic IO level to set blocking - * and nonblocking mode on a TCP socket based channel. + * This function is invoked by the generic IO level to set blocking and + * nonblocking mode on a TCP socket based channel. * * Results: * 0 if successful, errno when failed. * * Side effects: @@ -1924,14 +1976,14 @@ */ /* ARGSUSED */ static int TcpBlockModeProc(instanceData, mode) - ClientData instanceData; /* Socket state. */ - int mode; /* The mode to set. Can be one of - * TCL_MODE_BLOCKING or - * TCL_MODE_NONBLOCKING. */ + ClientData instanceData; /* Socket state. */ + int mode; /* The mode to set. Can be one of + * TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ { TcpState *statePtr = (TcpState *) instanceData; int setting; #ifndef USE_FIONBIO @@ -1968,12 +2020,12 @@ /* *---------------------------------------------------------------------- * * WaitForConnect -- * - * Waits for a connection on an asynchronously opened socket to - * be completed. + * Waits for a connection on an asynchronously opened socket to be + * completed. * * Results: * None. * * Side effects: @@ -1990,12 +2042,12 @@ int timeOut; /* How long to wait. */ int state; /* Of calling TclWaitForFile. */ int flags; /* fcntl flags for the socket. */ /* - * If an asynchronous connect is in progress, attempt to wait for it - * to complete before reading. + * If an asynchronous connect is in progress, attempt to wait for it to + * complete before reading. */ if (statePtr->flags & TCP_ASYNC_CONNECT) { if (statePtr->flags & TCP_ASYNC_SOCKET) { timeOut = 0; @@ -2031,20 +2083,20 @@ /* *---------------------------------------------------------------------- * * TcpInputProc -- * - * This procedure is invoked by the generic IO level to read input - * from a TCP socket based channel. + * This function is invoked by the generic IO level to read input from a + * TCP socket based channel. * - * NOTE: We cannot share code with FilePipeInputProc because here - * we must use recv to obtain the input from the channel, not read. + * NOTE: We cannot share code with FilePipeInputProc because here we must + * use recv to obtain the input from the channel, not read. * * Results: * The number of bytes read is returned or -1 on error. An output - * argument contains the POSIX error code on error, or zero if no - * error occurred. + * argument contains the POSIX error code on error, or zero if no error + * occurred. * * Side effects: * Reads input from the input device of the channel. * *---------------------------------------------------------------------- @@ -2053,12 +2105,12 @@ /* ARGSUSED */ static int TcpInputProc(instanceData, buf, bufSize, errorCodePtr) ClientData instanceData; /* Socket state. */ char *buf; /* Where to store data read. */ - int bufSize; /* How much space is available - * in the buffer? */ + int bufSize; /* How much space is available in the + * buffer? */ int *errorCodePtr; /* Where to store error code. */ { TcpState *statePtr = (TcpState *) instanceData; int bytesRead, state; @@ -2085,19 +2137,19 @@ /* *---------------------------------------------------------------------- * * TcpOutputProc -- * - * This procedure is invoked by the generic IO level to write output - * to a TCP socket based channel. + * This function is invoked by the generic IO level to write output to a + * TCP socket based channel. * - * NOTE: We cannot share code with FilePipeOutputProc because here - * we must use send, not write, to get reliable error reporting. + * NOTE: We cannot share code with FilePipeOutputProc because here we + * must use send, not write, to get reliable error reporting. * * Results: - * The number of bytes written is returned. An output argument is - * set to a POSIX error code if an error occurred, or zero. + * The number of bytes written is returned. An output argument is set to + * a POSIX error code if an error occurred, or zero. * * Side effects: * Writes output on the output device of the channel. * *---------------------------------------------------------------------- @@ -2130,13 +2182,13 @@ /* *---------------------------------------------------------------------- * * TcpCloseProc -- * - * This procedure is invoked by the generic IO level to perform - * channel-type-specific cleanup when a TCP socket based channel - * is closed. + * This function is invoked by the generic IO level to perform + * channel-type-specific cleanup when a TCP socket based channel is + * closed. * * Results: * 0 if successful, the value of errno if failed. * * Side effects: @@ -2153,16 +2205,15 @@ { TcpState *statePtr = (TcpState *) instanceData; int errorCode = 0; /* - * Delete a file handler that may be active for this socket if this - * is a server socket - the file handler was created automatically - * by Tcl as part of the mechanism to accept new client connections. - * Channel handlers are already deleted in the generic IO channel - * closing code that called this function, so we do not have to - * delete them here. + * Delete a file handler that may be active for this socket if this is a + * server socket - the file handler was created automatically by Tcl as + * part of the mechanism to accept new client connections. Channel + * handlers are already deleted in the generic IO channel closing code + * that called this function, so we do not have to delete them here. */ Tcl_DeleteFileHandler(statePtr->fd); if (close(statePtr->fd) < 0) { @@ -2176,19 +2227,19 @@ /* *---------------------------------------------------------------------- * * TcpGetOptionProc -- * - * Computes an option value for a TCP socket based channel, or a - * list of all options and their values. + * Computes an option value for a TCP socket based channel, or a list of + * all options and their values. * * Note: This code is based on code contributed by John Haxby. * * Results: - * A standard Tcl result. The value of the specified option or a - * list of all options and their values is returned in the - * supplied DString. Sets Error message if needed. + * A standard Tcl result. The value of the specified option or a list of + * all options and their values is returned in the supplied DString. Sets + * Error message if needed. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -2196,16 +2247,15 @@ static int TcpGetOptionProc(instanceData, interp, optionName, dsPtr) ClientData instanceData; /* Socket state. */ Tcl_Interp *interp; /* For error reporting - can be NULL. */ - CONST char *optionName; /* Name of the option to - * retrieve the value for, or - * NULL to get all options and - * their values. */ - Tcl_DString *dsPtr; /* Where to store the computed - * value; initialized by caller. */ + CONST char *optionName; /* Name of the option to retrieve the value + * for, or NULL to get all options and their + * values. */ + Tcl_DString *dsPtr; /* Where to store the computed value; + * initialized by caller. */ { TcpState *statePtr = (TcpState *) instanceData; struct sockaddr_in sockname; struct sockaddr_in peername; struct hostent *hostEntPtr; @@ -2263,13 +2313,13 @@ return TCL_OK; } } else { /* * getpeername failed - but if we were asked for all the options - * (len==0), don't flag an error at that point because it could - * be an fconfigure request on a server socket. (which have - * no peer). same must be done on win&mac. + * (len==0), don't flag an error at that point because it could be + * an fconfigure request on a server socket (which have no peer). + * Same must be done on win&mac. */ if (len) { if (interp) { Tcl_AppendResult(interp, "can't get peername: ", @@ -2334,12 +2384,12 @@ * * Results: * None. * * Side effects: - * Sets up the notifier so that a future event on the channel will - * be seen by Tcl. + * Sets up the notifier so that a future event on the channel will be + * seen by Tcl. * *---------------------------------------------------------------------- */ static void @@ -2371,16 +2421,16 @@ /* *---------------------------------------------------------------------- * * TcpGetHandleProc -- * - * Called from Tcl_GetChannelHandle to retrieve OS handles from inside - * a TCP socket based channel. + * Called from Tcl_GetChannelHandle to retrieve OS handles from inside a + * TCP socket based channel. * * Results: - * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if - * there is no handle for the specified direction. + * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no + * handle for the specified direction. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -2402,16 +2452,16 @@ /* *---------------------------------------------------------------------- * * CreateSocket -- * - * This function opens a new socket in client or server mode - * and initializes the TcpState structure. + * This function opens a new socket in client or server mode and + * initializes the TcpState structure. * * Results: - * Returns a new TcpState, or NULL with an error in the interp's - * result, if interp is not NULL. + * Returns a new TcpState, or NULL with an error in the interp's result, + * if interp is not NULL. * * Side effects: * Opens a socket. * *---------------------------------------------------------------------- @@ -2419,14 +2469,14 @@ static TcpState * CreateSocket(interp, port, host, server, myaddr, myport, async) Tcl_Interp *interp; /* For error reporting; can be NULL. */ int port; /* Port number to open. */ - CONST char *host; /* Name of host on which to open port. - * NULL implies INADDR_ANY */ - int server; /* 1 if socket should be a server socket, - * else 0 for a client socket. */ + CONST char *host; /* Name of host on which to open port. NULL + * implies INADDR_ANY */ + int server; /* 1 if socket should be a server socket, else + * 0 for a client socket. */ CONST char *myaddr; /* Optional client-side address */ int myport; /* Optional client-side port */ int async; /* If nonzero and creating a client socket, * attempt to do an async connect. Otherwise * do a synchronous connect or bind. */ @@ -2450,12 +2500,12 @@ if (sock < 0) { goto addressError; } /* - * Set the close-on-exec flag so that the socket will not get - * inherited by child processes. + * Set the close-on-exec flag so that the socket will not get inherited by + * child processes. */ fcntl(sock, F_SETFD, FD_CLOEXEC); /* @@ -2477,13 +2527,13 @@ sizeof(status)); status = bind(sock, (struct sockaddr *) &sockaddr, sizeof(struct sockaddr)); if (status != -1) { status = listen(sock, SOMAXCONN); - } + } } else { - if (myaddr != NULL || myport != 0) { + if (myaddr != NULL || myport != 0) { curState = 1; (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, (char *) &curState, sizeof(curState)); status = bind(sock, (struct sockaddr *) &mysockaddr, sizeof(struct sockaddr)); @@ -2492,13 +2542,13 @@ } } /* * Attempt to connect. The connect may fail at present with an - * EINPROGRESS but at a later time it will complete. The caller - * will set up a file handler on the socket if she is interested in - * being informed when the connect completes. + * EINPROGRESS but at a later time it will complete. The caller will + * set up a file handler on the socket if she is interested in being + * informed when the connect completes. */ if (async) { #ifndef USE_FIONBIO origState = fcntl(sock, F_GETFL); @@ -2521,14 +2571,15 @@ } } else { /* * Here we are if the connect succeeds. In case of an * asynchronous connect we have to reset the channel to - * blocking mode. This appears to happen not very often, - * but e.g. on a HP 9000/800 under HP-UX B.11.00 we enter - * this stage. [Bug: 4388] + * blocking mode. This appears to happen not very often, but + * e.g. on a HP 9000/800 under HP-UX B.11.00 we enter this + * stage. [Bug: 4388] */ + if (async) { #ifndef USE_FIONBIO origState = fcntl(sock, F_GETFL); curState = origState & ~(O_NONBLOCK); status = fcntl(sock, F_SETFL, curState); @@ -2539,11 +2590,11 @@ } } } } -bindError: + bindError: if (status < 0) { if (interp != NULL) { Tcl_AppendResult(interp, "couldn't open socket: ", Tcl_PosixError(interp), (char *) NULL); } @@ -2564,11 +2615,11 @@ } statePtr->fd = sock; return statePtr; -addressError: + addressError: if (sock != -1) { close(sock); } if (interp != NULL) { Tcl_AppendResult(interp, "couldn't open socket: ", @@ -2583,12 +2634,12 @@ * CreateSocketAddress -- * * This function initializes a sockaddr structure for a host and port. * * Results: - * 1 if the host was valid, 0 if the host could not be converted to - * an IP address. + * 1 if the host was valid, 0 if the host could not be converted to an IP + * address. * * Side effects: * Fills in the *sockaddrPtr structure. * *---------------------------------------------------------------------- @@ -2646,14 +2697,14 @@ Tcl_DStringFree(&ds); } } /* - * NOTE: On 64 bit machines the assignment below is rumored to not - * do the right thing. Please report errors related to this if you - * observe incorrect behavior on 64 bit machines such as DEC Alphas. - * Should we modify this code to do an explicit memcpy? + * NOTE: On 64 bit machines the assignment below is rumored to not do the + * right thing. Please report errors related to this if you observe + * incorrect behavior on 64 bit machines such as DEC Alphas. Should we + * modify this code to do an explicit memcpy? */ sockaddrPtr->sin_addr.s_addr = addr.s_addr; return 1; /* Success. */ } @@ -2664,12 +2715,12 @@ * Tcl_OpenTcpClient -- * * Opens a TCP client socket and creates a channel around it. * * Results: - * The channel or NULL if failed. An error message is returned - * in the interpreter on failure. + * The channel or NULL if failed. An error message is returned in the + * interpreter on failure. * * Side effects: * Opens a client socket and creates a new channel. * *---------------------------------------------------------------------- @@ -2786,13 +2837,12 @@ * Tcl_OpenTcpServer -- * * Opens a TCP server socket and creates a channel around it. * * Results: - * The channel or NULL if failed. If an error occurred, an - * error message is left in the interp's result if interp is - * not NULL. + * The channel or NULL if failed. If an error occurred, an error message + * is left in the interp's result if interp is not NULL. * * Side effects: * Opens a server socket and creates a new channel. * *---------------------------------------------------------------------- @@ -2822,12 +2872,12 @@ statePtr->acceptProc = acceptProc; statePtr->acceptProcData = acceptProcData; /* - * Set up the callback mechanism for accepting connections - * from new clients. + * Set up the callback mechanism for accepting connections from new + * clients. */ Tcl_CreateFileHandler(statePtr->fd, TCL_READABLE, TcpAccept, (ClientData) statePtr); sprintf(channelName, "sock%d", statePtr->fd); @@ -2844,12 +2894,12 @@ * * Results: * None. * * Side effects: - * Creates a new connection socket. Calls the registered callback - * for the connection acceptance mechanism. + * Creates a new connection socket. Calls the registered callback for the + * connection acceptance mechanism. * *---------------------------------------------------------------------- */ /* ARGSUSED */ @@ -2860,11 +2910,11 @@ { TcpState *sockState; /* Client data of server socket. */ int newsock; /* The new client socket */ TcpState *newSockState; /* State for new socket. */ struct sockaddr_in addr; /* The remote address */ - socklen_t len; /* For accept interface */ + socklen_t len; /* For accept interface */ char channelName[16 + TCL_INTEGER_SPACE]; sockState = (TcpState *) data; len = sizeof(struct sockaddr_in); @@ -2872,12 +2922,12 @@ if (newsock < 0) { return; } /* - * Set close-on-exec flag to prevent the newly accepted socket from - * being inherited by child processes. + * Set close-on-exec flag to prevent the newly accepted socket from being + * inherited by child processes. */ (void) fcntl(newsock, F_SETFD, FD_CLOEXEC); newSockState = (TcpState *) ckalloc((unsigned) sizeof(TcpState)); @@ -2904,19 +2954,18 @@ /* *---------------------------------------------------------------------- * * TclpGetDefaultStdChannel -- * - * Creates channels for standard input, standard output or standard - * error output if they do not already exist. + * Creates channels for standard input, standard output or standard error + * output if they do not already exist. * * Results: * Returns the specified default standard channel, or NULL. * * Side effects: - * May cause the creation of a standard channel and the underlying - * file. + * May cause the creation of a standard channel and the underlying file. * *---------------------------------------------------------------------- */ Tcl_Channel @@ -2929,44 +2978,45 @@ char *bufMode = NULL; /* * Some #def's to make the code a little clearer! */ + #define ZERO_OFFSET ((Tcl_SeekOffset) 0) #define ERROR_OFFSET ((Tcl_SeekOffset) -1) switch (type) { - case TCL_STDIN: - if ((TclOSseek(0, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET) - && (errno == EBADF)) { - return (Tcl_Channel) NULL; - } - fd = 0; - mode = TCL_READABLE; - bufMode = "line"; - break; - case TCL_STDOUT: - if ((TclOSseek(1, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET) - && (errno == EBADF)) { - return (Tcl_Channel) NULL; - } - fd = 1; - mode = TCL_WRITABLE; - bufMode = "line"; - break; - case TCL_STDERR: - if ((TclOSseek(2, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET) - && (errno == EBADF)) { - return (Tcl_Channel) NULL; - } - fd = 2; - mode = TCL_WRITABLE; - bufMode = "none"; - break; - default: - Tcl_Panic("TclGetDefaultStdChannel: Unexpected channel type"); - break; + case TCL_STDIN: + if ((TclOSseek(0, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET) + && (errno == EBADF)) { + return (Tcl_Channel) NULL; + } + fd = 0; + mode = TCL_READABLE; + bufMode = "line"; + break; + case TCL_STDOUT: + if ((TclOSseek(1, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET) + && (errno == EBADF)) { + return (Tcl_Channel) NULL; + } + fd = 1; + mode = TCL_WRITABLE; + bufMode = "line"; + break; + case TCL_STDERR: + if ((TclOSseek(2, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET) + && (errno == EBADF)) { + return (Tcl_Channel) NULL; + } + fd = 2; + mode = TCL_WRITABLE; + bufMode = "none"; + break; + default: + Tcl_Panic("TclGetDefaultStdChannel: Unexpected channel type"); + break; } #undef ZERO_OFFSET #undef ERROR_OFFSET @@ -2991,58 +3041,58 @@ /* *---------------------------------------------------------------------- * * Tcl_GetOpenFile -- * - * Given a name of a channel registered in the given interpreter, - * returns a FILE * for it. + * Given a name of a channel registered in the given interpreter, returns + * a FILE * for it. * * Results: * A standard Tcl result. If the channel is registered in the given - * interpreter and it is managed by the "file" channel driver, and - * it is open for the requested mode, then the output parameter - * filePtr is set to a FILE * for the underlying file. On error, the - * filePtr is not set, TCL_ERROR is returned and an error message is - * left in the interp's result. + * interpreter and it is managed by the "file" channel driver, and it is + * open for the requested mode, then the output parameter filePtr is set + * to a FILE * for the underlying file. On error, the filePtr is not set, + * TCL_ERROR is returned and an error message is left in the interp's + * result. * * Side effects: * May invoke fdopen to create the FILE * for the requested file. * *---------------------------------------------------------------------- */ int -Tcl_GetOpenFile(interp, string, forWriting, checkUsage, filePtr) +Tcl_GetOpenFile(interp, chanID, forWriting, checkUsage, filePtr) Tcl_Interp *interp; /* Interpreter in which to find file. */ - CONST char *string; /* String that identifies file. */ - int forWriting; /* 1 means the file is going to be used - * for writing, 0 means for reading. */ - int checkUsage; /* 1 means verify that the file was opened - * in a mode that allows the access specified - * by "forWriting". Ignored, we always - * check that the channel is open for the - * requested mode. */ + CONST char *chanID; /* String that identifies file. */ + int forWriting; /* 1 means the file is going to be used for + * writing, 0 means for reading. */ + int checkUsage; /* 1 means verify that the file was opened in + * a mode that allows the access specified by + * "forWriting". Ignored, we always check that + * the channel is open for the requested + * mode. */ ClientData *filePtr; /* Store pointer to FILE structure here. */ { Tcl_Channel chan; int chanMode; Tcl_ChannelType *chanTypePtr; ClientData data; int fd; FILE *f; - chan = Tcl_GetChannel(interp, string, &chanMode); + chan = Tcl_GetChannel(interp, chanID, &chanMode); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } if ((forWriting) && ((chanMode & TCL_WRITABLE) == 0)) { Tcl_AppendResult(interp, - "\"", string, "\" wasn't opened for writing", (char *) NULL); + "\"", chanID, "\" wasn't opened for writing", (char *) NULL); return TCL_ERROR; } else if ((!(forWriting)) && ((chanMode & TCL_READABLE) == 0)) { Tcl_AppendResult(interp, - "\"", string, "\" wasn't opened for reading", (char *) NULL); + "\"", chanID, "\" wasn't opened for reading", (char *) NULL); return TCL_ERROR; } /* * We allow creating a FILE * out of file based, pipe based and socket @@ -3062,47 +3112,46 @@ (ClientData*) &data) == TCL_OK) { fd = (int) data; /* * The call to fdopen below is probably dangerous, since it will - * truncate an existing file if the file is being opened - * for writing.... + * truncate an existing file if the file is being opened for + * writing.... */ f = fdopen(fd, (forWriting ? "w" : "r")); if (f == NULL) { - Tcl_AppendResult(interp, "cannot get a FILE * for \"", string, + Tcl_AppendResult(interp, "cannot get a FILE * for \"", chanID, "\"", (char *) NULL); return TCL_ERROR; } *filePtr = (ClientData) f; return TCL_OK; } } - Tcl_AppendResult(interp, "\"", string, + Tcl_AppendResult(interp, "\"", chanID, "\" cannot be used to get a FILE *", (char *) NULL); - return TCL_ERROR; + return TCL_ERROR; } /* *---------------------------------------------------------------------- * * TclUnixWaitForFile -- * - * This procedure waits synchronously for a file to become readable - * or writable, with an optional timeout. + * This function waits synchronously for a file to become readable or + * writable, with an optional timeout. * * Results: * The return value is an OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, and TCL_EXCEPTION, indicating the conditions - * that are present on file at the time of the return. This - * procedure will not return until either "timeout" milliseconds - * have elapsed or at least one of the conditions given by mask - * has occurred for file (a return value of 0 means that a timeout - * occurred). No normal events will be serviced during the - * execution of this procedure. + * TCL_WRITABLE, and TCL_EXCEPTION, indicating the conditions that are + * present on file at the time of the return. This function will not + * return until either "timeout" milliseconds have elapsed or at least + * one of the conditions given by mask has occurred for file (a return + * value of 0 means that a timeout occurred). No normal events will be + * serviced during the execution of this function. * * Side effects: * Time passes. * *---------------------------------------------------------------------- @@ -3112,15 +3161,15 @@ TclUnixWaitForFile(fd, mask, timeout) int fd; /* Handle for file on which to wait. */ int mask; /* What to wait for: OR'ed combination of * TCL_READABLE, TCL_WRITABLE, and * TCL_EXCEPTION. */ - int timeout; /* Maximum amount of time to wait for one - * of the conditions in mask to occur, in + int timeout; /* Maximum amount of time to wait for one of + * the conditions in mask to occur, in * milliseconds. A value of 0 means don't - * wait at all, and a value of -1 means - * wait forever. */ + * wait at all, and a value of -1 means wait + * forever. */ { Tcl_Time abortTime, now; struct timeval blockTime, *timeoutPtr; int index, bit, numFound, result = 0; fd_mask readyMasks[3*MASK_SIZE]; @@ -3128,12 +3177,12 @@ /* This array reflects the readable/writable * conditions that were found to exist by the * last call to select. */ /* - * If there is a non-zero finite timeout, compute the time when - * we give up. + * If there is a non-zero finite timeout, compute the time when we give + * up. */ if (timeout > 0) { Tcl_GetTime(&now); abortTime.sec = now.sec + timeout/1000; @@ -3161,12 +3210,12 @@ memset((VOID *) readyMasks, 0, 3*MASK_SIZE*sizeof(fd_mask)); index = fd/(NBBY*sizeof(fd_mask)); bit = 1 << (fd%(NBBY*sizeof(fd_mask))); /* - * Loop in a mini-event loop of our own, waiting for either the - * file to become ready or a timeout to occur. + * Loop in a mini-event loop of our own, waiting for either the file to + * become ready or a timeout to occur. */ while (1) { if (timeout > 0) { blockTime.tv_sec = abortTime.sec - now.sec; @@ -3197,11 +3246,14 @@ /* * Wait for the event or a timeout. */ - /* This is needed to satisfy GCC 3.3's strict aliasing rules */ + /* + * This is needed to satisfy GCC 3.3's strict aliasing rules. + */ + maskp[0] = &readyMasks[0]; maskp[1] = &readyMasks[MASK_SIZE]; maskp[2] = &readyMasks[2*MASK_SIZE]; numFound = select(fd+1, (SELECT_MASK *) maskp[0], (SELECT_MASK *) maskp[1], @@ -3237,17 +3289,17 @@ } } return result; } +#ifdef DEPRECATED /* *---------------------------------------------------------------------- * - * TclpCutFileChannel -- + * FileThreadActionProc -- * - * Remove any thread local refs to this channel. See - * Tcl_CutChannel for more info. + * Insert or remove any thread local refs to this channel. * * Results: * None. * * Side effects: @@ -3254,37 +3306,91 @@ * None. This is a no-op under unix. * *---------------------------------------------------------------------- */ -void -TclpCutFileChannel(chan) - Tcl_Channel chan; /* The channel being removed. Must - * not be referenced in any - * interpreter. */ +static void +FileThreadActionProc (instanceData, action) + ClientData instanceData; + int action; { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + FileState *fsPtr = (FileState *) instanceData; + + if (action == TCL_CHANNEL_THREAD_INSERT) { + fsPtr->nextPtr = tsdPtr->firstFilePtr; + tsdPtr->firstFilePtr = fsPtr; + } else { + FileState **nextPtrPtr; + int removed = 0; + + for (nextPtrPtr = &(tsdPtr->firstFilePtr); (*nextPtrPtr) != NULL; + nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { + if ((*nextPtrPtr) == fsPtr) { + (*nextPtrPtr) = fsPtr->nextPtr; + removed = 1; + break; + } + } + + /* + * This could happen if the channel was created in one thread and then + * moved to another without updating the thread local data in each + * thread. + */ + + if (!removed) { + Tcl_Panic("file info ptr not on thread channel list"); + } + } } +#endif /* *---------------------------------------------------------------------- * - * TclpSpliceFileChannel -- + * FileTruncateProc -- * - * Insert thread local ref for this channel. - * Tcl_SpliceChannel for more info. + * Truncates a file to a given length. * * Results: - * None. + * 0 if the operation succeeded, and -1 if it failed (in which case + * *errorCodePtr will be set to errno). * * Side effects: - * None. This is a no-op under unix. + * The underlying file is potentially truncated. This can have a wide + * variety of side effects, including moving file pointers that point at + * places later in the file than the truncate point. * *---------------------------------------------------------------------- */ -void -TclpSpliceFileChannel(chan) - Tcl_Channel chan; /* The channel being removed. Must - * not be referenced in any - * interpreter. */ +static int +FileTruncateProc(instanceData, length) + ClientData instanceData; + Tcl_WideInt length; { + FileState *fsPtr = (FileState *) instanceData; + int result; + +#ifdef HAVE_TYPE_OFF64_T + /* + * We assume this goes with the type for now... + */ + + result = ftruncate64(fsPtr->fd, (off64_t) length); +#else + result = ftruncate(fsPtr->fd, (off_t) length); +#endif + if (result) { + return errno; + } + return 0; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: unix/tclUnixEvent.c ================================================================== --- unix/tclUnixEvent.c +++ unix/tclUnixEvent.c @@ -3,17 +3,17 @@ * * This file implements Unix specific event related routines. * * Copyright (c) 1997 by Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixEvent.c,v 1.5 2004/04/06 22:25:56 dgp Exp $ + * RCS: @(#) $Id: tclUnixEvent.c,v 1.5.2.2 2005/08/02 18:16:56 dgp Exp $ */ -#include "tclPort.h" +#include "tclInt.h" /* *---------------------------------------------------------------------- * * Tcl_Sleep -- @@ -32,17 +32,16 @@ void Tcl_Sleep(ms) int ms; /* Number of milliseconds to sleep. */ { struct timeval delay; - Tcl_Time before, after; + Tcl_Time before, after, vdelay; /* - * The only trick here is that select appears to return early - * under some conditions, so we have to check to make sure that - * the right amount of time really has elapsed. If it's too - * early, go back to sleep again. + * The only trick here is that select appears to return early under some + * conditions, so we have to check to make sure that the right amount of + * time really has elapsed. If it's too early, go back to sleep again. */ Tcl_GetTime(&before); after = before; after.sec += ms/1000; @@ -50,20 +49,32 @@ if (after.usec > 1000000) { after.usec -= 1000000; after.sec += 1; } while (1) { - delay.tv_sec = after.sec - before.sec; - delay.tv_usec = after.usec - before.usec; - if (delay.tv_usec < 0) { - delay.tv_usec += 1000000; - delay.tv_sec -= 1; + /* + * TIP #233: Scale from virtual time to real-time for select. + */ + + vdelay.sec = after.sec - before.sec; + vdelay.usec = after.usec - before.usec; + + if (vdelay.usec < 0) { + vdelay.usec += 1000000; + vdelay.sec -= 1; + } + + if ((vdelay.sec != 0) || (vdelay.usec != 0)) { + (*tclScaleTimeProcPtr) (&vdelay, tclTimeClientData); } + delay.tv_sec = vdelay.sec; + delay.tv_usec = vdelay.usec; + /* - * Special note: must convert delay.tv_sec to int before comparing - * to zero, since delay.tv_usec is unsigned on some platforms. + * Special note: must convert delay.tv_sec to int before comparing to + * zero, since delay.tv_usec is unsigned on some platforms. */ if ((((int) delay.tv_sec) < 0) || ((delay.tv_usec == 0) && (delay.tv_sec == 0))) { break; @@ -71,5 +82,13 @@ (void) select(0, (SELECT_MASK *) 0, (SELECT_MASK *) 0, (SELECT_MASK *) 0, &delay); Tcl_GetTime(&before); } } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: unix/tclUnixFCmd.c ================================================================== --- unix/tclUnixFCmd.c +++ unix/tclUnixFCmd.c @@ -1,52 +1,51 @@ /* * tclUnixFCmd.c * - * This file implements the unix specific portion of file manipulation - * subcommands of the "file" command. All filename arguments should + * This file implements the unix specific portion of file manipulation + * subcommands of the "file" command. All filename arguments should * already be translated to native format. * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixFCmd.c,v 1.40 2004/11/11 01:14:41 das Exp $ + * RCS: @(#) $Id: tclUnixFCmd.c,v 1.40.2.5 2005/10/08 13:45:04 dgp Exp $ * - * Portions of this code were derived from NetBSD source code which has - * the following copyright notice: + * Portions of this code were derived from NetBSD source code which has the + * following copyright notice: * * Copyright (c) 1988, 1993, 1994 * The Regents of the University of California. All rights reserved. * * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions - * are met: - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. + * modification, are permitted provided that the following conditions are met: + * 1. Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * 3. All advertising materials mentioning features or use of this software * must display the following acknowledgement: * This product includes software developed by the University of * California, Berkeley and its contributors. - * 4. Neither the name of the University nor the names of its contributors - * may be used to endorse or promote products derived from this software + * 4. Neither the name of the University nor the names of its contributors may + * be used to endorse or promote products derived from this software * without specific prior written permission. * - * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY + * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + * DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY + * DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - * SUCH DAMAGE. + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH + * DAMAGE. */ #include "tclInt.h" #include #include @@ -59,13 +58,13 @@ /* * The following constants specify the type of callback when * TraverseUnixTree() calls the traverseProc() */ -#define DOTREE_PRED 1 /* pre-order directory */ -#define DOTREE_POSTD 2 /* post-order directory */ -#define DOTREE_F 3 /* regular file */ +#define DOTREE_PRED 1 /* pre-order directory */ +#define DOTREE_POSTD 2 /* post-order directory */ +#define DOTREE_F 3 /* regular file */ /* * Callbacks for file attributes code. */ @@ -107,69 +106,80 @@ Tcl_DString *dstPtr, CONST Tcl_StatBuf *statBufPtr, int type, Tcl_DString *errorPtr)); /* * Constants and variables necessary for file attributes subcommand. - * - * IMPORTANT: The permissions attribute is assumed to be the third - * item (i.e. to be indexed with '2' in arrays) in code in tclIOUtil.c - * and possibly elsewhere in Tcl's core. + * + * IMPORTANT: The permissions attribute is assumed to be the third item (i.e. + * to be indexed with '2' in arrays) in code in tclIOUtil.c and possibly + * elsewhere in Tcl's core. */ #ifdef DJGPP -/*See contrib/djgpp/tclDjgppFCmd.c for definitio*/ +/* + * See contrib/djgpp/tclDjgppFCmd.c for definition. + */ + extern TclFileAttrProcs tclpFileAttrProcs[]; extern char *tclpFileAttrStrings[]; #else enum { - UNIX_GROUP_ATTRIBUTE, - UNIX_OWNER_ATTRIBUTE, - UNIX_PERMISSIONS_ATTRIBUTE, + UNIX_GROUP_ATTRIBUTE, UNIX_OWNER_ATTRIBUTE, UNIX_PERMISSIONS_ATTRIBUTE, #if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) UNIX_READONLY_ATTRIBUTE, #endif #ifdef MAC_OSX_TCL - MACOSX_CREATOR_ATTRIBUTE, - MACOSX_TYPE_ATTRIBUTE, - MACOSX_HIDDEN_ATTRIBUTE, + MACOSX_CREATOR_ATTRIBUTE, MACOSX_TYPE_ATTRIBUTE, MACOSX_HIDDEN_ATTRIBUTE, MACOSX_RSRCLENGTH_ATTRIBUTE, #endif + UNIX_INVALID_ATTRIBUTE /* lint - last enum value needs no trailing , */ }; CONST char *tclpFileAttrStrings[] = { - "-group", - "-owner", - "-permissions", + "-group", "-owner", "-permissions", #if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) "-readonly", #endif #ifdef MAC_OSX_TCL - "-creator", - "-type", - "-hidden", - "-rsrclength", + "-creator", "-type", "-hidden", "-rsrclength", #endif (char *) NULL }; CONST TclFileAttrProcs tclpFileAttrProcs[] = { - {GetGroupAttribute, SetGroupAttribute}, - {GetOwnerAttribute, SetOwnerAttribute}, - {GetPermissionsAttribute, SetPermissionsAttribute}, + {GetGroupAttribute, SetGroupAttribute}, + {GetOwnerAttribute, SetOwnerAttribute}, + {GetPermissionsAttribute, SetPermissionsAttribute}, #if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) - {GetReadOnlyAttribute, SetReadOnlyAttribute}, + {GetReadOnlyAttribute, SetReadOnlyAttribute}, #endif #ifdef MAC_OSX_TCL {TclMacOSXGetFileAttribute, TclMacOSXSetFileAttribute}, {TclMacOSXGetFileAttribute, TclMacOSXSetFileAttribute}, {TclMacOSXGetFileAttribute, TclMacOSXSetFileAttribute}, {TclMacOSXGetFileAttribute, TclMacOSXSetFileAttribute}, #endif }; #endif + +/* + * This is the maximum number of consecutive readdir/unlink calls that can be + * made (with no intervening rewinddir or closedir/opendir) before triggering + * a bug that makes readdir return NULL even though some directory entries + * have not been processed. The bug afflicts SunOS's readdir when applied to + * ufs file systems and Darwin 6.5's (and OSX v.10.3.8's) HFS+. JH found the + * Darwin readdir to reset at 172, so 150 is chosen to be conservative. We + * can't do a general rewind on failure as NFS can create special files that + * recreate themselves when you try and delete them. 8.4.8 added a solution + * that was affected by a single such NFS file, this solution should not be + * affected by less than THRESHOLD such files. [Bug 1034337] + */ + +#define MAX_READDIR_UNLINK_THRESHOLD 150 + /* * Declarations for local procedures defined in this file: */ static int CopyFileAtts _ANSI_ARGS_((CONST char *src, @@ -192,15 +202,16 @@ Tcl_DString *sourcePtr, Tcl_DString *destPtr, Tcl_DString *errorPtr, int doRewind)); #ifdef PURIFY /* - * realpath and purify don't mix happily. It has been noted that realpath + * realpath and purify don't mix happily. It has been noted that realpath * should not be used with purify because of bogus warnings, but just - * memset'ing the resolved path will squelch those. This assumes we are + * memset'ing the resolved path will squelch those. This assumes we are * passing the standard MAXPATHLEN size resolved arg. */ + static char * Realpath _ANSI_ARGS_((CONST char *path, char *resolved)); char * Realpath(path, resolved) @@ -211,54 +222,52 @@ return realpath(path, resolved); } #else #define Realpath realpath #endif - /* *--------------------------------------------------------------------------- * * TclpObjRenameFile, DoRenameFile -- * - * Changes the name of an existing file or directory, from src to dst. - * If src and dst refer to the same file or directory, does nothing - * and returns success. Otherwise if dst already exists, it will be - * deleted and replaced by src subject to the following conditions: + * Changes the name of an existing file or directory, from src to dst. + * If src and dst refer to the same file or directory, does nothing and + * returns success. Otherwise if dst already exists, it will be deleted + * and replaced by src subject to the following conditions: * If src is a directory, dst may be an empty directory. * If src is a file, dst may be a file. - * In any other situation where dst already exists, the rename will - * fail. + * In any other situation where dst already exists, the rename will fail. * * Results: - * If the directory was successfully created, returns TCL_OK. - * Otherwise the return value is TCL_ERROR and errno is set to - * indicate the error. Some possible values for errno are: + * If the directory was successfully created, returns TCL_OK. Otherwise + * the return value is TCL_ERROR and errno is set to indicate the error. + * Some possible values for errno are: * - * EACCES: src or dst parent directory can't be read and/or written. + * EACCES: src or dst parent directory can't be read and/or written. * EEXIST: dst is a non-empty directory. * EINVAL: src is a root directory or dst is a subdirectory of src. * EISDIR: dst is a directory, but src is not. * ENOENT: src doesn't exist, or src or dst is "". - * ENOTDIR: src is a directory, but dst is not. + * ENOTDIR: src is a directory, but dst is not. * EXDEV: src and dst are on different filesystems. - * + * * Side effects: - * The implementation of rename may allow cross-filesystem renames, - * but the caller should be prepared to emulate it with copy and - * delete if errno is EXDEV. + * The implementation of rename may allow cross-filesystem renames, but + * the caller should be prepared to emulate it with copy and delete if + * errno is EXDEV. * *--------------------------------------------------------------------------- */ -int +int TclpObjRenameFile(srcPathPtr, destPathPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; { - return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr), - Tcl_FSGetNativePath(destPathPtr)); + return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr), + Tcl_FSGetNativePath(destPathPtr)); } static int DoRenameFile(src, dst) CONST char *src; /* Pathname of file or dir to be renamed @@ -272,39 +281,39 @@ if (errno == ENOTEMPTY) { errno = EEXIST; } /* - * IRIX returns EIO when you attept to move a directory into - * itself. We just map EIO to EINVAL get the right message on SGI. - * Most platforms don't return EIO except in really strange cases. + * IRIX returns EIO when you attept to move a directory into itself. We + * just map EIO to EINVAL get the right message on SGI. Most platforms + * don't return EIO except in really strange cases. */ - + if (errno == EIO) { errno = EINVAL; } - + #ifndef NO_REALPATH /* - * SunOS 4.1.4 reports overwriting a non-empty directory with a - * directory as EINVAL instead of EEXIST (first rule out the correct - * EINVAL result code for moving a directory into itself). Must be - * conditionally compiled because realpath() not defined on all systems. + * SunOS 4.1.4 reports overwriting a non-empty directory with a directory + * as EINVAL instead of EEXIST (first rule out the correct EINVAL result + * code for moving a directory into itself). Must be conditionally + * compiled because realpath() not defined on all systems. */ if (errno == EINVAL) { char srcPath[MAXPATHLEN], dstPath[MAXPATHLEN]; DIR *dirPtr; Tcl_DirEntry *dirEntPtr; if ((Realpath((char *) src, srcPath) != NULL) /* INTL: Native. */ - && (Realpath((char *) dst, dstPath) != NULL) /* INTL: Native. */ + && (Realpath((char *) dst, dstPath) != NULL) /* INTL: Native */ && (strncmp(srcPath, dstPath, strlen(srcPath)) != 0)) { dirPtr = opendir(dst); /* INTL: Native. */ if (dirPtr != NULL) { while (1) { - dirEntPtr = TclOSreaddir(dirPtr); /* INTL: Native. */ + dirEntPtr = TclOSreaddir(dirPtr); /* INTL: Native. */ if (dirEntPtr == NULL) { break; } if ((strcmp(dirEntPtr->d_name, ".") != 0) && (strcmp(dirEntPtr->d_name, "..") != 0)) { @@ -323,19 +332,19 @@ if (strcmp(src, "/") == 0) { /* * Alpha reports renaming / as EBUSY and Linux reports it as EACCES, * instead of EINVAL. */ - + errno = EINVAL; } /* - * DEC Alpha OSF1 V3.0 returns EACCES when attempting to move a - * file across filesystems and the parent directory of that file is - * not writable. Most other systems return EXDEV. Does nothing to - * correct this behavior. + * DEC Alpha OSF1 V3.0 returns EACCES when attempting to move a file + * across filesystems and the parent directory of that file is not + * writable. Most other systems return EXDEV. Does nothing to correct this + * behavior. */ return TCL_ERROR; } @@ -342,177 +351,180 @@ /* *--------------------------------------------------------------------------- * * TclpObjCopyFile, DoCopyFile -- * - * Copy a single file (not a directory). If dst already exists and - * is not a directory, it is removed. + * Copy a single file (not a directory). If dst already exists and is not + * a directory, it is removed. * * Results: - * If the file was successfully copied, returns TCL_OK. Otherwise - * the return value is TCL_ERROR and errno is set to indicate the - * error. Some possible values for errno are: + * If the file was successfully copied, returns TCL_OK. Otherwise the + * return value is TCL_ERROR and errno is set to indicate the error. + * Some possible values for errno are: * - * EACCES: src or dst parent directory can't be read and/or written. + * EACCES: src or dst parent directory can't be read and/or written. * EISDIR: src or dst is a directory. * ENOENT: src doesn't exist. src or dst is "". * * Side effects: - * This procedure will also copy symbolic links, block, and - * character devices, and fifos. For symbolic links, the links - * themselves will be copied and not what they point to. For the - * other special file types, the directory entry will be copied and - * not the contents of the device that it refers to. + * This procedure will also copy symbolic links, block, and character + * devices, and fifos. For symbolic links, the links themselves will be + * copied and not what they point to. For the other special file types, + * the directory entry will be copied and not the contents of the device + * that it refers to. * *--------------------------------------------------------------------------- */ -int +int TclpObjCopyFile(srcPathPtr, destPathPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; { - return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr), - Tcl_FSGetNativePath(destPathPtr)); + return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr), + Tcl_FSGetNativePath(destPathPtr)); } static int DoCopyFile(src, dst) - CONST char *src; /* Pathname of file to be copied (native). */ - CONST char *dst; /* Pathname of file to copy to (native). */ + CONST char *src; /* Pathname of file to be copied (native). */ + CONST char *dst; /* Pathname of file to copy to (native). */ { Tcl_StatBuf srcStatBuf, dstStatBuf; /* * Have to do a stat() to determine the filetype. */ - + if (TclOSlstat(src, &srcStatBuf) != 0) { /* INTL: Native. */ return TCL_ERROR; } if (S_ISDIR(srcStatBuf.st_mode)) { errno = EISDIR; return TCL_ERROR; } /* - * symlink, and some of the other calls will fail if the target - * exists, so we remove it first + * symlink, and some of the other calls will fail if the target exists, so + * we remove it first. */ - + if (TclOSlstat(dst, &dstStatBuf) == 0) { /* INTL: Native. */ if (S_ISDIR(dstStatBuf.st_mode)) { errno = EISDIR; return TCL_ERROR; } } if (unlink(dst) != 0) { /* INTL: Native. */ if (errno != ENOENT) { return TCL_ERROR; - } + } } switch ((int) (srcStatBuf.st_mode & S_IFMT)) { #ifndef DJGPP - case S_IFLNK: { - char link[MAXPATHLEN]; - int length; - - length = readlink(src, link, sizeof(link)); /* INTL: Native. */ - if (length == -1) { - return TCL_ERROR; - } - link[length] = '\0'; - if (symlink(link, dst) < 0) { /* INTL: Native. */ - return TCL_ERROR; - } - break; - } + case S_IFLNK: { + char link[MAXPATHLEN]; + int length; + + length = readlink(src, link, sizeof(link)); /* INTL: Native. */ + if (length == -1) { + return TCL_ERROR; + } + link[length] = '\0'; + if (symlink(link, dst) < 0) { /* INTL: Native. */ + return TCL_ERROR; + } + break; + } #endif - case S_IFBLK: - case S_IFCHR: { - if (mknod(dst, srcStatBuf.st_mode, /* INTL: Native. */ - srcStatBuf.st_rdev) < 0) { - return TCL_ERROR; - } - return CopyFileAtts(src, dst, &srcStatBuf); - } - case S_IFIFO: { - if (mkfifo(dst, srcStatBuf.st_mode) < 0) { /* INTL: Native. */ - return TCL_ERROR; - } - return CopyFileAtts(src, dst, &srcStatBuf); - } - default: { - return TclUnixCopyFile(src, dst, &srcStatBuf, 0); - } + case S_IFBLK: + case S_IFCHR: + if (mknod(dst, srcStatBuf.st_mode, /* INTL: Native. */ + srcStatBuf.st_rdev) < 0) { + return TCL_ERROR; + } + return CopyFileAtts(src, dst, &srcStatBuf); + case S_IFIFO: + if (mkfifo(dst, srcStatBuf.st_mode) < 0) { /* INTL: Native. */ + return TCL_ERROR; + } + return CopyFileAtts(src, dst, &srcStatBuf); + default: + return TclUnixCopyFile(src, dst, &srcStatBuf, 0); } return TCL_OK; } /* *---------------------------------------------------------------------- * - * TclUnixCopyFile - + * TclUnixCopyFile - * - * Helper function for TclpCopyFile. Copies one regular file, - * using read() and write(). + * Helper function for TclpCopyFile. Copies one regular file, using + * read() and write(). * * Results: * A standard Tcl result. * * Side effects: - * A file is copied. Dst will be overwritten if it exists. + * A file is copied. Dst will be overwritten if it exists. * *---------------------------------------------------------------------- */ -int -TclUnixCopyFile(src, dst, statBufPtr, dontCopyAtts) +int +TclUnixCopyFile(src, dst, statBufPtr, dontCopyAtts) CONST char *src; /* Pathname of file to copy (native). */ CONST char *dst; /* Pathname of file to create/overwrite * (native). */ CONST Tcl_StatBuf *statBufPtr; /* Used to determine mode and blocksize. */ - int dontCopyAtts; /* if flag set, don't copy attributes. */ + int dontCopyAtts; /* If flag set, don't copy attributes. */ { - int srcFd; - int dstFd; - u_int blockSize; /* Optimal I/O blocksize for filesystem */ - char *buffer; /* Data buffer for copy */ + int srcFd, dstFd; + unsigned blockSize; /* Optimal I/O blocksize for filesystem */ + char *buffer; /* Data buffer for copy */ size_t nread; #ifdef DJGPP #define BINMODE |O_BINARY #else #define BINMODE #endif - if ((srcFd = TclOSopen(src, O_RDONLY BINMODE, 0)) < 0) { /* INTL: Native. */ + if ((srcFd = TclOSopen(src, O_RDONLY BINMODE, 0)) < 0) { /* INTL: Native */ return TCL_ERROR; } - dstFd = TclOSopen(dst, O_CREAT|O_TRUNC|O_WRONLY BINMODE, /* INTL: Native. */ + dstFd = TclOSopen(dst, O_CREAT|O_TRUNC|O_WRONLY BINMODE, /* INTL: Native */ statBufPtr->st_mode); if (dstFd < 0) { - close(srcFd); + close(srcFd); return TCL_ERROR; } + /* + * Try to work out the best size of buffer to use for copying. If we + * can't, it's no big deal as we can just use a (32-bit) page, since + * that's likely to be fairly efficient anyway. + */ + #ifdef HAVE_ST_BLKSIZE blockSize = statBufPtr->st_blksize; #else #ifndef NO_FSTATFS { struct statfs fs; + if (fstatfs(srcFd, &fs, sizeof(fs), 0) == 0) { blockSize = fs.f_bsize; } else { blockSize = 4096; } } -#else +#else blockSize = 4096; #endif #endif buffer = ckalloc(blockSize); @@ -524,22 +536,21 @@ if (write(dstFd, buffer, nread) != nread) { nread = (size_t) -1; break; } } - + ckfree(buffer); close(srcFd); if ((close(dstFd) != 0) || (nread == -1)) { unlink(dst); /* INTL: Native. */ return TCL_ERROR; } if (!dontCopyAtts && CopyFileAtts(src, dst, statBufPtr) == TCL_ERROR) { /* - * The copy succeeded, but setting the permissions failed, so be in - * a consistent state, we remove the file that was created by the - * copy. + * The copy succeeded, but setting the permissions failed, so be in a + * consistent state, we remove the file that was created by the copy. */ unlink(dst); /* INTL: Native. */ return TCL_ERROR; } @@ -549,37 +560,37 @@ /* *--------------------------------------------------------------------------- * * TclpObjDeleteFile, TclpDeleteFile -- * - * Removes a single file (not a directory). + * Removes a single file (not a directory). * * Results: - * If the file was successfully deleted, returns TCL_OK. Otherwise - * the return value is TCL_ERROR and errno is set to indicate the - * error. Some possible values for errno are: + * If the file was successfully deleted, returns TCL_OK. Otherwise the + * return value is TCL_ERROR and errno is set to indicate the error. + * Some possible values for errno are: * - * EACCES: a parent directory can't be read and/or written. + * EACCES: a parent directory can't be read and/or written. * EISDIR: path is a directory. * ENOENT: path doesn't exist or is "". * * Side effects: - * The file is deleted, even if it is read-only. + * The file is deleted, even if it is read-only. * *--------------------------------------------------------------------------- */ -int +int TclpObjDeleteFile(pathPtr) Tcl_Obj *pathPtr; { return TclpDeleteFile(Tcl_FSGetNativePath(pathPtr)); } int TclpDeleteFile(path) - CONST char *path; /* Pathname of file to be removed (native). */ + CONST char *path; /* Pathname of file to be removed (native). */ { if (unlink(path) != 0) { /* INTL: Native. */ return TCL_ERROR; } return TCL_OK; @@ -588,32 +599,32 @@ /* *--------------------------------------------------------------------------- * * TclpCreateDirectory, DoCreateDirectory -- * - * Creates the specified directory. All parent directories of the - * specified directory must already exist. The directory is - * automatically created with permissions so that user can access - * the new directory and create new files or subdirectories in it. + * Creates the specified directory. All parent directories of the + * specified directory must already exist. The directory is automatically + * created with permissions so that user can access the new directory and + * create new files or subdirectories in it. * * Results: - * If the directory was successfully created, returns TCL_OK. - * Otherwise the return value is TCL_ERROR and errno is set to - * indicate the error. Some possible values for errno are: + * If the directory was successfully created, returns TCL_OK. Otherwise + * the return value is TCL_ERROR and errno is set to indicate the error. + * Some possible values for errno are: * - * EACCES: a parent directory can't be read and/or written. + * EACCES: a parent directory can't be read and/or written. * EEXIST: path already exists. * ENOENT: a parent directory doesn't exist. * * Side effects: - * A directory is created with the current umask, except that - * permission for u+rwx will always be added. + * A directory is created with the current umask, except that permission + * for u+rwx will always be added. * *--------------------------------------------------------------------------- */ -int +int TclpObjCreateDirectory(pathPtr) Tcl_Obj *pathPtr; { return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr)); } @@ -642,53 +653,51 @@ /* *--------------------------------------------------------------------------- * * TclpObjCopyDirectory -- * - * Recursively copies a directory. The target directory dst must - * not already exist. Note that this function does not merge two - * directory hierarchies, even if the target directory is an an - * empty directory. + * Recursively copies a directory. The target directory dst must not + * already exist. Note that this function does not merge two directory + * hierarchies, even if the target directory is an an empty directory. * * Results: - * If the directory was successfully copied, returns TCL_OK. - * Otherwise the return value is TCL_ERROR, errno is set to indicate - * the error, and the pathname of the file that caused the error - * is stored in errorPtr. See TclpObjCreateDirectory and - * TclpObjCopyFile for a description of possible values for errno. + * If the directory was successfully copied, returns TCL_OK. Otherwise + * the return value is TCL_ERROR, errno is set to indicate the error, and + * the pathname of the file that caused the error is stored in errorPtr. + * See TclpObjCreateDirectory and TclpObjCopyFile for a description of + * possible values for errno. * * Side effects: - * An exact copy of the directory hierarchy src will be created - * with the name dst. If an error occurs, the error will - * be returned immediately, and remaining files will not be - * processed. + * An exact copy of the directory hierarchy src will be created with the + * name dst. If an error occurs, the error will be returned immediately, + * and remaining files will not be processed. * *--------------------------------------------------------------------------- */ -int +int TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; Tcl_Obj **errorPtr; { Tcl_DString ds; Tcl_DString srcString, dstString; int ret; Tcl_Obj *transPtr; - + transPtr = Tcl_FSGetTranslatedPath(NULL,srcPathPtr); - Tcl_UtfToExternalDString(NULL, - (transPtr != NULL ? Tcl_GetString(transPtr) : NULL), - -1, &srcString); + Tcl_UtfToExternalDString(NULL, + (transPtr != NULL ? Tcl_GetString(transPtr) : NULL), + -1, &srcString); if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } transPtr = Tcl_FSGetTranslatedPath(NULL,destPathPtr); - Tcl_UtfToExternalDString(NULL, - (transPtr != NULL ? Tcl_GetString(transPtr) : NULL), - -1, &dstString); + Tcl_UtfToExternalDString(NULL, + (transPtr != NULL ? Tcl_GetString(transPtr) : NULL), + -1, &dstString); if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } ret = TraverseUnixTree(TraversalCopy, &srcString, &dstString, &ds, 0); @@ -711,29 +720,29 @@ * TclpRemoveDirectory, DoRemoveDirectory -- * * Removes directory (and its contents, if the recursive flag is set). * * Results: - * If the directory was successfully removed, returns TCL_OK. - * Otherwise the return value is TCL_ERROR, errno is set to indicate - * the error, and the pathname of the file that caused the error - * is stored in errorPtr. Some possible values for errno are: + * If the directory was successfully removed, returns TCL_OK. Otherwise + * the return value is TCL_ERROR, errno is set to indicate the error, and + * the pathname of the file that caused the error is stored in errorPtr. + * Some possible values for errno are: * - * EACCES: path directory can't be read and/or written. + * EACCES: path directory can't be read and/or written. * EEXIST: path is a non-empty directory. * EINVAL: path is a root directory. * ENOENT: path doesn't exist or is "". * ENOTDIR: path is not a directory. * * Side effects: - * Directory removed. If an error occurs, the error will be returned + * Directory removed. If an error occurs, the error will be returned * immediately, and remaining files will not be deleted. * *--------------------------------------------------------------------------- */ - -int + +int TclpObjRemoveDirectory(pathPtr, recursive, errorPtr) Tcl_Obj *pathPtr; int recursive; Tcl_Obj **errorPtr; { @@ -740,13 +749,13 @@ Tcl_DString ds; Tcl_DString pathString; int ret; Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); - Tcl_UtfToExternalDString(NULL, - (transPtr != NULL ? Tcl_GetString(transPtr) : NULL), - -1, &pathString); + Tcl_UtfToExternalDString(NULL, + (transPtr != NULL ? Tcl_GetString(transPtr) : NULL), + -1, &pathString); if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } ret = DoRemoveDirectory(&pathString, recursive, &ds); Tcl_DStringFree(&pathString); @@ -761,36 +770,39 @@ static int DoRemoveDirectory(pathPtr, recursive, errorPtr) Tcl_DString *pathPtr; /* Pathname of directory to be removed * (native). */ - int recursive; /* If non-zero, removes directories that - * are nonempty. Otherwise, will only remove - * empty directories. */ - Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free - * DString filled with UTF-8 name of file - * causing error. */ + int recursive; /* If non-zero, removes directories that are + * nonempty. Otherwise, will only remove empty + * directories. */ + Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free DString + * filled with UTF-8 name of file causing + * error. */ { CONST char *path; mode_t oldPerm = 0; int result; - + path = Tcl_DStringValue(pathPtr); - + if (recursive != 0) { - /* We should try to change permissions so this can be deleted */ + /* + * We should try to change permissions so this can be deleted. + */ + Tcl_StatBuf statBuf; int newPerm; if (TclOSstat(path, &statBuf) == 0) { oldPerm = (mode_t) (statBuf.st_mode & 0x00007FFF); } - + newPerm = oldPerm | (64+128+256); chmod(path, (mode_t) newPerm); } - + if (rmdir(path) == 0) { /* INTL: Native. */ return TCL_OK; } if (errno == ENOTEMPTY) { errno = EEXIST; @@ -801,72 +813,76 @@ if (errorPtr != NULL) { Tcl_ExternalToUtfDString(NULL, path, -1, errorPtr); } result = TCL_ERROR; } - + /* - * The directory is nonempty, but the recursive flag has been - * specified, so we recursively remove all the files in the directory. + * The directory is nonempty, but the recursive flag has been specified, + * so we recursively remove all the files in the directory. */ if (result == TCL_OK) { result = TraverseUnixTree(TraversalDelete, pathPtr, NULL, errorPtr, 1); } - + if ((result != TCL_OK) && (recursive != 0)) { - /* Try to restore permissions */ - chmod(path, oldPerm); + /* + * Try to restore permissions. + */ + + chmod(path, oldPerm); } return result; } - + /* *--------------------------------------------------------------------------- * * TraverseUnixTree -- * - * Traverse directory tree specified by sourcePtr, calling the function - * traverseProc for each file and directory encountered. If destPtr - * is non-null, each of name in the sourcePtr directory is appended to - * the directory specified by destPtr and passed as the second argument - * to traverseProc() . + * Traverse directory tree specified by sourcePtr, calling the function + * traverseProc for each file and directory encountered. If destPtr is + * non-null, each of name in the sourcePtr directory is appended to the + * directory specified by destPtr and passed as the second argument to + * traverseProc(). * * Results: - * Standard Tcl result. + * Standard Tcl result. * * Side effects: - * None caused by TraverseUnixTree, however the user specified - * traverseProc() may change state. If an error occurs, the error will - * be returned immediately, and remaining files will not be processed. + * None caused by TraverseUnixTree, however the user specified + * traverseProc() may change state. If an error occurs, the error will be + * returned immediately, and remaining files will not be processed. * *--------------------------------------------------------------------------- */ -static int +static int TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr, doRewind) TraversalProc *traverseProc;/* Function to call for every file and * directory in source hierarchy. */ Tcl_DString *sourcePtr; /* Pathname of source directory to be * traversed (native). */ Tcl_DString *targetPtr; /* Pathname of directory to traverse in * parallel with source directory (native). */ - Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free - * DString filled with UTF-8 name of file - * causing error. */ + Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free DString + * filled with UTF-8 name of file causing + * error. */ int doRewind; /* Flag indicating that to ensure complete * traversal of source hierarchy, the readdir * loop should be rewound whenever * traverseProc has returned TCL_OK; this is * required when traverseProc modifies the - * source hierarchy, e.g. by deleting files. */ + * source hierarchy, e.g. by deleting + * files. */ { Tcl_StatBuf statBuf; CONST char *source, *errfile; int result, sourceLen; int targetLen; - int needRewind; + int numProcessed = 0; Tcl_DirEntry *dirEntPtr; DIR *dirPtr; errfile = NULL; result = TCL_OK; @@ -885,11 +901,11 @@ return (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_F, errorPtr); } dirPtr = opendir(source); /* INTL: Native. */ if (dirPtr == NULL) { - /* + /* * Can't read directory */ errfile = source; goto end; @@ -898,60 +914,62 @@ errorPtr); if (result != TCL_OK) { closedir(dirPtr); return result; } - + Tcl_DStringAppend(sourcePtr, "/", 1); - sourceLen = Tcl_DStringLength(sourcePtr); + sourceLen = Tcl_DStringLength(sourcePtr); if (targetPtr != NULL) { Tcl_DStringAppend(targetPtr, "/", 1); targetLen = Tcl_DStringLength(targetPtr); } - do { - needRewind = 0; - while ((dirEntPtr = TclOSreaddir(dirPtr)) != NULL) { /* INTL: Native. */ - if ((dirEntPtr->d_name[0] == '.') - && ((dirEntPtr->d_name[1] == '\0') - || (strcmp(dirEntPtr->d_name, "..") == 0))) { - continue; - } - - /* - * Append name after slash, and recurse on the file. - */ - - Tcl_DStringAppend(sourcePtr, dirEntPtr->d_name, -1); - if (targetPtr != NULL) { - Tcl_DStringAppend(targetPtr, dirEntPtr->d_name, -1); - } - result = TraverseUnixTree(traverseProc, sourcePtr, targetPtr, - errorPtr, doRewind); - if (result != TCL_OK) { - needRewind = 0; - break; - } else { - needRewind = doRewind; - } - - /* - * Remove name after slash. - */ - - Tcl_DStringSetLength(sourcePtr, sourceLen); - if (targetPtr != NULL) { - Tcl_DStringSetLength(targetPtr, targetLen); - } - } - if (needRewind) { + while ((dirEntPtr = TclOSreaddir(dirPtr)) != NULL) { /* INTL: Native. */ + if ((dirEntPtr->d_name[0] == '.') + && ((dirEntPtr->d_name[1] == '\0') + || (strcmp(dirEntPtr->d_name, "..") == 0))) { + continue; + } + + /* + * Append name after slash, and recurse on the file. + */ + + Tcl_DStringAppend(sourcePtr, dirEntPtr->d_name, -1); + if (targetPtr != NULL) { + Tcl_DStringAppend(targetPtr, dirEntPtr->d_name, -1); + } + result = TraverseUnixTree(traverseProc, sourcePtr, targetPtr, + errorPtr, doRewind); + if (result != TCL_OK) { + break; + } else { + numProcessed++; + } + + /* + * Remove name after slash. + */ + + Tcl_DStringSetLength(sourcePtr, sourceLen); + if (targetPtr != NULL) { + Tcl_DStringSetLength(targetPtr, targetLen); + } + if (doRewind && (numProcessed > MAX_READDIR_UNLINK_THRESHOLD)) { + /* + * Call rewinddir if we've called unlink or rmdir so many times + * (since the opendir or the previous rewinddir), to avoid + * a NULL-return that may a symptom of a buggy readdir. + */ rewinddir(dirPtr); + numProcessed = 0; } - } while (needRewind); + } closedir(dirPtr); - + /* * Strip off the trailing slash we added */ Tcl_DStringSetLength(sourcePtr, sourceLen - 1); @@ -959,83 +977,83 @@ Tcl_DStringSetLength(targetPtr, targetLen - 1); } if (result == TCL_OK) { /* - * Call traverseProc() on a directory after visiting all the - * files in that directory. + * Call traverseProc() on a directory after visiting all the files in + * that directory. */ result = (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_POSTD, errorPtr); } - end: + + end: if (errfile != NULL) { if (errorPtr != NULL) { Tcl_ExternalToUtfDString(NULL, errfile, -1, errorPtr); } result = TCL_ERROR; } - + return result; } /* *---------------------------------------------------------------------- * * TraversalCopy * - * Called from TraverseUnixTree in order to execute a recursive copy - * of a directory. + * Called from TraverseUnixTree in order to execute a recursive copy of a + * directory. * * Results: - * Standard Tcl result. + * Standard Tcl result. * * Side effects: - * The file or directory src may be copied to dst, depending on - * the value of type. - * + * The file or directory src may be copied to dst, depending on the value + * of type. + * *---------------------------------------------------------------------- */ -static int -TraversalCopy(srcPtr, dstPtr, statBufPtr, type, errorPtr) +static int +TraversalCopy(srcPtr, dstPtr, statBufPtr, type, errorPtr) Tcl_DString *srcPtr; /* Source pathname to copy (native). */ Tcl_DString *dstPtr; /* Destination pathname of copy (native). */ CONST Tcl_StatBuf *statBufPtr; /* Stat info for file specified by srcPtr. */ - int type; /* Reason for call - see TraverseUnixTree(). */ - Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free - * DString filled with UTF-8 name of file - * causing error. */ + int type; /* Reason for call - see TraverseUnixTree(). */ + Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free DString + * filled with UTF-8 name of file causing + * error. */ { switch (type) { - case DOTREE_F: - if (DoCopyFile(Tcl_DStringValue(srcPtr), - Tcl_DStringValue(dstPtr)) == TCL_OK) { - return TCL_OK; - } - break; - - case DOTREE_PRED: - if (DoCreateDirectory(Tcl_DStringValue(dstPtr)) == TCL_OK) { - return TCL_OK; - } - break; - - case DOTREE_POSTD: - if (CopyFileAtts(Tcl_DStringValue(srcPtr), - Tcl_DStringValue(dstPtr), statBufPtr) == TCL_OK) { - return TCL_OK; - } - break; - + case DOTREE_F: + if (DoCopyFile(Tcl_DStringValue(srcPtr), + Tcl_DStringValue(dstPtr)) == TCL_OK) { + return TCL_OK; + } + break; + + case DOTREE_PRED: + if (DoCreateDirectory(Tcl_DStringValue(dstPtr)) == TCL_OK) { + return TCL_OK; + } + break; + + case DOTREE_POSTD: + if (CopyFileAtts(Tcl_DStringValue(srcPtr), + Tcl_DStringValue(dstPtr), statBufPtr) == TCL_OK) { + return TCL_OK; + } + break; } /* - * There shouldn't be a problem with src, because we already checked it - * to get here. + * There shouldn't be a problem with src, because we already checked it to + * get here. */ if (errorPtr != NULL) { Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(dstPtr), Tcl_DStringLength(dstPtr), errorPtr); @@ -1046,51 +1064,48 @@ /* *--------------------------------------------------------------------------- * * TraversalDelete -- * - * Called by procedure TraverseUnixTree for every file and directory - * that it encounters in a directory hierarchy. This procedure unlinks - * files, and removes directories after all the containing files - * have been processed. + * Called by procedure TraverseUnixTree for every file and directory that + * it encounters in a directory hierarchy. This procedure unlinks files, + * and removes directories after all the containing files have been + * processed. * * Results: - * Standard Tcl result. + * Standard Tcl result. * * Side effects: - * Files or directory specified by src will be deleted. + * Files or directory specified by src will be deleted. * *---------------------------------------------------------------------- */ static int -TraversalDelete(srcPtr, ignore, statBufPtr, type, errorPtr) +TraversalDelete(srcPtr, ignore, statBufPtr, type, errorPtr) Tcl_DString *srcPtr; /* Source pathname (native). */ Tcl_DString *ignore; /* Destination pathname (not used). */ CONST Tcl_StatBuf *statBufPtr; /* Stat info for file specified by srcPtr. */ - int type; /* Reason for call - see TraverseUnixTree(). */ - Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free - * DString filled with UTF-8 name of file - * causing error. */ + int type; /* Reason for call - see TraverseUnixTree(). */ + Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free DString + * filled with UTF-8 name of file causing + * error. */ { switch (type) { - case DOTREE_F: { - if (TclpDeleteFile(Tcl_DStringValue(srcPtr)) == 0) { - return TCL_OK; - } - break; - } - case DOTREE_PRED: { - return TCL_OK; - } - case DOTREE_POSTD: { - if (DoRemoveDirectory(srcPtr, 0, NULL) == 0) { - return TCL_OK; - } - break; - } + case DOTREE_F: + if (TclpDeleteFile(Tcl_DStringValue(srcPtr)) == 0) { + return TCL_OK; + } + break; + case DOTREE_PRED: + return TCL_OK; + case DOTREE_POSTD: + if (DoRemoveDirectory(srcPtr, 0, NULL) == 0) { + return TCL_OK; + } + break; } if (errorPtr != NULL) { Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(srcPtr), Tcl_DStringLength(srcPtr), errorPtr); } @@ -1100,55 +1115,53 @@ /* *--------------------------------------------------------------------------- * * CopyFileAtts -- * - * Copy the file attributes such as owner, group, permissions, - * and modification date from one file to another. + * Copy the file attributes such as owner, group, permissions, and + * modification date from one file to another. * * Results: * Standard Tcl result. * * Side effects: - * user id, group id, permission bits, last modification time, and - * last access time are updated in the new file to reflect the - * old file. + * User id, group id, permission bits, last modification time, and last + * access time are updated in the new file to reflect the old file. * *--------------------------------------------------------------------------- */ static int -CopyFileAtts(src, dst, statBufPtr) +CopyFileAtts(src, dst, statBufPtr) CONST char *src; /* Path name of source file (native). */ CONST char *dst; /* Path name of target file (native). */ CONST Tcl_StatBuf *statBufPtr; /* Stat info for source file */ { struct utimbuf tval; mode_t newMode; - + newMode = statBufPtr->st_mode & (S_ISUID | S_ISGID | S_IRWXU | S_IRWXG | S_IRWXO); - - /* - * Note that if you copy a setuid file that is owned by someone - * else, and you are not root, then the copy will be setuid to you. - * The most correct implementation would probably be to have the - * copy not setuid to anyone if the original file was owned by - * someone else, but this corner case isn't currently handled. - * It would require another lstat(), or getuid(). + + /* + * Note that if you copy a setuid file that is owned by someone else, and + * you are not root, then the copy will be setuid to you. The most correct + * implementation would probably be to have the copy not setuid to anyone + * if the original file was owned by someone else, but this corner case + * isn't currently handled. It would require another lstat(), or getuid(). */ - + if (chmod(dst, newMode)) { /* INTL: Native. */ newMode &= ~(S_ISUID | S_ISGID); if (chmod(dst, newMode)) { /* INTL: Native. */ return TCL_ERROR; } } - tval.actime = statBufPtr->st_atime; - tval.modtime = statBufPtr->st_mtime; + tval.actime = statBufPtr->st_atime; + tval.modtime = statBufPtr->st_mtime; if (utime(dst, &tval)) { /* INTL: Native. */ return TCL_ERROR; } #ifdef MAC_OSX_TCL @@ -1161,19 +1174,19 @@ /* *---------------------------------------------------------------------- * * GetGroupAttribute * - * Gets the group attribute of a file. + * Gets the group attribute of a file. * * Results: - * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr - * if there is no error. + * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there + * is no error. * * Side effects: - * A new object is allocated. - * + * A new object is allocated. + * *---------------------------------------------------------------------- */ static int GetGroupAttribute(interp, objIndex, fileName, attributePtrPtr) @@ -1185,14 +1198,14 @@ Tcl_StatBuf statBuf; struct group *groupPtr; int result; result = TclpObjStat(fileName, &statBuf); - + if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", + Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } @@ -1202,11 +1215,11 @@ *attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_gid); } else { Tcl_DString ds; CONST char *utf; - utf = Tcl_ExternalToUtfDString(NULL, groupPtr->gr_name, -1, &ds); + utf = Tcl_ExternalToUtfDString(NULL, groupPtr->gr_name, -1, &ds); *attributePtrPtr = Tcl_NewStringObj(utf, -1); Tcl_DStringFree(&ds); } endgrent(); return TCL_OK; @@ -1215,19 +1228,19 @@ /* *---------------------------------------------------------------------- * * GetOwnerAttribute * - * Gets the owner attribute of a file. + * Gets the owner attribute of a file. * * Results: - * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr - * if there is no error. + * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there + * is no error. * * Side effects: - * A new object is allocated. - * + * A new object is allocated. + * *---------------------------------------------------------------------- */ static int GetOwnerAttribute(interp, objIndex, fileName, attributePtrPtr) @@ -1239,14 +1252,14 @@ Tcl_StatBuf statBuf; struct passwd *pwPtr; int result; result = TclpObjStat(fileName, &statBuf); - + if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", + Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } @@ -1256,11 +1269,11 @@ *attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_uid); } else { Tcl_DString ds; CONST char *utf; - utf = Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, -1, &ds); + utf = Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, -1, &ds); *attributePtrPtr = Tcl_NewStringObj(utf, Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); } endpwent(); return TCL_OK; @@ -1269,19 +1282,19 @@ /* *---------------------------------------------------------------------- * * GetPermissionsAttribute * - * Gets the group attribute of a file. + * Gets the group attribute of a file. * * Results: - * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr - * if there is no error. The object will have ref count 0. + * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there + * is no error. The object will have ref count 0. * * Side effects: - * A new object is allocated. - * + * A new object is allocated. + * *---------------------------------------------------------------------- */ static int GetPermissionsAttribute(interp, objIndex, fileName, attributePtrPtr) @@ -1289,53 +1302,52 @@ int objIndex; /* The index of the attribute. */ Tcl_Obj *fileName; /* The name of the file (UTF-8). */ Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ { Tcl_StatBuf statBuf; - char returnString[7]; int result; result = TclpObjStat(fileName, &statBuf); - + if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", + Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } - sprintf(returnString, "%0#5lo", (long) (statBuf.st_mode & 0x00007FFF)); + *attributePtrPtr = Tcl_NewObj(); + TclObjPrintf(NULL, *attributePtrPtr, "%0#5lo", + (long) (statBuf.st_mode & 0x00007FFF)); - *attributePtrPtr = Tcl_NewStringObj(returnString, -1); - return TCL_OK; } /* *--------------------------------------------------------------------------- * * SetGroupAttribute -- * - * Sets the group of the file to the specified group. + * Sets the group of the file to the specified group. * * Results: - * Standard TCL result. + * Standard TCL result. * * Side effects: - * As above. - * + * As above. + * *--------------------------------------------------------------------------- */ static int SetGroupAttribute(interp, objIndex, fileName, attributePtr) - Tcl_Interp *interp; /* The interp for error reporting. */ - int objIndex; /* The index of the attribute. */ - Tcl_Obj *fileName; /* The name of the file (UTF-8). */ - Tcl_Obj *attributePtr; /* New group for file. */ + Tcl_Interp *interp; /* The interp for error reporting. */ + int objIndex; /* The index of the attribute. */ + Tcl_Obj *fileName; /* The name of the file (UTF-8). */ + Tcl_Obj *attributePtr; /* New group for file. */ { long gid; int result; CONST char *native; @@ -1353,11 +1365,11 @@ if (groupPtr == NULL) { endgrent(); if (interp != NULL) { Tcl_AppendResult(interp, "could not set group for file \"", - Tcl_GetString(fileName), "\": group \"", + Tcl_GetString(fileName), "\": group \"", string, "\" does not exist", (char *) NULL); } return TCL_ERROR; } @@ -1369,40 +1381,40 @@ endgrent(); if (result != 0) { if (interp != NULL) { Tcl_AppendResult(interp, "could not set group for file \"", - Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), + Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; - } + } return TCL_OK; } /* *--------------------------------------------------------------------------- * * SetOwnerAttribute -- * - * Sets the owner of the file to the specified owner. + * Sets the owner of the file to the specified owner. * * Results: - * Standard TCL result. + * Standard TCL result. * * Side effects: - * As above. - * + * As above. + * *--------------------------------------------------------------------------- */ static int SetOwnerAttribute(interp, objIndex, fileName, attributePtr) - Tcl_Interp *interp; /* The interp for error reporting. */ - int objIndex; /* The index of the attribute. */ - Tcl_Obj *fileName; /* The name of the file (UTF-8). */ - Tcl_Obj *attributePtr; /* New owner for file. */ + Tcl_Interp *interp; /* The interp for error reporting. */ + int objIndex; /* The index of the attribute. */ + Tcl_Obj *fileName; /* The name of the file (UTF-8). */ + Tcl_Obj *attributePtr; /* New owner for file. */ { long uid; int result; CONST char *native; @@ -1432,11 +1444,11 @@ native = Tcl_FSGetNativePath(fileName); result = chown(native, (uid_t) uid, (gid_t) -1); /* INTL: Native. */ if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not set owner for file \"", + Tcl_AppendResult(interp, "could not set owner for file \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } @@ -1446,52 +1458,54 @@ /* *--------------------------------------------------------------------------- * * SetPermissionsAttribute * - * Sets the file to the given permission. + * Sets the file to the given permission. * * Results: - * Standard TCL result. + * Standard TCL result. * * Side effects: - * The permission of the file is changed. - * + * The permission of the file is changed. + * *--------------------------------------------------------------------------- */ static int SetPermissionsAttribute(interp, objIndex, fileName, attributePtr) - Tcl_Interp *interp; /* The interp we are using for errors. */ - int objIndex; /* The index of the attribute. */ - Tcl_Obj *fileName; /* The name of the file (UTF-8). */ - Tcl_Obj *attributePtr; /* The attribute to set. */ + Tcl_Interp *interp; /* The interp we are using for errors. */ + int objIndex; /* The index of the attribute. */ + Tcl_Obj *fileName; /* The name of the file (UTF-8). */ + Tcl_Obj *attributePtr; /* The attribute to set. */ { long mode; mode_t newMode; int result; CONST char *native; /* * First try if the string is a number */ + if (Tcl_GetLongFromObj(NULL, attributePtr, &mode) == TCL_OK) { - newMode = (mode_t) (mode & 0x00007FFF); + newMode = (mode_t) (mode & 0x00007FFF); } else { Tcl_StatBuf buf; char *modeStringPtr = Tcl_GetString(attributePtr); /* * Try the forms "rwxrwxrwx" and "ugo=rwx" * - * We get the current mode of the file, in order to allow for - * ug+-=rwx style chmod strings. + * We get the current mode of the file, in order to allow for ug+-=rwx + * style chmod strings. */ + result = TclpObjStat(fileName, &buf); if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", + Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } @@ -1508,11 +1522,11 @@ native = Tcl_FSGetNativePath(fileName); result = chmod(native, newMode); /* INTL: Native. */ if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not set permissions for file \"", + Tcl_AppendResult(interp, "could not set permissions for file \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } @@ -1549,13 +1563,13 @@ /* *---------------------------------------------------------------------- * * GetModeFromPermString -- * - * This procedure is invoked to process the "file permissions" - * Tcl command, to check for a "rwxrwxrwx" or "ugoa+-=rwxst" string. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "file permissions" Tcl + * command, to check for a "rwxrwxrwx" or "ugoa+-=rwxst" string. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -1569,82 +1583,83 @@ Tcl_Interp *interp; /* The interp we are using for errors. */ char *modeStringPtr; /* Permissions string */ mode_t *modePtr; /* pointer to the mode value */ { mode_t newMode; - mode_t oldMode; /* Storage for the value of the old mode - * (that is passed in), to allow for the - * chmod style manipulation */ + mode_t oldMode; /* Storage for the value of the old mode (that + * is passed in), to allow for the chmod style + * manipulation. */ int i,n, who, op, what, op_found, who_found; /* * We start off checking for an "rwxrwxrwx" style permissions string */ + if (strlen(modeStringPtr) != 9) { - goto chmodStyleCheck; + goto chmodStyleCheck; } newMode = 0; for (i = 0; i < 9; i++) { switch (*(modeStringPtr+i)) { - case 'r': - if ((i%3) != 0) { - goto chmodStyleCheck; - } - newMode |= (1<<(8-i)); - break; - case 'w': - if ((i%3) != 1) { - goto chmodStyleCheck; - } - newMode |= (1<<(8-i)); - break; - case 'x': - if ((i%3) != 2) { - goto chmodStyleCheck; - } - newMode |= (1<<(8-i)); - break; - case 's': - if (((i%3) != 2) || (i > 5)) { - goto chmodStyleCheck; - } - newMode |= (1<<(8-i)); - newMode |= (1<<(11-(i/3))); - break; - case 'S': - if (((i%3) != 2) || (i > 5)) { - goto chmodStyleCheck; - } - newMode |= (1<<(11-(i/3))); - break; - case 't': - if (i != 8) { - goto chmodStyleCheck; - } - newMode |= (1<<(8-i)); - newMode |= (1<<9); - break; - case 'T': - if (i != 8) { - goto chmodStyleCheck; - } - newMode |= (1<<9); - break; - case '-': - break; - default: - /* - * Oops, not what we thought it was, so go on - */ - goto chmodStyleCheck; + case 'r': + if ((i%3) != 0) { + goto chmodStyleCheck; + } + newMode |= (1<<(8-i)); + break; + case 'w': + if ((i%3) != 1) { + goto chmodStyleCheck; + } + newMode |= (1<<(8-i)); + break; + case 'x': + if ((i%3) != 2) { + goto chmodStyleCheck; + } + newMode |= (1<<(8-i)); + break; + case 's': + if (((i%3) != 2) || (i > 5)) { + goto chmodStyleCheck; + } + newMode |= (1<<(8-i)); + newMode |= (1<<(11-(i/3))); + break; + case 'S': + if (((i%3) != 2) || (i > 5)) { + goto chmodStyleCheck; + } + newMode |= (1<<(11-(i/3))); + break; + case 't': + if (i != 8) { + goto chmodStyleCheck; + } + newMode |= (1<<(8-i)); + newMode |= (1<<9); + break; + case 'T': + if (i != 8) { + goto chmodStyleCheck; + } + newMode |= (1<<9); + break; + case '-': + break; + default: + /* + * Oops, not what we thought it was, so go on + */ + goto chmodStyleCheck; } } *modePtr = newMode; return TCL_OK; - chmodStyleCheck: + chmodStyleCheck: /* * We now check for an "ugoa+-=rwxst" style permissions string */ for (n = 0 ; *(modeStringPtr+n) != '\0' ; n = n + i) { @@ -1652,84 +1667,84 @@ who = op = what = op_found = who_found = 0; for (i = 0 ; *(modeStringPtr+n+i) != '\0' ; i++ ) { if (!who_found) { /* who */ switch (*(modeStringPtr+n+i)) { - case 'u' : - who |= 0x9c0; - continue; - case 'g' : - who |= 0x438; - continue; - case 'o' : - who |= 0x207; - continue; - case 'a' : - who |= 0xfff; - continue; + case 'u': + who |= 0x9c0; + continue; + case 'g': + who |= 0x438; + continue; + case 'o': + who |= 0x207; + continue; + case 'a': + who |= 0xfff; + continue; } } who_found = 1; if (who == 0) { who = 0xfff; } if (!op_found) { /* op */ switch (*(modeStringPtr+n+i)) { - case '+' : - op = 1; - op_found = 1; - continue; - case '-' : - op = 2; - op_found = 1; - continue; - case '=' : - op = 3; - op_found = 1; - continue; - default : - return TCL_ERROR; + case '+': + op = 1; + op_found = 1; + continue; + case '-': + op = 2; + op_found = 1; + continue; + case '=': + op = 3; + op_found = 1; + continue; + default: + return TCL_ERROR; } } /* what */ switch (*(modeStringPtr+n+i)) { - case 'r' : - what |= 0x124; - continue; - case 'w' : - what |= 0x92; - continue; - case 'x' : - what |= 0x49; - continue; - case 's' : - what |= 0xc00; - continue; - case 't' : - what |= 0x200; - continue; - case ',' : - break; - default : - return TCL_ERROR; + case 'r': + what |= 0x124; + continue; + case 'w': + what |= 0x92; + continue; + case 'x': + what |= 0x49; + continue; + case 's': + what |= 0xc00; + continue; + case 't': + what |= 0x200; + continue; + case ',': + break; + default: + return TCL_ERROR; } if (*(modeStringPtr+n+i) == ',') { i++; break; } } switch (op) { - case 1 : - *modePtr = oldMode | (who & what); - continue; - case 2 : - *modePtr = oldMode & ~(who & what); - continue; - case 3 : - *modePtr = (oldMode & ~who) | (who & what); - continue; + case 1 : + *modePtr = oldMode | (who & what); + continue; + case 2 : + *modePtr = oldMode & ~(who & what); + continue; + case 3 : + *modePtr = (oldMode & ~who) | (who & what); + continue; } } return TCL_OK; } @@ -1736,25 +1751,25 @@ /* *--------------------------------------------------------------------------- * * TclpObjNormalizePath -- * - * This function scans through a path specification and replaces - * it, in place, with a normalized version. A normalized version - * is one in which all symlinks in the path are replaced with - * their expanded form (except a symlink at the very end of the - * path). + * This function scans through a path specification and replaces it, in + * place, with a normalized version. A normalized version is one in which + * all symlinks in the path are replaced with their expanded form (except + * a symlink at the very end of the path). * * Results: - * The new 'nextCheckpoint' value, giving as far as we could - * understand in the path. + * The new 'nextCheckpoint' value, giving as far as we could understand + * in the path. * * Side effects: * The pathPtr string, is modified. * *--------------------------------------------------------------------------- */ + int TclpObjNormalizePath(interp, pathPtr, nextCheckpoint) Tcl_Interp *interp; Tcl_Obj *pathPtr; int nextCheckpoint; @@ -1764,126 +1779,170 @@ char cur; char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); #ifndef NO_REALPATH char normPath[MAXPATHLEN]; Tcl_DString ds; - CONST char *nativePath; + CONST char *nativePath; #endif - /* - * We add '1' here because if nextCheckpoint is zero we know - * that '/' exists, and if it isn't zero, it must point at - * a directory separator which we also know exists. + + /* + * We add '1' here because if nextCheckpoint is zero we know that '/' + * exists, and if it isn't zero, it must point at a directory separator + * which we also know exists. */ + currentPathEndPosition = path + nextCheckpoint; if (*currentPathEndPosition == '/') { currentPathEndPosition++; } #ifndef NO_REALPATH - /* For speed, try to get the entire path in one go */ + /* + * For speed, try to get the entire path in one go. + */ + if (nextCheckpoint == 0) { - char *lastDir = strrchr(currentPathEndPosition, '/'); + char *lastDir = strrchr(currentPathEndPosition, '/'); + if (lastDir != NULL) { - nativePath = Tcl_UtfToExternalDString(NULL, path, - lastDir - path, &ds); + nativePath = Tcl_UtfToExternalDString(NULL, path, + lastDir-path, &ds); if (Realpath(nativePath, normPath) != NULL) { nextCheckpoint = lastDir - path; goto wholeStringOk; } } } - /* Else do it the slow way */ + + /* + * Else do it the slow way. + */ #endif - + while (1) { cur = *currentPathEndPosition; if ((cur == '/') && (path != currentPathEndPosition)) { - /* Reached directory separator */ + /* + * Reached directory separator. + */ + Tcl_DString ds; CONST char *nativePath; int accessOk; - nativePath = Tcl_UtfToExternalDString(NULL, path, + nativePath = Tcl_UtfToExternalDString(NULL, path, currentPathEndPosition - path, &ds); accessOk = access(nativePath, F_OK); Tcl_DStringFree(&ds); + if (accessOk != 0) { - /* File doesn't exist */ + /* + * File doesn't exist. + */ + break; } - /* Update the acceptable point */ + + /* + * Update the acceptable point. + */ + nextCheckpoint = currentPathEndPosition - path; } else if (cur == 0) { - /* Reached end of string */ + /* + * Reached end of string. + */ + break; } currentPathEndPosition++; } - /* - * We should really now convert this to a canonical path. We do - * that with 'realpath' if we have it available. Otherwise we could - * step through every single path component, checking whether it is a - * symlink, but that would be a lot of work, and most modern OSes - * have 'realpath'. + + /* + * We should really now convert this to a canonical path. We do that with + * 'realpath' if we have it available. Otherwise we could step through + * every single path component, checking whether it is a symlink, but that + * would be a lot of work, and most modern OSes have 'realpath'. */ + #ifndef NO_REALPATH - /* - * If we only had '/foo' or '/' then we never increment nextCheckpoint - * and we don't need or want to go through 'Realpath'. Also, on some + /* + * If we only had '/foo' or '/' then we never increment nextCheckpoint and + * we don't need or want to go through 'Realpath'. Also, on some * platforms, passing an empty string to 'Realpath' will give us the * normalized pwd, which is not what we want at all! */ - if (nextCheckpoint == 0) return 0; - + + if (nextCheckpoint == 0) { + return 0; + } + nativePath = Tcl_UtfToExternalDString(NULL, path, nextCheckpoint, &ds); if (Realpath(nativePath, normPath) != NULL) { int newNormLen; - wholeStringOk: + + wholeStringOk: newNormLen = strlen(normPath); if ((newNormLen == Tcl_DStringLength(&ds)) && (strcmp(normPath, nativePath) == 0)) { - /* String is unchanged */ + /* + * String is unchanged. + */ + Tcl_DStringFree(&ds); + /* - * Enable this to have the native FS claim normalization of - * the whole path for existing files. That would permit the - * caller to declare normalization complete without calls to - * additional filesystems. Saving lots of calls is probably - * worth the extra access() time here. When no other FS's - * are registered though, things are less clear. + * Enable this to have the native FS claim normalization of the + * whole path for existing files. That would permit the caller to + * declare normalization complete without calls to additional + * filesystems. Saving lots of calls is probably worth the extra + * access() time here. When no other FS's are registered though, + * things are less clear. * if (0 == access(normPath, F_OK)) { return pathLen; } */ + return nextCheckpoint; } - - /* - * Free up the native path and put in its place the - * converted, normalized path. + + /* + * Free up the native path and put in its place the converted, + * normalized path. */ + Tcl_DStringFree(&ds); Tcl_ExternalToUtfDString(NULL, normPath, (int) newNormLen, &ds); if (path[nextCheckpoint] != '\0') { - /* not at end, append remaining path */ + /* + * Not at end, append remaining path. + */ + int normLen = Tcl_DStringLength(&ds); + Tcl_DStringAppend(&ds, path + nextCheckpoint, pathLen - nextCheckpoint); - /* - * We recognise up to and including the directory - * separator. - */ + + /* + * We recognise up to and including the directory separator. + */ + nextCheckpoint = normLen + 1; } else { - /* We recognise the whole string */ + /* + * We recognise the whole string. + */ + nextCheckpoint = Tcl_DStringLength(&ds); } - /* + + /* * Overwrite with the normalized path. */ + Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); } Tcl_DStringFree(&ds); #endif /* !NO_REALPATH */ @@ -1895,105 +1954,113 @@ /* *---------------------------------------------------------------------- * * GetReadOnlyAttribute * - * Gets the readonly attribute (user immutable flag) of a file. + * Gets the readonly attribute (user immutable flag) of a file. * * Results: - * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr - * if there is no error. The object will have ref count 0. + * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there + * is no error. The object will have ref count 0. * * Side effects: - * A new object is allocated. - * + * A new object is allocated. + * *---------------------------------------------------------------------- */ static int GetReadOnlyAttribute(interp, objIndex, fileName, attributePtrPtr) - Tcl_Interp *interp; /* The interp we are using for errors. */ - int objIndex; /* The index of the attribute. */ - Tcl_Obj *fileName; /* The name of the file (UTF-8). */ - Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ + Tcl_Interp *interp; /* The interp we are using for errors. */ + int objIndex; /* The index of the attribute. */ + Tcl_Obj *fileName; /* The name of the file (UTF-8). */ + Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ { Tcl_StatBuf statBuf; int result; result = TclpObjStat(fileName, &statBuf); - + if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", + Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } - *attributePtrPtr = Tcl_NewBooleanObj((statBuf.st_flags & UF_IMMUTABLE) != 0); - + *attributePtrPtr = Tcl_NewBooleanObj((statBuf.st_flags&UF_IMMUTABLE) != 0); + return TCL_OK; } /* *--------------------------------------------------------------------------- * * SetReadOnlyAttribute * - * Sets the readonly attribute (user immutable flag) of a file. + * Sets the readonly attribute (user immutable flag) of a file. * * Results: - * Standard TCL result. + * Standard TCL result. * * Side effects: - * The readonly attribute of the file is changed. - * + * The readonly attribute of the file is changed. + * *--------------------------------------------------------------------------- */ static int SetReadOnlyAttribute(interp, objIndex, fileName, attributePtr) - Tcl_Interp *interp; /* The interp we are using for errors. */ - int objIndex; /* The index of the attribute. */ - Tcl_Obj *fileName; /* The name of the file (UTF-8). */ - Tcl_Obj *attributePtr; /* The attribute to set. */ + Tcl_Interp *interp; /* The interp we are using for errors. */ + int objIndex; /* The index of the attribute. */ + Tcl_Obj *fileName; /* The name of the file (UTF-8). */ + Tcl_Obj *attributePtr; /* The attribute to set. */ { Tcl_StatBuf statBuf; int result; int readonly; CONST char *native; if (Tcl_GetBooleanFromObj(interp, attributePtr, &readonly) != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; } result = TclpObjStat(fileName, &statBuf); - + if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", + Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } if (readonly) { - statBuf.st_flags |= UF_IMMUTABLE; + statBuf.st_flags |= UF_IMMUTABLE; } else { - statBuf.st_flags &= ~UF_IMMUTABLE; + statBuf.st_flags &= ~UF_IMMUTABLE; } native = Tcl_FSGetNativePath(fileName); result = chflags(native, statBuf.st_flags); /* INTL: Native. */ if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not set flags for file \"", + Tcl_AppendResult(interp, "could not set flags for file \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } return TCL_OK; } #endif /* defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: unix/tclUnixFile.c ================================================================== --- unix/tclUnixFile.c +++ unix/tclUnixFile.c @@ -1,31 +1,30 @@ -/* +/* * tclUnixFile.c -- * - * This file contains wrappers around UNIX file handling functions. - * These wrappers mask differences between Windows and UNIX. + * This file contains wrappers around UNIX file handling functions. + * These wrappers mask differences between Windows and UNIX. * * Copyright (c) 1995-1998 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixFile.c,v 1.44 2004/12/01 23:18:55 dgp Exp $ + * RCS: @(#) $Id: tclUnixFile.c,v 1.44.2.2 2005/09/09 18:48:40 dgp Exp $ */ #include "tclInt.h" #include "tclFileSystem.h" static int NativeMatchType(CONST char* nativeName, Tcl_GlobTypeData *types); - /* *--------------------------------------------------------------------------- * * TclpFindExecutable -- * - * This procedure computes the absolute path name of the current + * This function computes the absolute path name of the current * application, given its argv[0] value. * * Results: * None. * @@ -52,23 +51,23 @@ name = argv0; for (p = name; *p != '\0'; p++) { if (*p == '/') { /* - * The name contains a slash, so use the name directly - * without doing a path search. + * The name contains a slash, so use the name directly without + * doing a path search. */ goto gotName; } } p = getenv("PATH"); /* INTL: Native. */ if (p == NULL) { /* - * There's no PATH environment variable; use the default that - * is used by sh. + * There's no PATH environment variable; use the default that is used + * by sh. */ p = ":/bin:/usr/bin"; } else if (*p == '\0') { /* @@ -77,17 +76,16 @@ p = "./"; } /* - * Search through all the directories named in the PATH variable - * to see if argv[0] is in one of them. If so, use that file - * name. + * Search through all the directories named in the PATH variable to see if + * argv[0] is in one of them. If so, use that file name. */ while (1) { - while (isspace(UCHAR(*p))) { /* INTL: BUG */ + while (isspace(UCHAR(*p))) { /* INTL: BUG */ p++; } name = p; while ((*p != ':') && (*p != 0)) { p++; @@ -125,28 +123,29 @@ /* * If the name starts with "/" then just store it */ -gotName: + gotName: #ifdef DJGPP - if (name[1] == ':') { + if (name[1] == ':') #else - if (name[0] == '/') { + if (name[0] == '/') #endif + { encoding = Tcl_GetEncoding(NULL, NULL); Tcl_ExternalToUtfDString(encoding, name, -1, &utfName); TclSetObjNameOfExecutable( Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding); Tcl_DStringFree(&utfName); goto done; } /* - * The name is relative to the current working directory. First - * strip off a leading "./", if any, then add the full path name of - * the current working directory. + * The name is relative to the current working directory. First strip off + * a leading "./", if any, then add the full path name of the current + * working directory. */ if ((name[0] == '.') && (name[1] == '/')) { name += 2; } @@ -166,62 +165,70 @@ Tcl_DStringAppend(&buffer, Tcl_DStringValue(&nameString), Tcl_DStringLength(&nameString)); Tcl_DStringFree(&nameString); encoding = Tcl_GetEncoding(NULL, NULL); - Tcl_ExternalToUtfDString(encoding, Tcl_DStringValue(&buffer), -1, &utfName); + Tcl_ExternalToUtfDString(encoding, Tcl_DStringValue(&buffer), -1, + &utfName); TclSetObjNameOfExecutable( Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding); Tcl_DStringFree(&utfName); - -done: + + done: Tcl_DStringFree(&buffer); } /* *---------------------------------------------------------------------- * * TclpMatchInDirectory -- * - * This routine is used by the globbing code to search a - * directory for all files which match a given pattern. + * This routine is used by the globbing code to search a directory for + * all files which match a given pattern. * - * Results: - * The return value is a standard Tcl result indicating whether an - * error occurred in globbing. Errors are left in interp, good - * results are lappended to resultPtr (which must be a valid object) + * Results: + * The return value is a standard Tcl result indicating whether an error + * occurred in globbing. Errors are left in interp, good results are + * [lappend]ed to resultPtr (which must be a valid object). * * Side effects: * None. * - *---------------------------------------------------------------------- */ + *---------------------------------------------------------------------- + */ int TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) Tcl_Interp *interp; /* Interpreter to receive errors. */ Tcl_Obj *resultPtr; /* List object to lappend results. */ - Tcl_Obj *pathPtr; /* Contains path to directory to search. */ + Tcl_Obj *pathPtr; /* Contains path to directory to search. */ CONST char *pattern; /* Pattern to match against. */ Tcl_GlobTypeData *types; /* Object containing list of acceptable types. * May be NULL. In particular the directory * flag is very important. */ { CONST char *native; Tcl_Obj *fileNamePtr; if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) { - /* The native filesystem never adds mounts */ + /* + * The native filesystem never adds mounts. + */ + return TCL_OK; } fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr); if (fileNamePtr == NULL) { return TCL_ERROR; } - + if (pattern == NULL || (*pattern == '\0')) { - /* Match a file directly */ + /* + * Match a file directly. + */ + native = (CONST char*) Tcl_FSGetNativePath(pathPtr); if (NativeMatchType(native, types)) { Tcl_ListObjAppendElement(interp, resultPtr, pathPtr); } Tcl_DecrRefCount(fileNamePtr); @@ -232,30 +239,34 @@ CONST char *dirName; int dirLength; int matchHidden; int nativeDirLen; Tcl_StatBuf statBuf; - Tcl_DString ds; /* native encoding of dir */ - Tcl_DString dsOrig; /* utf-8 encoding of dir */ + Tcl_DString ds; /* native encoding of dir */ + Tcl_DString dsOrig; /* utf-8 encoding of dir */ Tcl_DStringInit(&dsOrig); dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength); Tcl_DStringAppend(&dsOrig, dirName, dirLength); - + /* * Make sure that the directory part of the name really is a - * directory. If the directory name is "", use the name "." - * instead, because some UNIX systems don't treat "" like "." - * automatically. Keep the "" for use in generating file names, - * otherwise "glob foo.c" would return "./foo.c". + * directory. If the directory name is "", use the name "." instead, + * because some UNIX systems don't treat "" like "." automatically. + * Keep the "" for use in generating file names, otherwise "glob + * foo.c" would return "./foo.c". */ if (dirLength == 0) { dirName = "."; } else { dirName = Tcl_DStringValue(&dsOrig); - /* Make sure we have a trailing directory delimiter */ + + /* + * Make sure we have a trailing directory delimiter. + */ + if (dirName[dirLength-1] != '/') { dirName = Tcl_DStringAppend(&dsOrig, "/", 1); dirLength++; } } @@ -275,14 +286,16 @@ } d = opendir(native); /* INTL: Native. */ if (d == NULL) { Tcl_DStringFree(&ds); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't read directory \"", - Tcl_DStringValue(&dsOrig), "\": ", - Tcl_PosixError(interp), (char *) NULL); + if (interp != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't read directory \"", + Tcl_DStringValue(&dsOrig), "\": ", + Tcl_PosixError(interp), (char *) NULL); + } Tcl_DStringFree(&dsOrig); Tcl_DecrRefCount(fileNamePtr); return TCL_ERROR; } @@ -289,47 +302,49 @@ nativeDirLen = Tcl_DStringLength(&ds); /* * Check to see if -type or the pattern requests hidden files. */ - matchHidden = ((types && (types->perm & TCL_GLOB_PERM_HIDDEN)) || - ((pattern[0] == '.') - || ((pattern[0] == '\\') && (pattern[1] == '.')))); - while ((entryPtr = TclOSreaddir(d)) != NULL) { /* INTL: Native. */ + matchHidden = ((types && (types->perm & TCL_GLOB_PERM_HIDDEN)) + || ((pattern[0] == '.') + || ((pattern[0] == '\\') && (pattern[1] == '.')))); + + while ((entryPtr = TclOSreaddir(d)) != NULL) { /* INTL: Native. */ Tcl_DString utfDs; CONST char *utfname; - /* - * Skip this file if it doesn't agree with the hidden - * parameters requested by the user (via -type or pattern). + /* + * Skip this file if it doesn't agree with the hidden parameters + * requested by the user (via -type or pattern). */ + if (*entryPtr->d_name == '.') { if (!matchHidden) continue; } else { if (matchHidden) continue; } /* * Now check to see if the file matches, according to both type - * and pattern. If so, add the file to the result. + * and pattern. If so, add the file to the result. */ - utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, - -1, &utfDs); + utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1, + &utfDs); if (Tcl_StringCaseMatch(utfname, pattern, 0)) { int typeOk = 1; if (types != NULL) { Tcl_DStringSetLength(&ds, nativeDirLen); native = Tcl_DStringAppend(&ds, entryPtr->d_name, -1); typeOk = NativeMatchType(native, types); } if (typeOk) { - Tcl_ListObjAppendElement(interp, resultPtr, + Tcl_ListObjAppendElement(interp, resultPtr, TclNewFSPathObj(pathPtr, utfname, - Tcl_DStringLength(&utfDs))); + Tcl_DStringLength(&utfDs))); } } Tcl_DStringFree(&utfDs); } @@ -338,48 +353,49 @@ Tcl_DStringFree(&dsOrig); Tcl_DecrRefCount(fileNamePtr); return TCL_OK; } } -static int + +static int NativeMatchType( - CONST char* nativeEntry, /* Native path to check */ - Tcl_GlobTypeData *types) /* Type description to match against */ + CONST char* nativeEntry, /* Native path to check. */ + Tcl_GlobTypeData *types) /* Type description to match against. */ { Tcl_StatBuf buf; if (types == NULL) { - /* - * Simply check for the file's existence, but do it - * with lstat, in case it is a link to a file which - * doesn't exist (since that case would not show up - * if we used 'access' or 'stat') + /* + * Simply check for the file's existence, but do it with lstat, in + * case it is a link to a file which doesn't exist (since that case + * would not show up if we used 'access' or 'stat') */ + if (TclOSlstat(nativeEntry, &buf) != 0) { return 0; } } else { if (types->perm != 0) { if (TclOSstat(nativeEntry, &buf) != 0) { - /* - * Either the file has disappeared between the - * 'readdir' call and the 'stat' call, or - * the file is a link to a file which doesn't - * exist (which we could ascertain with - * lstat), or there is some other strange - * problem. In all these cases, we define this - * to mean the file does not match any defined - * permission, and therefore it is not - * added to the list of files to return. + /* + * Either the file has disappeared between the 'readdir' call + * and the 'stat' call, or the file is a link to a file which + * doesn't exist (which we could ascertain with lstat), or + * there is some other strange problem. In all these cases, we + * define this to mean the file does not match any defined + * permission, and therefore it is not added to the list of + * files to return. */ + return 0; } - - /* - * readonly means that there are NO write permissions - * (even for user), but execute is OK for anybody - * OR that the user immutable flag is set (where supported). + + /* + * readonly means that there are NO write permissions (even for + * user), but execute is OK for anybody OR that the user immutable + * flag is set (where supported). */ + if (((types->perm & TCL_GLOB_PERM_RONLY) && #if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) !(buf.st_flags & UF_IMMUTABLE) && #endif (buf.st_mode & (S_IWOTH|S_IWGRP|S_IWUSR))) || @@ -393,18 +409,21 @@ return 0; } } if (types->type != 0) { if (types->perm == 0) { - /* We haven't yet done a stat on the file */ + /* + * We haven't yet done a stat on the file. + */ + if (TclOSstat(nativeEntry, &buf) != 0) { - /* - * Posix error occurred. The only ok - * case is if this is a link to a nonexistent - * file, and the user did 'glob -l'. So - * we check that here: + /* + * Posix error occurred. The only ok case is if this is a + * link to a nonexistent file, and the user did 'glob -l'. + * So we check that here: */ + if (types->type & TCL_GLOB_TYPE_LINK) { if (TclOSlstat(nativeEntry, &buf) == 0) { if (S_ISLNK(buf.st_mode)) { return 1; } @@ -411,30 +430,27 @@ } } return 0; } } + /* * In order bcdpfls as in 'find -t' */ - if ( - ((types->type & TCL_GLOB_TYPE_BLOCK) && - S_ISBLK(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_CHAR) && - S_ISCHR(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_DIR) && - S_ISDIR(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_PIPE) && - S_ISFIFO(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_FILE) && - S_ISREG(buf.st_mode)) + + if (((types->type & TCL_GLOB_TYPE_BLOCK)&& S_ISBLK(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_CHAR) && S_ISCHR(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_DIR) && S_ISDIR(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_PIPE) && S_ISFIFO(buf.st_mode))|| + ((types->type & TCL_GLOB_TYPE_FILE) && S_ISREG(buf.st_mode)) #ifdef S_ISSOCK - || ((types->type & TCL_GLOB_TYPE_SOCK) && - S_ISSOCK(buf.st_mode)) + ||((types->type & TCL_GLOB_TYPE_SOCK) && S_ISSOCK(buf.st_mode)) #endif /* S_ISSOCK */ ) { - /* Do nothing -- this file is ok */ + /* + * Do nothing - this file is ok. + */ } else { #ifdef S_ISLNK if (types->type & TCL_GLOB_TYPE_LINK) { if (TclOSlstat(nativeEntry, &buf) == 0) { if (S_ISLNK(buf.st_mode)) { @@ -453,19 +469,19 @@ /* *--------------------------------------------------------------------------- * * TclpGetUserHome -- * - * This function takes the specified user name and finds their - * home directory. + * This function takes the specified user name and finds their home + * directory. * * Results: * The result is a pointer to a string specifying the user's home * directory, or NULL if the user's home directory could not be - * determined. Storage for the result string is allocated in - * bufferPtr; the caller must call Tcl_DStringFree() when the result - * is no longer needed. + * determined. Storage for the result string is allocated in bufferPtr; + * the caller must call Tcl_DStringFree() when the result is no longer + * needed. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -472,21 +488,21 @@ */ char * TclpGetUserHome(name, bufferPtr) CONST char *name; /* User name for desired home directory. */ - Tcl_DString *bufferPtr; /* Uninitialized or free DString filled - * with name of user's home directory. */ + Tcl_DString *bufferPtr; /* Uninitialized or free DString filled with + * name of user's home directory. */ { struct passwd *pwPtr; Tcl_DString ds; CONST char *native; native = Tcl_UtfToExternalDString(NULL, name, -1, &ds); pwPtr = getpwnam(native); /* INTL: Native. */ Tcl_DStringFree(&ds); - + if (pwPtr == NULL) { endpwent(); return NULL; } Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, -1, bufferPtr); @@ -508,14 +524,14 @@ * See access() documentation. * *--------------------------------------------------------------------------- */ -int +int TclpObjAccess(pathPtr, mode) - Tcl_Obj *pathPtr; /* Path of file to access */ - int mode; /* Permission setting. */ + Tcl_Obj *pathPtr; /* Path of file to access */ + int mode; /* Permission setting. */ { CONST char *path = Tcl_FSGetNativePath(pathPtr); if (path == NULL) { return -1; } else { @@ -532,18 +548,18 @@ * * Results: * See chdir() documentation. * * Side effects: - * See chdir() documentation. + * See chdir() documentation. * *--------------------------------------------------------------------------- */ -int +int TclpObjChdir(pathPtr) - Tcl_Obj *pathPtr; /* Path to new working directory */ + Tcl_Obj *pathPtr; /* Path to new working directory */ { CONST char *path = Tcl_FSGetNativePath(pathPtr); if (path == NULL) { return -1; } else { @@ -565,11 +581,11 @@ * See lstat() documentation. * *---------------------------------------------------------------------- */ -int +int TclpObjLstat(pathPtr, bufPtr) Tcl_Obj *pathPtr; /* Path of file to stat */ Tcl_StatBuf *bufPtr; /* Filled with results of stat call. */ { return TclOSlstat(Tcl_FSGetNativePath(pathPtr), bufPtr); @@ -581,17 +597,16 @@ * TclpGetNativeCwd -- * * This function replaces the library version of getcwd(). * * Results: - * The input and output are filesystem paths in native form. The - * result is either the given clientData, if the working directory - * hasn't changed, or a new clientData (owned by our caller), - * giving the new native path, or NULL if the current directory - * could not be determined. If NULL is returned, the caller can - * examine the standard posix error codes to determine the cause of - * the problem. + * The input and output are filesystem paths in native form. The result + * is either the given clientData, if the working directory hasn't + * changed, or a new clientData (owned by our caller), giving the new + * native path, or NULL if the current directory could not be determined. + * If NULL is returned, the caller can examine the standard posix error + * codes to determine the cause of the problem. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -602,22 +617,25 @@ ClientData clientData; { char buffer[MAXPATHLEN+1]; #ifdef USEGETWD - if (getwd(buffer) == NULL) { /* INTL: Native. */ + if (getwd(buffer) == NULL) /* INTL: Native. */ #else - if (getcwd(buffer, MAXPATHLEN + 1) == NULL) { /* INTL: Native. */ + if (getcwd(buffer, MAXPATHLEN+1) == NULL) /* INTL: Native. */ #endif + { return NULL; } if ((clientData != NULL) && strcmp(buffer, (CONST char*)clientData) == 0) { - /* No change to pwd */ + /* + * No change to pwd. + */ + return clientData; } else { - char *newCd = (char *) ckalloc((unsigned) - (strlen(buffer) + 1)); + char *newCd = (char *) ckalloc((unsigned) (strlen(buffer) + 1)); strcpy(newCd, buffer); return (ClientData) newCd; } } @@ -624,21 +642,20 @@ /* *--------------------------------------------------------------------------- * * TclpGetCwd -- * - * This function replaces the library version of getcwd(). - * (Obsolete function, only retained for old extensions which - * may call it directly). - * + * This function replaces the library version of getcwd(). (Obsolete + * function, only retained for old extensions which may call it + * directly). + * * Results: - * The result is a pointer to a string specifying the current - * directory, or NULL if the current directory could not be - * determined. If NULL is returned, an error message is left in the - * interp's result. Storage for the result string is allocated in - * bufferPtr; the caller must call Tcl_DStringFree() when the result - * is no longer needed. + * The result is a pointer to a string specifying the current directory, + * or NULL if the current directory could not be determined. If NULL is + * returned, an error message is left in the interp's result. Storage for + * the result string is allocated in bufferPtr; the caller must call + * Tcl_DStringFree() when the result is no longer needed. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -645,20 +662,21 @@ */ CONST char * TclpGetCwd(interp, bufferPtr) Tcl_Interp *interp; /* If non-NULL, used for error reporting. */ - Tcl_DString *bufferPtr; /* Uninitialized or free DString filled - * with name of current directory. */ + Tcl_DString *bufferPtr; /* Uninitialized or free DString filled with + * name of current directory. */ { char buffer[MAXPATHLEN+1]; #ifdef USEGETWD - if (getwd(buffer) == NULL) { /* INTL: Native. */ + if (getwd(buffer) == NULL) /* INTL: Native. */ #else - if (getcwd(buffer, MAXPATHLEN + 1) == NULL) { /* INTL: Native. */ + if (getcwd(buffer, MAXPATHLEN+1) == NULL) /* INTL: Native. */ #endif + { if (interp != NULL) { Tcl_AppendResult(interp, "error getting working directory name: ", Tcl_PosixError(interp), (char *) NULL); } @@ -673,15 +691,15 @@ * TclpReadlink -- * * This function replaces the library version of readlink(). * * Results: - * The result is a pointer to a string specifying the contents - * of the symbolic link given by 'path', or NULL if the symbolic - * link could not be read. Storage for the result string is - * allocated in bufferPtr; the caller must call Tcl_DStringFree() - * when the result is no longer needed. + * The result is a pointer to a string specifying the contents of the + * symbolic link given by 'path', or NULL if the symbolic link could not + * be read. Storage for the result string is allocated in bufferPtr; the + * caller must call Tcl_DStringFree() when the result is no longer + * needed. * * Side effects: * See readlink() documentation. * *--------------------------------------------------------------------------- @@ -688,12 +706,12 @@ */ char * TclpReadlink(path, linkPtr) CONST char *path; /* Path of file to readlink (UTF-8). */ - Tcl_DString *linkPtr; /* Uninitialized or free DString filled - * with contents of link (UTF-8). */ + Tcl_DString *linkPtr; /* Uninitialized or free DString filled with + * contents of link (UTF-8). */ { #ifndef DJGPP char link[MAXPATHLEN]; int length; CONST char *native; @@ -700,11 +718,11 @@ Tcl_DString ds; native = Tcl_UtfToExternalDString(NULL, path, -1, &ds); length = readlink(native, link, sizeof(link)); /* INTL: Native. */ Tcl_DStringFree(&ds); - + if (length < 0) { return NULL; } Tcl_ExternalToUtfDString(NULL, link, length, linkPtr); @@ -728,11 +746,11 @@ * See stat() documentation. * *---------------------------------------------------------------------- */ -int +int TclpObjStat(pathPtr, bufPtr) Tcl_Obj *pathPtr; /* Path of file to stat */ Tcl_StatBuf *bufPtr; /* Filled with results of stat call. */ { CONST char *path = Tcl_FSGetNativePath(pathPtr); @@ -741,95 +759,110 @@ } else { return TclOSstat(path, bufPtr); } } - #ifdef S_IFLNK -Tcl_Obj* +Tcl_Obj* TclpObjLink(pathPtr, toPtr, linkAction) Tcl_Obj *pathPtr; Tcl_Obj *toPtr; int linkAction; { if (toPtr != NULL) { CONST char *src = Tcl_FSGetNativePath(pathPtr); CONST char *target = NULL; if (src == NULL) return NULL; - - /* - * If we're making a symbolic link and the path is relative, - * then we must check whether it exists _relative_ to the - * directory in which the src is found (not relative to the - * current cwd which is just not relevant in this case). - * - * If we're making a hard link, then a relative path is - * just converted to absolute relative to the cwd. + + /* + * If we're making a symbolic link and the path is relative, then we + * must check whether it exists _relative_ to the directory in which + * the src is found (not relative to the current cwd which is just not + * relevant in this case). + * + * If we're making a hard link, then a relative path is just converted + * to absolute relative to the cwd. */ + if ((linkAction & TCL_CREATE_SYMBOLIC_LINK) - && (Tcl_FSGetPathType(toPtr) == TCL_PATH_RELATIVE)) { + && (Tcl_FSGetPathType(toPtr) == TCL_PATH_RELATIVE)) { Tcl_Obj *dirPtr, *absPtr; + dirPtr = TclPathPart(NULL, pathPtr, TCL_PATH_DIRNAME); if (dirPtr == NULL) { - return NULL; + return NULL; } absPtr = Tcl_FSJoinToPath(dirPtr, 1, &toPtr); Tcl_IncrRefCount(absPtr); if (Tcl_FSAccess(absPtr, F_OK) == -1) { Tcl_DecrRefCount(absPtr); Tcl_DecrRefCount(dirPtr); - /* target doesn't exist */ - errno = ENOENT; - return NULL; - } - /* - * Target exists; we'll construct the relative - * path we want below. - */ + + /* + * Target doesn't exist. + */ + + errno = ENOENT; + return NULL; + } + + /* + * Target exists; we'll construct the relative path we want below. + */ + Tcl_DecrRefCount(absPtr); Tcl_DecrRefCount(dirPtr); } else { target = Tcl_FSGetNativePath(toPtr); if (access(target, F_OK) == -1) { - /* target doesn't exist */ + /* + * Target doesn't exist. + */ + errno = ENOENT; return NULL; } if (target == NULL) { return NULL; } } - + if (access(src, F_OK) != -1) { - /* src exists */ + /* + * Src exists. + */ + errno = EEXIST; return NULL; } - /* - * Check symbolic link flag first, since we prefer to - * create these. + + /* + * Check symbolic link flag first, since we prefer to create these. */ + if (linkAction & TCL_CREATE_SYMBOLIC_LINK) { int targetLen; Tcl_DString ds; Tcl_Obj *transPtr; - /* + + /* * Now we don't want to link to the absolute, normalized path. - * Relative links are quite acceptable (but links to ~user - * are not -- these must be expanded first). + * Relative links are quite acceptable (but links to ~user are not + * -- these must be expanded first). */ + transPtr = Tcl_FSGetTranslatedPath(NULL, toPtr); if (transPtr == NULL) { return NULL; } target = Tcl_GetStringFromObj(transPtr, &targetLen); target = Tcl_UtfToExternalDString(NULL, target, targetLen, &ds); Tcl_DecrRefCount(transPtr); - + if (symlink(target, src) != 0) { - toPtr = NULL; + toPtr = NULL; } Tcl_DStringFree(&ds); } else if (linkAction & TCL_CREATE_HARD_LINK) { if (link(target, src) != 0) { return NULL; @@ -844,11 +877,11 @@ char link[MAXPATHLEN]; int length; Tcl_DString ds; Tcl_Obj *transPtr; - + transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); if (transPtr == NULL) { return NULL; } Tcl_DecrRefCount(transPtr); @@ -857,106 +890,109 @@ if (length < 0) { return NULL; } Tcl_ExternalToUtfDString(NULL, link, length, &ds); - linkPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds)); + linkPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); if (linkPtr != NULL) { Tcl_IncrRefCount(linkPtr); } return linkPtr; } } - -#endif - +#endif /* S_IFLNK */ /* *--------------------------------------------------------------------------- * * TclpFilesystemPathType -- * - * This function is part of the native filesystem support, and - * returns the path type of the given path. Right now it simply - * returns NULL. In the future it could return specific path - * types, like 'nfs', 'samba', 'FAT32', etc. + * This function is part of the native filesystem support, and returns + * the path type of the given path. Right now it simply returns NULL. In + * the future it could return specific path types, like 'nfs', 'samba', + * 'FAT32', etc. * * Results: - * NULL at present. + * NULL at present. * * Side effects: * None. * *--------------------------------------------------------------------------- */ + Tcl_Obj* TclpFilesystemPathType(pathPtr) Tcl_Obj* pathPtr; { - /* All native paths are of the same type */ + /* + * All native paths are of the same type. + */ + return NULL; } /* *--------------------------------------------------------------------------- * * TclpNativeToNormalized -- * - * Convert native format to a normalized path object, with refCount - * of zero. - * - * Currently assumes all native paths are actually normalized - * already, so if the path given is not normalized this will - * actually just convert to a valid string path, but not - * necessarily a normalized one. + * Convert native format to a normalized path object, with refCount of + * zero. + * + * Currently assumes all native paths are actually normalized already, so + * if the path given is not normalized this will actually just convert to + * a valid string path, but not necessarily a normalized one. * * Results: - * A valid normalized path. + * A valid normalized path. * * Side effects: * None. * *--------------------------------------------------------------------------- */ -Tcl_Obj* + +Tcl_Obj* TclpNativeToNormalized(clientData) ClientData clientData; { Tcl_DString ds; Tcl_Obj *objPtr; int len; - + CONST char *copy; Tcl_ExternalToUtfDString(NULL, (CONST char*)clientData, -1, &ds); - + copy = Tcl_DStringValue(&ds); len = Tcl_DStringLength(&ds); objPtr = Tcl_NewStringObj(copy,len); Tcl_DStringFree(&ds); - + return objPtr; } /* *--------------------------------------------------------------------------- * * TclNativeCreateNativeRep -- * - * Create a native representation for the given path. + * Create a native representation for the given path. * * Results: - * The nativePath representation. + * The nativePath representation. * * Side effects: * Memory will be allocated. The path may need to be normalized. * *--------------------------------------------------------------------------- */ -ClientData + +ClientData TclNativeCreateNativeRep(pathPtr) Tcl_Obj* pathPtr; { char *nativePathPtr; Tcl_DString ds; @@ -963,19 +999,22 @@ Tcl_Obj* validPathPtr; int len; char *str; if (TclFSCwdIsNative()) { - /* - * The cwd is native, which means we can use the translated - * path without worrying about normalization (this will also - * usually be shorter so the utf-to-external conversion will - * be somewhat faster). + /* + * The cwd is native, which means we can use the translated path + * without worrying about normalization (this will also usually be + * shorter so the utf-to-external conversion will be somewhat faster). */ + validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); } else { - /* Make sure the normalized path is set */ + /* + * Make sure the normalized path is set. + */ + validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); Tcl_IncrRefCount(validPathPtr); } str = Tcl_GetStringFromObj(validPathPtr, &len); @@ -982,32 +1021,33 @@ Tcl_UtfToExternalDString(NULL, str, len, &ds); len = Tcl_DStringLength(&ds) + sizeof(char); Tcl_DecrRefCount(validPathPtr); nativePathPtr = ckalloc((unsigned) len); memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), (size_t) len); - + Tcl_DStringFree(&ds); return (ClientData)nativePathPtr; } /* *--------------------------------------------------------------------------- * * TclNativeDupInternalRep -- * - * Duplicate the native representation. + * Duplicate the native representation. * * Results: - * The copied native representation, or NULL if it is not possible - * to copy the representation. + * The copied native representation, or NULL if it is not possible to + * copy the representation. * * Side effects: * Memory will be allocated for the copy. * *--------------------------------------------------------------------------- */ -ClientData + +ClientData TclNativeDupInternalRep(clientData) ClientData clientData; { char *copy; size_t len; @@ -1014,15 +1054,18 @@ if (clientData == NULL) { return NULL; } - /* ascii representation when running on Unix */ - len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char)); - + /* + * ASCII representation when running on Unix. + */ + + len = sizeof(char) + (strlen((CONST char*) clientData) * sizeof(char)); + copy = (char *) ckalloc(len); - memcpy((VOID*)copy, (VOID*)clientData, len); + memcpy((VOID *) copy, (VOID *) clientData, len); return (ClientData)copy; } /* *--------------------------------------------------------------------------- @@ -1037,12 +1080,21 @@ * Side effects: * None. * *--------------------------------------------------------------------------- */ -int + +int TclpUtime(pathPtr, tval) - Tcl_Obj *pathPtr; /* File to modify */ - struct utimbuf *tval; /* New modification date structure */ + Tcl_Obj *pathPtr; /* File to modify */ + struct utimbuf *tval; /* New modification date structure */ { - return utime(Tcl_FSGetNativePath(pathPtr),tval); + return utime(Tcl_FSGetNativePath(pathPtr), tval); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: unix/tclUnixInit.c ================================================================== --- unix/tclUnixInit.c +++ unix/tclUnixInit.c @@ -5,11 +5,11 @@ * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation. * All rights reserved. * - * RCS: @(#) $Id: tclUnixInit.c,v 1.53 2004/11/30 19:34:51 dgp Exp $ + * RCS: @(#) $Id: tclUnixInit.c,v 1.53.2.6 2005/08/15 18:14:14 dgp Exp $ */ #include "tclInt.h" #include #include @@ -24,42 +24,41 @@ # include # if _BSDI_VERSION > 199501 # include # endif #endif -#ifdef HAVE_CFBUNDLE +#ifdef HAVE_COREFOUNDATION #include #endif /* - * Define this if you want to revert to the old behavior of - * never checking the stack. + * Define this if you want to revert to the old behavior of never checking the + * stack. */ + #undef TCL_NO_STACK_CHECK /* - * Define this if you want to see a lot of output regarding - * stack checking. + * Define this if you want to see a lot of output regarding stack checking. */ + #undef TCL_DEBUG_STACK_CHECK /* - * Values used to compute how much space is really available for Tcl's - * use for the stack. - * - * NOTE: Now I have some idea why the maximum stack size must be - * divided by 64 on FreeBSD with threads enabled to get a reasonably - * correct value. - * - * The getrlimit() function is documented to return the maximum stack - * size in bytes. However, with threads enabled, the pthread library - * does bad things to the stack size limits. First, the limits cannot - * be changed. Second, they appear to be reported incorrectly by a - * factor of about 64. - * - * The defines below may need to be adjusted if more platforms have - * this broken behavior with threads enabled. + * Values used to compute how much space is really available for Tcl's use for + * the stack. + * + * NOTE: Now I have some idea why the maximum stack size must be divided by 64 + * on FreeBSD with threads enabled to get a reasonably correct value. + * + * The getrlimit() function is documented to return the maximum stack size in + * bytes. However, with threads enabled, the pthread library does bad things + * to the stack size limits. First, the limits cannot be changed. Second, + * they appear to be reported incorrectly by a factor of about 64. + * + * The defines below may need to be adjusted if more platforms have this + * broken behavior with threads enabled. */ #if defined(__FreeBSD__) # define TCL_MAGIC_STACK_DIVISOR 64 # define TCL_RESERVED_STACK_PAGES 3 @@ -92,49 +91,60 @@ #else #define STACK_DEBUG(args) (void)0 #endif /* TCL_DEBUG_STACK_CHECK */ /* - * Tcl tries to use standard and homebrew methods to guess the right - * encoding on the platform. However, there is always a final fallback, - * and this value is it. Make sure it is a real Tcl encoding. + * Tcl tries to use standard and homebrew methods to guess the right encoding + * on the platform. However, there is always a final fallback, and this value + * is it. Make sure it is a real Tcl encoding. */ #ifndef TCL_DEFAULT_ENCODING #define TCL_DEFAULT_ENCODING "iso8859-1" #endif /* - * Default directory in which to look for Tcl library scripts. The - * symbol is defined by Makefile. + * Default directory in which to look for Tcl library scripts. The symbol is + * defined by Makefile. */ static char defaultLibraryDir[sizeof(TCL_LIBRARY)+200] = TCL_LIBRARY; /* * Directory in which to look for packages (each package is typically - * installed as a subdirectory of this directory). The symbol is - * defined by Makefile. + * installed as a subdirectory of this directory). The symbol is defined by + * Makefile. */ static char pkgPath[sizeof(TCL_PACKAGE_PATH)+200] = TCL_PACKAGE_PATH; /* - * The following table is used to map from Unix locale strings to - * encoding files. If HAVE_LANGINFO is defined, then this is a fallback - * table when the result from nl_langinfo isn't a recognized encoding. - * Otherwise this is the first list checked for a mapping from env - * encoding to Tcl encoding name. + * The following table is used to map from Unix locale strings to encoding + * files. If HAVE_LANGINFO is defined, then this is a fallback table when the + * result from nl_langinfo isn't a recognized encoding. Otherwise this is the + * first list checked for a mapping from env encoding to Tcl encoding name. */ typedef struct LocaleTable { CONST char *lang; CONST char *encoding; } LocaleTable; +/* + * The table below is sorted for the sake of doing binary searches on it. The + * indenting reflects different categories of data. The leftmost data + * represent the encoding names directly implemented by data files in Tcl's + * default encoding directory. Indented by one TAB are the encoding names that + * are common alternative spellings. Indented by two TABs are the accumulated + * "bug fixes" that have been added to deal with the wide variability seen + * among existing platforms. + */ + static CONST LocaleTable localeTable[] = { - /* First list all the encoding files installed with Tcl */ + {"", "iso8859-1"}, + {"ansi-1251", "cp1251"}, + {"ansi_x3.4-1968", "iso8859-1"}, {"ascii", "ascii"}, {"big5", "big5"}, {"cp1250", "cp1250"}, {"cp1251", "cp1251"}, {"cp1252", "cp1252"}, @@ -167,17 +177,68 @@ {"dingbats", "dingbats"}, {"ebcdic", "ebcdic"}, {"euc-cn", "euc-cn"}, {"euc-jp", "euc-jp"}, {"euc-kr", "euc-kr"}, + {"eucjp", "euc-jp"}, + {"euckr", "euc-kr"}, + {"euctw", "euc-cn"}, {"gb12345", "gb12345"}, {"gb1988", "gb1988"}, - {"gb2312-raw", "gb2312-raw"}, {"gb2312", "gb2312"}, + {"gb2312-1980", "gb2312"}, + {"gb2312-raw", "gb2312-raw"}, + {"greek8", "cp869"}, + {"ibm1250", "cp1250"}, + {"ibm1251", "cp1251"}, + {"ibm1252", "cp1252"}, + {"ibm1253", "cp1253"}, + {"ibm1254", "cp1254"}, + {"ibm1255", "cp1255"}, + {"ibm1256", "cp1256"}, + {"ibm1257", "cp1257"}, + {"ibm1258", "cp1258"}, + {"ibm437", "cp437"}, + {"ibm737", "cp737"}, + {"ibm775", "cp775"}, + {"ibm850", "cp850"}, + {"ibm852", "cp852"}, + {"ibm855", "cp855"}, + {"ibm857", "cp857"}, + {"ibm860", "cp860"}, + {"ibm861", "cp861"}, + {"ibm862", "cp862"}, + {"ibm863", "cp863"}, + {"ibm864", "cp864"}, + {"ibm865", "cp865"}, + {"ibm866", "cp866"}, + {"ibm869", "cp869"}, + {"ibm874", "cp874"}, + {"ibm932", "cp932"}, + {"ibm936", "cp936"}, + {"ibm949", "cp949"}, + {"ibm950", "cp950"}, + {"iso-2022", "iso2022"}, + {"iso-2022-jp", "iso2022-jp"}, + {"iso-2022-kr", "iso2022-kr"}, + {"iso-8859-1", "iso8859-1"}, + {"iso-8859-10", "iso8859-10"}, + {"iso-8859-13", "iso8859-13"}, + {"iso-8859-14", "iso8859-14"}, + {"iso-8859-15", "iso8859-15"}, + {"iso-8859-16", "iso8859-16"}, + {"iso-8859-2", "iso8859-2"}, + {"iso-8859-3", "iso8859-3"}, + {"iso-8859-4", "iso8859-4"}, + {"iso-8859-5", "iso8859-5"}, + {"iso-8859-6", "iso8859-6"}, + {"iso-8859-7", "iso8859-7"}, + {"iso-8859-8", "iso8859-8"}, + {"iso-8859-9", "iso8859-9"}, + {"iso2022", "iso2022"}, {"iso2022-jp", "iso2022-jp"}, {"iso2022-kr", "iso2022-kr"}, - {"iso2022", "iso2022"}, {"iso8859-1", "iso8859-1"}, {"iso8859-10", "iso8859-10"}, {"iso8859-13", "iso8859-13"}, {"iso8859-14", "iso8859-14"}, {"iso8859-15", "iso8859-15"}, @@ -188,32 +249,52 @@ {"iso8859-5", "iso8859-5"}, {"iso8859-6", "iso8859-6"}, {"iso8859-7", "iso8859-7"}, {"iso8859-8", "iso8859-8"}, {"iso8859-9", "iso8859-9"}, + {"iso88591", "iso8859-1"}, + {"iso885915", "iso8859-15"}, + {"iso88592", "iso8859-2"}, + {"iso88595", "iso8859-5"}, + {"iso88596", "iso8859-6"}, + {"iso88597", "iso8859-7"}, + {"iso88598", "iso8859-8"}, + {"iso88599", "iso8859-9"}, +#ifdef hpux + {"ja", "shiftjis"}, +#else + {"ja", "euc-jp"}, +#endif + {"ja_jp", "euc-jp"}, + {"ja_jp.euc", "euc-jp"}, + {"ja_jp.eucjp", "euc-jp"}, + {"ja_jp.jis", "iso2022-jp"}, + {"ja_jp.mscode", "shiftjis"}, + {"ja_jp.sjis", "shiftjis"}, + {"ja_jp.ujis", "euc-jp"}, + {"japan", "euc-jp"}, +#ifdef hpux + {"japanese", "shiftjis"}, +#else + {"japanese", "euc-jp"}, +#endif + {"japanese-sjis", "shiftjis"}, + {"japanese-ujis", "euc-jp"}, + {"japanese.euc", "euc-jp"}, + {"japanese.sjis", "shiftjis"}, {"jis0201", "jis0201"}, {"jis0208", "jis0208"}, {"jis0212", "jis0212"}, + {"jp_jp", "shiftjis"}, + {"ko", "euc-kr"}, + {"ko_kr", "euc-kr"}, + {"ko_kr.euc", "euc-kr"}, + {"ko_kw.euckw", "euc-kr"}, {"koi8-r", "koi8-r"}, {"koi8-u", "koi8-u"}, + {"korean", "euc-kr"}, {"ksc5601", "ksc5601"}, - {"macCentEuro", "macCentEuro"}, - {"macCroatian", "macCroatian"}, - {"macCyrillic", "macCyrillic"}, - {"macDingbats", "macDingbats"}, - {"macGreek", "macGreek"}, - {"macIceland", "macIceland"}, - {"macJapan", "macJapan"}, - {"macRoman", "macRoman"}, - {"macRomania", "macRomania"}, - {"macThai", "macThai"}, - {"macTurkish", "macTurkish"}, - {"macUkraine", "macUkraine"}, - {"shiftjis", "shiftjis"}, - {"symbol", "symbol"}, - {"tis-620", "tis-620"}, - /* Next list a few common variants */ {"maccenteuro", "macCentEuro"}, {"maccroatian", "macCroatian"}, {"maccyrillic", "macCyrillic"}, {"macdingbats", "macDingbats"}, {"macgreek", "macGreek"}, @@ -222,133 +303,37 @@ {"macroman", "macRoman"}, {"macromania", "macRomania"}, {"macthai", "macThai"}, {"macturkish", "macTurkish"}, {"macukraine", "macUkraine"}, - {"iso-2022-jp", "iso2022-jp"}, - {"iso-2022-kr", "iso2022-kr"}, - {"iso-2022", "iso2022"}, - {"iso-8859-1", "iso8859-1"}, - {"iso-8859-10", "iso8859-10"}, - {"iso-8859-13", "iso8859-13"}, - {"iso-8859-14", "iso8859-14"}, - {"iso-8859-15", "iso8859-15"}, - {"iso-8859-16", "iso8859-16"}, - {"iso-8859-2", "iso8859-2"}, - {"iso-8859-3", "iso8859-3"}, - {"iso-8859-4", "iso8859-4"}, - {"iso-8859-5", "iso8859-5"}, - {"iso-8859-6", "iso8859-6"}, - {"iso-8859-7", "iso8859-7"}, - {"iso-8859-8", "iso8859-8"}, - {"iso-8859-9", "iso8859-9"}, - {"ibm1250", "cp1250"}, - {"ibm1251", "cp1251"}, - {"ibm1252", "cp1252"}, - {"ibm1253", "cp1253"}, - {"ibm1254", "cp1254"}, - {"ibm1255", "cp1255"}, - {"ibm1256", "cp1256"}, - {"ibm1257", "cp1257"}, - {"ibm1258", "cp1258"}, - {"ibm437", "cp437"}, - {"ibm737", "cp737"}, - {"ibm775", "cp775"}, - {"ibm850", "cp850"}, - {"ibm852", "cp852"}, - {"ibm855", "cp855"}, - {"ibm857", "cp857"}, - {"ibm860", "cp860"}, - {"ibm861", "cp861"}, - {"ibm862", "cp862"}, - {"ibm863", "cp863"}, - {"ibm864", "cp864"}, - {"ibm865", "cp865"}, - {"ibm866", "cp866"}, - {"ibm869", "cp869"}, - {"ibm874", "cp874"}, - {"ibm932", "cp932"}, - {"ibm936", "cp936"}, - {"ibm949", "cp949"}, - {"ibm950", "cp950"}, - {"", "iso8859-1"}, - {"ansi_x3.4-1968", "iso8859-1"}, - /* Finally, the accumulated bug fixes... */ -#ifdef HAVE_LANGINFO - {"gb2312-1980", "gb2312"}, -#ifdef __hpux - {"SJIS", "shiftjis"}, - {"eucjp", "euc-jp"}, - {"euckr", "euc-kr"}, - {"euctw", "euc-cn"}, - {"greek8", "cp869"}, - {"iso88591", "iso8859-1"}, - {"iso88592", "iso8859-2"}, - {"iso88595", "iso8859-5"}, - {"iso88596", "iso8859-6"}, - {"iso88597", "iso8859-7"}, - {"iso88598", "iso8859-8"}, - {"iso88599", "iso8859-9"}, - {"iso885915", "iso8859-15"}, - {"roman8", "iso8859-1"}, - {"tis620", "tis-620"}, - {"turkish8", "cp857"}, - {"utf8", "utf-8"}, -#endif /* __hpux */ -#endif /* HAVE_LANGINFO */ - - {"ja_JP.SJIS", "shiftjis"}, - {"ja_JP.EUC", "euc-jp"}, - {"ja_JP.eucJP", "euc-jp"}, - {"ja_JP.JIS", "iso2022-jp"}, - {"ja_JP.mscode", "shiftjis"}, - {"ja_JP.ujis", "euc-jp"}, - {"ja_JP", "euc-jp"}, - {"Ja_JP", "shiftjis"}, - {"Jp_JP", "shiftjis"}, - {"japan", "euc-jp"}, -#ifdef hpux - {"japanese", "shiftjis"}, - {"ja", "shiftjis"}, -#else - {"japanese", "euc-jp"}, - {"ja", "euc-jp"}, -#endif - {"japanese.sjis", "shiftjis"}, - {"japanese.euc", "euc-jp"}, - {"japanese-sjis", "shiftjis"}, - {"japanese-ujis", "euc-jp"}, - - {"ko", "euc-kr"}, - {"ko_KR", "euc-kr"}, - {"ko_KR.EUC", "euc-kr"}, - {"ko_KR.euc", "euc-kr"}, - {"ko_KR.eucKR", "euc-kr"}, - {"korean", "euc-kr"}, - - {"ru", "iso8859-5"}, - {"ru_RU", "iso8859-5"}, - {"ru_SU", "iso8859-5"}, - - {"zh", "cp936"}, - {"zh_CN.gb2312", "euc-cn"}, - {"zh_CN.GB2312", "euc-cn"}, - {"zh_CN.GBK", "euc-cn"}, - {"zh_TW.Big5", "big5"}, - {"zh_TW", "euc-tw"}, - - {NULL, NULL} + {"roman8", "iso8859-1"}, + {"ru", "iso8859-5"}, + {"ru_ru", "iso8859-5"}, + {"ru_su", "iso8859-5"}, + {"shiftjis", "shiftjis"}, + {"sjis", "shiftjis"}, + {"symbol", "symbol"}, + {"tis-620", "tis-620"}, + {"tis620", "tis-620"}, + {"turkish8", "cp857"}, + {"utf8", "utf-8"}, + {"zh", "cp936"}, + {"zh_cn.gb2312", "euc-cn"}, + {"zh_cn.gbk", "euc-cn"}, + {"zh_cz.gb2312", "euc-cn"}, + {"zh_tw", "euc-tw"}, + {"zh_tw.big5", "big5"}, }; #ifndef TCL_NO_STACK_CHECK static int GetStackSize _ANSI_ARGS_((size_t *stackSizePtr)); #endif /* TCL_NO_STACK_CHECK */ -#ifdef HAVE_CFBUNDLE +#ifdef HAVE_COREFOUNDATION static int MacOSXGetLibraryPath _ANSI_ARGS_(( Tcl_Interp *interp, int maxPathLen, char *tclLibPath)); -#endif /* HAVE_CFBUNDLE */ +#endif /* HAVE_COREFOUNDATION */ /* *--------------------------------------------------------------------------- * @@ -390,17 +375,16 @@ if (TclOSseek(2, (Tcl_SeekOffset) 0, SEEK_CUR) == -1 && errno == EBADF) { open("/dev/null", O_WRONLY); } /* - * The code below causes SIGPIPE (broken pipe) errors to - * be ignored. This is needed so that Tcl processes don't - * die if they create child processes (e.g. using "exec" or - * "open") that terminate prematurely. The signal handler - * is only set up when the first interpreter is created; - * after this the application can override the handler with - * a different one of its own, if it wants. + * The code below causes SIGPIPE (broken pipe) errors to be ignored. This + * is needed so that Tcl processes don't die if they create child + * processes (e.g. using "exec" or "open") that terminate prematurely. + * The signal handler is only set up when the first interpreter is + * created; after this the application can override the handler with a + * different one of its own, if it wants. */ #ifdef SIGPIPE (void) signal(SIGPIPE, SIG_IGN); #endif /* SIGPIPE */ @@ -414,26 +398,27 @@ /* * Find local symbols. Don't report an error if we fail. */ (void) dlopen (NULL, RTLD_NOW); /* INTL: Native. */ #endif + /* - * Initialize the C library's locale subsystem. This is required - * for input methods to work properly on X11. We only do this for - * LC_CTYPE because that's the necessary one, and we don't want to - * affect LC_TIME here. The side effect of setting the default - * locale should be to load any locale specific modules that are - * needed by X. [BUG: 5422 3345 4236 2522 2521]. + * Initialize the C library's locale subsystem. This is required for input + * methods to work properly on X11. We only do this for LC_CTYPE because + * that's the necessary one, and we don't want to affect LC_TIME here. + * The side effect of setting the default locale should be to load any + * locale specific modules that are needed by X. [BUG: 5422 3345 4236 2522 + * 2521]. */ setlocale(LC_CTYPE, ""); /* * In case the initial locale is not "C", ensure that the numeric - * processing is done in "C" locale regardless. This is needed because - * Tcl relies on routines like strtod, but should not have locale - * dependent behavior. + * processing is done in "C" locale regardless. This is needed because Tcl + * relies on routines like strtod, but should not have locale dependent + * behavior. */ setlocale(LC_NUMERIC, "C"); } @@ -440,22 +425,21 @@ /* *--------------------------------------------------------------------------- * * TclpInitLibraryPath -- * - * This is the fallback routine that sets the library path - * if the application has not set one by the first time - * it is needed. + * This is the fallback routine that sets the library path if the + * application has not set one by the first time it is needed. * * Results: - * None. + * None. * * Side effects: - * Sets the library path to an initial value. + * Sets the library path to an initial value. * *------------------------------------------------------------------------- - */ + */ void TclpInitLibraryPath(valuePtr, lengthPtr, encodingPtr) char **valuePtr; int *lengthPtr; @@ -471,22 +455,22 @@ Tcl_DStringInit(&ds); pathPtr = Tcl_NewObj(); /* - * Initialize the substrings used when locating an executable. The - * installLib variable computes the path as though the executable - * is installed. + * Initialize the substrings used when locating an executable. The + * installLib variable computes the path as though the executable is + * installed. */ sprintf(installLib, "lib/tcl%s", TCL_VERSION); /* - * Look for the library relative to the TCL_LIBRARY env variable. - * If the last dirname in the TCL_LIBRARY path does not match the - * last dirname in the installLib variable, use the last dir name - * of installLib in addition to the orginal TCL_LIBRARY path. + * Look for the library relative to the TCL_LIBRARY env variable. If the + * last dirname in the TCL_LIBRARY path does not match the last dirname in + * the installLib variable, use the last dir name of installLib in + * addition to the orginal TCL_LIBRARY path. */ str = getenv("TCL_LIBRARY"); /* INTL: Native. */ Tcl_ExternalToUtfDString(NULL, str, -1, &buffer); str = Tcl_DStringValue(&buffer); @@ -503,12 +487,12 @@ if ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc-1]) != 0)) { /* * If TCL_LIBRARY is set but refers to a different tcl * installation than the current version, try fiddling with the * specified directory to make it refer to this installation by - * removing the old "tclX.Y" and substituting the current - * version string. + * removing the old "tclX.Y" and substituting the current version + * string. */ pathv[pathc - 1] = installLib + 4; str = Tcl_JoinPath(pathc, pathv, &ds); objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds)); @@ -517,31 +501,34 @@ } ckfree((char *) pathv); } /* - * Finally, look for the library relative to the compiled-in path. - * This is needed when users install Tcl with an exec-prefix that - * is different from the prtefix. + * Finally, look for the library relative to the compiled-in path. This is + * needed when users install Tcl with an exec-prefix that is different + * from the prtefix. */ { -#ifdef HAVE_CFBUNDLE - char tclLibPath[MAXPATHLEN + 1]; - - if (MacOSXGetLibraryPath(NULL, MAXPATHLEN, tclLibPath) == TCL_OK) { - str = tclLibPath; - } else -#endif /* HAVE_CFBUNDLE */ - { - /* TODO: Pull this value from the TIP 59 table */ - str = defaultLibraryDir; - } - if (str[0] != '\0') { - objPtr = Tcl_NewStringObj(str, -1); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - } +#ifdef HAVE_COREFOUNDATION + char tclLibPath[MAXPATHLEN + 1]; + + if (MacOSXGetLibraryPath(NULL, MAXPATHLEN, tclLibPath) == TCL_OK) { + str = tclLibPath; + } else +#endif /* HAVE_COREFOUNDATION */ + { + /* + * TODO: Pull this value from the TIP 59 table. + */ + + str = defaultLibraryDir; + } + if (str[0] != '\0') { + objPtr = Tcl_NewStringObj(str, -1); + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); + } } Tcl_DStringFree(&buffer); *encodingPtr = Tcl_GetEncoding(NULL, NULL); str = Tcl_GetStringFromObj(pathPtr, lengthPtr); @@ -553,25 +540,25 @@ /* *--------------------------------------------------------------------------- * * TclpSetInitialEncodings -- * - * Based on the locale, determine the encoding of the operating - * system and the default encoding for newly opened files. + * Based on the locale, determine the encoding of the operating system + * and the default encoding for newly opened files. * - * Called at process initialization time, and part way through - * startup, we verify that the initial encodings were correctly - * setup. Depending on Tcl's environment, there may not have been - * enough information first time through (above). + * Called at process initialization time, and part way through startup, + * we verify that the initial encodings were correctly setup. Depending + * on Tcl's environment, there may not have been enough information first + * time through (above). * * Results: * None. * * Side effects: - * The Tcl library path is converted from native encoding to UTF-8, - * on the first call, and the encodings may be changed on first or - * second call. + * The Tcl library path is converted from native encoding to UTF-8, on + * the first call, and the encodings may be changed on first or second + * call. * *--------------------------------------------------------------------------- */ void @@ -580,43 +567,70 @@ Tcl_DString encodingName; Tcl_SetSystemEncoding(NULL, TclpGetEncodingNameFromEnvironment(&encodingName)); Tcl_DStringFree(&encodingName); } + +void +TclpSetInterfaces() +{ + /* do nothing */ +} + +static CONST char * +SearchKnownEncodings(encoding) + CONST char *encoding; +{ + int left = 0; + int right = sizeof(localeTable)/sizeof(LocaleTable); + + while (left <= right) { + int test = (left + right)/2; + int code = strcmp(localeTable[test].lang, encoding); + + if (code == 0) { + return localeTable[test].encoding; + } + if (code < 0) { + left = test+1; + } else { + right = test-1; + } + } + return NULL; +} CONST char * TclpGetEncodingNameFromEnvironment(bufPtr) Tcl_DString *bufPtr; { CONST char *encoding; - int i; + CONST char *knownEncoding; Tcl_DStringInit(bufPtr); /* * Determine the current encoding from the LC_* or LANG environment - * variables. We previously used setlocale() to determine the locale, - * but this does not work on some systems (e.g. Linux/i386 RH 5.0). + * variables. We previously used setlocale() to determine the locale, but + * this does not work on some systems (e.g. Linux/i386 RH 5.0). */ + #ifdef HAVE_LANGINFO if (setlocale(LC_CTYPE, "") != NULL) { Tcl_DString ds; - /* Use a DString so we can modify case. */ + /* + * Use a DString so we can modify case. + */ + Tcl_DStringInit(&ds); encoding = Tcl_DStringAppend(&ds, nl_langinfo(CODESET), -1); Tcl_UtfToLower(Tcl_DStringValue(&ds)); - /* Check whether it's a known encoding... */ - if (NULL == Tcl_GetEncoding(NULL, encoding)) { - /* ... or in the table if encodings we *should* know */ - for (i = 0; localeTable[i].lang != NULL; i++) { - if (strcmp(localeTable[i].lang, encoding) == 0) { - Tcl_DStringAppend(bufPtr, localeTable[i].encoding, -1); - break; - } - } - } else { + knownEncoding = SearchKnownEncodings(encoding); + if (knownEncoding != NULL) { + Tcl_DStringAppend(bufPtr, knownEncoding, -1); + } else if (NULL != Tcl_GetEncoding(NULL, encoding)) { Tcl_DStringAppend(bufPtr, encoding, -1); } Tcl_DStringFree(&ds); if (Tcl_DStringLength(bufPtr)) { return Tcl_DStringValue(bufPtr); @@ -623,13 +637,14 @@ } } #endif /* HAVE_LANGINFO */ /* - * Classic fallback check. This tries a homebrew algorithm to - * determine what encoding should be used based on env vars. + * Classic fallback check. This tries a homebrew algorithm to determine + * what encoding should be used based on env vars. */ + encoding = getenv("LC_ALL"); if (encoding == NULL || encoding[0] == '\0') { encoding = getenv("LC_CTYPE"); } @@ -640,61 +655,50 @@ encoding = NULL; } if (encoding != NULL) { CONST char *p; - - /* Check whether it's a known encoding... */ - if (NULL == Tcl_GetEncoding(NULL, encoding)) { - /* ... or in the table if encodings we *should* know */ - for (i = 0; localeTable[i].lang != NULL; i++) { - if (strcmp(localeTable[i].lang, encoding) == 0) { - Tcl_DStringAppend(bufPtr, localeTable[i].encoding, -1); - break; - } - } - } else { + Tcl_DString ds; + + Tcl_DStringInit(&ds); + p = encoding; + encoding = Tcl_DStringAppend(&ds, p, -1); + Tcl_UtfToLower(Tcl_DStringValue(&ds)); + + knownEncoding = SearchKnownEncodings(encoding); + if (knownEncoding != NULL) { + Tcl_DStringAppend(bufPtr, knownEncoding, -1); + } else if (NULL != Tcl_GetEncoding(NULL, encoding)) { Tcl_DStringAppend(bufPtr, encoding, -1); } if (Tcl_DStringLength(bufPtr)) { + Tcl_DStringFree(&ds); return Tcl_DStringValue(bufPtr); } /* - * We didn't recognize the full value as an encoding name. - * If there is an encoding subfield, we can try to guess from that. + * We didn't recognize the full value as an encoding name. If there is + * an encoding subfield, we can try to guess from that. */ for (p = encoding; *p != '\0'; p++) { if (*p == '.') { p++; break; } } if (*p != '\0') { - Tcl_DString ds; - Tcl_DStringInit(&ds); - encoding = Tcl_DStringAppend(&ds, p, -1); - Tcl_UtfToLower(Tcl_DStringValue(&ds)); - - /* Check whether it's a known encoding... */ - if (NULL == Tcl_GetEncoding(NULL, encoding)) { - /* ... or in the table if encodings we *should* know */ - for (i = 0; localeTable[i].lang != NULL; i++) { - if (strcmp(localeTable[i].lang, encoding) == 0) { - Tcl_DStringAppend(bufPtr, localeTable[i].encoding, -1); - break; - } - } - } else { - Tcl_DStringAppend(bufPtr, encoding, -1); - } - Tcl_DStringFree(&ds); - if (Tcl_DStringLength(bufPtr)) { - return Tcl_DStringValue(bufPtr); - } - + knownEncoding = SearchKnownEncodings(p); + if (knownEncoding != NULL) { + Tcl_DStringAppend(bufPtr, knownEncoding, -1); + } else if (NULL != Tcl_GetEncoding(NULL, p)) { + Tcl_DStringAppend(bufPtr, p, -1); + } + } + Tcl_DStringFree(&ds); + if (Tcl_DStringLength(bufPtr)) { + return Tcl_DStringValue(bufPtr); } } return Tcl_DStringAppend(bufPtr, TCL_DEFAULT_ENCODING, -1); } @@ -701,13 +705,13 @@ /* *--------------------------------------------------------------------------- * * TclpSetVariables -- * - * Performs platform-specific interpreter initialization related to - * the tcl_library and tcl_platform variables, and other platform- - * specific things. + * Performs platform-specific interpreter initialization related to the + * tcl_library and tcl_platform variables, and other platform-specific + * things. * * Results: * None. * * Side effects: @@ -726,78 +730,88 @@ #endif int unameOK; CONST char *user; Tcl_DString ds; -#ifdef HAVE_CFBUNDLE +#ifdef HAVE_COREFOUNDATION char tclLibPath[MAXPATHLEN + 1]; if (MacOSXGetLibraryPath(interp, MAXPATHLEN, tclLibPath) == TCL_OK) { - CONST char *str; - Tcl_DString ds; - CFBundleRef bundleRef; - - Tcl_SetVar(interp, "tclDefaultLibrary", tclLibPath, - TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, - TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "tcl_pkgPath", " ", - TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); - str = TclGetEnv("DYLD_FRAMEWORK_PATH", &ds); - if ((str != NULL) && (str[0] != '\0')) { - char *p = Tcl_DStringValue(&ds); - /* convert DYLD_FRAMEWORK_PATH from colon to space separated */ - do { - if(*p == ':') *p = ' '; - } while (*p++); - Tcl_SetVar(interp, "tcl_pkgPath", Tcl_DStringValue(&ds), - TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); - Tcl_SetVar(interp, "tcl_pkgPath", " ", - TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); - Tcl_DStringFree(&ds); - } - if ((bundleRef = CFBundleGetMainBundle())) { - CFURLRef frameworksURL; - Tcl_StatBuf statBuf; - if((frameworksURL = CFBundleCopyPrivateFrameworksURL(bundleRef))) { - if(CFURLGetFileSystemRepresentation(frameworksURL, TRUE, - tclLibPath, MAXPATHLEN) && - ! TclOSstat(tclLibPath, &statBuf) && - S_ISDIR(statBuf.st_mode)) { - Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, - TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); - Tcl_SetVar(interp, "tcl_pkgPath", " ", - TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); - } - CFRelease(frameworksURL); - } - if((frameworksURL = CFBundleCopySharedFrameworksURL(bundleRef))) { - if(CFURLGetFileSystemRepresentation(frameworksURL, TRUE, - tclLibPath, MAXPATHLEN) && - ! TclOSstat(tclLibPath, &statBuf) && - S_ISDIR(statBuf.st_mode)) { - Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, - TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); - Tcl_SetVar(interp, "tcl_pkgPath", " ", - TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); - } - CFRelease(frameworksURL); - } - } - Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, - TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); + CONST char *str; + Tcl_DString ds; + CFBundleRef bundleRef; + + Tcl_SetVar(interp, "tclDefaultLibrary", tclLibPath, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "tcl_pkgPath", " ", + TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); + + str = TclGetEnv("DYLD_FRAMEWORK_PATH", &ds); + if ((str != NULL) && (str[0] != '\0')) { + char *p = Tcl_DStringValue(&ds); + + /* + * Convert DYLD_FRAMEWORK_PATH from colon to space separated. + */ + + do { + if (*p == ':') { + *p = ' '; + } + } while (*p++); + Tcl_SetVar(interp, "tcl_pkgPath", Tcl_DStringValue(&ds), + TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); + Tcl_SetVar(interp, "tcl_pkgPath", " ", + TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); + Tcl_DStringFree(&ds); + } + bundleRef = CFBundleGetMainBundle(); + if (bundleRef) { + CFURLRef frameworksURL; + Tcl_StatBuf statBuf; + + frameworksURL = CFBundleCopyPrivateFrameworksURL(bundleRef); + if (frameworksURL) { + if (CFURLGetFileSystemRepresentation(frameworksURL, TRUE, + (unsigned char*) tclLibPath, MAXPATHLEN) && + ! TclOSstat(tclLibPath, &statBuf) && + S_ISDIR(statBuf.st_mode)) { + Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, + TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); + Tcl_SetVar(interp, "tcl_pkgPath", " ", + TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); + } + CFRelease(frameworksURL); + } + frameworksURL = CFBundleCopySharedFrameworksURL(bundleRef); + if (frameworksURL) { + if (CFURLGetFileSystemRepresentation(frameworksURL, TRUE, + (unsigned char*) tclLibPath, MAXPATHLEN) && + ! TclOSstat(tclLibPath, &statBuf) && + S_ISDIR(statBuf.st_mode)) { + Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, + TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); + Tcl_SetVar(interp, "tcl_pkgPath", " ", + TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); + } + CFRelease(frameworksURL); + } + } + Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, + TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); } else -#endif /* HAVE_CFBUNDLE */ +#endif /* HAVE_COREFOUNDATION */ { - Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY); } #ifdef DJGPP Tcl_SetVar2(interp, "tcl_platform", "platform", "dos", TCL_GLOBAL_ONLY); #else Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY); #endif + unameOK = 0; #ifndef NO_UNAME if (uname(&name) >= 0) { CONST char *native; @@ -806,26 +820,29 @@ native = Tcl_ExternalToUtfDString(NULL, name.sysname, -1, &ds); Tcl_SetVar2(interp, "tcl_platform", "os", native, TCL_GLOBAL_ONLY); Tcl_DStringFree(&ds); /* - * The following code is a special hack to handle differences in - * the way version information is returned by uname. On most - * systems the full version number is available in name.release. - * However, under AIX the major version number is in - * name.version and the minor version number is in name.release. + * The following code is a special hack to handle differences in the + * way version information is returned by uname. On most systems the + * full version number is available in name.release. However, under + * AIX the major version number is in name.version and the minor + * version number is in name.release. */ if ((strchr(name.release, '.') != NULL) || !isdigit(UCHAR(name.version[0]))) { /* INTL: digit */ Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release, TCL_GLOBAL_ONLY); } else { #ifdef DJGPP - /* For some obscure reason DJGPP puts major version into - * name.release and minor into name.version. As of DJGPP 2.04 - * this is documented in djgpp libc.info file*/ + /* + * For some obscure reason DJGPP puts major version into + * name.release and minor into name.version. As of DJGPP 2.04 this + * is documented in djgpp libc.info file. + */ + Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release, TCL_GLOBAL_ONLY); Tcl_SetVar2(interp, "tcl_platform", "osVersion", ".", TCL_GLOBAL_ONLY|TCL_APPEND_VALUE); Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.version, @@ -849,11 +866,11 @@ Tcl_SetVar2(interp, "tcl_platform", "osVersion", "", TCL_GLOBAL_ONLY); Tcl_SetVar2(interp, "tcl_platform", "machine", "", TCL_GLOBAL_ONLY); } /* - * Copy USER or LOGNAME environment variable into tcl_platform(user) + * Copy USER or LOGNAME environment variable into tcl_platform(user). */ Tcl_DStringInit(&ds); user = TclGetEnv("USER", &ds); if (user == NULL) { @@ -862,27 +879,25 @@ user = ""; } } Tcl_SetVar2(interp, "tcl_platform", "user", user, TCL_GLOBAL_ONLY); Tcl_DStringFree(&ds); - } /* *---------------------------------------------------------------------- * * TclpFindVariable -- * - * Locate the entry in environ for a given name. On Unix this - * routine is case sensetive, on Windows this matches mixed case. + * Locate the entry in environ for a given name. On Unix this routine is + * case sensetive, on Windows this matches mixed case. * * Results: - * The return value is the index in environ of an entry with the - * name "name", or -1 if there is no such entry. The integer at - * *lengthPtr is filled in with the length of name (if a matching - * entry is found) or the length of the environ array (if no matching - * entry is found). + * The return value is the index in environ of an entry with the name + * "name", or -1 if there is no such entry. The integer at *lengthPtr is + * filled in with the length of name (if a matching entry is found) or + * the length of the environ array (if no matching entry is found). * * Side effects: * None. * *---------------------------------------------------------------------- @@ -918,22 +933,22 @@ Tcl_DStringFree(&envString); } *lengthPtr = i; - done: + done: Tcl_DStringFree(&envString); return result; } /* *---------------------------------------------------------------------- * * TclpCheckStackSpace -- * - * Detect if we are about to blow the stack. Called before an - * evaluation can happen when nesting depth is checked. + * Detect if we are about to blow the stack. Called before an evaluation + * can happen when nesting depth is checked. * * Results: * 1 if there is enough stack space to continue; 0 if not. * * Side effects: @@ -946,12 +961,12 @@ TclpCheckStackSpace() { #ifdef TCL_NO_STACK_CHECK /* - * This function was normally unimplemented on Unix platforms and - * this implements old behavior, i.e. no stack checking performed. + * This function was normally unimplemented on Unix platforms and this + * implements old behavior, i.e. no stack checking performed. */ return 1; #else @@ -964,12 +979,16 @@ int localVar; /* Reference to somewhere on the local stack. * This is declared last so it's as "deep" as * possible. */ if (tsdPtr == NULL) { - /* this should probably be a panic(). */ - Tcl_Panic("failed to get thread specific stack check data"); + /* + * This should probably be a panic(); if we're out of stack, we might + * have virtually no room to manoeuver at all. + */ + + Tcl_Panic("failed to get thread specific stack check data"); } /* * The first time through, we record the "outermost" stack frame. */ @@ -978,15 +997,15 @@ tsdPtr->outerVarPtr = &localVar; } if (tsdPtr->initialised == 0) { /* - * We appear to have not computed the stack size before. - * Attempt to retrieve it from either the current thread or, - * failing that, the process accounting limit. Note that we - * assume that stack sizes do not change throughout the - * lifespan of the thread/process; this is almost always true. + * We appear to have not computed the stack size before. Attempt to + * retrieve it from either the current thread or, failing that, the + * process accounting limit. Note that we assume that stack sizes do + * not change throughout the lifespan of the thread/process; this is + * almost always true. */ tsdPtr->stackDetermineResult = GetStackSize(&tsdPtr->stackSize); tsdPtr->initialised = 1; } @@ -1010,12 +1029,11 @@ } else { stackUsed = (char *)tsdPtr->outerVarPtr - (char *)&localVar; } /* - * Now we perform the actual check. Are we about to blow - * our stack frame? + * Now we perform the actual check. Are we about to blow our stack frame? */ if (stackUsed < (ptrdiff_t) tsdPtr->stackSize) { STACK_DEBUG(("stack OK\tin:%p\tout:%p\tuse:%04X\tmax:%04X\n", &localVar, tsdPtr->outerVarPtr, stackUsed, tsdPtr->stackSize)); @@ -1031,21 +1049,21 @@ /* *---------------------------------------------------------------------- * * GetStackSize -- * - * Discover what the stack size for the current thread/process - * actually is. Expects to only ever be called once per thread - * and then only at a point when there is a reasonable amount of - * space left on the current stack; TclpCheckStackSpace is called - * sufficiently frequently that that is true. + * Discover what the stack size for the current thread/process actually + * is. Expects to only ever be called once per thread and then only at a + * point when there is a reasonable amount of space left on the current + * stack; TclpCheckStackSpace is called sufficiently frequently that that + * is true. * * Results: - * TCL_OK if the stack space was discovered, TCL_BREAK if the - * stack space was undiscoverable in a way that stack checks - * should fail, and TCL_CONTINUE if the stack space was - * undiscoverable in a way that stack checks should succeed. + * TCL_OK if the stack space was discovered, TCL_BREAK if the stack space + * was undiscoverable in a way that stack checks should fail, and + * TCL_CONTINUE if the stack space was undiscoverable in a way that stack + * checks should succeed. * * Side effects: * None * *---------------------------------------------------------------------- @@ -1070,14 +1088,13 @@ if (rawStackSize > 0) { goto finalSanityCheck; } /* - * If we have zero or an error, try the system limits - * instead. After all, the pthread documentation states that - * threads should always be bound by the system stack size limit - * in any case. + * If we have zero or an error, try the system limits instead. After all, + * the pthread documentation states that threads should always be bound by + * the system stack size limit in any case. */ #endif /* TCL_THREADS */ if (getrlimit(RLIMIT_STACK, &rLimit) != 0) { /* @@ -1092,13 +1109,13 @@ return TCL_CONTINUE; } rawStackSize = rLimit.rlim_cur; /* - * Final sanity check on the determined stack size. If we fail - * this, assume there are bogus values about and that we can't - * actually figure out what the stack size really is. + * Final sanity check on the determined stack size. If we fail this, + * assume there are bogus values about and that we can't actually figure + * out what the stack size really is. */ #ifdef TCL_THREADS /* Stop warning... */ finalSanityCheck: #endif @@ -1120,13 +1137,12 @@ /* *---------------------------------------------------------------------- * * MacOSXGetLibraryPath -- * - * If we have a bundle structure for the Tcl installation, - * then check there first to see if we can find the libraries - * there. + * If we have a bundle structure for the Tcl installation, then check + * there first to see if we can find the libraries there. * * Results: * TCL_OK if we have found the tcl library; TCL_ERROR otherwise. * * Side effects: @@ -1133,17 +1149,28 @@ * Same as for Tcl_MacOSXOpenVersionedBundleResources. * *---------------------------------------------------------------------- */ -#ifdef HAVE_CFBUNDLE +#ifdef HAVE_COREFOUNDATION static int MacOSXGetLibraryPath(Tcl_Interp *interp, int maxPathLen, char *tclLibPath) { int foundInFramework = TCL_ERROR; + #ifdef TCL_FRAMEWORK - foundInFramework = Tcl_MacOSXOpenVersionedBundleResources(interp, - "com.tcltk.tcllibrary", TCL_VERSION, 0, maxPathLen, tclLibPath); + foundInFramework = Tcl_MacOSXOpenVersionedBundleResources(interp, + "com.tcltk.tcllibrary", TCL_FRAMEWORK_VERSION, 0, maxPathLen, + tclLibPath); #endif + return foundInFramework; } -#endif /* HAVE_CFBUNDLE */ +#endif /* HAVE_COREFOUNDATION */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: unix/tclUnixNotfy.c ================================================================== --- unix/tclUnixNotfy.c +++ unix/tclUnixNotfy.c @@ -1,64 +1,70 @@ /* * tclUnixNotify.c -- * - * This file contains the implementation of the select-based - * Unix-specific notifier, which is the lowest-level part of the - * Tcl event loop. This file works together with - * ../generic/tclNotify.c. + * This file contains the implementation of the select()-based + * Unix-specific notifier, which is the lowest-level part of the Tcl + * event loop. This file works together with generic/tclNotify.c. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixNotfy.c,v 1.18 2004/11/24 20:12:19 kennykb Exp $ + * RCS: @(#) $Id: tclUnixNotfy.c,v 1.18.2.6 2005/08/02 18:16:57 dgp Exp $ */ +#ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is + * in tclMacOSXNotify.c */ #include "tclInt.h" #include +/* + * This code does deep stub magic to allow replacement of the notifier at + * runtime. + */ + extern TclStubs tclStubs; extern Tcl_NotifierProcs tclOriginalNotifier; /* - * This structure is used to keep track of the notifier info for a - * a registered file. + * This structure is used to keep track of the notifier info for a registered + * file. */ typedef struct FileHandler { int fd; int mask; /* Mask of desired events: TCL_READABLE, * etc. */ - int readyMask; /* Mask of events that have been seen since the - * last time file handlers were invoked for - * this file. */ - Tcl_FileProc *proc; /* Procedure to call, in the style of + int readyMask; /* Mask of events that have been seen since + * the last time file handlers were invoked + * for this file. */ + Tcl_FileProc *proc; /* Function to call, in the style of * Tcl_CreateFileHandler. */ ClientData clientData; /* Argument to pass to proc. */ struct FileHandler *nextPtr;/* Next in list of all files we care about. */ } FileHandler; /* - * The following structure is what is added to the Tcl event queue when - * file handlers are ready to fire. + * The following structure is what is added to the Tcl event queue when file + * handlers are ready to fire. */ typedef struct FileHandlerEvent { - Tcl_Event header; /* Information that is standard for - * all events. */ - int fd; /* File descriptor that is ready. Used - * to find the FileHandler structure for - * the file (can't point directly to the - * FileHandler structure because it could - * go away while the event is queued). */ + Tcl_Event header; /* Information that is standard for all + * events. */ + int fd; /* File descriptor that is ready. Used to find + * the FileHandler structure for the file + * (can't point directly to the FileHandler + * structure because it could go away while + * the event is queued). */ } FileHandlerEvent; /* * - * The following structure contains a set of select() masks to track - * readable, writable, and exceptional conditions. + * The following structure contains a set of select() masks to track readable, + * writable, and exceptional conditions. */ typedef struct SelectMasks { fd_set readable; fd_set writable; @@ -65,130 +71,128 @@ fd_set exceptional; } SelectMasks; /* * The following static structure contains the state information for the - * select based implementation of the Tcl notifier. One of these structures - * is created for each thread that is using the notifier. + * select based implementation of the Tcl notifier. One of these structures is + * created for each thread that is using the notifier. */ typedef struct ThreadSpecificData { FileHandler *firstFileHandlerPtr; /* Pointer to head of file handler list. */ - - SelectMasks checkMasks; /* This structure is used to build up the masks - * to be used in the next call to select. - * Bits are set in response to calls to - * Tcl_CreateFileHandler. */ + SelectMasks checkMasks; /* This structure is used to build up the + * masks to be used in the next call to + * select. Bits are set in response to calls + * to Tcl_CreateFileHandler. */ SelectMasks readyMasks; /* This array reflects the readable/writable * conditions that were found to exist by the * last call to select. */ - int numFdBits; /* Number of valid bits in checkMasks - * (one more than highest fd for which + int numFdBits; /* Number of valid bits in checkMasks (one + * more than highest fd for which * Tcl_WatchFile has been called). */ #ifdef TCL_THREADS int onList; /* True if it is in this list */ - unsigned int pollState; /* pollState is used to implement a polling + unsigned int pollState; /* pollState is used to implement a polling * handshake between each thread and the * notifier thread. Bits defined below. */ struct ThreadSpecificData *nextPtr, *prevPtr; - /* All threads that are currently waiting on - * an event have their ThreadSpecificData - * structure on a doubly-linked listed formed - * from these pointers. You must hold the - * notifierMutex lock before accessing these - * fields. */ - Tcl_Condition waitCV; /* Any other thread alerts a notifier - * that an event is ready to be processed - * by signaling this condition variable. */ - int eventReady; /* True if an event is ready to be processed. - * Used as condition flag together with - * waitCV above. */ + /* All threads that are currently waiting on + * an event have their ThreadSpecificData + * structure on a doubly-linked listed formed + * from these pointers. You must hold the + * notifierMutex lock before accessing these + * fields. */ + Tcl_Condition waitCV; /* Any other thread alerts a notifier that an + * event is ready to be processed by signaling + * this condition variable. */ + int eventReady; /* True if an event is ready to be processed. + * Used as condition flag together with waitCV + * above. */ #endif } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; #ifdef TCL_THREADS /* - * The following static indicates the number of threads that have - * initialized notifiers. + * The following static indicates the number of threads that have initialized + * notifiers. * * You must hold the notifierMutex lock before accessing this variable. */ static int notifierCount = 0; /* - * The following variable points to the head of a doubly-linked list of - * of ThreadSpecificData structures for all threads that are currently - * waiting on an event. + * The following variable points to the head of a doubly-linked list of + * ThreadSpecificData structures for all threads that are currently waiting on + * an event. * * You must hold the notifierMutex lock before accessing this list. */ static ThreadSpecificData *waitingListPtr = NULL; /* - * The notifier thread spends all its time in select() waiting for a - * file descriptor associated with one of the threads on the waitingListPtr - * list to do something interesting. But if the contents of the - * waitingListPtr list ever changes, we need to wake up and restart - * the select() system call. You can wake up the notifier thread by - * writing a single byte to the file descriptor defined below. This - * file descriptor is the input-end of a pipe and the notifier thread is - * listening for data on the output-end of the same pipe. Hence writing - * to this file descriptor will cause the select() system call to return - * and wake up the notifier thread. + * The notifier thread spends all its time in select() waiting for a file + * descriptor associated with one of the threads on the waitingListPtr list to + * do something interesting. But if the contents of the waitingListPtr list + * ever changes, we need to wake up and restart the select() system call. You + * can wake up the notifier thread by writing a single byte to the file + * descriptor defined below. This file descriptor is the input-end of a pipe + * and the notifier thread is listening for data on the output-end of the same + * pipe. Hence writing to this file descriptor will cause the select() system + * call to return and wake up the notifier thread. * * You must hold the notifierMutex lock before accessing this list. */ static int triggerPipe = -1; /* - * The notifierMutex locks access to all of the global notifier state. + * The notifierMutex locks access to all of the global notifier state. */ TCL_DECLARE_MUTEX(notifierMutex) /* * The notifier thread signals the notifierCV when it has finished - * initializing the triggerPipe and right before the notifier - * thread terminates. + * initializing the triggerPipe and right before the notifier thread + * terminates. */ static Tcl_Condition notifierCV; /* - * The pollState bits + * The pollState bits: * POLL_WANT is set by each thread before it waits on its condition - * variable. It is checked by the notifier before it does - * select. - * POLL_DONE is set by the notifier if it goes into select after - * seeing POLL_WANT. The idea is to ensure it tries a select - * with the same bits the initial thread had set. + * variable. It is checked by the notifier before it does select. + * POLL_DONE is set by the notifier if it goes into select after seeing + * POLL_WANT. The idea is to ensure it tries a select with the + * same bits the initial thread had set. */ + #define POLL_WANT 0x1 #define POLL_DONE 0x2 /* * This is the thread ID of the notifier thread that does select. */ + static Tcl_ThreadId notifierThread; #endif /* * Static routines defined in this file. */ #ifdef TCL_THREADS -static void NotifierThreadProc _ANSI_ARGS_((ClientData clientData)); +static void NotifierThreadProc(ClientData clientData); #endif -static int FileHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr, - int flags)); +static int FileHandlerEventProc(Tcl_Event *evPtr, int flags); /* *---------------------------------------------------------------------- * * Tcl_InitNotifier -- @@ -217,11 +221,11 @@ */ Tcl_MutexLock(¬ifierMutex); if (notifierCount == 0) { if (TclpThreadCreate(¬ifierThread, NotifierThreadProc, NULL, - TCL_THREAD_STACK_DEFAULT, TCL_THREAD_NOFLAGS) != TCL_OK) { + TCL_THREAD_STACK_DEFAULT, TCL_THREAD_JOINABLE) != TCL_OK) { Tcl_Panic("Tcl_InitNotifier: unable to start notifier thread"); } } notifierCount++; @@ -241,19 +245,19 @@ /* *---------------------------------------------------------------------- * * Tcl_FinalizeNotifier -- * - * This function is called to cleanup the notifier state before - * a thread is terminated. + * This function is called to cleanup the notifier state before a thread + * is terminated. * * Results: * None. * * Side effects: - * May terminate the background notifier thread if this is the - * last notifier instance. + * May terminate the background notifier thread if this is the last + * notifier instance. * *---------------------------------------------------------------------- */ void @@ -265,33 +269,40 @@ Tcl_MutexLock(¬ifierMutex); notifierCount--; /* - * If this is the last thread to use the notifier, close the notifier - * pipe and wait for the background thread to terminate. + * If this is the last thread to use the notifier, close the notifier pipe + * and wait for the background thread to terminate. */ if (notifierCount == 0) { + int result; if (triggerPipe < 0) { Tcl_Panic("Tcl_FinalizeNotifier: notifier pipe not initialized"); } - /* - * Send "q" message to the notifier thread so that it will - * terminate. The notifier will return from its call to select() - * and notice that a "q" message has arrived, it will then close - * its side of the pipe and terminate its thread. Note the we can - * not just close the pipe and check for EOF in the notifier - * thread because if a background child process was created with - * exec, select() would not register the EOF on the pipe until the - * child processes had terminated. [Bug: 4139] + /* + * Send "q" message to the notifier thread so that it will terminate. + * The notifier will return from its call to select() and notice that + * a "q" message has arrived, it will then close its side of the pipe + * and terminate its thread. Note the we can not just close the pipe + * and check for EOF in the notifier thread because if a background + * child process was created with exec, select() would not register + * the EOF on the pipe until the child processes had terminated. [Bug: + * 4139] [Bug: 1222872] */ + write(triggerPipe, "q", 1); close(triggerPipe); - - Tcl_ConditionWait(¬ifierCV, ¬ifierMutex, NULL); + while(triggerPipe >= 0) { + Tcl_ConditionWait(¬ifierCV, ¬ifierMutex, NULL); + } + result = Tcl_JoinThread(notifierThread, NULL); + if (result) { + Tcl_Panic("Tcl_FinalizeNotifier: unable to join notifier thread"); + } } /* * Clean up any synchronization objects in the thread local storage. */ @@ -305,22 +316,20 @@ /* *---------------------------------------------------------------------- * * Tcl_AlertNotifier -- * - * Wake up the specified notifier from any thread. This routine - * is called by the platform independent notifier code whenever - * the Tcl_ThreadAlert routine is called. This routine is - * guaranteed not to be called on a given notifier after - * Tcl_FinalizeNotifier is called for that notifier. + * Wake up the specified notifier from any thread. This routine is called + * by the platform independent notifier code whenever the Tcl_ThreadAlert + * routine is called. This routine is guaranteed not to be called on a + * given notifier after Tcl_FinalizeNotifier is called for that notifier. * * Results: * None. * * Side effects: - * Signals the notifier condition variable for the specified - * notifier. + * Signals the notifier condition variable for the specified notifier. * *---------------------------------------------------------------------- */ void @@ -339,13 +348,13 @@ /* *---------------------------------------------------------------------- * * Tcl_SetTimer -- * - * This procedure sets the current notifier timer value. This - * interface is not implemented in this notifier because we are - * always running inside of Tcl_DoOneEvent. + * This function sets the current notifier timer value. This interface is + * not implemented in this notifier because we are always running inside + * of Tcl_DoOneEvent. * * Results: * None. * * Side effects: @@ -357,13 +366,13 @@ void Tcl_SetTimer(timePtr) Tcl_Time *timePtr; /* Timeout value, may be NULL. */ { /* - * The interval timer doesn't do anything in this implementation, - * because the only event loop is via Tcl_DoOneEvent, which passes - * timeout values to Tcl_WaitForEvent. + * The interval timer doesn't do anything in this implementation, because + * the only event loop is via Tcl_DoOneEvent, which passes timeout values + * to Tcl_WaitForEvent. */ if (tclStubs.tcl_SetTimer != tclOriginalNotifier.setTimerProc) { tclStubs.tcl_SetTimer(timePtr); } @@ -395,11 +404,11 @@ /* *---------------------------------------------------------------------- * * Tcl_CreateFileHandler -- * - * This procedure registers a file handler with the select notifier. + * This function registers a file handler with the select notifier. * * Results: * None. * * Side effects: @@ -410,15 +419,15 @@ void Tcl_CreateFileHandler(fd, mask, proc, clientData) int fd; /* Handle of stream to watch. */ int mask; /* OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, and TCL_EXCEPTION: - * indicates conditions under which - * proc should be called. */ - Tcl_FileProc *proc; /* Procedure to call for each - * selected event. */ + * TCL_WRITABLE, and TCL_EXCEPTION: indicates + * conditions under which proc should be + * called. */ + Tcl_FileProc *proc; /* Function to call for each selected + * event. */ ClientData clientData; /* Arbitrary data to pass to proc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); FileHandler *filePtr; @@ -426,11 +435,11 @@ tclStubs.tcl_CreateFileHandler(fd, mask, proc, clientData); return; } for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL; - filePtr = filePtr->nextPtr) { + filePtr = filePtr->nextPtr) { if (filePtr->fd == fd) { break; } } if (filePtr == NULL) { @@ -446,24 +455,24 @@ /* * Update the check masks for this file. */ - if ( mask & TCL_READABLE ) { - FD_SET( fd, &(tsdPtr->checkMasks.readable) ); - } else { - FD_CLR( fd, &(tsdPtr->checkMasks.readable) ); - } - if ( mask & TCL_WRITABLE ) { - FD_SET( fd, &(tsdPtr->checkMasks.writable) ); - } else { - FD_CLR( fd, &(tsdPtr->checkMasks.writable) ); - } - if ( mask & TCL_EXCEPTION ) { - FD_SET( fd, &(tsdPtr->checkMasks.exceptional) ); - } else { - FD_CLR( fd, &(tsdPtr->checkMasks.exceptional) ); + if (mask & TCL_READABLE) { + FD_SET(fd, &(tsdPtr->checkMasks.readable)); + } else { + FD_CLR(fd, &(tsdPtr->checkMasks.readable)); + } + if (mask & TCL_WRITABLE) { + FD_SET(fd, &(tsdPtr->checkMasks.writable)); + } else { + FD_CLR(fd, &(tsdPtr->checkMasks.writable)); + } + if (mask & TCL_EXCEPTION) { + FD_SET(fd, &(tsdPtr->checkMasks.exceptional)); + } else { + FD_CLR(fd, &(tsdPtr->checkMasks.exceptional)); } if (tsdPtr->numFdBits <= fd) { tsdPtr->numFdBits = fd+1; } } @@ -471,12 +480,11 @@ /* *---------------------------------------------------------------------- * * Tcl_DeleteFileHandler -- * - * Cancel a previously-arranged callback arrangement for - * a file. + * Cancel a previously-arranged callback arrangement for a file. * * Results: * None. * * Side effects: @@ -485,11 +493,12 @@ *---------------------------------------------------------------------- */ void Tcl_DeleteFileHandler(fd) - int fd; /* Stream id for which to remove callback procedure. */ + int fd; /* Stream id for which to remove callback + * function. */ { FileHandler *filePtr, *prevPtr; int i; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -501,11 +510,11 @@ /* * Find the entry for the given file (and return if there isn't one). */ for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ; - prevPtr = filePtr, filePtr = filePtr->nextPtr) { + prevPtr = filePtr, filePtr = filePtr->nextPtr) { if (filePtr == NULL) { return; } if (filePtr->fd == fd) { break; @@ -515,29 +524,29 @@ /* * Update the check masks for this file. */ if (filePtr->mask & TCL_READABLE) { - FD_CLR( fd, &(tsdPtr->checkMasks.readable) ); + FD_CLR(fd, &(tsdPtr->checkMasks.readable)); } if (filePtr->mask & TCL_WRITABLE) { - FD_CLR( fd, &(tsdPtr->checkMasks.writable) ); + FD_CLR(fd, &(tsdPtr->checkMasks.writable)); } if (filePtr->mask & TCL_EXCEPTION) { - FD_CLR( fd, &(tsdPtr->checkMasks.exceptional) ); + FD_CLR(fd, &(tsdPtr->checkMasks.exceptional)); } /* * Find current max fd. */ if (fd+1 == tsdPtr->numFdBits) { tsdPtr->numFdBits = 0; for (i = fd-1; i >= 0; i--) { - if ( FD_ISSET( i, &(tsdPtr->checkMasks.readable) ) - || FD_ISSET( i, &(tsdPtr->checkMasks.writable) ) - || FD_ISSET( i, &(tsdPtr->checkMasks.exceptional ) ) ) { + if (FD_ISSET(i, &(tsdPtr->checkMasks.readable)) + || FD_ISSET(i, &(tsdPtr->checkMasks.writable)) + || FD_ISSET(i, &(tsdPtr->checkMasks.exceptional))) { tsdPtr->numFdBits = i+1; break; } } } @@ -557,32 +566,32 @@ /* *---------------------------------------------------------------------- * * FileHandlerEventProc -- * - * This procedure is called by Tcl_ServiceEvent when a file event - * reaches the front of the event queue. This procedure is - * responsible for actually handling the event by invoking the - * callback for the file handler. + * This function is called by Tcl_ServiceEvent when a file event reaches + * the front of the event queue. This function is responsible for + * actually handling the event by invoking the callback for the file + * handler. * * Results: - * Returns 1 if the event was handled, meaning it should be removed - * from the queue. Returns 0 if the event was not handled, meaning - * it should stay on the queue. The only time the event isn't - * handled is if the TCL_FILE_EVENTS flag bit isn't set. + * Returns 1 if the event was handled, meaning it should be removed from + * the queue. Returns 0 if the event was not handled, meaning it should + * stay on the queue. The only time the event isn't handled is if the + * TCL_FILE_EVENTS flag bit isn't set. * * Side effects: - * Whatever the file handler's callback procedure does. + * Whatever the file handler's callback function does. * *---------------------------------------------------------------------- */ static int FileHandlerEventProc(evPtr, flags) Tcl_Event *evPtr; /* Event to service. */ - int flags; /* Flags that indicate what events to - * handle, such as TCL_FILE_EVENTS. */ + int flags; /* Flags that indicate what events to handle, + * such as TCL_FILE_EVENTS. */ { int mask; FileHandler *filePtr; FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr; ThreadSpecificData *tsdPtr; @@ -591,32 +600,32 @@ return 0; } /* * Search through the file handlers to find the one whose handle matches - * the event. We do this rather than keeping a pointer to the file - * handler directly in the event, so that the handler can be deleted - * while the event is queued without leaving a dangling pointer. + * the event. We do this rather than keeping a pointer to the file handler + * directly in the event, so that the handler can be deleted while the + * event is queued without leaving a dangling pointer. */ tsdPtr = TCL_TSD_INIT(&dataKey); for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL; - filePtr = filePtr->nextPtr) { + filePtr = filePtr->nextPtr) { if (filePtr->fd != fileEvPtr->fd) { continue; } /* * The code is tricky for two reasons: - * 1. The file handler's desired events could have changed - * since the time when the event was queued, so AND the - * ready mask with the desired mask. - * 2. The file could have been closed and re-opened since - * the time when the event was queued. This is why the - * ready mask is stored in the file handler rather than - * the queued event: it will be zeroed when a new - * file handler is created for the newly opened file. + * 1. The file handler's desired events could have changed since the + * time when the event was queued, so AND the ready mask with the + * desired mask. + * 2. The file could have been closed and re-opened since the time + * when the event was queued. This is why the ready mask is stored + * in the file handler rather than the queued event: it will be + * zeroed when a new file handler is created for the newly opened + * file. */ mask = filePtr->readyMask & filePtr->mask; filePtr->readyMask = 0; if (mask != 0) { @@ -630,17 +639,16 @@ /* *---------------------------------------------------------------------- * * Tcl_WaitForEvent -- * - * This function is called by Tcl_DoOneEvent to wait for new - * events on the message queue. If the block time is 0, then - * Tcl_WaitForEvent just polls without blocking. + * This function is called by Tcl_DoOneEvent to wait for new events on + * the message queue. If the block time is 0, then Tcl_WaitForEvent just + * polls without blocking. * * Results: - * Returns -1 if the select would block forever, otherwise - * returns 0. + * Returns -1 if the select would block forever, otherwise returns 0. * * Side effects: * Queues file events that are detected by the select. * *---------------------------------------------------------------------- @@ -650,47 +658,76 @@ Tcl_WaitForEvent(timePtr) Tcl_Time *timePtr; /* Maximum block time, or NULL. */ { FileHandler *filePtr; FileHandlerEvent *fileEvPtr; - struct timeval timeout, *timeoutPtr; int mask; + Tcl_Time myTime; #ifdef TCL_THREADS int waitForFiles; + Tcl_Time *myTimePtr; #else + /* + * Impl. notes: timeout & timeoutPtr are used if, and only if threads are + * not enabled. They are the arguments for the regular select() used when + * the core is not thread-enabled. + */ + + struct timeval timeout, *timeoutPtr; int numFound; -#endif +#endif /* TCL_THREADS */ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tclStubs.tcl_WaitForEvent != tclOriginalNotifier.waitForEventProc) { return tclStubs.tcl_WaitForEvent(timePtr); } /* - * Set up the timeout structure. Note that if there are no events to - * check for, we return with a negative result rather than blocking - * forever. + * Set up the timeout structure. Note that if there are no events to check + * for, we return with a negative result rather than blocking forever. */ - if (timePtr) { - timeout.tv_sec = timePtr->sec; - timeout.tv_usec = timePtr->usec; + if (timePtr != NULL) { + /* + * TIP #233 (Virtualized Time). Is virtual time in effect? And do we + * actually have something to scale? If yes to both then we call the + * handler to do this scaling. + */ + + myTime.sec = timePtr->sec; + myTime.usec = timePtr->usec; + + if (myTime.sec != 0 || myTime.usec != 0) { + (*tclScaleTimeProcPtr) (&myTime, tclTimeClientData); + } + +#ifdef TCL_THREADS + myTimePtr = &myTime; +#else + timeout.tv_sec = myTime.sec; + timeout.tv_usec = myTime.usec; timeoutPtr = &timeout; +#endif /* TCL_THREADS */ + #ifndef TCL_THREADS } else if (tsdPtr->numFdBits == 0) { /* - * If there are no threads, no timeout, and no fds registered, - * then there are no events possible and we must avoid deadlock. - * Note that this is not entirely correct because there might - * be a signal that could interrupt the select call, but we - * don't handle that case if we aren't using threads. + * If there are no threads, no timeout, and no fds registered, then + * there are no events possible and we must avoid deadlock. Note that + * this is not entirely correct because there might be a signal that + * could interrupt the select call, but we don't handle that case if + * we aren't using threads. */ return -1; -#endif +#endif /* !TCL_THREADS */ } else { +#ifdef TCL_THREADS + myTimePtr = NULL; +#else timeoutPtr = NULL; +#endif /* TCL_THREADS */ } #ifdef TCL_THREADS /* * Place this thread on the list of interested threads, signal the @@ -698,135 +735,130 @@ */ Tcl_MutexLock(¬ifierMutex); waitForFiles = (tsdPtr->numFdBits > 0); - if (timePtr != NULL && timePtr->sec == 0 && timePtr->usec == 0) { + if (myTimePtr != NULL && myTimePtr->sec == 0 && myTimePtr->usec == 0) { /* * Cannot emulate a polling select with a polling condition variable. - * Instead, pretend to wait for files and tell the notifier - * thread what we are doing. The notifier thread makes sure - * it goes through select with its select mask in the same state - * as ours currently is. We block until that happens. + * Instead, pretend to wait for files and tell the notifier thread + * what we are doing. The notifier thread makes sure it goes through + * select with its select mask in the same state as ours currently is. + * We block until that happens. */ waitForFiles = 1; tsdPtr->pollState = POLL_WANT; - timePtr = NULL; + myTimePtr = NULL; } else { tsdPtr->pollState = 0; } if (waitForFiles) { - /* - * Add the ThreadSpecificData structure of this thread to the list - * of ThreadSpecificData structures of all threads that are waiting - * on file events. - */ - - - tsdPtr->nextPtr = waitingListPtr; - if (waitingListPtr) { - waitingListPtr->prevPtr = tsdPtr; - } - tsdPtr->prevPtr = 0; - waitingListPtr = tsdPtr; + /* + * Add the ThreadSpecificData structure of this thread to the list of + * ThreadSpecificData structures of all threads that are waiting on + * file events. + */ + + tsdPtr->nextPtr = waitingListPtr; + if (waitingListPtr) { + waitingListPtr->prevPtr = tsdPtr; + } + tsdPtr->prevPtr = 0; + waitingListPtr = tsdPtr; tsdPtr->onList = 1; - + write(triggerPipe, "", 1); } - FD_ZERO( &(tsdPtr->readyMasks.readable) ); - FD_ZERO( &(tsdPtr->readyMasks.writable) ); - FD_ZERO( &(tsdPtr->readyMasks.exceptional) ); + FD_ZERO(&(tsdPtr->readyMasks.readable)); + FD_ZERO(&(tsdPtr->readyMasks.writable)); + FD_ZERO(&(tsdPtr->readyMasks.exceptional)); if (!tsdPtr->eventReady) { - Tcl_ConditionWait(&tsdPtr->waitCV, ¬ifierMutex, timePtr); + Tcl_ConditionWait(&tsdPtr->waitCV, ¬ifierMutex, myTimePtr); } tsdPtr->eventReady = 0; if (waitForFiles && tsdPtr->onList) { /* * Remove the ThreadSpecificData structure of this thread from the - * waiting list. Alert the notifier thread to recompute its select + * waiting list. Alert the notifier thread to recompute its select * masks - skipping this caused a hang when trying to close a pipe * which the notifier thread was still doing a select on. */ - if (tsdPtr->prevPtr) { - tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; - } else { - waitingListPtr = tsdPtr->nextPtr; - } - if (tsdPtr->nextPtr) { - tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; - } - tsdPtr->nextPtr = tsdPtr->prevPtr = NULL; + if (tsdPtr->prevPtr) { + tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; + } else { + waitingListPtr = tsdPtr->nextPtr; + } + if (tsdPtr->nextPtr) { + tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; + } + tsdPtr->nextPtr = tsdPtr->prevPtr = NULL; tsdPtr->onList = 0; write(triggerPipe, "", 1); } - #else tsdPtr->readyMasks = tsdPtr->checkMasks; - numFound = select( tsdPtr->numFdBits, - &(tsdPtr->readyMasks.readable), - &(tsdPtr->readyMasks.writable), - &(tsdPtr->readyMasks.exceptional), - timeoutPtr ); + numFound = select(tsdPtr->numFdBits, &(tsdPtr->readyMasks.readable), + &(tsdPtr->readyMasks.writable), &(tsdPtr->readyMasks.exceptional), + timeoutPtr); /* - * Some systems don't clear the masks after an error, so - * we have to do it here. + * Some systems don't clear the masks after an error, so we have to do it + * here. */ if (numFound == -1) { - FD_ZERO( &(tsdPtr->readyMasks.readable ) ); - FD_ZERO( &(tsdPtr->readyMasks.writable ) ); - FD_ZERO( &(tsdPtr->readyMasks.exceptional ) ); + FD_ZERO(&(tsdPtr->readyMasks.readable)); + FD_ZERO(&(tsdPtr->readyMasks.writable)); + FD_ZERO(&(tsdPtr->readyMasks.exceptional)); } -#endif +#endif /* TCL_THREADS */ /* * Queue all detected file events before returning. */ for (filePtr = tsdPtr->firstFileHandlerPtr; (filePtr != NULL); - filePtr = filePtr->nextPtr) { + filePtr = filePtr->nextPtr) { mask = 0; - if ( FD_ISSET( filePtr->fd, &(tsdPtr->readyMasks.readable) ) ) { + if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.readable))) { mask |= TCL_READABLE; } - if ( FD_ISSET( filePtr->fd, &(tsdPtr->readyMasks.writable) ) ) { + if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.writable))) { mask |= TCL_WRITABLE; } - if ( FD_ISSET( filePtr->fd, &(tsdPtr->readyMasks.exceptional) ) ) { + if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.exceptional))) { mask |= TCL_EXCEPTION; } if (!mask) { continue; } /* - * Don't bother to queue an event if the mask was previously - * non-zero since an event must still be on the queue. + * Don't bother to queue an event if the mask was previously non-zero + * since an event must still be on the queue. */ if (filePtr->readyMask == 0) { - fileEvPtr = (FileHandlerEvent *) ckalloc( - sizeof(FileHandlerEvent)); + fileEvPtr = (FileHandlerEvent *) ckalloc(sizeof(FileHandlerEvent)); fileEvPtr->header.proc = FileHandlerEventProc; fileEvPtr->fd = filePtr->fd; Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); } filePtr->readyMask = mask; } #ifdef TCL_THREADS Tcl_MutexUnlock(¬ifierMutex); -#endif +#endif /* TCL_THREADS */ return 0; } #ifdef TCL_THREADS /* @@ -833,25 +865,24 @@ *---------------------------------------------------------------------- * * NotifierThreadProc -- * * This routine is the initial (and only) function executed by the - * special notifier thread. Its job is to wait for file descriptors - * to become readable or writable or to have an exception condition - * and then to notify other threads who are interested in this - * information by signalling a condition variable. Other threads - * can signal this notifier thread of a change in their interests - * by writing a single byte to a special pipe that the notifier - * thread is monitoring. + * special notifier thread. Its job is to wait for file descriptors to + * become readable or writable or to have an exception condition and then + * to notify other threads who are interested in this information by + * signalling a condition variable. Other threads can signal this + * notifier thread of a change in their interests by writing a single + * byte to a special pipe that the notifier thread is monitoring. * * Result: - * None. Once started, this routine never exits. It dies with - * the overall process. + * None. Once started, this routine never exits. It dies with the overall + * process. * * Side effects: - * The trigger pipe used to signal the notifier thread is created - * when the notifier thread first starts. + * The trigger pipe used to signal the notifier thread is created when + * the notifier thread first starts. * *---------------------------------------------------------------------- */ static void @@ -861,11 +892,11 @@ ThreadSpecificData *tsdPtr; fd_set readableMask; fd_set writableMask; fd_set exceptionalMask; int fds[2]; - int i, status, numFdBits, receivePipe; + int i, status, numFdBits = 0, receivePipe; long found; struct timeval poll = {0., 0.}, *timePtr; char buf[2]; if (pipe(fds) != 0) { @@ -890,11 +921,11 @@ Tcl_Panic("NotifierThreadProc: could not make receive pipe non blocking."); } if (ioctl(fds[1], (int) FIONBIO, &status) < 0) { Tcl_Panic("NotifierThreadProc: could not make trigger pipe non blocking."); } -#endif +#endif /* FIONBIO */ /* * Install the write end of the pipe into the global variable. */ @@ -911,41 +942,40 @@ /* * Look for file events and report them to interested threads. */ while (1) { - - FD_ZERO( &readableMask ); - FD_ZERO( &writableMask ); - FD_ZERO( &exceptionalMask ); + FD_ZERO(&readableMask); + FD_ZERO(&writableMask); + FD_ZERO(&exceptionalMask); /* - * Compute the logical OR of the select masks from all the - * waiting notifiers. + * Compute the logical OR of the select masks from all the waiting + * notifiers. */ Tcl_MutexLock(¬ifierMutex); timePtr = NULL; - for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) { - for ( i = tsdPtr->numFdBits-1; i >= 0; --i ) { - if ( FD_ISSET( i, &(tsdPtr->checkMasks.readable) ) ) { - FD_SET( i, &readableMask ); - } - if ( FD_ISSET( i, &(tsdPtr->checkMasks.writable) ) ) { - FD_SET( i, &writableMask ); - } - if ( FD_ISSET( i, &(tsdPtr->checkMasks.exceptional) ) ) { - FD_SET( i, &exceptionalMask ); + for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) { + for (i = tsdPtr->numFdBits-1; i >= 0; --i) { + if (FD_ISSET(i, &(tsdPtr->checkMasks.readable))) { + FD_SET(i, &readableMask); + } + if (FD_ISSET(i, &(tsdPtr->checkMasks.writable))) { + FD_SET(i, &writableMask); + } + if (FD_ISSET(i, &(tsdPtr->checkMasks.exceptional))) { + FD_SET(i, &exceptionalMask); } } - if ( tsdPtr->numFdBits > numFdBits ) { + if (tsdPtr->numFdBits > numFdBits) { numFdBits = tsdPtr->numFdBits; } if (tsdPtr->pollState & POLL_WANT) { /* - * Here we make sure we go through select() with the same - * mask bits that were present when the thread tried to poll. + * Here we make sure we go through select() with the same mask + * bits that were present when the thread tried to poll. */ tsdPtr->pollState |= POLL_DONE; timePtr = &poll; } @@ -954,60 +984,60 @@ /* * Set up the select mask to include the receive pipe. */ - if ( receivePipe >= numFdBits ) { + if (receivePipe >= numFdBits) { numFdBits = receivePipe + 1; } - FD_SET( receivePipe, &readableMask ); + FD_SET(receivePipe, &readableMask); - if ( select( numFdBits, &readableMask, &writableMask, - &exceptionalMask, timePtr) == -1 ) { + if (select(numFdBits, &readableMask, &writableMask, &exceptionalMask, + timePtr) == -1) { /* * Try again immediately on an error. */ continue; - } + } /* * Alert any threads that are waiting on a ready file descriptor. */ Tcl_MutexLock(¬ifierMutex); - for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) { - found = 0; - - for ( i = tsdPtr->numFdBits-1; i >= 0; --i ) { - if ( FD_ISSET( i, &(tsdPtr->checkMasks.readable) ) - && FD_ISSET( i, &readableMask ) ) { - FD_SET( i, &(tsdPtr->readyMasks.readable) ); - found = 1; - } - if ( FD_ISSET( i, &(tsdPtr->checkMasks.writable) ) - && FD_ISSET( i, &writableMask ) ) { - FD_SET( i, &(tsdPtr->readyMasks.writable) ); - found = 1; - } - if ( FD_ISSET( i, &(tsdPtr->checkMasks.exceptional) ) - && FD_ISSET( i, &exceptionalMask ) ) { - FD_SET( i, &(tsdPtr->readyMasks.exceptional) ); - found = 1; - } - } - - if (found || (tsdPtr->pollState & POLL_DONE)) { - tsdPtr->eventReady = 1; - if (tsdPtr->onList) { - /* - * Remove the ThreadSpecificData structure of this - * thread from the waiting list. This prevents us from - * continuously spining on select until the other - * threads runs and services the file event. - */ - + for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) { + found = 0; + + for (i = tsdPtr->numFdBits-1; i >= 0; --i) { + if (FD_ISSET(i, &(tsdPtr->checkMasks.readable)) + && FD_ISSET(i, &readableMask)) { + FD_SET(i, &(tsdPtr->readyMasks.readable)); + found = 1; + } + if (FD_ISSET(i, &(tsdPtr->checkMasks.writable)) + && FD_ISSET(i, &writableMask)) { + FD_SET(i, &(tsdPtr->readyMasks.writable)); + found = 1; + } + if (FD_ISSET(i, &(tsdPtr->checkMasks.exceptional)) + && FD_ISSET(i, &exceptionalMask)) { + FD_SET(i, &(tsdPtr->readyMasks.exceptional)); + found = 1; + } + } + + if (found || (tsdPtr->pollState & POLL_DONE)) { + tsdPtr->eventReady = 1; + if (tsdPtr->onList) { + /* + * Remove the ThreadSpecificData structure of this thread + * from the waiting list. This prevents us from + * continuously spining on select until the other threads + * runs and services the file event. + */ + if (tsdPtr->prevPtr) { tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; } else { waitingListPtr = tsdPtr->nextPtr; } @@ -1017,28 +1047,28 @@ tsdPtr->nextPtr = tsdPtr->prevPtr = NULL; tsdPtr->onList = 0; tsdPtr->pollState = 0; } Tcl_ConditionNotify(&tsdPtr->waitCV); - } - } + } + } Tcl_MutexUnlock(¬ifierMutex); - + /* * Consume the next byte from the notifier pipe if the pipe was - * readable. Note that there may be multiple bytes pending, but - * to avoid a race condition we only read one at a time. + * readable. Note that there may be multiple bytes pending, but to + * avoid a race condition we only read one at a time. */ - if ( FD_ISSET( receivePipe, &readableMask ) ) { + if (FD_ISSET(receivePipe, &readableMask)) { i = read(receivePipe, buf, 1); if ((i == 0) || ((i == 1) && (buf[0] == 'q'))) { /* - * Someone closed the write end of the pipe or sent us a - * Quit message [Bug: 4139] and then closed the write end - * of the pipe so we need to shut down the notifier thread. + * Someone closed the write end of the pipe or sent us a Quit + * message [Bug: 4139] and then closed the write end of the + * pipe so we need to shut down the notifier thread. */ break; } } @@ -1055,6 +1085,16 @@ Tcl_ConditionNotify(¬ifierCV); Tcl_MutexUnlock(¬ifierMutex); TclpThreadExit (0); } -#endif +#endif /* TCL_THREADS */ + +#endif /* HAVE_COREFOUNDATION */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: unix/tclUnixPipe.c ================================================================== --- unix/tclUnixPipe.c +++ unix/tclUnixPipe.c @@ -1,28 +1,28 @@ -/* +/* * tclUnixPipe.c -- * - * This file implements the UNIX-specific exec pipeline functions, - * the "pipe" channel driver, and the "pid" Tcl command. + * This file implements the UNIX-specific exec pipeline functions, the + * "pipe" channel driver, and the "pid" Tcl command. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixPipe.c,v 1.26 2004/10/06 16:08:57 dgp Exp $ + * RCS: @(#) $Id: tclUnixPipe.c,v 1.26.2.3 2005/08/02 18:16:57 dgp Exp $ */ #include "tclInt.h" #ifdef USE_VFORK #define fork vfork #endif /* - * The following macros convert between TclFile's and fd's. The conversion + * The following macros convert between TclFile's and fd's. The conversion * simple involves shifting fd's up by one to ensure that no valid fd is ever * the same as NULL. */ #define MakeFile(fd) ((TclFile)(((int)fd)+1)) @@ -31,20 +31,21 @@ /* * This structure describes per-instance state of a pipe based channel. */ typedef struct PipeState { - Tcl_Channel channel;/* Channel associated with this file. */ - TclFile inFile; /* Output from pipe. */ - TclFile outFile; /* Input to pipe. */ - TclFile errorFile; /* Error output from pipe. */ - int numPids; /* How many processes are attached to this pipe? */ - Tcl_Pid *pidPtr; /* The process IDs themselves. Allocated by - * the creator of the pipe. */ - int isNonBlocking; /* Nonzero when the pipe is in nonblocking mode. - * Used to decide whether to wait for the children - * at close time. */ + Tcl_Channel channel; /* Channel associated with this file. */ + TclFile inFile; /* Output from pipe. */ + TclFile outFile; /* Input to pipe. */ + TclFile errorFile; /* Error output from pipe. */ + int numPids; /* How many processes are attached to this + * pipe? */ + Tcl_Pid *pidPtr; /* The process IDs themselves. Allocated by + * the creator of the pipe. */ + int isNonBlocking; /* Nonzero when the pipe is in nonblocking + * mode. Used to decide whether to wait for + * the children at close time. */ } PipeState; /* * Declarations for local procedures defined in this file: */ @@ -63,17 +64,17 @@ static void PipeWatchProc _ANSI_ARGS_((ClientData instanceData, int mask)); static void RestoreSignals _ANSI_ARGS_((void)); static int SetupStdFile _ANSI_ARGS_((TclFile file, int type)); /* - * This structure describes the channel type structure for command pipe - * based IO: + * This structure describes the channel type structure for command pipe based + * I/O: */ static Tcl_ChannelType pipeChannelType = { "pipe", /* Type name. */ - TCL_CHANNEL_VERSION_2, /* v2 channel */ + TCL_CHANNEL_VERSION_4, /* v4 channel */ PipeCloseProc, /* Close proc. */ PipeInputProc, /* Input proc. */ PipeOutputProc, /* Output proc. */ NULL, /* Seek proc. */ NULL, /* Set option proc. */ @@ -82,10 +83,12 @@ PipeGetHandleProc, /* Get OS handles out of channel. */ NULL, /* close2proc. */ PipeBlockModeProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ + NULL, /* wide seek proc */ + NULL, /* thread action proc */ }; /* *---------------------------------------------------------------------- * @@ -107,13 +110,13 @@ Tcl_Channel channel; /* Channel to get file from. */ int direction; /* Either TCL_READABLE or TCL_WRITABLE. */ { ClientData data; - if (Tcl_GetChannelHandle(channel, direction, (ClientData *) &data) - == TCL_OK) { - return MakeFile((int)data); + if (Tcl_GetChannelHandle(channel, direction, + (ClientData *) &data) == TCL_OK) { + return MakeFile((int) data); } else { return (TclFile) NULL; } } @@ -120,11 +123,11 @@ /* *---------------------------------------------------------------------- * * TclpOpenFile -- * - * Open a file for use in a pipeline. + * Open a file for use in a pipeline. * * Results: * Returns a new TclFile handle or NULL on failure. * * Side effects: @@ -144,24 +147,24 @@ native = Tcl_UtfToExternalDString(NULL, fname, -1, &ds); fd = TclOSopen(native, mode, 0666); /* INTL: Native. */ Tcl_DStringFree(&ds); if (fd != -1) { - fcntl(fd, F_SETFD, FD_CLOEXEC); + fcntl(fd, F_SETFD, FD_CLOEXEC); /* - * If the file is being opened for writing, seek to the end - * so we can append to any data already in the file. + * If the file is being opened for writing, seek to the end so we can + * append to any data already in the file. */ - if (mode & O_WRONLY) { + if ((mode & O_WRONLY) && !(mode & O_APPEND)) { TclOSseek(fd, (Tcl_SeekOffset) 0, SEEK_END); } /* - * Increment the fd so it can't be 0, which would conflict with - * the NULL return for errors. + * Increment the fd so it can't be 0, which would conflict with the + * NULL return for errors. */ return MakeFile(fd); } return NULL; @@ -170,13 +173,13 @@ /* *---------------------------------------------------------------------- * * TclpCreateTempFile -- * - * This function creates a temporary file initialized with an - * optional string, and returns a file handle with the file pointer - * at the beginning of the file. + * This function creates a temporary file initialized with an optional + * string, and returns a file handle with the file pointer at the + * beginning of the file. * * Results: * A handle to a file. * * Side effects: @@ -237,11 +240,11 @@ * None. * *---------------------------------------------------------------------- */ -Tcl_Obj* +Tcl_Obj * TclpTempFileName() { char fileName[L_tmpnam + 9]; Tcl_Obj *result = NULL; int fd; @@ -261,36 +264,36 @@ } fcntl(fd, F_SETFD, FD_CLOEXEC); unlink(fileName); /* INTL: Native. */ result = TclpNativeToNormalized((ClientData) fileName); - close (fd); + close(fd); return result; } /* *---------------------------------------------------------------------- * * TclpCreatePipe -- * - * Creates a pipe - simply calls the pipe() function. + * Creates a pipe - simply calls the pipe() function. * * Results: - * Returns 1 on success, 0 on failure. + * Returns 1 on success, 0 on failure. * * Side effects: - * Creates a pipe. + * Creates a pipe. * *---------------------------------------------------------------------- */ int TclpCreatePipe(readPipe, writePipe) - TclFile *readPipe; /* Location to store file handle for - * read side of pipe. */ - TclFile *writePipe; /* Location to store file handle for - * write side of pipe. */ + TclFile *readPipe; /* Location to store file handle for read side + * of pipe. */ + TclFile *writePipe; /* Location to store file handle for write + * side of pipe. */ { int pipeIds[2]; if (pipe(pipeIds) != 0) { return 0; @@ -327,101 +330,101 @@ int fd = GetFd(file); /* * Refuse to close the fds for stdin, stdout and stderr. */ - + if ((fd == 0) || (fd == 1) || (fd == 2)) { - return 0; + return 0; } - + Tcl_DeleteFileHandler(fd); return close(fd); } /* *--------------------------------------------------------------------------- * * TclpCreateProcess -- * - * Create a child process that has the specified files as its - * standard input, output, and error. The child process runs - * asynchronously and runs with the same environment variables - * as the creating process. + * Create a child process that has the specified files as its standard + * input, output, and error. The child process runs asynchronously and + * runs with the same environment variables as the creating process. * - * The path is searched to find the specified executable. + * The path is searched to find the specified executable. * * Results: - * The return value is TCL_ERROR and an error message is left in - * the interp's result if there was a problem creating the child - * process. Otherwise, the return value is TCL_OK and *pidPtr is - * filled with the process id of the child process. - * + * The return value is TCL_ERROR and an error message is left in the + * interp's result if there was a problem creating the child process. + * Otherwise, the return value is TCL_OK and *pidPtr is filled with the + * process id of the child process. + * * Side effects: * A process is created. - * + * *--------------------------------------------------------------------------- */ /* ARGSUSED */ int -TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile, +TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile, pidPtr) Tcl_Interp *interp; /* Interpreter in which to leave errors that * occurred when creating the child process. * Error messages from the child process * itself are sent to errorFile. */ int argc; /* Number of arguments in following array. */ CONST char **argv; /* Array of argument strings in UTF-8. * argv[0] contains the name of the executable * translated using Tcl_TranslateFileName - * call). Additional arguments have not been + * call). Additional arguments have not been * converted. */ - TclFile inputFile; /* If non-NULL, gives the file to use as - * input for the child process. If inputFile - * file is not readable or is NULL, the child - * will receive no standard input. */ - TclFile outputFile; /* If non-NULL, gives the file that - * receives output from the child process. If + TclFile inputFile; /* If non-NULL, gives the file to use as input + * for the child process. If inputFile file is + * not readable or is NULL, the child will + * receive no standard input. */ + TclFile outputFile; /* If non-NULL, gives the file that receives + * output from the child process. If * outputFile file is not writeable or is * NULL, output from the child will be * discarded. */ - TclFile errorFile; /* If non-NULL, gives the file that - * receives errors from the child process. If - * errorFile file is not writeable or is NULL, - * errors from the child will be discarded. - * errorFile may be the same as outputFile. */ - Tcl_Pid *pidPtr; /* If this procedure is successful, pidPtr - * is filled with the process id of the child + TclFile errorFile; /* If non-NULL, gives the file that receives + * errors from the child process. If errorFile + * file is not writeable or is NULL, errors + * from the child will be discarded. errorFile + * may be the same as outputFile. */ + Tcl_Pid *pidPtr; /* If this procedure is successful, pidPtr is + * filled with the process id of the child * process. */ { TclFile errPipeIn, errPipeOut; int joinThisError, count, status, fd; char errSpace[200 + TCL_INTEGER_SPACE]; Tcl_DString *dsArray; char **newArgv; int pid, i; - + errPipeIn = NULL; errPipeOut = NULL; pid = -1; /* - * Create a pipe that the child can use to return error - * information if anything goes wrong. + * Create a pipe that the child can use to return error information if + * anything goes wrong. */ if (TclpCreatePipe(&errPipeIn, &errPipeOut) == 0) { Tcl_AppendResult(interp, "couldn't create pipe: ", Tcl_PosixError(interp), (char *) NULL); goto error; } /* - * We need to allocate and convert this before the fork - * so it is properly deallocated later + * We need to allocate and convert this before the fork so it is properly + * deallocated later */ + dsArray = (Tcl_DString *) ckalloc(argc * sizeof(Tcl_DString)); newArgv = (char **) ckalloc((argc+1) * sizeof(char *)); newArgv[argc] = NULL; for (i = 0; i < argc; i++) { newArgv[i] = Tcl_UtfToExternalDString(NULL, argv[i], -1, &dsArray[i]); @@ -438,12 +441,11 @@ if (!SetupStdFile(inputFile, TCL_STDIN) || !SetupStdFile(outputFile, TCL_STDOUT) || (!joinThisError && !SetupStdFile(errorFile, TCL_STDERR)) || (joinThisError && - ((dup2(1,2) == -1) || - (fcntl(2, F_SETFD, 0) != 0)))) { + ((dup2(1,2) == -1) || (fcntl(2, F_SETFD, 0) != 0)))) { sprintf(errSpace, "%dforked process couldn't set up input/output: ", errno); write(fd, errSpace, (size_t) strlen(errSpace)); _exit(1); } @@ -456,14 +458,15 @@ execvp(newArgv[0], newArgv); /* INTL: Native. */ sprintf(errSpace, "%dcouldn't execute \"%.150s\": ", errno, argv[0]); write(fd, errSpace, (size_t) strlen(errSpace)); _exit(1); } - + /* * Free the mem we used for the fork */ + for (i = 0; i < argc; i++) { Tcl_DStringFree(&dsArray[i]); } ckfree((char *) dsArray); ckfree((char *) newArgv); @@ -473,13 +476,13 @@ Tcl_PosixError(interp), (char *) NULL); goto error; } /* - * Read back from the error pipe to see if the child started - * up OK. The info in the pipe (if any) consists of a decimal - * errno value followed by an error message. + * Read back from the error pipe to see if the child started up OK. The + * info in the pipe (if any) consists of a decimal errno value followed by + * an error message. */ TclpCloseFile(errPipeOut); errPipeOut = NULL; @@ -491,27 +494,27 @@ errno = strtol(errSpace, &end, 10); Tcl_AppendResult(interp, end, Tcl_PosixError(interp), (char *) NULL); goto error; } - + TclpCloseFile(errPipeIn); *pidPtr = (Tcl_Pid) pid; return TCL_OK; - error: + error: if (pid != -1) { /* - * Reap the child process now if an error occurred during its - * startup. We don't call this with WNOHANG because that can lead to - * defunct processes on an MP system. We shouldn't have to worry - * about hanging here, since this is the error case. [Bug: 6148] + * Reap the child process now if an error occurred during its startup. + * We don't call this with WNOHANG because that can lead to defunct + * processes on an MP system. We shouldn't have to worry about hanging + * here, since this is the error case. [Bug: 6148] */ Tcl_WaitPid((Tcl_Pid) pid, &status, 0); } - + if (errPipeIn) { TclpCloseFile(errPipeIn); } if (errPipeOut) { TclpCloseFile(errPipeOut); @@ -522,23 +525,23 @@ /* *---------------------------------------------------------------------- * * RestoreSignals -- * - * This procedure is invoked in a forked child process just before - * exec-ing a new program to restore all signals to their default - * settings. + * This procedure is invoked in a forked child process just before + * exec-ing a new program to restore all signals to their default + * settings. * * Results: - * None. + * None. * * Side effects: - * Signal settings get changed. + * Signal settings get changed. * *---------------------------------------------------------------------- */ - + static void RestoreSignals() { #ifdef SIGABRT signal(SIGABRT, SIG_DFL); @@ -596,14 +599,14 @@ /* *---------------------------------------------------------------------- * * SetupStdFile -- * - * Set up stdio file handles for the child process, using the - * current standard channels if no other files are specified. - * If no standard channel is defined, or if no file is associated - * with the channel, then the corresponding standard fd is closed. + * Set up stdio file handles for the child process, using the current + * standard channels if no other files are specified. If no standard + * channel is defined, or if no file is associated with the channel, then + * the corresponding standard fd is closed. * * Results: * Returns 1 on success, or 0 on failure. * * Side effects: @@ -622,22 +625,22 @@ int targetFd = 0; /* Initializations here needed only to */ int direction = 0; /* prevent warnings about using uninitialized * variables. */ switch (type) { - case TCL_STDIN: - targetFd = 0; - direction = TCL_READABLE; - break; - case TCL_STDOUT: - targetFd = 1; - direction = TCL_WRITABLE; - break; - case TCL_STDERR: - targetFd = 2; - direction = TCL_WRITABLE; - break; + case TCL_STDIN: + targetFd = 0; + direction = TCL_READABLE; + break; + case TCL_STDOUT: + targetFd = 1; + direction = TCL_WRITABLE; + break; + case TCL_STDERR: + targetFd = 2; + direction = TCL_WRITABLE; + break; } if (!file) { channel = Tcl_GetStdChannel(type); if (channel) { @@ -649,17 +652,17 @@ if (fd != targetFd) { if (dup2(fd, targetFd) == -1) { return 0; } - /* - * Must clear the close-on-exec flag for the target FD, since - * some systems (e.g. Ultrix) do not clear the CLOEXEC flag on - * the target FD. - */ - - fcntl(targetFd, F_SETFD, 0); + /* + * Must clear the close-on-exec flag for the target FD, since some + * systems (e.g. Ultrix) do not clear the CLOEXEC flag on the + * target FD. + */ + + fcntl(targetFd, F_SETFD, 0); } else { /* * Since we aren't dup'ing the file, we need to explicitly clear * the close-on-exec flag. */ @@ -675,13 +678,12 @@ /* *---------------------------------------------------------------------- * * TclpCreateCommandChannel -- * - * This function is called by the generic IO level to perform - * the platform specific channel initialization for a command - * channel. + * This function is called by the generic IO level to perform the + * platform specific channel initialization for a command channel. * * Results: * Returns a new channel or NULL on failure. * * Side effects: @@ -695,14 +697,14 @@ TclFile readFile; /* If non-null, gives the file for reading. */ TclFile writeFile; /* If non-null, gives the file for writing. */ TclFile errorFile; /* If non-null, gives the file where errors * can be read. */ int numPids; /* The number of pids in the pid array. */ - Tcl_Pid *pidPtr; /* An array of process identifiers. - * Allocated by the caller, freed when - * the channel is closed or the processes - * are detached (in a background exec). */ + Tcl_Pid *pidPtr; /* An array of process identifiers. Allocated + * by the caller, freed when the channel is + * closed or the processes are detached (in a + * background exec). */ { char channelName[16 + TCL_INTEGER_SPACE]; int channelId; PipeState *statePtr = (PipeState *) ckalloc((unsigned) sizeof(PipeState)); int mode; @@ -714,19 +716,18 @@ statePtr->pidPtr = pidPtr; statePtr->isNonBlocking = 0; mode = 0; if (readFile) { - mode |= TCL_READABLE; + mode |= TCL_READABLE; } if (writeFile) { - mode |= TCL_WRITABLE; + mode |= TCL_WRITABLE; } - + /* - * Use one of the fds associated with the channel as the - * channel id. + * Use one of the fds associated with the channel as the channel id. */ if (readFile) { channelId = GetFd(readFile); } else if (writeFile) { @@ -736,30 +737,30 @@ } else { channelId = 0; } /* - * For backward compatibility with previous versions of Tcl, we - * use "file%d" as the base name for pipes even though it would - * be more natural to use "pipe%d". + * For backward compatibility with previous versions of Tcl, we use + * "file%d" as the base name for pipes even though it would be more + * natural to use "pipe%d". */ sprintf(channelName, "file%d", channelId); statePtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName, - (ClientData) statePtr, mode); + (ClientData) statePtr, mode); return statePtr->channel; } /* *---------------------------------------------------------------------- * * TclGetAndDetachPids -- * * This procedure is invoked in the generic implementation of a - * background "exec" (An exec when invoked with a terminating "&") - * to store a list of the PIDs for processes in a command pipeline - * in the interp's result and to detach the processes. + * background "exec" (an exec when invoked with a terminating "&") to + * store a list of the PIDs for processes in a command pipeline in the + * interp's result and to detach the processes. * * Results: * None. * * Side effects: @@ -768,12 +769,12 @@ *---------------------------------------------------------------------- */ void TclGetAndDetachPids(interp, chan) - Tcl_Interp *interp; - Tcl_Channel chan; + Tcl_Interp *interp; /* Interpreter to append the PIDs to. */ + Tcl_Channel chan; /* Handle for the pipeline. */ { PipeState *pipePtr; Tcl_ChannelType *chanTypePtr; int i; char buf[TCL_INTEGER_SPACE]; @@ -782,32 +783,32 @@ * Punt if the channel is not a command channel. */ chanTypePtr = Tcl_GetChannelType(chan); if (chanTypePtr != &pipeChannelType) { - return; + return; } pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan); for (i = 0; i < pipePtr->numPids; i++) { - TclFormatInt(buf, (long) TclpGetPid(pipePtr->pidPtr[i])); - Tcl_AppendElement(interp, buf); - Tcl_DetachPids(1, &(pipePtr->pidPtr[i])); + TclFormatInt(buf, (long) TclpGetPid(pipePtr->pidPtr[i])); + Tcl_AppendElement(interp, buf); + Tcl_DetachPids(1, &(pipePtr->pidPtr[i])); } if (pipePtr->numPids > 0) { - ckfree((char *) pipePtr->pidPtr); - pipePtr->numPids = 0; + ckfree((char *) pipePtr->pidPtr); + pipePtr->numPids = 0; } } /* *---------------------------------------------------------------------- * * PipeBlockModeProc -- * - * Helper procedure to set blocking and nonblocking modes on a - * pipe based channel. Invoked by generic IO level code. + * Helper procedure to set blocking and nonblocking modes on a pipe based + * channel. Invoked by generic IO level code. * * Results: * 0 if successful, errno when failed. * * Side effects: @@ -817,68 +818,68 @@ */ /* ARGSUSED */ static int PipeBlockModeProc(instanceData, mode) - ClientData instanceData; /* Pipe state. */ - int mode; /* The mode to set. Can be one of - * TCL_MODE_BLOCKING or - * TCL_MODE_NONBLOCKING. */ + ClientData instanceData; /* Pipe state. */ + int mode; /* The mode to set. Can be one of + * TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ { PipeState *psPtr = (PipeState *) instanceData; int curStatus; int fd; -#ifndef USE_FIONBIO +#ifndef USE_FIONBIO if (psPtr->inFile) { - fd = GetFd(psPtr->inFile); - curStatus = fcntl(fd, F_GETFL); - if (mode == TCL_MODE_BLOCKING) { - curStatus &= (~(O_NONBLOCK)); - } else { - curStatus |= O_NONBLOCK; - } - if (fcntl(fd, F_SETFL, curStatus) < 0) { - return errno; - } + fd = GetFd(psPtr->inFile); + curStatus = fcntl(fd, F_GETFL); + if (mode == TCL_MODE_BLOCKING) { + curStatus &= (~(O_NONBLOCK)); + } else { + curStatus |= O_NONBLOCK; + } + if (fcntl(fd, F_SETFL, curStatus) < 0) { + return errno; + } } if (psPtr->outFile) { - fd = GetFd(psPtr->outFile); - curStatus = fcntl(fd, F_GETFL); - if (mode == TCL_MODE_BLOCKING) { - curStatus &= (~(O_NONBLOCK)); - } else { - curStatus |= O_NONBLOCK; - } - if (fcntl(fd, F_SETFL, curStatus) < 0) { - return errno; - } + fd = GetFd(psPtr->outFile); + curStatus = fcntl(fd, F_GETFL); + if (mode == TCL_MODE_BLOCKING) { + curStatus &= (~(O_NONBLOCK)); + } else { + curStatus |= O_NONBLOCK; + } + if (fcntl(fd, F_SETFL, curStatus) < 0) { + return errno; + } } #endif /* !FIONBIO */ #ifdef USE_FIONBIO if (psPtr->inFile) { - fd = GetFd(psPtr->inFile); - if (mode == TCL_MODE_BLOCKING) { - curStatus = 0; - } else { - curStatus = 1; - } - if (ioctl(fd, (int) FIONBIO, &curStatus) < 0) { - return errno; - } + fd = GetFd(psPtr->inFile); + if (mode == TCL_MODE_BLOCKING) { + curStatus = 0; + } else { + curStatus = 1; + } + if (ioctl(fd, (int) FIONBIO, &curStatus) < 0) { + return errno; + } } if (psPtr->outFile != NULL) { - fd = GetFd(psPtr->outFile); - if (mode == TCL_MODE_BLOCKING) { - curStatus = 0; - } else { - curStatus = 1; - } - if (ioctl(fd, (int) FIONBIO, &curStatus) < 0) { - return errno; - } + fd = GetFd(psPtr->outFile); + if (mode == TCL_MODE_BLOCKING) { + curStatus = 0; + } else { + curStatus = 1; + } + if (ioctl(fd, (int) FIONBIO, &curStatus) < 0) { + return errno; + } } #endif /* USE_FIONBIO */ psPtr->isNonBlocking = (mode == TCL_MODE_NONBLOCKING); @@ -889,12 +890,12 @@ *---------------------------------------------------------------------- * * PipeCloseProc -- * * This procedure is invoked by the generic IO level to perform - * channel-type-specific cleanup when a command pipeline channel - * is closed. + * channel-type-specific cleanup when a command pipeline channel is + * closed. * * Results: * 0 on success, errno otherwise. * * Side effects: @@ -926,57 +927,55 @@ errorCode = errno; } } if (pipePtr->isNonBlocking || TclInExit()) { - /* - * If the channel is non-blocking or Tcl is being cleaned up, just - * detach the children PIDs, reap them (important if we are in a - * dynamic load module), and discard the errorFile. - */ - - Tcl_DetachPids(pipePtr->numPids, pipePtr->pidPtr); - Tcl_ReapDetachedProcs(); - - if (pipePtr->errorFile) { + * If the channel is non-blocking or Tcl is being cleaned up, just + * detach the children PIDs, reap them (important if we are in a + * dynamic load module), and discard the errorFile. + */ + + Tcl_DetachPids(pipePtr->numPids, pipePtr->pidPtr); + Tcl_ReapDetachedProcs(); + + if (pipePtr->errorFile) { TclpCloseFile(pipePtr->errorFile); - } + } } else { - /* - * Wrap the error file into a channel and give it to the cleanup - * routine. - */ + * Wrap the error file into a channel and give it to the cleanup + * routine. + */ - if (pipePtr->errorFile) { + if (pipePtr->errorFile) { errChan = Tcl_MakeFileChannel( (ClientData) GetFd(pipePtr->errorFile), TCL_READABLE); - } else { - errChan = NULL; - } - result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr, - errChan); + } else { + errChan = NULL; + } + result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr, + errChan); } if (pipePtr->numPids != 0) { - ckfree((char *) pipePtr->pidPtr); + ckfree((char *) pipePtr->pidPtr); } ckfree((char *) pipePtr); if (errorCode == 0) { - return result; + return result; } return errorCode; } /* *---------------------------------------------------------------------- * * PipeInputProc -- * - * This procedure is invoked from the generic IO level to read - * input from a command pipeline based channel. + * This procedure is invoked from the generic IO level to read input from + * a command pipeline based channel. * * Results: * The number of bytes read is returned or -1 on error. An output * argument contains a POSIX error code if an error occurs, or zero. * @@ -986,33 +985,32 @@ *---------------------------------------------------------------------- */ static int PipeInputProc(instanceData, buf, toRead, errorCodePtr) - ClientData instanceData; /* Pipe state. */ - char *buf; /* Where to store data read. */ - int toRead; /* How much space is available - * in the buffer? */ - int *errorCodePtr; /* Where to store error code. */ + ClientData instanceData; /* Pipe state. */ + char *buf; /* Where to store data read. */ + int toRead; /* How much space is available in the + * buffer? */ + int *errorCodePtr; /* Where to store error code. */ { PipeState *psPtr = (PipeState *) instanceData; - int bytesRead; /* How many bytes were actually - * read from the input device? */ + int bytesRead; /* How many bytes were actually read from the + * input device? */ *errorCodePtr = 0; - + /* * Assume there is always enough input available. This will block * appropriately, and read will unblock as soon as a short read is * possible, if the channel is in blocking mode. If the channel is - * nonblocking, the read will never block. - * Some OSes can throw an interrupt error, for which we should - * immediately retry. [Bug #415131] + * nonblocking, the read will never block. Some OSes can throw an + * interrupt error, for which we should immediately retry. [Bug #415131] */ do { - bytesRead = read (GetFd(psPtr->inFile), buf, (size_t) toRead); + bytesRead = read(GetFd(psPtr->inFile), buf, (size_t) toRead); } while ((bytesRead < 0) && (errno == EINTR)); if (bytesRead < 0) { *errorCodePtr = errno; return -1; @@ -1024,39 +1022,38 @@ /* *---------------------------------------------------------------------- * * PipeOutputProc-- * - * This procedure is invoked from the generic IO level to write - * output to a command pipeline based channel. + * This procedure is invoked from the generic IO level to write output to + * a command pipeline based channel. * * Results: - * The number of bytes written is returned or -1 on error. An - * output argument contains a POSIX error code if an error occurred, - * or zero. + * The number of bytes written is returned or -1 on error. An output + * argument contains a POSIX error code if an error occurred, or zero. * * Side effects: * Writes output on the output device of the channel. * *---------------------------------------------------------------------- */ static int PipeOutputProc(instanceData, buf, toWrite, errorCodePtr) - ClientData instanceData; /* Pipe state. */ - CONST char *buf; /* The data buffer. */ - int toWrite; /* How many bytes to write? */ - int *errorCodePtr; /* Where to store error code. */ + ClientData instanceData; /* Pipe state. */ + CONST char *buf; /* The data buffer. */ + int toWrite; /* How many bytes to write? */ + int *errorCodePtr; /* Where to store error code. */ { PipeState *psPtr = (PipeState *) instanceData; int written; *errorCodePtr = 0; /* - * Some OSes can throw an interrupt error, for which we should - * immediately retry. [Bug #415131] + * Some OSes can throw an interrupt error, for which we should immediately + * retry. [Bug #415131] */ do { written = write(GetFd(psPtr->outFile), buf, (size_t) toWrite); } while ((written < 0) && (errno == EINTR)); @@ -1078,22 +1075,22 @@ * * Results: * None. * * Side effects: - * Sets up the notifier so that a future event on the channel will - * be seen by Tcl. + * Sets up the notifier so that a future event on the channel will be + * seen by Tcl. * *---------------------------------------------------------------------- */ static void PipeWatchProc(instanceData, mask) - ClientData instanceData; /* The pipe state. */ - int mask; /* Events of interest; an OR-ed - * combination of TCL_READABLE, - * TCL_WRITABEL and TCL_EXCEPTION. */ + ClientData instanceData; /* The pipe state. */ + int mask; /* Events of interest; an OR-ed combination of + * TCL_READABLE, TCL_WRITABLE and + * TCL_EXCEPTION. */ { PipeState *psPtr = (PipeState *) instanceData; int newmask; if (psPtr->inFile) { @@ -1121,16 +1118,16 @@ /* *---------------------------------------------------------------------- * * PipeGetHandleProc -- * - * Called from Tcl_GetChannelHandle to retrieve OS handles from - * inside a command pipeline based channel. + * Called from Tcl_GetChannelHandle to retrieve OS handles from inside a + * command pipeline based channel. * * Results: - * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if - * there is no handle for the specified direction. + * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no + * handle for the specified direction. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -1192,12 +1189,12 @@ /* *---------------------------------------------------------------------- * * Tcl_PidObjCmd -- * - * This procedure is invoked to process the "pid" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "pid" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -1212,36 +1209,65 @@ ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST *objv; /* Argument strings. */ { - Tcl_Channel chan; - Tcl_ChannelType *chanTypePtr; - PipeState *pipePtr; - int i; - Tcl_Obj *resultPtr, *longObjPtr; - if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?channelId?"); return TCL_ERROR; } if (objc == 1) { Tcl_SetObjResult(interp, Tcl_NewLongObj((long) getpid())); } else { - chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL); - if (chan == (Tcl_Channel) NULL) { + Tcl_Channel chan; + Tcl_ChannelType *chanTypePtr; + PipeState *pipePtr; + int i; + Tcl_Obj *resultPtr, *longObjPtr; + + chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL); + if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } chanTypePtr = Tcl_GetChannelType(chan); if (chanTypePtr != &pipeChannelType) { return TCL_OK; } - pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan); + pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan); resultPtr = Tcl_NewObj(); - for (i = 0; i < pipePtr->numPids; i++) { + for (i = 0; i < pipePtr->numPids; i++) { longObjPtr = Tcl_NewLongObj((long) TclpGetPid(pipePtr->pidPtr[i])); Tcl_ListObjAppendElement(NULL, resultPtr, longObjPtr); } Tcl_SetObjResult(interp, resultPtr); } return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * TclpFinalizePipes -- + * + * Cleans up the pipe subsystem from Tcl_FinalizeThread + * + * Results: + * None. + * + * Notes: + * This procedure carries out no operation on Unix. + * + *---------------------------------------------------------------------- + */ + +void +TclpFinalizePipes() +{ +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: unix/tclUnixPort.h ================================================================== --- unix/tclUnixPort.h +++ unix/tclUnixPort.h @@ -17,11 +17,11 @@ * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixPort.h,v 1.39 2004/11/12 14:18:29 dkf Exp $ + * RCS: @(#) $Id: tclUnixPort.h,v 1.39.2.2 2005/05/21 15:10:35 kennykb Exp $ */ #ifndef _TCLUNIXPORT #define _TCLUNIXPORT @@ -54,15 +54,13 @@ #endif #ifdef HAVE_STRUCT_DIRENT64 typedef struct dirent64 Tcl_DirEntry; # define TclOSreaddir readdir64 -# define TclOSreaddir_r readdir64_r #else typedef struct dirent Tcl_DirEntry; # define TclOSreaddir readdir -# define TclOSreaddir_r readdir_r #endif #ifdef HAVE_TYPE_OFF64_T typedef off64_t Tcl_SeekOffset; # define TclOSseek lseek64 @@ -556,28 +554,17 @@ # include typedef pthread_mutex_t TclpMutex; EXTERN void TclpMutexInit _ANSI_ARGS_((TclpMutex *mPtr)); EXTERN void TclpMutexLock _ANSI_ARGS_((TclpMutex *mPtr)); EXTERN void TclpMutexUnlock _ANSI_ARGS_((TclpMutex *mPtr)); -EXTERN Tcl_DirEntry * TclpReaddir(DIR *); EXTERN struct tm * TclpLocaltime(CONST time_t *); EXTERN struct tm * TclpGmtime(CONST time_t *); EXTERN char * TclpInetNtoa(struct in_addr); -# define readdir(x) TclpReaddir(x) /* #define localtime(x) TclpLocaltime(x) * #define gmtime(x) TclpGmtime(x) */ # undef inet_ntoa # define inet_ntoa(x) TclpInetNtoa(x) -# undef TclOSreaddir -# define TclOSreaddir(x) TclpReaddir(x) -# ifdef MAC_OSX_TCL -/* - * On Mac OS X, realpath is currently not - * thread safe, c.f. SF bug # 711232. - */ -# define NO_REALPATH -# endif # ifdef HAVE_PTHREAD_ATTR_GET_NP # define TclpPthreadGetAttrs pthread_attr_get_np # ifdef ATTRGETNP_NOT_DECLARED /* * Assume it is in pthread_np.h if it isn't in pthread.h. [Bug 1064882] Index: unix/tclUnixSock.c ================================================================== --- unix/tclUnixSock.c +++ unix/tclUnixSock.c @@ -6,82 +6,49 @@ * Copyright (c) 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixSock.c,v 1.9 2004/04/06 22:25:57 dgp Exp $ - */ - -#include "tclInt.h" - -/* - * There is no portable macro for the maximum length - * of host names returned by gethostbyname(). We should only - * trust SYS_NMLN if it is at least 255 + 1 bytes to comply with DNS - * host name limits. - * - * Note: SYS_NMLN is a restriction on "uname" not on gethostbyname! - * - * For example HP-UX 10.20 has SYS_NMLN == 9, while gethostbyname() - * can return a fully qualified name from DNS of up to 255 bytes. - * - * Fix suggested by Viktor Dukhovni (viktor@esm.com) - */ - -#if defined(SYS_NMLN) && SYS_NMLEN >= 256 -#define TCL_HOSTNAME_LEN SYS_NMLEN -#else -#define TCL_HOSTNAME_LEN 256 -#endif - - -/* - * The following variable holds the network name of this host. - */ - -static char hostname[TCL_HOSTNAME_LEN + 1]; -static int hostnameInited = 0; -TCL_DECLARE_MUTEX(hostMutex) - - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetHostName -- - * - * Returns the name of the local host. - * - * Results: - * A string containing the network name for this machine, or - * an empty string if we can't figure out the name. The caller - * must not modify or free this string. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -CONST char * -Tcl_GetHostName() -{ -#ifndef NO_UNAME - struct utsname u; - struct hostent *hp; -#else - char buffer[sizeof(hostname)]; -#endif - CONST char *native; - - Tcl_MutexLock(&hostMutex); - if (hostnameInited) { - Tcl_MutexUnlock(&hostMutex); - return hostname; - } - - native = NULL; -#ifndef NO_UNAME + * RCS: @(#) $Id: tclUnixSock.c,v 1.9.2.3 2005/09/09 18:48:40 dgp Exp $ + */ + +#include "tclInt.h" + +/* + * The following variable holds the network name of this host. + */ + +static TclInitProcessGlobalValueProc InitializeHostName; +static ProcessGlobalValue hostName = + {0, 0, NULL, NULL, InitializeHostName, NULL, NULL}; + + +/* + *---------------------------------------------------------------------- + * + * InitializeHostName -- + * + * This routine sets the process global value of the name of + * the local host on which the process is running. + * + * Results: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +InitializeHostName(valuePtr, lengthPtr, encodingPtr) + char **valuePtr; + int *lengthPtr; + Tcl_Encoding *encodingPtr; +{ + CONST char *native = NULL; + +#ifndef NO_UNAME + struct utsname u; + struct hostent *hp; (VOID *) memset((VOID *) &u, (int) 0, sizeof(struct utsname)); if (uname(&u) > -1) { /* INTL: Native. */ hp = gethostbyname(u.nodename); /* INTL: Native. */ if (hp == NULL) { /* @@ -102,29 +69,68 @@ native = hp->h_name; } else { native = u.nodename; } } + if (native == NULL) { + native = tclEmptyStringRep; + } #else /* * Uname doesn't exist; try gethostname instead. + * + * There is no portable macro for the maximum length + * of host names returned by gethostbyname(). We should only + * trust SYS_NMLN if it is at least 255 + 1 bytes to comply with DNS + * host name limits. + * + * Note: SYS_NMLN is a restriction on "uname" not on gethostbyname! + * + * For example HP-UX 10.20 has SYS_NMLN == 9, while gethostbyname() + * can return a fully qualified name from DNS of up to 255 bytes. + * + * Fix suggested by Viktor Dukhovni (viktor@esm.com) */ +# if defined(SYS_NMLN) && SYS_NMLEN >= 256 + char buffer[SYS_NMLEN]; +# else + char buffer[256]; +# endif if (gethostname(buffer, sizeof(buffer)) > -1) { /* INTL: Native. */ native = buffer; } #endif - if (native == NULL) { - hostname[0] = 0; - } else { - Tcl_ExternalToUtf(NULL, NULL, native, -1, 0, NULL, hostname, - sizeof(hostname), NULL, NULL, NULL); - } - hostnameInited = 1; - Tcl_MutexUnlock(&hostMutex); - return hostname; + *encodingPtr = Tcl_GetEncoding(NULL, NULL); + *lengthPtr = strlen(native); + *valuePtr = ckalloc((unsigned int) (*lengthPtr)+1); + memcpy((VOID *) *valuePtr, (VOID *) native, (size_t)(*lengthPtr)+1); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetHostName -- + * + * Returns the name of the local host. + * + * Results: + * A string containing the network name for this machine, or + * an empty string if we can't figure out the name. The caller + * must not modify or free this string. + * + * Side effects: + * Caches the name to return for future calls. + * + *---------------------------------------------------------------------- + */ + +CONST char * +Tcl_GetHostName() +{ + return Tcl_GetString(TclGetProcessGlobalValue(&hostName)); } /* *---------------------------------------------------------------------- * @@ -144,52 +150,6 @@ int TclpHasSockets(interp) Tcl_Interp *interp; /* Not used. */ { return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclpCutSockChannel -- - * - * Remove any thread local refs to this channel. See - * Tcl_CutChannel for more info. Dummy definition. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TclpCutSockChannel(chan) - Tcl_Channel chan; -{ -} - -/* - *---------------------------------------------------------------------- - * - * TclpSpliceSockChannel -- - * - * Insert thread local ref for this channel. - * Tcl_SpliceChannel for more info. Dummy definition. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TclpSpliceSockChannel(chan) - Tcl_Channel chan; -{ } Index: unix/tclUnixThrd.c ================================================================== --- unix/tclUnixThrd.c +++ unix/tclUnixThrd.c @@ -4,12 +4,12 @@ * This file implements the UNIX-specific thread support. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * SCCS: @(#) tclUnixThrd.c 1.18 98/02/19 14:24:12 */ #include "tclInt.h" @@ -17,38 +17,33 @@ #ifdef TCL_THREADS #include "pthread.h" typedef struct ThreadSpecificData { - char nabuf[16]; - struct { - Tcl_DirEntry ent; - char name[MAXNAMLEN+1]; - } rdbuf; + char nabuf[16]; } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* - * masterLock is used to serialize creation of mutexes, condition - * variables, and thread local storage. - * This is the only place that can count on the ability to statically - * initialize the mutex. + * masterLock is used to serialize creation of mutexes, condition variables, + * and thread local storage. This is the only place that can count on the + * ability to statically initialize the mutex. */ static pthread_mutex_t masterLock = PTHREAD_MUTEX_INITIALIZER; /* - * initLock is used to serialize initialization and finalization - * of Tcl. It cannot use any dyamically allocated storage. + * initLock is used to serialize initialization and finalization of Tcl. It + * cannot use any dyamically allocated storage. */ static pthread_mutex_t initLock = PTHREAD_MUTEX_INITIALIZER; /* - * allocLock is used by Tcl's version of malloc for synchronization. - * For obvious reasons, cannot use any dyamically allocated storage. + * allocLock is used by Tcl's version of malloc for synchronization. For + * obvious reasons, cannot use any dyamically allocated storage. */ static pthread_mutex_t allocLock = PTHREAD_MUTEX_INITIALIZER; static pthread_mutex_t *allocLockPtr = &allocLock; @@ -63,17 +58,17 @@ /* *---------------------------------------------------------------------- * - * TclpThreadCreaet -- + * TclpThreadCreate -- * * This procedure creates a new thread. * * Results: - * TCL_OK if the thread could be created. The thread ID is - * returned in a parameter. + * TCL_OK if the thread could be created. The thread ID is returned in a + * parameter. * * Side effects: * A new thread is created. * *---------------------------------------------------------------------- @@ -83,12 +78,12 @@ TclpThreadCreate(idPtr, proc, clientData, stackSize, flags) Tcl_ThreadId *idPtr; /* Return, the ID of the thread */ Tcl_ThreadCreateProc proc; /* Main() function of the thread */ ClientData clientData; /* The one argument to Main() */ int stackSize; /* Size of stack for the new thread */ - int flags; /* Flags controlling behaviour of - * the new thread */ + int flags; /* Flags controlling behaviour of the + * new thread. */ { #ifdef TCL_THREADS pthread_attr_t attr; pthread_t theThread; int result; @@ -96,35 +91,35 @@ pthread_attr_init(&attr); pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM); #ifdef HAVE_PTHREAD_ATTR_SETSTACKSIZE if (stackSize != TCL_THREAD_STACK_DEFAULT) { - pthread_attr_setstacksize(&attr, (size_t) stackSize); + pthread_attr_setstacksize(&attr, (size_t) stackSize); #ifdef TCL_THREAD_STACK_MIN } else { - /* - * Certain systems define a thread stack size that by default is - * too small for many operations. The user has the option of - * defining TCL_THREAD_STACK_MIN to a value large enough to work - * for their needs. This would look like (for 128K min stack): + /* + * Certain systems define a thread stack size that by default is too + * small for many operations. The user has the option of defining + * TCL_THREAD_STACK_MIN to a value large enough to work for their + * needs. This would look like (for 128K min stack): * make MEM_DEBUG_FLAGS=-DTCL_THREAD_STACK_MIN=131072L * * This solution is not optimal, as we should allow the user to * specify a size at runtime, but we don't want to slow this function * down, and that would still leave the main thread at the default. */ - size_t size; + size_t size; result = pthread_attr_getstacksize(&attr, &size); if (!result && (size < TCL_THREAD_STACK_MIN)) { pthread_attr_setstacksize(&attr, (size_t) TCL_THREAD_STACK_MIN); } #endif } #endif if (! (flags & TCL_THREAD_JOINABLE)) { - pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED); + pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED); } if (pthread_create(&theThread, &attr, (void * (*)(void *))proc, (void *)clientData) && @@ -151,22 +146,21 @@ * * Results: * TCL_OK if the wait was successful, TCL_ERROR else. * * Side effects: - * The result area is set to the exit code of the thread we - * waited upon. + * The result area is set to the exit code of the thread we waited upon. * *---------------------------------------------------------------------- */ int Tcl_JoinThread(threadId, state) - Tcl_ThreadId threadId; /* Id of the thread to wait upon */ - int* state; /* Reference to the storage the result - * of the thread we wait upon will be - * written into. */ + Tcl_ThreadId threadId; /* Id of the thread to wait upon. */ + int *state; /* Reference to the storage the result of the + * thread we wait upon will be written + * into. */ { #ifdef TCL_THREADS int result; result = pthread_join ((pthread_t) threadId, (VOID**) state); @@ -239,14 +233,14 @@ } pthread_attr_destroy(&threadAttr); return (int) stackSize; #else /* - * Cannot determine the real stack size of this thread. The - * caller might want to try looking at the process accounting - * limits instead. + * Cannot determine the real stack size of this thread. The caller might + * want to try looking at the process accounting limits instead. */ + return 0; #endif } #endif /* TCL_THREADS */ @@ -281,13 +275,13 @@ *---------------------------------------------------------------------- * * TclpInitLock * * This procedure is used to grab a lock that serializes initialization - * and finalization of Tcl. On some platforms this may also initialize - * the mutex used to serialize creation of more mutexes and thread - * local storage keys. + * and finalization of Tcl. On some platforms this may also initialize + * the mutex used to serialize creation of more mutexes and thread local + * storage keys. * * Results: * None. * * Side effects: @@ -307,19 +301,19 @@ /* *---------------------------------------------------------------------- * * TclpFinalizeLock * - * This procedure is used to destroy all private resources used in - * this file. + * This procedure is used to destroy all private resources used in this + * file. * * Results: * None. * * Side effects: - * Destroys everything private. TclpInitLock must be held - * entering this function. + * Destroys everything private. TclpInitLock must be held entering this + * function. * *---------------------------------------------------------------------- */ void @@ -326,24 +320,25 @@ TclFinalizeLock () { #ifdef TCL_THREADS /* * You do not need to destroy mutexes that were created with the - * PTHREAD_MUTEX_INITIALIZER macro. These mutexes do not need - * any destruction: masterLock, allocLock, and initLock. + * PTHREAD_MUTEX_INITIALIZER macro. These mutexes do not need any + * destruction: masterLock, allocLock, and initLock. */ + pthread_mutex_unlock(&initLock); #endif } /* *---------------------------------------------------------------------- * * TclpInitUnlock * - * This procedure is used to release a lock that serializes initialization - * and finalization of Tcl. + * This procedure is used to release a lock that serializes + * initialization and finalization of Tcl. * * Results: * None. * * Side effects: @@ -363,17 +358,16 @@ /* *---------------------------------------------------------------------- * * TclpMasterLock * - * This procedure is used to grab a lock that serializes creation - * and finalization of serialization objects. This interface is - * only needed in finalization; it is hidden during - * creation of the objects. + * This procedure is used to grab a lock that serializes creation and + * finalization of serialization objects. This interface is only needed + * in finalization; it is hidden during creation of the objects. * - * This lock must be different than the initLock because the - * initLock is held during creation of syncronization objects. + * This lock must be different than the initLock because the initLock is + * held during creation of syncronization objects. * * Results: * None. * * Side effects: @@ -394,12 +388,12 @@ /* *---------------------------------------------------------------------- * * TclpMasterUnlock * - * This procedure is used to release a lock that serializes creation - * and finalization of synchronization objects. + * This procedure is used to release a lock that serializes creation and + * finalization of synchronization objects. * * Results: * None. * * Side effects: @@ -420,17 +414,17 @@ /* *---------------------------------------------------------------------- * * Tcl_GetAllocMutex * - * This procedure returns a pointer to a statically initialized - * mutex for use by the memory allocator. The alloctor must - * use this lock, because all other locks are allocated... + * This procedure returns a pointer to a statically initialized mutex for + * use by the memory allocator. The alloctor must use this lock, because + * all other locks are allocated... * * Results: - * A pointer to a mutex that is suitable for passing to - * Tcl_MutexLock and Tcl_MutexUnlock. + * A pointer to a mutex that is suitable for passing to Tcl_MutexLock and + * Tcl_MutexUnlock. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -451,22 +445,22 @@ /* *---------------------------------------------------------------------- * * Tcl_MutexLock -- * - * This procedure is invoked to lock a mutex. This procedure - * handles initializing the mutex, if necessary. The caller - * can rely on the fact that Tcl_Mutex is an opaque pointer. - * This routine will change that pointer from NULL after first use. + * This procedure is invoked to lock a mutex. This procedure handles + * initializing the mutex, if necessary. The caller can rely on the fact + * that Tcl_Mutex is an opaque pointer. This routine will change that + * pointer from NULL after first use. * * Results: * None. * * Side effects: - * May block the current thread. The mutex is aquired when - * this returns. Will allocate memory for a pthread_mutex_t - * and initialize this the first time this Tcl_Mutex is used. + * May block the current thread. The mutex is aquired when this returns. + * Will allocate memory for a pthread_mutex_t and initialize this the + * first time this Tcl_Mutex is used. * *---------------------------------------------------------------------- */ void @@ -496,12 +490,12 @@ /* *---------------------------------------------------------------------- * * Tcl_MutexUnlock -- * - * This procedure is invoked to unlock a mutex. The mutex must - * have been locked by Tcl_MutexLock. + * This procedure is invoked to unlock a mutex. The mutex must have been + * locked by Tcl_MutexLock. * * Results: * None. * * Side effects: @@ -522,12 +516,12 @@ /* *---------------------------------------------------------------------- * * TclpFinalizeMutex -- * - * This procedure is invoked to clean up one mutex. This is only - * safe to call at the end of time. + * This procedure is invoked to clean up one mutex. This is only safe to + * call at the end of time. * * This assumes the Master Lock is held. * * Results: * None. @@ -542,203 +536,34 @@ TclpFinalizeMutex(mutexPtr) Tcl_Mutex *mutexPtr; { pthread_mutex_t *pmutexPtr = *(pthread_mutex_t **)mutexPtr; if (pmutexPtr != NULL) { - pthread_mutex_destroy(pmutexPtr); + pthread_mutex_destroy(pmutexPtr); ckfree((char *)pmutexPtr); *mutexPtr = NULL; } } - - -/* - *---------------------------------------------------------------------- - * - * TclpThreadDataKeyInit -- - * - * This procedure initializes a thread specific data block key. - * Each thread has table of pointers to thread specific data. - * all threads agree on which table entry is used by each module. - * this is remembered in a "data key", that is just an index into - * this table. To allow self initialization, the interface - * passes a pointer to this key and the first thread to use - * the key fills in the pointer to the key. The key should be - * a process-wide static. - * - * Results: - * None. - * - * Side effects: - * Will allocate memory the first time this process calls for - * this key. In this case it modifies its argument - * to hold the pointer to information about the key. - * - *---------------------------------------------------------------------- - */ - -void -TclpThreadDataKeyInit(keyPtr) - Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, - * really (pthread_key_t **) */ -{ - pthread_key_t *pkeyPtr; - - MASTER_LOCK; - if (*keyPtr == NULL) { - pkeyPtr = (pthread_key_t *)ckalloc(sizeof(pthread_key_t)); - pthread_key_create(pkeyPtr, NULL); - *keyPtr = (Tcl_ThreadDataKey)pkeyPtr; - TclRememberDataKey(keyPtr); - } - MASTER_UNLOCK; -} - -/* - *---------------------------------------------------------------------- - * - * TclpThreadDataKeyGet -- - * - * This procedure returns a pointer to a block of thread local storage. - * - * Results: - * A thread-specific pointer to the data structure, or NULL - * if the memory has not been assigned to this key for this thread. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -VOID * -TclpThreadDataKeyGet(keyPtr) - Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, - * really (pthread_key_t **) */ -{ - pthread_key_t *pkeyPtr = *(pthread_key_t **)keyPtr; - if (pkeyPtr == NULL) { - return NULL; - } else { - return (VOID *)pthread_getspecific(*pkeyPtr); - } -} - - -/* - *---------------------------------------------------------------------- - * - * TclpThreadDataKeySet -- - * - * This procedure sets the pointer to a block of thread local storage. - * - * Results: - * None. - * - * Side effects: - * Sets up the thread so future calls to TclpThreadDataKeyGet with - * this key will return the data pointer. - * - *---------------------------------------------------------------------- - */ - -void -TclpThreadDataKeySet(keyPtr, data) - Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, - * really (pthread_key_t **) */ - VOID *data; /* Thread local storage */ -{ - pthread_key_t *pkeyPtr = *(pthread_key_t **)keyPtr; - pthread_setspecific(*pkeyPtr, data); -} - -/* - *---------------------------------------------------------------------- - * - * TclpFinalizeThreadData -- - * - * This procedure cleans up the thread-local storage. This is - * called once for each thread. - * - * Results: - * None. - * - * Side effects: - * Frees up all thread local storage. - * - *---------------------------------------------------------------------- - */ - -void -TclpFinalizeThreadData(keyPtr) - Tcl_ThreadDataKey *keyPtr; -{ - VOID *result; - pthread_key_t *pkeyPtr; - - if (*keyPtr != NULL) { - pkeyPtr = *(pthread_key_t **)keyPtr; - result = (VOID *)pthread_getspecific(*pkeyPtr); - if (result != NULL) { - ckfree((char *)result); - pthread_setspecific(*pkeyPtr, (void *)NULL); - } - } -} - -/* - *---------------------------------------------------------------------- - * - * TclpFinalizeThreadDataKey -- - * - * This procedure is invoked to clean up one key. This is a - * process-wide storage identifier. The thread finalization code - * cleans up the thread local storage itself. - * - * This assumes the master lock is held. - * - * Results: - * None. - * - * Side effects: - * The key is deallocated. - * - *---------------------------------------------------------------------- - */ - -void -TclpFinalizeThreadDataKey(keyPtr) - Tcl_ThreadDataKey *keyPtr; -{ - pthread_key_t *pkeyPtr; - if (*keyPtr != NULL) { - pkeyPtr = *(pthread_key_t **)keyPtr; - pthread_key_delete(*pkeyPtr); - ckfree((char *)pkeyPtr); - *keyPtr = NULL; - } -} - /* *---------------------------------------------------------------------- * * Tcl_ConditionWait -- * - * This procedure is invoked to wait on a condition variable. - * The mutex is automically released as part of the wait, and - * automatically grabbed when the condition is signaled. + * This procedure is invoked to wait on a condition variable. The mutex + * is automically released as part of the wait, and automatically grabbed + * when the condition is signaled. * * The mutex must be held when this procedure is called. * * Results: * None. * * Side effects: - * May block the current thread. The mutex is aquired when - * this returns. Will allocate memory for a pthread_mutex_t - * and initialize this the first time this Tcl_Mutex is used. + * May block the current thread. The mutex is aquired when this returns. + * Will allocate memory for a pthread_mutex_t and initialize this the + * first time this Tcl_Mutex is used. * *---------------------------------------------------------------------- */ void @@ -753,12 +578,12 @@ if (*condPtr == NULL) { MASTER_LOCK; /* - * Double check inside mutex to avoid race, - * then initialize condition variable if necessary. + * Double check inside mutex to avoid race, then initialize condition + * variable if necessary. */ if (*condPtr == NULL) { pcondPtr = (pthread_cond_t *)ckalloc(sizeof(pthread_cond_t)); pthread_cond_init(pcondPtr, NULL); @@ -792,12 +617,12 @@ * * Tcl_ConditionNotify -- * * This procedure is invoked to signal a condition variable. * - * The mutex must be held during this call to avoid races, - * but this interface does not enforce that. + * The mutex must be held during this call to avoid races, but this + * interface does not enforce that. * * Results: * None. * * Side effects: @@ -824,12 +649,12 @@ /* *---------------------------------------------------------------------- * * TclpFinalizeCondition -- * - * This procedure is invoked to clean up a condition variable. - * This is only safe to call at the end of time. + * This procedure is invoked to clean up a condition variable. This is + * only safe to call at the end of time. * * This assumes the Master Lock is held. * * Results: * None. @@ -856,97 +681,61 @@ /* *---------------------------------------------------------------------- * * TclpReaddir, TclpLocaltime, TclpGmtime, TclpInetNtoa -- * - * These procedures replace core C versions to be used in a - * threaded environment. + * These procedures replace core C versions to be used in a threaded + * environment. * * Results: * See documentation of C functions. * * Side effects: * See documentation of C functions. * + * Notes: + * TclpReaddir is no longer used by the core (see 1095909), but it + * appears in the internal stubs table (see #589526). + * *---------------------------------------------------------------------- */ -#if defined(TCL_THREADS) && !defined(HAVE_READDIR_R) -TCL_DECLARE_MUTEX( rdMutex ) -#undef readdir -#endif - Tcl_DirEntry * TclpReaddir(DIR * dir) { - Tcl_DirEntry *ent; -#ifdef TCL_THREADS - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - -#ifdef HAVE_READDIR_R - ent = &tsdPtr->rdbuf.ent; -# ifdef HAVE_TWO_ARG_READDIR_R - if (TclOSreaddir_r(dir, ent) != 0) { -# else /* HAVE_THREE_ARG_READDIR_R */ - if (TclOSreaddir_r(dir, ent, &ent) != 0) { -# endif /* HAVE_TWO_ARG_READDIR_R */ - ent = NULL; - } - -#else /* !HAVE_READDIR_R */ - - Tcl_MutexLock(&rdMutex); -# ifdef HAVE_STRUCT_DIRENT64 - ent = readdir64(dir); -# else /* !HAVE_STRUCT_DIRENT64 */ - ent = readdir(dir); -# endif /* HAVE_STRUCT_DIRENT64 */ - if (ent != NULL) { - memcpy((VOID *) &tsdPtr->rdbuf.ent, (VOID *) ent, - sizeof(tsdPtr->rdbuf)); - ent = &tsdPtr->rdbuf.ent; - } - Tcl_MutexUnlock(&rdMutex); - -#endif /* HAVE_READDIR_R */ -#else -# ifdef HAVE_STRUCT_DIRENT64 - ent = readdir64(dir); -# else /* !HAVE_STRUCT_DIRENT64 */ - ent = readdir(dir); -# endif /* HAVE_STRUCT_DIRENT64 */ -#endif - return ent; -} + return TclOSreaddir(dir); +} + char * TclpInetNtoa(struct in_addr addr) { #ifdef TCL_THREADS ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); union { - unsigned long l; - unsigned char b[4]; + unsigned long l; + unsigned char b[4]; } u; u.l = (unsigned long) addr.s_addr; sprintf(tsdPtr->nabuf, "%u.%u.%u.%u", u.b[0], u.b[1], u.b[2], u.b[3]); return tsdPtr->nabuf; #else return inet_ntoa(addr); #endif } - + #ifdef TCL_THREADS /* * Additions by AOL for specialized thread memory allocator. */ + #ifdef USE_THREAD_ALLOC static volatile int initialized = 0; static pthread_key_t key; typedef struct allocMutex { - Tcl_Mutex tlock; + Tcl_Mutex tlock; pthread_mutex_t plock; } allocMutex; Tcl_Mutex * TclpNewAllocMutex(void) @@ -965,27 +754,35 @@ void TclpFreeAllocMutex(mutex) Tcl_Mutex *mutex; /* The alloc mutex to free. */ { allocMutex* lockPtr = (allocMutex*) mutex; - if (!lockPtr) return; + if (!lockPtr) { + return; + } pthread_mutex_destroy(&lockPtr->plock); free(lockPtr); } void TclpFreeAllocCache(ptr) void *ptr; { - extern void TclFreeAllocCache(void *); - - TclFreeAllocCache(ptr); - /* - * Perform proper cleanup of things done in TclpGetAllocCache. - */ - if (initialized) { - pthread_key_delete(key); - initialized = 0; + if (ptr != NULL) { + /* + * Called by the pthread lib when a thread exits + */ + + TclFreeAllocCache(ptr); + + } else if (initialized) { + /* + * Called by us in TclFinalizeThreadAlloc() during the library + * finalization initiated from Tcl_Finalize() + */ + + pthread_key_delete(key); + initialized = 0; } } void * TclpGetAllocCache(void) @@ -1004,8 +801,15 @@ void TclpSetAllocCache(void *arg) { pthread_setspecific(key, arg); } - #endif /* USE_THREAD_ALLOC */ #endif /* TCL_THREADS */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: unix/tclUnixTime.c ================================================================== --- unix/tclUnixTime.c +++ unix/tclUnixTime.c @@ -1,60 +1,73 @@ -/* +/* * tclUnixTime.c -- * - * Contains Unix specific versions of Tcl functions that - * obtain time values from the operating system. + * Contains Unix specific versions of Tcl functions that obtain time + * values from the operating system. * * Copyright (c) 1995 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixTime.c,v 1.22 2004/09/27 14:31:20 kennykb Exp $ + * RCS: @(#) $Id: tclUnixTime.c,v 1.22.2.2 2005/08/02 18:16:58 dgp Exp $ */ #include "tclInt.h" #include #define TM_YEAR_BASE 1900 -#define IsLeapYear(x) ((x % 4 == 0) && (x % 100 != 0 || x % 400 == 0)) +#define IsLeapYear(x) (((x)%4 == 0) && ((x)%100 != 0 || (x)%400 == 0)) /* - * TclpGetDate is coded to return a pointer to a 'struct tm'. For - * thread safety, this structure must be in thread-specific data. - * The 'tmKey' variable is the key to this buffer. + * TclpGetDate is coded to return a pointer to a 'struct tm'. For thread + * safety, this structure must be in thread-specific data. The 'tmKey' + * variable is the key to this buffer. */ static Tcl_ThreadDataKey tmKey; typedef struct ThreadSpecificData { struct tm gmtime_buf; struct tm localtime_buf; } ThreadSpecificData; /* - * If we fall back on the thread-unsafe versions of gmtime and localtime, - * use this mutex to try to protect them. + * If we fall back on the thread-unsafe versions of gmtime and localtime, use + * this mutex to try to protect them. */ TCL_DECLARE_MUTEX(tmMutex) -static char* lastTZ = NULL; /* Holds the last setting of the - * TZ environment variable, or an - * empty string if the variable was - * not set. */ - -/* Static functions declared in this file */ - -static void SetTZIfNecessary _ANSI_ARGS_((void)); -static void CleanupMemory _ANSI_ARGS_((ClientData)); +static char *lastTZ = NULL; /* Holds the last setting of the TZ + * environment variable, or an empty string if + * the variable was not set. */ + +/* + * Static functions declared in this file. + */ + +static void SetTZIfNecessary _ANSI_ARGS_((void)); +static void CleanupMemory _ANSI_ARGS_((ClientData)); +static void NativeScaleTime _ANSI_ARGS_((Tcl_Time *timebuf, + ClientData clientData)); +static void NativeGetTime _ANSI_ARGS_((Tcl_Time *timebuf, + ClientData clientData)); + +/* + * TIP #233 (Virtualized Time): Data for the time hooks, if any. + */ + +Tcl_GetTimeProc *tclGetTimeProcPtr = NativeGetTime; +Tcl_ScaleTimeProc *tclScaleTimeProcPtr = NativeScaleTime; +ClientData tclTimeClientData = NULL; /* *----------------------------------------------------------------------------- * * TclpGetSeconds -- * - * This procedure returns the number of seconds from the epoch. On - * most Unix systems the epoch is Midnight Jan 1, 1970 GMT. + * This procedure returns the number of seconds from the epoch. On most + * Unix systems the epoch is Midnight Jan 1, 1970 GMT. * * Results: * Number of seconds from the epoch. * * Side effects: @@ -73,12 +86,12 @@ *----------------------------------------------------------------------------- * * TclpGetClicks -- * * This procedure returns a value that represents the highest resolution - * clock available on the system. There are no garantees on what the - * resolution will be. In Tcl we will call this value a "click". The + * clock available on the system. There are no garantees on what the + * resolution will be. In Tcl we will call this value a "click". The * start time is also system dependant. * * Results: * Number of clicks from some start time. * @@ -90,22 +103,30 @@ unsigned long TclpGetClicks() { unsigned long now; -#ifdef NO_GETTOD - struct tms dummy; -#else - struct timeval date; - struct timezone tz; -#endif #ifdef NO_GETTOD - now = (unsigned long) times(&dummy); + if (tclGetTimeProcPtr != NativeGetTime) { + Tcl_Time time; + + (*tclGetTimeProcPtr) (&time, tclTimeClientData); + now = time.sec*1000000 + time.usec; + } else { + /* + * A semi-NativeGetTime, specialized to clicks. + */ + struct tms dummy; + + now = (unsigned long) times(&dummy); + } #else - gettimeofday(&date, &tz); - now = date.tv_sec*1000000 + date.tv_usec; + Tcl_Time time; + + (*tclGetTimeProcPtr) (&time, tclTimeClientData); + now = time.sec*1000000 + time.usec; #endif return now; } @@ -112,130 +133,131 @@ /* *---------------------------------------------------------------------- * * TclpGetTimeZone -- * - * Determines the current timezone. The method varies wildly - * between different platform implementations, so its hidden in - * this function. + * Determines the current timezone. The method varies wildly between + * different platform implementations, so its hidden in this function. * * Results: - * The return value is the local time zone, measured in - * minutes away from GMT (-ve for east, +ve for west). + * The return value is the local time zone, measured in minutes away from + * GMT (-ve for east, +ve for west). * * Side effects: * None. * *---------------------------------------------------------------------- */ int -TclpGetTimeZone (currentTime) - unsigned long currentTime; +TclpGetTimeZone(currentTime) + unsigned long currentTime; { + int timeZone; + /* - * We prefer first to use the time zone in "struct tm" if the - * structure contains such a member. Following that, we try - * to locate the external 'timezone' variable and use its value. - * If both of those methods fail, we attempt to convert a known - * time to local time and use the difference from UTC as the local - * time zone. In all cases, we need to undo any Daylight Saving Time - * adjustment. + * We prefer first to use the time zone in "struct tm" if the structure + * contains such a member. Following that, we try to locate the external + * 'timezone' variable and use its value. If both of those methods fail, + * we attempt to convert a known time to local time and use the difference + * from UTC as the local time zone. In all cases, we need to undo any + * Daylight Saving Time adjustment. */ - + #if defined(HAVE_TM_TZADJ) -# define TCL_GOT_TIMEZONE - - /* Struct tm contains tm_tzadj - that value may be used. */ +#define TCL_GOT_TIMEZONE + /* + * Struct tm contains tm_tzadj - that value may be used. + */ - time_t curTime = (time_t) currentTime; - struct tm *timeDataPtr = TclpLocaltime(&curTime); - int timeZone; + time_t curTime = (time_t) currentTime; + struct tm *timeDataPtr = TclpLocaltime(&curTime); timeZone = timeDataPtr->tm_tzadj / 60; if (timeDataPtr->tm_isdst) { - timeZone += 60; + timeZone += 60; } - - return timeZone; - #endif #if defined(HAVE_TM_GMTOFF) && !defined (TCL_GOT_TIMEZONE) -# define TCL_GOT_TIMEZONE - - /* Struct tm contains tm_gmtoff - that value may be used. */ +#define TCL_GOT_TIMEZONE + /* + * Struct tm contains tm_gmtoff - that value may be used. + */ - time_t curTime = (time_t) currentTime; + time_t curTime = (time_t) currentTime; struct tm *timeDataPtr = TclpLocaltime(&curTime); - int timeZone; timeZone = -(timeDataPtr->tm_gmtoff / 60); if (timeDataPtr->tm_isdst) { - timeZone += 60; + timeZone += 60; } - - return timeZone; - #endif #if defined(HAVE_TIMEZONE_VAR) && !defined(TCL_GOT_TIMEZONE) && !defined(USE_DELTA_FOR_TZ) -# define TCL_GOT_TIMEZONE - - int timeZone; - - /* The 'timezone' external var is present and may be used. */ +#define TCL_GOT_TIMEZONE + /* + * The 'timezone' external var is present and may be used. + */ SetTZIfNecessary(); /* - * Note: this is not a typo in "timezone" below! See tzset - * documentation for details. + * Note: this is not a typo in "timezone" below! See tzset documentation + * for details. */ timeZone = timezone / 60; - return timeZone; - #endif -#if !defined(TCL_GOT_TIMEZONE) -#define TCL_GOT_TIMEZONE 1 +#if !defined(TCL_GOT_TIMEZONE) +#define TCL_GOT_TIMEZONE /* * Fallback - determine time zone with a known reference time. */ - int timeZone; time_t tt; struct tm *stm; - tt = 849268800L; /* 1996-11-29 12:00:00 GMT */ - stm = TclpLocaltime(&tt); /* eg 1996-11-29 6:00:00 CST6CDT */ - /* The calculation below assumes a max of +12 or -12 hours from GMT */ + + tt = 849268800L; /* 1996-11-29 12:00:00 GMT */ + stm = TclpLocaltime(&tt); /* eg 1996-11-29 6:00:00 CST6CDT */ + + /* + * The calculation below assumes a max of +12 or -12 hours from GMT. + */ + timeZone = (12 - stm->tm_hour)*60 + (0 - stm->tm_min); - if ( stm -> tm_isdst ) { + if (stm->tm_isdst) { timeZone += 60; } - return timeZone; /* eg +360 for CST6CDT */ + + /* + * Now have offset for our known reference time, eg +360 for CST6CDT. + */ #endif #ifndef TCL_GOT_TIMEZONE /* - * Cause compile error, we don't know how to get timezone. + * Cause fatal compile error, we don't know how to get timezone. */ -#error autoconf did not figure out how to determine the timezone. - +#error autoconf did not figure out how to determine the timezone. #endif + return timeZone; } /* *---------------------------------------------------------------------- * * Tcl_GetTime -- * - * Gets the current system time in seconds and microseconds - * since the beginning of the epoch: 00:00 UCT, January 1, 1970. + * Gets the current system time in seconds and microseconds since the + * beginning of the epoch: 00:00 UCT, January 1, 1970. + * + * This function is hooked, allowing users to specify their own virtual + * system time. * * Results: * Returns the current time in timePtr. * * Side effects: @@ -246,26 +268,21 @@ void Tcl_GetTime(timePtr) Tcl_Time *timePtr; /* Location to store time information. */ { - struct timeval tv; - struct timezone tz; - - (void) gettimeofday(&tv, &tz); - timePtr->sec = tv.tv_sec; - timePtr->usec = tv.tv_usec; + (*tclGetTimeProcPtr) (timePtr, tclTimeClientData); } /* *---------------------------------------------------------------------- * * TclpGetDate -- * - * This function converts between seconds and struct tm. If - * useGMT is true, then the returned date will be in Greenwich - * Mean Time (GMT). Otherwise, it will be in the local time zone. + * This function converts between seconds and struct tm. If useGMT is + * true, then the returned date will be in Greenwich Mean Time (GMT). + * Otherwise, it will be in the local time zone. * * Results: * Returns a static tm structure. * * Side effects: @@ -302,39 +319,41 @@ * *---------------------------------------------------------------------- */ struct tm * -TclpGmtime( timePtr ) - CONST time_t *timePtr; /* Pointer to the number of seconds - * since the local system's epoch */ - +TclpGmtime(timePtr) + CONST time_t *timePtr; /* Pointer to the number of seconds since the + * local system's epoch */ { /* * Get a thread-local buffer to hold the returned time. */ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT( &tmKey ); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tmKey); + #ifdef HAVE_GMTIME_R - gmtime_r(timePtr, &( tsdPtr->gmtime_buf )); + gmtime_r(timePtr, &(tsdPtr->gmtime_buf)); #else - Tcl_MutexLock( &tmMutex ); - memcpy( (VOID *) &( tsdPtr->gmtime_buf ), - (VOID *) gmtime( timePtr ), - sizeof( struct tm ) ); - Tcl_MutexUnlock( &tmMutex ); -#endif - return &( tsdPtr->gmtime_buf ); -} + Tcl_MutexLock(&tmMutex); + memcpy((VOID *) &(tsdPtr->gmtime_buf), (VOID *) gmtime(timePtr), + sizeof(struct tm)); + Tcl_MutexUnlock(&tmMutex); +#endif + + return &(tsdPtr->gmtime_buf); +} + /* * Forwarder for obsolete item in Stubs */ + struct tm* -TclpGmtime_unix( timePtr ) - CONST time_t* timePtr; +TclpGmtime_unix(timePtr) + CONST time_t *timePtr; { - return TclpGmtime( timePtr ); + return TclpGmtime(timePtr); } /* *---------------------------------------------------------------------- * @@ -352,89 +371,204 @@ *---------------------------------------------------------------------- */ struct tm * TclpLocaltime(timePtr) - CONST time_t *timePtr; /* Pointer to the number of seconds - * since the local system's epoch */ - + CONST time_t *timePtr; /* Pointer to the number of seconds since the + * local system's epoch */ { /* * Get a thread-local buffer to hold the returned time. */ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT( &tmKey ); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tmKey); + SetTZIfNecessary(); #ifdef HAVE_LOCALTIME_R - localtime_r( timePtr, &( tsdPtr->localtime_buf ) ); + localtime_r(timePtr, &(tsdPtr->localtime_buf)); #else - Tcl_MutexLock( &tmMutex ); - memcpy( (VOID *) &( tsdPtr -> localtime_buf ), - (VOID *) localtime( timePtr ), - sizeof( struct tm ) ); - Tcl_MutexUnlock( &tmMutex ); -#endif - return &( tsdPtr->localtime_buf ); + Tcl_MutexLock(&tmMutex); + memcpy((VOID *) &(tsdPtr->localtime_buf), (VOID *) localtime(timePtr), + sizeof(struct tm)); + Tcl_MutexUnlock(&tmMutex); +#endif + + return &(tsdPtr->localtime_buf); } /* * Forwarder for obsolete item in Stubs */ struct tm* -TclpLocaltime_unix( timePtr ) - CONST time_t* timePtr; +TclpLocaltime_unix(timePtr) + CONST time_t *timePtr; +{ + return TclpLocaltime(timePtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetTimeProc -- + * + * TIP #233 (Virtualized Time): Registers two handlers for the + * virtualization of Tcl's access to time information. + * + * Results: + * None. + * + * Side effects: + * Remembers the handlers, alters core behaviour. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetTimeProc(getProc, scaleProc, clientData) + Tcl_GetTimeProc *getProc; + Tcl_ScaleTimeProc *scaleProc; + ClientData clientData; +{ + tclGetTimeProcPtr = getProc; + tclScaleTimeProcPtr = scaleProc; + tclTimeClientData = clientData; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_QueryTimeProc -- + * + * TIP #233 (Virtualized Time): Query which time handlers are registered. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_QueryTimeProc(getProc, scaleProc, clientData) + Tcl_GetTimeProc **getProc; + Tcl_ScaleTimeProc **scaleProc; + ClientData *clientData; +{ + if (getProc) { + *getProc = tclGetTimeProcPtr; + } + if (scaleProc) { + *scaleProc = tclScaleTimeProcPtr; + } + if (clientData) { + *clientData = tclTimeClientData; + } +} + +/* + *---------------------------------------------------------------------- + * + * NativeScaleTime -- + * + * TIP #233: Scale from virtual time to the real-time. For native scaling + * the relationship is 1:1 and nothing has to be done. + * + * Results: + * Scales the time in timePtr. + * + * Side effects: + * See above. + * + *---------------------------------------------------------------------- + */ + +static void +NativeScaleTime(timePtr, clientData) + Tcl_Time *timePtr; + ClientData clientData; { - return TclpLocaltime( timePtr ); + /* Native scale is 1:1. Nothing is done */ } + +/* + *---------------------------------------------------------------------- + * + * NativeGetTime -- + * + * TIP #233: Gets the current system time in seconds and microseconds + * since the beginning of the epoch: 00:00 UCT, January 1, 1970. + * + * Results: + * Returns the current time in timePtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +NativeGetTime(timePtr, clientData) + Tcl_Time *timePtr; + ClientData clientData; +{ + struct timeval tv; + struct timezone tz; + (void) gettimeofday(&tv, &tz); + timePtr->sec = tv.tv_sec; + timePtr->usec = tv.tv_usec; +} /* *---------------------------------------------------------------------- * * SetTZIfNecessary -- * - * Determines whether a call to 'tzset' is needed prior to the - * next call to 'localtime' or examination of the 'timezone' variable. + * Determines whether a call to 'tzset' is needed prior to the next call + * to 'localtime' or examination of the 'timezone' variable. * * Results: * None. * * Side effects: - * If 'tzset' has never been called in the current process, or if - * the value of the environment variable TZ has changed since the - * last call to 'tzset', then 'tzset' is called again. + * If 'tzset' has never been called in the current process, or if the + * value of the environment variable TZ has changed since the last call + * to 'tzset', then 'tzset' is called again. * *---------------------------------------------------------------------- */ static void -SetTZIfNecessary() { +SetTZIfNecessary() +{ + CONST char *newTZ = getenv("TZ"); - CONST char* newTZ = getenv( "TZ" ); Tcl_MutexLock(&tmMutex); - if ( newTZ == NULL ) { + if (newTZ == NULL) { newTZ = ""; } - if ( lastTZ == NULL || strcmp( lastTZ, newTZ ) ) { - tzset(); - if ( lastTZ == NULL ) { - Tcl_CreateExitHandler( CleanupMemory, (ClientData) NULL ); + if (lastTZ == NULL || strcmp(lastTZ, newTZ)) { + tzset(); + if (lastTZ == NULL) { + Tcl_CreateExitHandler(CleanupMemory, (ClientData) NULL); } else { - Tcl_Free( lastTZ ); + Tcl_Free(lastTZ); } - lastTZ = Tcl_Alloc( strlen( newTZ ) + 1 ); - strcpy( lastTZ, newTZ ); + lastTZ = Tcl_Alloc(strlen(newTZ) + 1); + strcpy(lastTZ, newTZ); } Tcl_MutexUnlock(&tmMutex); - } - + /* *---------------------------------------------------------------------- * * CleanupMemory -- * - * Releases the private copy of the TZ environment variable - * upon exit from Tcl. + * Releases the private copy of the TZ environment variable upon exit + * from Tcl. * * Results: * None. * * Side effects: @@ -442,9 +576,17 @@ * *---------------------------------------------------------------------- */ static void -CleanupMemory( ClientData ignored ) +CleanupMemory(ClientData ignored) { - Tcl_Free( lastTZ ); + Tcl_Free(lastTZ); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: unix/tclXtNotify.c ================================================================== --- unix/tclXtNotify.c +++ unix/tclXtNotify.c @@ -1,33 +1,34 @@ -/* +/* * tclXtNotify.c -- * - * This file contains the notifier driver implementation for the - * Xt intrinsics. + * This file contains the notifier driver implementation for the Xt + * intrinsics. * * Copyright (c) 1997 by Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclXtNotify.c,v 1.6 2004/04/06 22:25:57 dgp Exp $ + * RCS: @(#) $Id: tclXtNotify.c,v 1.6.2.1 2005/08/02 18:16:58 dgp Exp $ */ #include #include "tclInt.h" /* - * This structure is used to keep track of the notifier info for a - * a registered file. + * This structure is used to keep track of the notifier info for a a + * registered file. */ typedef struct FileHandler { int fd; - int mask; /* Mask of desired events: TCL_READABLE, etc. */ - int readyMask; /* Events that have been seen since the - last time FileHandlerEventProc was called - for this file. */ + int mask; /* Mask of desired events: TCL_READABLE, + * etc. */ + int readyMask; /* Events that have been seen since the last + * time FileHandlerEventProc was called for + * this file. */ XtInputId read; /* Xt read callback handle. */ XtInputId write; /* Xt write callback handle. */ XtInputId except; /* Xt exception callback handle. */ Tcl_FileProc *proc; /* Procedure to call, in the style of * Tcl_CreateFileHandler. */ @@ -34,37 +35,36 @@ ClientData clientData; /* Argument to pass to proc. */ struct FileHandler *nextPtr;/* Next in list of all files we care about. */ } FileHandler; /* - * The following structure is what is added to the Tcl event queue when - * file handlers are ready to fire. + * The following structure is what is added to the Tcl event queue when file + * handlers are ready to fire. */ typedef struct FileHandlerEvent { - Tcl_Event header; /* Information that is standard for - * all events. */ - int fd; /* File descriptor that is ready. Used - * to find the FileHandler structure for - * the file (can't point directly to the - * FileHandler structure because it could - * go away while the event is queued). */ + Tcl_Event header; /* Information that is standard for all + * events. */ + int fd; /* File descriptor that is ready. Used to find + * the FileHandler structure for the file + * (can't point directly to the FileHandler + * structure because it could go away while + * the event is queued). */ } FileHandlerEvent; /* - * The following static structure contains the state information for the - * Xt based implementation of the Tcl notifier. + * The following static structure contains the state information for the Xt + * based implementation of the Tcl notifier. */ static struct NotifierState { - XtAppContext appContext; /* The context used by the Xt - * notifier. Can be set with - * TclSetAppContext. */ - int appContextCreated; /* Was it created by us? */ - XtIntervalId currentTimeout; /* Handle of current timer. */ - FileHandler *firstFileHandlerPtr; /* Pointer to head of file handler - * list. */ + XtAppContext appContext; /* The context used by the Xt notifier. Can be + * set with TclSetAppContext. */ + int appContextCreated; /* Was it created by us? */ + XtIntervalId currentTimeout;/* Handle of current timer. */ + FileHandler *firstFileHandlerPtr; + /* Pointer to head of file handler list. */ } notifier; /* * The following static indicates whether this module has been initialized. */ @@ -82,11 +82,11 @@ void InitNotifier _ANSI_ARGS_((void)); static void NotifierExitHandler _ANSI_ARGS_(( ClientData clientData)); static void TimerProc _ANSI_ARGS_((caddr_t clientData, XtIntervalId *id)); -static void CreateFileHandler _ANSI_ARGS_((int fd, int mask, +static void CreateFileHandler _ANSI_ARGS_((int fd, int mask, Tcl_FileProc * proc, ClientData clientData)); static void DeleteFileHandler _ANSI_ARGS_((int fd)); static void SetTimer _ANSI_ARGS_((Tcl_Time * timePtr)); static int WaitForEvent _ANSI_ARGS_((Tcl_Time * timePtr)); @@ -105,69 +105,64 @@ * * Results: * None. * * Side effects: - * Sets the application context used by the notifier. Panics if - * the context is already set when called. + * Sets the application context used by the notifier. Panics if the + * context is already set when called. * *---------------------------------------------------------------------- */ XtAppContext TclSetAppContext(appContext) - XtAppContext appContext; + XtAppContext appContext; { if (!initialized) { - InitNotifier(); + InitNotifier(); } /* * If we already have a context we check whether we were asked to set a * new context. If so, we panic because we try to prevent switching * contexts by mistake. Otherwise, we return the one we have. */ - - if (notifier.appContext != NULL) { - if (appContext != NULL) { - - /* - * We already have a context. We do not allow switching contexts - * after initialization, so we panic. - */ - - Tcl_Panic("TclSetAppContext: multiple application contexts"); - - } - } else { - - /* - * If we get here we have not yet gotten a context, so either create - * one or use the one supplied by our caller. - */ - - if (appContext == NULL) { - - /* - * We must create a new context and tell our caller what it is, so - * she can use it too. - */ - - notifier.appContext = XtCreateApplicationContext(); - notifier.appContextCreated = 1; - } else { - - /* - * Otherwise we remember the context that our caller gave us - * and use it. - */ - - notifier.appContextCreated = 0; - notifier.appContext = appContext; - } - } - + + if (notifier.appContext != NULL) { + if (appContext != NULL) { + /* + * We already have a context. We do not allow switching contexts + * after initialization, so we panic. + */ + + Tcl_Panic("TclSetAppContext: multiple application contexts"); + } + } else { + /* + * If we get here we have not yet gotten a context, so either create + * one or use the one supplied by our caller. + */ + + if (appContext == NULL) { + /* + * We must create a new context and tell our caller what it is, so + * she can use it too. + */ + + notifier.appContext = XtCreateApplicationContext(); + notifier.appContextCreated = 1; + } else { + /* + * Otherwise we remember the context that our caller gave us and + * use it. + */ + + notifier.appContextCreated = 0; + notifier.appContext = appContext; + } + } + return notifier.appContext; } /* *---------------------------------------------------------------------- @@ -187,18 +182,19 @@ void InitNotifier() { Tcl_NotifierProcs notifier; + /* - * Only reinitialize if we are not in exit handling. The notifier - * can get reinitialized after its own exit handler has run, because - * of exit handlers for the I/O and timer sub-systems (order dependency). + * Only reinitialize if we are not in exit handling. The notifier can get + * reinitialized after its own exit handler has run, because of exit + * handlers for the I/O and timer sub-systems (order dependency). */ if (TclInExit()) { - return; + return; } notifier.createFileHandlerProc = CreateFileHandler; notifier.deleteFileHandlerProc = DeleteFileHandler; notifier.setTimerProc = SetTimer; @@ -207,11 +203,11 @@ /* * DO NOT create the application context yet; doing so would prevent * external applications from setting it for us to their own ones. */ - + initialized = 1; memset(¬ifier, 0, sizeof(notifier)); Tcl_CreateExitHandler(NotifierExitHandler, NULL); } @@ -218,12 +214,12 @@ /* *---------------------------------------------------------------------- * * NotifierExitHandler -- * - * This function is called to cleanup the notifier state before - * Tcl is unloaded. + * This function is called to cleanup the notifier state before Tcl is + * unloaded. * * Results: * None. * * Side effects: @@ -235,19 +231,19 @@ static void NotifierExitHandler( ClientData clientData) /* Not used. */ { if (notifier.currentTimeout != 0) { - XtRemoveTimeOut(notifier.currentTimeout); + XtRemoveTimeOut(notifier.currentTimeout); } for (; notifier.firstFileHandlerPtr != NULL; ) { - Tcl_DeleteFileHandler(notifier.firstFileHandlerPtr->fd); + Tcl_DeleteFileHandler(notifier.firstFileHandlerPtr->fd); } if (notifier.appContextCreated) { - XtDestroyApplicationContext(notifier.appContext); - notifier.appContextCreated = 0; - notifier.appContext = NULL; + XtDestroyApplicationContext(notifier.appContext); + notifier.appContextCreated = 0; + notifier.appContext = NULL; } initialized = 0; } /* @@ -280,13 +276,12 @@ if (notifier.currentTimeout != 0) { XtRemoveTimeOut(notifier.currentTimeout); } if (timePtr) { timeout = timePtr->sec * 1000 + timePtr->usec / 1000; - notifier.currentTimeout = - XtAppAddTimeOut(notifier.appContext, (unsigned long) timeout, - TimerProc, NULL); + notifier.currentTimeout = XtAppAddTimeOut(notifier.appContext, + (unsigned long) timeout, TimerProc, NULL); } else { notifier.currentTimeout = 0; } } @@ -293,18 +288,17 @@ /* *---------------------------------------------------------------------- * * TimerProc -- * - * This procedure is the XtTimerCallbackProc used to handle - * timeouts. + * This procedure is the XtTimerCallbackProc used to handle timeouts. * * Results: * None. * * Side effects: - * Processes all queued events. + * Processes all queued events. * *---------------------------------------------------------------------- */ static void @@ -329,25 +323,25 @@ * * Results: * None. * * Side effects: - * Creates a new file handler structure and registers one or more - * input procedures with Xt. + * Creates a new file handler structure and registers one or more input + * procedures with Xt. * *---------------------------------------------------------------------- */ static void CreateFileHandler(fd, mask, proc, clientData) int fd; /* Handle of stream to watch. */ int mask; /* OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, and TCL_EXCEPTION: - * indicates conditions under which - * proc should be called. */ - Tcl_FileProc *proc; /* Procedure to call for each - * selected event. */ + * TCL_WRITABLE, and TCL_EXCEPTION: indicates + * conditions under which proc should be + * called. */ + Tcl_FileProc *proc; /* Procedure to call for each selected + * event. */ ClientData clientData; /* Arbitrary data to pass to proc. */ { FileHandler *filePtr; if (!initialized) { @@ -380,35 +374,32 @@ * Register the file with the Xt notifier, if it hasn't been done yet. */ if (mask & TCL_READABLE) { if (!(filePtr->mask & TCL_READABLE)) { - filePtr->read = - XtAppAddInput(notifier.appContext, fd, XtInputReadMask, - FileProc, filePtr); + filePtr->read = XtAppAddInput(notifier.appContext, fd, + XtInputReadMask, FileProc, filePtr); } } else { if (filePtr->mask & TCL_READABLE) { XtRemoveInput(filePtr->read); } } if (mask & TCL_WRITABLE) { if (!(filePtr->mask & TCL_WRITABLE)) { - filePtr->write = - XtAppAddInput(notifier.appContext, fd, XtInputWriteMask, - FileProc, filePtr); + filePtr->write = XtAppAddInput(notifier.appContext, fd, + XtInputWriteMask, FileProc, filePtr); } } else { if (filePtr->mask & TCL_WRITABLE) { XtRemoveInput(filePtr->write); } } if (mask & TCL_EXCEPTION) { if (!(filePtr->mask & TCL_EXCEPTION)) { - filePtr->except = - XtAppAddInput(notifier.appContext, fd, XtInputExceptMask, - FileProc, filePtr); + filePtr->except = XtAppAddInput(notifier.appContext, fd, + XtInputExceptMask, FileProc, filePtr); } } else { if (filePtr->mask & TCL_EXCEPTION) { XtRemoveInput(filePtr->except); } @@ -419,12 +410,11 @@ /* *---------------------------------------------------------------------- * * DeleteFileHandler -- * - * Cancel a previously-arranged callback arrangement for - * a file. + * Cancel a previously-arranged callback arrangement for a file. * * Results: * None. * * Side effects: @@ -433,12 +423,12 @@ *---------------------------------------------------------------------- */ static void DeleteFileHandler(fd) - int fd; /* Stream id for which to remove - * callback procedure. */ + int fd; /* Stream id for which to remove callback + * procedure. */ { FileHandler *filePtr, *prevPtr; if (!initialized) { InitNotifier(); @@ -445,12 +435,11 @@ } TclSetAppContext(NULL); /* - * Find the entry for the given file (and return if there - * isn't one). + * Find the entry for the given file (and return if there isn't one). */ for (prevPtr = NULL, filePtr = notifier.firstFileHandlerPtr; ; prevPtr = filePtr, filePtr = filePtr->nextPtr) { if (filePtr == NULL) { @@ -492,12 +481,11 @@ * * Results: * None. * * Side effects: - * Makes an entry on the Tcl event queue if the event is - * interesting. + * Makes an entry on the Tcl event queue if the event is interesting. * *---------------------------------------------------------------------- */ static void @@ -527,11 +515,11 @@ */ if (!(filePtr->mask & mask) || (filePtr->readyMask & mask)) { return; } - + /* * This is an interesting event, so put it onto the event queue. */ filePtr->readyMask |= mask; @@ -550,20 +538,20 @@ /* *---------------------------------------------------------------------- * * FileHandlerEventProc -- * - * This procedure is called by Tcl_ServiceEvent when a file event - * reaches the front of the event queue. This procedure is - * responsible for actually handling the event by invoking the - * callback for the file handler. + * This procedure is called by Tcl_ServiceEvent when a file event reaches + * the front of the event queue. This procedure is responsible for + * actually handling the event by invoking the callback for the file + * handler. * * Results: - * Returns 1 if the event was handled, meaning it should be removed - * from the queue. Returns 0 if the event was not handled, meaning - * it should stay on the queue. The only time the event isn't - * handled is if the TCL_FILE_EVENTS flag bit isn't set. + * Returns 1 if the event was handled, meaning it should be removed from + * the queue. Returns 0 if the event was not handled, meaning it should + * stay on the queue. The only time the event isn't handled is if the + * TCL_FILE_EVENTS flag bit isn't set. * * Side effects: * Whatever the file handler's callback procedure does. * *---------------------------------------------------------------------- @@ -570,12 +558,12 @@ */ static int FileHandlerEventProc(evPtr, flags) Tcl_Event *evPtr; /* Event to service. */ - int flags; /* Flags that indicate what events to - * handle, such as TCL_FILE_EVENTS. */ + int flags; /* Flags that indicate what events to handle, + * such as TCL_FILE_EVENTS. */ { FileHandler *filePtr; FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr; int mask; @@ -583,13 +571,13 @@ return 0; } /* * Search through the file handlers to find the one whose handle matches - * the event. We do this rather than keeping a pointer to the file - * handler directly in the event, so that the handler can be deleted - * while the event is queued without leaving a dangling pointer. + * the event. We do this rather than keeping a pointer to the file handler + * directly in the event, so that the handler can be deleted while the + * event is queued without leaving a dangling pointer. */ for (filePtr = notifier.firstFileHandlerPtr; filePtr != NULL; filePtr = filePtr->nextPtr) { if (filePtr->fd != fileEvPtr->fd) { @@ -596,18 +584,18 @@ continue; } /* * The code is tricky for two reasons: - * 1. The file handler's desired events could have changed - * since the time when the event was queued, so AND the - * ready mask with the desired mask. - * 2. The file could have been closed and re-opened since - * the time when the event was queued. This is why the - * ready mask is stored in the file handler rather than - * the queued event: it will be zeroed when a new - * file handler is created for the newly opened file. + * 1. The file handler's desired events could have changed since the + * time when the event was queued, so AND the ready mask with the + * desired mask. + * 2. The file could have been closed and re-opened since the time + * when the event was queued. This is why the ready mask is stored + * in the file handler rather than the queued event: it will be + * zeroed when a new file handler is created for the newly opened + * file. */ mask = filePtr->readyMask & filePtr->mask; filePtr->readyMask = 0; if (mask != 0) { @@ -621,18 +609,18 @@ /* *---------------------------------------------------------------------- * * WaitForEvent -- * - * This function is called by Tcl_DoOneEvent to wait for new - * events on the message queue. If the block time is 0, then - * Tcl_WaitForEvent just polls without blocking. + * This function is called by Tcl_DoOneEvent to wait for new events on + * the message queue. If the block time is 0, then Tcl_WaitForEvent just + * polls without blocking. * * Results: - * Returns 1 if an event was found, else 0. This ensures that - * Tcl_DoOneEvent will return 1, even if the event is handled - * by non-Tcl code. + * Returns 1 if an event was found, else 0. This ensures that + * Tcl_DoOneEvent will return 1, even if the event is handled by non-Tcl + * code. * * Side effects: * Queues file events that are detected by the select. * *---------------------------------------------------------------------- @@ -649,20 +637,29 @@ } TclSetAppContext(NULL); if (timePtr) { - timeout = timePtr->sec * 1000 + timePtr->usec / 1000; - if (timeout == 0) { - if (XtAppPending(notifier.appContext)) { - goto process; - } else { - return 0; - } - } else { - Tcl_SetTimer(timePtr); - } - } -process: + timeout = timePtr->sec * 1000 + timePtr->usec / 1000; + if (timeout == 0) { + if (XtAppPending(notifier.appContext)) { + goto process; + } else { + return 0; + } + } else { + Tcl_SetTimer(timePtr); + } + } + + process: XtAppProcessEvent(notifier.appContext, XtIMAll); return 1; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: win/.cvsignore ================================================================== --- win/.cvsignore +++ win/.cvsignore @@ -11,5 +11,7 @@ Makefile tcl.hpj tclConfig.sh nmakehlp.exe .#* +tcl.sln +tcl.suo Index: win/Makefile.in ================================================================== --- win/Makefile.in +++ win/Makefile.in @@ -3,11 +3,11 @@ # then it is a template for a Makefile; to generate the actual Makefile, # run "./configure", which is a configuration script generated by the # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # -# RCS: @(#) $Id: Makefile.in,v 1.84 2004/11/29 22:41:58 andreas_kupries Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.84.2.15 2005/09/23 16:47:35 dgp Exp $ VERSION = @TCL_VERSION@ #---------------------------------------------------------------- # Things you can change to personalize the Makefile for your own @@ -100,19 +100,21 @@ MAN2TCLFLAGS = @MAN2TCLFLAGS@ SRC_DIR = @srcdir@ ROOT_DIR = @srcdir@/.. GENERIC_DIR = @srcdir@/../generic +TOMMATH_DIR = @srcdir@/../libtommath WIN_DIR = @srcdir@ COMPAT_DIR = @srcdir@/../compat # Converts a POSIX path to a Windows native path. CYGPATH = @CYGPATH@ GENERIC_DIR_NATIVE = $(shell $(CYGPATH) '$(GENERIC_DIR)') +TOMMATH_DIR_NATIVE = $(shell $(CYGPATH) '$(TOMMATH_DIR)') WIN_DIR_NATIVE = $(shell $(CYGPATH) '$(WIN_DIR)') -ROOT_DIR_NATIVE = $(shell $(CYGPATH) '$(ROOT_DIR)') +ROOT_DIR_NATIVE = $(shell $(CYGPATH) '$(ROOT_DIR)' | sed 's/\\*$$//' ) LIBRARY_DIR = $(shell echo '$(ROOT_DIR_NATIVE)/library' | sed 's/\\/\//g' ) DLLSUFFIX = @DLLSUFFIX@ LIBSUFFIX = @LIBSUFFIX@ @@ -154,11 +156,11 @@ # Setting the VPATH variable to a list of paths will cause the # makefile to look into these paths when resolving .c to .obj # dependencies. -VPATH = $(GENERIC_DIR):$(WIN_DIR):$(COMPAT_DIR) +VPATH = $(GENERIC_DIR):$(TOMMATH_DIR):$(WIN_DIR):$(COMPAT_DIR) AR = @AR@ RANLIB = @RANLIB@ CC = @CC@ RC = @RC@ @@ -184,18 +186,20 @@ SHELL = @SHELL@ RM = rm -f COPY = cp CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} \ --I"${GENERIC_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \ +-I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH -DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" \ +-I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \ ${COMPILE_DEBUG_FLAGS} CC_OBJNAME = @CC_OBJNAME@ CC_EXENAME = @CC_EXENAME@ STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \ --I"${GENERIC_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \ +-I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH -DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" \ +-I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \ ${COMPILE_DEBUG_FLAGS} TCLTEST_OBJS = \ tclTest.$(OBJEXT) \ tclTestObj.$(OBJEXT) \ @@ -236,10 +240,11 @@ tclIndexObj.$(OBJEXT) \ tclInterp.$(OBJEXT) \ tclIO.$(OBJEXT) \ tclIOCmd.$(OBJEXT) \ tclIOGT.$(OBJEXT) \ + tclIORChan.$(OBJEXT) \ tclIOSock.$(OBJEXT) \ tclIOUtil.$(OBJEXT) \ tclLink.$(OBJEXT) \ tclLiteral.$(OBJEXT) \ tclListObj.$(OBJEXT) \ @@ -261,21 +266,87 @@ tclRegexp.$(OBJEXT) \ tclResolve.$(OBJEXT) \ tclResult.$(OBJEXT) \ tclScan.$(OBJEXT) \ tclStringObj.$(OBJEXT) \ + tclStrToD.$(OBJEXT) \ tclStubInit.$(OBJEXT) \ tclStubLib.$(OBJEXT) \ tclThread.$(OBJEXT) \ tclThreadAlloc.$(OBJEXT) \ tclThreadJoin.$(OBJEXT) \ tclThreadStorage.$(OBJEXT) \ tclTimer.$(OBJEXT) \ + tclTomMathInterface.$(OBJEXT) \ tclTrace.$(OBJEXT) \ tclUtf.$(OBJEXT) \ tclUtil.$(OBJEXT) \ tclVar.$(OBJEXT) + +TOMMATH_OBJS = \ + bncore.${OBJEXT} \ + bn_reverse.${OBJEXT} \ + bn_fast_s_mp_mul_digs.${OBJEXT} \ + 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} \ + bn_mp_div.${OBJEXT} \ + bn_mp_div_d.${OBJEXT} \ + bn_mp_div_2.${OBJEXT} \ + 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} \ + bn_mp_init_multi.${OBJEXT} \ + bn_mp_init_set.${OBJEXT} \ + bn_mp_init_size.${OBJEXT} \ + bn_mp_karatsuba_mul.${OBJEXT} \ + bn_mp_karatsuba_sqr.$(OBJEXT) \ + bn_mp_lshd.${OBJEXT} \ + bn_mp_mod.${OBJEXT} \ + bn_mp_mod_2d.${OBJEXT} \ + bn_mp_mul.${OBJEXT} \ + 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} \ + bn_s_mp_sqr.${OBJEXT} \ + bn_s_mp_sub.${OBJEXT} + WIN_OBJS = \ tclWin32Dll.$(OBJEXT) \ tclWinChan.$(OBJEXT) \ tclWinConsole.$(OBJEXT) \ @@ -302,11 +373,11 @@ STUB_OBJS = tclStubLib.$(OBJEXT) TCLSH_OBJS = tclAppInit.$(OBJEXT) -TCL_OBJS = ${GENERIC_OBJS} ${WIN_OBJS} ${COMPAT_OBJS} +TCL_OBJS = ${GENERIC_OBJS} $(TOMMATH_OBJS) ${WIN_OBJS} ${COMPAT_OBJS} TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n] all: binaries libraries doc @@ -466,11 +537,21 @@ # so that make doesn't try to automatically regenerate the .c file. gendate: bison --output-file=$(GENERIC_DIR)/tclDate.c \ --name-prefix=TclDate \ + --no-lines \ $(GENERIC_DIR)/tclGetDate.y + +# The following target generates the file generic/tommath.h. +# It needs to be run (and the results checked) after updating +# to a new release of libtommath. + +gentommath_h: + $(TCL_EXE) "$(ROOT_DIR_NATIVE)\tools\fix_tommath_h.tcl" \ + "$(TOMMATH_DIR_NATIVE)\tommath.h" \ + > "$(GENERIC_DIR_NATIVE)\tommath.h" install: all install-binaries install-libraries install-doc install-binaries: binaries @for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)" ; \ @@ -557,21 +638,21 @@ @echo "Installing library http1.0 directory"; @for j in $(ROOT_DIR)/library/http1.0/*.tcl; \ do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; - @echo "Installing package http 2.5.0 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.2/http-2.5.0.tm; + @echo "Installing package http 2.5.1 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.2/http-2.5.1.tm; @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; @echo "Installing package msgcat 1.4.1 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.4.1.tm; - @echo "Installing package tcltest 2.2.7 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.3/tcltest-2.2.7.tm; + @echo "Installing package tcltest 2.2.8 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.3/tcltest-2.2.8.tm; @echo "Installing encodings"; @for i in $(ROOT_DIR)/library/encoding/*.enc ; do \ $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \ done; @@ -648,11 +729,11 @@ $(RM) $(TCLSH) $(TCLTEST) $(CAT32) $(RM) *.pch *.ilk *.pdb distclean: clean $(RM) Makefile config.status config.cache config.log tclConfig.sh \ - tcl.hpj + tcl.hpj config.status.lineno # # Regenerate the stubs files. # Index: win/README ================================================================== --- win/README +++ win/README @@ -1,8 +1,8 @@ Tcl 8.5 for Windows -RCS: @(#) $Id: README,v 1.32 2004/07/01 10:08:11 dkf Exp $ +RCS: @(#) $Id: README,v 1.32.2.1 2005/08/02 18:16:58 dgp Exp $ 1. Introduction --------------- This is the directory where you configure and compile the Windows @@ -28,31 +28,20 @@ or Msys + Mingw - http://prdownloads.sourceforge.net/tcl/msys_mingw6.zip + http://prdownloads.sourceforge.net/tcl/msys_mingw8.zip This Msys + Mingw download is the minimal environment needed to build Tcl/Tk under Windows. It includes a shell environment and gcc. The release is designed to make it as easy a possible to build Tcl/Tk. To install, you just download the zip file and extract the files into a directory. The README.TXT file describes how to launch the msys shell, you then run the configure script in the tcl/win directory. - - or - - Cygwin 1.1 or newer (See http://sources.redhat.com/cygwin) - - Mingw 2.0 (http://prdownloads.sourceforge.net/mingw/MinGW-2.0.0-3.exe) - - Extract the contents of the archive file into /usr/local/mingw - and place /usr/local/mingw/bin at the front of your PATH env var - before running the configure script in the tcl/win directory. - In practice, this release is built with Visual C++ 6.0 and the TEA Makefile. If you are building with Visual C++, in the "win" subdirectory of the Index: win/README.binary ================================================================== --- win/README.binary +++ win/README.binary @@ -1,13 +1,13 @@ Tcl/Tk 8.5 for Windows, Binary Distribution -RCS: @(#) $Id: README.binary,v 1.38 2004/07/01 10:08:11 dkf Exp $ +RCS: @(#) $Id: README.binary,v 1.38.2.2 2005/07/12 20:37:31 kennykb Exp $ 1. Introduction --------------- -This directory contains the binary distribution of Tcl/Tk 8.5a2 for +This directory contains the binary distribution of Tcl/Tk 8.5a4 for Windows. It was compiled with Microsoft Visual C++ 6.0 using Win32 API, so that it will run under Windows 98, NT, 2000 and XP. Tcl provides a powerful platform for creating integration applications that tie together diverse applications, protocols, devices, and Index: win/configure ================================================================== --- win/configure +++ win/configure @@ -1,11 +1,10 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.57. +# Generated by GNU Autoconf 2.59. # -# Copyright 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, 2002 -# Free Software Foundation, Inc. +# Copyright (C) 2003 Free Software Foundation, Inc. # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## --------------------- ## ## M4sh Initialization. ## ## --------------------- ## @@ -18,13 +17,14 @@ # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then set -o posix fi +DUALCASE=1; export DUALCASE # for MKS sh # Support unset when possible. -if (FOO=FOO; unset FOO) >/dev/null 2>&1; then +if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then as_unset=unset else as_unset=false fi @@ -39,11 +39,11 @@ for as_var in \ LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ LC_TELEPHONE LC_TIME do - if (set +x; test -n "`(eval $as_var=C; export $as_var) 2>&1`"); then + if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then eval $as_var=C; export $as_var else $as_unset $as_var fi done @@ -216,20 +216,21 @@ rm -f conf$$ conf$$.exe conf$$.file if mkdir -p . 2>/dev/null; then as_mkdir_p=: else + test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_executable_p="test -f" # Sed expression to map a string onto a valid CPP name. -as_tr_cpp="sed y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g" +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. -as_tr_sh="sed y%*+%pp%;s%[^_$as_cr_alnum]%_%g" +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" # IFS # We need space, tab and new line, in precisely that order. as_nl=' @@ -665,11 +666,11 @@ esac done # Be sure to have absolute paths. for ac_var in bindir sbindir libexecdir datadir sysconfdir sharedstatedir \ - localstatedir libdir includedir oldincludedir infodir mandir + localstatedir libdir includedir oldincludedir infodir mandir do eval ac_val=$`echo $ac_var` case $ac_val in [\\/$]* | ?:[\\/]* ) ;; *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 @@ -705,14 +706,14 @@ if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then its parent. ac_confdir=`(dirname "$0") 2>/dev/null || $as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$0" : 'X\(//\)[^/]' \| \ - X"$0" : 'X\(//\)$' \| \ - X"$0" : 'X\(/\)' \| \ - . : '\(.\)' 2>/dev/null || + X"$0" : 'X\(//\)[^/]' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || echo X"$0" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } /^X\(\/\/\)[^/].*/{ s//\1/; q; } /^X\(\/\/\)$/{ s//\1/; q; } /^X\(\/\).*/{ s//\1/; q; } @@ -800,13 +801,13 @@ _ACEOF cat <<_ACEOF Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX - [$ac_default_prefix] + [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX - [PREFIX] + [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. @@ -892,16 +893,49 @@ ac_top_srcdir=$srcdir ;; *) # Relative path. ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_builddir$srcdir ;; esac -# Don't blindly perform a `cd "$ac_dir"/$ac_foo && pwd` since $ac_foo can be -# absolute. -ac_abs_builddir=`cd "$ac_dir" && cd $ac_builddir && pwd` -ac_abs_top_builddir=`cd "$ac_dir" && cd ${ac_top_builddir}. && pwd` -ac_abs_srcdir=`cd "$ac_dir" && cd $ac_srcdir && pwd` -ac_abs_top_srcdir=`cd "$ac_dir" && cd $ac_top_srcdir && pwd` + +# Do not use `cd foo && pwd` to compute absolute paths, because +# the directories may not exist. +case `pwd` in +.) ac_abs_builddir="$ac_dir";; +*) + case "$ac_dir" in + .) ac_abs_builddir=`pwd`;; + [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; + *) ac_abs_builddir=`pwd`/"$ac_dir";; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_builddir=${ac_top_builddir}.;; +*) + case ${ac_top_builddir}. in + .) ac_abs_top_builddir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; + *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_srcdir=$ac_srcdir;; +*) + case $ac_srcdir in + .) ac_abs_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; + *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_srcdir=$ac_top_srcdir;; +*) + case $ac_top_srcdir in + .) ac_abs_top_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; + *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; + esac;; +esac cd $ac_dir # Check for guested configure; otherwise get Cygnus style configure. if test -f $ac_srcdir/configure.gnu; then echo @@ -908,11 +942,11 @@ $SHELL $ac_srcdir/configure.gnu --help=recursive elif test -f $ac_srcdir/configure; then echo $SHELL $ac_srcdir/configure --help=recursive elif test -f $ac_srcdir/configure.ac || - test -f $ac_srcdir/configure.in; then + test -f $ac_srcdir/configure.in; then echo $ac_configure --help else echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi @@ -922,12 +956,11 @@ test -n "$ac_init_help" && exit 0 if $ac_init_version; then cat <<\_ACEOF -Copyright 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, 2002 -Free Software Foundation, Inc. +Copyright (C) 2003 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit 0 fi @@ -935,11 +968,11 @@ cat >&5 <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by $as_me, which was -generated by GNU Autoconf 2.57. Invocation command line was +generated by GNU Autoconf 2.59. Invocation command line was $ $0 $@ _ACEOF { @@ -1012,23 +1045,23 @@ case $ac_pass in 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;; 2) ac_configure_args1="$ac_configure_args1 '$ac_arg'" if test $ac_must_keep_next = true; then - ac_must_keep_next=false # Got value, back to normal. + ac_must_keep_next=false # Got value, back to normal. else - case $ac_arg in - *=* | --config-cache | -C | -disable-* | --disable-* \ - | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ - | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ - | -with-* | --with-* | -without-* | --without-* | --x) - case "$ac_configure_args0 " in - "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; - esac - ;; - -* ) ac_must_keep_next=true ;; - esac + case $ac_arg in + *=* | --config-cache | -C | -disable-* | --disable-* \ + | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ + | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ + | -with-* | --with-* | -without-* | --without-* | --x) + case "$ac_configure_args0 " in + "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; + esac + ;; + -* ) ac_must_keep_next=true ;; + esac fi ac_configure_args="$ac_configure_args$ac_sep'$ac_arg'" # Get rid of the leading space. ac_sep=" " ;; @@ -1058,16 +1091,16 @@ { (set) 2>&1 | case `(ac_space='"'"' '"'"'; set | grep ac_space) 2>&1` in *ac_space=\ *) sed -n \ - "s/'"'"'/'"'"'\\\\'"'"''"'"'/g; - s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='"'"'\\2'"'"'/p" + "s/'"'"'/'"'"'\\\\'"'"''"'"'/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='"'"'\\2'"'"'/p" ;; *) sed -n \ - "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" + "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" ;; esac; } echo @@ -1092,11 +1125,11 @@ _ASBOX echo for ac_var in $ac_subst_files do eval ac_val=$`echo $ac_var` - echo "$ac_var='"'"'$ac_val'"'"'" + echo "$ac_var='"'"'$ac_val'"'"'" done | sort echo fi if test -s confdefs.h; then @@ -1111,11 +1144,11 @@ fi test "$ac_signal" != 0 && echo "$as_me: caught signal $ac_signal" echo "$as_me: exit $exit_status" } >&5 - rm -f core core.* *.core && + rm -f core *.core && rm -rf conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal @@ -1191,11 +1224,11 @@ # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in `(set) 2>&1 | - sed -n 's/^ac_env_\([a-zA-Z_0-9]*\)_set=.*/\1/p'`; do + sed -n 's/^ac_env_\([a-zA-Z_0-9]*\)_set=.*/\1/p'`; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val="\$ac_cv_env_${ac_var}_value" eval ac_new_val="\$ac_env_${ac_var}_value" case $ac_old_set,$ac_new_set in @@ -1208,17 +1241,17 @@ echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then - { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5 + { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5 echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} - { echo "$as_me:$LINENO: former value: $ac_old_val" >&5 + { echo "$as_me:$LINENO: former value: $ac_old_val" >&5 echo "$as_me: former value: $ac_old_val" >&2;} - { echo "$as_me:$LINENO: current value: $ac_new_val" >&5 + { echo "$as_me:$LINENO: current value: $ac_new_val" >&5 echo "$as_me: current value: $ac_new_val" >&2;} - ac_cache_corrupted=: + ac_cache_corrupted=: fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in @@ -1272,11 +1305,11 @@ SHELL=/bin/sh TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 -TCL_PATCH_LEVEL="a2" +TCL_PATCH_LEVEL="a4" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.3 TCL_DDE_MAJOR_VERSION=1 TCL_DDE_MINOR_VERSION=3 @@ -1646,11 +1679,10 @@ ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -1666,12 +1698,12 @@ ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files a.out a.exe b.out" # Try to create an executable without -o first, disregard a.out. # It will help us diagnose broken compilers, and finding out an intuition # of exeext. -echo "$as_me:$LINENO: checking for C compiler default output" >&5 -echo $ECHO_N "checking for C compiler default output... $ECHO_C" >&6 +echo "$as_me:$LINENO: checking for C compiler default output file name" >&5 +echo $ECHO_N "checking for C compiler default output file name... $ECHO_C" >&6 ac_link_default=`echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` if { (eval echo "$as_me:$LINENO: \"$ac_link_default\"") >&5 (eval $ac_link_default) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 @@ -1687,27 +1719,27 @@ for ac_file in a_out.exe a.exe conftest.exe a.out conftest a.* conftest.* b.out do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) - ;; + ;; conftest.$ac_ext ) - # This is the source file. - ;; + # This is the source file. + ;; [ab].out ) - # We found the default executable, but exeext='' is most - # certainly right. - break;; + # We found the default executable, but exeext='' is most + # certainly right. + break;; *.* ) - ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` - # FIXME: I believe we export ac_cv_exeext for Libtool, - # but it would be cool to find out if it's true. Does anybody - # maintain Libtool? --akim. - export ac_cv_exeext - break;; + ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + # FIXME: I believe we export ac_cv_exeext for Libtool, + # but it would be cool to find out if it's true. Does anybody + # maintain Libtool? --akim. + export ac_cv_exeext + break;; * ) - break;; + break;; esac done else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 @@ -1777,12 +1809,12 @@ for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) ;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` - export ac_cv_exeext - break;; + export ac_cv_exeext + break;; * ) break;; esac done else { { echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link @@ -1803,11 +1835,10 @@ echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6 if test "${ac_cv_objext+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -1854,11 +1885,10 @@ echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6 if test "${ac_cv_c_compiler_gnu+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -1874,15 +1904,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -1891,11 +1931,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_compiler_gnu=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu fi echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5 echo "${ECHO_T}$ac_cv_c_compiler_gnu" >&6 @@ -1907,11 +1947,10 @@ echo $ECHO_N "checking whether $CC accepts -g... $ECHO_C" >&6 if test "${ac_cv_prog_cc_g+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -1924,15 +1963,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -1941,11 +1990,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_prog_cc_g=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5 echo "${ECHO_T}$ac_cv_prog_cc_g" >&6 if test "$ac_test_CFLAGS" = set; then CFLAGS=$ac_save_CFLAGS @@ -1968,11 +2017,10 @@ echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_cv_prog_cc_stdc=no ac_save_CC=$CC cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -1996,10 +2044,20 @@ va_start (v,p); s = g (p, va_arg (v,int)); va_end (v); return s; } + +/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has + function prototypes and stuff, but not '\xHH' hex character constants. + These don't provoke an error unfortunately, instead are silently treated + as 'x'. The following induces an error, until -std1 is added to get + proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an + array size at least. It's necessary to write '\x00'==0 to get something + that's true only with -std1. */ +int osf4_cc_array ['\x00' == 0 ? 1 : -1]; + int test (int i, double x); struct s1 {int (*f) (int a);}; struct s2 {int (*f) (double a);}; int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); int argc; @@ -2022,15 +2080,25 @@ for ac_arg in "" -qlanglvl=ansi -std1 -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -2039,11 +2107,11 @@ else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi -rm -f conftest.$ac_objext +rm -f conftest.err conftest.$ac_objext done rm -f conftest.$ac_ext conftest.$ac_objext CC=$ac_save_CC fi @@ -2067,38 +2135,46 @@ choke me #endif _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then for ac_declaration in \ - ''\ - '#include ' \ + '' \ 'extern "C" void std::exit (int) throw (); using std::exit;' \ 'extern "C" void std::exit (int); using std::exit;' \ 'extern "C" void exit (int) throw ();' \ 'extern "C" void exit (int);' \ 'void exit (int);' do cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ -#include $ac_declaration +#include int main () { exit (42); ; @@ -2105,15 +2181,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -2122,13 +2208,12 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 continue fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -2141,15 +2226,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -2157,11 +2252,11 @@ else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext done rm -f conftest* if test -n "$ac_declaration"; then echo '#ifdef __cplusplus' >>confdefs.h echo $ac_declaration >>confdefs.h @@ -2171,11 +2266,11 @@ else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu @@ -2316,11 +2411,11 @@ # Checks to see if the make progeam sets the $MAKE variable. #-------------------------------------------------------------------- echo "$as_me:$LINENO: checking whether ${MAKE-make} sets \$(MAKE)" >&5 echo $ECHO_N "checking whether ${MAKE-make} sets \$(MAKE)... $ECHO_C" >&6 -set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y,./+-,__p_,'` +set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y,:./+-,___p_,'` if eval "test \"\${ac_cv_prog_make_${ac_make}_set+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.make <<\_ACEOF all: @@ -2356,11 +2451,10 @@ if test "${ac_cv_cygwin+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -2377,15 +2471,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -2394,11 +2498,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_cygwin=yes fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_cygwin" >&5 echo "${ECHO_T}$ac_cv_cygwin" >&6 if test "$ac_cv_cygwin" = "yes" ; then @@ -2419,11 +2523,10 @@ else if test "$cross_compiling" = yes; then tcl_cv_seh=no else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -2462,11 +2565,11 @@ sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_seh=no fi -rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi echo "$as_me:$LINENO: result: $tcl_cv_seh" >&5 echo "${ECHO_T}$tcl_cv_seh" >&6 @@ -2488,11 +2591,10 @@ echo $ECHO_N "checking for EXCEPTION_DISPOSITION support in include files... $ECHO_C" >&6 if test "${tcl_cv_eh_disposition+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -2511,15 +2613,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -2528,11 +2640,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_eh_disposition=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_eh_disposition" >&5 echo "${ECHO_T}$tcl_cv_eh_disposition" >&6 if test "$tcl_cv_eh_disposition" = "no" ; then @@ -2551,11 +2663,10 @@ echo $ECHO_N "checking for LPFN_ACCEPT support in winsock2.h... $ECHO_C" >&6 if test "${tcl_cv_lpfn_decls+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -2575,15 +2686,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -2592,11 +2713,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_lpfn_decls=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_lpfn_decls" >&5 echo "${ECHO_T}$tcl_cv_lpfn_decls" >&6 if test "$tcl_cv_lpfn_decls" = "no" ; then @@ -2615,11 +2736,10 @@ echo $ECHO_N "checking for winnt.h that ignores VOID define... $ECHO_C" >&6 if test "${tcl_cv_winnt_ignore_void+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -2641,15 +2761,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -2658,11 +2788,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_winnt_ignore_void=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_winnt_ignore_void" >&5 echo "${ECHO_T}$tcl_cv_winnt_ignore_void" >&6 if test "$tcl_cv_winnt_ignore_void" = "yes" ; then @@ -2687,11 +2817,10 @@ echo $ECHO_N "checking for alloca declaration in malloc.h... $ECHO_C" >&6 if test "${tcl_cv_malloc_decl_alloca+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -2711,15 +2840,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -2728,11 +2867,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_malloc_decl_alloca=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_malloc_decl_alloca" >&5 echo "${ECHO_T}$tcl_cv_malloc_decl_alloca" >&6 if test "$tcl_cv_malloc_decl_alloca" = "no" && @@ -2752,11 +2891,10 @@ echo $ECHO_N "checking for cast to union support... $ECHO_C" >&6 if test "${tcl_cv_cast_to_union+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -2772,15 +2910,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -2789,11 +2937,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_cast_to_union=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_cast_to_union" >&5 echo "${ECHO_T}$tcl_cv_cast_to_union" >&6 if test "$tcl_cv_cast_to_union" = "yes"; then @@ -2813,11 +2961,10 @@ echo $ECHO_N "checking for FINDEX_INFO_LEVELS in winbase.h... $ECHO_C" >&6 if test "${tcl_cv_findex_enums+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -2837,15 +2984,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -2854,11 +3011,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_findex_enums=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_findex_enums" >&5 echo "${ECHO_T}$tcl_cv_findex_enums" >&6 if test "$tcl_cv_findex_enums" = "no"; then @@ -2876,11 +3033,10 @@ echo $ECHO_N "checking for MWMO_ALERTABLE in winuser.h... $ECHO_C" >&6 if test "${tcl_cv_mwmo_alertable+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -2899,15 +3055,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -2916,11 +3082,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_mwmo_alertable=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_mwmo_alertable" >&5 echo "${ECHO_T}$tcl_cv_mwmo_alertable" >&6 if test "$tcl_cv_mwmo_alertable" = "no"; then @@ -2965,16 +3131,10 @@ # allocator that significantly reduces lock contention cat >>confdefs.h <<\_ACEOF #define USE_THREAD_ALLOC 1 _ACEOF - # USE_THREAD_STORAGE tells us to use the new generic thread - # storage subsystem. - cat >>confdefs.h <<\_ACEOF -#define USE_THREAD_STORAGE 1 -_ACEOF - else TCL_THREADS=0 echo "$as_me:$LINENO: result: no (default)" >&5 echo "${ECHO_T}no (default)" >&6 fi @@ -3158,11 +3318,11 @@ echo "$as_me: WARNING: \"64bit mode not supported with GCC on Windows\"" >&2;} fi SHLIB_LD="" SHLIB_LD_LIBS="" LIBS="" - LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32" + LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32 -lole32 -loleaut32 -luuid" STLIB_LD='${AR} cr' RC_OUT=-o RC_TYPE= RC_INCLUDE=--include RC_DEFINE=--define @@ -3243,11 +3403,11 @@ SHLIB_SUFFIX=.dll EXTRA_CFLAGS="${extra_cflags}" CFLAGS_DEBUG=-g - CFLAGS_OPTIMIZE=-O + CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer" CFLAGS_WARNING="-Wall -Wconversion" LDFLAGS_DEBUG= LDFLAGS_OPTIMIZE= # Specify the CC output file names based on the target name @@ -3303,45 +3463,51 @@ # We have to know where the SDK is installed. if test "$do64bit" = "yes" ; then if test "x${MSSDK}x" = "xx" ; then MSSDK="C:/Progra~1/Microsoft SDK" fi - # In order to work in the tortured autoconf environment, - # we need to ensure that this path has no spaces - MSSDK=$(cygpath -w -s "$MSSDK" | sed -e 's!\\!/!g') + MSSDK=`echo "$MSSDK" | sed -e 's!\\\!/!g'` if test ! -d "${MSSDK}/bin/win64" ; then { echo "$as_me:$LINENO: WARNING: \"could not find 64-bit SDK to enable 64bit mode\"" >&5 echo "$as_me: WARNING: \"could not find 64-bit SDK to enable 64bit mode\"" >&2;} do64bit="no" fi fi if test "$do64bit" = "yes" ; then # All this magic is necessary for the Win64 SDK RC1 - hobbs - CC="${MSSDK}/Bin/Win64/cl.exe \ - -I${MSSDK}/Include/prerelease \ - -I${MSSDK}/Include/Win64/crt \ - -I${MSSDK}/Include/Win64/crt/sys \ - -I${MSSDK}/Include" - RC="${MSSDK}/bin/rc.exe" + # The space-based-path will work for the Makefile, but will + # not work if AC_TRY_COMPILE is called. TEA has the + # TEA_PATH_NOSPACE to avoid this issue. + CC="\"${MSSDK}/Bin/Win64/cl.exe\" \ + -I\"${MSSDK}/Include/prerelease\" \ + -I\"${MSSDK}/Include/Win64/crt\" \ + -I\"${MSSDK}/Include/Win64/crt/sys\" \ + -I\"${MSSDK}/Include\"" + RC="\"${MSSDK}/bin/rc.exe\"" CFLAGS_DEBUG="-nologo -Zi -Od ${runtime}d" - CFLAGS_OPTIMIZE="-nologo -O2 -Gs ${runtime}" - lflags="-MACHINE:IA64 -LIBPATH:${MSSDK}/Lib/IA64 \ - -LIBPATH:${MSSDK}/Lib/Prerelease/IA64" - STLIB_LD="${MSSDK}/bin/win64/lib.exe -nologo ${lflags}" - LINKBIN="${MSSDK}/bin/win64/link.exe ${lflags}" + # Do not use -O2 for Win64 - this has proved buggy in code gen. + CFLAGS_OPTIMIZE="-nologo -O1 ${runtime}" + lflags="-MACHINE:IA64 -LIBPATH:\"${MSSDK}/Lib/IA64\" \ + -LIBPATH:\"${MSSDK}/Lib/Prerelease/IA64\" -nologo" + LINKBIN="\"${MSSDK}/bin/win64/link.exe\"" else RC="rc" + # -Od - no optimization + # -WX - warnings as errors CFLAGS_DEBUG="-nologo -Z7 -Od -WX ${runtime}d" - CFLAGS_OPTIMIZE="-nologo -Oti -Gs -GD ${runtime}" - STLIB_LD="lib -nologo" - LINKBIN="link -link50compat" + # -O2 - create fast code (/Og /Oi /Ot /Oy /Ob2 /Gs /GF /Gy) + CFLAGS_OPTIMIZE="-nologo -O2 ${runtime}" + lflags="-nologo" + LINKBIN="link" fi - SHLIB_LD="${LINKBIN} -dll -nologo -incremental:no" LIBS="user32.lib advapi32.lib" - LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib" + LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib" + SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}" + # link -lib only works when -lib is the first arg + STLIB_LD="${LINKBIN} -lib ${lflags}" RC_OUT=-fo RC_TYPE=-r RC_INCLUDE=-i RC_DEFINE=-d RES=res @@ -3348,13 +3514,13 @@ MAKE_LIB="\${STLIB_LD} -out:\$@" POST_MAKE_LIB= MAKE_EXE="\${CC} -Fe\$@" LIBPREFIX="" - EXTRA_CFLAGS="-YX" + EXTRA_CFLAGS="" CFLAGS_WARNING="-W3" - LDFLAGS_DEBUG="-debug:full -debugtype:both" + LDFLAGS_DEBUG="-debug:full" LDFLAGS_OPTIMIZE="-release" # Specify the CC output file names based on the target name CC_OBJNAME="-Fo\$@" CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) '\$@')\"" @@ -3484,11 +3650,10 @@ # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3495,11 +3660,11 @@ #ifdef __STDC__ # include #else # include #endif - Syntax error + Syntax error _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err @@ -3507,10 +3672,11 @@ cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes @@ -3527,11 +3693,10 @@ rm -f conftest.err conftest.$ac_ext # OK, works on sane cases. Now check whether non-existent headers # can be detected and how. cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3545,10 +3710,11 @@ cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes @@ -3591,11 +3757,10 @@ # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3602,11 +3767,11 @@ #ifdef __STDC__ # include #else # include #endif - Syntax error + Syntax error _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err @@ -3614,10 +3779,11 @@ cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes @@ -3634,11 +3800,10 @@ rm -f conftest.err conftest.$ac_ext # OK, works on sane cases. Now check whether non-existent headers # can be detected and how. cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3652,10 +3817,11 @@ cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes @@ -3712,11 +3878,10 @@ echo $ECHO_N "checking for ANSI C header files... $ECHO_C" >&6 if test "${ac_cv_header_stdc+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3733,15 +3898,25 @@ return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -3750,16 +3925,15 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_header_stdc=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3777,11 +3951,10 @@ fi if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3802,11 +3975,10 @@ # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. if test "$cross_compiling" = yes; then : else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3814,13 +3986,13 @@ #if ((' ' & 0x0FF) == 0x020) # define ISLOWER(c) ('a' <= (c) && (c) <= 'z') # define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) #else # define ISLOWER(c) \ - (('a' <= (c) && (c) <= 'i') \ - || ('j' <= (c) && (c) <= 'r') \ - || ('s' <= (c) && (c) <= 'z')) + (('a' <= (c) && (c) <= 'i') \ + || ('j' <= (c) && (c) <= 'r') \ + || ('s' <= (c) && (c) <= 'z')) # define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) #endif #define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) int @@ -3827,11 +3999,11 @@ main () { int i; for (i = 0; i < 256; i++) if (XOR (islower (i), ISLOWER (i)) - || toupper (i) != TOUPPER (i)) + || toupper (i) != TOUPPER (i)) exit(2); exit (0); } _ACEOF rm -f conftest$ac_exeext @@ -3852,11 +4024,11 @@ sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) ac_cv_header_stdc=no fi -rm -f core core.* *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi fi echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5 echo "${ECHO_T}$ac_cv_header_stdc" >&6 @@ -3877,20 +4049,19 @@ for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ - inttypes.h stdint.h unistd.h + inttypes.h stdint.h unistd.h do as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_header" >&5 echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 if eval "test \"\${$as_ac_Header+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3898,15 +4069,25 @@ #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -3915,11 +4096,11 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_Header=no" fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 if test `eval echo '${'$as_ac_Header'}'` = yes; then cat >>confdefs.h <<_ACEOF @@ -3942,11 +4123,10 @@ else # Is the header compilable? echo "$as_me:$LINENO: checking errno.h usability" >&5 echo $ECHO_N "checking errno.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3953,15 +4133,25 @@ $ac_includes_default #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -s conftest.$ac_objext' + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then @@ -3970,19 +4160,18 @@ echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi -rm -f conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking errno.h presence" >&5 echo $ECHO_N "checking errno.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF -#line $LINENO "configure" /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ @@ -3996,10 +4185,11 @@ cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes @@ -4015,37 +4205,36 @@ rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? -case $ac_header_compiler:$ac_header_preproc in - yes:no ) +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) { echo "$as_me:$LINENO: WARNING: errno.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: errno.h: accepted by the compiler, rejected by the preprocessor!" >&2;} - { echo "$as_me:$LINENO: WARNING: errno.h: proceeding with the preprocessor's result" >&5 -echo "$as_me: WARNING: errno.h: proceeding with the preprocessor's result" >&2;} - ( - cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## -_ASBOX - ) | - sed "s/^/$as_me: WARNING: /" >&2 + { echo "$as_me:$LINENO: WARNING: errno.h: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: errno.h: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes ;; - no:yes ) + no:yes:* ) { echo "$as_me:$LINENO: WARNING: errno.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: errno.h: present but cannot be compiled" >&2;} - { echo "$as_me:$LINENO: WARNING: errno.h: check for missing prerequisite headers?" >&5 -echo "$as_me: WARNING: errno.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: errno.h: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: errno.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: errno.h: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: errno.h: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: errno.h: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: errno.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: errno.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: errno.h: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: errno.h: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: errno.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX -## ------------------------------------ ## -## Report this to bug-autoconf@gnu.org. ## -## ------------------------------------ ## +## ------------------------------------------ ## +## Report this to the AC_PACKAGE_NAME lists. ## +## ------------------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac @@ -4261,17 +4450,17 @@ case `(ac_space=' '; set | grep ac_space) 2>&1` in *ac_space=\ *) # `set' does not quote correctly, so add quotes (double-quote # substitution turns \\\\ into \\, and sed turns \\ into \). sed -n \ - "s/'/'\\\\''/g; - s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" + "s/'/'\\\\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; *) # `set' quotes correctly as required by POSIX, so do not add quotes. sed -n \ - "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" + "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" ;; esac; } | sed ' t clear @@ -4297,17 +4486,17 @@ # VPATH may cause trouble with some makes, so we remove $(srcdir), # ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then - ac_vpsub='/^[ ]*VPATH[ ]*=/{ + ac_vpsub='/^[ ]*VPATH[ ]*=/{ s/:*\$(srcdir):*/:/; s/:*\${srcdir}:*/:/; s/:*@srcdir@:*/:/; -s/^\([^=]*=[ ]*\):*/\1/; +s/^\([^=]*=[ ]*\):*/\1/; s/:*$//; -s/^[^=]*=[ ]*$//; +s/^[^=]*=[ ]*$//; }' fi # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. @@ -4317,17 +4506,17 @@ # take arguments), then we branch to the quote section. Otherwise, # look for a macro that doesn't take arguments. cat >confdef2opt.sed <<\_ACEOF t clear : clear -s,^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\),-D\1=\2,g +s,^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\),-D\1=\2,g t quote -s,^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\),-D\1=\2,g +s,^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\),-D\1=\2,g t quote d : quote -s,[ `~#$^&*(){}\\|;'"<>?],\\&,g +s,[ `~#$^&*(){}\\|;'"<>?],\\&,g s,\[,\\&,g s,\],\\&,g s,\$,$$,g p _ACEOF @@ -4345,11 +4534,11 @@ ac_libobjs= ac_ltlibobjs= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_i=`echo "$ac_i" | - sed 's/\$U\././;s/\.o$//;s/\.obj$//'` + sed 's/\$U\././;s/\.o$//;s/\.obj$//'` # 2. Add them. ac_libobjs="$ac_libobjs $ac_i\$U.$ac_objext" ac_ltlibobjs="$ac_ltlibobjs $ac_i"'$U.lo' done LIBOBJS=$ac_libobjs @@ -4389,13 +4578,14 @@ # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then set -o posix fi +DUALCASE=1; export DUALCASE # for MKS sh # Support unset when possible. -if (FOO=FOO; unset FOO) >/dev/null 2>&1; then +if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then as_unset=unset else as_unset=false fi @@ -4410,11 +4600,11 @@ for as_var in \ LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ LC_TELEPHONE LC_TIME do - if (set +x; test -n "`(eval $as_var=C; export $as_var) 2>&1`"); then + if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then eval $as_var=C; export $as_var else $as_unset $as_var fi done @@ -4589,20 +4779,21 @@ rm -f conf$$ conf$$.exe conf$$.file if mkdir -p . 2>/dev/null; then as_mkdir_p=: else + test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_executable_p="test -f" # Sed expression to map a string onto a valid CPP name. -as_tr_cpp="sed y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g" +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. -as_tr_sh="sed y%*+%pp%;s%[^_$as_cr_alnum]%_%g" +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" # IFS # We need space, tab and new line, in precisely that order. as_nl=' @@ -4625,11 +4816,11 @@ _ASBOX } >&5 cat >&5 <<_CSEOF This file was extended by $as_me, which was -generated by GNU Autoconf 2.57. Invocation command line was +generated by GNU Autoconf 2.59. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS @@ -4669,11 +4860,11 @@ -V, --version print version number, then exit -q, --quiet do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] - instantiate the configuration file FILE + instantiate the configuration file FILE Configuration files: $config_files Report bugs to ." @@ -4680,15 +4871,14 @@ _ACEOF cat >>$CONFIG_STATUS <<_ACEOF ac_cs_version="\\ config.status -configured by $0, generated by GNU Autoconf 2.57, +configured by $0, generated by GNU Autoconf 2.59, with options \\"`echo "$ac_configure_args" | sed 's/[\\""\`\$]/\\\\&/g'`\\" -Copyright 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001 -Free Software Foundation, Inc. +Copyright (C) 2003 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." srcdir=$srcdir _ACEOF @@ -4987,13 +5177,13 @@ # is no need to browse any of the substitutions). # These are the two extra sed commands mentioned above. (echo ':t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b' && cat $tmp/subs.frag) >$tmp/subs-$ac_sed_frag.sed if test -z "$ac_sed_cmds"; then - ac_sed_cmds="sed -f $tmp/subs-$ac_sed_frag.sed" + ac_sed_cmds="sed -f $tmp/subs-$ac_sed_frag.sed" else - ac_sed_cmds="$ac_sed_cmds | sed -f $tmp/subs-$ac_sed_frag.sed" + ac_sed_cmds="$ac_sed_cmds | sed -f $tmp/subs-$ac_sed_frag.sed" fi ac_sed_frag=`expr $ac_sed_frag + 1` ac_beg=$ac_end ac_end=`expr $ac_end + $ac_max_sed_lines` fi @@ -5007,25 +5197,25 @@ cat >>$CONFIG_STATUS <<\_ACEOF for ac_file in : $CONFIG_FILES; do test "x$ac_file" = x: && continue # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". case $ac_file in - | *:- | *:-:* ) # input from stdin - cat >$tmp/stdin - ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` - ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; + cat >$tmp/stdin + ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` + ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; *:* ) ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` - ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; + ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; * ) ac_file_in=$ac_file.in ;; esac # Compute @srcdir@, @top_srcdir@, and @INSTALL@ for subdirectories. ac_dir=`(dirname "$ac_file") 2>/dev/null || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$ac_file" : 'X\(//\)[^/]' \| \ - X"$ac_file" : 'X\(//\)$' \| \ - X"$ac_file" : 'X\(/\)' \| \ - . : '\(.\)' 2>/dev/null || + X"$ac_file" : 'X\(//\)[^/]' \| \ + X"$ac_file" : 'X\(//\)$' \| \ + X"$ac_file" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || echo X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } /^X\(\/\/\)[^/].*/{ s//\1/; q; } /^X\(\/\/\)$/{ s//\1/; q; } /^X\(\/\).*/{ s//\1/; q; } @@ -5037,14 +5227,14 @@ as_dirs= while test ! -d "$as_dir"; do as_dirs="$as_dir $as_dirs" as_dir=`(dirname "$as_dir") 2>/dev/null || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_dir" : 'X\(//\)[^/]' \| \ - X"$as_dir" : 'X\(//\)$' \| \ - X"$as_dir" : 'X\(/\)' \| \ - . : '\(.\)' 2>/dev/null || + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } /^X\(\/\/\)[^/].*/{ s//\1/; q; } /^X\(\/\/\)$/{ s//\1/; q; } /^X\(\/\).*/{ s//\1/; q; } @@ -5078,16 +5268,49 @@ ac_top_srcdir=$srcdir ;; *) # Relative path. ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_builddir$srcdir ;; esac -# Don't blindly perform a `cd "$ac_dir"/$ac_foo && pwd` since $ac_foo can be -# absolute. -ac_abs_builddir=`cd "$ac_dir" && cd $ac_builddir && pwd` -ac_abs_top_builddir=`cd "$ac_dir" && cd ${ac_top_builddir}. && pwd` -ac_abs_srcdir=`cd "$ac_dir" && cd $ac_srcdir && pwd` -ac_abs_top_srcdir=`cd "$ac_dir" && cd $ac_top_srcdir && pwd` + +# Do not use `cd foo && pwd` to compute absolute paths, because +# the directories may not exist. +case `pwd` in +.) ac_abs_builddir="$ac_dir";; +*) + case "$ac_dir" in + .) ac_abs_builddir=`pwd`;; + [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; + *) ac_abs_builddir=`pwd`/"$ac_dir";; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_builddir=${ac_top_builddir}.;; +*) + case ${ac_top_builddir}. in + .) ac_abs_top_builddir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; + *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_srcdir=$ac_srcdir;; +*) + case $ac_srcdir in + .) ac_abs_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; + *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_srcdir=$ac_top_srcdir;; +*) + case $ac_top_srcdir in + .) ac_abs_top_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; + *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; + esac;; +esac if test x"$ac_file" != x-; then { echo "$as_me:$LINENO: creating $ac_file" >&5 @@ -5101,37 +5324,37 @@ configure_input= else configure_input="$ac_file. " fi configure_input=$configure_input"Generated from `echo $ac_file_in | - sed 's,.*/,,'` by configure." + sed 's,.*/,,'` by configure." # First look for the input files in the build tree, otherwise in the # src tree. ac_file_inputs=`IFS=: for f in $ac_file_in; do case $f in -) echo $tmp/stdin ;; [\\/$]*) - # Absolute (can't be DOS-style, as IFS=:) - test -f "$f" || { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 -echo "$as_me: error: cannot find input file: $f" >&2;} - { (exit 1); exit 1; }; } - echo $f;; - *) # Relative - if test -f "$f"; then - # Build tree - echo $f - elif test -f "$srcdir/$f"; then - # Source tree - echo $srcdir/$f - else - # /dev/null tree - { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 -echo "$as_me: error: cannot find input file: $f" >&2;} - { (exit 1); exit 1; }; } - fi;; + # Absolute (can't be DOS-style, as IFS=:) + test -f "$f" || { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 +echo "$as_me: error: cannot find input file: $f" >&2;} + { (exit 1); exit 1; }; } + echo "$f";; + *) # Relative + if test -f "$f"; then + # Build tree + echo "$f" + elif test -f "$srcdir/$f"; then + # Source tree + echo "$srcdir/$f" + else + # /dev/null tree + { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 +echo "$as_me: error: cannot find input file: $f" >&2;} + { (exit 1); exit 1; }; } + fi;; esac done` || { (exit 1); exit 1; } _ACEOF cat >>$CONFIG_STATUS <<_ACEOF sed "$ac_vpsub Index: win/configure.in ================================================================== --- win/configure.in +++ win/configure.in @@ -1,24 +1,24 @@ #! /bin/bash -norc # This file is an input file used by the GNU "autoconf" program to # generate the file "configure", which is run during Tcl installation # to configure the system for the local environment. # -# RCS: @(#) $Id: configure.in,v 1.81 2004/06/11 20:25:25 dgp Exp $ +# RCS: @(#) $Id: configure.in,v 1.81.2.5 2005/08/25 15:47:07 dgp Exp $ AC_INIT(../generic/tcl.h) -AC_PREREQ(2.57) +AC_PREREQ(2.59) # The following define is needed when building with Cygwin since newer # versions of autoconf incorrectly set SHELL to /bin/bash instead of # /bin/sh. The bash shell seems to suffer from some strange failures. SHELL=/bin/sh TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 -TCL_PATCH_LEVEL="a2" +TCL_PATCH_LEVEL="a4" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.3 TCL_DDE_MAJOR_VERSION=1 TCL_DDE_MINOR_VERSION=3 Index: win/makefile.bc ================================================================== --- win/makefile.bc +++ win/makefile.bc @@ -454,11 +454,10 @@ -@copy "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)" -@copy "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)" -@copy "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)" -@copy "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)" -@copy "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)" - -@copy "$(ROOT)\library\ldAout.tcl" "$(SCRIPT_INSTALL_DIR)" -@copy "$(ROOT)\library\parray.tcl" "$(SCRIPT_INSTALL_DIR)" -@copy "$(ROOT)\library\safe.tcl" "$(SCRIPT_INSTALL_DIR)" -@copy "$(ROOT)\library\tclIndex" "$(SCRIPT_INSTALL_DIR)" -@copy "$(ROOT)\library\package.tcl" "$(SCRIPT_INSTALL_DIR)" -@copy "$(ROOT)\library\word.tcl" "$(SCRIPT_INSTALL_DIR)" Index: win/makefile.vc ================================================================== --- win/makefile.vc +++ win/makefile.vc @@ -6,40 +6,44 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Ajuba Solutions. -# Copyright (c) 2001 ActiveState Corporation. +# Copyright (c) 2001-2005 ActiveState Corporation. # Copyright (c) 2001-2004 David Gravereaux. # #------------------------------------------------------------------------------ -# RCS: @(#) $Id: makefile.vc,v 1.135 2004/10/27 20:53:38 davygrvy Exp $ +# RCS: @(#) $Id: makefile.vc,v 1.135.2.11 2005/09/23 16:47:35 dgp Exp $ #------------------------------------------------------------------------------ -!if !defined(MSDEVDIR) && !defined(MSVCDIR) +# Check to see we are configured to build with MSVC (MSDEVDIR or MSVCDIR) +# or with the MS Platform SDK (MSSDK) +!if !defined(MSDEVDIR) && !defined(MSVCDIR) && !defined(MSSDK) MSG = ^ -You'll need to run vcvars32.bat from Developer Studio, first, to setup^ -the environment. Jump to this line to read the new instructions. +You need to run vcvars32.bat from Developer Studio or setenv.bat from the^ +Platform SDK first to setup the environment. Jump to this line to read^ +the build instructions. !error $(MSG) !endif #------------------------------------------------------------------------------ # HOW TO USE this makefile: # -# 1) It is now necessary to have %MSDevDir% set in the environment. This is used -# as a check to see if vcvars32.bat had been run prior to running nmake or -# during the installation of Microsoft Visual C++, MSDevDir had been set -# globally and the PATH adjusted. Either way is valid. +# 1) It is now necessary to have MSVCDir, MSDevDir or MSSDK set in the +# environment. This is used as a check to see if vcvars32.bat had been +# run prior to running nmake or during the installation of Microsoft +# Visual C++, MSVCDir had been set globally and the PATH adjusted. +# Either way is valid. # # You'll need to run vcvars32.bat contained in the MsDev's vc(98)/bin -# directory to setup the proper environment, if needed, for your current -# setup. This is a needed bootstrap requirement and allows the swapping of -# different environments to be easier. +# directory to setup the proper environment, if needed, for your +# current setup. This is a needed bootstrap requirement and allows the +# swapping of different environments to be easier. # # 2) To use the Platform SDK (not expressly needed), run setenv.bat after -# vcvars32.bat according to the instructions for it. This can also turn on -# the 64-bit compiler, if your SDK has it. +# vcvars32.bat according to the instructions for it. This can also +# turn on the 64-bit compiler, if your SDK has it. # # 3) Targets are: # release -- Builds the core, the shell and the dlls. (default) # dlls -- Just builds the windows extensions and the 16-bit DOS # pipe/thunk helper app. @@ -278,10 +282,11 @@ $(TMP_DIR)\tclIO.obj \ $(TMP_DIR)\tclIOCmd.obj \ $(TMP_DIR)\tclIOGT.obj \ $(TMP_DIR)\tclIOSock.obj \ $(TMP_DIR)\tclIOUtil.obj \ + $(TMP_DIR)\tclIORChan.obj \ $(TMP_DIR)\tclLink.obj \ $(TMP_DIR)\tclListObj.obj \ $(TMP_DIR)\tclLiteral.obj \ $(TMP_DIR)\tclLoad.obj \ $(TMP_DIR)\tclMain.obj \ @@ -301,17 +306,19 @@ $(TMP_DIR)\tclRegexp.obj \ $(TMP_DIR)\tclResolve.obj \ $(TMP_DIR)\tclResult.obj \ $(TMP_DIR)\tclScan.obj \ $(TMP_DIR)\tclStringObj.obj \ + $(TMP_DIR)\tclStrToD.obj \ $(TMP_DIR)\tclStubInit.obj \ $(TMP_DIR)\tclStubLib.obj \ $(TMP_DIR)\tclThread.obj \ $(TMP_DIR)\tclThreadAlloc.obj \ $(TMP_DIR)\tclThreadJoin.obj \ $(TMP_DIR)\tclThreadStorage.obj \ $(TMP_DIR)\tclTimer.obj \ + $(TMP_DIR)\tclTomMathInterface.obj \ $(TMP_DIR)\tclTrace.obj \ $(TMP_DIR)\tclUtf.obj \ $(TMP_DIR)\tclUtil.obj \ $(TMP_DIR)\tclVar.obj \ $(TMP_DIR)\tclWin32Dll.obj \ @@ -326,10 +333,71 @@ $(TMP_DIR)\tclWinNotify.obj \ $(TMP_DIR)\tclWinPipe.obj \ $(TMP_DIR)\tclWinSock.obj \ $(TMP_DIR)\tclWinThrd.obj \ $(TMP_DIR)\tclWinTime.obj \ + $(TMP_DIR)\bncore.obj \ + $(TMP_DIR)\bn_reverse.obj \ + $(TMP_DIR)\bn_fast_s_mp_mul_digs.obj \ + $(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 \ + $(TMP_DIR)\bn_mp_div.obj \ + $(TMP_DIR)\bn_mp_div_d.obj \ + $(TMP_DIR)\bn_mp_div_2.obj \ + $(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 \ + $(TMP_DIR)\bn_mp_init_multi.obj \ + $(TMP_DIR)\bn_mp_init_set.obj \ + $(TMP_DIR)\bn_mp_init_size.obj \ + $(TMP_DIR)\bn_mp_karatsuba_mul.obj \ + $(TMP_DIR)\bn_mp_karatsuba_sqr.obj \ + $(TMP_DIR)\bn_mp_lshd.obj \ + $(TMP_DIR)\bn_mp_mod.obj \ + $(TMP_DIR)\bn_mp_mod_2d.obj \ + $(TMP_DIR)\bn_mp_mul.obj \ + $(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 \ + $(TMP_DIR)\bn_s_mp_sqr.obj \ + $(TMP_DIR)\bn_s_mp_sub.obj \ !if !$(STATIC_BUILD) $(TMP_DIR)\tcl.res !endif TCLSTUBOBJS = $(TMP_DIR)\tclStubLib.obj @@ -336,10 +404,11 @@ ### The following paths CANNOT have spaces in them. COMPATDIR = $(ROOT)\compat DOCDIR = $(ROOT)\doc GENERICDIR = $(ROOT)\generic +TOMMATHDIR = $(ROOT)\libtommath TOOLSDIR = $(ROOT)\tools WINDIR = $(ROOT)\win #--------------------------------------------------------------------- @@ -390,13 +459,14 @@ !else crt = -MT !endif !endif -TCL_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)" +TCL_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)" -I"$(TOMMATHDIR)" BASE_CFLAGS = $(cflags) $(cdebug) $(crt) $(TCL_INCLUDES) \ - -DTCL_PIPE_DLL=\"$(TCLPIPEDLLNAME)\" + -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) @@ -833,10 +903,15 @@ {$(WINDIR)}.c{$(TMP_DIR)}.obj:: $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<< $< << + +{$(TOMMATHDIR)}.c{$(TMP_DIR)}.obj:: + $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<< +$< +<< {$(GENERICDIR)}.c{$(TMP_DIR)}.obj:: $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<< $< << @@ -922,11 +997,10 @@ @$(CPY) "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\clock.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\tm.tcl" "$(SCRIPT_INSTALL_DIR)\" - @$(CPY) "$(ROOT)\library\ldAout.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\parray.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\safe.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\tclIndex" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\package.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\word.tcl" "$(SCRIPT_INSTALL_DIR)\" Index: win/rules.vc ================================================================== --- win/rules.vc +++ win/rules.vc @@ -8,11 +8,11 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Copyright (c) 2001-2003 David Gravereaux. # #------------------------------------------------------------------------------ -# RCS: @(#) $Id: rules.vc,v 1.19 2004/06/24 01:29:07 mistachkin Exp $ +# RCS: @(#) $Id: rules.vc,v 1.19.2.3 2005/08/15 18:14:15 dgp Exp $ #------------------------------------------------------------------------------ !ifndef _RULES_VC _RULES_VC = 1 @@ -177,16 +177,10 @@ !message *** Doing thrdalloc USE_THREAD_ALLOC = 1 !else USE_THREAD_ALLOC = 0 !endif -!if [nmakehlp -f $(OPTS) "thrdstorage"] -!message *** Doing thrdstorage -USE_THREAD_STORAGE = 1 -!else -USE_THREAD_STORAGE = 0 -!endif !if [nmakehlp -f $(OPTS) "unchecked"] !message *** Doing unchecked UNCHECKED = 1 !else UNCHECKED = 0 @@ -327,13 +321,10 @@ !if $(TCL_THREADS) OPTDEFINES = $(OPTDEFINES) -DTCL_THREADS=1 !if $(USE_THREAD_ALLOC) OPTDEFINES = $(OPTDEFINES) -DUSE_THREAD_ALLOC=1 !endif -!if $(USE_THREAD_STORAGE) -OPTDEFINES = $(OPTDEFINES) -DUSE_THREAD_STORAGE=1 -!endif !endif !if $(STATIC_BUILD) OPTDEFINES = $(OPTDEFINES) -DSTATIC_BUILD !endif !if $(TCL_NO_DEPRECATED) Index: win/tcl.m4 ================================================================== --- win/tcl.m4 +++ win/tcl.m4 @@ -255,13 +255,10 @@ TCL_THREADS=1 AC_DEFINE(TCL_THREADS) # USE_THREAD_ALLOC tells us to try the special thread-based # allocator that significantly reduces lock contention AC_DEFINE(USE_THREAD_ALLOC) - # USE_THREAD_STORAGE tells us to use the new generic thread - # storage subsystem. - AC_DEFINE(USE_THREAD_STORAGE) else TCL_THREADS=0 AC_MSG_RESULT([no (default)]) fi AC_SUBST(TCL_THREADS) @@ -437,11 +434,11 @@ AC_MSG_WARN("64bit mode not supported with GCC on Windows") fi SHLIB_LD="" SHLIB_LD_LIBS="" LIBS="" - LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32" + LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32 -lole32 -loleaut32 -luuid" STLIB_LD='${AR} cr' RC_OUT=-o RC_TYPE= RC_INCLUDE=--include RC_DEFINE=--define @@ -517,11 +514,11 @@ SHLIB_SUFFIX=.dll EXTRA_CFLAGS="${extra_cflags}" CFLAGS_DEBUG=-g - CFLAGS_OPTIMIZE=-O + CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer" CFLAGS_WARNING="-Wall -Wconversion" LDFLAGS_DEBUG= LDFLAGS_OPTIMIZE= # Specify the CC output file names based on the target name @@ -575,44 +572,50 @@ # We have to know where the SDK is installed. if test "$do64bit" = "yes" ; then if test "x${MSSDK}x" = "xx" ; then MSSDK="C:/Progra~1/Microsoft SDK" fi - # In order to work in the tortured autoconf environment, - # we need to ensure that this path has no spaces - MSSDK=$(cygpath -w -s "$MSSDK" | sed -e 's!\\!/!g') + MSSDK=`echo "$MSSDK" | sed -e 's!\\\!/!g'` if test ! -d "${MSSDK}/bin/win64" ; then AC_MSG_WARN("could not find 64-bit SDK to enable 64bit mode") do64bit="no" fi fi if test "$do64bit" = "yes" ; then # All this magic is necessary for the Win64 SDK RC1 - hobbs - CC="${MSSDK}/Bin/Win64/cl.exe \ - -I${MSSDK}/Include/prerelease \ - -I${MSSDK}/Include/Win64/crt \ - -I${MSSDK}/Include/Win64/crt/sys \ - -I${MSSDK}/Include" - RC="${MSSDK}/bin/rc.exe" + # The space-based-path will work for the Makefile, but will + # not work if AC_TRY_COMPILE is called. TEA has the + # TEA_PATH_NOSPACE to avoid this issue. + CC="\"${MSSDK}/Bin/Win64/cl.exe\" \ + -I\"${MSSDK}/Include/prerelease\" \ + -I\"${MSSDK}/Include/Win64/crt\" \ + -I\"${MSSDK}/Include/Win64/crt/sys\" \ + -I\"${MSSDK}/Include\"" + RC="\"${MSSDK}/bin/rc.exe\"" CFLAGS_DEBUG="-nologo -Zi -Od ${runtime}d" - CFLAGS_OPTIMIZE="-nologo -O2 -Gs ${runtime}" - lflags="-MACHINE:IA64 -LIBPATH:${MSSDK}/Lib/IA64 \ - -LIBPATH:${MSSDK}/Lib/Prerelease/IA64" - STLIB_LD="${MSSDK}/bin/win64/lib.exe -nologo ${lflags}" - LINKBIN="${MSSDK}/bin/win64/link.exe ${lflags}" + # Do not use -O2 for Win64 - this has proved buggy in code gen. + CFLAGS_OPTIMIZE="-nologo -O1 ${runtime}" + lflags="-MACHINE:IA64 -LIBPATH:\"${MSSDK}/Lib/IA64\" \ + -LIBPATH:\"${MSSDK}/Lib/Prerelease/IA64\" -nologo" + LINKBIN="\"${MSSDK}/bin/win64/link.exe\"" else RC="rc" + # -Od - no optimization + # -WX - warnings as errors CFLAGS_DEBUG="-nologo -Z7 -Od -WX ${runtime}d" - CFLAGS_OPTIMIZE="-nologo -Oti -Gs -GD ${runtime}" - STLIB_LD="lib -nologo" - LINKBIN="link -link50compat" + # -O2 - create fast code (/Og /Oi /Ot /Oy /Ob2 /Gs /GF /Gy) + CFLAGS_OPTIMIZE="-nologo -O2 ${runtime}" + lflags="-nologo" + LINKBIN="link" fi - SHLIB_LD="${LINKBIN} -dll -nologo -incremental:no" LIBS="user32.lib advapi32.lib" - LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib" + LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib" + SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}" + # link -lib only works when -lib is the first arg + STLIB_LD="${LINKBIN} -lib ${lflags}" RC_OUT=-fo RC_TYPE=-r RC_INCLUDE=-i RC_DEFINE=-d RES=res @@ -619,13 +622,13 @@ MAKE_LIB="\${STLIB_LD} -out:\[$]@" POST_MAKE_LIB= MAKE_EXE="\${CC} -Fe\[$]@" LIBPREFIX="" - EXTRA_CFLAGS="-YX" + EXTRA_CFLAGS="" CFLAGS_WARNING="-W3" - LDFLAGS_DEBUG="-debug:full -debugtype:both" + LDFLAGS_DEBUG="-debug:full" LDFLAGS_OPTIMIZE="-release" # Specify the CC output file names based on the target name CC_OBJNAME="-Fo\[$]@" CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) '\[$]@')\"" @@ -682,22 +685,21 @@ echo "building against Tcl binaries in: $TCL_BIN_DIR" fi AC_SUBST(TCL_BIN_DIR) ]) -# FIXME : SC_PROG_TCLSH should really look for the installed tclsh and -# not the build version. If we want to use the build version in the -# tk script, it is better to hardcode that! - #------------------------------------------------------------------------ # SC_PROG_TCLSH -# Locate a tclsh shell in the following directories: -# ${exec_prefix}/bin -# ${prefix}/bin -# ${TCL_BIN_DIR} -# ${TCL_BIN_DIR}/../bin -# ${PATH} +# Locate a tclsh shell installed on the system path. This macro +# will only find a Tcl shell that already exists on the system. +# It will not find a Tcl shell in the Tcl build directory or +# a Tcl shell that has been installed from the Tcl build directory. +# If a Tcl shell can't be located on the PATH, then TCLSH_PROG will +# be set to "". Extensions should take care not to create Makefile +# rules that are run by default and depend on TCLSH_PROG. An +# extension can't assume that an executable Tcl shell exists at +# build time. # # Arguments # none # # Results @@ -707,11 +709,11 @@ AC_DEFUN(SC_PROG_TCLSH, [ AC_MSG_CHECKING([for tclsh]) AC_CACHE_VAL(ac_cv_path_tclsh, [ - search_path=`echo ${exec_prefix}/bin:${prefix}/bin:${TCL_BIN_DIR}:${TCL_BIN_DIR}/../bin:${PATH} | sed -e 's/:/ /g'` + search_path=`echo ${PATH} | sed -e 's/:/ /g'` for dir in $search_path ; do for j in `ls -r $dir/tclsh[[8-9]]*.exe 2> /dev/null` \ `ls -r $dir/tclsh* 2> /dev/null` ; do if test x"$ac_cv_path_tclsh" = x ; then if test -f "$j" ; then @@ -724,20 +726,41 @@ ]) if test -f "$ac_cv_path_tclsh" ; then TCLSH_PROG="$ac_cv_path_tclsh" AC_MSG_RESULT($TCLSH_PROG) - elif test -f "$TCL_BIN_DIR/tclConfig.sh" ; then - # One-tree build. - ac_cv_path_tclsh="$TCL_BIN_DIR/tclsh" - TCLSH_PROG="$ac_cv_path_tclsh" - AC_MSG_RESULT($TCLSH_PROG) else - AC_MSG_ERROR(No tclsh found in PATH: $search_path) + # It is not an error if an installed version of Tcl can't be located. + TCLSH_PROG="" + AC_MSG_RESULT([No tclsh found on PATH]) fi AC_SUBST(TCLSH_PROG) ]) + +#------------------------------------------------------------------------ +# SC_BUILD_TCLSH +# Determine the fully qualified path name of the tclsh executable +# in the Tcl build directory. This macro will correctly determine +# the name of the tclsh executable even if tclsh has not yet +# been built in the build directory. The build tclsh must be used +# when running tests from an extension build directory. It is not +# correct to use the TCLSH_PROG in cases like this. +# +# Arguments +# none +# +# Results +# Subst's the following values: +# BUILD_TCLSH +#------------------------------------------------------------------------ + +AC_DEFUN(SC_BUILD_TCLSH, [ + AC_MSG_CHECKING([for tclsh in Tcl build directory]) + BUILD_TCLSH=${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${TCL_DBGX}${EXEEXT} + AC_MSG_RESULT($BUILD_TCLSH) + AC_SUBST(BUILD_TCLSH) +]) #-------------------------------------------------------------------- # SC_TCL_CFG_ENCODING TIP #59 # # Declare the encoding to use for embedded configuration information. Index: win/tclAppInit.c ================================================================== --- win/tclAppInit.c +++ win/tclAppInit.c @@ -1,19 +1,19 @@ /* * tclAppInit.c -- * * Provides a default version of the main program and Tcl_AppInit - * procedure for Tcl applications (without Tk). Note that this - * program must be built in Win32 console mode to work properly. + * function for Tcl applications (without Tk). Note that this program + * must be built in Win32 console mode to work properly. * * Copyright (c) 1996-1997 by Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclAppInit.c,v 1.21 2004/10/28 04:53:42 davygrvy Exp $ + * RCS: @(#) $Id: tclAppInit.c,v 1.21.2.1 2005/08/02 18:17:00 dgp Exp $ */ #include "tcl.h" #include #include @@ -24,18 +24,18 @@ extern Tcl_PackageInitProc Tcltest_Init; extern Tcl_PackageInitProc TclObjTest_Init; #endif /* TCL_TEST */ #if defined(__GNUC__) -static void setargv _ANSI_ARGS_((int *argcPtr, char ***argvPtr)); +static void setargv(int *argcPtr, char ***argvPtr); #endif /* __GNUC__ */ -static BOOL WINAPI sigHandler (DWORD fdwCtrlType); +static BOOL WINAPI sigHandler(DWORD fdwCtrlType); static Tcl_AsyncProc asyncExit; static void AppInitExitHandler(ClientData clientData); static Tcl_AsyncHandler exitToken = NULL; -static DWORD exitErrorCode = 0; +static DWORD exitErrorCode = 0; /* *---------------------------------------------------------------------- * @@ -42,27 +42,27 @@ * main -- * * This is the main program for the application. * * Results: - * None: Tcl_Main never returns here, so this procedure never - * returns either. + * None: Tcl_Main never returns here, so this function never returns + * either. * * Side effects: * Whatever the application does. * *---------------------------------------------------------------------- */ int -main (int argc, char *argv[]) +main(int argc, char *argv[]) { /* - * The following #if block allows you to change the AppInit - * function by using a #define of TCL_LOCAL_APPINIT instead - * of rewriting this entire file. The #if checks for that - * #define and uses Tcl_AppInit if it doesn't exist. + * The following #if block allows you to change the AppInit function by + * using a #define of TCL_LOCAL_APPINIT instead of rewriting this entire + * file. The #if checks for that #define and uses Tcl_AppInit if it + * doesn't exist. */ #ifndef TCL_LOCAL_APPINIT #define TCL_LOCAL_APPINIT Tcl_AppInit #endif @@ -79,12 +79,12 @@ #endif char *p; /* - * Set up the default locale to be standard "C" locale so parsing - * is performed correctly. + * Set up the default locale to be standard "C" locale so parsing is + * performed correctly. */ #if defined(__GNUC__) setargv( &argc, &argv ); #endif @@ -112,17 +112,17 @@ /* *---------------------------------------------------------------------- * * Tcl_AppInit -- * - * This procedure performs application-specific initialization. - * Most applications, especially those that incorporate additional - * packages, will have their own version of this procedure. + * This function performs application-specific initialization. Most + * applications, especially those that incorporate additional packages, + * will have their own version of this function. * * Results: - * Returns a standard Tcl completion code, and leaves an error - * message in the interp's result if an error occurs. + * Returns a standard Tcl completion code, and leaves an error message in + * the interp's result if an error occurs. * * Side effects: * Depends on the startup script. * *---------------------------------------------------------------------- @@ -137,17 +137,19 @@ } /* * Install a signal handler to the win32 console tclsh is running in. */ + SetConsoleCtrlHandler(sigHandler, TRUE); exitToken = Tcl_AsyncCreate(asyncExit, NULL); /* - * This exit handler will be used to free the - * resources allocated in this file. + * This exit handler will be used to free the resources allocated in this + * file. */ + Tcl_CreateExitHandler(AppInitExitHandler, NULL); #ifdef TCL_TEST if (Tcltest_Init(interp) == TCL_ERROR) { return TCL_ERROR; @@ -158,11 +160,11 @@ } if (Procbodytest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage(interp, "procbodytest", Procbodytest_Init, - Procbodytest_SafeInit); + Procbodytest_SafeInit); #endif /* TCL_TEST */ #if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES { extern Tcl_PackageInitProc Registry_Init; @@ -180,30 +182,30 @@ Tcl_StaticPackage(interp, "dde", Dde_Init, Dde_SafeInit); } #endif /* - * Call the init procedures for included packages. Each call should - * look like this: + * Call the init functions for included packages. Each call should look + * like this: * * if (Mod_Init(interp) == TCL_ERROR) { * return TCL_ERROR; * } * * where "Mod" is the name of the module. */ /* - * Call Tcl_CreateCommand for application-specific commands, if - * they weren't already created by the init procedures called above. + * Call Tcl_CreateCommand for application-specific commands, if they + * weren't already created by the init functions called above. */ /* - * Specify a user-specific startup file to invoke if the application - * is run interactively. Typically the startup file is "~/.apprc" - * where "app" is the name of the application. If this line is deleted - * then no user-specific startup file will be run under any conditions. + * Specify a user-specific startup file to invoke if the application is + * run interactively. Typically the startup file is "~/.apprc" where "app" + * is the name of the application. If this line is deleted then no + * user-specific startup file will be run under any conditions. */ Tcl_SetVar(interp, "tcl_rcFileName", "~/tclshrc.tcl", TCL_GLOBAL_ONLY); return TCL_OK; } @@ -211,12 +213,12 @@ /* *---------------------------------------------------------------------- * * AppInitExitHandler -- * - * This function is called to cleanup the app init resources before - * Tcl is unloaded. + * This function is called to cleanup the app init resources before Tcl + * is unloaded. * * Results: * None. * * Side effects: @@ -228,39 +230,40 @@ static void AppInitExitHandler( ClientData clientData) /* Not Used. */ { if (exitToken != NULL) { - /* - * This should be safe to do even if we - * are in an async exit right now. - */ - Tcl_AsyncDelete(exitToken); - exitToken = NULL; + /* + * This should be safe to do even if we are in an async exit right + * now. + */ + + Tcl_AsyncDelete(exitToken); + exitToken = NULL; } } /* *------------------------------------------------------------------------- * * setargv -- * - * Parse the Windows command line string into argc/argv. Done here - * because we don't trust the builtin argument parser in crt0. - * Windows applications are responsible for breaking their command - * line into arguments. + * Parse the Windows command line string into argc/argv. Done here + * because we don't trust the builtin argument parser in crt0. Windows + * applications are responsible for breaking their command line into + * arguments. * * 2N backslashes + quote -> N backslashes + begin quoted string * 2N + 1 backslashes + quote -> literal * N backslashes + non-quote -> literal * quote + quote in a quoted string -> single quote * quote + quote not in quoted string -> empty string * quote -> begin quoted string * * Results: - * Fills argcPtr with the number of arguments and argvPtr with the - * array of arguments. + * Fills argcPtr with the number of arguments and argvPtr with the array + * of arguments. * * Side effects: * Memory allocated. * *-------------------------------------------------------------------------- @@ -277,12 +280,12 @@ int argc, size, inquote, copy, slashes; cmdLine = GetCommandLine(); /* INTL: BUG */ /* - * Precompute an overly pessimistic guess at the number of arguments - * in the command line by counting non-space spans. + * Precompute an overly pessimistic guess at the number of arguments in + * the command line by counting non-space spans. */ size = 2; for (p = cmdLine; *p != '\0'; p++) { if ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ @@ -326,30 +329,30 @@ p++; copy = 1; } else { inquote = !inquote; } - } - slashes >>= 1; - } + } + slashes >>= 1; + } - while (slashes) { + while (slashes) { *arg = '\\'; arg++; slashes--; } - if ((*p == '\0') - || (!inquote && ((*p == ' ') || (*p == '\t')))) { /* INTL: ISO space. */ + if ((*p == '\0') || (!inquote && + ((*p == ' ') || (*p == '\t')))) { /* INTL: ISO space. */ break; } if (copy != 0) { *arg = *p; arg++; } p++; - } + } *arg = '\0'; argSpace = arg + 1; } argv[argc] = NULL; @@ -373,11 +376,11 @@ * *---------------------------------------------------------------------- */ int -asyncExit ( +asyncExit( ClientData clientData, /* Not Used. */ Tcl_Interp *interp, /* interp in context, if any. */ int code) /* result of last command, if any. */ { Tcl_Exit((int)exitErrorCode); @@ -389,21 +392,21 @@ /* *---------------------------------------------------------------------- * * sigHandler -- * - * Signal handler for the Win32 OS. Catches Ctrl+C, Ctrl+Break and - * other exits. This is needed so tclsh can do it's real clean-up - * and not an unclean crash terminate. + * Signal handler for the Win32 OS. Catches Ctrl+C, Ctrl+Break and other + * exits. This is needed so tclsh can do it's real clean-up and not an + * unclean crash terminate. * * Results: * TRUE. * * Side effects: - * Effects the way the app exits from a signal. This is an - * operating system supplied thread and unsafe to call ANY - * Tcl commands except for Tcl_AsyncMark. + * Effects the way the app exits from a signal. This is an operating + * system supplied thread and unsafe to call ANY Tcl commands except for + * Tcl_AsyncMark. * *---------------------------------------------------------------------- */ BOOL WINAPI @@ -411,30 +414,44 @@ DWORD fdwCtrlType) /* One of the CTRL_*_EVENT constants. */ { HANDLE hStdIn; if (!exitToken) { - /* Async token must have been destroyed, punt gracefully. */ + /* + * Async token must have been destroyed, punt gracefully. + */ return FALSE; } /* - * If Tcl is currently executing some bytecode or in the eventloop, - * this will cause Tcl to enter asyncExit at the next command - * boundry. + * If Tcl is currently executing some bytecode or in the eventloop, this + * will cause Tcl to enter asyncExit at the next command boundry. */ + exitErrorCode = fdwCtrlType; Tcl_AsyncMark(exitToken); /* - * This will cause Tcl_Gets in Tcl_Main() to drop-out with an - * should it be blocked on input and our Tcl_AsyncMark didn't grab - * the attention of the interpreter. + * This will cause Tcl_Gets in Tcl_Main() to drop-out with an should + * it be blocked on input and our Tcl_AsyncMark didn't grab the attention + * of the interpreter. */ + hStdIn = GetStdHandle(STD_INPUT_HANDLE); if (hStdIn) { CloseHandle(hStdIn); } - /* indicate to the OS not to call the default terminator. */ + /* + * Indicate to the OS not to call the default terminator. + */ + return TRUE; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: win/tclWin32Dll.c ================================================================== --- win/tclWin32Dll.c +++ win/tclWin32Dll.c @@ -1,24 +1,25 @@ /* * tclWin32Dll.c -- * - * This file contains the DLL entry point. + * This file contains the DLL entry point and other low-level bit bashing + * code that needs inline assembly. * * Copyright (c) 1995-1996 Sun Microsystems, Inc. * Copyright (c) 1998-2000 Scriptics Corporation. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWin32Dll.c,v 1.40 2004/11/01 16:58:37 kennykb Exp $ + * RCS: @(#) $Id: tclWin32Dll.c,v 1.40.2.6 2005/08/02 18:17:00 dgp Exp $ */ #include "tclWinInt.h" /* - * The following data structures are used when loading the thunking - * library for execing child processes under Win32s. + * The following data structures are used when loading the thunking library + * for execing child processes under Win32s. */ typedef DWORD (WINAPI UT32PROC)(LPVOID lpBuff, DWORD dwUserDefined, LPVOID *lpTranslationList); @@ -27,65 +28,41 @@ FARPROC UT32Callback, LPVOID Buff); typedef VOID (WINAPI UTUNREGISTER)(HANDLE hModule); /* - * The following variables keep track of information about this DLL - * on a per-instance basis. Each time this DLL is loaded, it gets its own - * new data segment with its own copy of all static and global information. + * The following variables keep track of information about this DLL on a + * per-instance basis. Each time this DLL is loaded, it gets its own new data + * segment with its own copy of all static and global information. */ static HINSTANCE hInstance; /* HINSTANCE of this DLL. */ static int platformId; /* Running under NT, or 95/98? */ -#if defined(HAVE_NO_SEH) && defined(TCL_MEM_DEBUG) -static void *INITIAL_ESP, - *INITIAL_EBP, - *INITIAL_HANDLER, - *RESTORED_ESP, - *RESTORED_EBP, - *RESTORED_HANDLER; -#endif /* HAVE_NO_SEH && TCL_MEM_DEBUG */ - #ifdef HAVE_NO_SEH - -static -__attribute__ ((cdecl)) -EXCEPTION_DISPOSITION -_except_dllmain_detach_handler( - struct _EXCEPTION_RECORD *ExceptionRecord, - void *EstablisherFrame, - struct _CONTEXT *ContextRecord, - void *DispatcherContext); - -static -__attribute__ ((cdecl)) -EXCEPTION_DISPOSITION -_except_checkstackspace_handler( - struct _EXCEPTION_RECORD *ExceptionRecord, - void *EstablisherFrame, - struct _CONTEXT *ContextRecord, - void *DispatcherContext); - -static -__attribute__((cdecl)) -EXCEPTION_DISPOSITION -_except_TclWinCPUID_detach_handler( - struct _EXCEPTION_RECORD *ExceptionRecord, - void *EstablisherFrame, - struct _CONTEXT *ContextRecord, - void *DispatcherContext); - -#endif /* HAVE_NO_SEH */ - +/* + * Unlike Borland and Microsoft, we don't register exception handlers by + * pushing registration records onto the runtime stack. Instead, we register + * them by creating an EXCEPTION_REGISTRATION within the activation record. + */ + +typedef struct EXCEPTION_REGISTRATION { + struct EXCEPTION_REGISTRATION *link; + EXCEPTION_DISPOSITION (*handler)( + struct _EXCEPTION_RECORD*, void*, struct _CONTEXT*, void*); + void *ebp; + void *esp; + int status; +} EXCEPTION_REGISTRATION; +#endif /* - * VC++ 5.x has no 'cpuid' assembler instruction, so we - * must emulate it + * VC++ 5.x has no 'cpuid' assembler instruction, so we must emulate it */ -#if defined(_MSC_VER) && ( _MSC_VER <= 1100 ) -#define cpuid __asm __emit 0fh __asm __emit 0a2h + +#if defined(_MSC_VER) && (_MSC_VER <= 1100) +#define cpuid __asm __emit 0fh __asm __emit 0a2h #endif /* * The following function tables are used to dispatch to either the * wide-character or multi-byte versions of the operating system calls, @@ -125,17 +102,19 @@ (BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryA, (DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD, WCHAR *, TCHAR **)) SearchPathA, (BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryA, (BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesA, + /* * The three NULL function pointers will only be set when - * Tcl_FindExecutable is called. If you don't ever call that - * function, the application will crash whenever WinTcl tries to call - * functions through these null pointers. That is not a bug in Tcl - * -- Tcl_FindExecutable is obligatory in recent Tcl releases. + * Tcl_FindExecutable is called. If you don't ever call that function, the + * application will crash whenever WinTcl tries to call functions through + * these null pointers. That is not a bug in Tcl - Tcl_FindExecutable is + * mandatory in recent Tcl releases. */ + NULL, NULL, /* deleted (int (__cdecl*)(CONST TCHAR *, struct _utimbuf *)) _utime, */ NULL, NULL, @@ -176,17 +155,19 @@ (BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryW, (DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD, WCHAR *, TCHAR **)) SearchPathW, (BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryW, (BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesW, + /* * The three NULL function pointers will only be set when - * Tcl_FindExecutable is called. If you don't ever call that - * function, the application will crash whenever WinTcl tries to call - * functions through these null pointers. That is not a bug in Tcl - * -- Tcl_FindExecutable is obligatory in recent Tcl releases. + * Tcl_FindExecutable is called. If you don't ever call that function, the + * application will crash whenever WinTcl tries to call functions through + * these null pointers. That is not a bug in Tcl - Tcl_FindExecutable is + * mandatory in recent Tcl releases. */ + NULL, NULL, /* deleted (int (__cdecl*)(CONST TCHAR *, struct _utimbuf *)) _wutime, */ NULL, NULL, @@ -195,68 +176,67 @@ }; TclWinProcs *tclWinProcs; static Tcl_Encoding tclWinTCharEncoding; - #ifdef HAVE_NO_SEH - -/* Need to add noinline flag to DllMain declaration so that gcc -O3 - * does not inline asm code into DllEntryPoint and cause a - * compile time error because of redefined local labels. +/* + * Need to add noinline flag to DllMain declaration so that gcc -O3 does not + * inline asm code into DllEntryPoint and cause a compile time error because + * of redefined local labels. */ BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason, - LPVOID reserved) - __attribute__ ((noinline)); - + LPVOID reserved) __attribute__ ((noinline)); #else - /* * The following declaration is for the VC++ DLL entry point. */ BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason, - LPVOID reserved); + LPVOID reserved); #endif /* HAVE_NO_SEH */ - /* * The following structure and linked list is to allow us to map between - * volume mount points and drive letters on the fly (no Win API exists - * for this). + * volume mount points and drive letters on the fly (no Win API exists for + * this). */ + typedef struct MountPointMap { - CONST WCHAR* volumeName; /* Native wide string volume name */ - char driveLetter; /* Drive letter corresponding to - * the volume name. */ - struct MountPointMap* nextPtr; /* Pointer to next structure in list, - * or NULL */ + CONST WCHAR *volumeName; /* Native wide string volume name. */ + char driveLetter; /* Drive letter corresponding to the volume + * name. */ + struct MountPointMap *nextPtr; + /* Pointer to next structure in list, or + * NULL. */ } MountPointMap; /* - * This is the head of the linked list, which is protected by the - * mutex which follows, for thread-enabled builds. + * This is the head of the linked list, which is protected by the mutex which + * follows, for thread-enabled builds. */ + MountPointMap *driveLetterLookup = NULL; TCL_DECLARE_MUTEX(mountPointMap) -/* We will need this below */ +/* + * We will need this below. + */ + extern Tcl_FSDupInternalRepProc TclNativeDupInternalRep; #ifdef __WIN32__ #ifndef STATIC_BUILD - /* *---------------------------------------------------------------------- * * DllEntryPoint -- * - * This wrapper function is used by Borland to invoke the - * initialization code for Tcl. It simply calls the DllMain - * routine. + * This wrapper function is used by Borland to invoke the initialization + * code for Tcl. It simply calls the DllMain routine. * * Results: * See DllMain. * * Side effects: @@ -277,139 +257,131 @@ /* *---------------------------------------------------------------------- * * DllMain -- * - * This routine is called by the VC++ C run time library init - * code, or the DllEntryPoint routine. It is responsible for - * initializing various dynamically loaded libraries. + * This routine is called by the VC++ C run time library init code, or + * the DllEntryPoint routine. It is responsible for initializing various + * dynamically loaded libraries. * * Results: * TRUE on sucess, FALSE on failure. * * Side effects: - * Establishes 32-to-16 bit thunk and initializes sockets library. - * This might call some sycronization functions, but MSDN - * documentation states: "Waiting on synchronization objects in - * DllMain can cause a deadlock." + * Establishes 32-to-16 bit thunk and initializes sockets library. This + * might call some sycronization functions, but MSDN documentation + * states: "Waiting on synchronization objects in DllMain can cause a + * deadlock." * *---------------------------------------------------------------------- */ + BOOL APIENTRY DllMain(hInst, reason, reserved) HINSTANCE hInst; /* Library instance handle. */ DWORD reason; /* Reason this function is being called. */ LPVOID reserved; /* Not used. */ { +#ifdef HAVE_NO_SEH + EXCEPTION_REGISTRATION registration; +#endif + switch (reason) { case DLL_PROCESS_ATTACH: DisableThreadLibraryCalls(hInst); TclWinInit(hInst); return TRUE; case DLL_PROCESS_DETACH: /* - * Protect the call to Tcl_Finalize. The OS could be unloading - * us from an exception handler and the state of the stack might - * be unstable. - */ -#ifdef HAVE_NO_SEH -# ifdef TCL_MEM_DEBUG - __asm__ __volatile__ ( - "movl %%esp, %0" "\n\t" - "movl %%ebp, %1" "\n\t" - "movl %%fs:0, %2" "\n\t" - : "=m"(INITIAL_ESP), - "=m"(INITIAL_EBP), - "=r"(INITIAL_HANDLER) ); -# endif /* TCL_MEM_DEBUG */ - - __asm__ __volatile__ ( - "pushl %%ebp" "\n\t" - "pushl %0" "\n\t" - "pushl %%fs:0" "\n\t" - "movl %%esp, %%fs:0" - : - : "r" (_except_dllmain_detach_handler) ); -#else - __try { -#endif /* HAVE_NO_SEH */ - Tcl_Finalize(); -#ifdef HAVE_NO_SEH - __asm__ __volatile__ ( - "jmp dllmain_detach_pop" "\n" - "dllmain_detach_reentry:" "\n\t" - "movl %%fs:0, %%eax" "\n\t" - "movl 0x8(%%eax), %%esp" "\n\t" - "movl 0x8(%%esp), %%ebp" "\n" - "dllmain_detach_pop:" "\n\t" - "movl (%%esp), %%eax" "\n\t" - "movl %%eax, %%fs:0" "\n\t" - "add $12, %%esp" "\n\t" - : - : - : "%eax"); - -# ifdef TCL_MEM_DEBUG - __asm__ __volatile__ ( - "movl %%esp, %0" "\n\t" - "movl %%ebp, %1" "\n\t" - "movl %%fs:0, %2" "\n\t" - : "=m"(RESTORED_ESP), - "=m"(RESTORED_EBP), - "=r"(RESTORED_HANDLER) ); - - if (INITIAL_ESP != RESTORED_ESP) - Tcl_Panic("ESP restored incorrectly"); - if (INITIAL_EBP != RESTORED_EBP) - Tcl_Panic("EBP restored incorrectly"); - if (INITIAL_HANDLER != RESTORED_HANDLER) - Tcl_Panic("HANDLER restored incorrectly"); -# endif /* TCL_MEM_DEBUG */ -#else + * Protect the call to Tcl_Finalize. The OS could be unloading us from + * an exception handler and the state of the stack might be unstable. + */ + +#ifdef HAVE_NO_SEH + __asm__ __volatile__ ( + + /* + * Construct an EXCEPTION_REGISTRATION to protect the call to + * Tcl_Finalize + */ + + "leal %[registration], %%edx" "\n\t" + "movl %%fs:0, %%eax" "\n\t" + "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ + "leal 1f, %%eax" "\n\t" + "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ + "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ + "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */ + "movl %[error], 0x10(%%edx)" "\n\t" /* status */ + + /* + * Link the EXCEPTION_REGISTRATION on the chain + */ + + "movl %%edx, %%fs:0" "\n\t" + + /* + * Call Tcl_Finalize + */ + + "call _Tcl_Finalize" "\n\t" + + /* + * Come here on a normal exit. Recover the EXCEPTION_REGISTRATION + * and store a TCL_OK status + */ + + "movl %%fs:0, %%edx" "\n\t" + "movl %[ok], %%eax" "\n\t" + "movl %%eax, 0x10(%%edx)" "\n\t" + "jmp 2f" "\n" + + /* + * Come here on an exception. Get the EXCEPTION_REGISTRATION that + * we previously put on the chain. + */ + + "1:" "\t" + "movl %%fs:0, %%edx" "\n\t" + "movl 0x8(%%edx), %%edx" "\n" + + + /* + * Come here however we exited. Restore context from the + * EXCEPTION_REGISTRATION in case the stack is unbalanced. + */ + + "2:" "\t" + "movl 0xc(%%edx), %%esp" "\n\t" + "movl 0x8(%%edx), %%ebp" "\n\t" + "movl 0x0(%%edx), %%eax" "\n\t" + "movl %%eax, %%fs:0" "\n\t" + + : + /* No outputs */ + : + [registration] "m" (registration), + [ok] "i" (TCL_OK), + [error] "i" (TCL_ERROR) + : + "%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory" + ); + +#else /* HAVE_NO_SEH */ + __try { + Tcl_Finalize(); } __except (EXCEPTION_EXECUTE_HANDLER) { /* empty handler body. */ } -#endif /* HAVE_NO_SEH */ +#endif + break; } return TRUE; } - -/* - *---------------------------------------------------------------------- - * - * _except_dllmain_detach_handler -- - * - * SEH exception handler for DllMain. - * - * Results: - * See DllMain. - * - * Side effects: - * See DllMain. - * - *---------------------------------------------------------------------- - */ -#ifdef HAVE_NO_SEH -static -__attribute__ ((cdecl)) -EXCEPTION_DISPOSITION -_except_dllmain_detach_handler( - struct _EXCEPTION_RECORD *ExceptionRecord, - void *EstablisherFrame, - struct _CONTEXT *ContextRecord, - void *DispatcherContext) -{ - __asm__ __volatile__ ( - "jmp dllmain_detach_reentry"); - return 0; /* Function does not return */ -} -#endif /* HAVE_NO_SEH */ - - #endif /* !STATIC_BUILD */ #endif /* __WIN32__ */ /* *---------------------------------------------------------------------- @@ -459,12 +431,12 @@ os.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); GetVersionEx(&os); platformId = os.dwPlatformId; /* - * We no longer support Win32s, so just in case someone manages to - * get a runtime there, make sure they know that. + * We no longer support Win32s, so just in case someone manages to get a + * runtime there, make sure they know that. */ if (platformId == VER_PLATFORM_WIN32s) { Tcl_Panic("Win32s is not a supported platform"); } @@ -475,12 +447,12 @@ /* *---------------------------------------------------------------------- * * TclWinGetPlatformId -- * - * Determines whether running under NT, 95, or Win32s, to allow - * runtime conditional code. + * Determines whether running under NT, 95, or Win32s, to allow runtime + * conditional code. * * Results: * The return value is one of: * VER_PLATFORM_WIN32s Win32s on Windows 3.1. (not supported) * VER_PLATFORM_WIN32_WINDOWS Win32 on Windows 95, 98, ME. @@ -532,12 +504,12 @@ /* *---------------------------------------------------------------------- * * TclpCheckStackSpace -- * - * Detect if we are about to blow the stack. Called before an - * evaluation can happen when nesting depth is checked. + * Detect if we are about to blow the stack. Called before an evaluation + * can happen when nesting depth is checked. * * Results: * 1 if there is enough stack space to continue; 0 if not. * * Side effects: @@ -547,160 +519,128 @@ */ int TclpCheckStackSpace() { + +#ifdef HAVE_NO_SEH + EXCEPTION_REGISTRATION registration; +#endif int retval = 0; /* - * We can recurse only if there is at least TCL_WIN_STACK_THRESHOLD - * bytes of stack space left. alloca() is cheap on windows; basically - * it just subtracts from the stack pointer causing the OS to throw an - * exception if the stack pointer is set below the bottom of the stack. + * We can recurse only if there is at least TCL_WIN_STACK_THRESHOLD bytes + * of stack space left. alloca() is cheap on windows; basically it just + * subtracts from the stack pointer causing the OS to throw an exception + * if the stack pointer is set below the bottom of the stack. */ #ifdef HAVE_NO_SEH -# ifdef TCL_MEM_DEBUG - __asm__ __volatile__ ( - "movl %%esp, %0" "\n\t" - "movl %%ebp, %1" "\n\t" - "movl %%fs:0, %2" "\n\t" - : "=m"(INITIAL_ESP), - "=m"(INITIAL_EBP), - "=r"(INITIAL_HANDLER) ); -# endif /* TCL_MEM_DEBUG */ - - __asm__ __volatile__ ( - "pushl %%ebp" "\n\t" - "pushl %0" "\n\t" - "pushl %%fs:0" "\n\t" - "movl %%esp, %%fs:0" - : - : "r" (_except_checkstackspace_handler) ); -#else - __try { -#endif /* HAVE_NO_SEH */ -#ifdef HAVE_ALLOCA_GCC_INLINE - __asm__ __volatile__ ( - "movl %0, %%eax" "\n\t" - "call __alloca" "\n\t" - : - : "i"(TCL_WIN_STACK_THRESHOLD) - : "%eax"); + __asm__ __volatile__ ( + + /* + * Construct an EXCEPTION_REGISTRATION to protect the call to __alloca + */ + + "leal %[registration], %%edx" "\n\t" + "movl %%fs:0, %%eax" "\n\t" + "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ + "leal 1f, %%eax" "\n\t" + "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ + "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ + "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */ + "movl %[error], 0x10(%%edx)" "\n\t" /* status */ + + /* + * Link the EXCEPTION_REGISTRATION on the chain + */ + + "movl %%edx, %%fs:0" "\n\t" + + /* + * Attempt a call to __alloca, to determine whether there's sufficient + * memory to be had. + */ + + "movl %[size], %%eax" "\n\t" + "pushl %%eax" "\n\t" + "call __alloca" "\n\t" + + /* + * Come here on a normal exit. Recover the EXCEPTION_REGISTRATION and + * store a TCL_OK status + */ + + "movl %%fs:0, %%edx" "\n\t" + "movl %[ok], %%eax" "\n\t" + "movl %%eax, 0x10(%%edx)" "\n\t" + "jmp 2f" "\n" + + /* + * Come here on an exception. Get the EXCEPTION_REGISTRATION that we + * previously put on the chain. + */ + + "1:" "\t" + "movl %%fs:0, %%edx" "\n\t" + "movl 0x8(%%edx), %%edx" "\n\t" + + /* + * Come here however we exited. Restore context from the + * EXCEPTION_REGISTRATION in case the stack is unbalanced. + */ + + "2:" "\t" + "movl 0xc(%%edx), %%esp" "\n\t" + "movl 0x8(%%edx), %%ebp" "\n\t" + "movl 0x0(%%edx), %%eax" "\n\t" + "movl %%eax, %%fs:0" "\n\t" + + : + /* No outputs */ + : + [registration] "m" (registration), + [ok] "i" (TCL_OK), + [error] "i" (TCL_ERROR), + [size] "i" (TCL_WIN_STACK_THRESHOLD) + : + "%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory" + ); + retval = (registration.status == TCL_OK); + +#else /* !HAVE_NO_SEH */ + __try { +#ifdef HAVE_ALLOCA_GCC_INLINE + __asm__ __volatile__ ( + "movl %0, %%eax" "\n\t" + "call __alloca" "\n\t" + : + : "i"(TCL_WIN_STACK_THRESHOLD) + : "%eax"); #else alloca(TCL_WIN_STACK_THRESHOLD); #endif /* HAVE_ALLOCA_GCC_INLINE */ retval = 1; -#ifdef HAVE_NO_SEH - __asm__ __volatile__ ( - "movl %%fs:0, %%esp" "\n\t" - "jmp checkstackspace_pop" "\n" - "checkstackspace_reentry:" "\n\t" - "movl %%fs:0, %%eax" "\n\t" - "movl 0x8(%%eax), %%esp" "\n\t" - "movl 0x8(%%esp), %%ebp" "\n" - "checkstackspace_pop:" "\n\t" - "movl (%%esp), %%eax" "\n\t" - "movl %%eax, %%fs:0" "\n\t" - "add $12, %%esp" "\n\t" - : - : - : "%eax"); - -# ifdef TCL_MEM_DEBUG - __asm__ __volatile__ ( - "movl %%esp, %0" "\n\t" - "movl %%ebp, %1" "\n\t" - "movl %%fs:0, %2" "\n\t" - : "=m"(RESTORED_ESP), - "=m"(RESTORED_EBP), - "=r"(RESTORED_HANDLER) ); - - if (INITIAL_ESP != RESTORED_ESP) - Tcl_Panic("ESP restored incorrectly"); - if (INITIAL_EBP != RESTORED_EBP) - Tcl_Panic("EBP restored incorrectly"); - if (INITIAL_HANDLER != RESTORED_HANDLER) - Tcl_Panic("HANDLER restored incorrectly"); -# endif /* TCL_MEM_DEBUG */ -#else } __except (EXCEPTION_EXECUTE_HANDLER) {} #endif /* HAVE_NO_SEH */ - - /* - * Avoid using control flow statements in the SEH guarded block! - */ + return retval; } - -/* - *---------------------------------------------------------------------- - * - * _except_checkstackspace_handler -- - * - * SEH exception handler for TclpCheckStackSpace. - * - * Results: - * See TclpCheckStackSpace. - * - * Side effects: - * See TclpCheckStackSpace. - * - *---------------------------------------------------------------------- - */ -#ifdef HAVE_NO_SEH -static -__attribute__ ((cdecl)) -EXCEPTION_DISPOSITION -_except_checkstackspace_handler( - struct _EXCEPTION_RECORD *ExceptionRecord, - void *EstablisherFrame, - struct _CONTEXT *ContextRecord, - void *DispatcherContext) -{ - __asm__ __volatile__ ( - "jmp checkstackspace_reentry"); - return 0; /* Function does not return */ -} -#endif /* HAVE_NO_SEH */ - -/* - *---------------------------------------------------------------------- - * - * TclWinGetPlatform -- - * - * This is a kludge that allows the test library to get access - * the internal tclPlatform variable. - * - * Results: - * Returns a pointer to the tclPlatform variable. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -TclPlatformType * -TclWinGetPlatform() -{ - return &tclPlatform; -} /* *--------------------------------------------------------------------------- * * TclWinSetInterfaces -- * - * A helper proc that allows the test library to change the - * tclWinProcs structure to dispatch to either the wide-character - * or multi-byte versions of the operating system calls, depending - * on whether Unicode is the system encoding. - * - * As well as this, we can also try to load in some additional - * procs which may/may not be present depending on the current - * Windows version (e.g. Win95 will not have the procs below). + * A helper proc that allows the test library to change the tclWinProcs + * structure to dispatch to either the wide-character or multi-byte + * versions of the operating system calls, depending on whether Unicode + * is the system encoding. + * + * As well as this, we can also try to load in some additional procs + * which may/may not be present depending on the current Windows version + * (e.g. Win95 will not have the procs below). * * Results: * None. * * Side effects: @@ -720,60 +660,59 @@ tclWinProcs = &unicodeProcs; tclWinTCharEncoding = Tcl_GetEncoding(NULL, "unicode"); if (tclWinProcs->getFileAttributesExProc == NULL) { HINSTANCE hInstance = LoadLibraryA("kernel32"); if (hInstance != NULL) { - tclWinProcs->getFileAttributesExProc = - (BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS, - LPVOID)) GetProcAddress(hInstance, "GetFileAttributesExW"); + tclWinProcs->getFileAttributesExProc = + (BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS, + LPVOID)) GetProcAddress(hInstance, + "GetFileAttributesExW"); tclWinProcs->createHardLinkProc = - (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*, - LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance, - "CreateHardLinkW"); - tclWinProcs->findFirstFileExProc = - (HANDLE (WINAPI *)(CONST TCHAR*, UINT, - LPVOID, UINT, LPVOID, DWORD)) GetProcAddress(hInstance, - "FindFirstFileExW"); - tclWinProcs->getVolumeNameForVMPProc = - (BOOL (WINAPI *)(CONST TCHAR*, TCHAR*, - DWORD)) GetProcAddress(hInstance, - "GetVolumeNameForVolumeMountPointW"); + (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*, + LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance, + "CreateHardLinkW"); + tclWinProcs->findFirstFileExProc = + (HANDLE (WINAPI *)(CONST TCHAR*, UINT, LPVOID, UINT, + LPVOID, DWORD)) GetProcAddress(hInstance, + "FindFirstFileExW"); + tclWinProcs->getVolumeNameForVMPProc = + (BOOL (WINAPI *)(CONST TCHAR*, TCHAR*, + DWORD)) GetProcAddress(hInstance, + "GetVolumeNameForVolumeMountPointW"); tclWinProcs->getLongPathNameProc = - (DWORD (WINAPI *)(CONST TCHAR*, TCHAR*, - DWORD)) GetProcAddress(hInstance, - "GetLongPathNameW"); + (DWORD (WINAPI *)(CONST TCHAR*, TCHAR*, + DWORD)) GetProcAddress(hInstance, "GetLongPathNameW"); FreeLibrary(hInstance); } hInstance = LoadLibraryA("advapi32"); if (hInstance != NULL) { tclWinProcs->getFileSecurityProc = (BOOL (WINAPI *)( - LPCTSTR lpFileName, - SECURITY_INFORMATION RequestedInformation, - PSECURITY_DESCRIPTOR pSecurityDescriptor, DWORD nLength, - LPDWORD lpnLengthNeeded)) GetProcAddress(hInstance, - "GetFileSecurityW"); + LPCTSTR lpFileName, + SECURITY_INFORMATION RequestedInformation, + PSECURITY_DESCRIPTOR pSecurityDescriptor, + DWORD nLength, LPDWORD lpnLengthNeeded)) + GetProcAddress(hInstance, "GetFileSecurityW"); tclWinProcs->impersonateSelfProc = (BOOL (WINAPI *) ( - SECURITY_IMPERSONATION_LEVEL ImpersonationLevel)) - GetProcAddress(hInstance, "ImpersonateSelf"); + SECURITY_IMPERSONATION_LEVEL ImpersonationLevel)) + GetProcAddress(hInstance, "ImpersonateSelf"); tclWinProcs->openThreadTokenProc = (BOOL (WINAPI *) ( - HANDLE ThreadHandle, DWORD DesiredAccess, BOOL OpenAsSelf, - PHANDLE TokenHandle)) GetProcAddress(hInstance, - "OpenThreadToken"); + HANDLE ThreadHandle, DWORD DesiredAccess, + BOOL OpenAsSelf, PHANDLE TokenHandle)) + GetProcAddress(hInstance, "OpenThreadToken"); tclWinProcs->revertToSelfProc = (BOOL (WINAPI *) (void)) - GetProcAddress(hInstance, "RevertToSelf"); + GetProcAddress(hInstance, "RevertToSelf"); tclWinProcs->mapGenericMaskProc = (VOID (WINAPI *) ( - PDWORD AccessMask, PGENERIC_MAPPING GenericMapping)) - GetProcAddress(hInstance, "MapGenericMask"); + PDWORD AccessMask, PGENERIC_MAPPING GenericMapping)) + GetProcAddress(hInstance, "MapGenericMask"); tclWinProcs->accessCheckProc = (BOOL (WINAPI *)( - PSECURITY_DESCRIPTOR pSecurityDescriptor, - HANDLE ClientToken, DWORD DesiredAccess, - PGENERIC_MAPPING GenericMapping, - PPRIVILEGE_SET PrivilegeSet, - LPDWORD PrivilegeSetLength, - LPDWORD GrantedAccess, - LPBOOL AccessStatus)) GetProcAddress(hInstance, - "AccessCheck"); + PSECURITY_DESCRIPTOR pSecurityDescriptor, + HANDLE ClientToken, DWORD DesiredAccess, + PGENERIC_MAPPING GenericMapping, + PPRIVILEGE_SET PrivilegeSet, + LPDWORD PrivilegeSetLength, LPDWORD GrantedAccess, + LPBOOL AccessStatus)) GetProcAddress(hInstance, + "AccessCheck"); FreeLibrary(hInstance); } } } else { tclWinProcs = &asciiProcs; @@ -780,33 +719,34 @@ tclWinTCharEncoding = NULL; if (tclWinProcs->getFileAttributesExProc == NULL) { HINSTANCE hInstance = LoadLibraryA("kernel32"); if (hInstance != NULL) { tclWinProcs->getFileAttributesExProc = - (BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS, - LPVOID)) GetProcAddress(hInstance, "GetFileAttributesExA"); + (BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS, + LPVOID)) GetProcAddress(hInstance, + "GetFileAttributesExA"); tclWinProcs->createHardLinkProc = - (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*, - LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance, - "CreateHardLinkA"); + (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*, + LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance, + "CreateHardLinkA"); tclWinProcs->findFirstFileExProc = NULL; tclWinProcs->getLongPathNameProc = NULL; /* - * The 'findFirstFileExProc' function exists on some - * of 95/98/ME, but it seems not to work as anticipated. - * Therefore we don't set this function pointer. The - * relevant code will fall back on a slower approach - * using the normal findFirstFileProc. + * The 'findFirstFileExProc' function exists on some of + * 95/98/ME, but it seems not to work as anticipated. + * Therefore we don't set this function pointer. The relevant + * code will fall back on a slower approach using the normal + * findFirstFileProc. * * (HANDLE (WINAPI *)(CONST TCHAR*, UINT, * LPVOID, UINT, LPVOID, DWORD)) GetProcAddress(hInstance, * "FindFirstFileExA"); */ tclWinProcs->getVolumeNameForVMPProc = - (BOOL (WINAPI *)(CONST TCHAR*, TCHAR*, - DWORD)) GetProcAddress(hInstance, - "GetVolumeNameForVolumeMountPointA"); + (BOOL (WINAPI *)(CONST TCHAR*, TCHAR*, + DWORD)) GetProcAddress(hInstance, + "GetVolumeNameForVolumeMountPointA"); FreeLibrary(hInstance); } } } } @@ -814,36 +754,40 @@ /* *--------------------------------------------------------------------------- * * TclWinResetInterfaceEncodings -- * - * Called during finalization to free up any encodings we use. - * The tclWinProcs-> look up table is still ok to use after - * this call, provided no encoding conversion is required. - * - * We also clean up any memory allocated in our mount point - * map which is used to follow certain kinds of symlinks. - * That code should never be used once encodings are taken - * down. - * + * Called during finalization to free up any encodings we use. The + * tclWinProcs-> look up table is still ok to use after this call, + * provided no encoding conversion is required. + * + * We also clean up any memory allocated in our mount point map which is + * used to follow certain kinds of symlinks. That code should never be + * used once encodings are taken down. + * * Results: * None. * * Side effects: * None. * *--------------------------------------------------------------------------- */ + void TclWinResetInterfaceEncodings() { MountPointMap *dlIter, *dlIter2; if (tclWinTCharEncoding != NULL) { Tcl_FreeEncoding(tclWinTCharEncoding); tclWinTCharEncoding = NULL; } - /* Clean up the mount point map */ + + /* + * Clean up the mount point map. + */ + Tcl_MutexLock(&mountPointMap); dlIter = driveLetterLookup; while (dlIter != NULL) { dlIter2 = dlIter->nextPtr; ckfree((char*)dlIter->volumeName); @@ -857,12 +801,12 @@ *--------------------------------------------------------------------------- * * TclWinResetInterfaces -- * * Called during finalization to reset us to a safe state for reuse. - * After this call, it is best not to use the tclWinProcs-> look - * up table since it is likely to be different to what is expected. + * After this call, it is best not to use the tclWinProcs-> look up table + * since it is likely to be different to what is expected. * * Results: * None. * * Side effects: @@ -879,125 +823,153 @@ /* *-------------------------------------------------------------------- * * TclWinDriveLetterForVolMountPoint * - * Unfortunately, Windows provides no easy way at all to get hold - * of the drive letter for a volume mount point, but we need that - * information to understand paths correctly. So, we have to - * build an associated array to find these correctly, and allow - * quick and easy lookup from volume mount points to drive letters. - * - * We assume here that we are running on a system for which the wide - * character interfaces are used, which is valid for Win 2000 and WinXP - * which are the only systems on which this function will ever be called. - * - * Result: the drive letter, or -1 if no drive letter corresponds to - * the given mount point. + * Unfortunately, Windows provides no easy way at all to get hold of the + * drive letter for a volume mount point, but we need that information to + * understand paths correctly. So, we have to build an associated array + * to find these correctly, and allow quick and easy lookup from volume + * mount points to drive letters. + * + * We assume here that we are running on a system for which the wide + * character interfaces are used, which is valid for Win 2000 and WinXP + * which are the only systems on which this function will ever be called. + * + * Result: + * The drive letter, or -1 if no drive letter corresponds to the given + * mount point. * *-------------------------------------------------------------------- */ + char TclWinDriveLetterForVolMountPoint(CONST WCHAR *mountPoint) { MountPointMap *dlIter, *dlPtr2; - WCHAR Target[55]; /* Target of mount at mount point */ + WCHAR Target[55]; /* Target of mount at mount point */ WCHAR drive[4] = { L'A', L':', L'\\', L'\0' }; /* - * Detect the volume mounted there. Unfortunately, there is no - * simple way to map a unique volume name to a DOS drive letter. - * So, we have to build an associative array. + * Detect the volume mounted there. Unfortunately, there is no simple way + * to map a unique volume name to a DOS drive letter. So, we have to build + * an associative array. */ Tcl_MutexLock(&mountPointMap); dlIter = driveLetterLookup; while (dlIter != NULL) { if (wcscmp(dlIter->volumeName, mountPoint) == 0) { /* - * We need to check whether this information is - * still valid, since either the user or various - * programs could have adjusted the mount points on - * the fly. + * We need to check whether this information is still valid, since + * either the user or various programs could have adjusted the + * mount points on the fly. */ + drive[0] = L'A' + (dlIter->driveLetter - 'A'); - /* Try to read the volume mount point and see where it points */ + + /* + * Try to read the volume mount point and see where it points. + */ + if ((*tclWinProcs->getVolumeNameForVMPProc)((TCHAR*)drive, - (TCHAR*)Target, 55) != 0) { + (TCHAR*)Target, 55) != 0) { if (wcscmp((WCHAR*)dlIter->volumeName, Target) == 0) { - /* Nothing has changed */ + /* + * Nothing has changed. + */ + Tcl_MutexUnlock(&mountPointMap); return dlIter->driveLetter; } } + /* - * If we reach here, unfortunately, this mount point is - * no longer valid at all + * If we reach here, unfortunately, this mount point is no longer + * valid at all. */ + if (driveLetterLookup == dlIter) { dlPtr2 = dlIter; driveLetterLookup = dlIter->nextPtr; } else { for (dlPtr2 = driveLetterLookup; - dlPtr2 != NULL; dlPtr2 = dlPtr2->nextPtr) { + dlPtr2 != NULL; dlPtr2 = dlPtr2->nextPtr) { if (dlPtr2->nextPtr == dlIter) { dlPtr2->nextPtr = dlIter->nextPtr; dlPtr2 = dlIter; break; } } } - /* Now dlPtr2 points to the structure to free */ + + /* + * Now dlPtr2 points to the structure to free. + */ + ckfree((char*)dlPtr2->volumeName); ckfree((char*)dlPtr2); + /* - * Restart the loop --- we could try to be clever - * and continue half way through, but the logic is a - * bit messy, so it's cleanest just to restart + * Restart the loop - we could try to be clever and continue half + * way through, but the logic is a bit messy, so it's cleanest + * just to restart. */ + dlIter = driveLetterLookup; continue; } dlIter = dlIter->nextPtr; } - /* We couldn't find it, so we must iterate over the letters */ + /* + * We couldn't find it, so we must iterate over the letters. + */ for (drive[0] = L'A'; drive[0] <= L'Z'; drive[0]++) { - /* Try to read the volume mount point and see where it points */ + /* + * Try to read the volume mount point and see where it points. + */ + if ((*tclWinProcs->getVolumeNameForVMPProc)((TCHAR*)drive, - (TCHAR*)Target, 55) != 0) { + (TCHAR*)Target, 55) != 0) { int alreadyStored = 0; + for (dlIter = driveLetterLookup; dlIter != NULL; - dlIter = dlIter->nextPtr) { + dlIter = dlIter->nextPtr) { if (wcscmp((WCHAR*)dlIter->volumeName, Target) == 0) { alreadyStored = 1; break; } } if (!alreadyStored) { - dlPtr2 = (MountPointMap*) ckalloc(sizeof(MountPointMap)); + dlPtr2 = (MountPointMap *) ckalloc(sizeof(MountPointMap)); dlPtr2->volumeName = TclNativeDupInternalRep(Target); dlPtr2->driveLetter = 'A' + (drive[0] - L'A'); dlPtr2->nextPtr = driveLetterLookup; driveLetterLookup = dlPtr2; } } } - /* Try again */ + + /* + * Try again. + */ + for (dlIter = driveLetterLookup; dlIter != NULL; - dlIter = dlIter->nextPtr) { + dlIter = dlIter->nextPtr) { if (wcscmp(dlIter->volumeName, mountPoint) == 0) { Tcl_MutexUnlock(&mountPointMap); return dlIter->driveLetter; } } + /* - * The volume doesn't appear to correspond to a drive letter -- we - * remember that fact and store '-1' so we don't have to look it - * up each time. + * The volume doesn't appear to correspond to a drive letter - we remember + * that fact and store '-1' so we don't have to look it up each time. */ + dlPtr2 = (MountPointMap*) ckalloc(sizeof(MountPointMap)); dlPtr2->volumeName = TclNativeDupInternalRep((ClientData)mountPoint); dlPtr2->driveLetter = -1; dlPtr2->nextPtr = driveLetterLookup; driveLetterLookup = dlPtr2; @@ -1008,52 +980,48 @@ /* *--------------------------------------------------------------------------- * * Tcl_WinUtfToTChar, Tcl_WinTCharToUtf -- * - * Convert between UTF-8 and Unicode when running Windows NT or - * the current ANSI code page when running Windows 95. + * Convert between UTF-8 and Unicode when running Windows NT or the + * current ANSI code page when running Windows 95. * - * On Mac, Unix, and Windows 95, all strings exchanged between Tcl - * and the OS are "char" oriented. We need only one Tcl_Encoding to - * convert between UTF-8 and the system's native encoding. We use - * NULL to represent that encoding. + * On Mac, Unix, and Windows 95, all strings exchanged between Tcl and + * the OS are "char" oriented. We need only one Tcl_Encoding to convert + * between UTF-8 and the system's native encoding. We use NULL to + * represent that encoding. * * On NT, some strings exchanged between Tcl and the OS are "char" - * oriented, while others are in Unicode. We need two Tcl_Encoding - * APIs depending on whether we are targeting a "char" or Unicode - * interface. - * - * Calling Tcl_UtfToExternal() or Tcl_ExternalToUtf() with an - * encoding of NULL should always used to convert between UTF-8 - * and the system's "char" oriented encoding. The following two - * functions are used in Windows-specific code to convert between - * UTF-8 and Unicode strings (NT) or "char" strings(95). This saves - * you the trouble of writing the following type of fragment over and - * over: + * oriented, while others are in Unicode. We need two Tcl_Encoding APIs + * depending on whether we are targeting a "char" or Unicode interface. + * + * Calling Tcl_UtfToExternal() or Tcl_ExternalToUtf() with an encoding of + * NULL should always used to convert between UTF-8 and the system's + * "char" oriented encoding. The following two functions are used in + * Windows-specific code to convert between UTF-8 and Unicode strings + * (NT) or "char" strings(95). This saves you the trouble of writing the + * following type of fragment over and over: * * if (running NT) { * encoding <- Tcl_GetEncoding("unicode"); * nativeBuffer <- UtfToExternal(encoding, utfBuffer); * Tcl_FreeEncoding(encoding); * } else { * nativeBuffer <- UtfToExternal(NULL, utfBuffer); * } * - * By convention, in Windows a TCHAR is a character in the ANSI code - * page on Windows 95, a Unicode character on Windows NT. If you - * plan on targeting a Unicode interfaces when running on NT and a - * "char" oriented interface while running on 95, these functions - * should be used. If you plan on targetting the same "char" - * oriented function on both 95 and NT, use Tcl_UtfToExternal() - * with an encoding of NULL. + * By convention, in Windows a TCHAR is a character in the ANSI code page + * on Windows 95, a Unicode character on Windows NT. If you plan on + * targeting a Unicode interfaces when running on NT and a "char" + * oriented interface while running on 95, these functions should be + * used. If you plan on targetting the same "char" oriented function on + * both 95 and NT, use Tcl_UtfToExternal() with an encoding of NULL. * * Results: - * The result is a pointer to the string in the desired target - * encoding. Storage for the result string is allocated in - * dsPtr; the caller must call Tcl_DStringFree() when the result - * is no longer needed. + * The result is a pointer to the string in the desired target encoding. + * Storage for the result string is allocated in dsPtr; the caller must + * call Tcl_DStringFree() when the result is no longer needed. * * Side effects: * None. * *--------------------------------------------------------------------------- @@ -1062,25 +1030,25 @@ TCHAR * Tcl_WinUtfToTChar(string, len, dsPtr) CONST char *string; /* Source string in UTF-8. */ int len; /* Source string length in bytes, or < 0 for * strlen(). */ - Tcl_DString *dsPtr; /* Uninitialized or free DString in which - * the converted string is stored. */ + Tcl_DString *dsPtr; /* Uninitialized or free DString in which the + * converted string is stored. */ { return (TCHAR *) Tcl_UtfToExternalDString(tclWinTCharEncoding, string, len, dsPtr); } char * Tcl_WinTCharToUtf(string, len, dsPtr) - CONST TCHAR *string; /* Source string in Unicode when running - * NT, ANSI when running 95. */ + CONST TCHAR *string; /* Source string in Unicode when running NT, + * ANSI when running 95. */ int len; /* Source string length in bytes, or < 0 for * platform-specific string length. */ - Tcl_DString *dsPtr; /* Uninitialized or free DString in which - * the converted string is stored. */ + Tcl_DString *dsPtr; /* Uninitialized or free DString in which the + * converted string is stored. */ { return Tcl_ExternalToUtfDString(tclWinTCharEncoding, (CONST char *) string, len, dsPtr); } @@ -1090,162 +1058,170 @@ * TclWinCPUID -- * * Get CPU ID information on an Intel box under Windows * * Results: - * Returns TCL_OK if successful, TCL_ERROR if CPUID is not - * supported or fails. + * Returns TCL_OK if successful, TCL_ERROR if CPUID is not supported or + * fails. * * Side effects: - * If successful, stores EAX, EBX, ECX and EDX registers after - * the CPUID instruction in the four integers designated by 'regsPtr' + * If successful, stores EAX, EBX, ECX and EDX registers after the CPUID + * instruction in the four integers designated by 'regsPtr' * *---------------------------------------------------------------------- */ int -TclWinCPUID( unsigned int index, /* Which CPUID value to retrieve */ - register unsigned int * regsPtr ) /* Registers after the CPUID */ +TclWinCPUID( + unsigned int index, /* Which CPUID value to retrieve. */ + unsigned int *regsPtr) /* Registers after the CPUID. */ { - +#ifdef HAVE_NO_SEH + EXCEPTION_REGISTRATION registration; +#endif int status = TCL_ERROR; -#if defined(__GNUC__) - - /* Establish structured exception handling */ - -# ifdef HAVE_NO_SEH - __asm__ __volatile__ ( - "pushl %%ebp" "\n\t" - "pushl %0" "\n\t" - "pushl %%fs:0" "\n\t" - "movl %%esp, %%fs:0" - : - : "r" (_except_TclWinCPUID_detach_handler) ); -# else - __try { -# endif - - /* - * Execute the CPUID instruction with the given index, and - * store results off 'regPtr'. - */ - - __asm__ __volatile__ ( - "movl %4, %%eax" "\n\t" - "cpuid" "\n\t" - "movl %%eax, %0" "\n\t" - "movl %%ebx, %1" "\n\t" - "movl %%ecx, %2" "\n\t" - "movl %%edx, %3" - : - "=m"(regsPtr[0]), - "=m"(regsPtr[1]), - "=m"(regsPtr[2]), - "=m"(regsPtr[3]) - : "m"(index) - : "%eax", "%ebx", "%ecx", "%edx" ); - status = TCL_OK; - - /* End the structured exception handler */ - -# ifndef HAVE_NO_SEH - } __except( EXCEPTION_EXECUTE_HANDLER ) { - /* do nothing */ - } -# else - __asm __volatile__ ( - "jmp TclWinCPUID_detach_pop" "\n" - "TclWinCPUID_detach_reentry:" "\n\t" - "movl %%fs:0, %%eax" "\n\t" - "movl 0x8(%%eax), %%esp" "\n\t" - "movl 0x8(%%esp), %%ebp" "\n" - "TclWinCPUID_detach_pop:" "\n\t" - "movl (%%esp), %%eax" "\n\t" - "movl %%eax, %%fs:0" "\n\t" - "add $12, %%esp" "\n\t" - : - : - : "%eax"); -# endif - +#if defined(__GNUC__) && !defined(_WIN64) + /* + * Execute the CPUID instruction with the given index, and store results + * off 'regPtr'. + */ + + __asm__ __volatile__( + /* + * Construct an EXCEPTION_REGISTRATION to protect the CPUID + * instruction (early 486's don't have CPUID) + */ + + "leal %[registration], %%edx" "\n\t" + "movl %%fs:0, %%eax" "\n\t" + "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ + "leal 1f, %%eax" "\n\t" + "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ + "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ + "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */ + "movl %[error], 0x10(%%edx)" "\n\t" /* status */ + + /* + * Link the EXCEPTION_REGISTRATION on the chain + */ + + "movl %%edx, %%fs:0" "\n\t" + + /* + * Do the CPUID instruction, and save the results in the 'regsPtr' + * area. + */ + + "movl %[rptr], %%edi" "\n\t" + "movl %[index], %%eax" "\n\t" + "cpuid" "\n\t" + "movl %%eax, 0x0(%%edi)" "\n\t" + "movl %%ebx, 0x4(%%edi)" "\n\t" + "movl %%ecx, 0x8(%%edi)" "\n\t" + "movl %%edx, 0xc(%%edi)" "\n\t" + + /* + * Come here on a normal exit. Recover the EXCEPTION_REGISTRATION and + * store a TCL_OK status. + */ + + "movl %%fs:0, %%edx" "\n\t" + "movl %[ok], %%eax" "\n\t" + "movl %%eax, 0x10(%%edx)" "\n\t" + "jmp 2f" "\n" + + /* + * Come here on an exception. Get the EXCEPTION_REGISTRATION that we + * previously put on the chain. + */ + + "1:" "\t" + "movl %%fs:0, %%edx" "\n\t" + "movl 0x8(%%edx), %%edx" "\n\t" + + /* + * Come here however we exited. Restore context from the + * EXCEPTION_REGISTRATION in case the stack is unbalanced. + */ + + "2:" "\t" + "movl 0xc(%%edx), %%esp" "\n\t" + "movl 0x8(%%edx), %%ebp" "\n\t" + "movl 0x0(%%edx), %%eax" "\n\t" + "movl %%eax, %%fs:0" "\n\t" + + : + /* No outputs */ + : + [index] "m" (index), + [rptr] "m" (regsPtr), + [registration] "m" (registration), + [ok] "i" (TCL_OK), + [error] "i" (TCL_ERROR) + : + "%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory"); + status = registration.status; #elif defined(_MSC_VER) && !defined(_WIN64) - - /* Define a structure in the stack frame to hold the registers */ + /* + * Define a structure in the stack frame to hold the registers. + */ struct { DWORD dw0; DWORD dw1; DWORD dw2; DWORD dw3; } regs; regs.dw0 = index; - /* Execute the CPUID instruction and save regs in the stack frame */ + /* + * Execute the CPUID instruction and save regs in the stack frame. + */ _try { _asm { push ebx push ecx push edx - mov eax, regs.dw0 - cpuid - mov regs.dw0, eax - mov regs.dw1, ebx - mov regs.dw2, ecx - mov regs.dw3, edx - pop edx - pop ecx - pop ebx - } - - /* Copy regs back out to the caller */ - - regsPtr[0]=regs.dw0; - regsPtr[1]=regs.dw1; - regsPtr[2]=regs.dw2; - regsPtr[3]=regs.dw3; - - status = TCL_OK; - } __except( EXCEPTION_EXECUTE_HANDLER ) { + mov eax, regs.dw0 + cpuid + mov regs.dw0, eax + mov regs.dw1, ebx + mov regs.dw2, ecx + mov regs.dw3, edx + pop edx + pop ecx + pop ebx + } + + /* + * Copy regs back out to the caller. + */ + + regsPtr[0] = regs.dw0; + regsPtr[1] = regs.dw1; + regsPtr[2] = regs.dw2; + regsPtr[3] = regs.dw3; + + status = TCL_OK; + } __except(EXCEPTION_EXECUTE_HANDLER) { + /* do nothing */ } #else - /* Don't know how to do assembly code for - * this compiler and/or architecture */ + /* + * Don't know how to do assembly code for this compiler and/or + * architecture. + */ #endif return status; } /* - *---------------------------------------------------------------------- - * - * _except_TclWinCPUID_detach_handler -- - * - * SEH exception handler for TclWinCPUID. - * - * Results: - * See TclWinCPUID. - * - * Side effects: - * See TclWinCPUID. - * - *---------------------------------------------------------------------- + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: */ - -#if defined( HAVE_NO_SEH ) -static -__attribute__((cdecl)) -EXCEPTION_DISPOSITION -_except_TclWinCPUID_detach_handler( - struct _EXCEPTION_RECORD *ExceptionRecord, - void *EstablisherFrame, - struct _CONTEXT *ContextRecord, - void *DispatcherContext) -{ - __asm__ __volatile__ ( - "jmp TclWinCPUID_detach_reentry" ); - return 0; /* Function does not return */ -} -#endif - Index: win/tclWinChan.c ================================================================== --- win/tclWinChan.c +++ win/tclWinChan.c @@ -1,17 +1,17 @@ /* * tclWinChan.c * - * Channel drivers for Windows channels based on files, command - * pipes and TCP sockets. + * Channel drivers for Windows channels based on files, command pipes and + * TCP sockets. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinChan.c,v 1.37 2004/10/20 14:50:44 dkf Exp $ + * RCS: @(#) $Id: tclWinChan.c,v 1.37.2.4 2005/08/02 18:17:00 dgp Exp $ */ #include "tclWinInt.h" #include "tclIO.h" @@ -40,11 +40,11 @@ * which events should be reported. */ int flags; /* State flags, see above for a list. */ HANDLE handle; /* Input/output file. */ struct FileInfo *nextPtr; /* Pointer to next registered file. */ int dirty; /* Boolean flag. Set if the OS may have data - * pending on the channel */ + * pending on the channel. */ } FileInfo; typedef struct ThreadSpecificData { /* * List of all file channels currently open. @@ -54,60 +54,58 @@ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* - * The following structure is what is added to the Tcl event queue when - * file events are generated. + * The following structure is what is added to the Tcl event queue when file + * events are generated. */ typedef struct FileEvent { - Tcl_Event header; /* Information that is standard for - * all events. */ - FileInfo *infoPtr; /* Pointer to file info structure. Note - * that we still have to verify that the - * file exists before dereferencing this + Tcl_Event header; /* Information that is standard for all + * events. */ + FileInfo *infoPtr; /* Pointer to file info structure. Note that + * we still have to verify that the file + * exists before dereferencing this * pointer. */ } FileEvent; /* * Static routines for this file: */ -static int FileBlockProc _ANSI_ARGS_((ClientData instanceData, - int mode)); -static void FileChannelExitHandler _ANSI_ARGS_(( - ClientData clientData)); -static void FileCheckProc _ANSI_ARGS_((ClientData clientData, - int flags)); -static int FileCloseProc _ANSI_ARGS_((ClientData instanceData, - Tcl_Interp *interp)); -static int FileEventProc _ANSI_ARGS_((Tcl_Event *evPtr, - int flags)); -static int FileGetHandleProc _ANSI_ARGS_((ClientData instanceData, - int direction, ClientData *handlePtr)); -static ThreadSpecificData *FileInit _ANSI_ARGS_((void)); -static int FileInputProc _ANSI_ARGS_((ClientData instanceData, - char *buf, int toRead, int *errorCode)); -static int FileOutputProc _ANSI_ARGS_((ClientData instanceData, - CONST char *buf, int toWrite, int *errorCode)); -static int FileSeekProc _ANSI_ARGS_((ClientData instanceData, - long offset, int mode, int *errorCode)); -static Tcl_WideInt FileWideSeekProc _ANSI_ARGS_((ClientData instanceData, - Tcl_WideInt offset, int mode, int *errorCode)); -static void FileSetupProc _ANSI_ARGS_((ClientData clientData, - int flags)); -static void FileWatchProc _ANSI_ARGS_((ClientData instanceData, - int mask)); +static int FileBlockProc(ClientData instanceData, int mode); +static void FileChannelExitHandler(ClientData clientData); +static void FileCheckProc(ClientData clientData, int flags); +static int FileCloseProc(ClientData instanceData, + Tcl_Interp *interp); +static int FileEventProc(Tcl_Event *evPtr, int flags); +static int FileGetHandleProc(ClientData instanceData, + int direction, ClientData *handlePtr); +static ThreadSpecificData *FileInit(void); +static int FileInputProc(ClientData instanceData, char *buf, + int toRead, int *errorCode); +static int FileOutputProc(ClientData instanceData, + CONST char *buf, int toWrite, int *errorCode); +static int FileSeekProc(ClientData instanceData, long offset, + int mode, int *errorCode); +static Tcl_WideInt FileWideSeekProc(ClientData instanceData, + Tcl_WideInt offset, int mode, int *errorCode); +static void FileSetupProc(ClientData clientData, int flags); +static void FileWatchProc(ClientData instanceData, int mask); +static void FileThreadActionProc(ClientData instanceData, + int action); +static int FileTruncateProc(ClientData instanceData, + Tcl_WideInt length); /* * This structure describes the channel type structure for file based IO. */ static Tcl_ChannelType fileChannelType = { "file", /* Type name. */ - TCL_CHANNEL_VERSION_3, /* v3 channel */ + TCL_CHANNEL_VERSION_4, /* v4 channel */ FileCloseProc, /* Close proc. */ FileInputProc, /* Input proc. */ FileOutputProc, /* Output proc. */ FileSeekProc, /* Seek proc. */ NULL, /* Set option proc. */ @@ -117,22 +115,29 @@ NULL, /* close2proc. */ FileBlockProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ FileWideSeekProc, /* Wide seek proc. */ + FileThreadActionProc, /* Thread action proc. */ + FileTruncateProc, /* Truncate proc. */ }; -#if defined(HAVE_NO_SEH) && defined(TCL_MEM_DEBUG) -static void *INITIAL_ESP, *INITIAL_EBP, *INITIAL_HANDLER; -static void *RESTORED_ESP, *RESTORED_EBP, *RESTORED_HANDLER; -#endif /* HAVE_NO_SEH && TCL_MEM_DEBUG */ - #ifdef HAVE_NO_SEH -static __attribute__ ((cdecl)) EXCEPTION_DISPOSITION -_except_makefilechannel_handler(struct _EXCEPTION_RECORD *ExceptionRecord, - void *EstablisherFrame, struct _CONTEXT *ContextRecord, - void *DispatcherContext); +/* + * Unlike Borland and Microsoft, we don't register exception handlers by + * pushing registration records onto the runtime stack. Instead, we register + * them by creating an EXCEPTION_REGISTRATION within the activation record. + */ + +typedef struct EXCEPTION_REGISTRATION { + struct EXCEPTION_REGISTRATION* link; + EXCEPTION_DISPOSITION (*handler)( + struct _EXCEPTION_RECORD*, void*, struct _CONTEXT*, void*); + void* ebp; + void* esp; + int status; +} EXCEPTION_REGISTRATION; #endif /* *---------------------------------------------------------------------- * @@ -167,12 +172,12 @@ /* *---------------------------------------------------------------------- * * FileChannelExitHandler -- * - * This function is called to cleanup the channel driver before - * Tcl is unloaded. + * This function is called to cleanup the channel driver before Tcl is + * unloaded. * * Results: * None. * * Side effects: @@ -191,12 +196,12 @@ /* *---------------------------------------------------------------------- * * FileSetupProc -- * - * This procedure is invoked before Tcl_DoOneEvent blocks waiting - * for an event. + * This function is invoked before Tcl_DoOneEvent blocks waiting for an + * event. * * Results: * None. * * Side effects: @@ -205,13 +210,12 @@ *---------------------------------------------------------------------- */ void FileSetupProc(data, flags) - ClientData data; /* Not used. */ - int flags; /* Event flags as passed to - * Tcl_DoOneEvent. */ + ClientData data; /* Not used. */ + int flags; /* Event flags as passed to Tcl_DoOneEvent. */ { FileInfo *infoPtr; Tcl_Time blockTime = { 0, 0 }; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -218,11 +222,11 @@ if (!(flags & TCL_FILE_EVENTS)) { return; } /* - * Check to see if there is a ready file. If so, poll. + * Check to see if there is a ready file. If so, poll. */ for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (infoPtr->watchMask) { @@ -235,12 +239,12 @@ /* *---------------------------------------------------------------------- * * FileCheckProc -- * - * This procedure is called by Tcl_DoOneEvent to check the file - * event source for events. + * This function is called by Tcl_DoOneEvent to check the file event + * source for events. * * Results: * None. * * Side effects: @@ -249,13 +253,12 @@ *---------------------------------------------------------------------- */ static void FileCheckProc(data, flags) - ClientData data; /* Not used. */ - int flags; /* Event flags as passed to - * Tcl_DoOneEvent. */ + ClientData data; /* Not used. */ + int flags; /* Event flags as passed to Tcl_DoOneEvent. */ { FileEvent *evPtr; FileInfo *infoPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -262,13 +265,12 @@ if (!(flags & TCL_FILE_EVENTS)) { return; } /* - * Queue events for any ready files that don't already have events - * queued (caused by persistent states that won't generate WinSock - * events). + * Queue events for any ready files that don't already have events queued + * (caused by persistent states that won't generate WinSock events). */ for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (infoPtr->watchMask && !(infoPtr->flags & FILE_PENDING)) { @@ -284,31 +286,31 @@ /* *---------------------------------------------------------------------- * * FileEventProc -- * - * This function is invoked by Tcl_ServiceEvent when a file event - * reaches the front of the event queue. This procedure invokes - * Tcl_NotifyChannel on the file. + * This function is invoked by Tcl_ServiceEvent when a file event reaches + * the front of the event queue. This function invokes Tcl_NotifyChannel + * on the file. * * Results: - * Returns 1 if the event was handled, meaning it should be removed - * from the queue. Returns 0 if the event was not handled, meaning - * it should stay on the queue. The only time the event isn't - * handled is if the TCL_FILE_EVENTS flag bit isn't set. + * Returns 1 if the event was handled, meaning it should be removed from + * the queue. Returns 0 if the event was not handled, meaning it should + * stay on the queue. The only time the event isn't handled is if the + * TCL_FILE_EVENTS flag bit isn't set. * * Side effects: * Whatever the notifier callback does. * *---------------------------------------------------------------------- */ static int FileEventProc(evPtr, flags) - Tcl_Event *evPtr; /* Event to service. */ - int flags; /* Flags that indicate what events to - * handle, such as TCL_FILE_EVENTS. */ + Tcl_Event *evPtr; /* Event to service. */ + int flags; /* Flags that indicate what events to handle, + * such as TCL_FILE_EVENTS. */ { FileEvent *fileEvPtr = (FileEvent *)evPtr; FileInfo *infoPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -316,13 +318,13 @@ return 0; } /* * Search through the list of watched files for the one whose handle - * matches the event. We do this rather than simply dereferencing - * the handle in the event so that files can be deleted while the - * event is in the queue. + * matches the event. We do this rather than simply dereferencing the + * handle in the event so that files can be deleted while the event is in + * the queue. */ for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (fileEvPtr->infoPtr == infoPtr) { @@ -350,13 +352,13 @@ *---------------------------------------------------------------------- */ static int FileBlockProc(instanceData, mode) - ClientData instanceData; /* Instance data for channel. */ - int mode; /* TCL_MODE_BLOCKING or - * TCL_MODE_NONBLOCKING. */ + ClientData instanceData; /* Instance data for channel. */ + int mode; /* TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ { FileInfo *infoPtr = (FileInfo *) instanceData; /* * Files on Windows can not be switched between blocking and nonblocking, @@ -389,26 +391,28 @@ *---------------------------------------------------------------------- */ static int FileCloseProc(instanceData, interp) - ClientData instanceData; /* Pointer to FileInfo structure. */ - Tcl_Interp *interp; /* Not used. */ + ClientData instanceData; /* Pointer to FileInfo structure. */ + Tcl_Interp *interp; /* Not used. */ { FileInfo *fileInfoPtr = (FileInfo *) instanceData; + FileInfo *infoPtr; + ThreadSpecificData *tsdPtr; int errorCode = 0; /* * Remove the file from the watch list. */ FileWatchProc(instanceData, 0); /* - * Don't close the Win32 handle if the handle is a standard channel - * during the thread exit process. Otherwise, one thread may kill - * the stdio of another. + * Don't close the Win32 handle if the handle is a standard channel during + * the thread exit process. Otherwise, one thread may kill the stdio of + * another. */ if (!TclInThreadExit() || ((GetStdHandle(STD_INPUT_HANDLE) != fileInfoPtr->handle) && (GetStdHandle(STD_OUTPUT_HANDLE) != fileInfoPtr->handle) @@ -417,10 +421,29 @@ TclWinConvertError(GetLastError()); errorCode = errno; } } + /* + * See if this FileInfo* is still on the thread local list. + */ + + tsdPtr = TCL_TSD_INIT(&dataKey); + for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + if (infoPtr == fileInfoPtr) { + /* + * This channel exists on the thread local list. It should have + * been removed by an earlier Threadaction call, but do that now + * since just deallocating fileInfoPtr would leave an deallocated + * pointer on the thread local list. + */ + + FileThreadActionProc(fileInfoPtr,TCL_CHANNEL_THREAD_REMOVE); + break; + } + } ckfree((char *)fileInfoPtr); return errorCode; } /* @@ -429,26 +452,26 @@ * FileSeekProc -- * * Seeks on a file-based channel. Returns the new position. * * Results: - * -1 if failed, the new position if successful. If failed, it - * also sets *errorCodePtr to the error code. + * -1 if failed, the new position if successful. If failed, it also sets + * *errorCodePtr to the error code. * * Side effects: - * Moves the location at which the channel will be accessed in - * future operations. + * Moves the location at which the channel will be accessed in future + * operations. * *---------------------------------------------------------------------- */ static int FileSeekProc(instanceData, offset, mode, errorCodePtr) - ClientData instanceData; /* File state. */ - long offset; /* Offset to seek to. */ - int mode; /* Relative to where should we seek? */ - int *errorCodePtr; /* To store error code. */ + ClientData instanceData; /* File state. */ + long offset; /* Offset to seek to. */ + int mode; /* Relative to where should we seek? */ + int *errorCodePtr; /* To store error code. */ { FileInfo *infoPtr = (FileInfo *) instanceData; LONG newPos, newPosHigh, oldPos, oldPosHigh; DWORD moveMethod; @@ -462,10 +485,11 @@ } /* * Save our current place in case we need to roll-back the seek. */ + oldPosHigh = 0; oldPos = SetFilePointer(infoPtr->handle, 0, &oldPosHigh, FILE_CURRENT); if (oldPos == INVALID_SET_FILE_POINTER) { DWORD winError = GetLastError(); @@ -489,10 +513,11 @@ } /* * Check for expressability in our return type, and roll-back otherwise. */ + if (newPosHigh != 0) { *errorCodePtr = EOVERFLOW; SetFilePointer(infoPtr->handle, oldPos, &oldPosHigh, FILE_BEGIN); return -1; } @@ -505,26 +530,26 @@ * FileWideSeekProc -- * * Seeks on a file-based channel. Returns the new position. * * Results: - * -1 if failed, the new position if successful. If failed, it - * also sets *errorCodePtr to the error code. + * -1 if failed, the new position if successful. If failed, it also sets + * *errorCodePtr to the error code. * * Side effects: - * Moves the location at which the channel will be accessed in - * future operations. + * Moves the location at which the channel will be accessed in future + * operations. * *---------------------------------------------------------------------- */ static Tcl_WideInt FileWideSeekProc(instanceData, offset, mode, errorCodePtr) - ClientData instanceData; /* File state. */ - Tcl_WideInt offset; /* Offset to seek to. */ - int mode; /* Relative to where should we seek? */ - int *errorCodePtr; /* To store error code. */ + ClientData instanceData; /* File state. */ + Tcl_WideInt offset; /* Offset to seek to. */ + int mode; /* Relative to where should we seek? */ + int *errorCodePtr; /* To store error code. */ { FileInfo *infoPtr = (FileInfo *) instanceData; DWORD moveMethod; LONG newPos, newPosHigh; @@ -553,14 +578,86 @@ } /* *---------------------------------------------------------------------- * + * FileTruncateProc -- + * + * Truncates a file-based channel. Returns the error code. + * + * Results: + * 0 if successful, POSIX-y error code if it failed. + * + * Side effects: + * Truncates the file, may move file pointers too. + * + *---------------------------------------------------------------------- + */ + +static int +FileTruncateProc(instanceData, length) + ClientData instanceData; /* File state. */ + Tcl_WideInt length; /* Length to truncate at. */ +{ + FileInfo *infoPtr = (FileInfo *) instanceData; + LONG newPos, newPosHigh, oldPos, oldPosHigh; + + /* + * Save where we were... + */ + + oldPosHigh = 0; + oldPos = SetFilePointer(infoPtr->handle, 0, &oldPosHigh, FILE_CURRENT); + if (oldPos == INVALID_SET_FILE_POINTER) { + DWORD winError = GetLastError(); + if (winError != NO_ERROR) { + TclWinConvertError(winError); + return errno; + } + } + + /* + * Move to where we want to truncate + */ + + newPosHigh = Tcl_WideAsLong(length >> 32); + newPos = SetFilePointer(infoPtr->handle, Tcl_WideAsLong(length), + &newPosHigh, FILE_BEGIN); + if (newPos == INVALID_SET_FILE_POINTER) { + DWORD winError = GetLastError(); + if (winError != NO_ERROR) { + TclWinConvertError(winError); + return errno; + } + } + + /* + * Perform the truncation (unlike POSIX ftruncate(), we needed to move to + * the location to truncate at first). + */ + + if (!SetEndOfFile(infoPtr->handle)) { + TclWinConvertError(GetLastError()); + return errno; + } + + /* + * Move back. If this last step fails, we don't care; it's just a "best + * effort" attempt to restore our file pointer to where it was. + */ + + SetFilePointer(infoPtr->handle, oldPos, &oldPosHigh, FILE_BEGIN); + return 0; +} + +/* + *---------------------------------------------------------------------- + * * FileInputProc -- * - * Reads input from the IO channel into the buffer given. Returns - * count of how many bytes were actually read, and an error indication. + * Reads input from the IO channel into the buffer given. Returns count + * of how many bytes were actually read, and an error indication. * * Results: * A count of how many bytes were read is returned and an error * indication is returned in an output argument. * @@ -570,27 +667,27 @@ *---------------------------------------------------------------------- */ static int FileInputProc(instanceData, buf, bufSize, errorCode) - ClientData instanceData; /* File state. */ - char *buf; /* Where to store data read. */ - int bufSize; /* Num bytes available in buffer. */ - int *errorCode; /* Where to store error code. */ + ClientData instanceData; /* File state. */ + char *buf; /* Where to store data read. */ + int bufSize; /* Num bytes available in buffer. */ + int *errorCode; /* Where to store error code. */ { FileInfo *infoPtr; DWORD bytesRead; *errorCode = 0; infoPtr = (FileInfo *) instanceData; /* - * Note that we will block on reads from a console buffer until a - * full line has been entered. The only way I know of to get - * around this is to write a console driver. We should probably - * do this at some point, but for now, we just block. The same - * problem exists for files being read over the network. + * Note that we will block on reads from a console buffer until a full + * line has been entered. The only way I know of to get around this is to + * write a console driver. We should probably do this at some point, but + * for now, we just block. The same problem exists for files being read + * over the network. */ if (ReadFile(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &bytesRead, (LPOVERLAPPED) NULL) != FALSE) { return bytesRead; @@ -607,29 +704,29 @@ /* *---------------------------------------------------------------------- * * FileOutputProc -- * - * Writes the given output on the IO channel. Returns count of how - * many characters were actually written, and an error indication. + * Writes the given output on the IO channel. Returns count of how many + * characters were actually written, and an error indication. * * Results: - * A count of how many characters were written is returned and an - * error indication is returned in an output argument. + * A count of how many characters were written is returned and an error + * indication is returned in an output argument. * * Side effects: * Writes output on the actual channel. * *---------------------------------------------------------------------- */ static int FileOutputProc(instanceData, buf, toWrite, errorCode) - ClientData instanceData; /* File state. */ - CONST char *buf; /* The data buffer. */ - int toWrite; /* How many bytes to write? */ - int *errorCode; /* Where to store error code. */ + ClientData instanceData; /* File state. */ + CONST char *buf; /* The data buffer. */ + int toWrite; /* How many bytes to write? */ + int *errorCode; /* Where to store error code. */ { FileInfo *infoPtr = (FileInfo *) instanceData; DWORD bytesWritten; *errorCode = 0; @@ -656,12 +753,11 @@ /* *---------------------------------------------------------------------- * * FileWatchProc -- * - * Called by the notifier to set up to watch for events on this - * channel. + * Called by the notifier to set up to watch for events on this channel. * * Results: * None. * * Side effects: @@ -670,21 +766,21 @@ *---------------------------------------------------------------------- */ static void FileWatchProc(instanceData, mask) - ClientData instanceData; /* File state. */ - int mask; /* What events to watch for; OR-ed - * combination of TCL_READABLE, - * TCL_WRITABLE and TCL_EXCEPTION. */ + ClientData instanceData; /* File state. */ + int mask; /* What events to watch for; OR-ed combination + * of TCL_READABLE, TCL_WRITABLE and + * TCL_EXCEPTION. */ { FileInfo *infoPtr = (FileInfo *) instanceData; Tcl_Time blockTime = { 0, 0 }; /* - * Since the file is always ready for events, we set the block time - * to zero so we will poll. + * Since the file is always ready for events, we set the block time to + * zero so we will poll. */ infoPtr->watchMask = mask & infoPtr->validMask; if (infoPtr->watchMask) { Tcl_SetMaxBlockTime(&blockTime); @@ -694,28 +790,28 @@ /* *---------------------------------------------------------------------- * * FileGetHandleProc -- * - * Called from Tcl_GetChannelHandle to retrieve OS handles from - * a file based channel. + * Called from Tcl_GetChannelHandle to retrieve OS handles from a file + * based channel. * * Results: - * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if - * there is no handle for the specified direction. + * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no + * handle for the specified direction. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int FileGetHandleProc(instanceData, direction, handlePtr) - ClientData instanceData; /* The file state. */ - int direction; /* TCL_READABLE or TCL_WRITABLE */ - ClientData *handlePtr; /* Where to store the handle. */ + ClientData instanceData; /* The file state. */ + int direction; /* TCL_READABLE or TCL_WRITABLE */ + ClientData *handlePtr; /* Where to store the handle. */ { FileInfo *infoPtr = (FileInfo *) instanceData; if (direction & infoPtr->validMask) { *handlePtr = (ClientData) infoPtr->handle; @@ -731,29 +827,28 @@ * TclpOpenFileChannel -- * * Open an File based channel on Unix systems. * * Results: - * The new channel or NULL. If NULL, the output argument - * errorCodePtr is set to a POSIX error. + * The new channel or NULL. If NULL, the output argument errorCodePtr is + * set to a POSIX error. * * Side effects: - * May open the channel and may cause creation of a file on the - * file system. + * May open the channel and may cause creation of a file on the file + * system. * *---------------------------------------------------------------------- */ Tcl_Channel TclpOpenFileChannel(interp, pathPtr, mode, permissions) - Tcl_Interp *interp; /* Interpreter for error reporting; - * can be NULL. */ - Tcl_Obj *pathPtr; /* Name of file to open. */ - int mode; /* POSIX mode. */ - int permissions; /* If the open involves creating a - * file, with what modes to create - * it? */ + Tcl_Interp *interp; /* Interpreter for error reporting; can be + * NULL. */ + Tcl_Obj *pathPtr; /* Name of file to open. */ + int mode; /* POSIX mode. */ + int permissions; /* If the open involves creating a file, with + * what modes to create it? */ { Tcl_Channel channel = 0; int channelPermissions; DWORD accessMode, createMode, shareMode, flags, consoleParams, type; CONST TCHAR *nativeName; @@ -834,11 +929,11 @@ /* * Now we get to create the file. */ - handle = (*tclWinProcs->createFileProc)(nativeName, accessMode, + handle = (*tclWinProcs->createFileProc)(nativeName, accessMode, shareMode, NULL, createMode, flags, (HANDLE) NULL); if (handle == INVALID_HANDLE_VALUE) { DWORD err = GetLastError(); @@ -854,13 +949,13 @@ } type = GetFileType(handle); /* - * If the file is a character device, we need to try to figure out - * whether it is a serial port, a console, or something else. We - * test for the console case first because this is more common. + * If the file is a character device, we need to try to figure out whether + * it is a serial port, a console, or something else. We test for the + * console case first because this is more common. */ if (type == FILE_TYPE_CHAR) { if (GetConsoleMode(handle, &consoleParams)) { type = FILE_TYPE_CONSOLE; @@ -877,13 +972,14 @@ channel = NULL; switch (type) { case FILE_TYPE_SERIAL: /* - * Reopen channel for OVERLAPPED operation - * Normally this shouldn't fail, because the channel exists + * Reopen channel for OVERLAPPED operation. Normally this shouldn't + * fail, because the channel exists. */ + handle = TclWinSerialReopen(handle, nativeName, accessMode); if (handle == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); if (interp != (Tcl_Interp *) NULL) { Tcl_AppendResult(interp, "couldn't reopen serial \"", @@ -915,12 +1011,12 @@ channelPermissions, (mode & O_APPEND) ? FILE_APPEND : 0); break; default: /* - * The handle is of an unknown type, probably /dev/nul equivalent - * or possibly a closed handle. + * The handle is of an unknown type, probably /dev/nul equivalent or + * possibly a closed handle. */ channel = NULL; Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr), "\": bad file type", (char *) NULL); @@ -933,12 +1029,11 @@ /* *---------------------------------------------------------------------- * * Tcl_MakeFileChannel -- * - * Creates a Tcl_Channel from an existing platform specific file - * handle. + * Creates a Tcl_Channel from an existing platform specific file handle. * * Results: * The Tcl_Channel created around the preexisting file. * * Side effects: @@ -947,15 +1042,17 @@ *---------------------------------------------------------------------- */ Tcl_Channel Tcl_MakeFileChannel(rawHandle, mode) - ClientData rawHandle; /* OS level handle */ - int mode; /* ORed combination of TCL_READABLE - * and TCL_WRITABLE to indicate file - * mode. */ + ClientData rawHandle; /* OS level handle */ + int mode; /* ORed combination of TCL_READABLE and + * TCL_WRITABLE to indicate file mode. */ { +#ifdef HAVE_NO_SEH + EXCEPTION_REGISTRATION registration; +#endif char channelName[16 + TCL_INTEGER_SPACE]; Tcl_Channel channel = NULL; HANDLE handle = (HANDLE) rawHandle; HANDLE dupedHandle; DWORD consoleParams, type; @@ -971,13 +1068,13 @@ */ type = GetFileType(handle); /* - * If the file is a character device, we need to try to figure out - * whether it is a serial port, a console, or something else. We - * test for the console case first because this is more common. + * If the file is a character device, we need to try to figure out whether + * it is a serial port, a console, or something else. We test for the + * console case first because this is more common. */ if (type == FILE_TYPE_CHAR) { if (GetConsoleMode(handle, &consoleParams)) { type = FILE_TYPE_CONSOLE; @@ -1014,14 +1111,14 @@ break; case FILE_TYPE_UNKNOWN: default: /* - * The handle is of an unknown type. Test the validity of this OS - * handle by duplicating it, then closing the dupe. The Win32 API + * The handle is of an unknown type. Test the validity of this OS + * handle by duplicating it, then closing the dupe. The Win32 API * doesn't provide an IsValidHandle() function, so we have to emulate - * it here. This test will not work on a console handle reliably, + * it here. This test will not work on a console handle reliably, * which is why we can't test every handle that comes into this * function in this way. */ result = DuplicateHandle(GetCurrentProcess(), handle, @@ -1040,89 +1137,105 @@ /* * Use structured exception handling (Win32 SEH) to protect the close * of this duped handle which might throw EXCEPTION_INVALID_HANDLE. */ -#ifdef HAVE_NO_SEH -# ifdef TCL_MEM_DEBUG - __asm__ __volatile__ ( - "movl %%esp, %0" "\n\t" - "movl %%ebp, %1" "\n\t" - "movl %%fs:0, %2" "\n\t" - : "=m"(INITIAL_ESP), - "=m"(INITIAL_EBP), - "=r"(INITIAL_HANDLER) ); -# endif /* TCL_MEM_DEBUG */ - - __asm__ __volatile__ ( - "pushl %%ebp" "\n\t" - "pushl %0" "\n\t" - "pushl %%fs:0" "\n\t" - "movl %%esp, %%fs:0" - : - : "r" (_except_makefilechannel_handler) ); - result = CloseHandle(dupedHandle); - __asm__ __volatile__ ( - "jmp makefilechannel_pop" "\n" - "makefilechannel_reentry:" "\n\t" - "movl %%fs:0, %%eax" "\n\t" - "movl 0x8(%%eax), %%esp" "\n\t" - "movl 0x8(%%esp), %%ebp" "\n" - "movl $0, %0" "\n" - "makefilechannel_pop:" "\n\t" - "movl (%%esp), %%eax" "\n\t" - "movl %%eax, %%fs:0" "\n\t" - "add $12, %%esp" "\n\t" - : "=m"(result) - : - : "%eax"); - -# ifdef TCL_MEM_DEBUG - __asm__ __volatile__ ( - "movl %%esp, %0" "\n\t" - "movl %%ebp, %1" "\n\t" - "movl %%fs:0, %2" "\n\t" - : "=m"(RESTORED_ESP), - "=m"(RESTORED_EBP), - "=r"(RESTORED_HANDLER) ); - - if (INITIAL_ESP != RESTORED_ESP) { - Tcl_Panic("ESP restored incorrectly"); - } - if (INITIAL_EBP != RESTORED_EBP) { - Tcl_Panic("EBP restored incorrectly"); - } - if (INITIAL_HANDLER != RESTORED_HANDLER) { - Tcl_Panic("HANDLER restored incorrectly"); - } -# endif /* TCL_MEM_DEBUG */ - - if (result == 0) { - /* - * The handle failed to close. The original is therefore - * invalid. - */ - - return NULL; - } - -#else - __try { - result = CloseHandle(dupedHandle); - } __except (EXCEPTION_EXECUTE_HANDLER) { - /* - * Definately an invalid handle. So, therefore, the original - * is invalid also. - */ - - return NULL; - } -#endif /* HAVE_NO_SEH */ - - /* Fall through, the handle is valid. */ - - /* + result = 0; +#ifndef HAVE_NO_SEH + __try { + CloseHandle(dupedHandle); + result = 1; + } __except (EXCEPTION_EXECUTE_HANDLER) {} +#else + /* + * Don't have SEH available, do things the hard way. Note that this + * needs to be one block of asm, to avoid stack imbalance; also, it is + * illegal for one asm block to contain a jump to another. + */ + + __asm__ __volatile__ ( + + /* + * Pick up parameters before messing with the stack + */ + + "movl %[dupedHandle], %%ebx" "\n\t" + + /* + * Construct an EXCEPTION_REGISTRATION to protect the call to + * CloseHandle. + */ + + "leal %[registration], %%edx" "\n\t" + "movl %%fs:0, %%eax" "\n\t" + "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ + "leal 1f, %%eax" "\n\t" + "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ + "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ + "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */ + "movl $0, 0x10(%%edx)" "\n\t" /* status */ + + /* + * Link the EXCEPTION_REGISTRATION on the chain. + */ + + "movl %%edx, %%fs:0" "\n\t" + + /* + * Call CloseHandle(dupedHandle). + */ + + "pushl %%ebx" "\n\t" + "call _CloseHandle@4" "\n\t" + + /* + * Come here on normal exit. Recover the EXCEPTION_REGISTRATION + * and put a TRUE status return into it. + */ + + "movl %%fs:0, %%edx" "\n\t" + "movl $1, %%eax" "\n\t" + "movl %%eax, 0x10(%%edx)" "\n\t" + "jmp 2f" "\n" + + /* + * Come here on an exception. Recover the EXCEPTION_REGISTRATION + */ + + "1:" "\t" + "movl %%fs:0, %%edx" "\n\t" + "movl 0x8(%%edx), %%edx" "\n\t" + + /* + * Come here however we exited. Restore context from the + * EXCEPTION_REGISTRATION in case the stack is unbalanced. + */ + + "2:" "\t" + "movl 0xc(%%edx), %%esp" "\n\t" + "movl 0x8(%%edx), %%ebp" "\n\t" + "movl 0x0(%%edx), %%eax" "\n\t" + "movl %%eax, %%fs:0" "\n\t" + + : + /* No outputs */ + : + [registration] "m" (registration), + [dupedHandle] "m" (dupedHandle) + : + "%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory" + ); + result = registration.status; + +#endif + if (result == FALSE) { + return NULL; + } + + /* + * Fall through, the handle is valid. + * * Create the undefined channel, anyways, because we know the handle * is valid to something. */ channel = TclWinOpenFileChannel(handle, channelName, mode, 0); @@ -1132,59 +1245,27 @@ } /* *---------------------------------------------------------------------- * - * _except_makefilechannel_handler -- - * - * SEH exception handler for Tcl_MakeFileChannel. - * - * Results: - * See Tcl_MakeFileChannel. - * - * Side effects: - * See Tcl_MakeFileChannel. - * - *---------------------------------------------------------------------- - */ -#ifdef HAVE_NO_SEH -static -__attribute__ ((cdecl)) -EXCEPTION_DISPOSITION -_except_makefilechannel_handler( - struct _EXCEPTION_RECORD *ExceptionRecord, - void *EstablisherFrame, - struct _CONTEXT *ContextRecord, - void *DispatcherContext) -{ - __asm__ __volatile__ ( - "jmp makefilechannel_reentry"); - return 0; /* Function does not return */ -} -#endif - -/* - *---------------------------------------------------------------------- - * * TclpGetDefaultStdChannel -- * * Constructs a channel for the specified standard OS handle. * * Results: * Returns the specified default standard channel, or NULL. * * Side effects: - * May cause the creation of a standard channel and the underlying - * file. + * May cause the creation of a standard channel and the underlying file. * *---------------------------------------------------------------------- */ Tcl_Channel TclpGetDefaultStdChannel(type) - int type; /* One of TCL_STDIN, TCL_STDOUT, or - * TCL_STDERR. */ + int type; /* One of TCL_STDIN, TCL_STDOUT, or + * TCL_STDERR. */ { Tcl_Channel channel; HANDLE handle; int mode; char *bufMode; @@ -1245,35 +1326,34 @@ /* *---------------------------------------------------------------------- * * TclWinOpenFileChannel -- * - * Constructs a File channel for the specified standard OS handle. - * This is a helper function to break up the construction of - * channels into File, Console, or Serial. + * Constructs a File channel for the specified standard OS handle. This + * is a helper function to break up the construction of channels into + * File, Console, or Serial. * * Results: * Returns the new channel, or NULL. * * Side effects: - * May open the channel and may cause creation of a file on the - * file system. + * May open the channel and may cause creation of a file on the file + * system. * *---------------------------------------------------------------------- */ Tcl_Channel TclWinOpenFileChannel(handle, channelName, permissions, appendMode) - HANDLE handle; /* Win32 HANDLE to swallow */ - char *channelName; /* Buffer to receive channel name */ - int permissions; /* OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, or TCL_EXCEPTION, - * indicating which operations are - * valid on the file. */ - int appendMode; /* OR'ed combination of bits indicating - * what additional configuration of the - * channel is present. */ + HANDLE handle; /* Win32 HANDLE to swallow */ + char *channelName; /* Buffer to receive channel name */ + int permissions; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, or TCL_EXCEPTION, indicating + * which operations are valid on the file. */ + int appendMode; /* OR'ed combination of bits indicating what + * additional configuration of the channel is + * present. */ { FileInfo *infoPtr; ThreadSpecificData *tsdPtr = FileInit(); /* @@ -1286,12 +1366,18 @@ return (permissions==infoPtr->validMask) ? infoPtr->channel : NULL; } } infoPtr = (FileInfo *) ckalloc((unsigned) sizeof(FileInfo)); - infoPtr->nextPtr = tsdPtr->firstFilePtr; - tsdPtr->firstFilePtr = infoPtr; + + /* + * TIP #218. Removed the code inserting the new structure into the global + * list. This is now handled in the thread action callbacks, and only + * there. + */ + + infoPtr->nextPtr = NULL; infoPtr->validMask = permissions; infoPtr->watchMask = 0; infoPtr->flags = appendMode; infoPtr->handle = handle; infoPtr->dirty = 0; @@ -1299,12 +1385,12 @@ infoPtr->channel = Tcl_CreateChannel(&fileChannelType, channelName, (ClientData) infoPtr, permissions); /* - * Files have default translation of AUTO and ^Z eof char, which - * means that a ^Z will be accepted as EOF when reading. + * Files have default translation of AUTO and ^Z eof char, which means + * that a ^Z will be accepted as EOF when reading. */ Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto"); Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}"); @@ -1314,34 +1400,33 @@ /* *---------------------------------------------------------------------- * * TclWinFlushDirtyChannels -- * - * Flush all dirty channels to disk, so that requesting the - * size of any file returns the correct value. + * Flush all dirty channels to disk, so that requesting the size of any + * file returns the correct value. * * Results: * None. * * Side effects: - * Information is actually written to disk now, rather than - * later. Don't call this too often, or there will be a - * performance hit (i.e. only call when we need to ask for - * the size of a file). + * Information is actually written to disk now, rather than later. Don't + * call this too often, or there will be a performance hit (i.e. only + * call when we need to ask for the size of a file). * *---------------------------------------------------------------------- */ void -TclWinFlushDirtyChannels () +TclWinFlushDirtyChannels() { FileInfo *infoPtr; ThreadSpecificData *tsdPtr = FileInit(); /* - * Flush all channels which are dirty, i.e. may have data pending - * in the OS + * Flush all channels which are dirty, i.e. may have data pending in the + * OS. */ for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (infoPtr->dirty) { @@ -1352,14 +1437,13 @@ } /* *---------------------------------------------------------------------- * - * TclpCutFileChannel -- + * FileThreadActionProc -- * - * Remove any thread local refs to this channel. See - * See Tcl_CutChannel for more info. + * Insert or remove any thread local refs to this channel. * * Results: * None. * * Side effects: @@ -1366,79 +1450,48 @@ * Changes thread local list of valid channels. * *---------------------------------------------------------------------- */ -void -TclpCutFileChannel(chan) - Tcl_Channel chan; /* The channel being removed. Must - * not be referenced in any - * interpreter. */ -{ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - Channel *chanPtr = (Channel *) chan; - FileInfo *infoPtr; - FileInfo **nextPtrPtr; - int removed = 0; - - if (chanPtr->typePtr != &fileChannelType) { - return; - } - - infoPtr = (FileInfo *) chanPtr->instanceData; - - for (nextPtrPtr = &(tsdPtr->firstFilePtr); (*nextPtrPtr) != NULL; - nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { - if ((*nextPtrPtr) == infoPtr) { - (*nextPtrPtr) = infoPtr->nextPtr; - removed = 1; - break; - } - } - - /* - * This could happen if the channel was created in one thread - * and then moved to another without updating the thread - * local data in each thread. - */ - - if (!removed) { - Tcl_Panic("file info ptr not on thread channel list"); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclpSpliceFileChannel -- - * - * Insert thread local ref for this channel. - * See Tcl_SpliceChannel for more info. - * - * Results: - * None. - * - * Side effects: - * Changes thread local list of valid channels. - * - *---------------------------------------------------------------------- - */ - -void -TclpSpliceFileChannel(chan) - Tcl_Channel chan; /* The channel being removed. Must - * not be referenced in any - * interpreter. */ -{ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - Channel *chanPtr = (Channel *) chan; - FileInfo *infoPtr; - - if (chanPtr->typePtr != &fileChannelType) { - return; - } - - infoPtr = (FileInfo *) chanPtr->instanceData; - - infoPtr->nextPtr = tsdPtr->firstFilePtr; - tsdPtr->firstFilePtr = infoPtr; -} +static void +FileThreadActionProc(instanceData, action) + ClientData instanceData; + int action; +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + FileInfo *infoPtr = (FileInfo *) instanceData; + + if (action == TCL_CHANNEL_THREAD_INSERT) { + infoPtr->nextPtr = tsdPtr->firstFilePtr; + tsdPtr->firstFilePtr = infoPtr; + } else { + FileInfo **nextPtrPtr; + int removed = 0; + + for (nextPtrPtr = &(tsdPtr->firstFilePtr); (*nextPtrPtr) != NULL; + nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { + if ((*nextPtrPtr) == infoPtr) { + (*nextPtrPtr) = infoPtr->nextPtr; + removed = 1; + break; + } + } + + /* + * This could happen if the channel was created in one thread and then + * moved to another without updating the thread local data in each + * thread. + */ + + if (!removed) { + Tcl_Panic("file info ptr not on thread channel list"); + } + } +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: win/tclWinConsole.c ================================================================== --- win/tclWinConsole.c +++ win/tclWinConsole.c @@ -1,17 +1,17 @@ /* * tclWinConsole.c -- * - * This file implements the Windows-specific console functions, - * and the "console" channel driver. + * This file implements the Windows-specific console functions, and the + * "console" channel driver. * * Copyright (c) 1999 by Scriptics Corp. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinConsole.c,v 1.12 2004/09/10 01:52:17 davygrvy Exp $ + * RCS: @(#) $Id: tclWinConsole.c,v 1.12.2.2 2005/08/02 18:17:00 dgp Exp $ */ #include "tclWinInt.h" #include @@ -43,14 +43,15 @@ /* * Bit masks used in the sharedFlags field of the ConsoleInfo structure below. */ #define CONSOLE_EOF (1<<2) /* Console has reached EOF. */ -#define CONSOLE_BUFFERED (1<<3) /* data was read into a buffer by the reader - thread */ +#define CONSOLE_BUFFERED (1<<3) /* Data was read into a buffer by the reader + * thread. */ #define CONSOLE_BUFFER_SIZE (8*1024) + /* * This structure describes per-instance data for a console based channel. */ typedef struct ConsoleInfo { @@ -69,54 +70,52 @@ * This value is used by the reader/writer * threads. */ HANDLE writeThread; /* Handle to writer thread. */ HANDLE readThread; /* Handle to reader thread. */ HANDLE writable; /* Manual-reset event to signal when the - * writer thread has finished waiting for - * the current buffer to be written. */ + * writer thread has finished waiting for the + * current buffer to be written. */ HANDLE readable; /* Manual-reset event to signal when the * reader thread has finished waiting for * input. */ HANDLE startWriter; /* Auto-reset event used by the main thread to - * signal when the writer thread should attempt - * to write to the console. */ + * signal when the writer thread should + * attempt to write to the console. */ HANDLE stopWriter; /* Auto-reset event used by the main thread to * signal when the writer thread should exit. */ HANDLE startReader; /* Auto-reset event used by the main thread to - * signal when the reader thread should attempt - * to read from the console. */ + * signal when the reader thread should + * attempt to read from the console. */ HANDLE stopReader; /* Auto-reset event used by the main thread to * signal when the reader thread should exit. */ DWORD writeError; /* An error caused by the last background - * write. Set to 0 if no error has been - * detected. This word is shared with the + * write. Set to 0 if no error has been + * detected. This word is shared with the * writer thread so access must be * synchronized with the writable object. */ - char *writeBuf; /* Current background output buffer. - * Access is synchronized with the writable - * object. */ - int writeBufLen; /* Size of write buffer. Access is - * synchronized with the writable - * object. */ - int toWrite; /* Current amount to be written. Access is + char *writeBuf; /* Current background output buffer. Access is + * synchronized with the writable object. */ + int writeBufLen; /* Size of write buffer. Access is + * synchronized with the writable object. */ + int toWrite; /* Current amount to be written. Access is * synchronized with the writable object. */ int readFlags; /* Flags that are shared with the reader - * thread. Access is synchronized with the - * readable object. */ - int bytesRead; /* number of bytes in the buffer */ - int offset; /* number of bytes read out of the buffer */ + * thread. Access is synchronized with the + * readable object. */ + int bytesRead; /* number of bytes in the buffer */ + int offset; /* number of bytes read out of the buffer */ char buffer[CONSOLE_BUFFER_SIZE]; - /* Data consumed by reader thread. */ + /* Data consumed by reader thread. */ } ConsoleInfo; typedef struct ThreadSpecificData { /* - * The following pointer refers to the head of the list of consoles - * that are being watched for file events. + * The following pointer refers to the head of the list of consoles that + * are being watched for file events. */ ConsoleInfo *firstConsolePtr; } ThreadSpecificData; @@ -126,13 +125,13 @@ * The following structure is what is added to the Tcl event queue when * console events are generated. */ typedef struct ConsoleEvent { - Tcl_Event header; /* Information that is standard for - * all events. */ - ConsoleInfo *infoPtr; /* Pointer to console info structure. Note + Tcl_Event header; /* Information that is standard for all + * events. */ + ConsoleInfo *infoPtr; /* Pointer to console info structure. Note * that we still have to verify that the * console exists before dereferencing this * pointer. */ } ConsoleEvent; @@ -146,11 +145,11 @@ Tcl_Interp *interp); static int ConsoleEventProc(Tcl_Event *evPtr, int flags); static void ConsoleExitHandler(ClientData clientData); static int ConsoleGetHandleProc(ClientData instanceData, int direction, ClientData *handlePtr); -static ThreadSpecificData *ConsoleInit(void); +static void ConsoleInit(void); static int ConsoleInputProc(ClientData instanceData, char *buf, int toRead, int *errorCode); static int ConsoleOutputProc(ClientData instanceData, CONST char *buf, int toWrite, int *errorCode); static DWORD WINAPI ConsoleReaderThread(LPVOID arg); @@ -157,19 +156,21 @@ static void ConsoleSetupProc(ClientData clientData, int flags); static void ConsoleWatchProc(ClientData instanceData, int mask); static DWORD WINAPI ConsoleWriterThread(LPVOID arg); static void ProcExitHandler(ClientData clientData); static int WaitForRead(ConsoleInfo *infoPtr, int blocking); +static void ConsoleThreadActionProc(ClientData instanceData, + int action); /* * This structure describes the channel type structure for command console * based IO. */ static Tcl_ChannelType consoleChannelType = { "console", /* Type name. */ - TCL_CHANNEL_VERSION_2, /* v2 channel */ + TCL_CHANNEL_VERSION_4, /* v4 channel */ ConsoleCloseProc, /* Close proc. */ ConsoleInputProc, /* Input proc. */ ConsoleOutputProc, /* Output proc. */ NULL, /* Seek proc. */ NULL, /* Set option proc. */ @@ -178,10 +179,12 @@ ConsoleGetHandleProc, /* Get an OS handle from channel. */ NULL, /* close2proc. */ ConsoleBlockModeProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ + NULL, /* wide seek proc */ + ConsoleThreadActionProc, /* thread action proc */ }; /* *---------------------------------------------------------------------- * @@ -196,18 +199,18 @@ * Creates a new event source. * *---------------------------------------------------------------------- */ -static ThreadSpecificData * +static void ConsoleInit() { ThreadSpecificData *tsdPtr; /* - * Check the initialized flag first, then check again in the mutex. - * This is a speed enhancement. + * Check the initialized flag first, then check again in the mutex. This + * is a speed enhancement. */ if (!initialized) { Tcl_MutexLock(&consoleMutex); if (!initialized) { @@ -222,20 +225,19 @@ tsdPtr = TCL_TSD_INIT(&dataKey); tsdPtr->firstConsolePtr = NULL; Tcl_CreateEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL); Tcl_CreateThreadExitHandler(ConsoleExitHandler, NULL); } - return tsdPtr; } /* *---------------------------------------------------------------------- * * ConsoleExitHandler -- * - * This function is called to cleanup the console module before - * Tcl is unloaded. + * This function is called to cleanup the console module before Tcl is + * unloaded. * * Results: * None. * * Side effects: @@ -254,12 +256,12 @@ /* *---------------------------------------------------------------------- * * ProcExitHandler -- * - * This function is called to cleanup the process list before - * Tcl is unloaded. + * This function is called to cleanup the process list before Tcl is + * unloaded. * * Results: * None. * * Side effects: @@ -280,12 +282,12 @@ /* *---------------------------------------------------------------------- * * ConsoleSetupProc -- * - * This procedure is invoked before Tcl_DoOneEvent blocks waiting - * for an event. + * This procedure is invoked before Tcl_DoOneEvent blocks waiting for an + * event. * * Results: * None. * * Side effects: @@ -307,11 +309,11 @@ if (!(flags & TCL_FILE_EVENTS)) { return; } /* - * Look to see if any events are already pending. If they are, poll. + * Look to see if any events are already pending. If they are, poll. */ for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (infoPtr->watchMask & TCL_WRITABLE) { @@ -333,12 +335,12 @@ /* *---------------------------------------------------------------------- * * ConsoleCheckProc -- * - * This procedure is called by Tcl_DoOneEvent to check the console - * event source for events. + * This procedure is called by Tcl_DoOneEvent to check the console event + * source for events. * * Results: * None. * * Side effects: @@ -418,19 +420,20 @@ static int ConsoleBlockModeProc( ClientData instanceData, /* Instance data for channel. */ int mode) /* TCL_MODE_BLOCKING or - * TCL_MODE_NONBLOCKING. */ + * TCL_MODE_NONBLOCKING. */ { ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; /* - * Consoles on Windows can not be switched between blocking and nonblocking, - * hence we have to emulate the behavior. This is done in the input - * function by checking against a bit in the state. We set or unset the - * bit here to cause the input function to emulate the correct behavior. + * Consoles on Windows can not be switched between blocking and + * nonblocking, hence we have to emulate the behavior. This is done in the + * input function by checking against a bit in the state. We set or unset + * the bit here to cause the input function to emulate the correct + * behavior. */ if (mode == TCL_MODE_NONBLOCKING) { infoPtr->flags |= CONSOLE_ASYNC; } else { @@ -467,29 +470,27 @@ DWORD exitCode; errorCode = 0; /* - * Clean up the background thread if necessary. Note that this - * must be done before we can close the file, since the - * thread may be blocking trying to read from the console. + * Clean up the background thread if necessary. Note that this must be + * done before we can close the file, since the thread may be blocking + * trying to read from the console. */ if (consolePtr->readThread) { - /* - * The thread may already have closed on it's own. Check it's - * exit code. + * The thread may already have closed on it's own. Check it's exit + * code. */ GetExitCodeThread(consolePtr->readThread, &exitCode); if (exitCode == STILL_ACTIVE) { - /* - * Set the stop event so that if the reader thread is blocked - * in ConsoleReaderThread on WaitForMultipleEvents, it will exit + * Set the stop event so that if the reader thread is blocked in + * ConsoleReaderThread on WaitForMultipleEvents, it will exit * cleanly. */ SetEvent(consolePtr->stopReader); @@ -498,15 +499,14 @@ */ if (WaitForSingleObject(consolePtr->readThread, 20) == WAIT_TIMEOUT) { /* - * Forcibly terminate the background thread as a last - * resort. Note that we need to guard against - * terminating the thread while it is in the middle of - * Tcl_ThreadAlert because it won't be able to release - * the notifier lock. + * Forcibly terminate the background thread as a last resort. + * Note that we need to guard against terminating the thread + * while it is in the middle of Tcl_ThreadAlert because it + * won't be able to release the notifier lock. */ Tcl_MutexLock(&consoleMutex); /* BUG: this leaks memory. */ @@ -522,36 +522,37 @@ consolePtr->readThread = NULL; } consolePtr->validMask &= ~TCL_READABLE; /* - * Wait for the writer thread to finish the current buffer, then - * terminate the thread and close the handles. If the channel is - * nonblocking, there should be no pending write operations. + * Wait for the writer thread to finish the current buffer, then terminate + * the thread and close the handles. If the channel is nonblocking, there + * should be no pending write operations. */ if (consolePtr->writeThread) { if (consolePtr->toWrite) { /* - * We only need to wait if there is something to write. - * This may prevent infinite wait on exit. [python bug 216289] + * We only need to wait if there is something to write. This may + * prevent infinite wait on exit. [python bug 216289] */ + WaitForSingleObject(consolePtr->writable, INFINITE); } /* - * The thread may already have closed on it's own. Check it's - * exit code. + * The thread may already have closed on it's own. Check it's exit + * code. */ GetExitCodeThread(consolePtr->writeThread, &exitCode); if (exitCode == STILL_ACTIVE) { /* - * Set the stop event so that if the reader thread is blocked - * in ConsoleWriterThread on WaitForMultipleEvents, it will - * exit cleanly. + * Set the stop event so that if the reader thread is blocked in + * ConsoleWriterThread on WaitForMultipleEvents, it will exit + * cleanly. */ SetEvent(consolePtr->stopWriter); /* @@ -559,15 +560,14 @@ */ if (WaitForSingleObject(consolePtr->writeThread, 20) == WAIT_TIMEOUT) { /* - * Forcibly terminate the background thread as a last - * resort. Note that we need to guard against - * terminating the thread while it is in the middle of - * Tcl_ThreadAlert because it won't be able to release - * the notifier lock. + * Forcibly terminate the background thread as a last resort. + * Note that we need to guard against terminating the thread + * while it is in the middle of Tcl_ThreadAlert because it + * won't be able to release the notifier lock. */ Tcl_MutexLock(&consoleMutex); /* BUG: this leaks memory. */ @@ -584,13 +584,13 @@ } consolePtr->validMask &= ~TCL_WRITABLE; /* - * Don't close the Win32 handle if the handle is a standard channel - * during the thread exit process. Otherwise, one thread may kill - * the stdio of another. + * Don't close the Win32 handle if the handle is a standard channel during + * the thread exit process. Otherwise, one thread may kill the stdio of + * another. */ if (!TclInThreadExit() || ((GetStdHandle(STD_INPUT_HANDLE) != consolePtr->handle) && (GetStdHandle(STD_OUTPUT_HANDLE) != consolePtr->handle) @@ -627,12 +627,12 @@ /* *---------------------------------------------------------------------- * * ConsoleInputProc -- * - * Reads input from the IO channel into the buffer given. Returns - * count of how many bytes were actually read, and an error indication. + * Reads input from the IO channel into the buffer given. Returns count + * of how many bytes were actually read, and an error indication. * * Results: * A count of how many bytes were read is returned and an error * indication is returned in an output argument. * @@ -642,15 +642,15 @@ *---------------------------------------------------------------------- */ static int ConsoleInputProc( - ClientData instanceData, /* Console state. */ - char *buf, /* Where to store data read. */ - int bufSize, /* How much space is available - * in the buffer? */ - int *errorCode) /* Where to store error code. */ + ClientData instanceData, /* Console state. */ + char *buf, /* Where to store data read. */ + int bufSize, /* How much space is available in the + * buffer? */ + int *errorCode) /* Where to store error code. */ { ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; DWORD count, bytesRead = 0; int result; @@ -694,17 +694,17 @@ return bytesRead; } /* - * Attempt to read bufSize bytes. The read will return immediately - * if there is any data available. Otherwise it will block until - * at least one byte is available or an EOF occurs. + * Attempt to read bufSize bytes. The read will return immediately if + * there is any data available. Otherwise it will block until at least one + * byte is available or an EOF occurs. */ if (ReadConsole(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &count, - (LPOVERLAPPED) NULL) == TRUE) { + (LPOVERLAPPED) NULL) == TRUE) { buf[count] = '\0'; return count; } return -1; @@ -713,16 +713,16 @@ /* *---------------------------------------------------------------------- * * ConsoleOutputProc -- * - * Writes the given output on the IO channel. Returns count of how - * many characters were actually written, and an error indication. + * Writes the given output on the IO channel. Returns count of how many + * characters were actually written, and an error indication. * * Results: - * A count of how many characters were written is returned and an - * error indication is returned in an output argument. + * A count of how many characters were written is returned and an error + * indication is returned in an output argument. * * Side effects: * Writes output on the actual channel. * *---------------------------------------------------------------------- @@ -740,12 +740,12 @@ *errorCode = 0; timeout = (infoPtr->flags & CONSOLE_ASYNC) ? 0 : INFINITE; if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) { /* - * The writer thread is blocked waiting for a write to complete - * and the channel is in non-blocking mode. + * The writer thread is blocked waiting for a write to complete and + * the channel is in non-blocking mode. */ errno = EAGAIN; goto error; } @@ -782,12 +782,12 @@ ResetEvent(infoPtr->writable); SetEvent(infoPtr->startWriter); bytesWritten = toWrite; } else { /* - * In the blocking case, just try to write the buffer directly. - * This avoids an unnecessary copy. + * In the blocking case, just try to write the buffer directly. This + * avoids an unnecessary copy. */ if (WriteConsole(infoPtr->handle, buf, toWrite, &bytesWritten, NULL) == FALSE) { TclWinConvertError(GetLastError()); @@ -794,29 +794,29 @@ goto error; } } return bytesWritten; -error: + error: *errorCode = errno; return -1; } /* *---------------------------------------------------------------------- * * ConsoleEventProc -- * - * This function is invoked by Tcl_ServiceEvent when a file event - * reaches the front of the event queue. This procedure invokes - * Tcl_NotifyChannel on the console. + * This function is invoked by Tcl_ServiceEvent when a file event reaches + * the front of the event queue. This procedure invokes Tcl_NotifyChannel + * on the console. * * Results: - * Returns 1 if the event was handled, meaning it should be removed - * from the queue. Returns 0 if the event was not handled, meaning - * it should stay on the queue. The only time the event isn't - * handled is if the TCL_FILE_EVENTS flag bit isn't set. + * Returns 1 if the event was handled, meaning it should be removed from + * the queue. Returns 0 if the event was not handled, meaning it should + * stay on the queue. The only time the event isn't handled is if the + * TCL_FILE_EVENTS flag bit isn't set. * * Side effects: * Whatever the notifier callback does. * *---------------------------------------------------------------------- @@ -823,12 +823,12 @@ */ static int ConsoleEventProc( Tcl_Event *evPtr, /* Event to service. */ - int flags) /* Flags that indicate what events to - * handle, such as TCL_FILE_EVENTS. */ + int flags) /* Flags that indicate what events to handle, + * such as TCL_FILE_EVENTS. */ { ConsoleEvent *consoleEvPtr = (ConsoleEvent *)evPtr; ConsoleInfo *infoPtr; int mask; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -837,13 +837,13 @@ return 0; } /* * Search through the list of watched consoles for the one whose handle - * matches the event. We do this rather than simply dereferencing - * the handle in the event so that consoles can be deleted while the - * event is in the queue. + * matches the event. We do this rather than simply dereferencing the + * handle in the event so that consoles can be deleted while the event is + * in the queue. */ for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (consoleEvPtr->infoPtr == infoPtr) { @@ -859,13 +859,13 @@ if (!infoPtr) { return 1; } /* - * Check to see if the console is readable. Note - * that we can't tell if a console is writable, so we always report it - * as being writable unless we have detected EOF. + * Check to see if the console is readable. Note that we can't tell if a + * console is writable, so we always report it as being writable unless we + * have detected EOF. */ mask = 0; if (infoPtr->watchMask & TCL_WRITABLE) { if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) { @@ -894,12 +894,11 @@ /* *---------------------------------------------------------------------- * * ConsoleWatchProc -- * - * Called by the notifier to set up to watch for events on this - * channel. + * Called by the notifier to set up to watch for events on this channel. * * Results: * None. * * Side effects: @@ -908,24 +907,23 @@ *---------------------------------------------------------------------- */ static void ConsoleWatchProc( - ClientData instanceData, /* Console state. */ - int mask) /* What events to watch for, OR-ed - * combination of TCL_READABLE, - * TCL_WRITABLE and TCL_EXCEPTION. */ + ClientData instanceData, /* Console state. */ + int mask) /* What events to watch for, OR-ed combination + * of TCL_READABLE, TCL_WRITABLE and + * TCL_EXCEPTION. */ { ConsoleInfo **nextPtrPtr, *ptr; ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; int oldMask = infoPtr->watchMask; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* - * Since most of the work is handled by the background threads, - * we just need to update the watchMask and then force the notifier - * to poll once. + * Since most of the work is handled by the background threads, we just + * need to update the watchMask and then force the notifier to poll once. */ infoPtr->watchMask = mask & infoPtr->validMask; if (infoPtr->watchMask) { Tcl_Time blockTime = { 0, 0 }; @@ -932,23 +930,21 @@ if (!oldMask) { infoPtr->nextPtr = tsdPtr->firstConsolePtr; tsdPtr->firstConsolePtr = infoPtr; } Tcl_SetMaxBlockTime(&blockTime); - } else { - if (oldMask) { - /* - * Remove the console from the list of watched consoles. - */ - - for (nextPtrPtr = &(tsdPtr->firstConsolePtr), ptr = *nextPtrPtr; - ptr != NULL; - nextPtrPtr = &ptr->nextPtr, ptr = *nextPtrPtr) { - if (infoPtr == ptr) { - *nextPtrPtr = ptr->nextPtr; - break; - } + } else if (oldMask) { + /* + * Remove the console from the list of watched consoles. + */ + + for (nextPtrPtr = &(tsdPtr->firstConsolePtr), ptr = *nextPtrPtr; + ptr != NULL; + nextPtrPtr = &ptr->nextPtr, ptr = *nextPtrPtr) { + if (infoPtr == ptr) { + *nextPtrPtr = ptr->nextPtr; + break; } } } } @@ -955,16 +951,16 @@ /* *---------------------------------------------------------------------- * * ConsoleGetHandleProc -- * - * Called from Tcl_GetChannelHandle to retrieve OS handles from - * inside a command consoleline based channel. + * Called from Tcl_GetChannelHandle to retrieve OS handles from inside a + * command consoleline based channel. * * Results: - * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if - * there is no handle for the specified direction. + * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no + * handle for the specified direction. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -972,11 +968,11 @@ static int ConsoleGetHandleProc( ClientData instanceData, /* The console state. */ int direction, /* TCL_READABLE or TCL_WRITABLE */ - ClientData *handlePtr) /* Where to store the handle. */ + ClientData *handlePtr) /* Where to store the handle. */ { ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; *handlePtr = (ClientData) infoPtr->handle; return TCL_OK; @@ -985,31 +981,29 @@ /* *---------------------------------------------------------------------- * * WaitForRead -- * - * Wait until some data is available, the console is at - * EOF or the reader thread is blocked waiting for data (if the - * channel is in non-blocking mode). + * Wait until some data is available, the console is at EOF or the reader + * thread is blocked waiting for data (if the channel is in non-blocking + * mode). * * Results: - * Returns 1 if console is readable. Returns 0 if there is no data - * on the console, but there is buffered data. Returns -1 if an - * error occurred. If an error occurred, the threads may not - * be synchronized. + * Returns 1 if console is readable. Returns 0 if there is no data on the + * console, but there is buffered data. Returns -1 if an error occurred. + * If an error occurred, the threads may not be synchronized. * * Side effects: - * Updates the shared state flags. If no error occurred, - * the reader thread is blocked waiting for a signal from the - * main thread. + * Updates the shared state flags. If no error occurred, the reader + * thread is blocked waiting for a signal from the main thread. * *---------------------------------------------------------------------- */ static int WaitForRead( - ConsoleInfo *infoPtr, /* Console state. */ + ConsoleInfo *infoPtr, /* Console state. */ int blocking) /* Indicates whether call should be * blocking or not. */ { DWORD timeout, count; HANDLE *handle = infoPtr->handle; @@ -1024,17 +1018,18 @@ if (WaitForSingleObject(infoPtr->readable, timeout) == WAIT_TIMEOUT) { /* * The reader thread is blocked waiting for data and the channel * is in non-blocking mode. */ + errno = EAGAIN; return -1; } /* - * At this point, the two threads are synchronized, so it is safe - * to access shared state. + * At this point, the two threads are synchronized, so it is safe to + * access shared state. */ /* * If the console has hit EOF, it is always readable. */ @@ -1042,11 +1037,11 @@ if (infoPtr->readFlags & CONSOLE_EOF) { return 1; } if (PeekConsoleInput(handle, &input, 1, &count) == FALSE) { - /* + /* * Check to see if the peek failed because of EOF. */ TclWinConvertError(GetLastError()); @@ -1065,22 +1060,20 @@ return -1; } } /* - * If there is data in the buffer, the console must be - * readable (since it is a line-oriented device). + * If there is data in the buffer, the console must be readable (since + * it is a line-oriented device). */ if (infoPtr->readFlags & CONSOLE_BUFFERED) { return 1; } - /* - * There wasn't any data available, so reset the thread and - * try again. + * There wasn't any data available, so reset the thread and try again. */ ResetEvent(infoPtr->readable); SetEvent(infoPtr->startReader); } @@ -1089,20 +1082,20 @@ /* *---------------------------------------------------------------------- * * ConsoleReaderThread -- * - * This function runs in a separate thread and waits for input - * to become available on a console. + * This function runs in a separate thread and waits for input to become + * available on a console. * * Results: * None. * * Side effects: - * Signals the main thread when input become available. May - * cause the main thread to wake up by posting a message. May - * one line from the console for each wait operation. + * Signals the main thread when input become available. May cause the + * main thread to wake up by posting a message. May one line from the + * console for each wait operation. * *---------------------------------------------------------------------- */ static DWORD WINAPI @@ -1124,23 +1117,24 @@ waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE); if (waitResult != (WAIT_OBJECT_0 + 1)) { /* - * The start event was not signaled. It must be the stop event - * or an error, so exit this thread. + * The start event was not signaled. It must be the stop event or + * an error, so exit this thread. */ break; } count = 0; /* - * Look for data on the console, but first ignore any events - * that are not KEY_EVENTs + * Look for data on the console, but first ignore any events that are + * not KEY_EVENTs. */ + if (ReadConsoleA(handle, infoPtr->buffer, CONSOLE_BUFFER_SIZE, (LPDWORD) &infoPtr->bytesRead, NULL) != FALSE) { /* * Data was stored in the buffer. */ @@ -1154,24 +1148,30 @@ infoPtr->readFlags = CONSOLE_EOF; } } /* - * Signal the main thread by signalling the readable event and - * then waking up the notifier thread. + * Signal the main thread by signalling the readable event and then + * waking up the notifier thread. */ SetEvent(infoPtr->readable); /* - * Alert the foreground thread. Note that we need to treat this like - * a critical section so the foreground thread does not terminate - * this thread while we are holding a mutex in the notifier code. + * Alert the foreground thread. Note that we need to treat this like a + * critical section so the foreground thread does not terminate this + * thread while we are holding a mutex in the notifier code. */ Tcl_MutexLock(&consoleMutex); - Tcl_ThreadAlert(infoPtr->threadId); + if (infoPtr->threadId != NULL) { + /* + * TIP #218. When in flight ignore the event, no one will receive + * it anyway. + */ + Tcl_ThreadAlert(infoPtr->threadId); + } Tcl_MutexUnlock(&consoleMutex); } return 0; } @@ -1179,19 +1179,20 @@ /* *---------------------------------------------------------------------- * * ConsoleWriterThread -- * - * This function runs in a separate thread and writes data - * onto a console. + * This function runs in a separate thread and writes data onto a + * console. * * Results: * Always returns 0. * * Side effects: - * Signals the main thread when an output operation is completed. - * May cause the main thread to wake up by posting a message. + + * Signals the main thread when an output operation is completed. May + * cause the main thread to wake up by posting a message. * *---------------------------------------------------------------------- */ static DWORD WINAPI @@ -1215,12 +1216,12 @@ waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE); if (waitResult != (WAIT_OBJECT_0 + 1)) { /* - * The start event was not signaled. It must be the stop event - * or an error, so exit this thread. + * The start event was not signaled. It must be the stop event or + * an error, so exit this thread. */ break; } @@ -1240,24 +1241,30 @@ buf += count; } } /* - * Signal the main thread by signalling the writable event and - * then waking up the notifier thread. + * Signal the main thread by signalling the writable event and then + * waking up the notifier thread. */ SetEvent(infoPtr->writable); /* - * Alert the foreground thread. Note that we need to treat this like - * a critical section so the foreground thread does not terminate - * this thread while we are holding a mutex in the notifier code. + * Alert the foreground thread. Note that we need to treat this like a + * critical section so the foreground thread does not terminate this + * thread while we are holding a mutex in the notifier code. */ Tcl_MutexLock(&consoleMutex); - Tcl_ThreadAlert(infoPtr->threadId); + if (infoPtr->threadId != NULL) { + /* + * TIP #218. When in flight ignore the event, no one will receive + * it anyway. + */ + Tcl_ThreadAlert(infoPtr->threadId); + } Tcl_MutexUnlock(&consoleMutex); } return 0; } @@ -1268,12 +1275,12 @@ *---------------------------------------------------------------------- * * TclWinOpenConsoleChannel -- * * Constructs a Console channel for the specified standard OS handle. - * This is a helper function to break up the construction of - * channels into File, Console, or Serial. + * This is a helper function to break up the construction of channels + * into File, Console, or Serial. * * Results: * Returns the new channel, or NULL. * * Side effects: @@ -1288,14 +1295,13 @@ char *channelName; int permissions; { char encoding[4 + TCL_INTEGER_SPACE]; ConsoleInfo *infoPtr; - ThreadSpecificData *tsdPtr; DWORD id, modes; - tsdPtr = ConsoleInit(); + ConsoleInit(); /* * See if a channel with this handle already exists. */ @@ -1302,61 +1308,119 @@ infoPtr = (ConsoleInfo *) ckalloc((unsigned) sizeof(ConsoleInfo)); memset(infoPtr, 0, sizeof(ConsoleInfo)); infoPtr->validMask = permissions; infoPtr->handle = handle; + infoPtr->channel = (Tcl_Channel) NULL; wsprintfA(encoding, "cp%d", GetConsoleCP()); + infoPtr->threadId = Tcl_GetCurrentThread(); + /* - * Use the pointer for the name of the result channel. - * This keeps the channel names unique, since some may share - * handles (stdin/stdout/stderr for instance). + * Use the pointer for the name of the result channel. This keeps the + * channel names unique, since some may share handles (stdin/stdout/stderr + * for instance). */ wsprintfA(channelName, "file%lx", (int) infoPtr); infoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName, - (ClientData) infoPtr, permissions); - - infoPtr->threadId = Tcl_GetCurrentThread(); + (ClientData) infoPtr, permissions); if (permissions & TCL_READABLE) { /* * Make sure the console input buffer is ready for only character - * input notifications and the buffer is set for line buffering. - * IOW, we only want to catch when complete lines are ready for - * reading. + * input notifications and the buffer is set for line buffering. IOW, + * we only want to catch when complete lines are ready for reading. */ + GetConsoleMode(infoPtr->handle, &modes); modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT); modes |= ENABLE_LINE_INPUT; SetConsoleMode(infoPtr->handle, modes); infoPtr->readable = CreateEvent(NULL, TRUE, TRUE, NULL); infoPtr->startReader = CreateEvent(NULL, FALSE, FALSE, NULL); infoPtr->stopReader = CreateEvent(NULL, FALSE, FALSE, NULL); infoPtr->readThread = CreateThread(NULL, 256, ConsoleReaderThread, - infoPtr, 0, &id); + infoPtr, 0, &id); SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST); } if (permissions & TCL_WRITABLE) { infoPtr->writable = CreateEvent(NULL, TRUE, TRUE, NULL); infoPtr->startWriter = CreateEvent(NULL, FALSE, FALSE, NULL); infoPtr->stopWriter = CreateEvent(NULL, FALSE, FALSE, NULL); infoPtr->writeThread = CreateThread(NULL, 256, ConsoleWriterThread, - infoPtr, 0, &id); + infoPtr, 0, &id); SetThreadPriority(infoPtr->writeThread, THREAD_PRIORITY_HIGHEST); } /* - * Files have default translation of AUTO and ^Z eof char, which - * means that a ^Z will be accepted as EOF when reading. + * Files have default translation of AUTO and ^Z eof char, which means + * that a ^Z will be accepted as EOF when reading. */ Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto"); Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}"); Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", encoding); return infoPtr->channel; } + +/* + *---------------------------------------------------------------------- + * + * ConsoleThreadActionProc -- + * + * Insert or remove any thread local refs to this channel. + * + * Results: + * None. + * + * Side effects: + * Changes thread local list of valid channels. + * + *---------------------------------------------------------------------- + */ + +static void +ConsoleThreadActionProc (instanceData, action) + ClientData instanceData; + int action; +{ + ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; + + /* We do not access firstConsolePtr in the thread structures. This is not + * for all serials managed by the thread, but only those we are watching. + * Removal of the filevent handlers before transfer thus takes care of + * this structure. + */ + + Tcl_MutexLock(&consoleMutex); + if (action == TCL_CHANNEL_THREAD_INSERT) { + /* + * We can't copy the thread information from the channel when the + * channel is created. At this time the channel back pointer has not + * been set yet. However in that case the threadId has already been + * set by TclpCreateCommandChannel itself, so the structure is still + * good. + */ + + ConsoleInit(); + if (infoPtr->channel != NULL) { + infoPtr->threadId = Tcl_GetChannelThread(infoPtr->channel); + } + } else { + infoPtr->threadId = NULL; + } + Tcl_MutexUnlock(&consoleMutex); +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: win/tclWinDde.c ================================================================== --- win/tclWinDde.c +++ win/tclWinDde.c @@ -1,31 +1,29 @@ /* * tclWinDde.c -- * - * This file provides procedures that implement the "send" - * command, allowing commands to be passed from interpreter - * to interpreter. + * This file provides functions that implement the "send" command, + * allowing commands to be passed from interpreter to interpreter. * * Copyright (c) 1997 by Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinDde.c,v 1.26 2004/11/30 18:40:33 kennykb Exp $ + * RCS: @(#) $Id: tclWinDde.c,v 1.26.2.1 2005/08/02 18:17:01 dgp Exp $ */ #include "tclInt.h" #include #include #include /* - * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the - * Dde_Init declaration is in the source file itself, which is only - * accessed when we are building a library. DO NOT MOVE BEFORE ANY - * #include LINES. ONLY USE EXTERN TO INDICATE EXPORTED FUNCTIONS FROM - * NOW ON. + * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the Dde_Init + * declaration is in the source file itself, which is only accessed when we + * are building a library. DO NOT MOVE BEFORE ANY #include LINES. ONLY USE + * EXTERN TO INDICATE EXPORTED FUNCTIONS FROM NOW ON. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLEXPORT @@ -63,26 +61,26 @@ HWND hwnd; }; typedef struct ThreadSpecificData { Conversation *currentConversations; - /* A list of conversations currently - * being processed. */ + /* A list of conversations currently being + * processed. */ RegisteredInterp *interpListPtr; - /* List of all interpreters registered - * in the current process. */ + /* List of all interpreters registered in the + * current process. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* - * The following variables cannot be placed in thread-local storage. - * The Mutex ddeMutex guards access to the ddeInstance. + * The following variables cannot be placed in thread-local storage. The Mutex + * ddeMutex guards access to the ddeInstance. */ static HSZ ddeServiceGlobal = 0; -static DWORD ddeInstance; /* The application instance handle given - * to us by DdeInitialize. */ +static DWORD ddeInstance; /* The application instance handle given to us + * by DdeInitialize. */ static int ddeIsServer = 0; #define TCL_DDE_VERSION "1.3.1" #define TCL_DDE_PACKAGE_NAME "dde" #define TCL_DDE_SERVICE_NAME "TclEval" @@ -89,11 +87,11 @@ #define TCL_DDE_EXECUTE_RESULT "$TCLEVAL$EXECUTE$RESULT" TCL_DECLARE_MUTEX(ddeMutex) /* - * Forward declarations for procedures defined later in this file. + * Forward declarations for functions defined later in this file. */ static LRESULT CALLBACK DdeClientWindowProc _ANSI_ARGS_(( HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam)); @@ -100,11 +98,11 @@ static int DdeCreateClient _ANSI_ARGS_(( struct DdeEnumServices *es)); static BOOL CALLBACK DdeEnumWindowsCallback _ANSI_ARGS_(( HWND hwndTarget, LPARAM lParam)); static void DdeExitProc _ANSI_ARGS_((ClientData clientData)); -static int DdeGetServicesList _ANSI_ARGS_((Tcl_Interp *interp, +static int DdeGetServicesList _ANSI_ARGS_((Tcl_Interp *interp, char *serviceName, char *topicName)); static HDDEDATA CALLBACK DdeServerProc _ANSI_ARGS_((UINT uType, UINT uFmt, HCONV hConv, HSZ ddeTopic, HSZ ddeItem, HDDEDATA hData, DWORD dwData1, DWORD dwData2)); @@ -127,11 +125,11 @@ /* *---------------------------------------------------------------------- * * Dde_Init -- * - * This procedure initializes the dde command. + * This function initializes the dde command. * * Results: * A standard Tcl result. * * Side effects: @@ -159,11 +157,11 @@ /* *---------------------------------------------------------------------- * * Dde_SafeInit -- * - * This procedure initializes the dde command within a safe interp + * This function initializes the dde command within a safe interp * * Results: * A standard Tcl result. * * Side effects: @@ -204,22 +202,22 @@ { int nameFound = 0; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* - * See if the application is already registered; if so, remove its - * current name from the registry. The deletion of the command - * will take care of disposing of this entry. + * See if the application is already registered; if so, remove its current + * name from the registry. The deletion of the command will take care of + * disposing of this entry. */ if (tsdPtr->interpListPtr != NULL) { nameFound = 1; } /* - * Make sure that the DDE server is there. This is done only once, - * add an exit handler tear it down. + * Make sure that the DDE server is there. This is done only once, add an + * exit handler tear it down. */ if (ddeInstance == 0) { Tcl_MutexLock(&ddeMutex); if (ddeInstance == 0) { @@ -249,35 +247,35 @@ /* *---------------------------------------------------------------------- * * DdeSetServerName -- * - * This procedure is called to associate an ASCII name with a Dde - * server. If the interpreter has already been named, the - * name replaces the old one. + * This function is called to associate an ASCII name with a Dde server. + * If the interpreter has already been named, the name replaces the old + * one. * * Results: - * The return value is the name actually given to the interp. - * This will normally be the same as name, but if name was already - * in use for a Dde Server then a name of the form "name #2" will - * be chosen, with a high enough number to make the name unique. + * The return value is the name actually given to the interp. This will + * normally be the same as name, but if name was already in use for a Dde + * Server then a name of the form "name #2" will be chosen, with a high + * enough number to make the name unique. * * Side effects: - * Registration info is saved, thereby allowing the "send" command - * to be used later to invoke commands in the application. In - * addition, the "send" command is created in the application's - * interpreter. The registration will be removed automatically - * if the interpreter is deleted or the "send" command is removed. + * Registration info is saved, thereby allowing the "send" command to be + * used later to invoke commands in the application. In addition, the + * "send" command is created in the application's interpreter. The + * registration will be removed automatically if the interpreter is + * deleted or the "send" command is removed. * *---------------------------------------------------------------------- */ static char * DdeSetServerName(interp, name, exactName, handlerPtr) Tcl_Interp *interp; char *name; /* The name that will be used to refer to the - * interpreter in later "send" commands. Must + * interpreter in later "send" commands. Must * be globally unique. */ int exactName; /* Should we make a unique name? 0 = unique */ Tcl_Obj *handlerPtr; /* Name of the optional proc/command to handle * incoming Dde eval's */ { @@ -288,13 +286,13 @@ Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL; int n, srvCount = 0, lastSuffix, r = TCL_OK; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* - * See if the application is already registered; if so, remove its - * current name from the registry. The deletion of the command - * will take care of disposing of this entry. + * See if the application is already registered; if so, remove its current + * name from the registry. The deletion of the command will take care of + * disposing of this entry. */ for (riPtr = tsdPtr->interpListPtr, prevPtr = NULL; riPtr != NULL; prevPtr = riPtr, riPtr = riPtr->nextPtr) { if (riPtr->interp == interp) { @@ -305,33 +303,33 @@ prevPtr->nextPtr = riPtr->nextPtr; } break; } else { /* - * the name was NULL, so the caller is asking for - * the name of the current interp. + * The name was NULL, so the caller is asking for the name of + * the current interp. */ return riPtr->name; } } } if (name == NULL) { /* - * the name was NULL, so the caller is asking for - * the name of the current interp, but it doesn't - * have a name. + * The name was NULL, so the caller is asking for the name of the + * current interp, but it doesn't have a name. */ return ""; } /* - * Get the list of currently registered Tcl interpreters by calling - * the internal implementation of the 'dde services' command. + * Get the list of currently registered Tcl interpreters by calling the + * internal implementation of the 'dde services' command. */ + Tcl_DStringInit(&dString); actualName = name; if (!exactName) { r = DdeGetServicesList(interp, TCL_DDE_SERVICE_NAME, NULL); @@ -346,14 +344,13 @@ OutputDebugString(Tcl_GetStringResult(interp)); return NULL; } /* - * Pick a name to use for the application. Use "name" if it's not - * already in use. Otherwise add a suffix such as " #2", trying - * larger and larger numbers until we eventually find one that is - * unique. + * Pick a name to use for the application. Use "name" if it's not + * already in use. Otherwise add a suffix such as " #2", trying larger + * and larger numbers until we eventually find one that is unique. */ offset = lastSuffix = 0; suffix = 1; @@ -368,11 +365,14 @@ actualName = Tcl_DStringValue(&dString); } sprintf(Tcl_DStringValue(&dString) + offset, "%d", suffix); } - /* see if the name is already in use, if so increment suffix */ + /* + * See if the name is already in use, if so increment suffix. + */ + for (n = 0; n < srvCount; ++n) { Tcl_Obj* namePtr; Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr); if (strcmp(actualName, Tcl_GetString(namePtr)) == 0) { @@ -408,12 +408,13 @@ Tcl_HideCommand(interp, "dde", "dde"); } Tcl_DStringFree(&dString); /* - * re-initialize with the new name + * Re-initialize with the new name. */ + Initialize(); return riPtr->name; } @@ -452,11 +453,11 @@ /* *---------------------------------------------------------------------- * * DeleteProc * - * This procedure is called when the command "dde" is destroyed. + * This function is called when the command "dde" is destroyed. * * Results: * none * * Side effects: @@ -465,12 +466,12 @@ *---------------------------------------------------------------------- */ static void DeleteProc(clientData) - ClientData clientData; /* The interp we are deleting passed - * as ClientData. */ + ClientData clientData; /* The interp we are deleting passed as + * ClientData. */ { RegisteredInterp *riPtr = (RegisteredInterp *) clientData; RegisteredInterp *searchPtr, *prevPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -499,25 +500,24 @@ /* *---------------------------------------------------------------------- * * ExecuteRemoteObject -- * - * Takes the package delivered by DDE and executes it in the - * server's interpreter. + * Takes the package delivered by DDE and executes it in the server's + * interpreter. * * Results: - * A list Tcl_Obj * that describes what happened. The first - * element is the numerical return code (TCL_ERROR, etc.). The - * second element is the result of the script. If the return - * result was TCL_ERROR, then the third element will be the value - * of the global "errorCode", and the fourth will be the value of - * the global "errorInfo". The return result will have a - * refCount of 0. + * A list Tcl_Obj * that describes what happened. The first element is + * the numerical return code (TCL_ERROR, etc.). The second element is the + * result of the script. If the return result was TCL_ERROR, then the + * third element will be the value of the global "errorCode", and the + * fourth will be the value of the global "errorInfo". The return result + * will have a refCount of 0. * * Side effects: - * A Tcl script is run, which can cause all kinds of other things - * to happen. + * A Tcl script is run, which can cause all kinds of other things to + * happen. * *---------------------------------------------------------------------- */ static Tcl_Obj * @@ -534,11 +534,14 @@ "interp", -1)); result = TCL_ERROR; } if (riPtr->handlerPtr != NULL) { - /* add the dde request data to the handler proc list */ + /* + * Add the dde request data to the handler proc list. + */ + Tcl_Obj *cmdPtr = Tcl_DuplicateObj(riPtr->handlerPtr); result = Tcl_ListObjAppendElement(riPtr->interp, cmdPtr, ddeObjectPtr); if (result == TCL_OK) { ddeObjectPtr = cmdPtr; @@ -574,20 +577,20 @@ /* *---------------------------------------------------------------------- * * DdeServerProc -- * - * Handles all transactions for this server. Can handle execute, - * request, and connect protocols. Dde will call this routine - * when a client attempts to run a dde command using this server. + * Handles all transactions for this server. Can handle execute, request, + * and connect protocols. Dde will call this routine when a client + * attempts to run a dde command using this server. * * Results: * A DDE Handle with the result of the dde command. * * Side effects: - * Depending on which command is executed, arbitrary Tcl scripts - * can be run. + * Depending on which command is executed, arbitrary Tcl scripts can be + * run. * *---------------------------------------------------------------------- */ static HDDEDATA CALLBACK @@ -612,14 +615,13 @@ Conversation *convPtr, *prevConvPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); switch(uType) { case XTYP_CONNECT: - /* - * Dde is trying to initialize a conversation with us. Check - * and make sure we have a valid topic. + * Dde is trying to initialize a conversation with us. Check and make + * sure we have a valid topic. */ len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0); Tcl_DStringInit(&dString); Tcl_DStringSetLength(&dString, len); @@ -637,16 +639,14 @@ Tcl_DStringFree(&dString); return (HDDEDATA) FALSE; case XTYP_CONNECT_CONFIRM: - /* - * Dde has decided that we can connect, so it gives us a - * conversation handle. We need to keep track of it - * so we know which execution result to return in an - * XTYP_REQUEST. + * Dde has decided that we can connect, so it gives us a conversation + * handle. We need to keep track of it so we know which execution + * result to return in an XTYP_REQUEST. */ len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0); Tcl_DStringInit(&dString); Tcl_DStringSetLength(&dString, len); @@ -667,11 +667,10 @@ } Tcl_DStringFree(&dString); return (HDDEDATA) TRUE; case XTYP_DISCONNECT: - /* * The client has disconnected from our server. Forget this * conversation. */ @@ -692,15 +691,14 @@ } } return (HDDEDATA) TRUE; case XTYP_REQUEST: - /* - * This could be either a request for a value of a Tcl variable, - * or it could be the send command requesting the results of the - * last execute. + * This could be either a request for a value of a Tcl variable, or it + * could be the send command requesting the results of the last + * execute. */ if (uFmt != CF_TEXT) { return (HDDEDATA) FALSE; } @@ -748,15 +746,13 @@ Tcl_DStringFree(&dString); } return ddeReturn; case XTYP_EXECUTE: { - /* - * Execute this script. The results will be saved into - * a list object which will be retreived later. See - * ExecuteRemoteObject. + * Execute this script. The results will be saved into a list object + * which will be retreived later. See ExecuteRemoteObject. */ Tcl_Obj *returnPackagePtr; for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) @@ -799,11 +795,10 @@ return (HDDEDATA) DDE_FACK; } } case XTYP_WILDCONNECT: { - /* * Dde wants a list of services and topics that we support. */ HSZPAIR *returnPtr; @@ -868,12 +863,12 @@ /* *---------------------------------------------------------------------- * * MakeDdeConnection -- * - * This procedure is a utility used to connect to a DDE server - * when given a server name and a topic name. + * This function is a utility used to connect to a DDE server when given + * a server name and a topic name. * * Results: * A standard Tcl result. * * Side effects: @@ -913,16 +908,15 @@ /* *---------------------------------------------------------------------- * * DdeGetServicesList -- * - * This procedure obtains the list of DDE services. + * This function obtains the list of DDE services. * - * The functions between here and this procedure are all involved - * with handling the DDE callbacks for this. They are: - * DdeCreateClient, DdeClientWindowProc, DdeServicesOnAck, and - * DdeEnumWindowsCallback + * The functions between here and this function are all involved with + * handling the DDE callbacks for this. They are: DdeCreateClient, + * DdeClientWindowProc, DdeServicesOnAck, and DdeEnumWindowsCallback * * Results: * A standard Tcl result. * * Side effects: @@ -943,11 +937,14 @@ wc.cbSize = sizeof(wc); wc.lpfnWndProc = DdeClientWindowProc; wc.lpszClassName = szDdeClientClassName; wc.cbWndExtra = sizeof(struct DdeEnumServices *); - /* register and create the callback window */ + /* + * Register and create the callback window. + */ + RegisterClassEx(&wc); es->hwnd = CreateWindowEx(0, szDdeClientClassName, szDdeClientWindowName, WS_POPUP, 0, 0, 0, 0, NULL, NULL, NULL, (LPVOID)es); return TCL_OK; } @@ -1028,15 +1025,18 @@ matchPtr) == TCL_OK) { Tcl_SetObjResult(es->interp, resultPtr); } } - /* tell the server we are no longer interested */ + /* + * Tell the server we are no longer interested. + */ + PostMessage(hwndRemote, WM_DDE_TERMINATE, (WPARAM)hwnd, 0L); return 0L; } - + static BOOL CALLBACK DdeEnumWindowsCallback(hwndTarget, lParam) HWND hwndTarget; LPARAM lParam; { @@ -1046,11 +1046,11 @@ SendMessageTimeout(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd, MAKELONG(es->service, es->topic), SMTO_ABORTIFHUNG, 1000, &dwResult); return TRUE; } - + static int DdeGetServicesList(interp, serviceName, topicName) Tcl_Interp *interp; char *serviceName, *topicName; { @@ -1081,12 +1081,12 @@ /* *---------------------------------------------------------------------- * * SetDdeError -- * - * Sets the interp result to a cogent error message describing - * the last DDE error. + * Sets the interp result to a cogent error message describing the last + * DDE error. * * Results: * None. * * Side effects: @@ -1123,12 +1123,12 @@ /* *---------------------------------------------------------------------- * * Tcl_DdeObjCmd -- * - * This procedure is invoked to process the "dde" Tcl command. - * See the user documentation for details on what it does. + * This function is invoked to process the "dde" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -1194,24 +1194,26 @@ for (i = 2; i < objc; i++) { enum DdeSrvOptions argIndex; if (Tcl_GetIndexFromObj(interp, objv[i], ddeSrvOptions, "option", 0, (int *) &argIndex) != TCL_OK) { /* - * If it is the last argument, it might be a server - * name instead of a bad argument. + * If it is the last argument, it might be a server name + * instead of a bad argument. */ + if (i != objc-1) { return TCL_ERROR; } Tcl_ResetResult(interp); break; } if (argIndex == DDE_SERVERNAME_EXACT) { exact = 1; } else if (argIndex == DDE_SERVERNAME_HANDLER) { - if ((objc - i) == 1) { /* return current handler */ + if ((objc - i) == 1) { /* return current handler */ RegisteredInterp *riPtr = DdeGetRegistrationPtr(interp); + if (riPtr && riPtr->handlerPtr) { Tcl_SetObjResult(interp, riPtr->handlerPtr); } else { Tcl_ResetResult(interp); } @@ -1269,11 +1271,15 @@ binary = 1; firstArg = 3; break; } } - /* otherwise ... */ + + /* + * Otherwise ... + */ + Tcl_WrongNumArgs(interp, 2, objv, "?-binary? serviceName topicName value"); return TCL_ERROR; case DDE_SERVICES: if (objc != 4) { @@ -1282,15 +1288,16 @@ } firstArg = 2; break; case DDE_EVAL: if (objc < 4) { - wrongDdeEvalArgs: + wrongDdeEvalArgs: Tcl_WrongNumArgs(interp, 2, objv, "?-async? serviceName args"); return TCL_ERROR; } else { int dummy; + firstArg = 2; if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option", 0, &dummy) == TCL_OK) { if (objc < 5) { goto wrongDdeEvalArgs; @@ -1380,10 +1387,11 @@ } break; } case DDE_REQUEST: { char *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length); + if (length == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot request value of null data", -1)); result = TCL_ERROR; goto cleanup; @@ -1481,17 +1489,16 @@ objc -= (async + 3); ((Tcl_Obj **) objv) += (async + 3); /* - * See if the target interpreter is local. If so, execute - * the command directly without going through the DDE server. - * Don't exchange objects between interps. The target interp could - * compile an object, producing a bytecode structure that refers to - * other objects owned by the target interp. If the target interp - * is then deleted, the bytecode structure would be referring to - * deallocated objects. + * See if the target interpreter is local. If so, execute the command + * directly without going through the DDE server. Don't exchange + * objects between interps. The target interp could compile an object, + * producing a bytecode structure that refers to other objects owned + * by the target interp. If the target interp is then deleted, the + * bytecode structure would be referring to deallocated objects. */ for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { if (stricmp(serviceName, riPtr->name) == 0) { @@ -1501,24 +1508,24 @@ if (riPtr != NULL) { Tcl_Interp *sendInterp; /* - * This command is to a local interp. No need to go through - * the server. + * This command is to a local interp. No need to go through the + * server. */ Tcl_Preserve((ClientData) riPtr); sendInterp = riPtr->interp; Tcl_Preserve((ClientData) sendInterp); /* - * Don't exchange objects between interps. The target interp - * would compile an object, producing a bytecode structure that - * refers to other objects owned by the target interp. If the - * target interp is then deleted, the bytecode structure would - * be referring to deallocated objects. + * Don't exchange objects between interps. The target interp would + * compile an object, producing a bytecode structure that refers + * to other objects owned by the target interp. If the target + * interp is then deleted, the bytecode structure would be + * referring to deallocated objects. */ if (Tcl_IsSafe(riPtr->interp) && riPtr->handlerPtr == NULL) { Tcl_SetResult(riPtr->interp, "permission denied: " "a handler procedure must be defined for use in " @@ -1552,13 +1559,12 @@ Tcl_DecrRefCount(objPtr); } if (interp != sendInterp) { if (result == TCL_ERROR) { /* - * An error occurred, so transfer error information - * from the destination interpreter back to our - * interpreter. + * An error occurred, so transfer error information from + * the destination interpreter back to our interpreter. */ Tcl_ResetResult(interp); objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL, TCL_GLOBAL_ONLY); @@ -1577,16 +1583,16 @@ } Tcl_Release((ClientData) riPtr); Tcl_Release((ClientData) sendInterp); } else { /* - * This is a non-local request. Send the script to the server - * and poll it for a result. + * This is a non-local request. Send the script to the server and + * poll it for a result. */ if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) { - invalidServerResponse: + invalidServerResponse: Tcl_SetObjResult(interp, Tcl_NewStringObj("invalid data returned from server", -1)); result = TCL_ERROR; goto cleanup; @@ -1623,16 +1629,16 @@ if (async == 0) { Tcl_Obj *resultPtr; /* - * The return handle has a two or four element list in - * it. The first element is the return code (TCL_OK, - * TCL_ERROR, etc.). The second is the result of the - * script. If the return code is TCL_ERROR, then the third - * element is the value of the variable "errorCode", and - * the fourth is the value of the variable "errorInfo". + * The return handle has a two or four element list in it. The + * first element is the return code (TCL_OK, TCL_ERROR, etc.). + * The second is the result of the script. If the return code + * is TCL_ERROR, then the third element is the value of the + * variable "errorCode", and the fourth is the value of the + * variable "errorInfo". */ resultPtr = Tcl_NewObj(); length = DdeGetData(ddeData, NULL, 0, 0); Tcl_SetObjLength(resultPtr, length); @@ -1690,13 +1696,15 @@ if (hConv != NULL) { DdeDisconnect(hConv); } return result; } - + /* * Local variables: * mode: c * indent-tabs-mode: t * tab-width: 8 + * c-basic-offset: 4 + * fill-column: 78 * End: */ Index: win/tclWinFCmd.c ================================================================== --- win/tclWinFCmd.c +++ win/tclWinFCmd.c @@ -1,50 +1,45 @@ /* * tclWinFCmd.c * - * This file implements the Windows specific portion of file manipulation - * subcommands of the "file" command. + * This file implements the Windows specific portion of file manipulation + * subcommands of the "file" command. * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinFCmd.c,v 1.43 2004/10/06 16:37:18 dgp Exp $ + * RCS: @(#) $Id: tclWinFCmd.c,v 1.43.2.4 2005/08/15 18:14:15 dgp Exp $ */ #include "tclWinInt.h" /* * The following constants specify the type of callback when * TraverseWinTree() calls the traverseProc() */ -#define DOTREE_PRED 1 /* pre-order directory */ -#define DOTREE_POSTD 2 /* post-order directory */ -#define DOTREE_F 3 /* regular file */ -#define DOTREE_LINK 4 /* symbolic link */ +#define DOTREE_PRED 1 /* pre-order directory */ +#define DOTREE_POSTD 2 /* post-order directory */ +#define DOTREE_F 3 /* regular file */ +#define DOTREE_LINK 4 /* symbolic link */ /* * Callbacks for file attributes code. */ -static int GetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj **attributePtrPtr)); -static int GetWinFileLongName _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj **attributePtrPtr)); -static int GetWinFileShortName _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj **attributePtrPtr)); -static int SetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj *attributePtr)); -static int CannotSetAttribute _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj *attributePtr)); +static int GetWinFileAttributes(Tcl_Interp *interp, int objIndex, + Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); +static int GetWinFileLongName(Tcl_Interp *interp, int objIndex, + Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); +static int GetWinFileShortName(Tcl_Interp *interp, int objIndex, + Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); +static int SetWinFileAttributes(Tcl_Interp *interp, int objIndex, + Tcl_Obj *fileName, Tcl_Obj *attributePtr); +static int CannotSetAttribute(Tcl_Interp *interp, int objIndex, + Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* * Constants and variables necessary for file attributes subcommand. */ @@ -72,231 +67,253 @@ {GetWinFileLongName, CannotSetAttribute}, {GetWinFileAttributes, SetWinFileAttributes}, {GetWinFileShortName, CannotSetAttribute}, {GetWinFileAttributes, SetWinFileAttributes}}; -#if defined(HAVE_NO_SEH) && defined(TCL_MEM_DEBUG) -static void *INITIAL_ESP, - *INITIAL_EBP, - *INITIAL_HANDLER, - *RESTORED_ESP, - *RESTORED_EBP, - *RESTORED_HANDLER; -#endif /* HAVE_NO_SEH && TCL_MEM_DEBUG */ - #ifdef HAVE_NO_SEH -static -__attribute__ ((cdecl)) -EXCEPTION_DISPOSITION -_except_dorenamefile_handler( - struct _EXCEPTION_RECORD *ExceptionRecord, - void *EstablisherFrame, - struct _CONTEXT *ContextRecord, - void *DispatcherContext); - -static -__attribute__ ((cdecl)) -EXCEPTION_DISPOSITION -_except_docopyfile_handler( - struct _EXCEPTION_RECORD *ExceptionRecord, - void *EstablisherFrame, - struct _CONTEXT *ContextRecord, - void *DispatcherContext); - -#endif /* HAVE_NO_SEH */ + +/* + * Unlike Borland and Microsoft, we don't register exception handlers by + * pushing registration records onto the runtime stack. Instead, we register + * them by creating an EXCEPTION_REGISTRATION within the activation record. + */ + +typedef struct EXCEPTION_REGISTRATION { + struct EXCEPTION_REGISTRATION *link; + EXCEPTION_DISPOSITION (*handler)( + struct _EXCEPTION_RECORD *, void *, struct _CONTEXT *, void *); + void *ebp; + void *esp; + int status; +} EXCEPTION_REGISTRATION; + +#endif /* * Prototype for the TraverseWinTree callback function. */ -typedef int (TraversalProc)(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, +typedef int (TraversalProc)(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, int type, Tcl_DString *errorPtr); /* - * Declarations for local procedures defined in this file: + * Declarations for local functions defined in this file: */ static void StatError(Tcl_Interp *interp, Tcl_Obj *fileName); -static int ConvertFileNameFormat(Tcl_Interp *interp, +static int ConvertFileNameFormat(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, int longShort, Tcl_Obj **attributePtrPtr); static int DoCopyFile(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr); static int DoCreateDirectory(CONST TCHAR *pathPtr); -static int DoRemoveJustDirectory(CONST TCHAR *nativeSrc, - int ignoreError, Tcl_DString *errorPtr); -static int DoRemoveDirectory(Tcl_DString *pathPtr, int recursive, - Tcl_DString *errorPtr); -static int DoRenameFile(CONST TCHAR *nativeSrc, CONST TCHAR *dstPtr); -static int TraversalCopy(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, - int type, Tcl_DString *errorPtr); -static int TraversalDelete(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, - int type, Tcl_DString *errorPtr); -static int TraverseWinTree(TraversalProc *traverseProc, - Tcl_DString *sourcePtr, Tcl_DString *dstPtr, - Tcl_DString *errorPtr); - +static int DoRemoveJustDirectory(CONST TCHAR *nativeSrc, + int ignoreError, Tcl_DString *errorPtr); +static int DoRemoveDirectory(Tcl_DString *pathPtr, int recursive, + Tcl_DString *errorPtr); +static int DoRenameFile(CONST TCHAR *nativeSrc, + CONST TCHAR *dstPtr); +static int TraversalCopy(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, + int type, Tcl_DString *errorPtr); +static int TraversalDelete(CONST TCHAR *srcPtr, + CONST TCHAR *dstPtr, int type, + Tcl_DString *errorPtr); +static int TraverseWinTree(TraversalProc *traverseProc, + Tcl_DString *sourcePtr, Tcl_DString *dstPtr, + Tcl_DString *errorPtr); /* *--------------------------------------------------------------------------- * * TclpObjRenameFile, DoRenameFile -- * - * Changes the name of an existing file or directory, from src to dst. - * If src and dst refer to the same file or directory, does nothing - * and returns success. Otherwise if dst already exists, it will be - * deleted and replaced by src subject to the following conditions: + * Changes the name of an existing file or directory, from src to dst. + * If src and dst refer to the same file or directory, does nothing and + * returns success. Otherwise if dst already exists, it will be deleted + * and replaced by src subject to the following conditions: * If src is a directory, dst may be an empty directory. * If src is a file, dst may be a file. - * In any other situation where dst already exists, the rename will - * fail. + * In any other situation where dst already exists, the rename will fail. * * Results: * If the file or directory was successfully renamed, returns TCL_OK. - * Otherwise the return value is TCL_ERROR and errno is set to - * indicate the error. Some possible values for errno are: + * Otherwise the return value is TCL_ERROR and errno is set to indicate + * the error. Some possible values for errno are: * * ENAMETOOLONG: src or dst names are too long. - * EACCES: src or dst parent directory can't be read and/or written. + * EACCES: src or dst parent directory can't be read and/or written. * EEXIST: dst is a non-empty directory. * EINVAL: src is a root directory or dst is a subdirectory of src. * EISDIR: dst is a directory, but src is not. - * ENOENT: src doesn't exist. src or dst is "". - * ENOTDIR: src is a directory, but dst is not. + * ENOENT: src doesn't exist. src or dst is "". + * ENOTDIR: src is a directory, but dst is not. * EXDEV: src and dst are on different filesystems. * - * EACCES: exists an open file already referring to src or dst. - * EACCES: src or dst specify the current working directory (NT). - * EACCES: src specifies a char device (nul:, com1:, etc.) + * EACCES: exists an open file already referring to src or dst. + * EACCES: src or dst specify the current working directory (NT). + * EACCES: src specifies a char device (nul:, com1:, etc.) * EEXIST: dst specifies a char device (nul:, com1:, etc.) (NT) * EACCES: dst specifies a char device (nul:, com1:, etc.) (95) - * + * * Side effects: - * The implementation supports cross-filesystem renames of files, - * but the caller should be prepared to emulate cross-filesystem - * renames of directories if errno is EXDEV. + * The implementation supports cross-filesystem renames of files, but the + * caller should be prepared to emulate cross-filesystem renames of + * directories if errno is EXDEV. * *--------------------------------------------------------------------------- */ -int +int TclpObjRenameFile(srcPathPtr, destPathPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; { - return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr), - Tcl_FSGetNativePath(destPathPtr)); + return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr), + Tcl_FSGetNativePath(destPathPtr)); } static int DoRenameFile( CONST TCHAR *nativeSrc, /* Pathname of file or dir to be renamed - * (native). */ + * (native). */ CONST TCHAR *nativeDst) /* New pathname for file or directory * (native). */ -{ +{ +#ifdef HAVE_NO_SEH + EXCEPTION_REGISTRATION registration; +#endif DWORD srcAttr, dstAttr; int retval = -1; /* - * The MoveFile API acts differently under Win95/98 and NT - * WRT NULL and "". Avoid passing these values. + * The MoveFile API acts differently under Win95/98 and NT WRT NULL and + * "". Avoid passing these values. */ if (nativeSrc == NULL || nativeSrc[0] == '\0' || nativeDst == NULL || nativeDst[0] == '\0') { Tcl_SetErrno(ENOENT); return TCL_ERROR; } /* - * The MoveFile API would throw an exception under NT - * if one of the arguments is a char block device. + * The MoveFile API would throw an exception under NT if one of the + * arguments is a char block device. */ -#ifdef HAVE_NO_SEH -# ifdef TCL_MEM_DEBUG - __asm__ __volatile__ ( - "movl %%esp, %0" "\n\t" - "movl %%ebp, %1" "\n\t" - "movl %%fs:0, %2" "\n\t" - : "=m"(INITIAL_ESP), - "=m"(INITIAL_EBP), - "=r"(INITIAL_HANDLER) ); -# endif /* TCL_MEM_DEBUG */ - - __asm__ __volatile__ ( - "pushl %%ebp" "\n\t" - "pushl %0" "\n\t" - "pushl %%fs:0" "\n\t" - "movl %%esp, %%fs:0" - : - : "r" (_except_dorenamefile_handler) - ); -#else +#ifndef HAVE_NO_SEH __try { -#endif /* HAVE_NO_SEH */ if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) { retval = TCL_OK; } -#ifdef HAVE_NO_SEH - __asm__ __volatile__ ( - "jmp dorenamefile_pop" "\n" - "dorenamefile_reentry:" "\n\t" - "movl %%fs:0, %%eax" "\n\t" - "movl 0x8(%%eax), %%esp" "\n\t" - "movl 0x8(%%esp), %%ebp" "\n" - "dorenamefile_pop:" "\n\t" - "movl (%%esp), %%eax" "\n\t" - "movl %%eax, %%fs:0" "\n\t" - "add $12, %%esp" "\n\t" - : - : - : "%eax"); - -# ifdef TCL_MEM_DEBUG - __asm__ __volatile__ ( - "movl %%esp, %0" "\n\t" - "movl %%ebp, %1" "\n\t" - "movl %%fs:0, %2" "\n\t" - : "=m"(RESTORED_ESP), - "=m"(RESTORED_EBP), - "=r"(RESTORED_HANDLER) ); - - if (INITIAL_ESP != RESTORED_ESP) { - Tcl_Panic("ESP restored incorrectly"); - } - if (INITIAL_EBP != RESTORED_EBP) { - Tcl_Panic("EBP restored incorrectly"); - } - if (INITIAL_HANDLER != RESTORED_HANDLER) { - Tcl_Panic("HANDLER restored incorrectly"); - } -# endif /* TCL_MEM_DEBUG */ -#else - } __except (EXCEPTION_EXECUTE_HANDLER) {} -#endif /* HAVE_NO_SEH */ - - /* - * Avoid using control flow statements in the SEH guarded block! - */ - if (retval != -1) { - return retval; + } __except (EXCEPTION_EXECUTE_HANDLER) {} +#else + + /* + * Don't have SEH available, do things the hard way. Note that this needs + * to be one block of asm, to avoid stack imbalance; also, it is illegal + * for one asm block to contain a jump to another. + */ + + __asm__ __volatile__ ( + /* + * Pick up params before messing with the stack. + */ + + "movl %[nativeDst], %%ebx" "\n\t" + "movl %[nativeSrc], %%ecx" "\n\t" + + /* + * Construct an EXCEPTION_REGISTRATION to protect the call to + * MoveFile. + */ + + "leal %[registration], %%edx" "\n\t" + "movl %%fs:0, %%eax" "\n\t" + "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ + "leal 1f, %%eax" "\n\t" + "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ + "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ + "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */ + "movl $0, 0x10(%%edx)" "\n\t" /* status */ + + /* + * Link the EXCEPTION_REGISTRATION on the chain. + */ + + "movl %%edx, %%fs:0" "\n\t" + + /* + * Call MoveFile(nativeSrc, nativeDst) + */ + + "pushl %%ebx" "\n\t" + "pushl %%ecx" "\n\t" + "movl %[moveFile], %%eax" "\n\t" + "call *%%eax" "\n\t" + + /* + * Come here on normal exit. Recover the EXCEPTION_REGISTRATION and + * put the status return from MoveFile into it. + */ + + "movl %%fs:0, %%edx" "\n\t" + "movl %%eax, 0x10(%%edx)" "\n\t" + "jmp 2f" "\n" + + /* + * Come here on an exception. Recover the EXCEPTION_REGISTRATION + */ + + "1:" "\t" + "movl %%fs:0, %%edx" "\n\t" + "movl 0x8(%%edx), %%edx" "\n\t" + + /* + * Come here however we exited. Restore context from the + * EXCEPTION_REGISTRATION in case the stack is unbalanced. + */ + + "2:" "\t" + "movl 0xc(%%edx), %%esp" "\n\t" + "movl 0x8(%%edx), %%ebp" "\n\t" + "movl 0x0(%%edx), %%eax" "\n\t" + "movl %%eax, %%fs:0" "\n\t" + + : + /* No outputs */ + : + [registration] "m" (registration), + [nativeDst] "m" (nativeDst), + [nativeSrc] "m" (nativeSrc), + [moveFile] "r" (tclWinProcs->moveFileProc) + : + "%eax", "%ebx", "%ecx", "%edx", "memory" + ); + if (registration.status != FALSE) { + retval = TCL_OK; + } +#endif + + if (retval != -1) { + return retval; } TclWinConvertError(GetLastError()); srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc); dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst); if (srcAttr == 0xffffffff) { - if ((*tclWinProcs->getFullPathNameProc)(nativeSrc, 0, NULL, NULL) >= MAX_PATH) { + if ((*tclWinProcs->getFullPathNameProc)(nativeSrc, 0, NULL, + NULL) >= MAX_PATH) { errno = ENAMETOOLONG; return TCL_ERROR; } srcAttr = 0; } if (dstAttr == 0xffffffff) { - if ((*tclWinProcs->getFullPathNameProc)(nativeDst, 0, NULL, NULL) >= MAX_PATH) { + if ((*tclWinProcs->getFullPathNameProc)(nativeDst, 0, NULL, + NULL) >= MAX_PATH) { errno = ENAMETOOLONG; return TCL_ERROR; } dstAttr = 0; } @@ -304,41 +321,43 @@ if (errno == EBADF) { errno = EACCES; return TCL_ERROR; } if (errno == EACCES) { - decode: + decode: if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) { TCHAR *nativeSrcRest, *nativeDstRest; CONST char **srcArgv, **dstArgv; int size, srcArgc, dstArgc; WCHAR nativeSrcPath[MAX_PATH]; WCHAR nativeDstPath[MAX_PATH]; Tcl_DString srcString, dstString; CONST char *src, *dst; - size = (*tclWinProcs->getFullPathNameProc)(nativeSrc, MAX_PATH, + size = (*tclWinProcs->getFullPathNameProc)(nativeSrc, MAX_PATH, nativeSrcPath, &nativeSrcRest); if ((size == 0) || (size > MAX_PATH)) { return TCL_ERROR; } - size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH, + size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH, nativeDstPath, &nativeDstRest); if ((size == 0) || (size > MAX_PATH)) { return TCL_ERROR; } (*tclWinProcs->charLowerProc)((TCHAR *) nativeSrcPath); (*tclWinProcs->charLowerProc)((TCHAR *) nativeDstPath); src = Tcl_WinTCharToUtf((TCHAR *) nativeSrcPath, -1, &srcString); dst = Tcl_WinTCharToUtf((TCHAR *) nativeDstPath, -1, &dstString); + /* * Check whether the destination path is actually inside the - * source path. This is true if the prefix matches, and the next + * source path. This is true if the prefix matches, and the next * character is either end-of-string or a directory separator */ - if ((strncmp(src, dst, (size_t) Tcl_DStringLength(&srcString))==0) + + if ((strncmp(src, dst, (size_t) Tcl_DStringLength(&srcString))==0) && (dst[Tcl_DStringLength(&srcString)] == '\\' || dst[Tcl_DStringLength(&srcString)] == '/' || dst[Tcl_DStringLength(&srcString)] == '\0')) { /* * Trying to move a directory into itself. @@ -354,26 +373,24 @@ Tcl_DStringFree(&srcString); Tcl_DStringFree(&dstString); if (srcArgc == 1) { /* - * They are trying to move a root directory. Whether - * or not it is across filesystems, this cannot be - * done. + * They are trying to move a root directory. Whether or not it + * is across filesystems, this cannot be done. */ Tcl_SetErrno(EINVAL); } else if ((srcArgc > 0) && (dstArgc > 0) && (strcmp(srcArgv[0], dstArgv[0]) != 0)) { /* - * If src is a directory and dst filesystem != src - * filesystem, errno should be EXDEV. It is very - * important to get this behavior, so that the caller - * can respond to a cross filesystem rename by - * simulating it with copy and delete. The MoveFile - * system call already handles the case of moving a - * file between filesystems. + * If src is a directory and dst filesystem != src filesystem, + * errno should be EXDEV. It is very important to get this + * behavior, so that the caller can respond to a cross + * filesystem rename by simulating it with copy and delete. + * The MoveFile system call already handles the case of moving + * a file between filesystems. */ Tcl_SetErrno(EXDEV); } @@ -381,43 +398,44 @@ ckfree((char *) dstArgv); } /* * Other types of access failure is that dst is a read-only - * filesystem, that an open file referred to src or dest, or that - * src or dest specified the current working directory on the - * current filesystem. EACCES is returned for those cases. + * filesystem, that an open file referred to src or dest, or that src + * or dest specified the current working directory on the current + * filesystem. EACCES is returned for those cases. */ } else if (Tcl_GetErrno() == EEXIST) { /* - * Reports EEXIST any time the target already exists. If it makes + * Reports EEXIST any time the target already exists. If it makes * sense, remove the old file and try renaming again. */ if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) { if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) { /* - * Overwrite empty dst directory with src directory. The - * following call will remove an empty directory. If it - * fails, it's because it wasn't empty. + * Overwrite empty dst directory with src directory. The + * following call will remove an empty directory. If it fails, + * it's because it wasn't empty. */ if (DoRemoveJustDirectory(nativeDst, 0, NULL) == TCL_OK) { /* * Now that that empty directory is gone, we can try - * renaming again. If that fails, we'll put this empty + * renaming again. If that fails, we'll put this empty * directory back, for completeness. */ - if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) { + if ((*tclWinProcs->moveFileProc)(nativeSrc, + nativeDst) != FALSE) { return TCL_OK; } /* - * Some new error has occurred. Don't know what it - * could be, but report this one. + * Some new error has occurred. Don't know what it could + * be, but report this one. */ TclWinConvertError(GetLastError()); (*tclWinProcs->createDirectoryProc)(nativeDst, NULL); (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr); @@ -436,59 +454,61 @@ if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) { Tcl_SetErrno(EISDIR); } else { /* * Overwrite existing file by: - * + * * 1. Rename existing file to temp name. * 2. Rename old file to new name. - * 3. If success, delete temp file. If failure, - * put temp file back to old name. + * 3. If success, delete temp file. If failure, put temp file + * back to old name. */ TCHAR *nativeRest, *nativeTmp, *nativePrefix; int result, size; WCHAR tempBuf[MAX_PATH]; - - size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH, + + size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH, tempBuf, &nativeRest); if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) { return TCL_ERROR; } nativeTmp = (TCHAR *) tempBuf; ((char *) nativeRest)[0] = '\0'; ((char *) nativeRest)[1] = '\0'; /* In case it's Unicode. */ result = TCL_ERROR; - nativePrefix = (tclWinProcs->useWide) + nativePrefix = (tclWinProcs->useWide) ? (TCHAR *) L"tclr" : (TCHAR *) "tclr"; - if ((*tclWinProcs->getTempFileNameProc)(nativeTmp, + if ((*tclWinProcs->getTempFileNameProc)(nativeTmp, nativePrefix, 0, tempBuf) != 0) { /* * Strictly speaking, need the following DeleteFile and * MoveFile to be joined as an atomic operation so no * other app comes along in the meantime and creates the * same temp file. */ - + nativeTmp = (TCHAR *) tempBuf; (*tclWinProcs->deleteFileProc)(nativeTmp); - if ((*tclWinProcs->moveFileProc)(nativeDst, nativeTmp) != FALSE) { - if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) { - (*tclWinProcs->setFileAttributesProc)(nativeTmp, + if ((*tclWinProcs->moveFileProc)(nativeDst, + nativeTmp) != FALSE) { + if ((*tclWinProcs->moveFileProc)(nativeSrc, + nativeDst) != FALSE) { + (*tclWinProcs->setFileAttributesProc)(nativeTmp, FILE_ATTRIBUTE_NORMAL); (*tclWinProcs->deleteFileProc)(nativeTmp); return TCL_OK; } else { (*tclWinProcs->deleteFileProc)(nativeDst); (*tclWinProcs->moveFileProc)(nativeTmp, nativeDst); } - } + } /* - * Can't backup dst file or move src file. Return that - * error. Could happen if an open file refers to dst. + * Can't backup dst file or move src file. Return that + * error. Could happen if an open file refers to dst. */ TclWinConvertError(GetLastError()); if (Tcl_GetErrno() == EACCES) { /* @@ -503,168 +523,170 @@ } } return TCL_ERROR; } -/* - *---------------------------------------------------------------------- - * - * _except_dorenamefile_handler -- - * - * SEH exception handler for DoRenameFile. - * - * Results: - * See DoRenameFile. - * - * Side effects: - * See DoRenameFile. - * - *---------------------------------------------------------------------- - */ -#ifdef HAVE_NO_SEH -static -__attribute__ ((cdecl)) -EXCEPTION_DISPOSITION -_except_dorenamefile_handler( - struct _EXCEPTION_RECORD *ExceptionRecord, - void *EstablisherFrame, - struct _CONTEXT *ContextRecord, - void *DispatcherContext) -{ - __asm__ __volatile__ ( - "jmp dorenamefile_reentry"); - return 0; /* Function does not return */ -} -#endif /* HAVE_NO_SEH */ - /* *--------------------------------------------------------------------------- * * TclpObjCopyFile, DoCopyFile -- * - * Copy a single file (not a directory). If dst already exists and - * is not a directory, it is removed. + * Copy a single file (not a directory). If dst already exists and is not + * a directory, it is removed. * * Results: - * If the file was successfully copied, returns TCL_OK. Otherwise - * the return value is TCL_ERROR and errno is set to indicate the - * error. Some possible values for errno are: + * If the file was successfully copied, returns TCL_OK. Otherwise the + * return value is TCL_ERROR and errno is set to indicate the error. + * Some possible values for errno are: * - * EACCES: src or dst parent directory can't be read and/or written. + * EACCES: src or dst parent directory can't be read and/or written. * EISDIR: src or dst is a directory. - * ENOENT: src doesn't exist. src or dst is "". + * ENOENT: src doesn't exist. src or dst is "". * - * EACCES: exists an open file already referring to dst (95). + * EACCES: exists an open file already referring to dst (95). * EACCES: src specifies a char device (nul:, com1:, etc.) (NT) * ENOENT: src specifies a char device (nul:, com1:, etc.) (95) * * Side effects: * It is not an error to copy to a char device. * *--------------------------------------------------------------------------- */ -int +int TclpObjCopyFile(srcPathPtr, destPathPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; { return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr), - Tcl_FSGetNativePath(destPathPtr)); + Tcl_FSGetNativePath(destPathPtr)); } static int DoCopyFile( - CONST TCHAR *nativeSrc, /* Pathname of file to be copied (native). */ - CONST TCHAR *nativeDst) /* Pathname of file to copy to (native). */ + CONST TCHAR *nativeSrc, /* Pathname of file to be copied (native). */ + CONST TCHAR *nativeDst) /* Pathname of file to copy to (native). */ { +#ifdef HAVE_NO_SEH + EXCEPTION_REGISTRATION registration; +#endif int retval = -1; /* - * The CopyFile API acts differently under Win95/98 and NT - * WRT NULL and "". Avoid passing these values. + * The CopyFile API acts differently under Win95/98 and NT WRT NULL and + * "". Avoid passing these values. */ if (nativeSrc == NULL || nativeSrc[0] == '\0' || nativeDst == NULL || nativeDst[0] == '\0') { Tcl_SetErrno(ENOENT); return TCL_ERROR; } - + /* - * The CopyFile API would throw an exception under NT if one - * of the arguments is a char block device. + * The CopyFile API would throw an exception under NT if one of the + * arguments is a char block device. */ -#ifdef HAVE_NO_SEH -# ifdef TCL_MEM_DEBUG - __asm__ __volatile__ ( - "movl %%esp, %0" "\n\t" - "movl %%ebp, %1" "\n\t" - "movl %%fs:0, %2" "\n\t" - : "=m"(INITIAL_ESP), - "=m"(INITIAL_EBP), - "=r"(INITIAL_HANDLER) ); -# endif /* TCL_MEM_DEBUG */ - - __asm__ __volatile__ ( - "pushl %%ebp" "\n\t" - "pushl %0" "\n\t" - "pushl %%fs:0" "\n\t" - "movl %%esp, %%fs:0" - : - : "r" (_except_docopyfile_handler) - ); -#else +#ifndef HAVE_NO_SEH __try { -#endif /* HAVE_NO_SEH */ if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) { retval = TCL_OK; } -#ifdef HAVE_NO_SEH - __asm__ __volatile__ ( - "jmp docopyfile_pop" "\n" - "docopyfile_reentry:" "\n\t" - "movl %%fs:0, %%eax" "\n\t" - "movl 0x8(%%eax), %%esp" "\n\t" - "movl 0x8(%%esp), %%ebp" "\n" - "docopyfile_pop:" "\n\t" - "movl (%%esp), %%eax" "\n\t" - "movl %%eax, %%fs:0" "\n\t" - "add $12, %%esp" "\n\t" - : - : - : "%eax"); - -# ifdef TCL_MEM_DEBUG - __asm__ __volatile__ ( - "movl %%esp, %0" "\n\t" - "movl %%ebp, %1" "\n\t" - "movl %%fs:0, %2" "\n\t" - : "=m"(RESTORED_ESP), - "=m"(RESTORED_EBP), - "=r"(RESTORED_HANDLER) ); - - if (INITIAL_ESP != RESTORED_ESP) { - Tcl_Panic("ESP restored incorrectly"); - } - if (INITIAL_EBP != RESTORED_EBP) { - Tcl_Panic("EBP restored incorrectly"); - } - if (INITIAL_HANDLER != RESTORED_HANDLER) { - Tcl_Panic("HANDLER restored incorrectly"); - } -# endif /* TCL_MEM_DEBUG */ -#else - } __except (EXCEPTION_EXECUTE_HANDLER) {} -#endif /* HAVE_NO_SEH */ - - /* - * Avoid using control flow statements in the SEH guarded block! - */ - if (retval != -1) { - return retval; + } __except (EXCEPTION_EXECUTE_HANDLER) {} +#else + + /* + * Don't have SEH available, do things the hard way. Note that this needs + * to be one block of asm, to avoid stack imbalance; also, it is illegal + * for one asm block to contain a jump to another. + */ + + __asm__ __volatile__ ( + + /* + * Pick up parameters before messing with the stack + */ + + "movl %[nativeDst], %%ebx" "\n\t" + "movl %[nativeSrc], %%ecx" "\n\t" + + /* + * Construct an EXCEPTION_REGISTRATION to protect the call to + * CopyFile. + */ + + "leal %[registration], %%edx" "\n\t" + "movl %%fs:0, %%eax" "\n\t" + "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ + "leal 1f, %%eax" "\n\t" + "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ + "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ + "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */ + "movl $0, 0x10(%%edx)" "\n\t" /* status */ + + /* + * Link the EXCEPTION_REGISTRATION on the chain. + */ + + "movl %%edx, %%fs:0" "\n\t" + + /* + * Call CopyFile(nativeSrc, nativeDst, 0) + */ + + "movl %[copyFile], %%eax" "\n\t" + "pushl $0" "\n\t" + "pushl %%ebx" "\n\t" + "pushl %%ecx" "\n\t" + "call *%%eax" "\n\t" + + /* + * Come here on normal exit. Recover the EXCEPTION_REGISTRATION and + * put the status return from CopyFile into it. + */ + + "movl %%fs:0, %%edx" "\n\t" + "movl %%eax, 0x10(%%edx)" "\n\t" + "jmp 2f" "\n" + + /* + * Come here on an exception. Recover the EXCEPTION_REGISTRATION + */ + + "1:" "\t" + "movl %%fs:0, %%edx" "\n\t" + "movl 0x8(%%edx), %%edx" "\n\t" + + /* + * Come here however we exited. Restore context from the + * EXCEPTION_REGISTRATION in case the stack is unbalanced. + */ + + "2:" "\t" + "movl 0xc(%%edx), %%esp" "\n\t" + "movl 0x8(%%edx), %%ebp" "\n\t" + "movl 0x0(%%edx), %%eax" "\n\t" + "movl %%eax, %%fs:0" "\n\t" + + : + /* No outputs */ + : + [registration] "m" (registration), + [nativeDst] "m" (nativeDst), + [nativeSrc] "m" (nativeSrc), + [copyFile] "r" (tclWinProcs->copyFileProc) + : + "%eax", "%ebx", "%ecx", "%edx", "memory" + ); + if (registration.status != FALSE) { + retval = TCL_OK; + } +#endif + + if (retval != -1) { + return retval; } TclWinConvertError(GetLastError()); if (Tcl_GetErrno() == EBADF) { Tcl_SetErrno(EACCES); @@ -681,25 +703,27 @@ } if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) || (dstAttr & FILE_ATTRIBUTE_DIRECTORY)) { if (srcAttr & FILE_ATTRIBUTE_REPARSE_POINT) { /* Source is a symbolic link -- copy it */ - if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst) == 0) { - return TCL_OK; + if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst)==0) { + return TCL_OK; } } Tcl_SetErrno(EISDIR); } if (dstAttr & FILE_ATTRIBUTE_READONLY) { - (*tclWinProcs->setFileAttributesProc)(nativeDst, + (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr & ~((DWORD)FILE_ATTRIBUTE_READONLY)); - if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) { + if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, + 0) != FALSE) { return TCL_OK; } + /* - * Still can't copy onto dst. Return that error, and - * restore attributes of dst. + * Still can't copy onto dst. Return that error, and restore + * attributes of dst. */ TclWinConvertError(GetLastError()); (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr); } @@ -706,67 +730,36 @@ } } return TCL_ERROR; } -/* - *---------------------------------------------------------------------- - * - * _except_docopyfile_handler -- - * - * SEH exception handler for DoCopyFile. - * - * Results: - * See DoCopyFile. - * - * Side effects: - * See DoCopyFile. - * - *---------------------------------------------------------------------- - */ -#ifdef HAVE_NO_SEH -static -__attribute__ ((cdecl)) -EXCEPTION_DISPOSITION -_except_docopyfile_handler( - struct _EXCEPTION_RECORD *ExceptionRecord, - void *EstablisherFrame, - struct _CONTEXT *ContextRecord, - void *DispatcherContext) -{ - __asm__ __volatile__ ( - "jmp docopyfile_reentry"); - return 0; /* Function does not return */ -} -#endif /* HAVE_NO_SEH */ - /* *--------------------------------------------------------------------------- * * TclpObjDeleteFile, TclpDeleteFile -- * - * Removes a single file (not a directory). + * Removes a single file (not a directory). * * Results: - * If the file was successfully deleted, returns TCL_OK. Otherwise - * the return value is TCL_ERROR and errno is set to indicate the - * error. Some possible values for errno are: + * If the file was successfully deleted, returns TCL_OK. Otherwise the + * return value is TCL_ERROR and errno is set to indicate the error. + * Some possible values for errno are: * - * EACCES: a parent directory can't be read and/or written. + * EACCES: a parent directory can't be read and/or written. * EISDIR: path is a directory. * ENOENT: path doesn't exist or is "". * - * EACCES: exists an open file already referring to path. + * EACCES: exists an open file already referring to path. * EACCES: path is a char device (nul:, com1:, etc.) * * Side effects: - * The file is deleted, even if it is read-only. + * The file is deleted, even if it is read-only. * *--------------------------------------------------------------------------- */ -int +int TclpObjDeleteFile(pathPtr) Tcl_Obj *pathPtr; { return TclpDeleteFile(Tcl_FSGetNativePath(pathPtr)); } @@ -776,12 +769,12 @@ CONST TCHAR *nativePath) /* Pathname of file to be removed (native). */ { DWORD attr; /* - * The DeleteFile API acts differently under Win95/98 and NT - * WRT NULL and "". Avoid passing these values. + * The DeleteFile API acts differently under Win95/98 and NT WRT NULL and + * "". Avoid passing these values. */ if (nativePath == NULL || nativePath[0] == '\0') { Tcl_SetErrno(ENOENT); return TCL_ERROR; @@ -791,31 +784,34 @@ return TCL_OK; } TclWinConvertError(GetLastError()); if (Tcl_GetErrno() == EACCES) { - attr = (*tclWinProcs->getFileAttributesProc)(nativePath); + attr = (*tclWinProcs->getFileAttributesProc)(nativePath); if (attr != 0xffffffff) { if (attr & FILE_ATTRIBUTE_DIRECTORY) { if (attr & FILE_ATTRIBUTE_REPARSE_POINT) { - /* It is a symbolic link -- remove it */ + /* + * It is a symbolic link - remove it. + */ if (TclWinSymLinkDelete(nativePath, 0) == 0) { - return TCL_OK; + return TCL_OK; } } - - /* + + /* * If we fall through here, it is a directory. - * + * * Windows NT reports removing a directory as EACCES instead * of EISDIR. */ Tcl_SetErrno(EISDIR); } else if (attr & FILE_ATTRIBUTE_READONLY) { - int res = (*tclWinProcs->setFileAttributesProc)(nativePath, + int res = (*tclWinProcs->setFileAttributesProc)(nativePath, attr & ~((DWORD)FILE_ATTRIBUTE_READONLY)); + if ((res != 0) && ((*tclWinProcs->deleteFileProc)(nativePath) != FALSE)) { return TCL_OK; } TclWinConvertError(GetLastError()); @@ -823,16 +819,16 @@ (*tclWinProcs->setFileAttributesProc)(nativePath, attr); } } } } else if (Tcl_GetErrno() == ENOENT) { - attr = (*tclWinProcs->getFileAttributesProc)(nativePath); + attr = (*tclWinProcs->getFileAttributesProc)(nativePath); if (attr != 0xffffffff) { if (attr & FILE_ATTRIBUTE_DIRECTORY) { - /* - * Windows 95 reports removing a directory as ENOENT instead - * of EISDIR. + /* + * Windows 95 reports removing a directory as ENOENT instead + * of EISDIR. */ Tcl_SetErrno(EISDIR); } } @@ -851,31 +847,31 @@ /* *--------------------------------------------------------------------------- * * TclpObjCreateDirectory -- * - * Creates the specified directory. All parent directories of the - * specified directory must already exist. The directory is - * automatically created with permissions so that user can access - * the new directory and create new files or subdirectories in it. + * Creates the specified directory. All parent directories of the + * specified directory must already exist. The directory is automatically + * created with permissions so that user can access the new directory and + * create new files or subdirectories in it. * * Results: - * If the directory was successfully created, returns TCL_OK. - * Otherwise the return value is TCL_ERROR and errno is set to - * indicate the error. Some possible values for errno are: + * If the directory was successfully created, returns TCL_OK. Otherwise + * the return value is TCL_ERROR and errno is set to indicate the error. + * Some possible values for errno are: * - * EACCES: a parent directory can't be read and/or written. + * EACCES: a parent directory can't be read and/or written. * EEXIST: path already exists. * ENOENT: a parent directory doesn't exist. * * Side effects: - * A directory is created. + * A directory is created. * *--------------------------------------------------------------------------- */ -int +int TclpObjCreateDirectory(pathPtr) Tcl_Obj *pathPtr; { return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr)); } @@ -887,41 +883,39 @@ DWORD error; if ((*tclWinProcs->createDirectoryProc)(nativePath, NULL) == 0) { error = GetLastError(); TclWinConvertError(error); return TCL_ERROR; - } + } return TCL_OK; } /* *--------------------------------------------------------------------------- * * TclpObjCopyDirectory -- * - * Recursively copies a directory. The target directory dst must - * not already exist. Note that this function does not merge two - * directory hierarchies, even if the target directory is an an - * empty directory. + * Recursively copies a directory. The target directory dst must not + * already exist. Note that this function does not merge two directory + * hierarchies, even if the target directory is an an empty directory. * * Results: - * If the directory was successfully copied, returns TCL_OK. - * Otherwise the return value is TCL_ERROR, errno is set to indicate - * the error, and the pathname of the file that caused the error - * is stored in errorPtr. See TclpCreateDirectory and TclpCopyFile - * for a description of possible values for errno. + * If the directory was successfully copied, returns TCL_OK. Otherwise + * the return value is TCL_ERROR, errno is set to indicate the error, and + * the pathname of the file that caused the error is stored in errorPtr. + * See TclpCreateDirectory and TclpCopyFile for a description of possible + * values for errno. * * Side effects: - * An exact copy of the directory hierarchy src will be created - * with the name dst. If an error occurs, the error will - * be returned immediately, and remaining files will not be - * processed. + * An exact copy of the directory hierarchy src will be created with the + * name dst. If an error occurs, the error will be returned immediately, + * and remaining files will not be processed. * *--------------------------------------------------------------------------- */ -int +int TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; Tcl_Obj **errorPtr; { @@ -939,13 +933,13 @@ Tcl_DStringFree(&srcString); Tcl_DStringFree(&dstString); if (ret != TCL_OK) { - if (!strcmp(Tcl_DStringValue(&ds), Tcl_GetString(normSrcPtr))) { + if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normSrcPtr))) { *errorPtr = srcPathPtr; - } else if (!strcmp(Tcl_DStringValue(&ds), Tcl_GetString(normDestPtr))) { + } else if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normDestPtr))) { *errorPtr = destPathPtr; } else { *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); } Tcl_DStringFree(&ds); @@ -955,60 +949,62 @@ } /* *---------------------------------------------------------------------- * - * TclpObjRemoveDirectory, DoRemoveDirectory -- + * TclpObjRemoveDirectory, DoRemoveDirectory -- * * Removes directory (and its contents, if the recursive flag is set). * * Results: - * If the directory was successfully removed, returns TCL_OK. - * Otherwise the return value is TCL_ERROR, errno is set to indicate - * the error, and the pathname of the file that caused the error - * is stored in errorPtr. Some possible values for errno are: + * If the directory was successfully removed, returns TCL_OK. Otherwise + * the return value is TCL_ERROR, errno is set to indicate the error, and + * the pathname of the file that caused the error is stored in errorPtr. + * Some possible values for errno are: * - * EACCES: path directory can't be read and/or written. + * EACCES: path directory can't be read and/or written. * EEXIST: path is a non-empty directory. * EINVAL: path is root directory or current directory. * ENOENT: path doesn't exist or is "". - * ENOTDIR: path is not a directory. + * ENOTDIR: path is not a directory. * * EACCES: path is a char device (nul:, com1:, etc.) (95) * EINVAL: path is a char device (nul:, com1:, etc.) (NT) * * Side effects: - * Directory removed. If an error occurs, the error will be returned + * Directory removed. If an error occurs, the error will be returned * immediately, and remaining files will not be deleted. * *---------------------------------------------------------------------- */ -int +int TclpObjRemoveDirectory(pathPtr, recursive, errorPtr) Tcl_Obj *pathPtr; int recursive; Tcl_Obj **errorPtr; { Tcl_DString ds; Tcl_Obj *normPtr = NULL; int ret; + if (recursive) { - /* + /* * In the recursive case, the string rep is used to construct a - * Tcl_DString which may be used extensively, so we can't - * optimize this case easily. + * Tcl_DString which may be used extensively, so we can't optimize + * this case easily. */ + Tcl_DString native; normPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); Tcl_WinUtfToTChar(Tcl_GetString(normPtr), -1, &native); ret = DoRemoveDirectory(&native, recursive, &ds); Tcl_DStringFree(&native); } else { - ret = DoRemoveJustDirectory(Tcl_FSGetNativePath(pathPtr), - 0, &ds); + ret = DoRemoveJustDirectory(Tcl_FSGetNativePath(pathPtr), 0, &ds); } + if (ret != TCL_OK) { int len = Tcl_DStringLength(&ds); if (len > 0) { if (normPtr != NULL && !strcmp(Tcl_DStringValue(&ds), TclGetString(normPtr))) { @@ -1018,28 +1014,29 @@ } Tcl_IncrRefCount(*errorPtr); } Tcl_DStringFree(&ds); } + return ret; } static int DoRemoveJustDirectory( CONST TCHAR *nativePath, /* Pathname of directory to be removed * (native). */ - int ignoreError, /* If non-zero, don't initialize the - * errorPtr under some circumstances - * on return. */ - Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free - * DString filled with UTF-8 name of file - * causing error. */ + int ignoreError, /* If non-zero, don't initialize the errorPtr + * under some circumstances on return. */ + Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free DString + * filled with UTF-8 name of file causing + * error. */ { DWORD attr; + /* - * The RemoveDirectory API acts differently under Win95/98 and NT - * WRT NULL and "". Avoid passing these values. + * The RemoveDirectory API acts differently under Win95/98 and NT WRT NULL + * and "". Avoid passing these values. */ if (nativePath == NULL || nativePath[0] == '\0') { Tcl_SetErrno(ENOENT); goto end; @@ -1046,61 +1043,69 @@ } attr = (*tclWinProcs->getFileAttributesProc)(nativePath); if (attr & FILE_ATTRIBUTE_REPARSE_POINT) { - /* It is a symbolic link -- remove it */ + /* + * It is a symbolic link - remove it. + */ if (TclWinSymLinkDelete(nativePath, 0) == 0) { return TCL_OK; } } else { - /* Ordinary directory */ + /* + * Ordinary directory. + */ + if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) { return TCL_OK; } } - + TclWinConvertError(GetLastError()); if (Tcl_GetErrno() == EACCES) { attr = (*tclWinProcs->getFileAttributesProc)(nativePath); if (attr != 0xffffffff) { if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) { - /* - * Windows 95 reports calling RemoveDirectory on a file as an + /* + * Windows 95 reports calling RemoveDirectory on a file as an * EACCES, not an ENOTDIR. */ - + Tcl_SetErrno(ENOTDIR); goto end; } if (attr & FILE_ATTRIBUTE_REPARSE_POINT) { - /* It is a symbolic link -- remove it */ + /* + * It is a symbolic link - remove it. + */ + if (TclWinSymLinkDelete(nativePath, 1) != 0) { goto end; } } - + if (attr & FILE_ATTRIBUTE_READONLY) { attr &= ~FILE_ATTRIBUTE_READONLY; - if ((*tclWinProcs->setFileAttributesProc)(nativePath, attr) == FALSE) { + if ((*tclWinProcs->setFileAttributesProc)(nativePath, + attr) == FALSE) { goto end; } if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) { return TCL_OK; } TclWinConvertError(GetLastError()); - (*tclWinProcs->setFileAttributesProc)(nativePath, + (*tclWinProcs->setFileAttributesProc)(nativePath, attr | FILE_ATTRIBUTE_READONLY); } - /* - * Windows 95 and Win32s report removing a non-empty directory - * as EACCES, not EEXIST. If the directory is not empty, - * change errno so caller knows what's going on. - + /* + * Windows 95 and Win32s report removing a non-empty directory as + * EACCES, not EEXIST. If the directory is not empty, change errno + * so caller knows what's going on. */ if (TclWinGetPlatformId() != VER_PLATFORM_WIN32_NT) { CONST char *path, *find; HANDLE handle; @@ -1137,28 +1142,29 @@ } Tcl_DStringFree(&buffer); } } } + if (Tcl_GetErrno() == ENOTEMPTY) { - /* - * The caller depends on EEXIST to signify that the directory is - * not empty, not ENOTEMPTY. + /* + * The caller depends on EEXIST to signify that the directory is not + * empty, not ENOTEMPTY. */ Tcl_SetErrno(EEXIST); } + if ((ignoreError != 0) && (Tcl_GetErrno() == EEXIST)) { - /* - * If we're being recursive, this error may actually - * be ok, so we don't want to initialise the errorPtr - * yet. + /* + * If we're being recursive, this error may actually be ok, so we + * don't want to initialise the errorPtr yet. */ return TCL_ERROR; } - end: + end: if (errorPtr != NULL) { Tcl_WinTCharToUtf(nativePath, -1, errorPtr); } return TCL_ERROR; @@ -1166,25 +1172,26 @@ static int DoRemoveDirectory( Tcl_DString *pathPtr, /* Pathname of directory to be removed * (native). */ - int recursive, /* If non-zero, removes directories that - * are nonempty. Otherwise, will only remove - * empty directories. */ - Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free - * DString filled with UTF-8 name of file - * causing error. */ -{ - int res = DoRemoveJustDirectory(Tcl_DStringValue(pathPtr), recursive, - errorPtr); - + int recursive, /* If non-zero, removes directories that are + * nonempty. Otherwise, will only remove empty + * directories. */ + Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free DString + * filled with UTF-8 name of file causing + * error. */ +{ + int res = DoRemoveJustDirectory(Tcl_DStringValue(pathPtr), recursive, + errorPtr); + if ((res == TCL_ERROR) && (recursive != 0) && (Tcl_GetErrno() == EEXIST)) { /* * The directory is nonempty, but the recursive flag has been * specified, so we recursively remove all the files in the directory. */ + return TraverseWinTree(TraversalDelete, pathPtr, NULL, errorPtr); } else { return res; } } @@ -1192,39 +1199,39 @@ /* *--------------------------------------------------------------------------- * * TraverseWinTree -- * - * Traverse directory tree specified by sourcePtr, calling the function - * traverseProc for each file and directory encountered. If destPtr - * is non-null, each of name in the sourcePtr directory is appended to - * the directory specified by destPtr and passed as the second argument - * to traverseProc() . + * Traverse directory tree specified by sourcePtr, calling the function + * traverseProc for each file and directory encountered. If destPtr is + * non-null, each of name in the sourcePtr directory is appended to the + * directory specified by destPtr and passed as the second argument to + * traverseProc(). * * Results: - * Standard Tcl result. + * Standard Tcl result. * * Side effects: - * None caused by TraverseWinTree, however the user specified - * traverseProc() may change state. If an error occurs, the error will - * be returned immediately, and remaining files will not be processed. + * None caused by TraverseWinTree, however the user specified + * traverseProc() may change state. If an error occurs, the error will be + * returned immediately, and remaining files will not be processed. * *--------------------------------------------------------------------------- */ -static int +static int TraverseWinTree( TraversalProc *traverseProc,/* Function to call for every file and * directory in source hierarchy. */ Tcl_DString *sourcePtr, /* Pathname of source directory to be * traversed (native). */ Tcl_DString *targetPtr, /* Pathname of directory to traverse in * parallel with source directory (native), * may be NULL. */ - Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free - * DString filled with UTF-8 name of file - * causing error. */ + Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free DString + * filled with UTF-8 name of file causing + * error. */ { DWORD sourceAttr; TCHAR *nativeSource, *nativeTarget, *nativeErrfile; int result, found, sourceLen, targetLen, oldSourceLen, oldTargetLen; HANDLE handle; @@ -1233,29 +1240,29 @@ nativeErrfile = NULL; result = TCL_OK; oldTargetLen = 0; /* lint. */ nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr); - nativeTarget = (TCHAR *) (targetPtr == NULL - ? NULL : Tcl_DStringValue(targetPtr)); - + nativeTarget = (TCHAR *) + (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)); + oldSourceLen = Tcl_DStringLength(sourcePtr); sourceAttr = (*tclWinProcs->getFileAttributesProc)(nativeSource); if (sourceAttr == 0xffffffff) { nativeErrfile = nativeSource; goto end; } - + if (sourceAttr & FILE_ATTRIBUTE_REPARSE_POINT) { /* * Process the symbolic link */ - return (*traverseProc)(nativeSource, nativeTarget, - DOTREE_LINK, errorPtr); + return (*traverseProc)(nativeSource, nativeTarget, DOTREE_LINK, + errorPtr); } - + if ((sourceAttr & FILE_ATTRIBUTE_DIRECTORY) == 0) { /* * Process the regular file */ @@ -1266,25 +1273,27 @@ Tcl_DStringAppend(sourcePtr, (char *) L"\\*.*", 4 * sizeof(WCHAR) + 1); Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1); } else { Tcl_DStringAppend(sourcePtr, "\\*.*", 4); } + nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr); handle = (*tclWinProcs->findFirstFileProc)(nativeSource, &data); if (handle == INVALID_HANDLE_VALUE) { - /* - * Can't read directory + /* + * Can't read directory. */ TclWinConvertError(GetLastError()); nativeErrfile = nativeSource; goto end; } nativeSource[oldSourceLen + 1] = '\0'; Tcl_DStringSetLength(sourcePtr, oldSourceLen); - result = (*traverseProc)(nativeSource, nativeTarget, DOTREE_PRED, errorPtr); + result = (*traverseProc)(nativeSource, nativeTarget, DOTREE_PRED, + errorPtr); if (result != TCL_OK) { FindClose(handle); return result; } @@ -1311,11 +1320,11 @@ Tcl_DStringAppend(targetPtr, "\\", 1); } } found = 1; - for ( ; found; found = (*tclWinProcs->findNextFileProc)(handle, &data)) { + for (; found; found = (*tclWinProcs->findNextFileProc)(handle, &data)) { TCHAR *nativeName; int len; if (tclWinProcs->useWide) { WCHAR *wp; @@ -1329,31 +1338,31 @@ if (*wp == '\0') { continue; } } nativeName = (TCHAR *) data.w.cFileName; - len = Tcl_UniCharLen(data.w.cFileName) * sizeof(WCHAR); + len = wcslen(data.w.cFileName) * sizeof(WCHAR); } else { - if ((strcmp(data.a.cFileName, ".") == 0) + if ((strcmp(data.a.cFileName, ".") == 0) || (strcmp(data.a.cFileName, "..") == 0)) { continue; } nativeName = (TCHAR *) data.a.cFileName; len = strlen(data.a.cFileName); } - /* - * Append name after slash, and recurse on the file. + /* + * Append name after slash, and recurse on the file. */ Tcl_DStringAppend(sourcePtr, (char *) nativeName, len + 1); Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1); if (targetPtr != NULL) { Tcl_DStringAppend(targetPtr, (char *) nativeName, len + 1); Tcl_DStringSetLength(targetPtr, Tcl_DStringLength(targetPtr) - 1); } - result = TraverseWinTree(traverseProc, sourcePtr, targetPtr, + result = TraverseWinTree(traverseProc, sourcePtr, targetPtr, errorPtr); if (result != TCL_OK) { break; } @@ -1367,11 +1376,11 @@ } } FindClose(handle); /* - * Strip off the trailing slash we added + * Strip off the trailing slash we added. */ Tcl_DStringSetLength(sourcePtr, oldSourceLen + 1); Tcl_DStringSetLength(sourcePtr, oldSourceLen); if (targetPtr != NULL) { @@ -1382,83 +1391,81 @@ /* * Call traverseProc() on a directory after visiting all the * files in that directory. */ - result = (*traverseProc)(Tcl_DStringValue(sourcePtr), - (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)), - DOTREE_POSTD, errorPtr); + result = (*traverseProc)(Tcl_DStringValue(sourcePtr), + (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)), + DOTREE_POSTD, errorPtr); } - end: + + end: if (nativeErrfile != NULL) { TclWinConvertError(GetLastError()); if (errorPtr != NULL) { Tcl_WinTCharToUtf(nativeErrfile, -1, errorPtr); } result = TCL_ERROR; } - + return result; } /* *---------------------------------------------------------------------- * * TraversalCopy * - * Called from TraverseUnixTree in order to execute a recursive - * copy of a directory. + * Called from TraverseUnixTree in order to execute a recursive copy of a + * directory. * * Results: - * Standard Tcl result. + * Standard Tcl result. * * Side effects: - * Depending on the value of type, src may be copied to dst. - * + * Depending on the value of type, src may be copied to dst. + * *---------------------------------------------------------------------- */ -static int +static int TraversalCopy( CONST TCHAR *nativeSrc, /* Source pathname to copy. */ CONST TCHAR *nativeDst, /* Destination pathname of copy. */ int type, /* Reason for call - see TraverseWinTree() */ Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled * with UTF-8 name of file causing error. */ { switch (type) { - case DOTREE_F: { - if (DoCopyFile(nativeSrc, nativeDst) == TCL_OK) { - return TCL_OK; - } - break; - } - case DOTREE_LINK: { - if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst) == TCL_OK) { - return TCL_OK; - } - break; - } - case DOTREE_PRED: { - if (DoCreateDirectory(nativeDst) == TCL_OK) { - DWORD attr = (*tclWinProcs->getFileAttributesProc)(nativeSrc); - if ((*tclWinProcs->setFileAttributesProc)(nativeDst, attr) - != FALSE) { - return TCL_OK; - } - TclWinConvertError(GetLastError()); - } - break; - } - case DOTREE_POSTD: { - return TCL_OK; - } + case DOTREE_F: + if (DoCopyFile(nativeSrc, nativeDst) == TCL_OK) { + return TCL_OK; + } + break; + case DOTREE_LINK: + if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst) == TCL_OK) { + return TCL_OK; + } + break; + case DOTREE_PRED: + if (DoCreateDirectory(nativeDst) == TCL_OK) { + DWORD attr = (*tclWinProcs->getFileAttributesProc)(nativeSrc); + + if ((*tclWinProcs->setFileAttributesProc)(nativeDst, + attr) != FALSE) { + return TCL_OK; + } + TclWinConvertError(GetLastError()); + } + break; + case DOTREE_POSTD: + return TCL_OK; } /* - * There shouldn't be a problem with src, because we already - * checked it to get here. + * There shouldn't be a problem with src, because we already checked it to + * get here. */ if (errorPtr != NULL) { Tcl_WinTCharToUtf(nativeDst, -1, errorPtr); } @@ -1468,56 +1475,52 @@ /* *---------------------------------------------------------------------- * * TraversalDelete -- * - * Called by procedure TraverseWinTree for every file and - * directory that it encounters in a directory hierarchy. This - * procedure unlinks files, and removes directories after all the - * containing files have been processed. + * Called by function TraverseWinTree for every file and directory that + * it encounters in a directory hierarchy. This function unlinks files, + * and removes directories after all the containing files have been + * processed. * * Results: - * Standard Tcl result. + * Standard Tcl result. * * Side effects: - * Files or directory specified by src will be deleted. If an - * error occurs, the windows error is converted to a Posix error - * and errno is set accordingly. + * Files or directory specified by src will be deleted. If an error + * occurs, the windows error is converted to a Posix error and errno is + * set accordingly. * *---------------------------------------------------------------------- */ static int -TraversalDelete( +TraversalDelete( CONST TCHAR *nativeSrc, /* Source pathname to delete. */ CONST TCHAR *dstPtr, /* Not used. */ int type, /* Reason for call - see TraverseWinTree() */ Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled * with UTF-8 name of file causing error. */ { switch (type) { - case DOTREE_F: { - if (TclpDeleteFile(nativeSrc) == TCL_OK) { - return TCL_OK; - } - break; - } - case DOTREE_LINK: { - if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) { - return TCL_OK; - } - break; - } - case DOTREE_PRED: { - return TCL_OK; - } - case DOTREE_POSTD: { - if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) { - return TCL_OK; - } - break; - } + case DOTREE_F: + if (TclpDeleteFile(nativeSrc) == TCL_OK) { + return TCL_OK; + } + break; + case DOTREE_LINK: + if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) { + return TCL_OK; + } + break; + case DOTREE_PRED: + return TCL_OK; + case DOTREE_POSTD: + if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) { + return TCL_OK; + } + break; } if (errorPtr != NULL) { Tcl_WinTCharToUtf(nativeSrc, -1, errorPtr); } @@ -1530,60 +1533,60 @@ * StatError -- * * Sets the object result with the appropriate error. * * Results: - * None. + * None. * * Side effects: - * The interp's object result is set with an error message - * based on the objIndex, fileName and errno. + * The interp's object result is set with an error message based on the + * objIndex, fileName and errno. * *---------------------------------------------------------------------- */ static void StatError( Tcl_Interp *interp, /* The interp that has the error */ - Tcl_Obj *fileName) /* The name of the file which caused the + Tcl_Obj *fileName) /* The name of the file which caused the * error. */ { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), + Tcl_AppendResult(interp, "could not read \"", TclGetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } /* *---------------------------------------------------------------------- * * GetWinFileAttributes -- * - * Returns a Tcl_Obj containing the value of a file attribute. - * This routine gets the -hidden, -readonly or -system attribute. + * Returns a Tcl_Obj containing the value of a file attribute. This + * routine gets the -hidden, -readonly or -system attribute. * * Results: - * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object - * will have ref count 0. If the return value is not TCL_OK, - * attributePtrPtr is not touched. + * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object will + * have ref count 0. If the return value is not TCL_OK, attributePtrPtr + * is not touched. * * Side effects: - * A new object is allocated if the file is valid. + * A new object is allocated if the file is valid. * *---------------------------------------------------------------------- */ static int GetWinFileAttributes( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ - Tcl_Obj *fileName, /* The name of the file. */ + Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ { DWORD result; CONST TCHAR *nativeName; int attr; - + nativeName = Tcl_FSGetNativePath(fileName); result = (*tclWinProcs->getFileAttributesProc)(nativeName); if (result == 0xffffffff) { StatError(interp, fileName); @@ -1590,111 +1593,123 @@ return TCL_ERROR; } attr = (int)(result & attributeArray[objIndex]); if ((objIndex == WIN_HIDDEN_ATTRIBUTE) && (attr != 0)) { - /* - * It is hidden. However there is a bug on some Windows - * OSes in which root volumes (drives) formatted as NTFS - * are declared hidden when they are not (and cannot be). - * + /* + * It is hidden. However there is a bug on some Windows OSes in which + * root volumes (drives) formatted as NTFS are declared hidden when + * they are not (and cannot be). + * * We test for, and fix that case, here. */ + int len; char *str = Tcl_GetStringFromObj(fileName,&len); + if (len < 4) { if (len == 0) { - /* - * Not sure if this is possible, but we pass it on - * anyway + /* + * Not sure if this is possible, but we pass it on anyway. */ } else if (len == 1 && (str[0] == '/' || str[0] == '\\')) { - /* Path is pointing to the root volume */ + /* + * Path is pointing to the root volume. + */ + attr = 0; - } else if ((str[1] == ':') + } else if ((str[1] == ':') && (len == 2 || (str[2] == '/' || str[2] == '\\'))) { - /* Path is of the form 'x:' or 'x:/' or 'x:\' */ + /* + * Path is of the form 'x:' or 'x:/' or 'x:\' + */ + attr = 0; } } } + *attributePtrPtr = Tcl_NewBooleanObj(attr); return TCL_OK; } /* *---------------------------------------------------------------------- * * ConvertFileNameFormat -- * - * Returns a Tcl_Obj containing either the long or short version of the + * Returns a Tcl_Obj containing either the long or short version of the * file name. * * Results: - * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object - * will have ref count 0. If the return value is not TCL_OK, - * attributePtrPtr is not touched. - * - * Warning: if you pass this function a drive name like 'c:' it - * will actually return the current working directory on that - * drive. To avoid this, make sure the drive name ends in a - * slash, like this 'c:/'. + * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object will + * have ref count 0. If the return value is not TCL_OK, attributePtrPtr + * is not touched. + * + * Warning: if you pass this function a drive name like 'c:' it will + * actually return the current working directory on that drive. To avoid + * this, make sure the drive name ends in a slash, like this 'c:/'. * * Side effects: - * A new object is allocated if the file is valid. + * A new object is allocated if the file is valid. * *---------------------------------------------------------------------- */ static int ConvertFileNameFormat( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ - Tcl_Obj *fileName, /* The name of the file. */ + Tcl_Obj *fileName, /* The name of the file. */ int longShort, /* 0 to short name, 1 to long name. */ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ { int pathc, i; Tcl_Obj *splitPath; splitPath = Tcl_FSSplitPath(fileName, &pathc); - + if (splitPath == NULL || pathc == 0) { if (interp != NULL) { Tcl_AppendResult(interp, "could not read \"", - Tcl_GetString(fileName), "\": no such file or directory", + Tcl_GetString(fileName), "\": no such file or directory", (char *) NULL); } goto cleanup; } - + /* - * We will decrement this again at the end. It is safer to - * do this in case any of the calls below retain a reference - * to splitPath. + * We will decrement this again at the end. It is safer to do this in + * case any of the calls below retain a reference to splitPath. */ + Tcl_IncrRefCount(splitPath); for (i = 0; i < pathc; i++) { Tcl_Obj *elt; char *pathv; int pathLen; + Tcl_ListObjIndex(NULL, splitPath, i, &elt); - + pathv = Tcl_GetStringFromObj(elt, &pathLen); if ((pathv[0] == '/') || ((pathLen == 3) && (pathv[1] == ':')) || (strcmp(pathv, ".") == 0) || (strcmp(pathv, "..") == 0)) { /* * Handle "/", "//machine/export", "c:/", "." or ".." by just - * copying the string literally. Uppercase the drive letter, - * just because it looks better under Windows to do so. + * copying the string literally. Uppercase the drive letter, just + * because it looks better under Windows to do so. + */ + + simple: + /* + * Here we are modifying the string representation in place. + * + * I believe this is legal, since this won't affect any file + * representation this thing may have. */ - simple: - /* Here we are modifying the string representation in place */ - /* I believe this is legal, since this won't affect any - * file representation this thing may have. */ pathv[0] = (char) Tcl_UniCharToUpper(UCHAR(pathv[0])); } else { Tcl_Obj *tempPath; Tcl_DString ds; Tcl_DString dsTemp; @@ -1705,29 +1720,31 @@ HANDLE handle; DWORD attr; tempPath = Tcl_FSJoinPath(splitPath, i+1); Tcl_IncrRefCount(tempPath); - /* - * We'd like to call Tcl_FSGetNativePath(tempPath) - * but that is likely to lead to infinite loops + + /* + * We'd like to call Tcl_FSGetNativePath(tempPath) but that is + * likely to lead to infinite loops. */ + Tcl_DStringInit(&ds); tempString = Tcl_GetStringFromObj(tempPath,&tempLen); nativeName = Tcl_WinUtfToTChar(tempString, tempLen, &ds); Tcl_DecrRefCount(tempPath); handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data); if (handle == INVALID_HANDLE_VALUE) { /* - * FindFirstFile() doesn't like root directories. We - * would only get a root directory here if the caller - * specified "c:" or "c:." and the current directory on the - * drive was the root directory + * FindFirstFile() doesn't like root directories. We would + * only get a root directory here if the caller specified "c:" + * or "c:." and the current directory on the drive was the + * root directory */ attr = (*tclWinProcs->getFileAttributesProc)(nativeName); - if ((attr != 0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) { + if ((attr!=0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) { Tcl_DStringFree(&ds); goto simple; } } @@ -1741,11 +1758,11 @@ if (tclWinProcs->useWide) { nativeName = (TCHAR *) data.w.cAlternateFileName; if (longShort) { if (data.w.cFileName[0] != '\0') { nativeName = (TCHAR *) data.w.cFileName; - } + } } else { if (data.w.cAlternateFileName[0] == '\0') { nativeName = (TCHAR *) data.w.cFileName; } } @@ -1752,58 +1769,63 @@ } else { nativeName = (TCHAR *) data.a.cAlternateFileName; if (longShort) { if (data.a.cFileName[0] != '\0') { nativeName = (TCHAR *) data.a.cFileName; - } + } } else { if (data.a.cAlternateFileName[0] == '\0') { nativeName = (TCHAR *) data.a.cFileName; } } } /* - * Purify reports a extraneous UMR in Tcl_WinTCharToUtf() trying - * to dereference nativeName as a Unicode string. I have proven - * to myself that purify is wrong by running the following - * example when nativeName == data.w.cAlternateFileName and - * noting that purify doesn't complain about the first line, - * but does complain about the second. + * Purify reports a extraneous UMR in Tcl_WinTCharToUtf() trying + * to dereference nativeName as a Unicode string. I have proven to + * myself that purify is wrong by running the following example + * when nativeName == data.w.cAlternateFileName and noting that + * purify doesn't complain about the first line, but does complain + * about the second. * * fprintf(stderr, "%d\n", data.w.cAlternateFileName[0]); * fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]); */ Tcl_DStringInit(&dsTemp); Tcl_WinTCharToUtf(nativeName, -1, &dsTemp); - /* Deal with issues of tildes being absolute */ + + /* + * Deal with issues of tildes being absolute. + */ + if (Tcl_DStringValue(&dsTemp)[0] == '~') { tempPath = Tcl_NewStringObj("./",2); - Tcl_AppendToObj(tempPath, Tcl_DStringValue(&dsTemp), - Tcl_DStringLength(&dsTemp)); + Tcl_AppendToObj(tempPath, Tcl_DStringValue(&dsTemp), + Tcl_DStringLength(&dsTemp)); } else { - tempPath = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp), - Tcl_DStringLength(&dsTemp)); + tempPath = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp), + Tcl_DStringLength(&dsTemp)); } Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath); Tcl_DStringFree(&ds); Tcl_DStringFree(&dsTemp); FindClose(handle); } } *attributePtrPtr = Tcl_FSJoinPath(splitPath, -1); - + if (splitPath != NULL) { - /* - * Unfortunately, the object we will return may have its only - * refCount as part of the list splitPath. This means if - * we free splitPath, the object will disappear. So, we - * have to be very careful here. Unfortunately this means - * we must manipulate the object's refCount directly. + /* + * Unfortunately, the object we will return may have its only refCount + * as part of the list splitPath. This means if we free splitPath, the + * object will disappear. So, we have to be very careful here. + * Unfortunately this means we must manipulate the object's refCount + * directly. */ + Tcl_IncrRefCount(*attributePtrPtr); Tcl_DecrRefCount(splitPath); --(*attributePtrPtr)->refCount; } return TCL_OK; @@ -1810,94 +1832,94 @@ cleanup: if (splitPath != NULL) { Tcl_DecrRefCount(splitPath); } - + return TCL_ERROR; } /* *---------------------------------------------------------------------- * * GetWinFileLongName -- * - * Returns a Tcl_Obj containing the long version of the file - * name. + * Returns a Tcl_Obj containing the long version of the file name. * * Results: - * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object - * will have ref count 0. If the return value is not TCL_OK, - * attributePtrPtr is not touched. + * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object will + * have ref count 0. If the return value is not TCL_OK, attributePtrPtr + * is not touched. * * Side effects: - * A new object is allocated if the file is valid. + * A new object is allocated if the file is valid. * *---------------------------------------------------------------------- */ static int GetWinFileLongName( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ - Tcl_Obj *fileName, /* The name of the file. */ + Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ { - return ConvertFileNameFormat(interp, objIndex, fileName, 1, attributePtrPtr); + return ConvertFileNameFormat(interp, objIndex, fileName, 1, + attributePtrPtr); } /* *---------------------------------------------------------------------- * * GetWinFileShortName -- * - * Returns a Tcl_Obj containing the short version of the file - * name. + * Returns a Tcl_Obj containing the short version of the file name. * * Results: - * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object - * will have ref count 0. If the return value is not TCL_OK, - * attributePtrPtr is not touched. + * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object will + * have ref count 0. If the return value is not TCL_OK, attributePtrPtr + * is not touched. * * Side effects: - * A new object is allocated if the file is valid. + * A new object is allocated if the file is valid. * *---------------------------------------------------------------------- */ static int GetWinFileShortName( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ - Tcl_Obj *fileName, /* The name of the file. */ + Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ { - return ConvertFileNameFormat(interp, objIndex, fileName, 0, attributePtrPtr); + return ConvertFileNameFormat(interp, objIndex, fileName, 0, + attributePtrPtr); } /* *---------------------------------------------------------------------- * * SetWinFileAttributes -- * - * Set the file attributes to the value given by attributePtr. - * This routine sets the -hidden, -readonly, or -system attributes. + * Set the file attributes to the value given by attributePtr. This + * routine sets the -hidden, -readonly, or -system attributes. * * Results: - * Standard TCL error. + * Standard TCL error. * * Side effects: - * The file's attribute is set. + * The file's attribute is set. * *---------------------------------------------------------------------- */ static int SetWinFileAttributes( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ - Tcl_Obj *fileName, /* The name of the file. */ + Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj *attributePtr) /* The new value of the attribute. */ { DWORD fileAttributes; int yesNo; int result; @@ -1933,27 +1955,26 @@ /* *---------------------------------------------------------------------- * * SetWinFileLongName -- * - * The attribute in question is a readonly attribute and cannot - * be set. + * The attribute in question is a readonly attribute and cannot be set. * * Results: - * TCL_ERROR + * TCL_ERROR * * Side effects: - * The object result is set to a pertinent error message. + * The object result is set to a pertinent error message. * *---------------------------------------------------------------------- */ static int CannotSetAttribute( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ - Tcl_Obj *fileName, /* The name of the file. */ + Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj *attributePtr) /* The new value of the attribute. */ { Tcl_AppendResult(interp, "cannot set attribute \"", tclpFileAttrStrings[objIndex], "\" for file \"", Tcl_GetString(fileName), "\": attribute is readonly", @@ -1995,15 +2016,15 @@ */ if (GetLogicalDriveStringsA(sizeof(buf), buf) == 0) { /* * GetVolumeInformation() will detects all drives, but causes - * chattering on empty floppy drives. We only do this if - * GetLogicalDriveStrings() didn't work. It has also been reported - * that on some laptops it takes a while for GetVolumeInformation() - * to return when pinging an empty floppy drive, another reason to - * try to avoid calling it. + * chattering on empty floppy drives. We only do this if + * GetLogicalDriveStrings() didn't work. It has also been reported + * that on some laptops it takes a while for GetVolumeInformation() to + * return when pinging an empty floppy drive, another reason to try to + * avoid calling it. */ buf[1] = ':'; buf[2] = '/'; buf[3] = '\0'; @@ -2021,9 +2042,17 @@ p[2] = '/'; elemPtr = Tcl_NewStringObj(p, -1); Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr); } } - + Tcl_IncrRefCount(resultPtr); return resultPtr; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: win/tclWinFile.c ================================================================== --- win/tclWinFile.c +++ win/tclWinFile.c @@ -1,274 +1,316 @@ -/* +/* * tclWinFile.c -- * - * This file contains temporary wrappers around UNIX file handling - * functions. These wrappers map the UNIX functions to Win32 HANDLE-style - * files, which can be manipulated through the Win32 console redirection - * interfaces. + * This file contains temporary wrappers around UNIX file handling + * functions. These wrappers map the UNIX functions to Win32 HANDLE-style + * files, which can be manipulated through the Win32 console redirection + * interfaces. * * Copyright (c) 1995-1998 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinFile.c,v 1.72 2004/12/01 23:18:55 dgp Exp $ + * RCS: @(#) $Id: tclWinFile.c,v 1.72.2.4 2005/09/09 18:48:41 dgp Exp $ */ -//#define _WIN32_WINNT 0x0500 +//#define _WIN32_WINNT 0x0500 #include "tclWinInt.h" #include "tclFileSystem.h" #include #include #include #include /* For TclpGetUserHome(). */ /* - * The number of 100-ns intervals between the Windows system epoch - * (1601-01-01 on the proleptic Gregorian calendar) and the - * Posix epoch (1970-01-01). + * The number of 100-ns intervals between the Windows system epoch (1601-01-01 + * on the proleptic Gregorian calendar) and the Posix epoch (1970-01-01). */ -#define POSIX_EPOCH_AS_FILETIME 116444736000000000 +#define POSIX_EPOCH_AS_FILETIME 116444736000000000 /* - * Declarations for 'link' related information. This information - * should come with VC++ 6.0, but is not in some older SDKs. - * In any case it is not well documented. + * Declarations for 'link' related information. This information should come + * with VC++ 6.0, but is not in some older SDKs. In any case it is not well + * documented. */ + #ifndef IO_REPARSE_TAG_RESERVED_ONE -# define IO_REPARSE_TAG_RESERVED_ONE 0x000000001 +# define IO_REPARSE_TAG_RESERVED_ONE 0x000000001 #endif #ifndef IO_REPARSE_TAG_RESERVED_RANGE -# define IO_REPARSE_TAG_RESERVED_RANGE 0x000000001 +# define IO_REPARSE_TAG_RESERVED_RANGE 0x000000001 #endif #ifndef IO_REPARSE_TAG_VALID_VALUES -# define IO_REPARSE_TAG_VALID_VALUES 0x0E000FFFF +# define IO_REPARSE_TAG_VALID_VALUES 0x0E000FFFF #endif #ifndef IO_REPARSE_TAG_HSM -# define IO_REPARSE_TAG_HSM 0x0C0000004 +# define IO_REPARSE_TAG_HSM 0x0C0000004 #endif #ifndef IO_REPARSE_TAG_NSS -# define IO_REPARSE_TAG_NSS 0x080000005 +# define IO_REPARSE_TAG_NSS 0x080000005 #endif #ifndef IO_REPARSE_TAG_NSSRECOVER -# define IO_REPARSE_TAG_NSSRECOVER 0x080000006 +# define IO_REPARSE_TAG_NSSRECOVER 0x080000006 #endif #ifndef IO_REPARSE_TAG_SIS -# define IO_REPARSE_TAG_SIS 0x080000007 +# define IO_REPARSE_TAG_SIS 0x080000007 #endif #ifndef IO_REPARSE_TAG_DFS -# define IO_REPARSE_TAG_DFS 0x080000008 +# define IO_REPARSE_TAG_DFS 0x080000008 #endif #ifndef IO_REPARSE_TAG_RESERVED_ZERO -# define IO_REPARSE_TAG_RESERVED_ZERO 0x00000000 +# define IO_REPARSE_TAG_RESERVED_ZERO 0x00000000 #endif #ifndef FILE_FLAG_OPEN_REPARSE_POINT -# define FILE_FLAG_OPEN_REPARSE_POINT 0x00200000 +# define FILE_FLAG_OPEN_REPARSE_POINT 0x00200000 #endif #ifndef IO_REPARSE_TAG_MOUNT_POINT -# define IO_REPARSE_TAG_MOUNT_POINT 0xA0000003 +# define IO_REPARSE_TAG_MOUNT_POINT 0xA0000003 #endif #ifndef IsReparseTagValid -# define IsReparseTagValid(x) (!((x)&~IO_REPARSE_TAG_VALID_VALUES)&&((x)>IO_REPARSE_TAG_RESERVED_RANGE)) +# define IsReparseTagValid(x) \ + (!((x)&~IO_REPARSE_TAG_VALID_VALUES)&&((x)>IO_REPARSE_TAG_RESERVED_RANGE)) #endif #ifndef IO_REPARSE_TAG_SYMBOLIC_LINK -# define IO_REPARSE_TAG_SYMBOLIC_LINK IO_REPARSE_TAG_RESERVED_ZERO +# define IO_REPARSE_TAG_SYMBOLIC_LINK IO_REPARSE_TAG_RESERVED_ZERO #endif #ifndef FILE_SPECIAL_ACCESS -# define FILE_SPECIAL_ACCESS (FILE_ANY_ACCESS) +# define FILE_SPECIAL_ACCESS (FILE_ANY_ACCESS) #endif #ifndef FSCTL_SET_REPARSE_POINT -# define FSCTL_SET_REPARSE_POINT CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 41, METHOD_BUFFERED, FILE_SPECIAL_ACCESS) -# define FSCTL_GET_REPARSE_POINT CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 42, METHOD_BUFFERED, FILE_ANY_ACCESS) -# define FSCTL_DELETE_REPARSE_POINT CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 43, METHOD_BUFFERED, FILE_SPECIAL_ACCESS) +# define FSCTL_SET_REPARSE_POINT \ + CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 41, METHOD_BUFFERED, FILE_SPECIAL_ACCESS) +# define FSCTL_GET_REPARSE_POINT \ + CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 42, METHOD_BUFFERED, FILE_ANY_ACCESS) +# define FSCTL_DELETE_REPARSE_POINT \ + CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 43, METHOD_BUFFERED, FILE_SPECIAL_ACCESS) #endif -/* - * Maximum reparse buffer info size. The max user defined reparse - * data is 16KB, plus there's a header. - */ - -#define MAX_REPARSE_SIZE 17000 - -/* - * Undocumented REPARSE_MOUNTPOINT_HEADER_SIZE structure definition. - * This is found in winnt.h. - * - * IMPORTANT: caution when using this structure, since the actual - * structures used will want to store a full path in the 'PathBuffer' - * field, but there isn't room (there's only a single WCHAR!). Therefore - * one must artificially create a larger space of memory and then cast it - * to this type. We use the 'DUMMY_REPARSE_BUFFER' struct just below to - * deal with this problem. - */ - -#define REPARSE_MOUNTPOINT_HEADER_SIZE 8 +/* + * Maximum reparse buffer info size. The max user defined reparse data is + * 16KB, plus there's a header. + */ + +#define MAX_REPARSE_SIZE 17000 + +/* + * Undocumented REPARSE_MOUNTPOINT_HEADER_SIZE structure definition. This is + * found in winnt.h. + * + * IMPORTANT: caution when using this structure, since the actual structures + * used will want to store a full path in the 'PathBuffer' field, but there + * isn't room (there's only a single WCHAR!). Therefore one must artificially + * create a larger space of memory and then cast it to this type. We use the + * 'DUMMY_REPARSE_BUFFER' struct just below to deal with this problem. + */ + +#define REPARSE_MOUNTPOINT_HEADER_SIZE 8 #ifndef REPARSE_DATA_BUFFER_HEADER_SIZE typedef struct _REPARSE_DATA_BUFFER { - DWORD ReparseTag; - WORD ReparseDataLength; - WORD Reserved; + DWORD ReparseTag; + WORD ReparseDataLength; + WORD Reserved; union { - struct { - WORD SubstituteNameOffset; - WORD SubstituteNameLength; - WORD PrintNameOffset; - WORD PrintNameLength; - WCHAR PathBuffer[1]; - } SymbolicLinkReparseBuffer; - struct { - WORD SubstituteNameOffset; - WORD SubstituteNameLength; - WORD PrintNameOffset; - WORD PrintNameLength; - WCHAR PathBuffer[1]; - } MountPointReparseBuffer; - struct { - BYTE DataBuffer[1]; - } GenericReparseBuffer; + struct { + WORD SubstituteNameOffset; + WORD SubstituteNameLength; + WORD PrintNameOffset; + WORD PrintNameLength; + WCHAR PathBuffer[1]; + } SymbolicLinkReparseBuffer; + struct { + WORD SubstituteNameOffset; + WORD SubstituteNameLength; + WORD PrintNameOffset; + WORD PrintNameLength; + WCHAR PathBuffer[1]; + } MountPointReparseBuffer; + struct { + BYTE DataBuffer[1]; + } GenericReparseBuffer; }; } REPARSE_DATA_BUFFER; #endif typedef struct { REPARSE_DATA_BUFFER dummy; - WCHAR dummyBuf[MAX_PATH*3]; + WCHAR dummyBuf[MAX_PATH*3]; } DUMMY_REPARSE_BUFFER; -#if defined(_MSC_VER) && ( _MSC_VER <= 1100 ) -#undef HAVE_NO_FINDEX_ENUMS +#if defined(_MSC_VER) && (_MSC_VER <= 1100) +#undef HAVE_NO_FINDEX_ENUMS #define HAVE_NO_FINDEX_ENUMS #elif !defined(_WIN32_WINNT) || (_WIN32_WINNT < 0x0400) -#undef HAVE_NO_FINDEX_ENUMS +#undef HAVE_NO_FINDEX_ENUMS #define HAVE_NO_FINDEX_ENUMS #endif #ifdef HAVE_NO_FINDEX_ENUMS /* These two aren't in VC++ 5.2 headers */ typedef enum _FINDEX_INFO_LEVELS { - FindExInfoStandard, - FindExInfoMaxInfoLevel + FindExInfoStandard, + FindExInfoMaxInfoLevel } FINDEX_INFO_LEVELS; typedef enum _FINDEX_SEARCH_OPS { - FindExSearchNameMatch, - FindExSearchLimitToDirectories, - FindExSearchLimitToDevices, - FindExSearchMaxSearchOp + FindExSearchNameMatch, + FindExSearchLimitToDirectories, + FindExSearchLimitToDevices, + FindExSearchMaxSearchOp } FINDEX_SEARCH_OPS; #endif /* HAVE_NO_FINDEX_ENUMS */ -/* Other typedefs required by this code */ +/* + * Other typedefs required by this code. + */ static time_t ToCTime(FILETIME fileTime); -static void FromCTime( time_t posixTime, - FILETIME* fileTime ); - -typedef NET_API_STATUS NET_API_FUNCTION NETUSERGETINFOPROC - (LPWSTR servername, LPWSTR username, DWORD level, LPBYTE *bufptr); - -typedef NET_API_STATUS NET_API_FUNCTION NETAPIBUFFERFREEPROC - (LPVOID Buffer); - -typedef NET_API_STATUS NET_API_FUNCTION NETGETDCNAMEPROC - (LPWSTR servername, LPWSTR domainname, LPBYTE *bufptr); - -/* - * Declarations for local procedures defined in this file: - */ - -static int NativeAccess(CONST TCHAR *path, int mode); -static int NativeStat(CONST TCHAR *path, Tcl_StatBuf *statPtr, int checkLinks); -static unsigned short NativeStatMode(DWORD attr, int checkLinks, int isExec); -static int NativeIsExec(CONST TCHAR *path); -static int NativeReadReparse(CONST TCHAR* LinkDirectory, - REPARSE_DATA_BUFFER* buffer); -static int NativeWriteReparse(CONST TCHAR* LinkDirectory, - REPARSE_DATA_BUFFER* buffer); -static int NativeMatchType(int isDrive, DWORD attr, CONST TCHAR* nativeName, - Tcl_GlobTypeData *types); -static int WinIsDrive(CONST char *name, int nameLen); -static Tcl_Obj* WinReadLink(CONST TCHAR* LinkSource); -static Tcl_Obj* WinReadLinkDirectory(CONST TCHAR* LinkDirectory); -static int WinLink(CONST TCHAR* LinkSource, CONST TCHAR* LinkTarget, - int linkAction); -static int WinSymLinkDirectory(CONST TCHAR* LinkDirectory, - CONST TCHAR* LinkTarget); - -/* - *-------------------------------------------------------------------- - * - * WinLink - * - * Make a link from source to target. - *-------------------------------------------------------------------- - */ -static int +static void FromCTime(time_t posixTime, FILETIME *fileTime); + +typedef NET_API_STATUS NET_API_FUNCTION NETUSERGETINFOPROC( + LPWSTR servername, LPWSTR username, DWORD level, LPBYTE *bufptr); + +typedef NET_API_STATUS NET_API_FUNCTION NETAPIBUFFERFREEPROC(LPVOID Buffer); + +typedef NET_API_STATUS NET_API_FUNCTION NETGETDCNAMEPROC( + LPWSTR servername, LPWSTR domainname, LPBYTE *bufptr); + +/* + * Declarations for local functions defined in this file: + */ + +static int NativeAccess(CONST TCHAR *path, int mode); +static int NativeStat(CONST TCHAR *path, Tcl_StatBuf *statPtr, + int checkLinks); +static unsigned short NativeStatMode(DWORD attr, int checkLinks, int isExec); +static int NativeIsExec(CONST TCHAR *path); +static int NativeReadReparse(CONST TCHAR *LinkDirectory, + REPARSE_DATA_BUFFER* buffer); +static int NativeWriteReparse(CONST TCHAR *LinkDirectory, + REPARSE_DATA_BUFFER* buffer); +static int NativeMatchType(int isDrive, DWORD attr, + CONST TCHAR *nativeName, Tcl_GlobTypeData *types); +static int WinIsDrive(CONST char *name, int nameLen); +static int WinIsReserved(CONST char *path); +static Tcl_Obj * WinReadLink(CONST TCHAR *LinkSource); +static Tcl_Obj * WinReadLinkDirectory(CONST TCHAR *LinkDirectory); +static int WinLink(CONST TCHAR *LinkSource, + CONST TCHAR *LinkTarget, int linkAction); +static int WinSymLinkDirectory(CONST TCHAR *LinkDirectory, + CONST TCHAR *LinkTarget); + +/* + *-------------------------------------------------------------------- + * + * WinLink -- + * + * Make a link from source to target. + * + *-------------------------------------------------------------------- + */ + +static int WinLink(LinkSource, LinkTarget, linkAction) - CONST TCHAR* LinkSource; - CONST TCHAR* LinkTarget; + CONST TCHAR *LinkSource; + CONST TCHAR *LinkTarget; int linkAction; { - WCHAR tempFileName[MAX_PATH]; - TCHAR* tempFilePart; - int attr; - - /* Get the full path referenced by the target */ - if (!(*tclWinProcs->getFullPathNameProc)(LinkTarget, - MAX_PATH, tempFileName, &tempFilePart)) { - /* Invalid file */ + WCHAR tempFileName[MAX_PATH]; + TCHAR *tempFilePart; + int attr; + + /* + * Get the full path referenced by the target. + */ + + if (!(*tclWinProcs->getFullPathNameProc)(LinkTarget, MAX_PATH, + tempFileName, &tempFilePart)) { + /* + * Invalid file. + */ TclWinConvertError(GetLastError()); return -1; } - /* Make sure source file doesn't exist */ + /* + * Make sure source file doesn't exist. + */ + attr = (*tclWinProcs->getFileAttributesProc)(LinkSource); if (attr != 0xffffffff) { Tcl_SetErrno(EEXIST); return -1; } - /* Get the full path referenced by the source file/directory */ - if (!(*tclWinProcs->getFullPathNameProc)(LinkSource, - MAX_PATH, tempFileName, &tempFilePart)) { - /* Invalid file */ + /* + * Get the full path referenced by the source file/directory. + */ + + if (!(*tclWinProcs->getFullPathNameProc)(LinkSource, MAX_PATH, + tempFileName, &tempFilePart)) { + /* + * Invalid file. + */ + TclWinConvertError(GetLastError()); return -1; } - /* Check the target */ + + /* + * Check the target. + */ + attr = (*tclWinProcs->getFileAttributesProc)(LinkTarget); if (attr == 0xffffffff) { - /* The target doesn't exist */ + /* + * The target doesn't exist. + */ + TclWinConvertError(GetLastError()); return -1; + } else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) { - /* It is a file */ + /* + * It is a file. + */ + if (tclWinProcs->createHardLinkProc == NULL) { Tcl_SetErrno(ENOTDIR); return -1; } + if (linkAction & TCL_CREATE_HARD_LINK) { - if (!(*tclWinProcs->createHardLinkProc)(LinkSource, LinkTarget, NULL)) { + if (!(*tclWinProcs->createHardLinkProc)(LinkSource, LinkTarget, + NULL)) { TclWinConvertError(GetLastError()); return -1; } return 0; + } else if (linkAction & TCL_CREATE_SYMBOLIC_LINK) { - /* Can't symlink files */ + /* + * Can't symlink files. + */ + Tcl_SetErrno(ENOTDIR); return -1; } else { Tcl_SetErrno(ENODEV); return -1; } } else { if (linkAction & TCL_CREATE_SYMBOLIC_LINK) { return WinSymLinkDirectory(LinkSource, LinkTarget); + } else if (linkAction & TCL_CREATE_HARD_LINK) { - /* Can't hard link directories */ + /* + * Can't hard link directories. + */ + Tcl_SetErrno(EISDIR); return -1; } else { Tcl_SetErrno(ENODEV); return -1; @@ -277,39 +319,57 @@ } /* *-------------------------------------------------------------------- * - * WinReadLink + * WinReadLink -- * - * What does 'LinkSource' point to? + * What does 'LinkSource' point to? + * *-------------------------------------------------------------------- */ -static Tcl_Obj* + +static Tcl_Obj* WinReadLink(LinkSource) - CONST TCHAR* LinkSource; -{ - WCHAR tempFileName[MAX_PATH]; - TCHAR* tempFilePart; - int attr; - - /* Get the full path referenced by the target */ - if (!(*tclWinProcs->getFullPathNameProc)(LinkSource, - MAX_PATH, tempFileName, &tempFilePart)) { - /* Invalid file */ + CONST TCHAR *LinkSource; +{ + WCHAR tempFileName[MAX_PATH]; + TCHAR *tempFilePart; + int attr; + + /* + * Get the full path referenced by the target. + */ + + if (!(*tclWinProcs->getFullPathNameProc)(LinkSource, MAX_PATH, + tempFileName, &tempFilePart)) { + /* + * Invalid file. + */ + TclWinConvertError(GetLastError()); return NULL; } - /* Make sure source file does exist */ + /* + * Make sure source file does exist. + */ + attr = (*tclWinProcs->getFileAttributesProc)(LinkSource); if (attr == 0xffffffff) { - /* The source doesn't exist */ + /* + * The source doesn't exist. + */ + TclWinConvertError(GetLastError()); return NULL; + } else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) { - /* It is a file - this is not yet supported */ + /* + * It is a file - this is not yet supported. + */ + Tcl_SetErrno(ENOTDIR); return NULL; } else { return WinReadLinkDirectory(LinkSource); } @@ -316,134 +376,158 @@ } /* *-------------------------------------------------------------------- * - * WinSymLinkDirectory - * - * This routine creates a NTFS junction, using the undocumented - * FSCTL_SET_REPARSE_POINT structure Win2K uses for mount points - * and junctions. - * - * Assumption that LinkTarget is a valid, existing directory. - * - * Returns zero on success. + * WinSymLinkDirectory -- + * + * This routine creates a NTFS junction, using the undocumented + * FSCTL_SET_REPARSE_POINT structure Win2K uses for mount points and + * junctions. + * + * Assumption that LinkTarget is a valid, existing directory. + * + * Returns: + * Zero on success. + * *-------------------------------------------------------------------- */ -static int + +static int WinSymLinkDirectory(LinkDirectory, LinkTarget) - CONST TCHAR* LinkDirectory; - CONST TCHAR* LinkTarget; + CONST TCHAR *LinkDirectory; + CONST TCHAR *LinkTarget; { DUMMY_REPARSE_BUFFER dummy; REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy; - int len; - WCHAR nativeTarget[MAX_PATH]; - WCHAR *loop; - - /* Make the native target name */ + int len; + WCHAR nativeTarget[MAX_PATH]; + WCHAR *loop; + + /* + * Make the native target name. + */ + memcpy((VOID*)nativeTarget, (VOID*)L"\\??\\", 4*sizeof(WCHAR)); - memcpy((VOID*)(nativeTarget + 4), (VOID*)LinkTarget, + memcpy((VOID*)(nativeTarget + 4), (VOID*)LinkTarget, sizeof(WCHAR)*(1+wcslen((WCHAR*)LinkTarget))); len = wcslen(nativeTarget); - /* - * We must have backslashes only. This is VERY IMPORTANT. - * If we have any forward slashes everything appears to work, - * but the resulting symlink is useless! + + /* + * We must have backslashes only. This is VERY IMPORTANT. If we have any + * forward slashes everything appears to work, but the resulting symlink + * is useless! */ + for (loop = nativeTarget; *loop != 0; loop++) { if (*loop == L'/') *loop = L'\\'; } if ((nativeTarget[len-1] == L'\\') && (nativeTarget[len-2] != L':')) { nativeTarget[len-1] = 0; } - - /* Build the reparse info */ + + /* + * Build the reparse info. + */ + memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER)); reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT; - reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength = - wcslen(nativeTarget) * sizeof(WCHAR); + reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength = + wcslen(nativeTarget) * sizeof(WCHAR); reparseBuffer->Reserved = 0; reparseBuffer->SymbolicLinkReparseBuffer.PrintNameLength = 0; - reparseBuffer->SymbolicLinkReparseBuffer.PrintNameOffset = - reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength - + sizeof(WCHAR); - memcpy(reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer, nativeTarget, - sizeof(WCHAR) - + reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength); - reparseBuffer->ReparseDataLength = - reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength + 12; - + reparseBuffer->SymbolicLinkReparseBuffer.PrintNameOffset = + reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength + + sizeof(WCHAR); + memcpy(reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer, nativeTarget, + sizeof(WCHAR) + + reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength); + reparseBuffer->ReparseDataLength = + reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength + 12; + return NativeWriteReparse(LinkDirectory, reparseBuffer); } /* *-------------------------------------------------------------------- * - * TclWinSymLinkCopyDirectory + * TclWinSymLinkCopyDirectory -- * - * Copy a Windows NTFS junction. This function assumes that - * LinkOriginal exists and is a valid junction point, and that - * LinkCopy does not exist. - * - * Returns zero on success. + * Copy a Windows NTFS junction. This function assumes that LinkOriginal + * exists and is a valid junction point, and that LinkCopy does not + * exist. + * + * Returns: + * Zero on success. + * *-------------------------------------------------------------------- */ -int + +int TclWinSymLinkCopyDirectory(LinkOriginal, LinkCopy) - CONST TCHAR* LinkOriginal; /* Existing junction - reparse point */ - CONST TCHAR* LinkCopy; /* Will become a duplicate junction */ + CONST TCHAR *LinkOriginal; /* Existing junction - reparse point */ + CONST TCHAR *LinkCopy; /* Will become a duplicate junction */ { DUMMY_REPARSE_BUFFER dummy; - REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy; - + REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy; + if (NativeReadReparse(LinkOriginal, reparseBuffer)) { return -1; } return NativeWriteReparse(LinkCopy, reparseBuffer); } /* *-------------------------------------------------------------------- * - * TclWinSymLinkDelete - * - * Delete a Windows NTFS junction. Once the junction information - * is deleted, the filesystem object becomes an ordinary directory. - * Unless 'linkOnly' is given, that directory is also removed. - * - * Assumption that LinkOriginal is a valid, existing junction. - * - * Returns zero on success. + * TclWinSymLinkDelete -- + * + * Delete a Windows NTFS junction. Once the junction information is + * deleted, the filesystem object becomes an ordinary directory. Unless + * 'linkOnly' is given, that directory is also removed. + * + * Assumption that LinkOriginal is a valid, existing junction. + * + * Returns: + * Zero on success. + * *-------------------------------------------------------------------- */ -int + +int TclWinSymLinkDelete(LinkOriginal, linkOnly) - CONST TCHAR* LinkOriginal; + CONST TCHAR *LinkOriginal; int linkOnly; { - /* It is a symbolic link -- remove it */ + /* + * It is a symbolic link - remove it. + */ + DUMMY_REPARSE_BUFFER dummy; - REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy; + REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy; HANDLE hFile; DWORD returnedLength; + memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER)); reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT; hFile = (*tclWinProcs->createFileProc)(LinkOriginal, GENERIC_WRITE, 0, - NULL, OPEN_EXISTING, - FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL); + NULL, OPEN_EXISTING, + FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL); + if (hFile != INVALID_HANDLE_VALUE) { - if (!DeviceIoControl(hFile, FSCTL_DELETE_REPARSE_POINT, reparseBuffer, - REPARSE_MOUNTPOINT_HEADER_SIZE, - NULL, 0, &returnedLength, NULL)) { - /* Error setting junction */ + if (!DeviceIoControl(hFile, FSCTL_DELETE_REPARSE_POINT, reparseBuffer, + REPARSE_MOUNTPOINT_HEADER_SIZE,NULL,0,&returnedLength,NULL)) { + /* + * Error setting junction. + */ + TclWinConvertError(GetLastError()); CloseHandle(hFile); } else { CloseHandle(hFile); if (!linkOnly) { - (*tclWinProcs->removeDirectoryProc)(LinkOriginal); + (*tclWinProcs->removeDirectoryProc)(LinkOriginal); } return 0; } } return -1; @@ -450,171 +534,200 @@ } /* *-------------------------------------------------------------------- * - * WinReadLinkDirectory - * - * This routine reads a NTFS junction, using the undocumented - * FSCTL_GET_REPARSE_POINT structure Win2K uses for mount points - * and junctions. - * - * Assumption that LinkDirectory is a valid, existing directory. - * - * Returns a Tcl_Obj with refCount of 1 (i.e. owned by the caller), - * or NULL if anything went wrong. - * - * In the future we should enhance this to return a path object - * rather than a string. + * WinReadLinkDirectory -- + * + * This routine reads a NTFS junction, using the undocumented + * FSCTL_GET_REPARSE_POINT structure Win2K uses for mount points and + * junctions. + * + * Assumption that LinkDirectory is a valid, existing directory. + * + * Returns: + * A Tcl_Obj with refCount of 1 (i.e. owned by the caller), or NULL if + * anything went wrong. + * + * In the future we should enhance this to return a path object rather + * than a string. + * *-------------------------------------------------------------------- */ -static Tcl_Obj* + +static Tcl_Obj* WinReadLinkDirectory(LinkDirectory) - CONST TCHAR* LinkDirectory; + CONST TCHAR *LinkDirectory; { int attr; DUMMY_REPARSE_BUFFER dummy; REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy; - + attr = (*tclWinProcs->getFileAttributesProc)(LinkDirectory); if (!(attr & FILE_ATTRIBUTE_REPARSE_POINT)) { Tcl_SetErrno(EINVAL); return NULL; } if (NativeReadReparse(LinkDirectory, reparseBuffer)) { - return NULL; - } - - switch (reparseBuffer->ReparseTag) { - case 0x80000000|IO_REPARSE_TAG_SYMBOLIC_LINK: - case IO_REPARSE_TAG_SYMBOLIC_LINK: - case IO_REPARSE_TAG_MOUNT_POINT: { - Tcl_Obj *retVal; - Tcl_DString ds; - CONST char *copy; - int len; - int offset = 0; - - /* - * Certain native path representations on Windows have a - * special prefix to indicate that they are to be treated - * specially. For example extremely long paths, or symlinks, - * or volumes mounted inside directories. - * - * There is an assumption in this code that 'wide' interfaces - * are being used (see tclWin32Dll.c), which is true for the - * only systems which support reparse tags at present. If - * that changes in the future, this code will have to be - * generalised. - */ - if (reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer[0] - == L'\\') { - /* Check whether this is a mounted volume */ - if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer, - L"\\??\\Volume{",11) == 0) { - char drive; - /* - * There is some confusion between \??\ and \\?\ which - * we have to fix here. It doesn't seem very well - * documented. - */ - reparseBuffer->SymbolicLinkReparseBuffer - .PathBuffer[1] = L'\\'; - /* - * Check if a corresponding drive letter exists, and - * use that if it is found - */ - drive = TclWinDriveLetterForVolMountPoint(reparseBuffer - ->SymbolicLinkReparseBuffer.PathBuffer); - if (drive != -1) { - char driveSpec[3] = { - '\0', ':', '\0' - }; - driveSpec[0] = drive; - retVal = Tcl_NewStringObj(driveSpec,2); - Tcl_IncrRefCount(retVal); - return retVal; - } - /* - * This is actually a mounted drive, which doesn't - * exists as a DOS drive letter. This means the path - * isn't actually a link, although we partially treat - * it like one ('file type' will return 'link'), but - * then the link will actually just be treated like - * an ordinary directory. I don't believe any - * serious inconsistency will arise from this, but it - * is something to be aware of. - */ - Tcl_SetErrno(EINVAL); - return NULL; - } else if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer - .PathBuffer, L"\\\\?\\",4) == 0) { - /* Strip off the prefix */ - offset = 4; - } else if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer - .PathBuffer, L"\\??\\",4) == 0) { - /* Strip off the prefix */ - offset = 4; - } - } - - Tcl_WinTCharToUtf( - (CONST char*)reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer, - (int)reparseBuffer->SymbolicLinkReparseBuffer - .SubstituteNameLength, &ds); - - copy = Tcl_DStringValue(&ds)+offset; - len = Tcl_DStringLength(&ds)-offset; - retVal = Tcl_NewStringObj(copy,len); - Tcl_IncrRefCount(retVal); - Tcl_DStringFree(&ds); - return retVal; - } - } - Tcl_SetErrno(EINVAL); - return NULL; -} - -/* - *-------------------------------------------------------------------- - * - * NativeReadReparse - * - * Read the junction/reparse information from a given NTFS directory. - * - * Assumption that LinkDirectory is a valid, existing directory. - * - * Returns zero on success. - *-------------------------------------------------------------------- - */ -static int -NativeReadReparse(LinkDirectory, buffer) - CONST TCHAR* LinkDirectory; /* The junction to read */ - REPARSE_DATA_BUFFER* buffer; /* Pointer to buffer. Cannot be NULL */ + return NULL; + } + + switch (reparseBuffer->ReparseTag) { + case 0x80000000|IO_REPARSE_TAG_SYMBOLIC_LINK: + case IO_REPARSE_TAG_SYMBOLIC_LINK: + case IO_REPARSE_TAG_MOUNT_POINT: { + Tcl_Obj *retVal; + Tcl_DString ds; + CONST char *copy; + int len; + int offset = 0; + + /* + * Certain native path representations on Windows have a special + * prefix to indicate that they are to be treated specially. For + * example extremely long paths, or symlinks, or volumes mounted + * inside directories. + * + * There is an assumption in this code that 'wide' interfaces are + * being used (see tclWin32Dll.c), which is true for the only systems + * which support reparse tags at present. If that changes in the + * future, this code will have to be generalised. + */ + + if (reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer[0] == L'\\') { + /* + * Check whether this is a mounted volume. + */ + + if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer, + L"\\??\\Volume{",11) == 0) { + char drive; + + /* + * There is some confusion between \??\ and \\?\ which we have + * to fix here. It doesn't seem very well documented. + */ + + reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer[1] = L'\\'; + + /* + * Check if a corresponding drive letter exists, and use that + * if it is found + */ + + drive = TclWinDriveLetterForVolMountPoint( + reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer); + if (drive != -1) { + char driveSpec[3] = { + '\0', ':', '\0' + }; + + driveSpec[0] = drive; + retVal = Tcl_NewStringObj(driveSpec,2); + Tcl_IncrRefCount(retVal); + return retVal; + } + + /* + * This is actually a mounted drive, which doesn't exists as a + * DOS drive letter. This means the path isn't actually a + * link, although we partially treat it like one ('file type' + * will return 'link'), but then the link will actually just + * be treated like an ordinary directory. I don't believe any + * serious inconsistency will arise from this, but it is + * something to be aware of. + */ + + Tcl_SetErrno(EINVAL); + return NULL; + + } else if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer + .PathBuffer, L"\\\\?\\",4) == 0) { + /* + * Strip off the prefix. + */ + + offset = 4; + } else if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer + .PathBuffer, L"\\??\\",4) == 0) { + /* + * Strip off the prefix. + */ + offset = 4; + } + } + + Tcl_WinTCharToUtf((CONST char*) + reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer, + (int) reparseBuffer->SymbolicLinkReparseBuffer + .SubstituteNameLength, &ds); + + copy = Tcl_DStringValue(&ds)+offset; + len = Tcl_DStringLength(&ds)-offset; + retVal = Tcl_NewStringObj(copy,len); + Tcl_IncrRefCount(retVal); + Tcl_DStringFree(&ds); + return retVal; + } + default: + Tcl_SetErrno(EINVAL); + return NULL; + } +} + +/* + *-------------------------------------------------------------------- + * + * NativeReadReparse -- + * + * Read the junction/reparse information from a given NTFS directory. + * + * Assumption that LinkDirectory is a valid, existing directory. + * + * Returns: + * Zero on success. + * + *-------------------------------------------------------------------- + */ + +static int +NativeReadReparse(LinkDirectory, buffer) + CONST TCHAR *LinkDirectory; /* The junction to read */ + REPARSE_DATA_BUFFER *buffer;/* Pointer to buffer. Cannot be NULL */ { HANDLE hFile; DWORD returnedLength; - + hFile = (*tclWinProcs->createFileProc)(LinkDirectory, GENERIC_READ, 0, - NULL, OPEN_EXISTING, - FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL); + NULL, OPEN_EXISTING, + FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL); + if (hFile == INVALID_HANDLE_VALUE) { - /* Error creating directory */ + /* + * Error creating directory. + */ + TclWinConvertError(GetLastError()); return -1; } - /* Get the link */ - if (!DeviceIoControl(hFile, FSCTL_GET_REPARSE_POINT, NULL, - 0, buffer, sizeof(DUMMY_REPARSE_BUFFER), - &returnedLength, NULL)) { - /* Error setting junction */ + + /* + * Get the link. + */ + + if (!DeviceIoControl(hFile, FSCTL_GET_REPARSE_POINT, NULL, 0, buffer, + sizeof(DUMMY_REPARSE_BUFFER), &returnedLength, NULL)) { + /* + * Error setting junction. + */ + TclWinConvertError(GetLastError()); CloseHandle(hFile); return -1; } CloseHandle(hFile); - + if (!IsReparseTagValid(buffer->ReparseTag)) { Tcl_SetErrno(EINVAL); return -1; } return 0; @@ -621,65 +734,86 @@ } /* *-------------------------------------------------------------------- * - * NativeWriteReparse + * NativeWriteReparse -- * - * Write the reparse information for a given directory. - * - * Assumption that LinkDirectory does not exist. + * Write the reparse information for a given directory. + * + * Assumption that LinkDirectory does not exist. + * *-------------------------------------------------------------------- */ -static int + +static int NativeWriteReparse(LinkDirectory, buffer) - CONST TCHAR* LinkDirectory; + CONST TCHAR *LinkDirectory; REPARSE_DATA_BUFFER* buffer; { HANDLE hFile; DWORD returnedLength; - - /* Create the directory - it must not already exist */ + + /* + * Create the directory - it must not already exist. + */ + if ((*tclWinProcs->createDirectoryProc)(LinkDirectory, NULL) == 0) { - /* Error creating directory */ + /* + * Error creating directory. + */ + TclWinConvertError(GetLastError()); return -1; } + hFile = (*tclWinProcs->createFileProc)(LinkDirectory, GENERIC_WRITE, 0, - NULL, OPEN_EXISTING, - FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL); + NULL, OPEN_EXISTING, + FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL); if (hFile == INVALID_HANDLE_VALUE) { - /* Error creating directory */ + /* + * Error creating directory. + */ TclWinConvertError(GetLastError()); return -1; } - /* Set the link */ - if (!DeviceIoControl(hFile, FSCTL_SET_REPARSE_POINT, buffer, - (DWORD) buffer->ReparseDataLength - + REPARSE_MOUNTPOINT_HEADER_SIZE, - NULL, 0, &returnedLength, NULL)) { - /* Error setting junction */ + + /* + * Set the link. + */ + + if (!DeviceIoControl(hFile, FSCTL_SET_REPARSE_POINT, buffer, + (DWORD) buffer->ReparseDataLength + REPARSE_MOUNTPOINT_HEADER_SIZE, + NULL, 0, &returnedLength, NULL)) { + /* + * Error setting junction. + */ + TclWinConvertError(GetLastError()); CloseHandle(hFile); (*tclWinProcs->removeDirectoryProc)(LinkDirectory); return -1; } CloseHandle(hFile); - /* We succeeded */ + + /* + * We succeeded. + */ + return 0; } /* *--------------------------------------------------------------------------- * * TclpFindExecutable -- * - * This procedure computes the absolute path name of the current + * This function computes the absolute path name of the current * application. * * Results: - * None. + * None. * * Side effects: * The computed path is stored. * *--------------------------------------------------------------------------- @@ -698,15 +832,18 @@ * create this process. */ if (GetModuleFileNameW(NULL, wName, MAX_PATH) == 0) { GetModuleFileNameA(NULL, name, sizeof(name)); + /* * Convert to WCHAR to get out of ANSI codepage */ + MultiByteToWideChar(CP_ACP, 0, name, -1, wName, MAX_PATH); } + WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL); TclWinNoBackslash(name); TclSetObjNameOfExecutable(Tcl_NewStringObj(name, -1), NULL); } @@ -713,51 +850,57 @@ /* *---------------------------------------------------------------------- * * TclpMatchInDirectory -- * - * This routine is used by the globbing code to search a - * directory for all files which match a given pattern. - * - * Results: - * - * The return value is a standard Tcl result indicating whether an - * error occurred in globbing. Errors are left in interp, good - * results are lappended to resultPtr (which must be a valid object) + * This routine is used by the globbing code to search a directory for + * all files which match a given pattern. + * + * Results: + * The return value is a standard Tcl result indicating whether an error + * occurred in globbing. Errors are left in interp, good results are + * lappended to resultPtr (which must be a valid object). * * Side effects: * None. * - *---------------------------------------------------------------------- */ + *---------------------------------------------------------------------- + */ int TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) Tcl_Interp *interp; /* Interpreter to receive errors. */ Tcl_Obj *resultPtr; /* List object to lappend results. */ - Tcl_Obj *pathPtr; /* Contains path to directory to search. */ + Tcl_Obj *pathPtr; /* Contains path to directory to search. */ CONST char *pattern; /* Pattern to match against. */ Tcl_GlobTypeData *types; /* Object containing list of acceptable types. * May be NULL. In particular the directory * flag is very important. */ { CONST TCHAR *native; if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) { - /* The native filesystem never adds mounts */ + /* + * The native filesystem never adds mounts. + */ + return TCL_OK; } if (pattern == NULL || (*pattern == '\0')) { Tcl_Obj *norm = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (norm != NULL) { - /* Match a single file directly */ + /* + * Match a single file directly. + */ + int len; DWORD attr; CONST char *str = Tcl_GetStringFromObj(norm,&len); - native = (CONST TCHAR*) Tcl_FSGetNativePath(pathPtr); - + native = (CONST TCHAR *) Tcl_FSGetNativePath(pathPtr); + if (tclWinProcs->getFileAttributesExProc == NULL) { attr = (*tclWinProcs->getFileAttributesProc)(native); if (attr == 0xffffffff) { return TCL_OK; } @@ -767,44 +910,44 @@ GetFileExInfoStandard, &data) != TRUE) { return TCL_OK; } attr = data.dwFileAttributes; } - if (NativeMatchType(WinIsDrive(str,len), attr, - native, types)) { + + if (NativeMatchType(WinIsDrive(str,len), attr, native, types)) { Tcl_ListObjAppendElement(interp, resultPtr, pathPtr); } } return TCL_OK; } else { DWORD attr; HANDLE handle; WIN32_FIND_DATAT data; - CONST char *dirName; /* utf-8 dir name, later - * with pattern appended */ + CONST char *dirName; /* UTF-8 dir name, later with pattern + * appended. */ int dirLength; int matchSpecialDots; - Tcl_DString ds; /* native encoding of dir, also used - * temporarily for other things. */ - Tcl_DString dsOrig; /* utf-8 encoding of dir */ + Tcl_DString ds; /* Native encoding of dir, also used + * temporarily for other things. */ + Tcl_DString dsOrig; /* UTF-8 encoding of dir. */ Tcl_Obj *fileNamePtr; char lastChar; /* - * Get the normalized path representation - * (the main thing is we dont want any '~' sequences). + * Get the normalized path representation (the main thing is we dont + * want any '~' sequences). */ fileNamePtr = Tcl_FSGetNormalizedPath(interp, pathPtr); if (fileNamePtr == NULL) { return TCL_ERROR; } /* - * Verify that the specified path exists and - * is actually a directory. + * Verify that the specified path exists and is actually a directory. */ + native = Tcl_FSGetNativePath(pathPtr); if (native == NULL) { return TCL_OK; } attr = (*tclWinProcs->getFileAttributesProc)(native); @@ -811,89 +954,97 @@ if ((attr == 0xffffffff) || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) { return TCL_OK; } - /* - * Build up the directory name for searching, including - * a trailing directory separator. + /* + * Build up the directory name for searching, including a trailing + * directory separator. */ Tcl_DStringInit(&dsOrig); dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength); Tcl_DStringAppend(&dsOrig, dirName, dirLength); - + lastChar = dirName[dirLength -1]; if ((lastChar != '\\') && (lastChar != '/') && (lastChar != ':')) { Tcl_DStringAppend(&dsOrig, "/", 1); dirLength++; } dirName = Tcl_DStringValue(&dsOrig); /* - * We need to check all files in the directory, so we append - * '*.*' to the path, unless the pattern we've been given is - * rather simple, when we can use that instead. + * We need to check all files in the directory, so we append '*.*' to + * the path, unless the pattern we've been given is rather simple, + * when we can use that instead. */ if (strpbrk(pattern, "[]\\") == NULL) { - /* + /* * The pattern is a simple one containing just '*' and/or '?'. - * This means we can get the OS to help us, by passing - * it the pattern. + * This means we can get the OS to help us, by passing it the + * pattern. */ + dirName = Tcl_DStringAppend(&dsOrig, pattern, -1); } else { dirName = Tcl_DStringAppend(&dsOrig, "*.*", 3); } + native = Tcl_WinUtfToTChar(dirName, -1, &ds); - if (tclWinProcs->findFirstFileExProc == NULL - || (types == NULL) - || (types->type != TCL_GLOB_TYPE_DIR)) { + if (tclWinProcs->findFirstFileExProc == NULL || (types == NULL) + || (types->type != TCL_GLOB_TYPE_DIR)) { handle = (*tclWinProcs->findFirstFileProc)(native, &data); } else { - /* We can be more efficient, for pure directory requests */ - handle = (*tclWinProcs->findFirstFileExProc)(native, - FindExInfoStandard, &data, - FindExSearchLimitToDirectories, NULL, 0); + /* + * We can be more efficient, for pure directory requests. + */ + + handle = (*tclWinProcs->findFirstFileExProc)(native, + FindExInfoStandard, &data, + FindExSearchLimitToDirectories, NULL, 0); } if (handle == INVALID_HANDLE_VALUE) { DWORD err = GetLastError(); Tcl_DStringFree(&ds); if (err == ERROR_FILE_NOT_FOUND) { - /* - * We used our 'pattern' above, and matched nothing - * This means we just return TCL_OK, indicating - * no results found. - */ + /* + * We used our 'pattern' above, and matched nothing. This + * means we just return TCL_OK, indicating no results found. + */ + Tcl_DStringFree(&dsOrig); return TCL_OK; } + TclWinConvertError(err); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't read directory \"", - Tcl_DStringValue(&dsOrig), "\": ", - Tcl_PosixError(interp), (char *) NULL); + if (interp != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't read directory \"", + Tcl_DStringValue(&dsOrig), "\": ", + Tcl_PosixError(interp), (char *) NULL); + } Tcl_DStringFree(&dsOrig); return TCL_ERROR; } Tcl_DStringFree(&ds); - /* - * We may use this later, so we must restore it to its - * length including the directory delimiter + /* + * We may use this later, so we must restore it to its length + * including the directory delimiter. */ + Tcl_DStringSetLength(&dsOrig, dirLength); /* - * Check to see if the pattern should match the special - * . and .. names, referring to the current directory, - * or the directory above. We need a special check for - * this because paths beginning with a dot are not considered - * hidden on Windows, and so otherwise a relative glob like - * 'glob -join * *' will actually return './. ../..' etc. + * Check to see if the pattern should match the special . and + * .. names, referring to the current directory, or the directory + * above. We need a special check for this because paths beginning + * with a dot are not considered hidden on Windows, and so otherwise a + * relative glob like 'glob -join * *' will actually return + * './. ../..' etc. */ if ((pattern[0] == '.') || ((pattern[0] == '\\') && (pattern[1] == '.'))) { matchSpecialDots = 1; @@ -900,55 +1051,58 @@ } else { matchSpecialDots = 0; } /* - * Now iterate over all of the files in the directory, starting - * with the first one we found. + * Now iterate over all of the files in the directory, starting with + * the first one we found. */ do { CONST char *utfname; int checkDrive = 0; int isDrive; DWORD attr; - + if (tclWinProcs->useWide) { native = (CONST TCHAR *) data.w.cFileName; attr = data.w.dwFileAttributes; } else { native = (CONST TCHAR *) data.a.cFileName; attr = data.a.dwFileAttributes; } - + utfname = Tcl_WinTCharToUtf(native, -1, &ds); if (!matchSpecialDots) { - /* If it is exactly '.' or '..' then we ignore it */ - if ((utfname[0] == '.') && (utfname[1] == '\0' + /* + * If it is exactly '.' or '..' then we ignore it. + */ + + if ((utfname[0] == '.') && (utfname[1] == '\0' || (utfname[1] == '.' && utfname[2] == '\0'))) { Tcl_DStringFree(&ds); continue; } } else if (utfname[0] == '.' && utfname[1] == '.' && utfname[2] == '\0') { - /* - * Have to check if this is a drive below, so we can - * correctly match 'hidden' and not hidden files. + /* + * Have to check if this is a drive below, so we can correctly + * match 'hidden' and not hidden files. */ + checkDrive = 1; } - + /* - * Check to see if the file matches the pattern. Note that - * we are ignoring the case sensitivity flag because Windows - * doesn't honor case even if the volume is case sensitive. - * If the volume also doesn't preserve case, then we - * previously returned the lower case form of the name. This - * didn't seem quite right since there are - * non-case-preserving volumes that actually return mixed - * case. So now we are returning exactly what we get from + * Check to see if the file matches the pattern. Note that we are + * ignoring the case sensitivity flag because Windows doesn't + * honor case even if the volume is case sensitive. If the volume + * also doesn't preserve case, then we previously returned the + * lower case form of the name. This didn't seem quite right since + * there are non-case-preserving volumes that actually return + * mixed case. So now we are returning exactly what we get from * the system. */ if (Tcl_StringCaseMatch(utfname, pattern, 1)) { /* @@ -963,179 +1117,254 @@ Tcl_DStringSetLength(&dsOrig, dirLength); } else { isDrive = 0; } if (NativeMatchType(isDrive, attr, native, types)) { - Tcl_ListObjAppendElement(interp, resultPtr, + Tcl_ListObjAppendElement(interp, resultPtr, TclNewFSPathObj(pathPtr, utfname, Tcl_DStringLength(&ds))); } } /* * Free ds here to ensure that native is valid above. */ + Tcl_DStringFree(&ds); } while ((*tclWinProcs->findNextFileProc)(handle, &data) == TRUE); FindClose(handle); Tcl_DStringFree(&dsOrig); return TCL_OK; } } -/* - * Does the given path represent a root volume? We need this special - * case because for NTFS root volumes, the getFileAttributesProc returns - * a 'hidden' attribute when it should not. +/* + * Does the given path represent a root volume? We need this special case + * because for NTFS root volumes, the getFileAttributesProc returns a 'hidden' + * attribute when it should not. */ + static int WinIsDrive( - CONST char *name, /* Name (UTF-8) */ - int len) /* Length of name */ + CONST char *name, /* Name (UTF-8) */ + int len) /* Length of name */ { int remove = 0; while (len > 4) { - if ((name[len-1] != '.' || name[len-2] != '.') - || (name[len-3] != '/' && name[len-3] != '\\')) { - /* We don't have '/..' at the end */ + if ((name[len-1] != '.' || name[len-2] != '.') + || (name[len-3] != '/' && name[len-3] != '\\')) { + /* + * We don't have '/..' at the end. + */ + if (remove == 0) { - break; + break; } remove--; while (len > 0) { len--; if (name[len] == '/' || name[len] == '\\') { break; } } if (len < 4) { - len++; + len++; break; } - } else { - /* We do have '/..' */ + } else { + /* + * We do have '/..' + */ + len -= 3; remove++; - } + } } + if (len < 4) { if (len == 0) { - /* - * Not sure if this is possible, but we pass it on - * anyway + /* + * Not sure if this is possible, but we pass it on anyway. */ } else if (len == 1 && (name[0] == '/' || name[0] == '\\')) { - /* Path is pointing to the root volume */ + /* + * Path is pointing to the root volume. + */ + return 1; - } else if ((name[1] == ':') + } else if ((name[1] == ':') && (len == 2 || (name[2] == '/' || name[2] == '\\'))) { - /* Path is of the form 'x:' or 'x:/' or 'x:\' */ + /* + * Path is of the form 'x:' or 'x:/' or 'x:\' + */ + return 1; } } + + return 0; +} + +/* + * Does the given path represent a reserved window path name? If not return 0, + * if true, return the number of characters of the path that we actually want + * (not any trailing :). + */ + +static int WinIsReserved( + CONST char *path) /* Path in UTF-8 */ +{ + if ((path[0] == 'c' || path[0] == 'C') + && (path[1] == 'o' || path[1] == 'O')) { + if ((path[2] == 'm' || path[2] == 'M') + && path[3] >= '1' && path[3] <= '4') { + /* + * May have match for 'com[1-4]:?', which is a serial port. + */ + + if (path[4] == '\0') { + return 4; + } else if (path [4] == ':' && path[5] == '\0') { + return 4; + } + } else if ((path[2] == 'n' || path[2] == 'N') && path[3] == '\0') { + /* + * Have match for 'con' + */ + + return 3; + } + + } else if ((path[0] == 'l' || path[0] == 'L') + && (path[1] == 'p' || path[1] == 'P') + && (path[2] == 't' || path[2] == 'T')) { + if (path[3] >= '1' && path[3] <= '3') { + /* + * May have match for 'lpt[1-3]:?' + */ + + if (path[4] == '\0') { + return 4; + } else if (path [4] == ':' && path[5] == '\0') { + return 4; + } + } + + } else if (!stricmp(path, "prn") || !stricmp(path, "nul") + || !stricmp(path, "aux")) { + /* + * Have match for 'prn', 'nul' or 'aux'. + */ + + return 3; + } return 0; } /* *---------------------------------------------------------------------- - * + * * NativeMatchType -- - * - * This function needs a special case for a path which is a root - * volume, because for NTFS root volumes, the getFileAttributesProc - * returns a 'hidden' attribute when it should not. - * - * We never make any calss to a 'get attributes' routine here, - * since we have arranged things so that our caller already knows - * such information. - * + * + * This function needs a special case for a path which is a root volume, + * because for NTFS root volumes, the getFileAttributesProc returns a + * 'hidden' attribute when it should not. + * + * We never make any calss to a 'get attributes' routine here, since we + * have arranged things so that our caller already knows such + * information. + * * Results: - * 0 = file doesn't match - * 1 = file matches - * + * 0 = file doesn't match + * 1 = file matches + * *---------------------------------------------------------------------- */ -static int + +static int NativeMatchType( - int isDrive, /* Is this a drive */ - DWORD attr, /* We already know the attributes - * for the file */ - CONST TCHAR* nativeName, /* Native path to check */ - Tcl_GlobTypeData *types) /* Type description to match against */ + int isDrive, /* Is this a drive. */ + DWORD attr, /* We already know the attributes for the + * file. */ + CONST TCHAR *nativeName, /* Native path to check. */ + Tcl_GlobTypeData *types) /* Type description to match against. */ { /* - * 'attr' represents the attributes of the file, but we only - * want to retrieve this info if it is absolutely necessary - * because it is an expensive call. Unfortunately, to deal - * with hidden files properly, we must always retrieve it. + * 'attr' represents the attributes of the file, but we only want to + * retrieve this info if it is absolutely necessary because it is an + * expensive call. Unfortunately, to deal with hidden files properly, we + * must always retrieve it. */ if (types == NULL) { - /* If invisible, don't return the file */ + /* + * If invisible, don't return the file. + */ if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) { return 0; } } else { if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) { - /* If invisible */ - if ((types->perm == 0) || - !(types->perm & TCL_GLOB_PERM_HIDDEN)) { + /* + * If invisible. + */ + + if ((types->perm == 0) || !(types->perm & TCL_GLOB_PERM_HIDDEN)) { return 0; } } else { - /* Visible */ + /* + * Visible. + */ if (types->perm & TCL_GLOB_PERM_HIDDEN) { return 0; } } - + if (types->perm != 0) { - if ( - ((types->perm & TCL_GLOB_PERM_RONLY) && + if (((types->perm & TCL_GLOB_PERM_RONLY) && !(attr & FILE_ATTRIBUTE_READONLY)) || - ((types->perm & TCL_GLOB_PERM_R) && + ((types->perm & TCL_GLOB_PERM_R) && (0 /* File exists => R_OK on Windows */)) || - ((types->perm & TCL_GLOB_PERM_W) && + ((types->perm & TCL_GLOB_PERM_W) && (attr & FILE_ATTRIBUTE_READONLY)) || - ((types->perm & TCL_GLOB_PERM_X) && + ((types->perm & TCL_GLOB_PERM_X) && (!(attr & FILE_ATTRIBUTE_DIRECTORY) - && !NativeIsExec(nativeName))) - ) { + && !NativeIsExec(nativeName)))) { return 0; } } - if ((types->type & TCL_GLOB_TYPE_DIR) - && (attr & FILE_ATTRIBUTE_DIRECTORY)) { - /* Quicker test for directory, which is a common case */ + if ((types->type & TCL_GLOB_TYPE_DIR) + && (attr & FILE_ATTRIBUTE_DIRECTORY)) { + /* + * Quicker test for directory, which is a common case. + */ + return 1; + } else if (types->type != 0) { unsigned short st_mode; int isExec = NativeIsExec(nativeName); - + st_mode = NativeStatMode(attr, 0, isExec); /* * In order bcdpfls as in 'find -t' */ - if ( - ((types->type & TCL_GLOB_TYPE_BLOCK) && - S_ISBLK(st_mode)) || - ((types->type & TCL_GLOB_TYPE_CHAR) && - S_ISCHR(st_mode)) || - ((types->type & TCL_GLOB_TYPE_DIR) && - S_ISDIR(st_mode)) || - ((types->type & TCL_GLOB_TYPE_PIPE) && - S_ISFIFO(st_mode)) || - ((types->type & TCL_GLOB_TYPE_FILE) && - S_ISREG(st_mode)) + + if (((types->type&TCL_GLOB_TYPE_BLOCK) && S_ISBLK(st_mode)) || + ((types->type&TCL_GLOB_TYPE_CHAR) && S_ISCHR(st_mode)) || + ((types->type&TCL_GLOB_TYPE_DIR) && S_ISDIR(st_mode)) || + ((types->type&TCL_GLOB_TYPE_PIPE) && S_ISFIFO(st_mode)) || #ifdef S_ISSOCK - || ((types->type & TCL_GLOB_TYPE_SOCK) && - S_ISSOCK(st_mode)) + ((types->type&TCL_GLOB_TYPE_SOCK) && S_ISSOCK(st_mode)) || #endif - ) { - /* Do nothing -- this file is ok */ + ((types->type&TCL_GLOB_TYPE_FILE) && S_ISREG(st_mode))) { + /* + * Do nothing - this file is ok. + */ } else { #ifdef S_ISLNK if (types->type & TCL_GLOB_TYPE_LINK) { st_mode = NativeStatMode(attr, 1, isExec); if (S_ISLNK(st_mode)) { @@ -1143,12 +1372,12 @@ } } #endif return 0; } - } - } + } + } return 1; } /* *---------------------------------------------------------------------- @@ -1159,13 +1388,13 @@ * corresponding home directory specified in the password file. * * Results: * The result is a pointer to a string specifying the user's home * directory, or NULL if the user's home directory could not be - * determined. Storage for the result string is allocated in - * bufferPtr; the caller must call Tcl_DStringFree() when the result - * is no longer needed. + * determined. Storage for the result string is allocated in bufferPtr; + * the caller must call Tcl_DStringFree() when the result is no longer + * needed. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -1190,13 +1419,13 @@ NETGETDCNAMEPROC *netGetDCNameProc; NETUSERGETINFOPROC *netUserGetInfoProc; netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *) GetProcAddress(netapiInst, "NetApiBufferFree"); - netGetDCNameProc = (NETGETDCNAMEPROC *) + netGetDCNameProc = (NETGETDCNAMEPROC *) GetProcAddress(netapiInst, "NetGetDCName"); - netUserGetInfoProc = (NETUSERGETINFOPROC *) + netUserGetInfoProc = (NETUSERGETINFOPROC *) GetProcAddress(netapiInst, "NetUserGetInfo"); if ((netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL) && (netApiBufferFreeProc != NULL)) { USER_INFO_1 *uiPtr; Tcl_DString ds; @@ -1225,12 +1454,12 @@ wHomeDir = uiPtr->usri1_home_dir; if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) { Tcl_UniCharToUtfDString(wHomeDir, lstrlenW(wHomeDir), bufferPtr); } else { - /* - * User exists but has no home dir. Return + /* + * User exists but has no home dir. Return * "{Windows Drive}:/users/default". */ GetWindowsDirectoryW(buf, MAX_PATH); Tcl_UniCharToUtfDString(buf, 2, bufferPtr); @@ -1247,24 +1476,24 @@ } FreeLibrary(netapiInst); } if (result == NULL) { /* - * Look in the "Password Lists" section of system.ini for the - * local user. There are also entries in that section that begin - * with a "*" character that are used by Windows for other - * purposes; ignore user names beginning with a "*". + * Look in the "Password Lists" section of system.ini for the local + * user. There are also entries in that section that begin with a "*" + * character that are used by Windows for other purposes; ignore user + * names beginning with a "*". */ char buf[MAX_PATH]; if (name[0] != '*') { - if (GetPrivateProfileStringA("Password Lists", name, "", buf, + if (GetPrivateProfileStringA("Password Lists", name, "", buf, MAX_PATH, "system.ini") > 0) { - /* - * User exists, but there is no such thing as a home - * directory in system.ini. Return "{Windows drive}:/". + /* + * User exists, but there is no such thing as a home directory + * in system.ini. Return "{Windows drive}:/". */ GetWindowsDirectoryA(buf, MAX_PATH); Tcl_DStringAppend(bufferPtr, buf, 3); result = Tcl_DStringValue(bufferPtr); @@ -1280,11 +1509,11 @@ * * NativeAccess -- * * This function replaces the library version of access(), fixing the * following bugs: - * + * * 1. access() returns that all files have execute permission. * * Results: * See access documentation. * @@ -1294,21 +1523,20 @@ *--------------------------------------------------------------------------- */ static int NativeAccess(nativePath, mode) - CONST TCHAR *nativePath; /* Path of file to access, native - * encoding. */ + CONST TCHAR *nativePath; /* Path of file to access, native encoding. */ int mode; /* Permission setting. */ { DWORD attr; attr = (*tclWinProcs->getFileAttributesProc)(nativePath); if (attr == 0xffffffff) { /* - * File doesn't exist. + * File doesn't exist. */ TclWinConvertError(GetLastError()); return -1; } @@ -1315,38 +1543,38 @@ if ((mode & W_OK) && (attr & FILE_ATTRIBUTE_READONLY)) { /* * File is not writable. */ + Tcl_SetErrno(EACCES); return -1; } if (mode & X_OK) { if (!(attr & FILE_ATTRIBUTE_DIRECTORY) && !NativeIsExec(nativePath)) { /* - * It's not a directory and doesn't have the correct - * extension. Therefore it can't be executable + * It's not a directory and doesn't have the correct extension. + * Therefore it can't be executable */ + Tcl_SetErrno(EACCES); return -1; } } - /* - * It looks as if the permissions are ok, but if we are on NT, 2000 - * or XP, we have a more complex permissions structure so we try to - * check that. The code below is remarkably complex for such a - * simple thing as finding what permissions the OS has set for a - * file. - * - * If we are simply checking for file existence, then we don't - * need all these complications (which are really quite slow: - * with this code 'file readable' is 5-6 times slower than 'file - * exists'). + /* + * It looks as if the permissions are ok, but if we are on NT, 2000 or XP, + * we have a more complex permissions structure so we try to check that. + * The code below is remarkably complex for such a simple thing as finding + * what permissions the OS has set for a file. + * + * If we are simply checking for file existence, then we don't need all + * these complications (which are really quite slow: with this code 'file + * readable' is 5-6 times slower than 'file exists'). */ - + if ((mode != F_OK) && (tclWinProcs->getFileSecurityProc != NULL)) { SECURITY_DESCRIPTOR *sdPtr = NULL; unsigned long size; GENERIC_MAPPING genMap; HANDLE hToken = NULL; @@ -1354,78 +1582,84 @@ DWORD grantedAccess; BOOL accessYesNo; PRIVILEGE_SET privSet; DWORD privSetSize = sizeof(PRIVILEGE_SET); int error; - - /* - * First find out how big the buffer needs to be + + /* + * First find out how big the buffer needs to be */ + size = 0; - (*tclWinProcs->getFileSecurityProc)(nativePath, - OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION + (*tclWinProcs->getFileSecurityProc)(nativePath, + OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION, 0, 0, &size); - /* - * Should have failed with ERROR_INSUFFICIENT_BUFFER + /* + * Should have failed with ERROR_INSUFFICIENT_BUFFER */ + error = GetLastError(); if (error != ERROR_INSUFFICIENT_BUFFER) { - /* - * Most likely case is ERROR_ACCESS_DENIED, which - * we will convert to EACCES - just what we want! + /* + * Most likely case is ERROR_ACCESS_DENIED, which we will convert + * to EACCES - just what we want! */ + TclWinConvertError(error); return -1; } - /* - * Now size contains the size of buffer needed + /* + * Now size contains the size of buffer needed */ + sdPtr = (SECURITY_DESCRIPTOR *) HeapAlloc(GetProcessHeap(), 0, size); if (sdPtr == NULL) { goto accessError; } - /* - * Call GetFileSecurity() for real + /* + * Call GetFileSecurity() for real */ - if (!(*tclWinProcs->getFileSecurityProc)(nativePath, - OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION + + if (!(*tclWinProcs->getFileSecurityProc)(nativePath, + OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION, sdPtr, size, &size)) { - /* + /* * Error getting owner SD */ goto accessError; } - /* + /* * Perform security impersonation of the user and open the * resulting thread token. */ if (!(*tclWinProcs->impersonateSelfProc)(SecurityImpersonation)) { - /* - * Unable to perform security impersonation. + /* + * Unable to perform security impersonation. */ goto accessError; } - if (!(*tclWinProcs->openThreadTokenProc)(GetCurrentThread (), + if (!(*tclWinProcs->openThreadTokenProc)(GetCurrentThread (), TOKEN_DUPLICATE | TOKEN_QUERY, FALSE, &hToken)) { - /* - * Unable to get current thread's token. + /* + * Unable to get current thread's token. */ goto accessError; } (*tclWinProcs->revertToSelfProc)(); - + memset (&genMap, 0x00, sizeof (GENERIC_MAPPING)); - - /* - * Setup desiredAccess according to the access priveleges we - * are checking. + + /* + * Setup desiredAccess according to the access priveleges we are + * checking. */ + genMap.GenericAll = 0; if (mode & R_OK) { desiredAccess |= FILE_GENERIC_READ; } if (mode & W_OK) { @@ -1433,32 +1667,36 @@ } if (mode & X_OK) { desiredAccess |= FILE_GENERIC_EXECUTE; } - /* - * Perform access check using the token. + /* + * Perform access check using the token. */ - if (!(*tclWinProcs->accessCheckProc )(sdPtr, hToken, desiredAccess, + + if (!(*tclWinProcs->accessCheckProc)(sdPtr, hToken, desiredAccess, &genMap, &privSet, &privSetSize, &grantedAccess, &accessYesNo)) { - /* - * Unable to perform access check. + /* + * Unable to perform access check. */ - accessError: + + accessError: TclWinConvertError(GetLastError()); if (sdPtr != NULL) { - HeapFree(GetProcessHeap(), 0, sdPtr); + HeapFree(GetProcessHeap(), 0, sdPtr); } if (hToken != NULL) { - CloseHandle(hToken); + CloseHandle(hToken); } return -1; } - /* - * Clean up. + + /* + * Clean up. */ + HeapFree(GetProcessHeap (), 0, sdPtr); CloseHandle(hToken); if (!accessYesNo) { Tcl_SetErrno(EACCES); return -1; @@ -1470,58 +1708,63 @@ /* *---------------------------------------------------------------------- * * NativeIsExec -- * - * Determines if a path is executable. On windows this is - * simply defined by whether the path ends in any of ".exe", - * ".com", or ".bat" + * Determines if a path is executable. On windows this is simply defined + * by whether the path ends in any of ".exe", ".com", or ".bat" * * Results: * 1 = executable, 0 = not. * *---------------------------------------------------------------------- */ + static int NativeIsExec(nativePath) CONST TCHAR *nativePath; { if (tclWinProcs->useWide) { CONST WCHAR *path; int len; - + path = (CONST WCHAR*)nativePath; len = wcslen(path); - + if (len < 5) { return 0; } - + if (path[len-4] != L'.') { return 0; } - + /* * Use wide-char case-insensitive comparison */ + if ((_wcsicmp(path+len-3,L"exe") == 0) - || (_wcsicmp(path+len-3,L"com") == 0) - || (_wcsicmp(path+len-3,L"bat") == 0)) { + || (_wcsicmp(path+len-3,L"com") == 0) + || (_wcsicmp(path+len-3,L"bat") == 0)) { return 1; } } else { CONST char *p; - - /* We are only looking for pure ascii */ - + + /* + * We are only looking for pure ascii. + */ + p = strrchr((CONST char*)nativePath, '.'); if (p != NULL) { p++; - /* + + /* * Note: in the old code, stat considered '.pif' files as * executable, whereas access did not. */ + if ((stricmp(p, "exe") == 0) || (stricmp(p, "com") == 0) || (stricmp(p, "bat") == 0)) { /* * File that ends with .exe, .com, or .bat is executable. @@ -1543,32 +1786,35 @@ * * Results: * See chdir() documentation. * * Side effects: - * See chdir() documentation. + * See chdir() documentation. * *---------------------------------------------------------------------- */ -int +int TclpObjChdir(pathPtr) - Tcl_Obj *pathPtr; /* Path to new working directory. */ + Tcl_Obj *pathPtr; /* Path to new working directory. */ { int result; CONST TCHAR *nativePath; #ifdef __CYGWIN__ - extern int cygwin_conv_to_posix_path - _ANSI_ARGS_((CONST char *, char *)); + extern int cygwin_conv_to_posix_path(CONST char *, char *); char posixPath[MAX_PATH+1]; CONST char *path; Tcl_DString ds; #endif /* __CYGWIN__ */ nativePath = (CONST TCHAR *) Tcl_FSGetNativePath(pathPtr); + #ifdef __CYGWIN__ - /* Cygwin chdir only groks POSIX path. */ + /* + * Cygwin chdir only groks POSIX path. + */ + path = Tcl_WinTCharToUtf(nativePath, -1, &ds); cygwin_conv_to_posix_path(path, posixPath); result = (chdir(posixPath) == 0 ? 1 : 0); Tcl_DStringFree(&ds); #else /* __CYGWIN__ */ @@ -1586,40 +1832,40 @@ /* *--------------------------------------------------------------------------- * * TclpReadlink -- * - * This function replaces the library version of readlink(). + * This function replaces the library version of readlink(). * * Results: - * The result is a pointer to a string specifying the contents - * of the symbolic link given by 'path', or NULL if the symbolic - * link could not be read. Storage for the result string is - * allocated in bufferPtr; the caller must call Tcl_DStringFree() - * when the result is no longer needed. + * The result is a pointer to a string specifying the contents of the + * symbolic link given by 'path', or NULL if the symbolic link could not + * be read. Storage for the result string is allocated in bufferPtr; the + * caller must call Tcl_DStringFree() when the result is no longer + * needed. * * Side effects: - * See readlink() documentation. + * See readlink() documentation. * *--------------------------------------------------------------------------- */ char * TclpReadlink(path, linkPtr) - CONST char *path; /* Path of file to readlink (UTF-8). */ - Tcl_DString *linkPtr; /* Uninitialized or free DString filled - * with contents of link (UTF-8). */ + CONST char *path; /* Path of file to readlink (UTF-8). */ + Tcl_DString *linkPtr; /* Uninitialized or free DString filled with + * contents of link (UTF-8). */ { char link[MAXPATHLEN]; int length; char *native; Tcl_DString ds; native = Tcl_UtfToExternalDString(NULL, path, -1, &ds); - length = readlink(native, link, sizeof(link)); /* INTL: Native. */ + length = readlink(native, link, sizeof(link)); /* INTL: Native. */ Tcl_DStringFree(&ds); - + if (length < 0) { return NULL; } Tcl_ExternalToUtfDString(NULL, link, length, linkPtr); @@ -1630,21 +1876,20 @@ /* *---------------------------------------------------------------------- * * TclpGetCwd -- * - * This function replaces the library version of getcwd(). - * (Obsolete function, only retained for old extensions which - * may call it directly). + * This function replaces the library version of getcwd(). (Obsolete + * function, only retained for old extensions which may call it + * directly). * * Results: - * The result is a pointer to a string specifying the current - * directory, or NULL if the current directory could not be - * determined. If NULL is returned, an error message is left in the - * interp's result. Storage for the result string is allocated in - * bufferPtr; the caller must call Tcl_DStringFree() when the result - * is no longer needed. + * The result is a pointer to a string specifying the current directory, + * or NULL if the current directory could not be determined. If NULL is + * returned, an error message is left in the interp's result. Storage for + * the result string is allocated in bufferPtr; the caller must call + * Tcl_DStringFree() when the result is no longer needed. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -1651,21 +1896,20 @@ */ CONST char * TclpGetCwd(interp, bufferPtr) Tcl_Interp *interp; /* If non-NULL, used for error reporting. */ - Tcl_DString *bufferPtr; /* Uninitialized or free DString filled - * with name of current directory. */ + Tcl_DString *bufferPtr; /* Uninitialized or free DString filled with + * name of current directory. */ { WCHAR buffer[MAX_PATH]; char *p; if ((*tclWinProcs->getCurrentDirectoryProc)(MAX_PATH, buffer) == 0) { TclWinConvertError(GetLastError()); if (interp != NULL) { - Tcl_AppendResult(interp, - "error getting working directory name: ", + Tcl_AppendResult(interp, "error getting working directory name: ", Tcl_PosixError(interp), (char *) NULL); } return NULL; } @@ -1675,48 +1919,49 @@ if (tclWinProcs->useWide) { WCHAR *native; native = (WCHAR *) buffer; - if ((native[0] != '\0') && (native[1] == ':') + if ((native[0] != '\0') && (native[1] == ':') && (native[2] == '\\') && (native[3] == '\\')) { native += 2; } Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr); } else { char *native; native = (char *) buffer; - if ((native[0] != '\0') && (native[1] == ':') + if ((native[0] != '\0') && (native[1] == ':') && (native[2] == '\\') && (native[3] == '\\')) { native += 2; } Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr); } /* * Convert to forward slashes for easier use in scripts. */ - + for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) { if (*p == '\\') { *p = '/'; } } return Tcl_DStringValue(bufferPtr); } -int +int TclpObjStat(pathPtr, statPtr) - Tcl_Obj *pathPtr; /* Path of file to stat */ - Tcl_StatBuf *statPtr; /* Filled with results of stat call. */ + Tcl_Obj *pathPtr; /* Path of file to stat. */ + Tcl_StatBuf *statPtr; /* Filled with results of stat call. */ { #ifdef OLD_API Tcl_Obj *transPtr; + /* - * Eliminate file names containing wildcard characters, or subsequent - * call to FindFirstFile() will expand them, matching some other file. + * Eliminate file names containing wildcard characters, or subsequent call + * to FindFirstFile() will expand them, matching some other file. */ transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); if (transPtr == NULL || (strpbrk(Tcl_GetString(transPtr), "?*") != NULL)) { if (transPtr != NULL) { @@ -1725,29 +1970,29 @@ Tcl_SetErrno(ENOENT); return -1; } Tcl_DecrRefCount(transPtr); #endif - + /* - * Ensure correct file sizes by forcing the OS to write any - * pending data to disk. This is done only for channels which are - * dirty, i.e. have been written to since the last flush here. + * Ensure correct file sizes by forcing the OS to write any pending data + * to disk. This is done only for channels which are dirty, i.e. have been + * written to since the last flush here. */ - TclWinFlushDirtyChannels (); + TclWinFlushDirtyChannels(); return NativeStat((CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), statPtr, 0); } /* *---------------------------------------------------------------------- * * NativeStat -- * - * This function replaces the library version of stat(), fixing - * the following bugs: + * This function replaces the library version of stat(), fixing the + * following bugs: * * 1. stat("c:") returns an error. * 2. Borland stat() return time in GMT instead of localtime. * 3. stat("\\server\mount") would return error. * 4. Accepts slashes or backslashes. @@ -1760,35 +2005,36 @@ * See stat documentation. * *---------------------------------------------------------------------- */ -static int +static int NativeStat(nativePath, statPtr, checkLinks) - CONST TCHAR *nativePath; /* Path of file to stat */ - Tcl_StatBuf *statPtr; /* Filled with results of stat call. */ - int checkLinks; /* If non-zero, behave like 'lstat' */ + CONST TCHAR *nativePath; /* Path of file to stat */ + Tcl_StatBuf *statPtr; /* Filled with results of stat call. */ + int checkLinks; /* If non-zero, behave like 'lstat' */ { Tcl_DString ds; DWORD attr; WCHAR nativeFullPath[MAX_PATH]; TCHAR *nativePart; CONST char *fullPath; int dev; unsigned short mode; - + if (tclWinProcs->getFileAttributesExProc == NULL) { - /* - * We don't have the faster attributes proc, so we're - * probably running on Win95 - */ + /* + * We don't have the faster attributes proc, so we're probably running + * on Win95. + */ + WIN32_FIND_DATAT data; HANDLE handle; handle = (*tclWinProcs->findFirstFileProc)(nativePath, &data); if (handle == INVALID_HANDLE_VALUE) { - /* + /* * FindFirstFile() doesn't work on root directories, so call * GetFileAttributes() to see if the specified file exists. */ attr = (*tclWinProcs->getFileAttributesProc)(nativePath); @@ -1795,24 +2041,23 @@ if (attr == 0xffffffff) { Tcl_SetErrno(ENOENT); return -1; } - /* - * Make up some fake information for this file. It has the - * correct file attributes and a time of 0. + /* + * Make up some fake information for this file. It has the correct + * file attributes and a time of 0. */ memset(&data, 0, sizeof(data)); data.a.dwFileAttributes = attr; } else { FindClose(handle); } - - (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH, nativeFullPath, - &nativePart); + (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH, + nativeFullPath, &nativePart); fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds); dev = -1; if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) { @@ -1823,11 +2068,11 @@ p = strchr(fullPath + 2, '\\'); p = strchr(p + 1, '\\'); if (p == NULL) { /* - * Add terminating backslash to fullpath or + * Add terminating backslash to fullpath or * GetVolumeInformation() won't work. */ fullPath = Tcl_DStringAppend(&ds, "\\", 1); p = fullPath + Tcl_DStringLength(&ds); @@ -1836,44 +2081,44 @@ } nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString); dw = (DWORD) -1; (*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw, NULL, NULL, NULL, 0); + /* * GetFullPathName() turns special devices like "NUL" into * "\\.\NUL", but GetVolumeInformation() returns failure for - * "\\.\NUL". This will cause "NUL" to get a drive number of - * -1, which makes about as much sense as anything since the - * special devices don't live on any drive. + * "\\.\NUL". This will cause "NUL" to get a drive number of -1, + * which makes about as much sense as anything since the special + * devices don't live on any drive. */ dev = dw; Tcl_DStringFree(&volString); } else if ((fullPath[0] != '\0') && (fullPath[1] == ':')) { dev = Tcl_UniCharToLower(fullPath[0]) - 'a'; } Tcl_DStringFree(&ds); - + attr = data.a.dwFileAttributes; - statPtr->st_size = ((Tcl_WideInt)data.a.nFileSizeLow) | + statPtr->st_size = ((Tcl_WideInt)data.a.nFileSizeLow) | (((Tcl_WideInt)data.a.nFileSizeHigh) << 32); statPtr->st_atime = ToCTime(data.a.ftLastAccessTime); statPtr->st_mtime = ToCTime(data.a.ftLastWriteTime); statPtr->st_ctime = ToCTime(data.a.ftCreationTime); } else { WIN32_FILE_ATTRIBUTE_DATA data; - if((*tclWinProcs->getFileAttributesExProc)(nativePath, - GetFileExInfoStandard, - &data) != TRUE) { + + if ((*tclWinProcs->getFileAttributesExProc)(nativePath, + GetFileExInfoStandard, &data) != TRUE) { Tcl_SetErrno(ENOENT); return -1; } - - (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH, - nativeFullPath, &nativePart); + (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH, + nativeFullPath, &nativePart); fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds); dev = -1; if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) { @@ -1884,11 +2129,11 @@ p = strchr(fullPath + 2, '\\'); p = strchr(p + 1, '\\'); if (p == NULL) { /* - * Add terminating backslash to fullpath or + * Add terminating backslash to fullpath or * GetVolumeInformation() won't work. */ fullPath = Tcl_DStringAppend(&ds, "\\", 1); p = fullPath + Tcl_DStringLength(&ds); @@ -1897,36 +2142,37 @@ } nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString); dw = (DWORD) -1; (*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw, NULL, NULL, NULL, 0); + /* * GetFullPathName() turns special devices like "NUL" into * "\\.\NUL", but GetVolumeInformation() returns failure for - * "\\.\NUL". This will cause "NUL" to get a drive number of - * -1, which makes about as much sense as anything since the - * special devices don't live on any drive. + * "\\.\NUL". This will cause "NUL" to get a drive number of -1, + * which makes about as much sense as anything since the special + * devices don't live on any drive. */ dev = dw; Tcl_DStringFree(&volString); } else if ((fullPath[0] != '\0') && (fullPath[1] == ':')) { dev = Tcl_UniCharToLower(fullPath[0]) - 'a'; } Tcl_DStringFree(&ds); - + attr = data.dwFileAttributes; - - statPtr->st_size = ((Tcl_WideInt)data.nFileSizeLow) | + + statPtr->st_size = ((Tcl_WideInt)data.nFileSizeLow) | (((Tcl_WideInt)data.nFileSizeHigh) << 32); statPtr->st_atime = ToCTime(data.ftLastAccessTime); statPtr->st_mtime = ToCTime(data.ftLastWriteTime); statPtr->st_ctime = ToCTime(data.ftCreationTime); } mode = NativeStatMode(attr, checkLinks, NativeIsExec(nativePath)); - + statPtr->st_dev = (dev_t) dev; statPtr->st_ino = 0; statPtr->st_mode = mode; statPtr->st_nlink = 1; statPtr->st_uid = 0; @@ -1939,35 +2185,37 @@ *---------------------------------------------------------------------- * * NativeStatMode -- * * Calculate just the 'st_mode' field of a 'stat' structure. - * - * In many places we don't need the full stat structure, and - * it's much faster just to calculate these pieces, if that's - * all we need. + * + * In many places we don't need the full stat structure, and it's much + * faster just to calculate these pieces, if that's all we need. * *---------------------------------------------------------------------- */ + static unsigned short -NativeStatMode(DWORD attr, int checkLinks, int isExec) +NativeStatMode(DWORD attr, int checkLinks, int isExec) { int mode; if (checkLinks && (attr & FILE_ATTRIBUTE_REPARSE_POINT)) { - /* It is a link */ + /* + * It is a link. + */ mode = S_IFLNK; } else { - mode = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR | S_IEXEC : S_IFREG; + mode = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR | S_IEXEC : S_IFREG; } mode |= (attr & FILE_ATTRIBUTE_READONLY) ? S_IREAD : S_IREAD | S_IWRITE; if (isExec) { mode |= S_IEXEC; } - + /* - * Propagate the S_IREAD, S_IWRITE, S_IEXEC bits to the group and - * other positions. + * Propagate the S_IREAD, S_IWRITE, S_IEXEC bits to the group and other + * positions. */ mode |= (mode & 0x0700) >> 3; mode |= (mode & 0x0700) >> 6; return (unsigned short)mode; @@ -1988,17 +2236,17 @@ static time_t ToCTime(FILETIME fileTime) /* UTC time */ { LARGE_INTEGER convertedTime; + convertedTime.LowPart = fileTime.dwLowDateTime; convertedTime.HighPart = (LONG) fileTime.dwHighDateTime; + return (time_t) ((convertedTime.QuadPart - - (Tcl_WideInt) POSIX_EPOCH_AS_FILETIME) - / (Tcl_WideInt) 10000000); + - (Tcl_WideInt) POSIX_EPOCH_AS_FILETIME) / (Tcl_WideInt) 10000000); } - /* *------------------------------------------------------------------------ * * FromCTime -- @@ -2010,58 +2258,59 @@ * *------------------------------------------------------------------------ */ static void -FromCTime(time_t posixTime, - FILETIME* fileTime) /* UTC Time */ +FromCTime( + time_t posixTime, + FILETIME* fileTime) /* UTC Time */ { LARGE_INTEGER convertedTime; - convertedTime.QuadPart = ((LONGLONG) posixTime) * 10000000 + convertedTime.QuadPart = ((LONGLONG) posixTime) * 10000000 + POSIX_EPOCH_AS_FILETIME; fileTime->dwLowDateTime = convertedTime.LowPart; fileTime->dwHighDateTime = convertedTime.HighPart; } - + #if 0 /* *------------------------------------------------------------------------- * * TclWinResolveShortcut -- * - * Resolve a potential Windows shortcut to get the actual file or - * directory in question. + * Resolve a potential Windows shortcut to get the actual file or + * directory in question. * * Results: - * Returns 1 if the shortcut could be resolved, or 0 if there was - * an error or if the filename was not a shortcut. - * If bufferPtr did hold the name of a shortcut, it is modified to - * hold the resolved target of the shortcut instead. + * Returns 1 if the shortcut could be resolved, or 0 if there was an + * error or if the filename was not a shortcut. If bufferPtr did hold the + * name of a shortcut, it is modified to hold the resolved target of the + * shortcut instead. * * Side effects: - * Loads and unloads OLE package to determine if filename refers to - * a shortcut. + * Loads and unloads OLE package to determine if filename refers to a + * shortcut. * *------------------------------------------------------------------------- */ int TclWinResolveShortcut(bufferPtr) - Tcl_DString *bufferPtr; /* Holds name of file to resolve. On - * return, holds resolved file name. */ + Tcl_DString *bufferPtr; /* Holds name of file to resolve. On return, + * holds resolved file name. */ { - HRESULT hres; - IShellLink *psl; - IPersistFile *ppf; - WIN32_FIND_DATA wfd; + HRESULT hres; + IShellLink *psl; + IPersistFile *ppf; + WIN32_FIND_DATA wfd; WCHAR wpath[MAX_PATH]; char *path, *ext; char realFileName[MAX_PATH]; /* - * Windows system calls do not automatically resolve - * shortcuts like UNIX automatically will with symbolic links. + * Windows system calls do not automatically resolve shortcuts like UNIX + * automatically will with symbolic links. */ path = Tcl_DStringValue(bufferPtr); ext = strrchr(path, '.'); if ((ext == NULL) || (stricmp(ext, ".lnk") != 0)) { @@ -2069,29 +2318,28 @@ } CoInitialize(NULL); path = Tcl_DStringValue(bufferPtr); realFileName[0] = '\0'; - hres = CoCreateInstance(&CLSID_ShellLink, NULL, CLSCTX_INPROC_SERVER, - &IID_IShellLink, &psl); - if (SUCCEEDED(hres)) { - hres = psl->lpVtbl->QueryInterface(psl, &IID_IPersistFile, &ppf); - if (SUCCEEDED(hres)) { - MultiByteToWideChar(CP_ACP, 0, path, -1, wpath, sizeof(wpath)); - hres = ppf->lpVtbl->Load(ppf, wpath, STGM_READ); - if (SUCCEEDED(hres)) { - hres = psl->lpVtbl->Resolve(psl, NULL, - SLR_ANY_MATCH | SLR_NO_UI); - if (SUCCEEDED(hres)) { - hres = psl->lpVtbl->GetPath(psl, realFileName, MAX_PATH, - &wfd, 0); - } - } - ppf->lpVtbl->Release(ppf); - } - psl->lpVtbl->Release(psl); - } + hres = CoCreateInstance(&CLSID_ShellLink, NULL, CLSCTX_INPROC_SERVER, + &IID_IShellLink, &psl); + if (SUCCEEDED(hres)) { + hres = psl->lpVtbl->QueryInterface(psl, &IID_IPersistFile, &ppf); + if (SUCCEEDED(hres)) { + MultiByteToWideChar(CP_ACP, 0, path, -1, wpath, sizeof(wpath)); + hres = ppf->lpVtbl->Load(ppf, wpath, STGM_READ); + if (SUCCEEDED(hres)) { + hres = psl->lpVtbl->Resolve(psl,NULL,SLR_ANY_MATCH|SLR_NO_UI); + if (SUCCEEDED(hres)) { + hres = psl->lpVtbl->GetPath(psl, realFileName, MAX_PATH, + &wfd, 0); + } + } + ppf->lpVtbl->Release(ppf); + } + psl->lpVtbl->Release(psl); + } CoUninitialize(); if (realFileName[0] != '\0') { Tcl_DStringSetLength(bufferPtr, 0); Tcl_DStringAppend(bufferPtr, realFileName, -1); @@ -2107,17 +2355,16 @@ * TclpGetNativeCwd -- * * This function replaces the library version of getcwd(). * * Results: - * The input and output are filesystem paths in native form. The - * result is either the given clientData, if the working directory - * hasn't changed, or a new clientData (owned by our caller), - * giving the new native path, or NULL if the current directory - * could not be determined. If NULL is returned, the caller can - * examine the standard posix error codes to determine the cause of - * the problem. + * The input and output are filesystem paths in native form. The result + * is either the given clientData, if the working directory hasn't + * changed, or a new clientData (owned by our caller), giving the new + * native path, or NULL if the current directory could not be determined. + * If NULL is returned, the caller can examine the standard posix error + * codes to determine the cause of the problem. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -2126,75 +2373,80 @@ ClientData TclpGetNativeCwd(clientData) ClientData clientData; { WCHAR buffer[MAX_PATH]; - + if ((*tclWinProcs->getCurrentDirectoryProc)(MAX_PATH, buffer) == 0) { TclWinConvertError(GetLastError()); return NULL; } if (clientData != NULL) { - if (tclWinProcs->useWide) { - /* unicode representation when running on NT/2K/XP */ - if (wcscmp((CONST WCHAR*)clientData, - (CONST WCHAR*)buffer) == 0) { + if (tclWinProcs->useWide) { + /* + * Unicode representation when running on NT/2K/XP. + */ + + if (wcscmp((CONST WCHAR*)clientData, (CONST WCHAR*)buffer) == 0) { return clientData; } } else { - /* ansi representation when running on 95/98/ME */ - if (strcmp((CONST char*)clientData, - (CONST char*)buffer) == 0) { + /* + * ANSI representation when running on 95/98/ME. + */ + + if (strcmp((CONST char*)clientData, (CONST char*)buffer) == 0) { return clientData; } } } - + return TclNativeDupInternalRep((ClientData)buffer); } - -int + +int TclpObjAccess(pathPtr, mode) Tcl_Obj *pathPtr; int mode; { - return NativeAccess((CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), mode); + return NativeAccess((CONST TCHAR *) Tcl_FSGetNativePath(pathPtr), mode); } - -int + +int TclpObjLstat(pathPtr, statPtr) Tcl_Obj *pathPtr; - Tcl_StatBuf *statPtr; + Tcl_StatBuf *statPtr; { /* - * Ensure correct file sizes by forcing the OS to write any - * pending data to disk. This is done only for channels which are - * dirty, i.e. have been written to since the last flush here. + * Ensure correct file sizes by forcing the OS to write any pending data + * to disk. This is done only for channels which are dirty, i.e. have been + * written to since the last flush here. */ TclWinFlushDirtyChannels (); return NativeStat((CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), statPtr, 1); } - + #ifdef S_IFLNK - -Tcl_Obj* +Tcl_Obj* TclpObjLink(pathPtr, toPtr, linkAction) Tcl_Obj *pathPtr; Tcl_Obj *toPtr; int linkAction; { if (toPtr != NULL) { int res; #if 0 - TCHAR* LinkTarget = (TCHAR*)Tcl_FSGetNativePath(toPtr); + TCHAR *LinkTarget = (TCHAR *) Tcl_FSGetNativePath(toPtr); #else - TCHAR* LinkTarget = (TCHAR*)Tcl_FSGetNativePath(Tcl_FSGetNormalizedPath(NULL,toPtr)); + TCHAR *LinkTarget = (TCHAR *) Tcl_FSGetNativePath( + Tcl_FSGetNormalizedPath(NULL, toPtr)); #endif - TCHAR* LinkSource = (TCHAR*)Tcl_FSGetNativePath(pathPtr); + TCHAR *LinkSource = (TCHAR *) Tcl_FSGetNativePath(pathPtr); + if (LinkSource == NULL || LinkTarget == NULL) { return NULL; } res = WinLink(LinkSource, LinkTarget, linkAction); if (res == 0) { @@ -2201,112 +2453,118 @@ return toPtr; } else { return NULL; } } else { - TCHAR* LinkSource = (TCHAR*)Tcl_FSGetNativePath(pathPtr); + TCHAR *LinkSource = (TCHAR *) Tcl_FSGetNativePath(pathPtr); + if (LinkSource == NULL) { return NULL; } return WinReadLink(LinkSource); } } - #endif - /* *--------------------------------------------------------------------------- * * TclpFilesystemPathType -- * - * This function is part of the native filesystem support, and - * returns the path type of the given path. Returns NTFS or FAT - * or whatever is returned by the 'volume information' proc. + * This function is part of the native filesystem support, and returns + * the path type of the given path. Returns NTFS or FAT or whatever is + * returned by the 'volume information' proc. * * Results: - * NULL at present. + * NULL at present. * * Side effects: * None. * *--------------------------------------------------------------------------- */ + Tcl_Obj* TclpFilesystemPathType(pathPtr) Tcl_Obj* pathPtr; { #define VOL_BUF_SIZE 32 int found; - char volType[VOL_BUF_SIZE]; + WCHAR volType[VOL_BUF_SIZE]; char* firstSeparator; CONST char *path; - Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); - if (normPath == NULL) return NULL; + + if (normPath == NULL) { + return NULL; + } path = Tcl_GetString(normPath); - if (path == NULL) return NULL; - + if (path == NULL) { + return NULL; + } + firstSeparator = strchr(path, '/'); if (firstSeparator == NULL) { found = tclWinProcs->getVolumeInformationProc( - Tcl_FSGetNativePath(pathPtr), NULL, 0, NULL, NULL, - NULL, (WCHAR *)volType, VOL_BUF_SIZE); + Tcl_FSGetNativePath(pathPtr), NULL, 0, NULL, NULL, NULL, + (WCHAR *) volType, VOL_BUF_SIZE); } else { Tcl_Obj *driveName = Tcl_NewStringObj(path, firstSeparator - path+1); + Tcl_IncrRefCount(driveName); found = tclWinProcs->getVolumeInformationProc( - Tcl_FSGetNativePath(driveName), NULL, 0, NULL, NULL, - NULL, (WCHAR *)volType, VOL_BUF_SIZE); + Tcl_FSGetNativePath(driveName), NULL, 0, NULL, NULL, NULL, + (WCHAR *) volType, VOL_BUF_SIZE); Tcl_DecrRefCount(driveName); } if (found == 0) { return NULL; } else { Tcl_DString ds; Tcl_Obj *objPtr; - - Tcl_WinTCharToUtf(volType, -1, &ds); - objPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),Tcl_DStringLength(&ds)); + + Tcl_WinTCharToUtf((CONST char *)volType, -1, &ds); + objPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); return objPtr; } #undef VOL_BUF_SIZE } -/* + +/* * This define can be turned on to experiment with a different way of - * normalizing paths (using a different Windows API). Unfortunately the - * new path seems to take almost exactly the same amount of time as the - * old path! The primary time taken by normalization is in - * GetFileAttributesEx/FindFirstFile or - * GetFileAttributesEx/GetLongPathName. Conversion to/from native is - * not a significant factor at all. - * - * Also, since we have to check for symbolic links (reparse points) - * then we have to call GetFileAttributes on each path segment anyway, - * so there's no benefit to doing anything clever there. + * normalizing paths (using a different Windows API). Unfortunately the new + * path seems to take almost exactly the same amount of time as the old path! + * The primary time taken by normalization is in + * GetFileAttributesEx/FindFirstFile or GetFileAttributesEx/GetLongPathName. + * Conversion to/from native is not a significant factor at all. + * + * Also, since we have to check for symbolic links (reparse points) then we + * have to call GetFileAttributes on each path segment anyway, so there's no + * benefit to doing anything clever there. */ + /* #define TclNORM_LONG_PATH */ /* *--------------------------------------------------------------------------- * * TclpObjNormalizePath -- * - * This function scans through a path specification and replaces it, - * in place, with a normalized version. This means using the - * 'longname', and expanding any symbolic links contained within the - * path. + * This function scans through a path specification and replaces it, in + * place, with a normalized version. This means using the 'longname', and + * expanding any symbolic links contained within the path. * * Results: - * The new 'nextCheckpoint' value, giving as far as we could - * understand in the path. + * The new 'nextCheckpoint' value, giving as far as we could understand + * in the path. * * Side effects: - * The pathPtr string, which must contain a valid path, is - * possibly modified in place. + * The pathPtr string, which must contain a valid path, is possibly + * modified in place. * *--------------------------------------------------------------------------- */ int TclpObjNormalizePath(interp, pathPtr, nextCheckpoint) @@ -2313,59 +2571,84 @@ Tcl_Interp *interp; Tcl_Obj *pathPtr; int nextCheckpoint; { char *lastValidPathEnd = NULL; - /* This will hold the normalized string */ - Tcl_DString dsNorm; + Tcl_DString dsNorm; /* This will hold the normalized string. */ char *path; char *currentPathEndPosition; Tcl_DStringInit(&dsNorm); path = Tcl_GetString(pathPtr); if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS) { - /* - * We're on Win95, 98 or ME. There are two assumptions - * in this block of code. First that the native (NULL) - * encoding is basically ascii, and second that symbolic - * links are not possible. Both of these assumptions - * appear to be true of these operating systems. + /* + * We're on Win95, 98 or ME. There are two assumptions in this block + * of code. First that the native (NULL) encoding is basically ascii, + * and second that symbolic links are not possible. Both of these + * assumptions appear to be true of these operating systems. */ + int isDrive = 1; Tcl_DString ds; currentPathEndPosition = path + nextCheckpoint; - if (*currentPathEndPosition == '/') { + if (*currentPathEndPosition == '/') { currentPathEndPosition++; - } + } + while (1) { char cur = *currentPathEndPosition; if ((cur == '/' || cur == 0) && (path != currentPathEndPosition)) { - /* Reached directory separator, or end of string */ - CONST char *nativePath = Tcl_UtfToExternalDString(NULL, path, - currentPathEndPosition - path, &ds); + /* + * Reached directory separator, or end of string. + */ + + CONST char *nativePath = Tcl_UtfToExternalDString(NULL, path, + currentPathEndPosition - path, &ds); /* - * Now we convert the tail of the current path to its - * 'long form', and append it to 'dsNorm' which holds - * the current normalized path, if the file exists. + * Now we convert the tail of the current path to its 'long + * form', and append it to 'dsNorm' which holds the current + * normalized path, if the file exists. */ + if (isDrive) { - if (GetFileAttributesA(nativePath) - == 0xffffffff) { - /* File doesn't exist */ + if (GetFileAttributesA(nativePath) == 0xffffffff) { + /* + * File doesn't exist. + */ + + if (isDrive) { + int len = WinIsReserved(path); + if (len > 0) { + /* + * Actually it does exist - COM1, etc. + */ + + int i; + + for (i=0;i= 'a') { + ((char*)nativePath)[i] -= ('a' - 'A'); + } + } + Tcl_DStringAppend(&dsNorm, nativePath, len); + lastValidPathEnd = currentPathEndPosition; + } + } Tcl_DStringFree(&ds); break; } if (nativePath[0] >= 'a') { ((char*)nativePath)[0] -= ('a' - 'A'); } - Tcl_DStringAppend(&dsNorm,nativePath,Tcl_DStringLength(&ds)); + Tcl_DStringAppend(&dsNorm, nativePath, + Tcl_DStringLength(&ds)); } else { char *checkDots = NULL; - + if (lastValidPathEnd[1] == '.') { checkDots = lastValidPathEnd + 1; while (checkDots < currentPathEndPosition) { if (*checkDots != '.') { checkDots = NULL; @@ -2374,37 +2657,49 @@ checkDots++; } } if (checkDots != NULL) { int dotLen = currentPathEndPosition - lastValidPathEnd; - /* - * Path is just dots. We shouldn't really - * ever see a path like that. However, to be - * nice we at least don't mangle the path -- - * we just add the dots as a path segment and - * continue + + /* + * Path is just dots. We shouldn't really ever see a + * path like that. However, to be nice we at least + * don't mangle the path - we just add the dots as a + * path segment and continue */ - Tcl_DStringAppend(&dsNorm, (TCHAR*)(nativePath - + Tcl_DStringLength(&ds) - - dotLen), dotLen); + + Tcl_DStringAppend(&dsNorm, (TCHAR *) + (nativePath + Tcl_DStringLength(&ds) - dotLen), + dotLen); } else { - /* Normal path */ + /* + * Normal path. + */ + WIN32_FIND_DATA fData; HANDLE handle; - + handle = FindFirstFileA(nativePath, &fData); if (handle == INVALID_HANDLE_VALUE) { - if (GetFileAttributesA(nativePath) - == 0xffffffff) { - /* File doesn't exist */ + if (GetFileAttributesA(nativePath) == 0xffffffff) { + /* + * File doesn't exist. + */ + Tcl_DStringFree(&ds); break; } - /* This is usually the '/' in 'c:/' at end of string */ + + /* + * This is usually the '/' in 'c:/' at end of + * string. + */ + Tcl_DStringAppend(&dsNorm,"/", 1); } else { char *nativeName; + if (fData.cFileName[0] != '\0') { nativeName = fData.cFileName; } else { nativeName = fData.cAlternateFileName; } @@ -2417,107 +2712,150 @@ Tcl_DStringFree(&ds); lastValidPathEnd = currentPathEndPosition; if (cur == 0) { break; } - /* - * If we get here, we've got past one directory - * delimiter, so we know it is no longer a drive + /* + * If we get here, we've got past one directory delimiter, so + * we know it is no longer a drive. */ isDrive = 0; } currentPathEndPosition++; } } else { - /* We're on WinNT or 2000 or XP */ + /* + * We're on WinNT (or 2000 or XP; something with an NT core). + */ + Tcl_Obj *temp = NULL; int isDrive = 1; Tcl_DString ds; - + currentPathEndPosition = path + nextCheckpoint; if (*currentPathEndPosition == '/') { currentPathEndPosition++; } while (1) { char cur = *currentPathEndPosition; if ((cur == '/' || cur == 0) && (path != currentPathEndPosition)) { - /* Reached directory separator, or end of string */ + /* + * Reached directory separator, or end of string. + */ + WIN32_FILE_ATTRIBUTE_DATA data; - CONST char *nativePath = Tcl_WinUtfToTChar(path, - currentPathEndPosition - path, &ds); + CONST char *nativePath = Tcl_WinUtfToTChar(path, + currentPathEndPosition - path, &ds); + if ((*tclWinProcs->getFileAttributesExProc)(nativePath, - GetFileExInfoStandard, &data) != TRUE) { - /* File doesn't exist */ + GetFileExInfoStandard, &data) != TRUE) { + /* + * File doesn't exist. + */ + + if (isDrive) { + int len = WinIsReserved(path); + + if (len > 0) { + /* + * Actually it does exist - COM1, etc. + */ + + int i; + + for (i=0;i= L'a') { + wc -= (L'a' - L'A'); + ((WCHAR*)nativePath)[i] = wc; + } + } + Tcl_DStringAppend(&dsNorm, nativePath, + sizeof(WCHAR)*len); + lastValidPathEnd = currentPathEndPosition; + } + } Tcl_DStringFree(&ds); break; } - /* - * File 'nativePath' does exist if we get here. We - * now want to check if it is a symlink and otherwise - * continue with the rest of the path. + /* + * File 'nativePath' does exist if we get here. We now want to + * check if it is a symlink and otherwise continue with the + * rest of the path. */ - - /* - * Check for symlinks, except at last component - * of path (we don't follow final symlinks). Also - * a drive (C:/) for example, may sometimes have - * the reparse flag set for some reason I don't - * understand. We therefore don't perform this + + /* + * Check for symlinks, except at last component of path (we + * don't follow final symlinks). Also a drive (C:/) for + * example, may sometimes have the reparse flag set for some + * reason I don't understand. We therefore don't perform this * check for drives. */ - if (cur != 0 && !isDrive - && (data.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT)) { + + if (cur != 0 && !isDrive && + (data.dwFileAttributes&FILE_ATTRIBUTE_REPARSE_POINT)) { Tcl_Obj *to = WinReadLinkDirectory(nativePath); + if (to != NULL) { - /* - * Read the reparse point ok. Now, reparse - * points need not be normalized, otherwise - * we could use: - * - * Tcl_GetStringFromObj(to, &pathLen); + /* + * Read the reparse point ok. Now, reparse points need + * not be normalized, otherwise we could use: + * + * Tcl_GetStringFromObj(to, &pathLen); * nextCheckpoint = pathLen - * - * So, instead we have to start from the - * beginning. + * + * So, instead we have to start from the beginning. */ + nextCheckpoint = 0; Tcl_AppendToObj(to, currentPathEndPosition, -1); - /* Convert link to forward slashes */ + + /* + * Convert link to forward slashes. + */ + for (path = Tcl_GetString(to); *path != 0; path++) { if (*path == '\\') *path = '/'; } path = Tcl_GetString(to); currentPathEndPosition = path + nextCheckpoint; if (temp != NULL) { Tcl_DecrRefCount(temp); } temp = to; - /* Reset variables so we can restart normalization */ + + /* + * Reset variables so we can restart normalization. + */ + isDrive = 1; Tcl_DStringFree(&dsNorm); Tcl_DStringInit(&dsNorm); Tcl_DStringFree(&ds); continue; } } + #ifndef TclNORM_LONG_PATH /* - * Now we convert the tail of the current path to its - * 'long form', and append it to 'dsNorm' which holds - * the current normalized path + * Now we convert the tail of the current path to its 'long + * form', and append it to 'dsNorm' which holds the current + * normalized path */ + if (isDrive) { WCHAR drive = ((WCHAR*)nativePath)[0]; if (drive >= L'a') { - drive -= (L'a' - L'A'); + drive -= (L'a' - L'A'); ((WCHAR*)nativePath)[0] = drive; } - Tcl_DStringAppend(&dsNorm,nativePath,Tcl_DStringLength(&ds)); + Tcl_DStringAppend(&dsNorm, nativePath, + Tcl_DStringLength(&ds)); } else { char *checkDots = NULL; - + if (lastValidPathEnd[1] == '.') { checkDots = lastValidPathEnd + 1; while (checkDots < currentPathEndPosition) { if (*checkDots != '.') { checkDots = NULL; @@ -2526,110 +2864,135 @@ checkDots++; } } if (checkDots != NULL) { int dotLen = currentPathEndPosition - lastValidPathEnd; - /* - * Path is just dots. We shouldn't really - * ever see a path like that. However, to be - * nice we at least don't mangle the path -- - * we just add the dots as a path segment and - * continue + + /* + * Path is just dots. We shouldn't really ever see a + * path like that. However, to be nice we at least + * don't mangle the path - we just add the dots as a + * path segment and continue. */ - Tcl_DStringAppend(&dsNorm, - (TCHAR*)((WCHAR*)(nativePath - + Tcl_DStringLength(&ds)) - - dotLen), - (int)(dotLen * sizeof(WCHAR))); + + Tcl_DStringAppend(&dsNorm, (TCHAR *) + ((WCHAR*)(nativePath + Tcl_DStringLength(&ds)) + - dotLen), (int)(dotLen * sizeof(WCHAR))); } else { - /* Normal path */ + /* + * Normal path. + */ + WIN32_FIND_DATAW fData; HANDLE handle; handle = FindFirstFileW((WCHAR*)nativePath, &fData); if (handle == INVALID_HANDLE_VALUE) { - /* This is usually the '/' in 'c:/' at end of string */ - Tcl_DStringAppend(&dsNorm,(CONST char*)L"/", - sizeof(WCHAR)); + /* + * This is usually the '/' in 'c:/' at end of + * string. + */ + + Tcl_DStringAppend(&dsNorm,(CONST char*)L"/", + sizeof(WCHAR)); } else { WCHAR *nativeName; + if (fData.cFileName[0] != '\0') { nativeName = fData.cFileName; } else { nativeName = fData.cAlternateFileName; } FindClose(handle); - Tcl_DStringAppend(&dsNorm,(CONST char*)L"/", - sizeof(WCHAR)); - Tcl_DStringAppend(&dsNorm,(TCHAR*)nativeName, - (int) (wcslen(nativeName)*sizeof(WCHAR))); + Tcl_DStringAppend(&dsNorm, (CONST char*)L"/", + sizeof(WCHAR)); + Tcl_DStringAppend(&dsNorm, (TCHAR *) nativeName, + (int) (wcslen(nativeName)*sizeof(WCHAR))); } } } #endif Tcl_DStringFree(&ds); lastValidPathEnd = currentPathEndPosition; if (cur == 0) { break; } - /* - * If we get here, we've got past one directory - * delimiter, so we know it is no longer a drive + + /* + * If we get here, we've got past one directory delimiter, so + * we know it is no longer a drive. */ + isDrive = 0; } currentPathEndPosition++; } + #ifdef TclNORM_LONG_PATH - /* + /* * Convert the entire known path to long form. */ + if (1) { WCHAR wpath[MAX_PATH]; - DWORD wpathlen; - CONST char *nativePath = Tcl_WinUtfToTChar(path, - lastValidPathEnd - path, &ds); - wpathlen = (*tclWinProcs->getLongPathNameProc)(nativePath, - (TCHAR*)wpath, - MAX_PATH); - /* We have to make the drive letter uppercase */ + CONST char *nativePath = + Tcl_WinUtfToTChar(path, lastValidPathEnd - path, &ds); + DWORD wpathlen = (*tclWinProcs->getLongPathNameProc)( + nativePath, (TCHAR *) wpath, MAX_PATH); + + /* + * We have to make the drive letter uppercase. + */ + if (wpath[0] >= L'a') { wpath[0] -= (L'a' - L'A'); } Tcl_DStringAppend(&dsNorm, (TCHAR*)wpath, wpathlen*sizeof(WCHAR)); Tcl_DStringFree(&ds); } #endif } - /* Common code path for all Windows platforms */ + + /* + * Common code path for all Windows platforms. + */ + nextCheckpoint = currentPathEndPosition - path; if (lastValidPathEnd != NULL) { - /* - * Concatenate the normalized string in dsNorm with the - * tail of the path which we didn't recognise. The - * string in dsNorm is in the native encoding, so we - * have to convert it to Utf. + /* + * Concatenate the normalized string in dsNorm with the tail of the + * path which we didn't recognise. The string in dsNorm is in the + * native encoding, so we have to convert it to Utf. */ + Tcl_DString dsTemp; - Tcl_WinTCharToUtf(Tcl_DStringValue(&dsNorm), - Tcl_DStringLength(&dsNorm), &dsTemp); + + Tcl_WinTCharToUtf(Tcl_DStringValue(&dsNorm), + Tcl_DStringLength(&dsNorm), &dsTemp); nextCheckpoint = Tcl_DStringLength(&dsTemp); if (*lastValidPathEnd != 0) { - /* Not the end of the string */ + /* + * Not the end of the string. + */ + int len; char *path; Tcl_Obj *tmpPathPtr; - tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp), - nextCheckpoint); + + tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp), + nextCheckpoint); Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, -1); path = Tcl_GetStringFromObj(tmpPathPtr, &len); Tcl_SetStringObj(pathPtr, path, len); Tcl_DecrRefCount(tmpPathPtr); } else { - /* End of string was reached above */ + /* + * End of string was reached above. + */ + Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&dsTemp), - nextCheckpoint); + nextCheckpoint); } Tcl_DStringFree(&dsTemp); } Tcl_DStringFree(&dsNorm); return nextCheckpoint; @@ -2638,98 +3001,101 @@ /* *--------------------------------------------------------------------------- * * TclWinVolumeRelativeNormalize -- * - * Only Windows has volume-relative paths. These paths are rather - * rare, but it is nice if Tcl can handle them. It is much better - * if we can handle them here, rather than in the native fs code, - * because we really need to have a real absolute path just below. - * - * We do not let this block compile on non-Windows platforms - * because the test suite's manual forcing of tclPlatform can - * otherwise cause this code path to be executed, causing various - * errors because volume-relative paths really do not exist. + * Only Windows has volume-relative paths. These paths are rather rare, + * but it is nice if Tcl can handle them. It is much better if we can + * handle them here, rather than in the native fs code, because we really + * need to have a real absolute path just below. + * + * We do not let this block compile on non-Windows platforms because the + * test suite's manual forcing of tclPlatform can otherwise cause this + * code path to be executed, causing various errors because + * volume-relative paths really do not exist. * * Results: - * A valid normalized path. + * A valid normalized path. * * Side effects: * None. * *--------------------------------------------------------------------------- */ + Tcl_Obj* TclWinVolumeRelativeNormalize(interp, path, useThisCwdPtr) Tcl_Interp *interp; CONST char *path; Tcl_Obj **useThisCwdPtr; { Tcl_Obj *absolutePath, *useThisCwd; - + useThisCwd = Tcl_FSGetCwd(interp); if (useThisCwd == NULL) { - return NULL; + return NULL; } - + if (path[0] == '/') { - /* - * Path of form /foo/bar which is a path in the - * root directory of the current volume. + /* + * Path of form /foo/bar which is a path in the root directory of the + * current volume. */ + CONST char *drive = Tcl_GetString(useThisCwd); - + absolutePath = Tcl_NewStringObj(drive,2); Tcl_AppendToObj(absolutePath, path, -1); Tcl_IncrRefCount(absolutePath); - /* We have a refCount on the cwd */ + + /* + * We have a refCount on the cwd. + */ } else { - /* - * Path of form C:foo/bar, but this only makes - * sense if the cwd is also on drive C. + /* + * Path of form C:foo/bar, but this only makes sense if the cwd is + * also on drive C. */ - + int cwdLen; - CONST char *drive = - Tcl_GetStringFromObj(useThisCwd, &cwdLen); + CONST char *drive = + Tcl_GetStringFromObj(useThisCwd, &cwdLen); char drive_cur = path[0]; - + if (drive_cur >= 'a') { drive_cur -= ('a' - 'A'); } if (drive[0] == drive_cur) { absolutePath = Tcl_DuplicateObj(useThisCwd); - /* - * We have a refCount on the cwd, which we - * will release later. + + /* + * We have a refCount on the cwd, which we will release later. */ if (drive[cwdLen-1] != '/' && (path[2] != '\0')) { - /* - * Only add a trailing '/' if needed, which - * is if there isn't one already, and if we - * are going to be adding some more + /* + * Only add a trailing '/' if needed, which is if there isn't + * one already, and if we are going to be adding some more * characters. */ + Tcl_AppendToObj(absolutePath, "/", 1); } } else { Tcl_DecrRefCount(useThisCwd); useThisCwd = NULL; - /* - * The path is not in the current drive, but - * is volume-relative. The way Tcl 8.3 handles - * this is that it treats such a path as - * relative to the root of the drive. We - * therefore behave the same here. This - * behaviour is, however, different to that - * of the windows command-line. If we want - * to fix this at some point in the future - * (at the expense of a behaviour change to - * Tcl), we could use the '_dgetdcwd' Win32 - * API to get the drive's cwd. + + /* + * The path is not in the current drive, but is volume-relative. + * The way Tcl 8.3 handles this is that it treats such a path as + * relative to the root of the drive. We therefore behave the same + * here. This behaviour is, however, different to that of the + * windows command-line. If we want to fix this at some point in + * the future (at the expense of a behaviour change to Tcl), we + * could use the '_dgetdcwd' Win32 API to get the drive's cwd. */ + absolutePath = Tcl_NewStringObj(path, 2); Tcl_AppendToObj(absolutePath, "/", 1); } Tcl_IncrRefCount(absolutePath); Tcl_AppendToObj(absolutePath, path+2, -1); @@ -2741,86 +3107,90 @@ /* *--------------------------------------------------------------------------- * * TclpNativeToNormalized -- * - * Convert native format to a normalized path object, with refCount - * of zero. - * - * Currently assumes all native paths are actually normalized - * already, so if the path given is not normalized this will - * actually just convert to a valid string path, but not - * necessarily a normalized one. + * Convert native format to a normalized path object, with refCount of + * zero. + * + * Currently assumes all native paths are actually normalized already, so + * if the path given is not normalized this will actually just convert to + * a valid string path, but not necessarily a normalized one. * * Results: - * A valid normalized path. + * A valid normalized path. * * Side effects: * None. * *--------------------------------------------------------------------------- */ -Tcl_Obj* + +Tcl_Obj* TclpNativeToNormalized(clientData) ClientData clientData; { Tcl_DString ds; Tcl_Obj *objPtr; int len; - + char *copy; char *p; Tcl_WinTCharToUtf((CONST char*)clientData, -1, &ds); - + copy = Tcl_DStringValue(&ds); len = Tcl_DStringLength(&ds); - /* - * Certain native path representations on Windows have this special - * prefix to indicate that they are to be treated specially. For - * example extremely long paths, or symlinks + /* + * Certain native path representations on Windows have this special prefix + * to indicate that they are to be treated specially. For example + * extremely long paths, or symlinks. */ + if (*copy == '\\') { if (0 == strncmp(copy,"\\??\\",4)) { copy += 4; len -= 4; } else if (0 == strncmp(copy,"\\\\?\\",4)) { copy += 4; len -= 4; } } - /* + + /* * Ensure we are using forward slashes only. */ + for (p = copy; *p != '\0'; p++) { if (*p == '\\') { *p = '/'; } } objPtr = Tcl_NewStringObj(copy,len); Tcl_DStringFree(&ds); - + return objPtr; } /* *--------------------------------------------------------------------------- * * TclNativeCreateNativeRep -- * - * Create a native representation for the given path. + * Create a native representation for the given path. * * Results: - * The nativePath representation. + * The nativePath representation. * * Side effects: - * Memory will be allocated. The path may need to be normalized. + * Memory will be allocated. The path may need to be normalized. * *--------------------------------------------------------------------------- */ -ClientData + +ClientData TclNativeCreateNativeRep(pathPtr) Tcl_Obj* pathPtr; { char *nativePathPtr; Tcl_DString ds; @@ -2827,19 +3197,22 @@ Tcl_Obj* validPathPtr; int len; char *str; if (TclFSCwdIsNative()) { - /* - * The cwd is native, which means we can use the translated - * path without worrying about normalization (this will also - * usually be shorter so the utf-to-external conversion will - * be somewhat faster). + /* + * The cwd is native, which means we can use the translated path + * without worrying about normalization (this will also usually be + * shorter so the utf-to-external conversion will be somewhat faster). */ + validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); } else { - /* Make sure the normalized path is set */ + /* + * Make sure the normalized path is set. + */ + validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); Tcl_IncrRefCount(validPathPtr); } str = Tcl_GetStringFromObj(validPathPtr, &len); @@ -2850,32 +3223,33 @@ len = Tcl_DStringLength(&ds) + sizeof(char); } Tcl_DecrRefCount(validPathPtr); nativePathPtr = ckalloc((unsigned) len); memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), (size_t) len); - + Tcl_DStringFree(&ds); return (ClientData)nativePathPtr; } /* *--------------------------------------------------------------------------- * * TclNativeDupInternalRep -- * - * Duplicate the native representation. + * Duplicate the native representation. * * Results: - * The copied native representation, or NULL if it is not possible - * to copy the representation. + * The copied native representation, or NULL if it is not possible to + * copy the representation. * * Side effects: * Memory allocation for the copy. * *--------------------------------------------------------------------------- */ -ClientData + +ClientData TclNativeDupInternalRep(clientData) ClientData clientData; { char *copy; size_t len; @@ -2883,20 +3257,26 @@ if (clientData == NULL) { return NULL; } if (tclWinProcs->useWide) { - /* unicode representation when running on NT/2K/XP */ - len = sizeof(WCHAR) + (wcslen((CONST WCHAR*)clientData) * sizeof(WCHAR)); + /* + * Unicode representation when running on NT/2K/XP. + */ + + len = sizeof(WCHAR) * (wcslen((CONST WCHAR *) clientData) + 1); } else { - /* ansi representation when running on 95/98/ME */ - len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char)); + /* + * ANSI representation when running on 95/98/ME. + */ + + len = sizeof(char) * (strlen((CONST char *) clientData) + 1); } - + copy = (char *) ckalloc(len); - memcpy((VOID*)copy, (VOID*)clientData, len); - return (ClientData)copy; + memcpy((VOID *) copy, (VOID *) clientData, len); + return (ClientData) copy; } /* *--------------------------------------------------------------------------- * @@ -2906,41 +3286,50 @@ * * Results: * 0 on success, -1 on error. * * Side effects: - * Sets errno to a representation of any Windows problem that's - * observed in the process. + * Sets errno to a representation of any Windows problem that's observed + * in the process. * *--------------------------------------------------------------------------- */ int TclpUtime(pathPtr, tval) - Tcl_Obj *pathPtr; /* File to modify */ - struct utimbuf *tval; /* New modification date structure */ + Tcl_Obj *pathPtr; /* File to modify */ + struct utimbuf *tval; /* New modification date structure */ { int res = 0; HANDLE fileHandle; FILETIME lastAccessTime, lastModTime; - + FromCTime(tval->actime, &lastAccessTime); FromCTime(tval->modtime, &lastModTime); - + /* - * We use the native APIs (not 'utime') because there are - * some daylight savings complications that utime gets wrong. + * We use the native APIs (not 'utime') because there are some daylight + * savings complications that utime gets wrong. */ + fileHandle = (tclWinProcs->createFileProc) ( - (CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), - FILE_WRITE_ATTRIBUTES, 0, NULL, OPEN_EXISTING, - FILE_ATTRIBUTE_NORMAL, NULL); - - if (fileHandle == INVALID_HANDLE_VALUE - || !SetFileTime(fileHandle, NULL, &lastAccessTime, &lastModTime)) { + (CONST TCHAR *) Tcl_FSGetNativePath(pathPtr), + FILE_WRITE_ATTRIBUTES, 0, NULL, OPEN_EXISTING, + FILE_ATTRIBUTE_NORMAL, NULL); + + if (fileHandle == INVALID_HANDLE_VALUE || + !SetFileTime(fileHandle, NULL, &lastAccessTime, &lastModTime)) { TclWinConvertError(GetLastError()); res = -1; } if (fileHandle != INVALID_HANDLE_VALUE) { CloseHandle(fileHandle); } return res; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: win/tclWinInit.c ================================================================== --- win/tclWinInit.c +++ win/tclWinInit.c @@ -5,11 +5,14 @@ * * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * All rights reserved. * - * RCS: @(#) $Id: tclWinInit.c,v 1.64 2004/11/30 19:34:52 dgp Exp $ + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclWinInit.c,v 1.64.2.2 2005/08/02 18:17:17 dgp Exp $ */ #include "tclWinInt.h" #include #include @@ -23,12 +26,12 @@ #endif /* * The following declaration is a workaround for some Microsoft brain damage. * The SYSTEM_INFO structure is different in various releases, even though the - * layout is the same. So we overlay our own structure on top of it so we - * can access the interesting slots in a uniform way. + * layout is the same. So we overlay our own structure on top of it so we can + * access the interesting slots in a uniform way. */ typedef struct { WORD wProcessorArchitecture; WORD wReserved; @@ -37,44 +40,44 @@ /* * The following macros are missing from some versions of winnt.h. */ #ifndef PROCESSOR_ARCHITECTURE_INTEL -#define PROCESSOR_ARCHITECTURE_INTEL 0 +#define PROCESSOR_ARCHITECTURE_INTEL 0 #endif #ifndef PROCESSOR_ARCHITECTURE_MIPS -#define PROCESSOR_ARCHITECTURE_MIPS 1 +#define PROCESSOR_ARCHITECTURE_MIPS 1 #endif #ifndef PROCESSOR_ARCHITECTURE_ALPHA -#define PROCESSOR_ARCHITECTURE_ALPHA 2 +#define PROCESSOR_ARCHITECTURE_ALPHA 2 #endif #ifndef PROCESSOR_ARCHITECTURE_PPC -#define PROCESSOR_ARCHITECTURE_PPC 3 +#define PROCESSOR_ARCHITECTURE_PPC 3 #endif #ifndef PROCESSOR_ARCHITECTURE_SHX -#define PROCESSOR_ARCHITECTURE_SHX 4 +#define PROCESSOR_ARCHITECTURE_SHX 4 #endif #ifndef PROCESSOR_ARCHITECTURE_ARM -#define PROCESSOR_ARCHITECTURE_ARM 5 +#define PROCESSOR_ARCHITECTURE_ARM 5 #endif #ifndef PROCESSOR_ARCHITECTURE_IA64 -#define PROCESSOR_ARCHITECTURE_IA64 6 +#define PROCESSOR_ARCHITECTURE_IA64 6 #endif #ifndef PROCESSOR_ARCHITECTURE_ALPHA64 -#define PROCESSOR_ARCHITECTURE_ALPHA64 7 +#define PROCESSOR_ARCHITECTURE_ALPHA64 7 #endif #ifndef PROCESSOR_ARCHITECTURE_MSIL -#define PROCESSOR_ARCHITECTURE_MSIL 8 +#define PROCESSOR_ARCHITECTURE_MSIL 8 #endif #ifndef PROCESSOR_ARCHITECTURE_AMD64 -#define PROCESSOR_ARCHITECTURE_AMD64 9 +#define PROCESSOR_ARCHITECTURE_AMD64 9 #endif #ifndef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 -#define PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 10 +#define PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 10 #endif #ifndef PROCESSOR_ARCHITECTURE_UNKNOWN -#define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF +#define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF #endif /* * The following arrays contain the human readable strings for the Windows * platform and processor values. @@ -93,10 +96,11 @@ }; /* * The default directory in which the init.tcl file is expected to be found. */ + static TclInitProcessGlobalValueProc InitializeDefaultLibraryDir; static ProcessGlobalValue defaultLibraryDir = {0, 0, NULL, NULL, InitializeDefaultLibraryDir, NULL, NULL}; static void AppendEnvironment(Tcl_Obj *listPtr, CONST char *lib); @@ -125,28 +129,27 @@ TclpInitPlatform() { tclPlatform = TCL_PLATFORM_WINDOWS; /* - * The following code stops Windows 3.X and Windows NT 3.51 from - * automatically putting up Sharing Violation dialogs, e.g, when - * someone tries to access a file that is locked or a drive with no - * disk in it. Tcl already returns the appropriate error to the - * caller, and they can decide to put up their own dialog in response - * to that failure. - * - * Under 95 and NT 4.0, this is a NOOP because the system doesn't + * The following code stops Windows 3.X and Windows NT 3.51 from + * automatically putting up Sharing Violation dialogs, e.g, when someone + * tries to access a file that is locked or a drive with no disk in it. + * Tcl already returns the appropriate error to the caller, and they can + * decide to put up their own dialog in response to that failure. + * + * Under 95 and NT 4.0, this is a NOOP because the system doesn't * automatically put up dialogs when the above operations fail. */ SetErrorMode(SetErrorMode(0) | SEM_FAILCRITICALERRORS); #ifdef STATIC_BUILD /* - * If we are in a statically linked executable, then we need to - * explicitly initialize the Windows function tables here since - * DllMain() will not be invoked. + * If we are in a statically linked executable, then we need to explicitly + * initialize the Windows function tables here since DllMain() will not be + * invoked. */ TclWinInit(GetModuleHandle(NULL)); #endif } @@ -154,19 +157,18 @@ /* *------------------------------------------------------------------------- * * TclpInitLibraryPath -- * - * This is the fallback routine that sets the library path - * if the application has not set one by the first time - * it is needed. + * This is the fallback routine that sets the library path if the + * application has not set one by the first time it is needed. * * Results: - * None. + * None. * * Side effects: - * Sets the library path to an initial value. + * Sets the library path to an initial value. * *------------------------------------------------------------------------- */ void @@ -181,29 +183,30 @@ char *bytes; pathPtr = Tcl_NewObj(); /* - * Initialize the substring used when locating the script library. The + * Initialize the substring used when locating the script library. The * installLib variable computes the script library path relative to the * installed DLL. */ sprintf(installLib, "lib/tcl%s", TCL_VERSION); /* - * Look for the library relative to the TCL_LIBRARY env variable. - * If the last dirname in the TCL_LIBRARY path does not match the - * last dirname in the installLib variable, use the last dir name - * of installLib in addition to the orginal TCL_LIBRARY path. + * Look for the library relative to the TCL_LIBRARY env variable. If the + * last dirname in the TCL_LIBRARY path does not match the last dirname in + * the installLib variable, use the last dir name of installLib in + * addition to the orginal TCL_LIBRARY path. */ AppendEnvironment(pathPtr, installLib); /* * Look for the library in its default location. */ + Tcl_ListObjAppendElement(NULL, pathPtr, TclGetProcessGlobalValue(&defaultLibraryDir)); *encodingPtr = NULL; bytes = Tcl_GetStringFromObj(pathPtr, lengthPtr); @@ -215,13 +218,13 @@ /* *--------------------------------------------------------------------------- * * AppendEnvironment -- * - * Append the value of the TCL_LIBRARY environment variable onto the - * path pointer. If the env variable points to another version of - * tcl (e.g. "tcl7.6") also append the path to this version (e.g., + * Append the value of the TCL_LIBRARY environment variable onto the path + * pointer. If the env variable points to another version of tcl (e.g. + * "tcl7.6") also append the path to this version (e.g., * "tcl7.6/../tcl8.2") * * Results: * None. * @@ -243,14 +246,14 @@ Tcl_DString ds; CONST char **pathv; char *shortlib; /* - * The shortlib value needs to be the tail component of the - * lib path. For example, "lib/tcl8.4" -> "tcl8.4" while - * "usr/share/tcl8.5" -> "tcl8.5". + * The shortlib value needs to be the tail component of the lib path. For + * example, "lib/tcl8.4" -> "tcl8.4" while "usr/share/tcl8.5" -> "tcl8.5". */ + for (shortlib = (char *) &lib[strlen(lib)-1]; shortlib>lib ; shortlib--) { if (*shortlib == '/') { if ((unsigned)(shortlib - lib) == strlen(lib) - 1) { Tcl_Panic("last character in lib cannot be '/'"); } @@ -261,12 +264,12 @@ if (shortlib == lib) { Tcl_Panic("no '/' character found in lib"); } /* - * The "L" preceeding the TCL_LIBRARY string is used to tell VC++ - * that this is a unicode string. + * The "L" preceeding the TCL_LIBRARY string is used to tell VC++ that + * this is a unicode string. */ if (GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH) == 0) { buf[0] = '\0'; GetEnvironmentVariableA("TCL_LIBRARY", buf, MAX_PATH); @@ -280,22 +283,22 @@ TclWinNoBackslash(buf); Tcl_SplitPath(buf, &pathc, &pathv); /* - * The lstrcmpi() will work even if pathv[pathc - 1] is random - * UTF-8 chars because I know shortlib is ascii. + * The lstrcmpi() will work even if pathv[pathc-1] is random UTF-8 + * chars because I know shortlib is ascii. */ if ((pathc > 0) && (lstrcmpiA(shortlib, pathv[pathc - 1]) != 0)) { CONST char *str; + /* - * TCL_LIBRARY is set but refers to a different tcl - * installation than the current version. Try fiddling with the - * specified directory to make it refer to this installation by - * removing the old "tclX.Y" and substituting the current - * version string. + * TCL_LIBRARY is set but refers to a different tcl installation + * than the current version. Try fiddling with the specified + * directory to make it refer to this installation by removing the + * old "tclX.Y" and substituting the current version string. */ pathv[pathc - 1] = shortlib; Tcl_DStringInit(&ds); str = Tcl_JoinPath(pathc, pathv, &ds); @@ -312,12 +315,12 @@ /* *--------------------------------------------------------------------------- * * InitializeDefaultLibraryDir -- * - * Locate the Tcl script library default location relative to - * the location of the Tcl DLL. + * Locate the Tcl script library default location relative to the + * location of the Tcl DLL. * * Results: * None. * * Side effects: @@ -340,17 +343,19 @@ if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) { GetModuleFileNameA(hModule, name, MAX_PATH); } else { ToUtf(wName, name); } - end = strrchr(name, '\\'); - *end = '\0'; - p = strrchr(name, '\\'); - if (p != NULL) { - end = p; - } - *end = '\\'; + + end = strrchr(name, '\\'); + *end = '\0'; + p = strrchr(name, '\\'); + if (p != NULL) { + end = p; + } + *end = '\\'; + TclWinNoBackslash(name); sprintf(end + 1, "lib/tcl%s", TCL_VERSION); *lengthPtr = strlen(name); *valuePtr = ckalloc((unsigned int) *lengthPtr + 1); *encodingPtr = NULL; @@ -392,14 +397,14 @@ /* *--------------------------------------------------------------------------- * * TclWinEncodingsCleanup -- * - * Reset information to its original state in finalization to - * allow for reinitialization to be possible. This must not - * be called until after the filesystem has been finalised, or - * exit crashes may occur when using virtual filesystems. + * Reset information to its original state in finalization to allow for + * reinitialization to be possible. This must not be called until after + * the filesystem has been finalised, or exit crashes may occur when + * using virtual filesystems. * * Results: * None. * * Side effects: @@ -417,43 +422,49 @@ /* *--------------------------------------------------------------------------- * * TclpSetInitialEncodings -- * - * Based on the locale, determine the encoding of the operating - * system and the default encoding for newly opened files. + * Based on the locale, determine the encoding of the operating system + * and the default encoding for newly opened files. * - * Called at process initialization time, and part way through - * startup, we verify that the initial encodings were correctly - * setup. Depending on Tcl's environment, there may not have been - * enough information first time through (above). + * Called at process initialization time, and part way through startup, + * we verify that the initial encodings were correctly setup. Depending + * on Tcl's environment, there may not have been enough information first + * time through (above). * * Results: * None. * * Side effects: - * The Tcl library path is converted from native encoding to UTF-8, - * on the first call, and the encodings may be changed on first or - * second call. + * The Tcl library path is converted from native encoding to UTF-8, on + * the first call, and the encodings may be changed on first or second + * call. * *--------------------------------------------------------------------------- */ void TclpSetInitialEncodings() { - int platformId, useWide; Tcl_DString encodingName; + + TclpSetInterfaces(); + Tcl_SetSystemEncoding(NULL, + TclpGetEncodingNameFromEnvironment(&encodingName)); + Tcl_DStringFree(&encodingName); +} + +void +TclpSetInterfaces() +{ + int platformId, useWide; platformId = TclWinGetPlatformId(); useWide = ((platformId == VER_PLATFORM_WIN32_NT) || (platformId == VER_PLATFORM_WIN32_CE)); TclWinSetInterfaces(useWide); - - Tcl_SetSystemEncoding(NULL, - TclpGetEncodingNameFromEnvironment(&encodingName)); - Tcl_DStringFree(&encodingName); } CONST char * TclpGetEncodingNameFromEnvironment(bufPtr) Tcl_DString *bufPtr; @@ -466,13 +477,12 @@ /* *--------------------------------------------------------------------------- * * TclpSetVariables -- * - * Performs platform-specific interpreter initialization related to - * the tcl_platform and env variables, and other platform-specific - * things. + * Performs platform-specific interpreter initialization related to the + * tcl_platform and env variables, and other platform-specific things. * * Results: * None. * * Side effects: @@ -521,14 +531,15 @@ TCL_GLOBAL_ONLY); } #ifdef _DEBUG /* - * The existence of the "debug" element of the tcl_platform array indicates - * that this particular Tcl shell has been compiled with debug information. - * Using "info exists tcl_platform(debug)" a Tcl script can direct the - * interpreter to load debug versions of DLLs with the load command. + * The existence of the "debug" element of the tcl_platform array + * indicates that this particular Tcl shell has been compiled with debug + * information. Using "info exists tcl_platform(debug)" a Tcl script can + * direct the interpreter to load debug versions of DLLs with the load + * command. */ Tcl_SetVar2(interp, "tcl_platform", "debug", "1", TCL_GLOBAL_ONLY); #endif @@ -576,19 +587,18 @@ /* *---------------------------------------------------------------------- * * TclpFindVariable -- * - * Locate the entry in environ for a given name. On Unix this - * routine is case sensetive, on Windows this matches mioxed case. + * Locate the entry in environ for a given name. On Unix this routine is + * case sensetive, on Windows this matches mioxed case. * * Results: - * The return value is the index in environ of an entry with the - * name "name", or -1 if there is no such entry. The integer at - * *lengthPtr is filled in with the length of name (if a matching - * entry is found) or the length of the environ array (if no matching - * entry is found). + * The return value is the index in environ of an entry with the name + * "name", or -1 if there is no such entry. The integer at *lengthPtr is + * filled in with the length of name (if a matching entry is found) or + * the length of the environ array (if no matching entry is found). * * Side effects: * None. * *---------------------------------------------------------------------- @@ -607,12 +617,11 @@ register CONST char *env, *p1, *p2; char *envUpper, *nameUpper; Tcl_DString envString; /* - * Convert the name to all upper case for the case insensitive - * comparison. + * Convert the name to all upper case for the case insensitive comparison. */ length = strlen(name); nameUpper = (char *) ckalloc((unsigned) length+1); memcpy((VOID *) nameUpper, (VOID *) name, (size_t) length+1); @@ -619,13 +628,13 @@ Tcl_UtfToUpper(nameUpper); Tcl_DStringInit(&envString); for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) { /* - * Chop the env string off after the equal sign, then Convert - * the name to all upper case, so we do not have to convert - * all the characters after the equal sign. + * Chop the env string off after the equal sign, then Convert the name + * to all upper case, so we do not have to convert all the characters + * after the equal sign. */ envUpper = Tcl_ExternalToUtfDString(NULL, env, -1, &envString); p1 = strchr(envUpper, '='); if (p1 == NULL) { @@ -649,10 +658,18 @@ Tcl_DStringFree(&envString); } *lengthPtr = i; - done: + done: Tcl_DStringFree(&envString); ckfree(nameUpper); return result; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: win/tclWinLoad.c ================================================================== --- win/tclWinLoad.c +++ win/tclWinLoad.c @@ -1,18 +1,18 @@ -/* +/* * tclWinLoad.c -- * - * This procedure provides a version of the TclLoadFile that - * works with the Windows "LoadLibrary" and "GetProcAddress" - * API for dynamic loading. + * This function provides a version of the TclLoadFile that works with + * the Windows "LoadLibrary" and "GetProcAddress" API for dynamic + * loading. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinLoad.c,v 1.17 2003/09/08 20:12:07 davygrvy Exp $ + * RCS: @(#) $Id: tclWinLoad.c,v 1.17.2.1 2005/08/02 18:17:18 dgp Exp $ */ #include "tclWinInt.h" @@ -19,16 +19,16 @@ /* *---------------------------------------------------------------------- * * TclpDlopen -- * - * Dynamically loads a binary code file into memory and returns - * a handle to the new code. + * Dynamically loads a binary code file into memory and returns a handle + * to the new code. * * Results: - * A standard Tcl completion code. If an error occurs, an error - * message is left in the interp's result. + * A standard Tcl completion code. If an error occurs, an error message + * is left in the interp's result. * * Side effects: * New code suddenly appears in memory. * *---------------------------------------------------------------------- @@ -38,91 +38,97 @@ TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr) Tcl_Interp *interp; /* Used for error reporting. */ Tcl_Obj *pathPtr; /* Name of the file containing the desired * code (UTF-8). */ Tcl_LoadHandle *loadHandle; /* Filled with token for dynamically loaded - * file which will be passed back to + * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr; + Tcl_FSUnloadFileProc **unloadProcPtr; /* Filled with address of Tcl_FSUnloadFileProc - * function which should be used for - * this file. */ + * function which should be used for this + * file. */ { HINSTANCE handle; CONST TCHAR *nativeName; - /* - * First try the full path the user gave us. This is particularly - * important if the cwd is inside a vfs, and we are trying to load - * using a relative path. + /* + * First try the full path the user gave us. This is particularly + * important if the cwd is inside a vfs, and we are trying to load using a + * relative path. */ + nativeName = Tcl_FSGetNativePath(pathPtr); handle = (*tclWinProcs->loadLibraryProc)(nativeName); if (handle == NULL) { - /* - * Let the OS loader examine the binary search path for - * whatever string the user gave us which hopefully refers - * to a file on the binary path + /* + * Let the OS loader examine the binary search path for whatever + * string the user gave us which hopefully refers to a file on the + * binary path. */ + Tcl_DString ds; - char *fileName = Tcl_GetString(pathPtr); + char *fileName = Tcl_GetString(pathPtr); + nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds); handle = (*tclWinProcs->loadLibraryProc)(nativeName); Tcl_DStringFree(&ds); } *loadHandle = (Tcl_LoadHandle) handle; - + if (handle == NULL) { DWORD lastError = GetLastError(); + #if 0 /* - * It would be ideal if the FormatMessage stuff worked better, - * but unfortunately it doesn't seem to want to... + * It would be ideal if the FormatMessage stuff worked better, but + * unfortunately it doesn't seem to want to... */ + LPTSTR lpMsgBuf; char *buf; int size; + size = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, lastError, 0, (LPTSTR) &lpMsgBuf, 0, NULL); buf = (char *) ckalloc((unsigned) TCL_INTEGER_SPACE + size + 1); sprintf(buf, "%d %s", lastError, (char *)lpMsgBuf); #endif + Tcl_AppendResult(interp, "couldn't load library \"", - Tcl_GetString(pathPtr), "\": ", (char *) NULL); + Tcl_GetString(pathPtr), "\": ", (char *) NULL); + /* - * Check for possible DLL errors. This doesn't work quite right, - * because Windows seems to only return ERROR_MOD_NOT_FOUND for - * just about any problem, but it's better than nothing. It'd be - * even better if there was a way to get what DLLs + * Check for possible DLL errors. This doesn't work quite right, + * because Windows seems to only return ERROR_MOD_NOT_FOUND for just + * about any problem, but it's better than nothing. It'd be even + * better if there was a way to get what DLLs */ + switch (lastError) { - case ERROR_MOD_NOT_FOUND: - case ERROR_DLL_NOT_FOUND: - Tcl_AppendResult(interp, "this library or a dependent library", - " could not be found in library path", - (char *) NULL); - break; - case ERROR_PROC_NOT_FOUND: - Tcl_AppendResult(interp, "A function specified in the import", - " table could not be resolved by the system. Windows", - " is not telling which one, I'm sorry.", - (char *) NULL); - break; - case ERROR_INVALID_DLL: - Tcl_AppendResult(interp, "this library or a dependent library", - " is damaged", (char *) NULL); - break; - case ERROR_DLL_INIT_FAILED: - Tcl_AppendResult(interp, "the library initialization", - " routine failed", (char *) NULL); - break; - default: - TclWinConvertError(lastError); - Tcl_AppendResult(interp, Tcl_PosixError(interp), - (char *) NULL); + case ERROR_MOD_NOT_FOUND: + case ERROR_DLL_NOT_FOUND: + Tcl_AppendResult(interp, "this library or a dependent library", + " could not be found in library path", (char *) NULL); + break; + case ERROR_PROC_NOT_FOUND: + Tcl_AppendResult(interp, "A function specified in the import", + " table could not be resolved by the system. Windows", + " is not telling which one, I'm sorry.", (char *) NULL); + break; + case ERROR_INVALID_DLL: + Tcl_AppendResult(interp, "this library or a dependent library", + " is damaged", (char *) NULL); + break; + case ERROR_DLL_INIT_FAILED: + Tcl_AppendResult(interp, "the library initialization", + " routine failed", (char *) NULL); + break; + default: + TclWinConvertError(lastError); + Tcl_AppendResult(interp, Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } else { *unloadProcPtr = &TclpUnloadFile; } @@ -132,22 +138,23 @@ /* *---------------------------------------------------------------------- * * TclpFindSymbol -- * - * Looks up a symbol, by name, through a handle associated with - * a previously loaded piece of code (shared library). + * Looks up a symbol, by name, through a handle associated with a + * previously loaded piece of code (shared library). * * Results: - * Returns a pointer to the function associated with 'symbol' if - * it is found. Otherwise returns NULL and may leave an error - * message in the interp's result. + * Returns a pointer to the function associated with 'symbol' if it is + * found. Otherwise returns NULL and may leave an error message in the + * interp's result. * *---------------------------------------------------------------------- */ + Tcl_PackageInitProc* -TclpFindSymbol(interp, loadHandle, symbol) +TclpFindSymbol(interp, loadHandle, symbol) Tcl_Interp *interp; Tcl_LoadHandle loadHandle; CONST char *symbol; { Tcl_PackageInitProc *proc = NULL; @@ -159,10 +166,11 @@ */ proc = (Tcl_PackageInitProc *) GetProcAddress(handle, symbol); if (proc == NULL) { Tcl_DString ds; + Tcl_DStringInit(&ds); Tcl_DStringAppend(&ds, "_", 1); symbol = Tcl_DStringAppend(&ds, symbol, -1); proc = (Tcl_PackageInitProc *) GetProcAddress(handle, symbol); Tcl_DStringFree(&ds); @@ -173,13 +181,13 @@ /* *---------------------------------------------------------------------- * * TclpUnloadFile -- * - * Unloads a dynamically loaded binary code file from memory. - * Code pointers in the formerly loaded file are no longer valid - * after calling this function. + * Unloads a dynamically loaded binary code file from memory. Code + * pointers in the formerly loaded file are no longer valid after calling + * this function. * * Results: * None. * * Side effects: @@ -188,14 +196,13 @@ *---------------------------------------------------------------------- */ void TclpUnloadFile(loadHandle) - Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call - * to TclpDlopen(). The loadHandle is - * a token that represents the loaded - * file. */ + Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call to + * TclpDlopen(). The loadHandle is a token + * that represents the loaded file. */ { HINSTANCE handle; handle = (HINSTANCE) loadHandle; FreeLibrary(handle); @@ -204,18 +211,18 @@ /* *---------------------------------------------------------------------- * * TclGuessPackageName -- * - * If the "load" command is invoked without providing a package - * name, this procedure is invoked to try to figure it out. + * If the "load" command is invoked without providing a package name, + * this function is invoked to try to figure it out. * * Results: - * Always returns 0 to indicate that we couldn't figure out a - * package name; generic code will then try to guess the package - * from the file name. A return value of 1 would have meant that - * we figured out the package name and put it in bufPtr. + * Always returns 0 to indicate that we couldn't figure out a package + * name; generic code will then try to guess the package from the file + * name. A return value of 1 would have meant that we figured out the + * package name and put it in bufPtr. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -223,10 +230,18 @@ int TclGuessPackageName(fileName, bufPtr) CONST char *fileName; /* Name of file containing package (already * translated to local form if needed). */ - Tcl_DString *bufPtr; /* Initialized empty dstring. Append - * package name to this if possible. */ + Tcl_DString *bufPtr; /* Initialized empty dstring. Append package + * name to this if possible. */ { return 0; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: win/tclWinNotify.c ================================================================== --- win/tclWinNotify.c +++ win/tclWinNotify.c @@ -1,44 +1,44 @@ -/* +/* * tclWinNotify.c -- * - * This file contains Windows-specific procedures for the notifier, - * which is the lowest-level part of the Tcl event loop. This file - * works together with ../generic/tclNotify.c. + * This file contains Windows-specific procedures for the notifier, which + * is the lowest-level part of the Tcl event loop. This file works + * together with ../generic/tclNotify.c. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinNotify.c,v 1.16 2004/04/06 22:25:58 dgp Exp $ + * RCS: @(#) $Id: tclWinNotify.c,v 1.16.2.3 2005/08/02 18:17:18 dgp Exp $ */ #include "tclInt.h" /* * The follwing static indicates whether this module has been initialized. */ -#define INTERVAL_TIMER 1 /* Handle of interval timer. */ +#define INTERVAL_TIMER 1 /* Handle of interval timer. */ -#define WM_WAKEUP WM_USER /* Message that is send by +#define WM_WAKEUP WM_USER /* Message that is send by * Tcl_AlertNotifier. */ /* * The following static structure contains the state information for the - * Windows implementation of the Tcl notifier. One of these structures - * is created for each thread that is using the notifier. + * Windows implementation of the Tcl notifier. One of these structures is + * created for each thread that is using the notifier. */ typedef struct ThreadSpecificData { CRITICAL_SECTION crit; /* Monitor for this notifier. */ DWORD thread; /* Identifier for thread associated with this * notifier. */ HANDLE event; /* Event object used to wake up the notifier * thread. */ - int pending; /* Alert message pending, this field is - * locked by the notifierMutex. */ + int pending; /* Alert message pending, this field is locked + * by the notifierMutex. */ HWND hwnd; /* Messaging window. */ int timeout; /* Current timeout value. */ int timerActive; /* 1 if interval timer is running. */ } ThreadSpecificData; @@ -46,13 +46,12 @@ extern TclStubs tclStubs; extern Tcl_NotifierProcs tclOriginalNotifier; /* - * The following static indicates the number of threads that have - * initialized notifiers. It controls the lifetime of the TclNotifier - * window class. + * The following static indicates the number of threads that have initialized + * notifiers. It controls the lifetime of the TclNotifier window class. * * You must hold the notifierMutex lock before accessing this variable. */ static int notifierCount = 0; @@ -60,13 +59,12 @@ /* * Static routines defined in this file. */ -static LRESULT CALLBACK NotifierProc(HWND hwnd, UINT message, - WPARAM wParam, LPARAM lParam); - +static LRESULT CALLBACK NotifierProc(HWND hwnd, UINT message, + WPARAM wParam, LPARAM lParam); /* *---------------------------------------------------------------------- * * Tcl_InitNotifier -- @@ -87,12 +85,12 @@ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); WNDCLASS class; /* - * Register Notifier window class if this is the first thread to - * use this module. + * Register Notifier window class if this is the first thread to use this + * module. */ Tcl_MutexLock(¬ifierMutex); if (notifierCount == 0) { class.style = 0; @@ -129,12 +127,12 @@ /* *---------------------------------------------------------------------- * * Tcl_FinalizeNotifier -- * - * This function is called to cleanup the notifier state before - * a thread is terminated. + * This function is called to cleanup the notifier state before a thread + * is terminated. * * Results: * None. * * Side effects: @@ -148,19 +146,20 @@ ClientData clientData; /* Pointer to notifier data. */ { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; /* - * Only finalize the notifier if a notifier was installed in the - * current thread; there is a route in which this is not - * guaranteed to be true (when tclWin32Dll.c:DllMain() is called - * with the flag DLL_PROCESS_DETACH by the OS, which could be - * doing so from a thread that's never previously been involved - * with Tcl, e.g. the task manager) so this check is important. + * Only finalize the notifier if a notifier was installed in the current + * thread; there is a route in which this is not guaranteed to be true + * (when tclWin32Dll.c:DllMain() is called with the flag + * DLL_PROCESS_DETACH by the OS, which could be doing so from a thread + * that's never previously been involved with Tcl, e.g. the task manager) + * so this check is important. * * Fixes Bug #217982 reported by Hugh Vu and Gene Leache. */ + if (tsdPtr == NULL) { return; } DeleteCriticalSection(&tsdPtr->crit); @@ -174,12 +173,12 @@ KillTimer(tsdPtr->hwnd, INTERVAL_TIMER); DestroyWindow(tsdPtr->hwnd); } /* - * If this is the last thread to use the notifier, unregister - * the notifier window class. + * If this is the last thread to use the notifier, unregister the notifier + * window class. */ Tcl_MutexLock(¬ifierMutex); notifierCount--; if (notifierCount == 0) { @@ -191,24 +190,23 @@ /* *---------------------------------------------------------------------- * * Tcl_AlertNotifier -- * - * Wake up the specified notifier from any thread. This routine - * is called by the platform independent notifier code whenever - * the Tcl_ThreadAlert routine is called. This routine is - * guaranteed not to be called on a given notifier after - * Tcl_FinalizeNotifier is called for that notifier. This routine - * is typically called from a thread other than the notifier's - * thread. + * Wake up the specified notifier from any thread. This routine is called + * by the platform independent notifier code whenever the Tcl_ThreadAlert + * routine is called. This routine is guaranteed not to be called on a + * given notifier after Tcl_FinalizeNotifier is called for that notifier. + * This routine is typically called from a thread other than the + * notifier's thread. * * Results: * None. * * Side effects: - * Sends a message to the messaging window for the notifier - * if there isn't already one pending. + * Sends a message to the messaging window for the notifier if there + * isn't already one pending. * *---------------------------------------------------------------------- */ void @@ -216,13 +214,13 @@ ClientData clientData; /* Pointer to thread data. */ { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; /* - * Note that we do not need to lock around access to the hwnd - * because the race condition has no effect since any race condition - * implies that the notifier thread is already awake. + * Note that we do not need to lock around access to the hwnd because the + * race condition has no effect since any race condition implies that the + * notifier thread is already awake. */ if (tsdPtr->hwnd) { /* * We do need to lock around access to the pending flag. @@ -242,13 +240,13 @@ /* *---------------------------------------------------------------------- * * Tcl_SetTimer -- * - * This procedure sets the current notifier timer value. The - * notifier will ensure that Tcl_ServiceAll() is called after - * the specified interval, even if no events have occurred. + * This procedure sets the current notifier timer value. The notifier + * will ensure that Tcl_ServiceAll() is called after the specified + * interval, even if no events have occurred. * * Results: * None. * * Side effects: @@ -263,24 +261,23 @@ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); UINT timeout; /* - * Allow the notifier to be hooked. This may not make sense - * on Windows, but mirrors the UNIX hook. + * Allow the notifier to be hooked. This may not make sense on Windows, + * but mirrors the UNIX hook. */ if (tclStubs.tcl_SetTimer != tclOriginalNotifier.setTimerProc) { tclStubs.tcl_SetTimer(timePtr); return; } /* - * We only need to set up an interval timer if we're being called - * from an external event loop. If we don't have a window handle - * then we just return immediately and let Tcl_WaitForEvent handle - * timeouts. + * We only need to set up an interval timer if we're being called from an + * external event loop. If we don't have a window handle then we just + * return immediately and let Tcl_WaitForEvent handle timeouts. */ if (!tsdPtr->hwnd) { return; } @@ -299,12 +296,12 @@ } } tsdPtr->timeout = timeout; if (timeout != 0) { tsdPtr->timerActive = 1; - SetTimer(tsdPtr->hwnd, INTERVAL_TIMER, - (unsigned long) tsdPtr->timeout, NULL); + SetTimer(tsdPtr->hwnd, INTERVAL_TIMER, (unsigned long) tsdPtr->timeout, + NULL); } else { tsdPtr->timerActive = 0; KillTimer(tsdPtr->hwnd, INTERVAL_TIMER); } } @@ -318,12 +315,12 @@ * * Results: * None. * * Side effects: - * If this is the first time the notifier is set into - * TCL_SERVICE_ALL, then the communication window is created. + * If this is the first time the notifier is set into TCL_SERVICE_ALL, + * then the communication window is created. * *---------------------------------------------------------------------- */ void @@ -332,27 +329,27 @@ * TCL_SERVICE_NONE. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* - * If this is the first time that the notifier has been used from a - * modal loop, then create a communication window. Note that after - * this point, the application needs to service events in a timely - * fashion or Windows will hang waiting for the window to respond - * to synchronous system messages. At some point, we may want to - * consider destroying the window if we leave the modal loop, but - * for now we'll leave it around. + * If this is the first time that the notifier has been used from a modal + * loop, then create a communication window. Note that after this point, + * the application needs to service events in a timely fashion or Windows + * will hang waiting for the window to respond to synchronous system + * messages. At some point, we may want to consider destroying the window + * if we leave the modal loop, but for now we'll leave it around. */ if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) { tsdPtr->hwnd = CreateWindowA("TclNotifier", "TclNotifier", WS_TILED, 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), NULL); + /* * Send an initial message to the window to ensure that we wake up the - * notifier once we get into the modal loop. This will force the - * notifier to recompute the timeout value and schedule a timer - * if one is needed. + * notifier once we get into the modal loop. This will force the + * notifier to recompute the timeout value and schedule a timer if one + * is needed. */ Tcl_AlertNotifier((ClientData)tsdPtr); } } @@ -360,14 +357,13 @@ /* *---------------------------------------------------------------------- * * NotifierProc -- * - * This procedure is invoked by Windows to process events on - * the notifier window. Messages will be sent to this window - * in response to external timer events or calls to - * TclpAlertTsdPtr-> + * This procedure is invoked by Windows to process events on the notifier + * window. Messages will be sent to this window in response to external + * timer events or calls to TclpAlertTsdPtr-> * * Results: * A standard windows result. * * Side effects: @@ -376,14 +372,14 @@ *---------------------------------------------------------------------- */ static LRESULT CALLBACK NotifierProc( - HWND hwnd, - UINT message, - WPARAM wParam, - LPARAM lParam) + HWND hwnd, /* Passed on... */ + UINT message, /* What messsage is this? */ + WPARAM wParam, /* Passed on... */ + LPARAM lParam) /* Passed on... */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (message == WM_WAKEUP) { EnterCriticalSection(&tsdPtr->crit); @@ -390,11 +386,11 @@ tsdPtr->pending = 0; LeaveCriticalSection(&tsdPtr->crit); } else if (message != WM_TIMER) { return DefWindowProc(hwnd, message, wParam, lParam); } - + /* * Process all of the runnable events. */ Tcl_ServiceAll(); @@ -404,21 +400,20 @@ /* *---------------------------------------------------------------------- * * Tcl_WaitForEvent -- * - * This function is called by Tcl_DoOneEvent to wait for new - * events on the message queue. If the block time is 0, then - * Tcl_WaitForEvent just polls the event queue without blocking. + * This function is called by Tcl_DoOneEvent to wait for new events on + * the message queue. If the block time is 0, then Tcl_WaitForEvent just + * polls the event queue without blocking. * * Results: - * Returns -1 if a WM_QUIT message is detected, returns 1 if - * a message was dispatched, otherwise returns 0. + * Returns -1 if a WM_QUIT message is detected, returns 1 if a message + * was dispatched, otherwise returns 0. * * Side effects: - * Dispatches a message to a window procedure, which could do - * anything. + * Dispatches a message to a window procedure, which could do anything. * *---------------------------------------------------------------------- */ int @@ -429,12 +424,12 @@ MSG msg; DWORD timeout, result; int status; /* - * Allow the notifier to be hooked. This may not make - * sense on windows, but mirrors the UNIX hook. + * Allow the notifier to be hooked. This may not make sense on windows, + * but mirrors the UNIX hook. */ if (tclStubs.tcl_WaitForEvent != tclOriginalNotifier.waitForEventProc) { return tclStubs.tcl_WaitForEvent(timePtr); } @@ -442,11 +437,25 @@ /* * Compute the timeout in milliseconds. */ if (timePtr) { - timeout = timePtr->sec * 1000 + timePtr->usec / 1000; + /* + * TIP #233 (Virtualized Time). Convert virtual domain delay to + * real-time. + */ + + Tcl_Time myTime; + + myTime.sec = timePtr->sec; + myTime.usec = timePtr->usec; + + if (myTime.sec != 0 || myTime.usec != 0) { + (*tclScaleTimeProcPtr) (&myTime, tclTimeClientData); + } + + timeout = myTime.sec * 1000 + myTime.usec / 1000; } else { timeout = INFINITE; } /* @@ -456,15 +465,15 @@ */ if (!PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) { /* * Wait for something to happen (a signal from another thread, a - * message, or timeout) or loop servicing asynchronous procedure - * calls queued to this thread. + * message, or timeout) or loop servicing asynchronous procedure calls + * queued to this thread. */ -again: + again: result = MsgWaitForMultipleObjectsEx(1, &tsdPtr->event, timeout, QS_ALLINPUT, MWMO_ALERTABLE); if (result == WAIT_IO_COMPLETION) { goto again; } else if (result == WAIT_FAILED) { @@ -491,11 +500,11 @@ PostQuitMessage((int) msg.wParam); status = -1; } else if (result == -1) { /* - * We got an error from the system. I have no idea why this would + * We got an error from the system. I have no idea why this would * happen, so we'll just unwind. */ status = -1; } else { @@ -505,11 +514,11 @@ } } else { status = 0; } -end: + end: ResetEvent(tsdPtr->event); return status; } /* @@ -531,40 +540,62 @@ void Tcl_Sleep(ms) int ms; /* Number of milliseconds to sleep. */ { /* - * Simply calling 'Sleep' for the requisite number of milliseconds - * can make the process appear to wake up early because it isn't - * synchronized with the CPU performance counter that is used in - * tclWinTime.c. This behavior is probably benign, but messes - * up some of the corner cases in the test suite. We get around - * this problem by repeating the 'Sleep' call as many times - * as necessary to make the clock advance by the requisite amount. + * Simply calling 'Sleep' for the requisite number of milliseconds can + * make the process appear to wake up early because it isn't synchronized + * with the CPU performance counter that is used in tclWinTime.c. This + * behavior is probably benign, but messes up some of the corner cases in + * the test suite. We get around this problem by repeating the 'Sleep' + * call as many times as necessary to make the clock advance by the + * requisite amount. */ - Tcl_Time now; /* Current wall clock time */ - Tcl_Time desired; /* Desired wakeup time */ - DWORD sleepTime = ms; /* Time to sleep */ - - Tcl_GetTime( &now ); - desired.sec = now.sec + ( ms / 1000 ); - desired.usec = now.usec + 1000 * ( ms % 1000 ); - if ( desired.usec > 1000000 ) { + Tcl_Time now; /* Current wall clock time. */ + Tcl_Time desired; /* Desired wakeup time. */ + Tcl_Time vdelay; /* Time to sleep, for scaling virtual -> + * real. */ + DWORD sleepTime; /* Time to sleep, real-time */ + + vdelay.sec = ms / 1000; + vdelay.usec = (ms % 1000) * 1000; + + Tcl_GetTime(&now); + desired.sec = now.sec + vdelay.sec; + desired.usec = now.usec + vdelay.usec; + if (desired.usec > 1000000) { ++desired.sec; desired.usec -= 1000000; } - - for ( ; ; ) { - Sleep( sleepTime ); - Tcl_GetTime( &now ); - if ( now.sec > desired.sec ) { - break; - } else if ( ( now.sec == desired.sec ) - && ( now.usec >= desired.usec ) ) { - break; - } - sleepTime = ( ( 1000 * ( desired.sec - now.sec ) ) - + ( ( desired.usec - now.usec ) / 1000 ) ); - } - -} + + /* + * TIP #233: Scale delay from virtual to real-time. + */ + + (*tclScaleTimeProcPtr) (&vdelay, tclTimeClientData); + sleepTime = vdelay.sec * 1000 + vdelay.usec / 1000; + + for (;;) { + Sleep(sleepTime); + Tcl_GetTime(&now); + if (now.sec > desired.sec) { + break; + } else if ((now.sec == desired.sec) && (now.usec >= desired.usec)) { + break; + } + + vdelay.sec = desired.sec - now.sec; + vdelay.usec = desired.usec - now.usec; + + (*tclScaleTimeProcPtr) (&vdelay, tclTimeClientData); + sleepTime = vdelay.sec * 1000 + vdelay.usec / 1000; + } +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: win/tclWinPipe.c ================================================================== --- win/tclWinPipe.c +++ win/tclWinPipe.c @@ -1,17 +1,17 @@ -/* +/* * tclWinPipe.c -- * - * This file implements the Windows-specific exec pipeline functions, - * the "pipe" channel driver, and the "pid" Tcl command. + * This file implements the Windows-specific exec pipeline functions, the + * "pipe" channel driver, and the "pid" Tcl command. * * Copyright (c) 1996-1997 by Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinPipe.c,v 1.53 2004/12/01 23:18:55 dgp Exp $ + * RCS: @(#) $Id: tclWinPipe.c,v 1.53.2.3 2005/08/02 18:17:18 dgp Exp $ */ #include "tclWinInt.h" #include @@ -24,38 +24,38 @@ */ static int initialized = 0; /* - * The pipeMutex locks around access to the initialized and procList variables, - * and it is used to protect background threads from being terminated while - * they are using APIs that hold locks. + * The pipeMutex locks around access to the initialized and procList + * variables, and it is used to protect background threads from being + * terminated while they are using APIs that hold locks. */ TCL_DECLARE_MUTEX(pipeMutex) /* - * The following defines identify the various types of applications that - * run under windows. There is special case code for the various types. + * The following defines identify the various types of applications that run + * under windows. There is special case code for the various types. */ #define APPL_NONE 0 #define APPL_DOS 1 #define APPL_WIN3X 2 #define APPL_WIN32 3 /* - * The following constants and structures are used to encapsulate the state - * of various types of files used in a pipeline. - * This used to have a 1 && 2 that supported Win32s. + * The following constants and structures are used to encapsulate the state of + * various types of files used in a pipeline. This used to have a 1 && 2 that + * supported Win32s. */ -#define WIN_FILE 3 /* Basic Win32 file. */ +#define WIN_FILE 3 /* Basic Win32 file. */ /* - * This structure encapsulates the common state associated with all file - * types used in a pipeline. + * This structure encapsulates the common state associated with all file types + * used in a pipeline. */ typedef struct WinFile { int type; /* One of the file types defined above. */ HANDLE handle; /* Open file handle. */ @@ -110,80 +110,78 @@ * This value is used by the reader/writer * threads. */ HANDLE writeThread; /* Handle to writer thread. */ HANDLE readThread; /* Handle to reader thread. */ HANDLE writable; /* Manual-reset event to signal when the - * writer thread has finished waiting for - * the current buffer to be written. */ + * writer thread has finished waiting for the + * current buffer to be written. */ HANDLE readable; /* Manual-reset event to signal when the * reader thread has finished waiting for * input. */ HANDLE startWriter; /* Auto-reset event used by the main thread to - * signal when the writer thread should attempt - * to write to the pipe. */ + * signal when the writer thread should + * attempt to write to the pipe. */ HANDLE stopWriter; /* Manual-reset event used to alert the reader * thread to fall-out and exit */ HANDLE startReader; /* Auto-reset event used by the main thread to - * signal when the reader thread should attempt - * to read from the pipe. */ + * signal when the reader thread should + * attempt to read from the pipe. */ HANDLE stopReader; /* Manual-reset event used to alert the reader * thread to fall-out and exit */ DWORD writeError; /* An error caused by the last background - * write. Set to 0 if no error has been - * detected. This word is shared with the + * write. Set to 0 if no error has been + * detected. This word is shared with the * writer thread so access must be * synchronized with the writable object. */ - char *writeBuf; /* Current background output buffer. - * Access is synchronized with the writable - * object. */ - int writeBufLen; /* Size of write buffer. Access is - * synchronized with the writable - * object. */ - int toWrite; /* Current amount to be written. Access is + char *writeBuf; /* Current background output buffer. Access is + * synchronized with the writable object. */ + int writeBufLen; /* Size of write buffer. Access is + * synchronized with the writable object. */ + int toWrite; /* Current amount to be written. Access is * synchronized with the writable object. */ int readFlags; /* Flags that are shared with the reader - * thread. Access is synchronized with the + * thread. Access is synchronized with the * readable object. */ char extraByte; /* Buffer for extra character consumed by - * reader thread. This byte is shared with - * the reader thread so access must be + * reader thread. This byte is shared with the + * reader thread so access must be * synchronized with the readable object. */ } PipeInfo; typedef struct ThreadSpecificData { /* - * The following pointer refers to the head of the list of pipes - * that are being watched for file events. + * The following pointer refers to the head of the list of pipes that are + * being watched for file events. */ - + PipeInfo *firstPipePtr; } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* - * The following structure is what is added to the Tcl event queue when - * pipe events are generated. + * The following structure is what is added to the Tcl event queue when pipe + * events are generated. */ typedef struct PipeEvent { - Tcl_Event header; /* Information that is standard for - * all events. */ - PipeInfo *infoPtr; /* Pointer to pipe info structure. Note - * that we still have to verify that the - * pipe exists before dereferencing this + Tcl_Event header; /* Information that is standard for all + * events. */ + PipeInfo *infoPtr; /* Pointer to pipe info structure. Note that + * we still have to verify that the pipe + * exists before dereferencing this * pointer. */ } PipeEvent; /* * Declarations for functions used only in this file. */ static int ApplicationType(Tcl_Interp *interp, const char *fileName, char *fullName); -static void BuildCommandLine(const char *executable, int argc, +static void BuildCommandLine(const char *executable, int argc, CONST char **argv, Tcl_DString *linePtr); static BOOL HasConsole(void); static int PipeBlockModeProc(ClientData instanceData, int mode); static void PipeCheckProc(ClientData clientData, int flags); static int PipeClose2Proc(ClientData instanceData, @@ -199,22 +197,23 @@ CONST char *buf, int toWrite, int *errorCode); static DWORD WINAPI PipeReaderThread(LPVOID arg); static void PipeSetupProc(ClientData clientData, int flags); static void PipeWatchProc(ClientData instanceData, int mask); static DWORD WINAPI PipeWriterThread(LPVOID arg); -static void ProcExitHandler(ClientData clientData); static int TempFileName(WCHAR name[MAX_PATH]); static int WaitForRead(PipeInfo *infoPtr, int blocking); +static void PipeThreadActionProc(ClientData instanceData, + int action); /* - * This structure describes the channel type structure for command pipe - * based IO. + * This structure describes the channel type structure for command pipe based + * I/O. */ static Tcl_ChannelType pipeChannelType = { "pipe", /* Type name. */ - TCL_CHANNEL_VERSION_2, /* v2 channel */ + TCL_CHANNEL_VERSION_4, /* v4 channel */ TCL_CLOSE2PROC, /* Close proc. */ PipeInputProc, /* Input proc. */ PipeOutputProc, /* Output proc. */ NULL, /* Seek proc. */ NULL, /* Set option proc. */ @@ -223,10 +222,12 @@ PipeGetHandleProc, /* Get an OS handle from channel. */ PipeClose2Proc, /* close2proc */ PipeBlockModeProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ + NULL, /* wide seek proc */ + PipeThreadActionProc, /* thread action proc */ }; /* *---------------------------------------------------------------------- * @@ -247,20 +248,19 @@ PipeInit() { ThreadSpecificData *tsdPtr; /* - * Check the initialized flag first, then check again in the mutex. - * This is a speed enhancement. + * Check the initialized flag first, then check again in the mutex. This + * is a speed enhancement. */ if (!initialized) { Tcl_MutexLock(&pipeMutex); if (!initialized) { initialized = 1; procList = NULL; - Tcl_CreateExitHandler(ProcExitHandler, NULL); } Tcl_MutexUnlock(&pipeMutex); } tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); @@ -275,12 +275,12 @@ /* *---------------------------------------------------------------------- * * PipeExitHandler -- * - * This function is called to cleanup the pipe module before - * Tcl is unloaded. + * This function is called to cleanup the pipe module before Tcl is + * unloaded. * * Results: * None. * * Side effects: @@ -297,14 +297,14 @@ } /* *---------------------------------------------------------------------- * - * ProcExitHandler -- + * TclpFinalizePipes -- * - * This function is called to cleanup the process list before - * Tcl is unloaded. + * This function is called to cleanup the process list before Tcl is + * unloaded. * * Results: * None. * * Side effects: @@ -311,13 +311,12 @@ * Resets the process list. * *---------------------------------------------------------------------- */ -static void -ProcExitHandler( - ClientData clientData) /* Old window proc */ +void +TclpFinalizePipes() { Tcl_MutexLock(&pipeMutex); initialized = 0; Tcl_MutexUnlock(&pipeMutex); } @@ -325,12 +324,12 @@ /* *---------------------------------------------------------------------- * * PipeSetupProc -- * - * This procedure is invoked before Tcl_DoOneEvent blocks waiting - * for an event. + * This function is invoked before Tcl_DoOneEvent blocks waiting for an + * event. * * Results: * None. * * Side effects: @@ -351,16 +350,16 @@ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!(flags & TCL_FILE_EVENTS)) { return; } - + /* * Look to see if any events are already pending. If they are, poll. */ - for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL; + for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (infoPtr->watchMask & TCL_WRITABLE) { filePtr = (WinFile*) infoPtr->writeFile; if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) { block = 0; @@ -381,12 +380,12 @@ /* *---------------------------------------------------------------------- * * PipeCheckProc -- * - * This procedure is called by Tcl_DoOneEvent to check the pipe - * event source for events. + * This function is called by Tcl_DoOneEvent to check the pipe event + * source for events. * * Results: * None. * * Side effects: @@ -407,22 +406,21 @@ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!(flags & TCL_FILE_EVENTS)) { return; } - + /* - * Queue events for any ready pipes that don't already have events - * queued. + * Queue events for any ready pipes that don't already have events queued. */ - for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL; + for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (infoPtr->flags & PIPE_PENDING) { continue; } - + /* * Queue an event if the pipe is signaled for reading or writing. */ needEvent = 0; @@ -429,11 +427,11 @@ filePtr = (WinFile*) infoPtr->writeFile; if ((infoPtr->watchMask & TCL_WRITABLE) && (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT)) { needEvent = 1; } - + filePtr = (WinFile*) infoPtr->readFile; if ((infoPtr->watchMask & TCL_READABLE) && (WaitForRead(infoPtr, 0) >= 0)) { needEvent = 1; } @@ -451,12 +449,12 @@ /* *---------------------------------------------------------------------- * * TclWinMakeFile -- * - * This function constructs a new TclFile from a given data and - * type value. + * This function constructs a new TclFile from a given data and type + * value. * * Results: * Returns a newly allocated WinFile as a TclFile. * * Side effects: @@ -481,36 +479,35 @@ /* *---------------------------------------------------------------------- * * TempFileName -- * - * Gets a temporary file name and deals with the fact that the - * temporary file path provided by Windows may not actually exist - * if the TMP or TEMP environment variables refer to a - * non-existent directory. - * - * Results: - * 0 if error, non-zero otherwise. If non-zero is returned, the - * name buffer will be filled with a name that can be used to - * construct a temporary file. + * Gets a temporary file name and deals with the fact that the temporary + * file path provided by Windows may not actually exist if the TMP or + * TEMP environment variables refer to a non-existent directory. + * + * Results: + * 0 if error, non-zero otherwise. If non-zero is returned, the name + * buffer will be filled with a name that can be used to construct a + * temporary file. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int TempFileName(name) - WCHAR name[MAX_PATH]; /* Buffer in which name for temporary - * file gets stored. */ + WCHAR name[MAX_PATH]; /* Buffer in which name for temporary file + * gets stored. */ { TCHAR *prefix; prefix = (tclWinProcs->useWide) ? (TCHAR *) L"TCL" : (TCHAR *) "TCL"; if ((*tclWinProcs->getTempPathProc)(MAX_PATH, name) != 0) { - if ((*tclWinProcs->getTempFileNameProc)((TCHAR *) name, prefix, 0, + if ((*tclWinProcs->getTempFileNameProc)((TCHAR *) name, prefix, 0, name) != 0) { return 1; } } if (tclWinProcs->useWide) { @@ -518,11 +515,11 @@ ((WCHAR *) name)[1] = '\0'; } else { ((char *) name)[0] = '.'; ((char *) name)[1] = '\0'; } - return (*tclWinProcs->getTempFileNameProc)((TCHAR *) name, prefix, 0, + return (*tclWinProcs->getTempFileNameProc)((TCHAR *) name, prefix, 0, name); } /* *---------------------------------------------------------------------- @@ -545,11 +542,11 @@ Tcl_Channel channel; /* Channel to get file from. */ int direction; /* Either TCL_READABLE or TCL_WRITABLE. */ { HANDLE handle; - if (Tcl_GetChannelHandle(channel, direction, + if (Tcl_GetChannelHandle(channel, direction, (ClientData *) &handle) == TCL_OK) { return TclWinMakeFile(handle); } else { return (TclFile) NULL; } @@ -561,12 +558,12 @@ * TclpOpenFile -- * * This function opens files for use in a pipeline. * * Results: - * Returns a newly allocated TclFile structure containing the - * file handle. + * Returns a newly allocated TclFile structure containing the file + * handle. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -579,52 +576,52 @@ { HANDLE handle; DWORD accessMode, createMode, shareMode, flags; Tcl_DString ds; CONST TCHAR *nativePath; - + /* * Map the access bits to the NT access mode. */ switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { - case O_RDONLY: - accessMode = GENERIC_READ; - break; - case O_WRONLY: - accessMode = GENERIC_WRITE; - break; - case O_RDWR: - accessMode = (GENERIC_READ | GENERIC_WRITE); - break; - default: - TclWinConvertError(ERROR_INVALID_FUNCTION); - return NULL; + case O_RDONLY: + accessMode = GENERIC_READ; + break; + case O_WRONLY: + accessMode = GENERIC_WRITE; + break; + case O_RDWR: + accessMode = (GENERIC_READ | GENERIC_WRITE); + break; + default: + TclWinConvertError(ERROR_INVALID_FUNCTION); + return NULL; } /* * Map the creation flags to the NT create mode. */ switch (mode & (O_CREAT | O_EXCL | O_TRUNC)) { - case (O_CREAT | O_EXCL): - case (O_CREAT | O_EXCL | O_TRUNC): - createMode = CREATE_NEW; - break; - case (O_CREAT | O_TRUNC): - createMode = CREATE_ALWAYS; - break; - case O_CREAT: - createMode = OPEN_ALWAYS; - break; - case O_TRUNC: - case (O_TRUNC | O_EXCL): - createMode = TRUNCATE_EXISTING; - break; - default: - createMode = OPEN_EXISTING; - break; + case (O_CREAT | O_EXCL): + case (O_CREAT | O_EXCL | O_TRUNC): + createMode = CREATE_NEW; + break; + case (O_CREAT | O_TRUNC): + createMode = CREATE_ALWAYS; + break; + case O_CREAT: + createMode = OPEN_ALWAYS; + break; + case O_TRUNC: + case (O_TRUNC | O_EXCL): + createMode = TRUNCATE_EXISTING; + break; + default: + createMode = OPEN_EXISTING; + break; } nativePath = Tcl_WinUtfToTChar(path, -1, &ds); /* @@ -647,30 +644,30 @@ /* * Now we get to create the file. */ - handle = (*tclWinProcs->createFileProc)(nativePath, accessMode, + handle = (*tclWinProcs->createFileProc)(nativePath, accessMode, shareMode, NULL, createMode, flags, NULL); Tcl_DStringFree(&ds); if (handle == INVALID_HANDLE_VALUE) { DWORD err; - + err = GetLastError(); if ((err & 0xffffL) == ERROR_OPEN_FAILED) { err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND; } - TclWinConvertError(err); - return NULL; + TclWinConvertError(err); + return NULL; } /* * Seek to the end of file if we are writing. */ - if (mode & O_WRONLY) { + if (mode & (O_WRONLY|O_APPEND)) { SetFilePointer(handle, 0, NULL, FILE_END); } return TclWinMakeFile(handle); } @@ -678,13 +675,13 @@ /* *---------------------------------------------------------------------- * * TclpCreateTempFile -- * - * This function opens a unique file with the property that it - * will be deleted when its file handle is closed. The temporary - * file is created in the system temporary directory. + * This function opens a unique file with the property that it will be + * deleted when its file handle is closed. The temporary file is created + * in the system temporary directory. * * Results: * Returns a valid TclFile, or NULL on failure. * * Side effects: @@ -704,12 +701,12 @@ if (TempFileName(name) == 0) { return NULL; } - handle = (*tclWinProcs->createFileProc)((TCHAR *) name, - GENERIC_READ | GENERIC_WRITE, 0, NULL, CREATE_ALWAYS, + handle = (*tclWinProcs->createFileProc)((TCHAR *) name, + GENERIC_READ | GENERIC_WRITE, 0, NULL, CREATE_ALWAYS, FILE_ATTRIBUTE_TEMPORARY|FILE_FLAG_DELETE_ON_CLOSE, NULL); if (handle == INVALID_HANDLE_VALUE) { goto error; } @@ -722,12 +719,13 @@ CONST char *p; /* * Convert the contents from UTF to native encoding */ + native = Tcl_UtfToExternalDString(NULL, contents, -1, &dstring); - + for (p = native; *p != '\0'; p++) { if (*p == '\n') { length = p - native; if (length > 0) { if (!WriteFile(handle, native, length, &result, NULL)) { @@ -753,11 +751,14 @@ } return TclWinMakeFile(handle); error: - /* Free the native representation of the contents if necessary */ + /* + * Free the native representation of the contents if necessary. + */ + if (contents != NULL) { Tcl_DStringFree(&dstring); } TclWinConvertError(GetLastError()); @@ -780,11 +781,11 @@ * None. * *---------------------------------------------------------------------- */ -Tcl_Obj* +Tcl_Obj* TclpTempFileName() { WCHAR fileName[MAX_PATH]; if (TempFileName(fileName) == 0) { @@ -797,27 +798,27 @@ /* *---------------------------------------------------------------------- * * TclpCreatePipe -- * - * Creates an anonymous pipe. + * Creates an anonymous pipe. * * Results: - * Returns 1 on success, 0 on failure. + * Returns 1 on success, 0 on failure. * * Side effects: - * Creates a pipe. + * Creates a pipe. * *---------------------------------------------------------------------- */ int TclpCreatePipe( - TclFile *readPipe, /* Location to store file handle for - * read side of pipe. */ - TclFile *writePipe) /* Location to store file handle for - * write side of pipe. */ + TclFile *readPipe, /* Location to store file handle for read side + * of pipe. */ + TclFile *writePipe) /* Location to store file handle for write + * side of pipe. */ { HANDLE readHandle, writeHandle; if (CreatePipe(&readHandle, &writeHandle, NULL, 0) != 0) { *readPipe = TclWinMakeFile(readHandle); @@ -832,11 +833,11 @@ /* *---------------------------------------------------------------------- * * TclpCloseFile -- * - * Closes a pipeline file handle. These handles are created by + * Closes a pipeline file handle. These handles are created by * TclpOpenFile, TclpCreatePipe, or TclpMakeFile. * * Results: * 0 on success, -1 on failure. * @@ -846,37 +847,37 @@ *---------------------------------------------------------------------- */ int TclpCloseFile( - TclFile file) /* The file to close. */ + TclFile file) /* The file to close. */ { WinFile *filePtr = (WinFile *) file; switch (filePtr->type) { - case WIN_FILE: - /* - * Don't close the Win32 handle if the handle is a standard channel - * during the thread exit process. Otherwise, one thread may kill - * the stdio of another. - */ - - if (!TclInThreadExit() - || ((GetStdHandle(STD_INPUT_HANDLE) != filePtr->handle) - && (GetStdHandle(STD_OUTPUT_HANDLE) != filePtr->handle) - && (GetStdHandle(STD_ERROR_HANDLE) != filePtr->handle))) { - if (filePtr->handle != NULL && - CloseHandle(filePtr->handle) == FALSE) { - TclWinConvertError(GetLastError()); - ckfree((char *) filePtr); - return -1; - } - } - break; - - default: - Tcl_Panic("TclpCloseFile: unexpected file type"); + case WIN_FILE: + /* + * Don't close the Win32 handle if the handle is a standard channel + * during the thread exit process. Otherwise, one thread may kill the + * stdio of another. + */ + + if (!TclInThreadExit() + || ((GetStdHandle(STD_INPUT_HANDLE) != filePtr->handle) + && (GetStdHandle(STD_OUTPUT_HANDLE) != filePtr->handle) + && (GetStdHandle(STD_ERROR_HANDLE) != filePtr->handle))) { + if (filePtr->handle != NULL && + CloseHandle(filePtr->handle) == FALSE) { + TclWinConvertError(GetLastError()); + ckfree((char *) filePtr); + return -1; + } + } + break; + + default: + Tcl_Panic("TclpCloseFile: unexpected file type"); } ckfree((char *) filePtr); return 0; } @@ -888,13 +889,13 @@ * * Given a HANDLE to a child process, return the process id for that * child process. * * Results: - * Returns the process id for the child process. If the pid was not - * known by Tcl, either because the pid was not created by Tcl or the - * child process has already been reaped, -1 is returned. + * Returns the process id for the child process. If the pid was not known + * by Tcl, either because the pid was not created by Tcl or the child + * process has already been reaped, -1 is returned. * * Side effects: * None. * *-------------------------------------------------------------------------- @@ -922,29 +923,29 @@ /* *---------------------------------------------------------------------- * * TclpCreateProcess -- * - * Create a child process that has the specified files as its - * standard input, output, and error. The child process runs - * asynchronously under Windows NT and Windows 9x, and runs - * with the same environment variables as the creating process. - * - * The complete Windows search path is searched to find the specified - * executable. If an executable by the given name is not found, - * automatically tries appending ".com", ".exe", and ".bat" to the + * Create a child process that has the specified files as its standard + * input, output, and error. The child process runs asynchronously under + * Windows NT and Windows 9x, and runs with the same environment + * variables as the creating process. + * + * The complete Windows search path is searched to find the specified + * executable. If an executable by the given name is not found, + * automatically tries appending ".com", ".exe", and ".bat" to the * executable name. * * Results: - * The return value is TCL_ERROR and an error message is left in - * the interp's result if there was a problem creating the child - * process. Otherwise, the return value is TCL_OK and *pidPtr is - * filled with the process id of the child process. - * + * The return value is TCL_ERROR and an error message is left in the + * interp's result if there was a problem creating the child process. + * Otherwise, the return value is TCL_OK and *pidPtr is filled with the + * process id of the child process. + * * Side effects: * A process is created. - * + * *---------------------------------------------------------------------- */ int TclpCreateProcess( @@ -951,31 +952,31 @@ Tcl_Interp *interp, /* Interpreter in which to leave errors that * occurred when creating the child process. * Error messages from the child process * itself are sent to errorFile. */ int argc, /* Number of arguments in following array. */ - CONST char **argv, /* Array of argument strings. argv[0] - * contains the name of the executable - * converted to native format (using the - * Tcl_TranslateFileName call). Additional + CONST char **argv, /* Array of argument strings. argv[0] contains + * the name of the executable converted to + * native format (using the + * Tcl_TranslateFileName call). Additional * arguments have not been converted. */ - TclFile inputFile, /* If non-NULL, gives the file to use as - * input for the child process. If inputFile - * file is not readable or is NULL, the child - * will receive no standard input. */ - TclFile outputFile, /* If non-NULL, gives the file that - * receives output from the child process. If + TclFile inputFile, /* If non-NULL, gives the file to use as input + * for the child process. If inputFile file is + * not readable or is NULL, the child will + * receive no standard input. */ + TclFile outputFile, /* If non-NULL, gives the file that receives + * output from the child process. If * outputFile file is not writeable or is * NULL, output from the child will be * discarded. */ - TclFile errorFile, /* If non-NULL, gives the file that - * receives errors from the child process. If - * errorFile file is not writeable or is NULL, - * errors from the child will be discarded. - * errorFile may be the same as outputFile. */ - Tcl_Pid *pidPtr) /* If this procedure is successful, pidPtr - * is filled with the process id of the child + TclFile errorFile, /* If non-NULL, gives the file that receives + * errors from the child process. If errorFile + * file is not writeable or is NULL, errors + * from the child will be discarded. errorFile + * may be the same as outputFile. */ + Tcl_Pid *pidPtr) /* If this function is successful, pidPtr is + * filled with the process id of the child * process. */ { int result, applType, createFlags; Tcl_DString cmdLine; /* Complete command line (TCHAR). */ STARTUPINFOA startInfo; @@ -996,28 +997,28 @@ Tcl_DStringInit(&cmdLine); hProcess = GetCurrentProcess(); /* * STARTF_USESTDHANDLES must be used to pass handles to child process. - * Using SetStdHandle() and/or dup2() only works when a console mode + * Using SetStdHandle() and/or dup2() only works when a console mode * parent process is spawning an attached console mode child process. */ ZeroMemory(&startInfo, sizeof(startInfo)); startInfo.cb = sizeof(startInfo); - startInfo.dwFlags = STARTF_USESTDHANDLES; + startInfo.dwFlags = STARTF_USESTDHANDLES; startInfo.hStdInput = INVALID_HANDLE_VALUE; startInfo.hStdOutput= INVALID_HANDLE_VALUE; startInfo.hStdError = INVALID_HANDLE_VALUE; secAtts.nLength = sizeof(SECURITY_ATTRIBUTES); secAtts.lpSecurityDescriptor = NULL; secAtts.bInheritHandle = TRUE; /* - * We have to check the type of each file, since we cannot duplicate - * some file types. + * We have to check the type of each file, since we cannot duplicate some + * file types. */ inputHandle = INVALID_HANDLE_VALUE; if (inputFile != NULL) { filePtr = (WinFile *)inputFile; @@ -1039,27 +1040,26 @@ errorHandle = filePtr->handle; } } /* - * Duplicate all the handles which will be passed off as stdin, stdout - * and stderr of the child process. The duplicate handles are set to - * be inheritable, so the child process can use them. + * Duplicate all the handles which will be passed off as stdin, stdout and + * stderr of the child process. The duplicate handles are set to be + * inheritable, so the child process can use them. */ if (inputHandle == INVALID_HANDLE_VALUE) { - /* - * If handle was not set, stdin should return immediate EOF. - * Under Windows95, some applications (both 16 and 32 bit!) - * cannot read from the NUL device; they read from console - * instead. When running tk, this is fatal because the child - * process would hang forever waiting for EOF from the unmapped - * console window used by the helper application. - * - * Fortunately, the helper application detects a closed pipe - * as an immediate EOF and can pass that information to the - * child process. + /* + * If handle was not set, stdin should return immediate EOF. Under + * Windows95, some applications (both 16 and 32 bit!) cannot read from + * the NUL device; they read from console instead. When running tk, + * this is fatal because the child process would hang forever waiting + * for EOF from the unmapped console window used by the helper + * application. + * + * Fortunately, the helper application detects a closed pipe as an + * immediate EOF and can pass that information to the child process. */ if (CreatePipe(&startInfo.hStdInput, &h, &secAtts, 0) != FALSE) { CloseHandle(h); } @@ -1074,36 +1074,35 @@ goto end; } if (outputHandle == INVALID_HANDLE_VALUE) { /* - * If handle was not set, output should be sent to an infinitely - * deep sink. Under Windows 95, some 16 bit applications cannot - * have stdout redirected to NUL; they send their output to - * the console instead. Some applications, like "more" or "dir /p", - * when outputting multiple pages to the console, also then try and - * read from the console to go the next page. When running tk, this - * is fatal because the child process would hang forever waiting - * for input from the unmapped console window used by the helper - * application. - * - * Fortunately, the helper application will detect a closed pipe - * as a sink. - */ - - if ((TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS) + * If handle was not set, output should be sent to an infinitely deep + * sink. Under Windows 95, some 16 bit applications cannot have stdout + * redirected to NUL; they send their output to the console instead. + * Some applications, like "more" or "dir /p", when outputting + * multiple pages to the console, also then try and read from the + * console to go the next page. When running tk, this is fatal because + * the child process would hang forever waiting for input from the + * unmapped console window used by the helper application. + * + * Fortunately, the helper application will detect a closed pipe as a + * sink. + */ + + if ((TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS) && (applType == APPL_DOS)) { if (CreatePipe(&h, &startInfo.hStdOutput, &secAtts, 0) != FALSE) { CloseHandle(h); } } else { startInfo.hStdOutput = CreateFileA("NUL:", GENERIC_WRITE, 0, &secAtts, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL); } } else { - DuplicateHandle(hProcess, outputHandle, hProcess, &startInfo.hStdOutput, - 0, TRUE, DUPLICATE_SAME_ACCESS); + DuplicateHandle(hProcess, outputHandle, hProcess, + &startInfo.hStdOutput, 0, TRUE, DUPLICATE_SAME_ACCESS); } if (startInfo.hStdOutput == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); Tcl_AppendResult(interp, "couldn't duplicate output handle: ", Tcl_PosixError(interp), (char *) NULL); @@ -1110,94 +1109,93 @@ goto end; } if (errorHandle == INVALID_HANDLE_VALUE) { /* - * If handle was not set, errors should be sent to an infinitely - * deep sink. + * If handle was not set, errors should be sent to an infinitely deep + * sink. */ startInfo.hStdError = CreateFileA("NUL:", GENERIC_WRITE, 0, &secAtts, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); } else { - DuplicateHandle(hProcess, errorHandle, hProcess, &startInfo.hStdError, + DuplicateHandle(hProcess, errorHandle, hProcess, &startInfo.hStdError, 0, TRUE, DUPLICATE_SAME_ACCESS); - } + } if (startInfo.hStdError == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); Tcl_AppendResult(interp, "couldn't duplicate error handle: ", Tcl_PosixError(interp), (char *) NULL); goto end; } - /* - * If we do not have a console window, then we must run DOS and - * WIN32 console mode applications as detached processes. This tells - * the loader that the child application should not inherit the - * console, and that it should not create a new console window for - * the child application. The child application should get its stdio - * from the redirection handles provided by this application, and run - * in the background. - * - * If we are starting a GUI process, they don't automatically get a - * console, so it doesn't matter if they are started as foreground or - * detached processes. The GUI window will still pop up to the - * foreground. + + /* + * If we do not have a console window, then we must run DOS and WIN32 + * console mode applications as detached processes. This tells the loader + * that the child application should not inherit the console, and that it + * should not create a new console window for the child application. The + * child application should get its stdio from the redirection handles + * provided by this application, and run in the background. + * + * If we are starting a GUI process, they don't automatically get a + * console, so it doesn't matter if they are started as foreground or + * detached processes. The GUI window will still pop up to the foreground. */ if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) { if (HasConsole()) { createFlags = 0; } else if (applType == APPL_DOS) { /* - * Under NT, 16-bit DOS applications will not run unless they - * can be attached to a console. If we are running without a - * console, run the 16-bit program as an normal process inside - * of a hidden console application, and then run that hidden - * console as a detached process. + * Under NT, 16-bit DOS applications will not run unless they can + * be attached to a console. If we are running without a console, + * run the 16-bit program as an normal process inside of a hidden + * console application, and then run that hidden console as a + * detached process. */ startInfo.wShowWindow = SW_HIDE; startInfo.dwFlags |= STARTF_USESHOWWINDOW; createFlags = CREATE_NEW_CONSOLE; Tcl_DStringAppend(&cmdLine, "cmd.exe /c", -1); } else { createFlags = DETACHED_PROCESS; - } + } } else { if (HasConsole()) { createFlags = 0; } else { createFlags = DETACHED_PROCESS; } - + if (applType == APPL_DOS) { /* - * Under Windows 95, 16-bit DOS applications do not work well - * with pipes: - * - * 1. EOF on a pipe between a detached 16-bit DOS application - * and another application is not seen at the other - * end of the pipe, so the listening process blocks forever on - * reads. This inablity to detect EOF happens when either a - * 16-bit app or the 32-bit app is the listener. - * - * 2. If a 16-bit DOS application (detached or not) blocks when + * Under Windows 95, 16-bit DOS applications do not work well with + * pipes: + * + * 1. EOF on a pipe between a detached 16-bit DOS application and + * another application is not seen at the other end of the pipe, + * so the listening process blocks forever on reads. This inablity + * to detect EOF happens when either a 16-bit app or the 32-bit + * app is the listener. + * + * 2. If a 16-bit DOS application (detached or not) blocks when * writing to a pipe, it will never wake up again, and it * eventually brings the whole system down around it. * - * The 16-bit application is run as a normal process inside - * of a hidden helper console app, and this helper may be run - * as a detached process. If any of the stdio handles is - * a pipe, the helper application accumulates information - * into temp files and forwards it to or from the DOS - * application as appropriate. This means that DOS apps - * must receive EOF from a stdin pipe before they will actually - * begin, and must finish generating stdout or stderr before - * the data will be sent to the next stage of the pipe. - * - * The helper app should be located in the same directory as - * the tcl dll. + * The 16-bit application is run as a normal process inside of a + * hidden helper console app, and this helper may be run as a + * detached process. If any of the stdio handles is a pipe, the + * helper application accumulates information into temp files and + * forwards it to or from the DOS application as appropriate. + * This means that DOS apps must receive EOF from a stdin pipe + * before they will actually begin, and must finish generating + * stdout or stderr before the data will be sent to the next stage + * of the pipe. + * + * The helper app should be located in the same directory as the + * tcl dll. */ if (createFlags != 0) { startInfo.wShowWindow = SW_HIDE; startInfo.dwFlags |= STARTF_USESHOWWINDOW; @@ -1207,17 +1205,18 @@ { Tcl_Obj *tclExePtr, *pipeDllPtr; int i, fileExists; char *start,*end; Tcl_DString pipeDll; + Tcl_DStringInit(&pipeDll); Tcl_DStringAppend(&pipeDll, TCL_PIPE_DLL, -1); tclExePtr = TclGetObjNameOfExecutable(); start = Tcl_GetStringFromObj(tclExePtr, &i); for (end = start + (i-1); end > start; end--) { if (*end == '/') { - break; + break; } } if (*end != '/') { Tcl_Panic("no / in executable path name"); } @@ -1229,66 +1228,64 @@ Tcl_Panic("Tcl_FSConvertToPathType failed"); } fileExists = (Tcl_FSAccess(pipeDllPtr, F_OK) == 0); if (!fileExists) { Tcl_Panic("Tcl pipe dll \"%s\" not found", - Tcl_DStringValue(&pipeDll)); + Tcl_DStringValue(&pipeDll)); } Tcl_DStringAppend(&cmdLine, Tcl_DStringValue(&pipeDll), -1); Tcl_DecrRefCount(tclExePtr); Tcl_DecrRefCount(pipeDllPtr); Tcl_DStringFree(&pipeDll); } } } - + /* * cmdLine gets the full command line used to invoke the executable, - * including the name of the executable itself. The command line - * arguments in argv[] are stored in cmdLine separated by spaces. - * Special characters in individual arguments from argv[] must be - * quoted when being stored in cmdLine. - * - * When calling any application, bear in mind that arguments that - * specify a path name are not converted. If an argument contains - * forward slashes as path separators, it may or may not be - * recognized as a path name, depending on the program. In general, - * most applications accept forward slashes only as option - * delimiters and backslashes only as paths. - * - * Additionally, when calling a 16-bit dos or windows application, - * all path names must use the short, cryptic, path format (e.g., - * using ab~1.def instead of "a b.default"). + * including the name of the executable itself. The command line arguments + * in argv[] are stored in cmdLine separated by spaces. Special characters + * in individual arguments from argv[] must be quoted when being stored in + * cmdLine. + * + * When calling any application, bear in mind that arguments that specify + * a path name are not converted. If an argument contains forward slashes + * as path separators, it may or may not be recognized as a path name, + * depending on the program. In general, most applications accept forward + * slashes only as option delimiters and backslashes only as paths. + * + * Additionally, when calling a 16-bit dos or windows application, all + * path names must use the short, cryptic, path format (e.g., using + * ab~1.def instead of "a b.default"). */ BuildCommandLine(execPath, argc, argv, &cmdLine); - if ((*tclWinProcs->createProcessProc)(NULL, - (TCHAR *) Tcl_DStringValue(&cmdLine), NULL, NULL, TRUE, + if ((*tclWinProcs->createProcessProc)(NULL, + (TCHAR *) Tcl_DStringValue(&cmdLine), NULL, NULL, TRUE, (DWORD) createFlags, NULL, NULL, &startInfo, &procInfo) == 0) { TclWinConvertError(GetLastError()); Tcl_AppendResult(interp, "couldn't execute \"", argv[0], "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } /* - * This wait is used to force the OS to give some time to the DOS - * process. + * This wait is used to force the OS to give some time to the DOS process. */ if (applType == APPL_DOS) { WaitForSingleObject(procInfo.hProcess, 50); } - /* - * "When an application spawns a process repeatedly, a new thread - * instance will be created for each process but the previous - * instances may not be cleaned up. This results in a significant - * virtual memory loss each time the process is spawned. If there - * is a WaitForInputIdle() call between CreateProcess() and - * CloseHandle(), the problem does not occur." PSS ID Number: Q124121 + /* + * "When an application spawns a process repeatedly, a new thread instance + * will be created for each process but the previous instances may not be + * cleaned up. This results in a significant virtual memory loss each time + * the process is spawned. If there is a WaitForInputIdle() call between + * CreateProcess() and CloseHandle(), the problem does not occur." PSS ID + * Number: Q124121 */ WaitForInputIdle(procInfo.hProcess, 5000); CloseHandle(procInfo.hThread); @@ -1296,17 +1293,17 @@ if (*pidPtr != 0) { TclWinAddProcess(procInfo.hProcess, procInfo.dwProcessId); } result = TCL_OK; - end: + end: Tcl_DStringFree(&cmdLine); if (startInfo.hStdInput != INVALID_HANDLE_VALUE) { - CloseHandle(startInfo.hStdInput); + CloseHandle(startInfo.hStdInput); } if (startInfo.hStdOutput != INVALID_HANDLE_VALUE) { - CloseHandle(startInfo.hStdOutput); + CloseHandle(startInfo.hStdOutput); } if (startInfo.hStdError != INVALID_HANDLE_VALUE) { CloseHandle(startInfo.hStdError); } return result; @@ -1316,12 +1313,11 @@ /* *---------------------------------------------------------------------- * * HasConsole -- * - * Determines whether the current application is attached to a - * console. + * Determines whether the current application is attached to a console. * * Results: * Returns TRUE if this application has a console, else FALSE. * * Side effects: @@ -1332,51 +1328,50 @@ static BOOL HasConsole() { HANDLE handle; - + handle = CreateFileA("CONOUT$", GENERIC_WRITE, FILE_SHARE_WRITE, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); if (handle != INVALID_HANDLE_VALUE) { - CloseHandle(handle); + CloseHandle(handle); return TRUE; } else { - return FALSE; + return FALSE; } } /* *-------------------------------------------------------------------- * * ApplicationType -- * * Search for the specified program and identify if it refers to a DOS, - * Windows 3.X, or Win32 program. Used to determine how to invoke - * a program, or if it can even be invoked. - * - * It is possible to almost positively identify DOS and Windows - * applications that contain the appropriate magic numbers. However, - * DOS .com files do not seem to contain a magic number; if the program - * name ends with .com and could not be identified as a Windows .com - * file, it will be assumed to be a DOS application, even if it was - * just random data. If the program name does not end with .com, no - * such assumption is made. - * - * The Win32 procedure GetBinaryType incorrectly identifies any - * junk file that ends with .exe as a dos executable and some - * executables that don't end with .exe as not executable. Plus it - * doesn't exist under win95, so I won't feel bad about reimplementing - * functionality. + * Windows 3.X, or Win32 program. Used to determine how to invoke a + * program, or if it can even be invoked. + * + * It is possible to almost positively identify DOS and Windows + * applications that contain the appropriate magic numbers. However, DOS + * .com files do not seem to contain a magic number; if the program name + * ends with .com and could not be identified as a Windows .com file, it + * will be assumed to be a DOS application, even if it was just random + * data. If the program name does not end with .com, no such assumption + * is made. + * + * The Win32 function GetBinaryType incorrectly identifies any junk file + * that ends with .exe as a dos executable and some executables that + * don't end with .exe as not executable. Plus it doesn't exist under + * win95, so I won't feel bad about reimplementing functionality. * * Results: - * The return value is one of APPL_DOS, APPL_WIN3X, or APPL_WIN32 - * if the filename referred to the corresponding application type. - * If the file name could not be found or did not refer to any known - * application type, APPL_NONE is returned and an error message is - * left in interp. .bat files are identified as APPL_DOS. + * The return value is one of APPL_DOS, APPL_WIN3X, or APPL_WIN32 if the + * filename referred to the corresponding application type. If the file + * name could not be found or did not refer to any known application + * type, APPL_NONE is returned and an error message is left in interp. + * .bat files are identified as APPL_DOS. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -1384,11 +1379,11 @@ static int ApplicationType(interp, originalName, fullName) Tcl_Interp *interp; /* Interp, for error message. */ const char *originalName; /* Name of the application to find. */ - char fullName[]; /* Filled with complete path to + char fullName[]; /* Filled with complete path to * application. */ { int applType, i, nameLen, found; HANDLE hFile; TCHAR *rest; @@ -1399,21 +1394,21 @@ Tcl_DString nameBuf, ds; CONST TCHAR *nativeName; WCHAR nativeFullPath[MAX_PATH]; static char extensions[][5] = {"", ".com", ".exe", ".bat"}; - /* Look for the program as an external program. First try the name - * as it is, then try adding .com, .exe, and .bat, in that order, to - * the name, looking for an executable. - * - * Using the raw SearchPath() procedure doesn't do quite what is - * necessary. If the name of the executable already contains a '.' - * character, it will not try appending the specified extension when - * searching (in other words, SearchPath will not find the program - * "a.b.exe" if the arguments specified "a.b" and ".exe"). - * So, first look for the file as it is named. Then manually append - * the extensions, looking for a match. + /* + * Look for the program as an external program. First try the name as it + * is, then try adding .com, .exe, and .bat, in that order, to the name, + * looking for an executable. + * + * Using the raw SearchPath() function doesn't do quite what is necessary. + * If the name of the executable already contains a '.' character, it will + * not try appending the specified extension when searching (in other + * words, SearchPath will not find the program "a.b.exe" if the arguments + * specified "a.b" and ".exe"). So, first look for the file as it is + * named. Then manually append the extensions, looking for a match. */ applType = APPL_NONE; Tcl_DStringInit(&nameBuf); Tcl_DStringAppend(&nameBuf, originalName, -1); @@ -1420,22 +1415,22 @@ nameLen = Tcl_DStringLength(&nameBuf); for (i = 0; i < (int) (sizeof(extensions) / sizeof(extensions[0])); i++) { Tcl_DStringSetLength(&nameBuf, nameLen); Tcl_DStringAppend(&nameBuf, extensions[i], -1); - nativeName = Tcl_WinUtfToTChar(Tcl_DStringValue(&nameBuf), + nativeName = Tcl_WinUtfToTChar(Tcl_DStringValue(&nameBuf), Tcl_DStringLength(&nameBuf), &ds); - found = (*tclWinProcs->searchPathProc)(NULL, nativeName, NULL, + found = (*tclWinProcs->searchPathProc)(NULL, nativeName, NULL, MAX_PATH, nativeFullPath, &rest); Tcl_DStringFree(&ds); if (found == 0) { continue; } /* - * Ignore matches on directories or data files, return if identified - * a known type. + * Ignore matches on directories or data files, return if identified a + * known type. */ attr = (*tclWinProcs->getFileAttributesProc)((TCHAR *) nativeFullPath); if ((attr == 0xffffffff) || (attr & FILE_ATTRIBUTE_DIRECTORY)) { continue; @@ -1446,27 +1441,27 @@ ext = strrchr(fullName, '.'); if ((ext != NULL) && (stricmp(ext, ".bat") == 0)) { applType = APPL_DOS; break; } - - hFile = (*tclWinProcs->createFileProc)((TCHAR *) nativeFullPath, - GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING, + + hFile = (*tclWinProcs->createFileProc)((TCHAR *) nativeFullPath, + GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); if (hFile == INVALID_HANDLE_VALUE) { continue; } header.e_magic = 0; ReadFile(hFile, (void *) &header, sizeof(header), &read, NULL); if (header.e_magic != IMAGE_DOS_SIGNATURE) { - /* - * Doesn't have the magic number for relocatable executables. If + /* + * Doesn't have the magic number for relocatable executables. If * filename ends with .com, assume it's a DOS application anyhow. * Note that we didn't make this assumption at first, because some * supposed .com files are really 32-bit executables with all the - * magic numbers and everything. + * magic numbers and everything. */ CloseHandle(hFile); if ((ext != NULL) && (stricmp(ext, ".com") == 0)) { applType = APPL_DOS; @@ -1473,22 +1468,22 @@ break; } continue; } if (header.e_lfarlc != sizeof(header)) { - /* + /* * All Windows 3.X and Win32 and some DOS programs have this value - * set here. If it doesn't, assume that since it already had the + * set here. If it doesn't, assume that since it already had the * other magic number it was a DOS application. */ CloseHandle(hFile); applType = APPL_DOS; break; } - /* + /* * The DWORD at header.e_lfanew points to yet another magic number. */ buf[0] = '\0'; SetFilePointer(hFile, header.e_lfanew, NULL, FILE_BEGIN); @@ -1499,15 +1494,15 @@ applType = APPL_WIN3X; } else if ((buf[0] == 'P') && (buf[1] == 'E')) { applType = APPL_WIN32; } else { /* - * Strictly speaking, there should be a test that there - * is an 'L' and 'E' at buf[0..1], to identify the type as - * DOS, but of course we ran into a DOS executable that - * _doesn't_ have the magic number -- specifically, one - * compiled using the Lahey Fortran90 compiler. + * Strictly speaking, there should be a test that there is an 'L' + * and 'E' at buf[0..1], to identify the type as DOS, but of + * course we ran into a DOS executable that _doesn't_ have the + * magic number - specifically, one compiled using the Lahey + * Fortran90 compiler. */ applType = APPL_DOS; } break; @@ -1520,34 +1515,34 @@ "\": ", Tcl_PosixError(interp), (char *) NULL); return APPL_NONE; } if ((applType == APPL_DOS) || (applType == APPL_WIN3X)) { - /* - * Replace long path name of executable with short path name for - * 16-bit applications. Otherwise the application may not be able - * to correctly parse its own command line to separate off the + /* + * Replace long path name of executable with short path name for + * 16-bit applications. Otherwise the application may not be able to + * correctly parse its own command line to separate off the * application name from the arguments. */ - (*tclWinProcs->getShortPathNameProc)((TCHAR *) nativeFullPath, + (*tclWinProcs->getShortPathNameProc)((TCHAR *) nativeFullPath, nativeFullPath, MAX_PATH); strcpy(fullName, Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds)); Tcl_DStringFree(&ds); } return applType; } -/* +/* *---------------------------------------------------------------------- * * BuildCommandLine -- * - * The command line arguments are stored in linePtr separated - * by spaces, in a form that CreateProcess() understands. Special - * characters in individual arguments from argv[] must be quoted - * when being stored in cmdLine. + * The command line arguments are stored in linePtr separated by spaces, + * in a form that CreateProcess() understands. Special characters in + * individual arguments from argv[] must be quoted when being stored in + * cmdLine. * * Results: * None. * * Side effects: @@ -1556,12 +1551,12 @@ *---------------------------------------------------------------------- */ static void BuildCommandLine( - CONST char *executable, /* Full path of executable (including - * extension). Replacement for argv[0]. */ + CONST char *executable, /* Full path of executable (including + * extension). Replacement for argv[0]. */ int argc, /* Number of arguments. */ CONST char **argv, /* Argument strings in UTF. */ Tcl_DString *linePtr) /* Initialized Tcl_DString that receives the * command line (TCHAR). */ { @@ -1570,12 +1565,11 @@ Tcl_DString ds; Tcl_DStringInit(&ds); /* - * Prime the path. Add a space separator if we were primed with - * something. + * Prime the path. Add a space separator if we were primed with something. */ Tcl_DStringAppend(&ds, Tcl_DStringValue(linePtr), -1); if (Tcl_DStringLength(linePtr) > 0) { Tcl_DStringAppend(&ds, " ", 1); @@ -1594,32 +1588,32 @@ quote = 1; } else { int count; Tcl_UniChar ch; for (start = arg; *start != '\0'; start += count) { - count = Tcl_UtfToUniChar(start, &ch); + count = Tcl_UtfToUniChar(start, &ch); if (Tcl_UniCharIsSpace(ch)) { /* INTL: ISO space. */ quote = 1; break; } } } if (quote) { Tcl_DStringAppend(&ds, "\"", 1); } - start = arg; + start = arg; for (special = arg; ; ) { if ((*special == '\\') && (special[1] == '\\' || special[1] == '"' || (quote && special[1] == '\0'))) { Tcl_DStringAppend(&ds, start, (int) (special - start)); start = special; while (1) { special++; if (*special == '"' || (quote && *special == '\0')) { - /* - * N backslashes followed a quote -> insert - * N * 2 + 1 backslashes then a quote. + /* + * N backslashes followed a quote -> insert N * 2 + 1 + * backslashes then a quote. */ Tcl_DStringAppend(&ds, start, (int) (special - start)); break; @@ -1654,13 +1648,12 @@ /* *---------------------------------------------------------------------- * * TclpCreateCommandChannel -- * - * This function is called by Tcl_OpenCommandChannel to perform - * the platform specific channel initialization for a command - * channel. + * This function is called by Tcl_OpenCommandChannel to perform the + * platform specific channel initialization for a command channel. * * Results: * Returns a new channel or NULL on failure. * * Side effects: @@ -1694,14 +1687,14 @@ infoPtr->numPids = numPids; infoPtr->pidPtr = pidPtr; infoPtr->writeBuf = 0; infoPtr->writeBufLen = 0; infoPtr->writeError = 0; + infoPtr->channel = (Tcl_Channel) NULL; /* - * Use one of the fds associated with the channel as the - * channel id. + * Use one of the fds associated with the channel as the channel id. */ if (readFile) { channelId = (int) ((WinFile*)readFile)->handle; } else if (writeFile) { @@ -1724,12 +1717,12 @@ infoPtr->readable = CreateEvent(NULL, TRUE, TRUE, NULL); infoPtr->startReader = CreateEvent(NULL, FALSE, FALSE, NULL); infoPtr->stopReader = CreateEvent(NULL, TRUE, FALSE, NULL); infoPtr->readThread = CreateThread(NULL, 256, PipeReaderThread, infoPtr, 0, &id); - SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST); - infoPtr->validMask |= TCL_READABLE; + SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST); + infoPtr->validMask |= TCL_READABLE; } else { infoPtr->readThread = 0; } if (writeFile != NULL) { /* @@ -1739,30 +1732,29 @@ infoPtr->writable = CreateEvent(NULL, TRUE, TRUE, NULL); infoPtr->startWriter = CreateEvent(NULL, FALSE, FALSE, NULL); infoPtr->stopWriter = CreateEvent(NULL, TRUE, FALSE, NULL); infoPtr->writeThread = CreateThread(NULL, 256, PipeWriterThread, infoPtr, 0, &id); - SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST); - infoPtr->validMask |= TCL_WRITABLE; + SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST); + infoPtr->validMask |= TCL_WRITABLE; } /* - * For backward compatibility with previous versions of Tcl, we - * use "file%d" as the base name for pipes even though it would - * be more natural to use "pipe%d". - * Use the pointer to keep the channel names unique, in case - * channels share handles (stdin/stdout). + * For backward compatibility with previous versions of Tcl, we use + * "file%d" as the base name for pipes even though it would be more + * natural to use "pipe%d". Use the pointer to keep the channel names + * unique, in case channels share handles (stdin/stdout). */ wsprintfA(channelName, "file%lx", infoPtr); infoPtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName, - (ClientData) infoPtr, infoPtr->validMask); + (ClientData) infoPtr, infoPtr->validMask); /* * Pipes have AUTO translation mode on Windows and ^Z eof char, which - * means that a ^Z will be appended to them at close. This is needed - * for Windows programs that expect a ^Z at EOF. + * means that a ^Z will be appended to them at close. This is needed for + * Windows programs that expect a ^Z at EOF. */ Tcl_SetChannelOption((Tcl_Interp *) NULL, infoPtr->channel, "-translation", "auto"); Tcl_SetChannelOption((Tcl_Interp *) NULL, infoPtr->channel, @@ -1773,12 +1765,12 @@ /* *---------------------------------------------------------------------- * * TclGetAndDetachPids -- * - * Stores a list of the command PIDs for a command channel in - * the interp's result. + * Stores a list of the command PIDs for a command channel in the + * interp's result. * * Results: * None. * * Side effects: @@ -1801,22 +1793,22 @@ * Punt if the channel is not a command channel. */ chanTypePtr = Tcl_GetChannelType(chan); if (chanTypePtr != &pipeChannelType) { - return; + return; } pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan); for (i = 0; i < pipePtr->numPids; i++) { - wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i])); - Tcl_AppendElement(interp, buf); - Tcl_DetachPids(1, &(pipePtr->pidPtr[i])); + wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i])); + Tcl_AppendElement(interp, buf); + Tcl_DetachPids(1, &(pipePtr->pidPtr[i])); } if (pipePtr->numPids > 0) { - ckfree((char *) pipePtr->pidPtr); - pipePtr->numPids = 0; + ckfree((char *) pipePtr->pidPtr); + pipePtr->numPids = 0; } } /* *---------------------------------------------------------------------- @@ -1836,14 +1828,14 @@ static int PipeBlockModeProc( ClientData instanceData, /* Instance data for channel. */ int mode) /* TCL_MODE_BLOCKING or - * TCL_MODE_NONBLOCKING. */ + * TCL_MODE_NONBLOCKING. */ { PipeInfo *infoPtr = (PipeInfo *) instanceData; - + /* * Pipes on Windows can not be switched between blocking and nonblocking, * hence we have to emulate the behavior. This is done in the input * function by checking against a bit in the state. We set or unset the * bit here to cause the input function to emulate the correct behavior. @@ -1887,31 +1879,30 @@ DWORD exitCode; errorCode = 0; result = 0; - if ((!flags || flags == TCL_CLOSE_READ) - && (pipePtr->readFile != NULL)) { + if ((!flags || flags == TCL_CLOSE_READ) && (pipePtr->readFile != NULL)) { /* - * Clean up the background thread if necessary. Note that this - * must be done before we can close the file, since the - * thread may be blocking trying to read from the pipe. + * Clean up the background thread if necessary. Note that this must be + * done before we can close the file, since the thread may be blocking + * trying to read from the pipe. */ if (pipePtr->readThread) { /* - * The thread may already have closed on its own. Check - * its exit code. + * The thread may already have closed on its own. Check its exit + * code. */ GetExitCodeThread(pipePtr->readThread, &exitCode); if (exitCode == STILL_ACTIVE) { /* - * Set the stop event so that if the reader thread is - * blocked in PipeReaderThread on WaitForMultipleEvents, - * it will exit cleanly. + * Set the stop event so that if the reader thread is blocked + * in PipeReaderThread on WaitForMultipleEvents, it will exit + * cleanly. */ SetEvent(pipePtr->stopReader); /* @@ -1921,22 +1912,20 @@ if (WaitForSingleObject(pipePtr->readThread, 20) == WAIT_TIMEOUT) { /* * The thread must be blocked waiting for the pipe to - * become readable in ReadFile(). There isn't a - * clean way to exit the thread from this condition. - * We should terminate the child process instead to - * get the reader thread to fall out of ReadFile with - * a FALSE. (below) is not the correct way to do - * this, but will stay here until a better solution - * is found. + * become readable in ReadFile(). There isn't a clean way + * to exit the thread from this condition. We should + * terminate the child process instead to get the reader + * thread to fall out of ReadFile with a FALSE. (below) is + * not the correct way to do this, but will stay here + * until a better solution is found. * * Note that we need to guard against terminating the - * thread while it is in the middle of - * Tcl_ThreadAlert because it won't be able to - * release the notifier lock. + * thread while it is in the middle of Tcl_ThreadAlert + * because it won't be able to release the notifier lock. */ Tcl_MutexLock(&pipeMutex); /* BUG: this leaks memory */ @@ -1959,30 +1948,29 @@ } if ((!flags || flags & TCL_CLOSE_WRITE) && (pipePtr->writeFile != NULL)) { if (pipePtr->writeThread) { /* - * Wait for the writer thread to finish the current buffer, - * then terminate the thread and close the handles. If the - * channel is nonblocking, there should be no pending write - * operations. + * Wait for the writer thread to finish the current buffer, then + * terminate the thread and close the handles. If the channel is + * nonblocking, there should be no pending write operations. */ WaitForSingleObject(pipePtr->writable, INFINITE); /* - * The thread may already have closed on it's own. Check - * its exit code. + * The thread may already have closed on it's own. Check its exit + * code. */ GetExitCodeThread(pipePtr->writeThread, &exitCode); if (exitCode == STILL_ACTIVE) { /* - * Set the stop event so that if the reader thread is - * blocked in PipeReaderThread on WaitForMultipleEvents, - * it will exit cleanly. + * Set the stop event so that if the reader thread is blocked + * in PipeReaderThread on WaitForMultipleEvents, it will exit + * cleanly. */ SetEvent(pipePtr->stopWriter); /* @@ -1992,22 +1980,20 @@ if (WaitForSingleObject(pipePtr->writeThread, 20) == WAIT_TIMEOUT) { /* * The thread must be blocked waiting for the pipe to - * consume input in WriteFile(). There isn't a clean - * way to exit the thread from this condition. We - * should terminate the child process instead to get - * the writer thread to fall out of WriteFile with a - * FALSE. (below) is not the correct way to do this, - * but will stay here until a better solution is - * found. + * consume input in WriteFile(). There isn't a clean way + * to exit the thread from this condition. We should + * terminate the child process instead to get the writer + * thread to fall out of WriteFile with a FALSE. (below) + * is not the correct way to do this, but will stay here + * until a better solution is found. * * Note that we need to guard against terminating the - * thread while it is in the middle of - * Tcl_ThreadAlert because it won't be able to - * release the notifier lock. + * thread while it is in the middle of Tcl_ThreadAlert + * because it won't be able to release the notifier lock. */ Tcl_MutexLock(&pipeMutex); /* BUG: this leaks memory */ @@ -2054,21 +2040,26 @@ } } if ((pipePtr->flags & PIPE_ASYNC) || TclInExit()) { /* - * If the channel is non-blocking or Tcl is being cleaned up, - * just detach the children PIDs, reap them (important if we are - * in a dynamic load module), and discard the errorFile. + * If the channel is non-blocking or Tcl is being cleaned up, just + * detach the children PIDs, reap them (important if we are in a + * dynamic load module), and discard the errorFile. */ Tcl_DetachPids(pipePtr->numPids, pipePtr->pidPtr); Tcl_ReapDetachedProcs(); if (pipePtr->errorFile) { - TclpCloseFile(pipePtr->errorFile); + if (TclpCloseFile(pipePtr->errorFile) != 0) { + if (errorCode == 0) { + errorCode = errno; + } + } } + result = 0; } else { /* * Wrap the error file into a channel and give it to the cleanup * routine. */ @@ -2107,12 +2098,12 @@ /* *---------------------------------------------------------------------- * * PipeInputProc -- * - * Reads input from the IO channel into the buffer given. Returns - * count of how many bytes were actually read, and an error indication. + * Reads input from the IO channel into the buffer given. Returns count + * of how many bytes were actually read, and an error indication. * * Results: * A count of how many bytes were read is returned and an error * indication is returned in an output argument. * @@ -2122,15 +2113,15 @@ *---------------------------------------------------------------------- */ static int PipeInputProc( - ClientData instanceData, /* Pipe state. */ - char *buf, /* Where to store data read. */ - int bufSize, /* How much space is available - * in the buffer? */ - int *errorCode) /* Where to store error code. */ + ClientData instanceData, /* Pipe state. */ + char *buf, /* Where to store data read. */ + int bufSize, /* How much space is available in the + * buffer? */ + int *errorCode) /* Where to store error code. */ { PipeInfo *infoPtr = (PipeInfo *) instanceData; WinFile *filePtr = (WinFile*) infoPtr->readFile; DWORD count, bytesRead = 0; int result; @@ -2151,12 +2142,12 @@ return -1; } if (infoPtr->readFlags & PIPE_EXTRABYTE) { /* - * The reader thread consumed 1 byte as a side effect of - * waiting so we need to move it into the buffer. + * The reader thread consumed 1 byte as a side effect of waiting so we + * need to move it into the buffer. */ *buf = infoPtr->extraByte; infoPtr->readFlags &= ~PIPE_EXTRABYTE; buf++; @@ -2171,13 +2162,13 @@ return bytesRead; } } /* - * Attempt to read bufSize bytes. The read will return immediately - * if there is any data available. Otherwise it will block until - * at least one byte is available or an EOF occurs. + * Attempt to read bufSize bytes. The read will return immediately if + * there is any data available. Otherwise it will block until at least one + * byte is available or an EOF occurs. */ if (ReadFile(filePtr->handle, (LPVOID) buf, (DWORD) bufSize, &count, (LPOVERLAPPED) NULL) == TRUE) { return bytesRead + count; @@ -2201,46 +2192,46 @@ /* *---------------------------------------------------------------------- * * PipeOutputProc -- * - * Writes the given output on the IO channel. Returns count of how - * many characters were actually written, and an error indication. + * Writes the given output on the IO channel. Returns count of how many + * characters were actually written, and an error indication. * * Results: - * A count of how many characters were written is returned and an - * error indication is returned in an output argument. + * A count of how many characters were written is returned and an error + * indication is returned in an output argument. * * Side effects: * Writes output on the actual channel. * *---------------------------------------------------------------------- */ static int PipeOutputProc( - ClientData instanceData, /* Pipe state. */ - CONST char *buf, /* The data buffer. */ - int toWrite, /* How many bytes to write? */ - int *errorCode) /* Where to store error code. */ + ClientData instanceData, /* Pipe state. */ + CONST char *buf, /* The data buffer. */ + int toWrite, /* How many bytes to write? */ + int *errorCode) /* Where to store error code. */ { PipeInfo *infoPtr = (PipeInfo *) instanceData; WinFile *filePtr = (WinFile*) infoPtr->writeFile; DWORD bytesWritten, timeout; - + *errorCode = 0; timeout = (infoPtr->flags & PIPE_ASYNC) ? 0 : INFINITE; if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) { /* - * The writer thread is blocked waiting for a write to complete - * and the channel is in non-blocking mode. + * The writer thread is blocked waiting for a write to complete and + * the channel is in non-blocking mode. */ errno = EAGAIN; goto error; } - + /* * Check for a background error on the last write. */ if (infoPtr->writeError) { @@ -2249,12 +2240,12 @@ goto error; } if (infoPtr->flags & PIPE_ASYNC) { /* - * The pipe is non-blocking, so copy the data into the output - * buffer and restart the writer thread. + * The pipe is non-blocking, so copy the data into the output buffer + * and restart the writer thread. */ if (toWrite > infoPtr->writeBufLen) { /* * Reallocate the buffer to be large enough to hold the data. @@ -2271,12 +2262,12 @@ ResetEvent(infoPtr->writable); SetEvent(infoPtr->startWriter); bytesWritten = toWrite; } else { /* - * In the blocking case, just try to write the buffer directly. - * This avoids an unnecessary copy. + * In the blocking case, just try to write the buffer directly. This + * avoids an unnecessary copy. */ if (WriteFile(filePtr->handle, (LPVOID) buf, (DWORD) toWrite, &bytesWritten, (LPOVERLAPPED) NULL) == FALSE) { TclWinConvertError(GetLastError()); @@ -2283,11 +2274,11 @@ goto error; } } return bytesWritten; - error: + error: *errorCode = errno; return -1; } @@ -2294,19 +2285,19 @@ /* *---------------------------------------------------------------------- * * PipeEventProc -- * - * This function is invoked by Tcl_ServiceEvent when a file event - * reaches the front of the event queue. This procedure invokes - * Tcl_NotifyChannel on the pipe. + * This function is invoked by Tcl_ServiceEvent when a file event reaches + * the front of the event queue. This function invokes Tcl_NotifyChannel + * on the pipe. * * Results: - * Returns 1 if the event was handled, meaning it should be removed - * from the queue. Returns 0 if the event was not handled, meaning - * it should stay on the queue. The only time the event isn't - * handled is if the TCL_FILE_EVENTS flag bit isn't set. + * Returns 1 if the event was handled, meaning it should be removed from + * the queue. Returns 0 if the event was not handled, meaning it should + * stay on the queue. The only time the event isn't handled is if the + * TCL_FILE_EVENTS flag bit isn't set. * * Side effects: * Whatever the notifier callback does. * *---------------------------------------------------------------------- @@ -2328,13 +2319,13 @@ return 0; } /* * Search through the list of watched pipes for the one whose handle - * matches the event. We do this rather than simply dereferencing - * the handle in the event so that pipes can be deleted while the - * event is in the queue. + * matches the event. We do this rather than simply dereferencing the + * handle in the event so that pipes can be deleted while the event is in + * the queue. */ for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (pipeEvPtr->infoPtr == infoPtr) { @@ -2350,13 +2341,13 @@ if (!infoPtr) { return 1; } /* - * Check to see if the pipe is readable. Note - * that we can't tell if a pipe is writable, so we always report it - * as being writable unless we have detected EOF. + * Check to see if the pipe is readable. Note that we can't tell if a pipe + * is writable, so we always report it as being writable unless we have + * detected EOF. */ filePtr = (WinFile*) ((PipeInfo*)infoPtr)->writeFile; mask = 0; if ((infoPtr->watchMask & TCL_WRITABLE) && @@ -2384,12 +2375,11 @@ /* *---------------------------------------------------------------------- * * PipeWatchProc -- * - * Called by the notifier to set up to watch for events on this - * channel. + * Called by the notifier to set up to watch for events on this channel. * * Results: * None. * * Side effects: @@ -2398,24 +2388,23 @@ *---------------------------------------------------------------------- */ static void PipeWatchProc( - ClientData instanceData, /* Pipe state. */ - int mask) /* What events to watch for, OR-ed - * combination of TCL_READABLE, - * TCL_WRITABLE and TCL_EXCEPTION. */ + ClientData instanceData, /* Pipe state. */ + int mask) /* What events to watch for, OR-ed combination + * of TCL_READABLE, TCL_WRITABLE and + * TCL_EXCEPTION. */ { PipeInfo **nextPtrPtr, *ptr; PipeInfo *infoPtr = (PipeInfo *) instanceData; int oldMask = infoPtr->watchMask; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* - * Since most of the work is handled by the background threads, - * we just need to update the watchMask and then force the notifier - * to poll once. + * Since most of the work is handled by the background threads, we just + * need to update the watchMask and then force the notifier to poll once. */ infoPtr->watchMask = mask & infoPtr->validMask; if (infoPtr->watchMask) { Tcl_Time blockTime = { 0, 0 }; @@ -2429,12 +2418,12 @@ /* * Remove the pipe from the list of watched pipes. */ for (nextPtrPtr = &(tsdPtr->firstPipePtr), ptr = *nextPtrPtr; - ptr != NULL; - nextPtrPtr = &ptr->nextPtr, ptr = *nextPtrPtr) { + ptr != NULL; + nextPtrPtr = &ptr->nextPtr, ptr = *nextPtrPtr) { if (infoPtr == ptr) { *nextPtrPtr = ptr->nextPtr; break; } } @@ -2445,16 +2434,16 @@ /* *---------------------------------------------------------------------- * * PipeGetHandleProc -- * - * Called from Tcl_GetChannelHandle to retrieve OS handles from - * inside a command pipeline based channel. + * Called from Tcl_GetChannelHandle to retrieve OS handles from inside a + * command pipeline based channel. * * Results: - * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if - * there is no handle for the specified direction. + * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no + * handle for the specified direction. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -2465,11 +2454,11 @@ ClientData instanceData, /* The pipe state. */ int direction, /* TCL_READABLE or TCL_WRITABLE */ ClientData *handlePtr) /* Where to store the handle. */ { PipeInfo *infoPtr = (PipeInfo *) instanceData; - WinFile *filePtr; + WinFile *filePtr; if (direction == TCL_READABLE && infoPtr->readFile) { filePtr = (WinFile*) infoPtr->readFile; *handlePtr = (ClientData) filePtr->handle; return TCL_OK; @@ -2488,17 +2477,16 @@ * Tcl_WaitPid -- * * Emulates the waitpid system call. * * Results: - * Returns 0 if the process is still alive, -1 on an error, or - * the pid on a clean close. + * Returns 0 if the process is still alive, -1 on an error, or the pid on + * a clean close. * * Side effects: - * Unless WNOHANG is set and the wait times out, the process - * information record will be deleted and the process handle - * will be closed. + * Unless WNOHANG is set and the wait times out, the process information + * record will be deleted and the process handle will be closed. * *---------------------------------------------------------------------- */ Tcl_Pid @@ -2515,11 +2503,11 @@ PipeInit(); /* * If no pid is specified, do nothing. */ - + if (pid == 0) { *statPtr = 0; return 0; } @@ -2540,21 +2528,21 @@ /* * If the pid is not one of the processes we know about (we started it) * then do nothing. */ - + if (infoPtr == NULL) { - *statPtr = 0; + *statPtr = 0; return 0; } /* - * Officially "wait" for it to finish. We either poll (WNOHANG) or - * wait for an infinite amount of time. + * Officially "wait" for it to finish. We either poll (WNOHANG) or wait + * for an infinite amount of time. */ - + if (options & WNOHANG) { flags = 0; } else { flags = INFINITE; } @@ -2563,10 +2551,11 @@ *statPtr = 0; if (options & WNOHANG) { /* * Re-insert this infoPtr back on the list. */ + Tcl_MutexLock(&pipeMutex); infoPtr->nextPtr = procList; procList = infoPtr; Tcl_MutexUnlock(&pipeMutex); return 0; @@ -2579,68 +2568,69 @@ /* * Does the exit code look like one of the exception codes? */ switch (exitCode) { - case EXCEPTION_FLT_DENORMAL_OPERAND: - case EXCEPTION_FLT_DIVIDE_BY_ZERO: - case EXCEPTION_FLT_INEXACT_RESULT: - case EXCEPTION_FLT_INVALID_OPERATION: - case EXCEPTION_FLT_OVERFLOW: - case EXCEPTION_FLT_STACK_CHECK: - case EXCEPTION_FLT_UNDERFLOW: - case EXCEPTION_INT_DIVIDE_BY_ZERO: - case EXCEPTION_INT_OVERFLOW: - *statPtr = SIGFPE; - break; - - case EXCEPTION_PRIV_INSTRUCTION: - case EXCEPTION_ILLEGAL_INSTRUCTION: - *statPtr = SIGILL; - break; - - case EXCEPTION_ACCESS_VIOLATION: - case EXCEPTION_ARRAY_BOUNDS_EXCEEDED: - case EXCEPTION_STACK_OVERFLOW: - case EXCEPTION_NONCONTINUABLE_EXCEPTION: - case EXCEPTION_INVALID_DISPOSITION: - case EXCEPTION_GUARD_PAGE: - case EXCEPTION_INVALID_HANDLE: - *statPtr = SIGSEGV; - break; - - case EXCEPTION_DATATYPE_MISALIGNMENT: - *statPtr = SIGBUS; - break; - - case EXCEPTION_BREAKPOINT: - case EXCEPTION_SINGLE_STEP: - *statPtr = SIGTRAP; - break; - - case CONTROL_C_EXIT: - *statPtr = SIGINT; - break; - - default: - /* - * Non-exceptional, normal, exit code. Note that the - * exit code is truncated to a signed short range - * [-32768,32768) whether it fits into this range or not. - * - * BUG: Even though the exit code is a DWORD, it is - * understood by convention to be a signed integer, yet - * there isn't enough room to fit this into the POSIX - * style waitstatus mask without truncating it. - */ - *statPtr = (((int)(short) exitCode << 8) & 0xffff00); - break; + case EXCEPTION_FLT_DENORMAL_OPERAND: + case EXCEPTION_FLT_DIVIDE_BY_ZERO: + case EXCEPTION_FLT_INEXACT_RESULT: + case EXCEPTION_FLT_INVALID_OPERATION: + case EXCEPTION_FLT_OVERFLOW: + case EXCEPTION_FLT_STACK_CHECK: + case EXCEPTION_FLT_UNDERFLOW: + case EXCEPTION_INT_DIVIDE_BY_ZERO: + case EXCEPTION_INT_OVERFLOW: + *statPtr = SIGFPE; + break; + + case EXCEPTION_PRIV_INSTRUCTION: + case EXCEPTION_ILLEGAL_INSTRUCTION: + *statPtr = SIGILL; + break; + + case EXCEPTION_ACCESS_VIOLATION: + case EXCEPTION_ARRAY_BOUNDS_EXCEEDED: + case EXCEPTION_STACK_OVERFLOW: + case EXCEPTION_NONCONTINUABLE_EXCEPTION: + case EXCEPTION_INVALID_DISPOSITION: + case EXCEPTION_GUARD_PAGE: + case EXCEPTION_INVALID_HANDLE: + *statPtr = SIGSEGV; + break; + + case EXCEPTION_DATATYPE_MISALIGNMENT: + *statPtr = SIGBUS; + break; + + case EXCEPTION_BREAKPOINT: + case EXCEPTION_SINGLE_STEP: + *statPtr = SIGTRAP; + break; + + case CONTROL_C_EXIT: + *statPtr = SIGINT; + break; + + default: + /* + * Non-exceptional, normal, exit code. Note that the exit code is + * truncated to a signed short range [-32768,32768) whether it + * fits into this range or not. + * + * BUG: Even though the exit code is a DWORD, it is understood by + * convention to be a signed integer, yet there isn't enough room + * to fit this into the POSIX style waitstatus mask without + * truncating it. + */ + + *statPtr = (((int)(short) exitCode << 8) & 0xffff00); + break; } result = pid; } else { errno = ECHILD; - *statPtr = ECHILD; + *statPtr = ECHILD; result = (Tcl_Pid) -1; } /* * Officially close the process handle. @@ -2655,27 +2645,27 @@ /* *---------------------------------------------------------------------- * * TclWinAddProcess -- * - * Add a process to the process list so that we can use - * Tcl_WaitPid on the process. + * Add a process to the process list so that we can use Tcl_WaitPid on + * the process. * * Results: - * None + * None * * Side effects: - * Adds the specified process handle to the process list so - * Tcl_WaitPid knows about it. + * Adds the specified process handle to the process list so Tcl_WaitPid + * knows about it. * *---------------------------------------------------------------------- */ void TclWinAddProcess(hProcess, id) - HANDLE hProcess; /* Handle to process */ - DWORD id; /* Global process identifier */ + HANDLE hProcess; /* Handle to process */ + DWORD id; /* Global process identifier */ { ProcInfo *procPtr = (ProcInfo *) ckalloc(sizeof(ProcInfo)); PipeInit(); @@ -2690,12 +2680,12 @@ /* *---------------------------------------------------------------------- * * Tcl_PidObjCmd -- * - * This procedure is invoked to process the "pid" Tcl command. - * See the user documentation for details on what it does. + * This function is invoked to process the "pid" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -2725,23 +2715,23 @@ } if (objc == 1) { wsprintfA(buf, "%lu", (unsigned long) getpid()); Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1)); } else { - chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), + chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL); - if (chan == (Tcl_Channel) NULL) { + if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } chanTypePtr = Tcl_GetChannelType(chan); if (chanTypePtr != &pipeChannelType) { return TCL_OK; } - pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan); + pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan); resultPtr = Tcl_NewObj(); - for (i = 0; i < pipePtr->numPids; i++) { + for (i = 0; i < pipePtr->numPids; i++) { wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i])); Tcl_ListObjAppendElement(/*interp*/ NULL, resultPtr, Tcl_NewStringObj(buf, -1)); } Tcl_SetObjResult(interp, resultPtr); @@ -2752,42 +2742,41 @@ /* *---------------------------------------------------------------------- * * WaitForRead -- * - * Wait until some data is available, the pipe is at - * EOF or the reader thread is blocked waiting for data (if the - * channel is in non-blocking mode). + * Wait until some data is available, the pipe is at EOF or the reader + * thread is blocked waiting for data (if the channel is in non-blocking + * mode). * * Results: - * Returns 1 if pipe is readable. Returns 0 if there is no data - * on the pipe, but there is buffered data. Returns -1 if an - * error occurred. If an error occurred, the threads may not - * be synchronized. + * Returns 1 if pipe is readable. Returns 0 if there is no data on the + * pipe, but there is buffered data. Returns -1 if an error occurred. If + * an error occurred, the threads may not be synchronized. * * Side effects: - * Updates the shared state flags and may consume 1 byte of data - * from the pipe. If no error occurred, the reader thread is - * blocked waiting for a signal from the main thread. + * Updates the shared state flags and may consume 1 byte of data from the + * pipe. If no error occurred, the reader thread is blocked waiting for a + * signal from the main thread. * *---------------------------------------------------------------------- */ static int WaitForRead( PipeInfo *infoPtr, /* Pipe state. */ - int blocking) /* Indicates whether call should be - * blocking or not. */ + int blocking) /* Indicates whether call should be blocking + * or not. */ { DWORD timeout, count; HANDLE *handle = ((WinFile *) infoPtr->readFile)->handle; while (1) { /* * Synchronize with the reader thread. */ - + timeout = blocking ? INFINITE : 0; if (WaitForSingleObject(infoPtr->readable, timeout) == WAIT_TIMEOUT) { /* * The reader thread is blocked waiting for data and the channel * is in non-blocking mode. @@ -2796,30 +2785,30 @@ errno = EAGAIN; return -1; } /* - * At this point, the two threads are synchronized, so it is safe - * to access shared state. + * At this point, the two threads are synchronized, so it is safe to + * access shared state. */ - /* * If the pipe has hit EOF, it is always readable. */ if (infoPtr->readFlags & PIPE_EOF) { return 1; } - + /* * Check to see if there is any data sitting in the pipe. */ if (PeekNamedPipe(handle, (LPVOID) NULL, (DWORD) 0, (LPDWORD) NULL, &count, (LPDWORD) NULL) != TRUE) { TclWinConvertError(GetLastError()); + /* * Check to see if the peek failed because of EOF. */ if (errno == EPIPE) { @@ -2845,23 +2834,22 @@ if (count > 0) { return 1; } /* - * The pipe isn't readable, but there is some data sitting - * in the buffer, so return immediately. + * The pipe isn't readable, but there is some data sitting in the + * buffer, so return immediately. */ if (infoPtr->readFlags & PIPE_EXTRABYTE) { return 0; } /* - * There wasn't any data available, so reset the thread and - * try again. + * There wasn't any data available, so reset the thread and try again. */ - + ResetEvent(infoPtr->readable); SetEvent(infoPtr->startReader); } } @@ -2868,22 +2856,21 @@ /* *---------------------------------------------------------------------- * * PipeReaderThread -- * - * This function runs in a separate thread and waits for input - * to become available on a pipe. + * This function runs in a separate thread and waits for input to become + * available on a pipe. * * Results: * None. * * Side effects: - * Signals the main thread when input become available. May - * cause the main thread to wake up by posting a message. May - * consume one byte from the pipe for each wait operation. Will - * cause a memory leak of ~4k, if forcefully terminated with - * TerminateThread(). + * Signals the main thread when input become available. May cause the + * main thread to wake up by posting a message. May consume one byte from + * the pipe for each wait operation. Will cause a memory leak of ~4k, if + * forcefully terminated with TerminateThread(). * *---------------------------------------------------------------------- */ static DWORD WINAPI @@ -2899,37 +2886,37 @@ wEvents[0] = infoPtr->stopReader; wEvents[1] = infoPtr->startReader; while (!done) { /* - * Wait for the main thread to signal before attempting to wait - * on the pipe becoming readable. + * Wait for the main thread to signal before attempting to wait on the + * pipe becoming readable. */ waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE); if (waitResult != (WAIT_OBJECT_0 + 1)) { /* - * The start event was not signaled. It might be the stop event - * or an error, so exit. + * The start event was not signaled. It might be the stop event or + * an error, so exit. */ break; } /* - * Try waiting for 0 bytes. This will block until some data is - * available on NT, but will return immediately on Win 95. So, - * if no data is available after the first read, we block until - * we can read a single byte off of the pipe. + * Try waiting for 0 bytes. This will block until some data is + * available on NT, but will return immediately on Win 95. So, if no + * data is available after the first read, we block until we can read + * a single byte off of the pipe. */ if (ReadFile(handle, NULL, 0, &count, NULL) == FALSE || PeekNamedPipe(handle, NULL, 0, NULL, &count, NULL) == FALSE) { /* - * The error is a result of an EOF condition, so set the - * EOF bit before signalling the main thread. + * The error is a result of an EOF condition, so set the EOF bit + * before signalling the main thread. */ err = GetLastError(); if (err == ERROR_BROKEN_PIPE) { infoPtr->readFlags |= PIPE_EOF; @@ -2939,12 +2926,12 @@ } } else if (count == 0) { if (ReadFile(handle, &(infoPtr->extraByte), 1, &count, NULL) != FALSE) { /* - * One byte was consumed as a side effect of waiting - * for the pipe to become readable. + * One byte was consumed as a side effect of waiting for the + * pipe to become readable. */ infoPtr->readFlags |= PIPE_EXTRABYTE; } else { err = GetLastError(); @@ -2960,26 +2947,33 @@ break; } } } - + /* - * Signal the main thread by signalling the readable event and - * then waking up the notifier thread. + * Signal the main thread by signalling the readable event and then + * waking up the notifier thread. */ SetEvent(infoPtr->readable); - + /* - * Alert the foreground thread. Note that we need to treat this like - * a critical section so the foreground thread does not terminate - * this thread while we are holding a mutex in the notifier code. + * Alert the foreground thread. Note that we need to treat this like a + * critical section so the foreground thread does not terminate this + * thread while we are holding a mutex in the notifier code. */ Tcl_MutexLock(&pipeMutex); - Tcl_ThreadAlert(infoPtr->threadId); + if (infoPtr->threadId != NULL) { + /* + * TIP #218. When in flight ignore the event, no one will receive + * it anyway. + */ + + Tcl_ThreadAlert(infoPtr->threadId); + } Tcl_MutexUnlock(&pipeMutex); } return 0; } @@ -2987,27 +2981,25 @@ /* *---------------------------------------------------------------------- * * PipeWriterThread -- * - * This function runs in a separate thread and writes data - * onto a pipe. + * This function runs in a separate thread and writes data onto a pipe. * * Results: * Always returns 0. * * Side effects: - * Signals the main thread when an output operation is completed. - * May cause the main thread to wake up by posting a message. + * Signals the main thread when an output operation is completed. May + * cause the main thread to wake up by posting a message. * *---------------------------------------------------------------------- */ static DWORD WINAPI PipeWriterThread(LPVOID arg) { - PipeInfo *infoPtr = (PipeInfo *)arg; HANDLE *handle = ((WinFile *) infoPtr->writeFile)->handle; DWORD count, toWrite; char *buf; int done = 0; @@ -3024,12 +3016,12 @@ waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE); if (waitResult != (WAIT_OBJECT_0 + 1)) { /* - * The start event was not signaled. It might be the stop event - * or an error, so exit. + * The start event was not signaled. It might be the stop event or + * an error, so exit. */ break; } @@ -3041,34 +3033,98 @@ */ while (toWrite > 0) { if (WriteFile(handle, buf, toWrite, &count, NULL) == FALSE) { infoPtr->writeError = GetLastError(); - done = 1; + done = 1; break; } else { toWrite -= count; buf += count; } } - + /* - * Signal the main thread by signalling the writable event and - * then waking up the notifier thread. + * Signal the main thread by signalling the writable event and then + * waking up the notifier thread. */ SetEvent(infoPtr->writable); /* - * Alert the foreground thread. Note that we need to treat this like - * a critical section so the foreground thread does not terminate - * this thread while we are holding a mutex in the notifier code. + * Alert the foreground thread. Note that we need to treat this like a + * critical section so the foreground thread does not terminate this + * thread while we are holding a mutex in the notifier code. */ Tcl_MutexLock(&pipeMutex); - Tcl_ThreadAlert(infoPtr->threadId); + if (infoPtr->threadId != NULL) { + /* + * TIP #218. When in flight ignore the event, no one will receive + * it anyway. + */ + + Tcl_ThreadAlert(infoPtr->threadId); + } Tcl_MutexUnlock(&pipeMutex); } return 0; } + +/* + *---------------------------------------------------------------------- + * + * PipeThreadActionProc -- + * + * Insert or remove any thread local refs to this channel. + * + * Results: + * None. + * + * Side effects: + * Changes thread local list of valid channels. + * + *---------------------------------------------------------------------- + */ + +static void +PipeThreadActionProc(instanceData, action) + ClientData instanceData; + int action; +{ + PipeInfo *infoPtr = (PipeInfo *) instanceData; + + /* + * We do not access firstPipePtr in the thread structures. This is not for + * all pipes managed by the thread, but only those we are watching. + * Removal of the filevent handlers before transfer thus takes care of + * this structure. + */ + + Tcl_MutexLock(&pipeMutex); + if (action == TCL_CHANNEL_THREAD_INSERT) { + /* + * We can't copy the thread information from the channel when the + * channel is created. At this time the channel back pointer has not + * been set yet. However in that case the threadId has already been + * set by TclpCreateCommandChannel itself, so the structure is still + * good. + */ + PipeInit(); + if (infoPtr->channel != NULL) { + infoPtr->threadId = Tcl_GetChannelThread(infoPtr->channel); + } + } else { + infoPtr->threadId = NULL; + } + Tcl_MutexUnlock(&pipeMutex); +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: win/tclWinPort.h ================================================================== --- win/tclWinPort.h +++ win/tclWinPort.h @@ -8,11 +8,11 @@ * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinPort.h,v 1.43 2004/11/03 21:07:01 davygrvy Exp $ + * RCS: @(#) $Id: tclWinPort.h,v 1.43.2.2 2005/10/08 13:45:04 dgp Exp $ */ #ifndef _TCLWINPORT #define _TCLWINPORT @@ -42,10 +42,17 @@ #include #include #include #include +/* + * These string functions are not defined with the same names on Windows. + */ + +#define strcasecmp stricmp +#define strncasecmp strnicmp + /* * Need to block out these includes for building extensions with MetroWerks * compiler for Win32. */ @@ -436,11 +443,12 @@ * The following define ensures that we use the native putenv * implementation to modify the environment array. This keeps * the C level environment in synch with the system level environment. */ -#define USE_PUTENV 1 +#define USE_PUTENV 1 +#define USE_PUTENV_FOR_UNSET 1 /* * Msvcrt's putenv() copies the string rather than takes ownership of it. */ Index: win/tclWinReg.c ================================================================== --- win/tclWinReg.c +++ win/tclWinReg.c @@ -1,19 +1,19 @@ /* * tclWinReg.c -- * - * This file contains the implementation of the "registry" Tcl - * built-in command. This command is built as a dynamically - * loadable extension in a separate DLL. + * This file contains the implementation of the "registry" Tcl built-in + * command. This command is built as a dynamically loadable extension in + * a separate DLL. * * Copyright (c) 1997 by Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinReg.c,v 1.32 2004/10/07 00:55:36 dgp Exp $ + * RCS: @(#) $Id: tclWinReg.c,v 1.32.2.1 2005/08/02 18:17:18 dgp Exp $ */ #include "tclInt.h" #ifdef _MSC_VER # pragma comment (lib, "advapi32.lib") @@ -35,19 +35,19 @@ #define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x)) #define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x))) /* - * The following flag is used in OpenKeys to indicate that the specified - * key should be created if it doesn't currently exist. + * The following flag is used in OpenKeys to indicate that the specified key + * should be created if it doesn't currently exist. */ #define REG_CREATE 1 /* - * The following tables contain the mapping from registry root names - * to the system predefined keys. + * The following tables contain the mapping from registry root names to the + * system predefined keys. */ static CONST char *rootKeyNames[] = { "HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT", "HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG", @@ -60,14 +60,13 @@ }; static CONST char REGISTRY_ASSOC_KEY[] = "registry::command"; /* - * The following table maps from registry types to strings. Note that - * the indices for this array are the same as the constants for the - * known registry types so we don't need a separate table to hold the - * mapping. + * The following table maps from registry types to strings. Note that the + * indices for this array are the same as the constants for the known registry + * types so we don't need a separate table to hold the mapping. */ static CONST char *typeNames[] = { "none", "sz", "expand_sz", "binary", "dword", "dword_big_endian", "link", "multi_sz", "resource_list", NULL @@ -75,21 +74,21 @@ static DWORD lastType = REG_RESOURCE_LIST; /* * The following structures allow us to select between the Unicode and ASCII - * interfaces at run time based on whether Unicode APIs are available. The - * Unicode APIs are preferable because they will handle characters outside - * of the current code page. + * interfaces at run time based on whether Unicode APIs are available. The + * Unicode APIs are preferable because they will handle characters outside of + * the current code page. */ typedef struct RegWinProcs { int useWide; LONG (WINAPI *regConnectRegistryProc)(CONST TCHAR *, HKEY, PHKEY); LONG (WINAPI *regCreateKeyExProc)(HKEY, CONST TCHAR *, DWORD, TCHAR *, - DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *); + DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *); LONG (WINAPI *regDeleteKeyProc)(HKEY, CONST TCHAR *); LONG (WINAPI *regDeleteValueProc)(HKEY, CONST TCHAR *); LONG (WINAPI *regEnumKeyProc)(HKEY, DWORD, TCHAR *, DWORD); LONG (WINAPI *regEnumKeyExProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, TCHAR *, DWORD *, FILETIME *); @@ -112,11 +111,11 @@ 0, (LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryA, (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *, DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, - DWORD *)) RegCreateKeyExA, + DWORD *)) RegCreateKeyExA, (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyA, (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueA, (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyA, (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExA, @@ -137,11 +136,11 @@ 1, (LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryW, (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *, DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, - DWORD *)) RegCreateKeyExW, + DWORD *)) RegCreateKeyExW, (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyW, (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueW, (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyW, (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExW, @@ -202,11 +201,11 @@ /* *---------------------------------------------------------------------- * * Registry_Init -- * - * This procedure initializes the registry command. + * This function initializes the registry command. * * Results: * A standard Tcl result. * * Side effects: @@ -245,11 +244,11 @@ /* *---------------------------------------------------------------------- * * Registry_Unload -- * - * This procedure removes the registry command. + * This function removes the registry command. * * Results: * A standard Tcl result. * * Side effects: @@ -264,11 +263,11 @@ int flags) /* Flags passed by the unload system */ { Tcl_Command cmd; Tcl_Obj *objv[3]; - /* + /* * Unregister the registry package. There is no Tcl_PkgForget() */ objv[0] = Tcl_NewStringObj("package", -1); objv[1] = Tcl_NewStringObj("forget", -1); @@ -290,12 +289,12 @@ /* *---------------------------------------------------------------------- * * DeleteCmd -- * - * Cleanup the interp command token so that unloading doesn't try - * to re-delete the command (which will crash). + * Cleanup the interp command token so that unloading doesn't try to + * re-delete the command (which will crash). * * Results: * None. * * Side effects: @@ -354,69 +353,68 @@ != TCL_OK) { return TCL_ERROR; } switch (index) { - case BroadcastIdx: /* broadcast */ - return BroadcastValue(interp, objc, objv); - break; - case DeleteIdx: /* delete */ - if (objc == 3) { - return DeleteKey(interp, objv[2]); - } else if (objc == 4) { - return DeleteValue(interp, objv[2], objv[3]); - } - errString = "keyName ?valueName?"; - break; - case GetIdx: /* get */ - if (objc == 4) { - return GetValue(interp, objv[2], objv[3]); - } - errString = "keyName valueName"; - break; - case KeysIdx: /* keys */ - if (objc == 3) { - return GetKeyNames(interp, objv[2], NULL); - } else if (objc == 4) { - return GetKeyNames(interp, objv[2], objv[3]); - } - errString = "keyName ?pattern?"; - break; - case SetIdx: /* set */ - if (objc == 3) { - HKEY key; - - /* - * Create the key and then close it immediately. - */ - - if (OpenKey(interp, objv[2], KEY_ALL_ACCESS, 1, &key) - != TCL_OK) { - return TCL_ERROR; - } - RegCloseKey(key); - return TCL_OK; - } else if (objc == 5 || objc == 6) { - Tcl_Obj *typeObj = (objc == 5) ? NULL : objv[5]; - return SetValue(interp, objv[2], objv[3], objv[4], typeObj); - } - errString = "keyName ?valueName data ?type??"; - break; - case TypeIdx: /* type */ - if (objc == 4) { - return GetType(interp, objv[2], objv[3]); - } - errString = "keyName valueName"; - break; - case ValuesIdx: /* values */ - if (objc == 3) { - return GetValueNames(interp, objv[2], NULL); - } else if (objc == 4) { - return GetValueNames(interp, objv[2], objv[3]); - } - errString = "keyName ?pattern?"; - break; + case BroadcastIdx: /* broadcast */ + return BroadcastValue(interp, objc, objv); + break; + case DeleteIdx: /* delete */ + if (objc == 3) { + return DeleteKey(interp, objv[2]); + } else if (objc == 4) { + return DeleteValue(interp, objv[2], objv[3]); + } + errString = "keyName ?valueName?"; + break; + case GetIdx: /* get */ + if (objc == 4) { + return GetValue(interp, objv[2], objv[3]); + } + errString = "keyName valueName"; + break; + case KeysIdx: /* keys */ + if (objc == 3) { + return GetKeyNames(interp, objv[2], NULL); + } else if (objc == 4) { + return GetKeyNames(interp, objv[2], objv[3]); + } + errString = "keyName ?pattern?"; + break; + case SetIdx: /* set */ + if (objc == 3) { + HKEY key; + + /* + * Create the key and then close it immediately. + */ + + if (OpenKey(interp, objv[2], KEY_ALL_ACCESS, 1, &key) != TCL_OK) { + return TCL_ERROR; + } + RegCloseKey(key); + return TCL_OK; + } else if (objc == 5 || objc == 6) { + Tcl_Obj *typeObj = (objc == 5) ? NULL : objv[5]; + return SetValue(interp, objv[2], objv[3], objv[4], typeObj); + } + errString = "keyName ?valueName data ?type??"; + break; + case TypeIdx: /* type */ + if (objc == 4) { + return GetType(interp, objv[2], objv[3]); + } + errString = "keyName valueName"; + break; + case ValuesIdx: /* values */ + if (objc == 3) { + return GetValueNames(interp, objv[2], NULL); + } else if (objc == 4) { + return GetValueNames(interp, objv[2], objv[3]); + } + errString = "keyName ?pattern?"; + break; } Tcl_WrongNumArgs(interp, 2, objv, errString); return TCL_ERROR; } @@ -454,12 +452,12 @@ keyName = Tcl_GetStringFromObj(keyNameObj, &length); buffer = ckalloc((unsigned int) length + 1); strcpy(buffer, keyName); - if (ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName) - != TCL_OK) { + if (ParseKeyName(interp, buffer, &hostName, &rootKey, + &keyName) != TCL_OK) { ckfree(buffer); return TCL_ERROR; } if (*keyName == '\0') { @@ -481,16 +479,15 @@ KEY_ENUMERATE_SUB_KEYS | DELETE, 0, &subkey); if (result != ERROR_SUCCESS) { ckfree(buffer); if (result == ERROR_FILE_NOT_FOUND) { return TCL_OK; - } else { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unable to delete key: ", -1)); - AppendSystemError(interp, result); - return TCL_ERROR; } + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unable to delete key: ", -1)); + AppendSystemError(interp, result); + return TCL_ERROR; } /* * Now we recursively delete the key and everything below it. */ @@ -570,17 +567,17 @@ /* *---------------------------------------------------------------------- * * GetKeyNames -- * - * This function enumerates the subkeys of a given key. If the - * optional pattern is supplied, then only keys that match the - * pattern will be returned. + * This function enumerates the subkeys of a given key. If the optional + * pattern is supplied, then only keys that match the pattern will be + * returned. * * Results: - * Returns the list of subkeys in the result object of the - * interpreter, or an error message on failure. + * Returns the list of subkeys in the result object of the interpreter, + * or an error message on failure. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -601,12 +598,12 @@ /* * Attempt to open the key for enumeration. */ - if (OpenKey(interp, keyNameObj, KEY_ENUMERATE_SUB_KEYS, 0, &key) - != TCL_OK) { + if (OpenKey(interp, keyNameObj, KEY_ENUMERATE_SUB_KEYS, 0, + &key) != TCL_OK) { return TCL_ERROR; } if (patternObj) { pattern = Tcl_GetString(patternObj); @@ -613,12 +610,12 @@ } else { pattern = NULL; } /* - * Enumerate over the subkeys until we get an error, indicating the - * end of the list. + * Enumerate over the subkeys until we get an error, indicating the end of + * the list. */ resultPtr = Tcl_NewObj(); for (index = 0; (*regWinProcs->regEnumKeyProc)(key, index, buffer, MAX_PATH+1) == ERROR_SUCCESS; index++) { @@ -644,12 +641,12 @@ /* *---------------------------------------------------------------------- * * GetType -- * - * This function gets the type of a given registry value and - * places it in the interpreter result. + * This function gets the type of a given registry value and places it in + * the interpreter result. * * Results: * Returns a normal Tcl result. * * Side effects: @@ -699,12 +696,12 @@ AppendSystemError(interp, result); return TCL_ERROR; } /* - * Set the type into the result. Watch out for unknown types. - * If we don't know about the type, just use the numeric value. + * Set the type into the result. Watch out for unknown types. If we don't + * know about the type, just use the numeric value. */ if (type > lastType || type < 0) { Tcl_SetObjResult(interp, Tcl_NewIntObj((int) type)); } else { @@ -716,13 +713,12 @@ /* *---------------------------------------------------------------------- * * GetValue -- * - * This function gets the contents of a registry value and places - * a list containing the data and the type in the interpreter - * result. + * This function gets the contents of a registry value and places a list + * containing the data and the type in the interpreter result. * * Results: * Returns a normal Tcl result. * * Side effects: @@ -746,20 +742,19 @@ /* * Attempt to open the key for reading. */ - if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) - != TCL_OK) { + if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) != TCL_OK) { return TCL_ERROR; } /* - * Initialize a Dstring to maximum statically allocated size - * we could get one more byte by avoiding Tcl_DStringSetLength() - * and just setting length to TCL_DSTRING_STATIC_SIZE, but this - * should be safer if the implementation of Dstrings changes. + * Initialize a Dstring to maximum statically allocated size we could get + * one more byte by avoiding Tcl_DStringSetLength() and just setting + * length to TCL_DSTRING_STATIC_SIZE, but this should be safer if the + * implementation of Dstrings changes. * * This allows short values to be read from the registy in one call. * Longer values need a second call with an expanded DString. */ @@ -772,17 +767,18 @@ result = (*regWinProcs->regQueryValueExProc)(key, nativeValue, NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); while (result == ERROR_MORE_DATA) { /* - * The Windows docs say that in this error case, we just need - * to expand our buffer and request more data. - * Required for HKEY_PERFORMANCE_DATA + * The Windows docs say that in this error case, we just need to + * expand our buffer and request more data. Required for + * HKEY_PERFORMANCE_DATA */ + length *= 2; - Tcl_DStringSetLength(&data, (int) length); - result = (*regWinProcs->regQueryValueExProc)(key, (char *) nativeValue, + Tcl_DStringSetLength(&data, (int) length); + result = (*regWinProcs->regQueryValueExProc)(key, (char *) nativeValue, NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); } Tcl_DStringFree(&buf); RegCloseKey(key); if (result != ERROR_SUCCESS) { @@ -793,31 +789,31 @@ Tcl_DStringFree(&data); return TCL_ERROR; } /* - * If the data is a 32-bit quantity, store it as an integer object. If it - * is a multi-string, store it as a list of strings. For null-terminated - * strings, append up the to first null. Otherwise, store it as a binary + * If the data is a 32-bit quantity, store it as an integer object. If it + * is a multi-string, store it as a list of strings. For null-terminated + * strings, append up the to first null. Otherwise, store it as a binary * string. */ if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { - Tcl_SetObjResult(interp, Tcl_NewIntObj( - (int) ConvertDWORD(type, *((DWORD*) Tcl_DStringValue(&data))))); + Tcl_SetObjResult(interp, Tcl_NewIntObj((int) ConvertDWORD(type, + *((DWORD*) Tcl_DStringValue(&data))))); } else if (type == REG_MULTI_SZ) { char *p = Tcl_DStringValue(&data); char *end = Tcl_DStringValue(&data) + length; Tcl_Obj *resultPtr = Tcl_NewObj(); /* * Multistrings are stored as an array of null-terminated strings, - * terminated by two null characters. Also do a bounds check in - * case we get bogus data. + * terminated by two null characters. Also do a bounds check in case + * we get bogus data. */ - - while (p < end && ((regWinProcs->useWide) + + while (p < end && ((regWinProcs->useWide) ? *((Tcl_UniChar *)p) : *p) != 0) { Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf); Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(Tcl_DStringValue(&buf), Tcl_DStringLength(&buf))); @@ -847,13 +843,13 @@ /* *---------------------------------------------------------------------- * * GetValueNames -- * - * This function enumerates the values of the a given key. If - * the optional pattern is supplied, then only value names that - * match the pattern will be returned. + * This function enumerates the values of the a given key. If the + * optional pattern is supplied, then only value names that match the + * pattern will be returned. * * Results: * Returns the list of value names in the result object of the * interpreter, or an error message on failure. * @@ -914,12 +910,12 @@ pattern = NULL; } /* * Enumerate the values under the given subkey until we get an error, - * indicating the end of the list. Note that we need to reset size - * after each iteration because RegEnumValue smashes the old value. + * indicating the end of the list. Note that we need to reset size after + * each iteration because RegEnumValue smashes the old value. */ size = maxSize; while ((*regWinProcs->regEnumValueProc)(key, index, Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL) @@ -927,11 +923,12 @@ if (regWinProcs->useWide) { size *= 2; } - Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), (int) size, &ds); + Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), (int) size, + &ds); name = Tcl_DStringValue(&ds); if (!pattern || Tcl_StringMatch(name, pattern)) { result = Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(name, Tcl_DStringLength(&ds))); if (result != TCL_OK) { @@ -945,26 +942,25 @@ size = maxSize; } Tcl_SetObjResult(interp, resultPtr); Tcl_DStringFree(&buffer); - done: + done: RegCloseKey(key); return result; } /* *---------------------------------------------------------------------- * * OpenKey -- * - * This function opens the specified key. This function is a - * simple wrapper around ParseKeyName and OpenSubKey. + * This function opens the specified key. This function is a simple + * wrapper around ParseKeyName and OpenSubKey. * * Results: - * Returns the opened key in the keyPtr argument and a Tcl - * result code. + * Returns the opened key in the keyPtr argument and a Tcl result code. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -1007,16 +1003,16 @@ /* *---------------------------------------------------------------------- * * OpenSubKey -- * - * This function opens a given subkey of a root key on the - * specified host. + * This function opens a given subkey of a root key on the specified + * host. * * Results: - * Returns the opened key in the keyPtr and a Windows error code - * as the return value. + * Returns the opened key in the keyPtr and a Windows error code as the + * return value. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -1047,32 +1043,29 @@ return result; } } /* - * Now open the specified key with the requested permissions. Note - * that this key must be closed by the caller. + * Now open the specified key with the requested permissions. Note that + * this key must be closed by the caller. */ keyName = (char *) Tcl_WinUtfToTChar(keyName, -1, &buf); if (flags & REG_CREATE) { DWORD create; result = (*regWinProcs->regCreateKeyExProc)(rootKey, keyName, 0, NULL, REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create); - } else { - if (rootKey == HKEY_PERFORMANCE_DATA) { - /* - * Here we fudge it for this special root key. - * See MSDN for more info on HKEY_PERFORMANCE_DATA and - * the peculiarities surrounding it - */ - *keyPtr = HKEY_PERFORMANCE_DATA; - result = ERROR_SUCCESS; - } else { - result = (*regWinProcs->regOpenKeyExProc)(rootKey, keyName, 0, - mode, keyPtr); - } + } else if (rootKey == HKEY_PERFORMANCE_DATA) { + /* + * Here we fudge it for this special root key. See MSDN for more info + * on HKEY_PERFORMANCE_DATA and the peculiarities surrounding it. + */ + *keyPtr = HKEY_PERFORMANCE_DATA; + result = ERROR_SUCCESS; + } else { + result = (*regWinProcs->regOpenKeyExProc)(rootKey, keyName, 0, mode, + keyPtr); } Tcl_DStringFree(&buf); /* * Be sure to close the root key since we are done with it now. @@ -1087,19 +1080,16 @@ /* *---------------------------------------------------------------------- * * ParseKeyName -- * - * This function parses a key name into the host, root, and subkey - * parts. + * This function parses a key name into the host, root, and subkey parts. * * Results: - * The pointers to the start of the host and subkey names are - * returned in the hostNamePtr and keyNamePtr variables. The - * specified root HKEY is returned in rootKeyPtr. Returns - * a standard Tcl result. - * + * The pointers to the start of the host and subkey names are returned in + * the hostNamePtr and keyNamePtr variables. The specified root HKEY is + * returned in rootKeyPtr. Returns a standard Tcl result. * * Side effects: * Modifies the name string by inserting nulls. * *---------------------------------------------------------------------- @@ -1171,13 +1161,13 @@ /* *---------------------------------------------------------------------- * * RecursiveDeleteKey -- * - * This function recursively deletes all the keys below a starting - * key. Although Windows 95 does this automatically, we still need - * to do this for Windows NT. + * This function recursively deletes all the keys below a starting key. + * Although Windows 95 does this automatically, we still need to do this + * for Windows NT. * * Results: * Returns a Windows error code. * * Side effects: @@ -1243,13 +1233,13 @@ /* *---------------------------------------------------------------------- * * SetValue -- * - * This function sets the contents of a registry value. If - * the key or value does not exist, it will be created. If it - * does exist, then the data and type will be replaced. + * This function sets the contents of a registry value. If the key or + * value does not exist, it will be created. If it does exist, then the + * data and type will be replaced. * * Results: * Returns a normal Tcl result. * * Side effects: @@ -1309,22 +1299,22 @@ Tcl_DStringFree(&nameBuf); return TCL_ERROR; } /* - * Append the elements as null terminated strings. Note that - * we must not assume the length of the string in case there are - * embedded nulls, which aren't allowed in REG_MULTI_SZ values. + * Append the elements as null terminated strings. Note that we must + * not assume the length of the string in case there are embedded + * nulls, which aren't allowed in REG_MULTI_SZ values. */ Tcl_DStringInit(&data); for (i = 0; i < objc; i++) { Tcl_DStringAppend(&data, Tcl_GetString(objv[i]), -1); /* - * Add a null character to separate this value from the next. - * We accomplish this by growing the string by one byte. Since the + * Add a null character to separate this value from the next. We + * accomplish this by growing the string by one byte. Since the * DString always tacks on an extra null byte, the new byte will * already be set to null. */ Tcl_DStringSetLength(&data, Tcl_DStringLength(&data)+1); @@ -1364,14 +1354,17 @@ data = Tcl_GetByteArrayFromObj(dataObj, &length); result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type, (BYTE *)data, (DWORD) length); } + Tcl_DStringFree(&nameBuf); RegCloseKey(key); + if (result != ERROR_SUCCESS) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("unable to set value: ", -1)); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("unable to set value: ", -1)); AppendSystemError(interp, result); return TCL_ERROR; } return TCL_OK; } @@ -1379,13 +1372,12 @@ /* *---------------------------------------------------------------------- * * BroadcastValue -- * - * This function broadcasts a WM_SETTINGCHANGE message to indicate - * to other programs that we have changed the contents of a registry - * value. + * This function broadcasts a WM_SETTINGCHANGE message to indicate to + * other programs that we have changed the contents of a registry value. * * Results: * Returns a normal Tcl result. * * Side effects: @@ -1411,11 +1403,12 @@ return TCL_ERROR; } if (objc > 3) { str = Tcl_GetStringFromObj(objv[3], &len); - if ((len < 2) || (*str != '-') || strncmp(str, "-timeout", (size_t) len)) { + if ((len < 2) || (*str != '-') + || strncmp(str, "-timeout", (size_t) len)) { Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?"); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, objv[4], (int *) &timeout) != TCL_OK) { return TCL_ERROR; @@ -1428,10 +1421,11 @@ } /* * Use the ignore the result. */ + result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, (WPARAM) 0, (LPARAM) str, SMTO_ABORTIFHUNG, timeout, &sendResult); objPtr = Tcl_NewObj(); Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) result)); @@ -1444,12 +1438,12 @@ /* *---------------------------------------------------------------------- * * AppendSystemError -- * - * This routine formats a Windows system error message and places - * it into the interpreter result. + * This routine formats a Windows system error message and places it into + * the interpreter result. * * Results: * None. * * Side effects: @@ -1510,10 +1504,11 @@ length = Tcl_DStringLength(&ds); /* * Trim the trailing CR/LF from the system message. */ + if (msg[length-1] == '\n') { msg[--length] = 0; } if (msg[length-1] == '\r') { msg[--length] = 0; @@ -1533,12 +1528,12 @@ /* *---------------------------------------------------------------------- * * ConvertDWORD -- * - * This function determines whether a DWORD needs to be byte - * swapped, and returns the appropriately swapped value. + * This function determines whether a DWORD needs to be byte swapped, and + * returns the appropriately swapped value. * * Results: * Returns a converted DWORD. * * Side effects: @@ -1560,5 +1555,13 @@ */ localType = (*((char*)(&order)) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN; return (type != localType) ? SWAPLONG(value) : value; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: win/tclWinSerial.c ================================================================== --- win/tclWinSerial.c +++ win/tclWinSerial.c @@ -1,19 +1,19 @@ /* * tclWinSerial.c -- * - * This file implements the Windows-specific serial port functions, - * and the "serial" channel driver. + * This file implements the Windows-specific serial port functions, and + * the "serial" channel driver. * * Copyright (c) 1999 by Scriptics Corp. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * Serial functionality implemented by Rolf.Schroedter@dlr.de * - * RCS: @(#) $Id: tclWinSerial.c,v 1.28 2003/08/19 19:39:56 patthoyts Exp $ + * RCS: @(#) $Id: tclWinSerial.c,v 1.28.2.3 2005/10/08 13:45:04 dgp Exp $ */ #include "tclWinInt.h" #include @@ -37,33 +37,34 @@ /* * Bit masks used in the flags field of the SerialInfo structure below. */ -#define SERIAL_PENDING (1<<0) /* Message is pending in the queue. */ -#define SERIAL_ASYNC (1<<1) /* Channel is non-blocking. */ +#define SERIAL_PENDING (1<<0) /* Message is pending in the queue. */ +#define SERIAL_ASYNC (1<<1) /* Channel is non-blocking. */ /* * Bit masks used in the sharedFlags field of the SerialInfo structure below. */ -#define SERIAL_EOF (1<<2) /* Serial has reached EOF. */ -#define SERIAL_ERROR (1<<4) +#define SERIAL_EOF (1<<2) /* Serial has reached EOF. */ +#define SERIAL_ERROR (1<<4) /* * Default time to block between checking status on the serial port. */ -#define SERIAL_DEFAULT_BLOCKTIME 10 /* 10 msec */ +#define SERIAL_DEFAULT_BLOCKTIME 10 /* 10 msec */ /* * Define Win32 read/write error masks returned by ClearCommError() */ -#define SERIAL_READ_ERRORS ( CE_RXOVER | CE_OVERRUN | CE_RXPARITY \ - | CE_FRAME | CE_BREAK ) -#define SERIAL_WRITE_ERRORS ( CE_TXFULL | CE_PTO ) +#define SERIAL_READ_ERRORS \ + (CE_RXOVER | CE_OVERRUN | CE_RXPARITY | CE_FRAME | CE_BREAK) +#define SERIAL_WRITE_ERRORS \ + (CE_TXFULL | CE_PTO) /* * This structure describes per-instance data for a serial based channel. */ @@ -76,82 +77,79 @@ * which operations are valid on the file. */ int watchMask; /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, or TCL_EXCEPTION: indicates * which events should be reported. */ int flags; /* State flags, see above for a list. */ - int readable; /* flag that the channel is readable */ - int writable; /* flag that the channel is writable */ - int blockTime; /* max. blocktime in msec */ + int readable; /* Flag that the channel is readable. */ + int writable; /* Flag that the channel is writable. */ + int blockTime; /* Maximum blocktime in msec. */ unsigned int lastEventTime; /* Time in milliseconds since last readable - * event */ + * event. */ /* Next readable event only after blockTime */ DWORD error; /* pending error code returned by * ClearCommError() */ DWORD lastError; /* last error code, can be fetched with * fconfigure chan -lasterror */ - DWORD sysBufRead; /* Win32 system buffer size for read ops, + DWORD sysBufRead; /* Win32 system buffer size for read ops, * default=4096 */ - DWORD sysBufWrite; /* Win32 system buffer size for write ops, + DWORD sysBufWrite; /* Win32 system buffer size for write ops, * default=4096 */ Tcl_ThreadId threadId; /* Thread to which events should be reported. * This value is used by the reader/writer * threads. */ - OVERLAPPED osRead; /* OVERLAPPED structure for read operations */ + OVERLAPPED osRead; /* OVERLAPPED structure for read operations. */ OVERLAPPED osWrite; /* OVERLAPPED structure for write operations */ HANDLE writeThread; /* Handle to writer thread. */ - CRITICAL_SECTION csWrite; /* Writer thread synchronisation */ + CRITICAL_SECTION csWrite; /* Writer thread synchronisation. */ HANDLE evWritable; /* Manual-reset event to signal when the - * writer thread has finished waiting for - * the current buffer to be written. */ + * writer thread has finished waiting for the + * current buffer to be written. */ HANDLE evStartWriter; /* Auto-reset event used by the main thread to - * signal when the writer thread should attempt - * to write to the serial. */ + * signal when the writer thread should + * attempt to write to the serial. */ HANDLE evStopWriter; /* Auto-reset event used by the main thread to * signal when the writer thread should close. */ DWORD writeError; /* An error caused by the last background - * write. Set to 0 if no error has been - * detected. This word is shared with the + * write. Set to 0 if no error has been + * detected. This word is shared with the * writer thread so access must be - * synchronized with the evWritable object. - */ - char *writeBuf; /* Current background output buffer. - * Access is synchronized with the evWritable - * object. */ - int writeBufLen; /* Size of write buffer. Access is - * synchronized with the evWritable - * object. */ - int toWrite; /* Current amount to be written. Access is + * synchronized with the evWritable object. */ + char *writeBuf; /* Current background output buffer. Access is + * synchronized with the evWritable object. */ + int writeBufLen; /* Size of write buffer. Access is + * synchronized with the evWritable object. */ + int toWrite; /* Current amount to be written. Access is * synchronized with the evWritable object. */ int writeQueue; /* Number of bytes pending in output queue. - * Offset to DCB.cbInQue. - * Used to query [fconfigure -queue] */ + * Offset to DCB.cbInQue. Used to query + * [fconfigure -queue] */ } SerialInfo; typedef struct ThreadSpecificData { /* - * The following pointer refers to the head of the list of serials - * that are being watched for file events. + * The following pointer refers to the head of the list of serials that + * are being watched for file events. */ SerialInfo *firstSerialPtr; } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* - * The following structure is what is added to the Tcl event queue when - * serial events are generated. + * The following structure is what is added to the Tcl event queue when serial + * events are generated. */ typedef struct SerialEvent { - Tcl_Event header; /* Information that is standard for - * all events. */ - SerialInfo *infoPtr; /* Pointer to serial info structure. Note - * that we still have to verify that the - * serial exists before dereferencing this + Tcl_Event header; /* Information that is standard for all + * events. */ + SerialInfo *infoPtr; /* Pointer to serial info structure. Note that + * we still have to verify that the serial + * exists before dereferencing this * pointer. */ } SerialEvent; /* * We don't use timeouts. @@ -188,28 +186,29 @@ static void SerialSetupProc(ClientData clientData, int flags); static void SerialWatchProc(ClientData instanceData, int mask); static void ProcExitHandler(ClientData clientData); -static int SerialGetOptionProc _ANSI_ARGS_(( - ClientData instanceData, - Tcl_Interp *interp, CONST char *optionName, - Tcl_DString *dsPtr)); -static int SerialSetOptionProc _ANSI_ARGS_(( - ClientData instanceData, - Tcl_Interp *interp, CONST char *optionName, - CONST char *value)); -static DWORD WINAPI SerialWriterThread(LPVOID arg); +static int SerialGetOptionProc(ClientData instanceData, + Tcl_Interp *interp, CONST char *optionName, + Tcl_DString *dsPtr); +static int SerialSetOptionProc(ClientData instanceData, + Tcl_Interp *interp, CONST char *optionName, + CONST char *value); +static DWORD WINAPI SerialWriterThread(LPVOID arg); + +static void SerialThreadActionProc(ClientData instanceData, + int action); /* * This structure describes the channel type structure for command serial * based IO. */ static Tcl_ChannelType serialChannelType = { "serial", /* Type name. */ - TCL_CHANNEL_VERSION_2, /* v2 channel */ + TCL_CHANNEL_VERSION_4, /* v4 channel */ SerialCloseProc, /* Close proc. */ SerialInputProc, /* Input proc. */ SerialOutputProc, /* Output proc. */ NULL, /* Seek proc. */ SerialSetOptionProc, /* Set option proc. */ @@ -218,10 +217,12 @@ SerialGetHandleProc, /* Get an OS handle from channel. */ NULL, /* close2proc. */ SerialBlockProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ + NULL, /* wide seek proc */ + SerialThreadActionProc, /* thread action proc */ }; /* *---------------------------------------------------------------------- * @@ -270,12 +271,12 @@ /* *---------------------------------------------------------------------- * * SerialExitHandler -- * - * This function is called to cleanup the serial module before - * Tcl is unloaded. + * This function is called to cleanup the serial module before Tcl is + * unloaded. * * Results: * None. * * Side effects: @@ -284,20 +285,19 @@ *---------------------------------------------------------------------- */ static void SerialExitHandler( - ClientData clientData) /* Old window proc */ + ClientData clientData) /* Old window proc */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); SerialInfo *infoPtr; /* - * Clear all eventually pending output. - * Otherwise Tcl's exit could totally block, - * because it performs a blocking flush on all open channels. - * Note that serial write operations may be blocked due to handshake. + * Clear all eventually pending output. Otherwise Tcl's exit could totally + * block, because it performs a blocking flush on all open channels. Note + * that serial write operations may be blocked due to handshake. */ for (infoPtr = tsdPtr->firstSerialPtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { PurgeComm(infoPtr->handle, @@ -309,12 +309,12 @@ /* *---------------------------------------------------------------------- * * ProcExitHandler -- * - * This function is called to cleanup the process list before - * Tcl is unloaded. + * This function is called to cleanup the process list before Tcl is + * unloaded. * * Results: * None. * * Side effects: @@ -323,11 +323,11 @@ *---------------------------------------------------------------------- */ static void ProcExitHandler( - ClientData clientData) /* Old window proc */ + ClientData clientData) /* Old window proc */ { Tcl_MutexLock(&serialMutex); initialized = 0; Tcl_MutexUnlock(&serialMutex); } @@ -342,16 +342,17 @@ * Results: * None. * * Side effects: * Updates the maximum blocking time. + * *---------------------------------------------------------------------- */ static void SerialBlockTime( - int msec) /* milli-seconds */ + int msec) /* milli-seconds */ { Tcl_Time blockTime; blockTime.sec = msec / 1000; blockTime.usec = (msec % 1000) * 1000; @@ -368,10 +369,11 @@ * Results: * The current time. * * Side effects: * None. + * *---------------------------------------------------------------------- */ static unsigned int SerialGetMilliseconds(void) @@ -386,38 +388,39 @@ /* *---------------------------------------------------------------------- * * SerialSetupProc -- * - * This procedure is invoked before Tcl_DoOneEvent blocks waiting - * for an event. + * This procedure is invoked before Tcl_DoOneEvent blocks waiting for an + * event. * * Results: - * None. + * None. * * Side effects: - * Adjusts the block time if needed. + * Adjusts the block time if needed. * *---------------------------------------------------------------------- */ void SerialSetupProc( - ClientData data, /* Not used. */ - int flags) /* Event flags as passed to Tcl_DoOneEvent. */ + ClientData data, /* Not used. */ + int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { SerialInfo *infoPtr; int block = 1; - int msec = INT_MAX; /* min. found block time */ + int msec = INT_MAX; /* min. found block time */ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!(flags & TCL_FILE_EVENTS)) { return; } /* - * Look to see if any events handlers installed. If they are, do not block. + * Look to see if any events handlers installed. If they are, do not + * block. */ for (infoPtr=tsdPtr->firstSerialPtr ; infoPtr!=NULL ; infoPtr=infoPtr->nextPtr) { if (infoPtr->watchMask & TCL_WRITABLE) { @@ -440,12 +443,12 @@ /* *---------------------------------------------------------------------- * * SerialCheckProc -- * - * This procedure is called by Tcl_DoOneEvent to check the serial - * event source for events. + * This procedure is called by Tcl_DoOneEvent to check the serial event + * source for events. * * Results: * None. * * Side effects: @@ -454,12 +457,12 @@ *---------------------------------------------------------------------- */ static void SerialCheckProc( - ClientData data, /* Not used. */ - int flags) /* Event flags as passed to Tcl_DoOneEvent. */ + ClientData data, /* Not used. */ + int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { SerialInfo *infoPtr; SerialEvent *evPtr; int needEvent; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -482,36 +485,34 @@ } needEvent = 0; /* - * If WRITABLE watch mask is set look for infoPtr->evWritable - * object + * If WRITABLE watch mask is set look for infoPtr->evWritable object. */ - if (infoPtr->watchMask & TCL_WRITABLE) { - if (WaitForSingleObject(infoPtr->evWritable, 0) != WAIT_TIMEOUT) { - infoPtr->writable = 1; - needEvent = 1; - } + if (infoPtr->watchMask & TCL_WRITABLE && + WaitForSingleObject(infoPtr->evWritable, 0) != WAIT_TIMEOUT) { + infoPtr->writable = 1; + needEvent = 1; } /* - * If READABLE watch mask is set call ClearCommError to poll - * cbInQue Window errors are ignored here + * If READABLE watch mask is set call ClearCommError to poll cbInQue. + * Window errors are ignored here. */ if (infoPtr->watchMask & TCL_READABLE) { if (ClearCommError(infoPtr->handle, &infoPtr->error, &cStat)) { /* - * Look for characters already pending in windows - * queue. If they are, poll. + * Look for characters already pending in windows queue. If + * they are, poll. */ if (infoPtr->watchMask & TCL_READABLE) { /* - * force fileevent after serial read error + * Force fileevent after serial read error. */ if ((cStat.cbInQue > 0) || (infoPtr->error & SERIAL_READ_ERRORS)) { infoPtr->readable = 1; @@ -525,12 +526,11 @@ } } } /* - * Queue an event if the serial is signaled for reading or - * writing. + * Queue an event if the serial is signaled for reading or writing. */ if (needEvent) { infoPtr->flags |= SERIAL_PENDING; evPtr = (SerialEvent *) ckalloc(sizeof(SerialEvent)); @@ -565,13 +565,13 @@ { int errorCode = 0; SerialInfo *infoPtr = (SerialInfo *) instanceData; /* - * Only serial READ can be switched between blocking & nonblocking - * using COMMTIMEOUTS. Serial write emulates blocking & - * nonblocking by the SerialWriterThread. + * Only serial READ can be switched between blocking & nonblocking using + * COMMTIMEOUTS. Serial write emulates blocking & nonblocking by the + * SerialWriterThread. */ if (mode == TCL_MODE_NONBLOCKING) { infoPtr->flags |= SERIAL_ASYNC; } else { @@ -614,46 +614,43 @@ CloseHandle(serialPtr->osRead.hEvent); } serialPtr->validMask &= ~TCL_READABLE; if (serialPtr->validMask & TCL_WRITABLE) { - /* - * Generally we cannot wait for a pending write operation - * because it may hang due to handshake + * Generally we cannot wait for a pending write operation because it + * may hang due to handshake * WaitForSingleObject(serialPtr->evWritable, INFINITE); */ /* - * The thread may have already closed on it's own. Check it's - * exit code. + * The thread may have already closed on it's own. Check it's exit + * code. */ GetExitCodeThread(serialPtr->writeThread, &exitCode); if (exitCode == STILL_ACTIVE) { /* - * Set the stop event so that if the writer thread is - * blocked in SerialWriterThread on WaitForMultipleEvents, it - * will exit cleanly. + * Set the stop event so that if the writer thread is blocked in + * SerialWriterThread on WaitForMultipleEvents, it will exit + * cleanly. */ SetEvent(serialPtr->evStopWriter); /* - * Wait at most 20 milliseconds for the writer thread to - * close. + * Wait at most 20 milliseconds for the writer thread to close. */ - if (WaitForSingleObject(serialPtr->writeThread, 20) - == WAIT_TIMEOUT) { + if (WaitForSingleObject(serialPtr->writeThread, + 20) == WAIT_TIMEOUT) { /* - * Forcibly terminate the background thread as a last - * resort. Note that we need to guard against - * terminating the thread while it is in the middle of - * Tcl_ThreadAlert because it won't be able to release - * the notifier lock. + * Forcibly terminate the background thread as a last resort. + * Note that we need to guard against terminating the thread + * while it is in the middle of Tcl_ThreadAlert because it + * won't be able to release the notifier lock. */ Tcl_MutexLock(&serialMutex); /* BUG: this leaks memory */ @@ -674,13 +671,13 @@ PurgeComm(serialPtr->handle, PURGE_TXABORT | PURGE_TXCLEAR); } serialPtr->validMask &= ~TCL_WRITABLE; /* - * Don't close the Win32 handle if the handle is a standard - * channel during the thread exit process. Otherwise, one thread - * may kill the stdio of another. + * Don't close the Win32 handle if the handle is a standard channel during + * the thread exit process. Otherwise, one thread may kill the stdio of + * another. */ if (!TclInThreadExit() || ((GetStdHandle(STD_INPUT_HANDLE) != serialPtr->handle) && (GetStdHandle(STD_OUTPUT_HANDLE) != serialPtr->handle) @@ -705,12 +702,11 @@ break; } } /* - * Wrap the error file into a channel and give it to the cleanup - * routine. + * Wrap the error file into a channel and give it to the cleanup routine. */ if (serialPtr->writeBuf != NULL) { ckfree(serialPtr->writeBuf); serialPtr->writeBuf = NULL; @@ -726,12 +722,12 @@ /* *---------------------------------------------------------------------- * * blockingRead -- * - * Perform a blocking read into the buffer given. Returns count - * of how many bytes were actually read, and an error indication. + * Perform a blocking read into the buffer given. Returns count of how + * many bytes were actually read, and an error indication. * * Results: * A count of how many bytes were read is returned and an error * indication is returned. * @@ -740,54 +736,61 @@ * *---------------------------------------------------------------------- */ static int -blockingRead( +blockingRead( SerialInfo *infoPtr, /* Serial info structure */ LPVOID buf, /* The input buffer pointer */ DWORD bufSize, /* The number of bytes to read */ - LPDWORD lpRead, /* Returns number of bytes read */ + LPDWORD lpRead, /* Returns number of bytes read */ LPOVERLAPPED osPtr ) /* OVERLAPPED structure */ { /* - * Perform overlapped blocking read. + * Perform overlapped blocking read. * 1. Reset the overlapped event * 2. Start overlapped read operation * 3. Wait for completion */ - /* + /* * Set Offset to ZERO, otherwise NT4.0 may report an error. */ osPtr->Offset = osPtr->OffsetHigh = 0; ResetEvent(osPtr->hEvent); if (!ReadFile(infoPtr->handle, buf, bufSize, lpRead, osPtr)) { if (GetLastError() != ERROR_IO_PENDING) { - /* ReadFile failed, but it isn't delayed. Report error. */ + /* + * ReadFile failed, but it isn't delayed. Report error. + */ + return FALSE; - } else { - /* Read is pending, wait for completion, timeout ? */ + } else { + /* + * Read is pending, wait for completion, timeout? + */ + if (!GetOverlappedResult(infoPtr->handle, osPtr, lpRead, TRUE)) { return FALSE; } } } else { - /* ReadFile completed immediately. */ + /* + * ReadFile completed immediately. + */ } return TRUE; } /* *---------------------------------------------------------------------- * * blockingWrite -- * - * Perform a blocking write from the buffer given. Returns count - * of how many bytes were actually written, and an error - * indication. + * Perform a blocking write from the buffer given. Returns count of how + * many bytes were actually written, and an error indication. * * Results: * A count of how many bytes were written is returned and an error * indication is returned. * @@ -800,17 +803,17 @@ static int blockingWrite( SerialInfo *infoPtr, /* Serial info structure */ LPVOID buf, /* The output buffer pointer */ DWORD bufSize, /* The number of bytes to write */ - LPDWORD lpWritten, /* Returns number of bytes written */ - LPOVERLAPPED osPtr ) /* OVERLAPPED structure */ + LPDWORD lpWritten, /* Returns number of bytes written */ + LPOVERLAPPED osPtr) /* OVERLAPPED structure */ { int result; /* - * Perform overlapped blocking write. + * Perform overlapped blocking write. * 1. Reset the overlapped event * 2. Remove these bytes from the output queue counter * 3. Start overlapped write operation * 3. Remove these bytes from the output queue counter * 4. Wait for completion @@ -819,36 +822,50 @@ ResetEvent(osPtr->hEvent); EnterCriticalSection(&infoPtr->csWrite); infoPtr->writeQueue -= bufSize; - /* - * Set Offset to ZERO, otherwise NT4.0 may report an error + + /* + * Set Offset to ZERO, otherwise NT4.0 may report an error */ + osPtr->Offset = osPtr->OffsetHigh = 0; result = WriteFile(infoPtr->handle, buf, bufSize, lpWritten, osPtr); LeaveCriticalSection(&infoPtr->csWrite); if (result == FALSE) { int err = GetLastError(); + switch (err) { case ERROR_IO_PENDING: - /* Write is pending, wait for completion */ + /* + * Write is pending, wait for completion. + */ + if (!GetOverlappedResult(infoPtr->handle, osPtr, lpWritten, TRUE)) { return FALSE; } break; case ERROR_COUNTER_TIMEOUT: - /* Write timeout handled in SerialOutputProc */ + /* + * Write timeout handled in SerialOutputProc. + */ + break; default: - /* WriteFile failed, but it isn't delayed. Report error */ + /* + * WriteFile failed, but it isn't delayed. Report error. + */ + return FALSE; } } else { - /* WriteFile completed immediately. */ + /* + * WriteFile completed immediately. + */ } EnterCriticalSection(&infoPtr->csWrite); infoPtr->writeQueue += (*lpWritten - bufSize); LeaveCriticalSection(&infoPtr->csWrite); @@ -859,13 +876,12 @@ /* *---------------------------------------------------------------------- * * SerialInputProc -- * - * Reads input from the IO channel into the buffer given. Returns - * count of how many bytes were actually read, and an error - * indication. + * Reads input from the IO channel into the buffer given. Returns count + * of how many bytes were actually read, and an error indication. * * Results: * A count of how many bytes were read is returned and an error * indication is returned in an output argument. * @@ -877,12 +893,12 @@ static int SerialInputProc( ClientData instanceData, /* Serial state. */ char *buf, /* Where to store data read. */ - int bufSize, /* How much space is available - * in the buffer? */ + int bufSize, /* How much space is available in the + * buffer? */ int *errorCode) /* Where to store error code. */ { SerialInfo *infoPtr = (SerialInfo *) instanceData; DWORD bytesRead = 0; COMSTAT cStat; @@ -896,27 +912,26 @@ if (infoPtr->error & SERIAL_READ_ERRORS) { goto commError; } /* - * Look for characters already pending in windows queue. - * This is the mainly restored good old code from Tcl8.0 + * Look for characters already pending in windows queue. This is the + * mainly restored good old code from Tcl8.0 */ if (ClearCommError(infoPtr->handle, &infoPtr->error, &cStat)) { /* - * Check for errors here, but not in the evSetup/Check procedures + * Check for errors here, but not in the evSetup/Check procedures. */ if (infoPtr->error & SERIAL_READ_ERRORS) { goto commError; } if (infoPtr->flags & SERIAL_ASYNC) { /* - * NON_BLOCKING mode: - * Avoid blocking by reading more bytes than available - * in input buffer + * NON_BLOCKING mode: Avoid blocking by reading more bytes than + * available in input buffer. */ if (cStat.cbInQue > 0) { if ((DWORD) bufSize > cStat.cbInQue) { bufSize = cStat.cbInQue; @@ -925,12 +940,11 @@ errno = *errorCode = EAGAIN; return -1; } } else { /* - * BLOCKING mode: - * Tcl trys to read a full buffer of 4 kBytes here + * BLOCKING mode: Tcl trys to read a full buffer of 4 kBytes here. */ if (cStat.cbInQue > 0) { if ((DWORD) bufSize > cStat.cbInQue) { bufSize = cStat.cbInQue; @@ -944,43 +958,41 @@ if (bufSize == 0) { return bytesRead = 0; } /* - * Perform blocking read. Doesn't block in non-blocking mode, - * because we checked the number of available bytes. + * Perform blocking read. Doesn't block in non-blocking mode, because we + * checked the number of available bytes. */ + if (blockingRead(infoPtr, (LPVOID) buf, (DWORD) bufSize, &bytesRead, &infoPtr->osRead) == FALSE) { - goto error; + TclWinConvertError(GetLastError()); + *errorCode = errno; + return -1; } return bytesRead; - error: - TclWinConvertError(GetLastError()); - *errorCode = errno; - return -1; - commError: - infoPtr->lastError = infoPtr->error;/* save last error code */ - infoPtr->error = 0; /* reset error code */ - *errorCode = EIO; /* to return read-error only once */ + infoPtr->lastError = infoPtr->error; + /* save last error code */ + infoPtr->error = 0; /* reset error code */ + *errorCode = EIO; /* to return read-error only once */ return -1; } /* *---------------------------------------------------------------------- * * SerialOutputProc -- * - * Writes the given output on the IO channel. Returns count of - * how many characters were actually written, and an error - * indication. + * Writes the given output on the IO channel. Returns count of how many + * characters were actually written, and an error indication. * * Results: - * A count of how many characters were written is returned and an - * error indication is returned in an output argument. + * A count of how many characters were written is returned and an error + * indication is returned in an output argument. * * Side effects: * Writes output on the actual channel. * *---------------------------------------------------------------------- @@ -997,13 +1009,13 @@ DWORD bytesWritten, timeout; *errorCode = 0; /* - * At EXIT Tcl trys to flush all open channels in blocking mode. - * We avoid blocking output after ExitProc or CloseHandler(chan) - * has been called by checking the corrresponding variables. + * At EXIT Tcl trys to flush all open channels in blocking mode. We avoid + * blocking output after ExitProc or CloseHandler(chan) has been called by + * checking the corrresponding variables. */ if (!initialized || TclInExit()) { return toWrite; } @@ -1011,21 +1023,22 @@ /* * Check if there is a CommError pending from SerialCheckProc */ if (infoPtr->error & SERIAL_WRITE_ERRORS) { - infoPtr->lastError = infoPtr->error; /* save last error code */ - infoPtr->error = 0; /* reset error code */ + infoPtr->lastError = infoPtr->error; + /* save last error code */ + infoPtr->error = 0; /* reset error code */ errno = EIO; goto error; } timeout = (infoPtr->flags & SERIAL_ASYNC) ? 0 : INFINITE; if (WaitForSingleObject(infoPtr->evWritable, timeout) == WAIT_TIMEOUT) { /* - * The writer thread is blocked waiting for a write to complete - * and the channel is in non-blocking mode. + * The writer thread is blocked waiting for a write to complete and + * the channel is in non-blocking mode. */ errno = EWOULDBLOCK; goto error1; } @@ -1048,12 +1061,12 @@ infoPtr->writeQueue += toWrite; LeaveCriticalSection(&infoPtr->csWrite); if (infoPtr->flags & SERIAL_ASYNC) { /* - * The serial is non-blocking, so copy the data into the output - * buffer and restart the writer thread. + * The serial is non-blocking, so copy the data into the output buffer + * and restart the writer thread. */ if (toWrite > infoPtr->writeBufLen) { /* * Reallocate the buffer to be large enough to hold the data. @@ -1071,20 +1084,22 @@ SetEvent(infoPtr->evStartWriter); bytesWritten = (DWORD) toWrite; } else { /* - * In the blocking case, just try to write the buffer directly. - * This avoids an unnecessary copy. + * In the blocking case, just try to write the buffer directly. This + * avoids an unnecessary copy. */ if (!blockingWrite(infoPtr, (LPVOID) buf, (DWORD) toWrite, &bytesWritten, &infoPtr->osWrite)) { goto writeError; } if (bytesWritten != (DWORD) toWrite) { - /* Write timeout */ + /* + * Write timeout. + */ infoPtr->lastError |= CE_PTO; errno = EIO; goto error; } } @@ -1093,39 +1108,38 @@ writeError: TclWinConvertError(GetLastError()); error: - /* - * Reset the output queue counter on error during blocking output + /* + * Reset the output queue counter on error during blocking output */ /* * EnterCriticalSection(&infoPtr->csWrite); * infoPtr->writeQueue = 0; * LeaveCriticalSection(&infoPtr->csWrite); */ - error1: + error1: *errorCode = errno; return -1; } /* *---------------------------------------------------------------------- * * SerialEventProc -- * - * This function is invoked by Tcl_ServiceEvent when a file event - * reaches the front of the event queue. This procedure invokes - * Tcl_NotifyChannel on the serial. + * This function is invoked by Tcl_ServiceEvent when a file event reaches + * the front of the event queue. This procedure invokes Tcl_NotifyChannel + * on the serial. * * Results: - * Returns 1 if the event was handled, meaning it should be - * removed from the queue. Returns 0 if the event was not - * handled, meaning it should stay on the queue. The only time - * the event isn't handled is if the TCL_FILE_EVENTS flag bit - * isn't set. + * Returns 1 if the event was handled, meaning it should be removed from + * the queue. Returns 0 if the event was not handled, meaning it should + * stay on the queue. The only time the event isn't handled is if the + * TCL_FILE_EVENTS flag bit isn't set. * * Side effects: * Whatever the notifier callback does. * *---------------------------------------------------------------------- @@ -1132,12 +1146,12 @@ */ static int SerialEventProc( Tcl_Event *evPtr, /* Event to service. */ - int flags) /* Flags that indicate what events to - * handle, such as TCL_FILE_EVENTS. */ + int flags) /* Flags that indicate what events to handle, such as + * TCL_FILE_EVENTS. */ { SerialEvent *serialEvPtr = (SerialEvent *)evPtr; SerialInfo *infoPtr; int mask; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -1146,13 +1160,13 @@ return 0; } /* * Search through the list of watched serials for the one whose handle - * matches the event. We do this rather than simply dereferencing - * the handle in the event so that serials can be deleted while the - * event is in the queue. + * matches the event. We do this rather than simply dereferencing the + * handle in the event so that serials can be deleted while the event is + * in the queue. */ for (infoPtr = tsdPtr->firstSerialPtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (serialEvPtr->infoPtr == infoPtr) { @@ -1168,13 +1182,13 @@ if (!infoPtr) { return 1; } /* - * Check to see if the serial is readable. Note - * that we can't tell if a serial is writable, so we always report it - * as being writable unless we have detected EOF. + * Check to see if the serial is readable. Note that we can't tell if a + * serial is writable, so we always report it as being writable unless we + * have detected EOF. */ mask = 0; if (infoPtr->watchMask & TCL_WRITABLE) { if (infoPtr->writable) { @@ -1201,12 +1215,11 @@ /* *---------------------------------------------------------------------- * * SerialWatchProc -- * - * Called by the notifier to set up to watch for events on this - * channel. + * Called by the notifier to set up to watch for events on this channel. * * Results: * None. * * Side effects: @@ -1216,22 +1229,22 @@ */ static void SerialWatchProc( ClientData instanceData, /* Serial state. */ - int mask) /* What events to watch for, OR-ed - * combination of TCL_READABLE, - * TCL_WRITABLE and TCL_EXCEPTION. */ + int mask) /* What events to watch for, OR-ed combination + * of TCL_READABLE, TCL_WRITABLE and + * TCL_EXCEPTION. */ { SerialInfo **nextPtrPtr, *ptr; SerialInfo *infoPtr = (SerialInfo *) instanceData; int oldMask = infoPtr->watchMask; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* - * Since the file is always ready for events, we set the block time - * so we will poll. + * Since the file is always ready for events, we set the block time so we + * will poll. */ infoPtr->watchMask = mask & infoPtr->validMask; if (infoPtr->watchMask) { if (!oldMask) { @@ -1258,16 +1271,16 @@ /* *---------------------------------------------------------------------- * * SerialGetHandleProc -- * - * Called from Tcl_GetChannelHandle to retrieve OS handles from - * inside a command serial port based channel. + * Called from Tcl_GetChannelHandle to retrieve OS handles from inside a + * command serial port based channel. * * Results: - * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if - * there is no handle for the specified direction. + * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no + * handle for the specified direction. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -1275,11 +1288,11 @@ static int SerialGetHandleProc( ClientData instanceData, /* The serial state. */ int direction, /* TCL_READABLE or TCL_WRITABLE */ - ClientData *handlePtr) /* Where to store the handle. */ + ClientData *handlePtr) /* Where to store the handle. */ { SerialInfo *infoPtr = (SerialInfo *) instanceData; *handlePtr = (ClientData) infoPtr->handle; return TCL_OK; @@ -1288,36 +1301,35 @@ /* *---------------------------------------------------------------------- * * SerialWriterThread -- * - * This function runs in a separate thread and writes data - * onto a serial. + * This function runs in a separate thread and writes data onto a serial. * * Results: - * Always returns 0. + * Always returns 0. * * Side effects: - * Signals the main thread when an output operation is completed. - * May cause the main thread to wake up by posting a message. + * Signals the main thread when an output operation is completed. May + * cause the main thread to wake up by posting a message. * *---------------------------------------------------------------------- */ static DWORD WINAPI SerialWriterThread(LPVOID arg) { - SerialInfo *infoPtr = (SerialInfo *)arg; DWORD bytesWritten, toWrite, waitResult; char *buf; - OVERLAPPED myWrite; /* have an own OVERLAPPED in this thread */ + OVERLAPPED myWrite; /* Have an own OVERLAPPED in this thread. */ HANDLE wEvents[2]; /* * The stop event takes precedence by being first in the list. */ + wEvents[0] = infoPtr->evStopWriter; wEvents[1] = infoPtr->evStartWriter; for (;;) { /* @@ -1326,12 +1338,12 @@ waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE); if (waitResult != (WAIT_OBJECT_0 + 1)) { /* - * The start event was not signaled. It might be the stop event - * or an error, so exit. + * The start event was not signaled. It might be the stop event or + * an error, so exit. */ break; } @@ -1344,24 +1356,27 @@ * Loop until all of the bytes are written or an error occurs. */ while (toWrite > 0) { /* - * Check for pending writeError. Ignore all write - * operations until the user has been notified + * Check for pending writeError. Ignore all write operations until + * the user has been notified. */ if (infoPtr->writeError) { break; } - if (blockingWrite(infoPtr, (LPVOID) buf, (DWORD) toWrite, + if (blockingWrite(infoPtr, (LPVOID) buf, (DWORD) toWrite, &bytesWritten, &myWrite) == FALSE) { infoPtr->writeError = GetLastError(); break; } if (bytesWritten != toWrite) { - /* Write timeout */ + /* + * Write timeout. + */ + infoPtr->writeError = ERROR_WRITE_FAULT; break; } toWrite -= bytesWritten; buf += bytesWritten; @@ -1368,25 +1383,31 @@ } CloseHandle(myWrite.hEvent); /* - * Signal the main thread by signalling the evWritable event - * and then waking up the notifier thread. + * Signal the main thread by signalling the evWritable event and then + * waking up the notifier thread. */ SetEvent(infoPtr->evWritable); /* - * Alert the foreground thread. Note that we need to treat - * this like a critical section so the foreground thread does - * not terminate this thread while we are holding a mutex in - * the notifier code. + * Alert the foreground thread. Note that we need to treat this like a + * critical section so the foreground thread does not terminate this + * thread while we are holding a mutex in the notifier code. */ Tcl_MutexLock(&serialMutex); - Tcl_ThreadAlert(infoPtr->threadId); + if (infoPtr->threadId != NULL) { + /* + * TIP #218: When in flight ignore the event, no one will receive + * it anyway. + */ + + Tcl_ThreadAlert(infoPtr->threadId); + } Tcl_MutexUnlock(&serialMutex); } return 0; } @@ -1397,13 +1418,13 @@ * TclWinSerialReopen -- * * Reopens the serial port with the OVERLAPPED FLAG set * * Results: - * Returns the new handle, or INVALID_HANDLE_VALUE. Normally - * there shouldn't be any error, because the same channel has - * previously been succeesfully opened. + * Returns the new handle, or INVALID_HANDLE_VALUE. Normally there + * shouldn't be any error, because the same channel has previously been + * succeesfully opened. * * Side effects: * May close the original handle * *---------------------------------------------------------------------- @@ -1417,14 +1438,14 @@ { ThreadSpecificData *tsdPtr; tsdPtr = SerialInit(); - /* - * Multithreaded I/O needs the overlapped flag set - * otherwise ClearCommError blocks under Windows NT/2000 until serial - * output is finished + /* + * Multithreaded I/O needs the overlapped flag set otherwise + * ClearCommError blocks under Windows NT/2000 until serial output is + * finished */ if (CloseHandle(handle) == FALSE) { return INVALID_HANDLE_VALUE; } @@ -1436,13 +1457,13 @@ /* *---------------------------------------------------------------------- * * TclWinOpenSerialChannel -- * - * Constructs a Serial port channel for the specified standard OS - * handle. This is a helper function to break up the - * construction of channels into File, Console, or Serial. + * Constructs a Serial port channel for the specified standard OS handle. + * This is a helper function to break up the construction of channels + * into File, Console, or Serial. * * Results: * Returns the new channel, or NULL. * * Side effects: @@ -1456,57 +1477,57 @@ HANDLE handle; char *channelName; int permissions; { SerialInfo *infoPtr; - ThreadSpecificData *tsdPtr; DWORD id; - tsdPtr = SerialInit(); + SerialInit(); infoPtr = (SerialInfo *) ckalloc((unsigned) sizeof(SerialInfo)); memset(infoPtr, 0, sizeof(SerialInfo)); infoPtr->validMask = permissions; infoPtr->handle = handle; + infoPtr->channel = (Tcl_Channel) NULL; + infoPtr->readable = 0; + infoPtr->writable = 1; + infoPtr->toWrite = infoPtr->writeQueue = 0; + infoPtr->blockTime = SERIAL_DEFAULT_BLOCKTIME; + infoPtr->lastEventTime = 0; + infoPtr->lastError = infoPtr->error = 0; + infoPtr->threadId = Tcl_GetCurrentThread(); + infoPtr->sysBufRead = 4096; + infoPtr->sysBufWrite = 4096; /* - * Use the pointer to keep the channel names unique, in case - * the handles are shared between multiple channels (stdin/stdout). + * Use the pointer to keep the channel names unique, in case the handles + * are shared between multiple channels (stdin/stdout). */ wsprintfA(channelName, "file%lx", (int) infoPtr); infoPtr->channel = Tcl_CreateChannel(&serialChannelType, channelName, (ClientData) infoPtr, permissions); - infoPtr->readable = 0; - infoPtr->writable = 1; - infoPtr->toWrite = infoPtr->writeQueue = 0; - infoPtr->blockTime = SERIAL_DEFAULT_BLOCKTIME; - infoPtr->lastEventTime = 0; - infoPtr->lastError = infoPtr->error = 0; - infoPtr->threadId = Tcl_GetCurrentThread(); - infoPtr->sysBufRead = infoPtr->sysBufWrite = 4096; SetupComm(handle, infoPtr->sysBufRead, infoPtr->sysBufWrite); PurgeComm(handle, PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR | PURGE_RXCLEAR); /* - * default is blocking + * Default is blocking. */ SetCommTimeouts(handle, &no_timeout); if (permissions & TCL_READABLE) { infoPtr->osRead.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL); } if (permissions & TCL_WRITABLE) { - /* - * Initially the channel is writable - * and the writeThread is idle. + /* + * Initially the channel is writable and the writeThread is idle. */ infoPtr->osWrite.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL); infoPtr->evWritable = CreateEvent(NULL, TRUE, TRUE, NULL); infoPtr->evStartWriter = CreateEvent(NULL, FALSE, FALSE, NULL); @@ -1515,12 +1536,12 @@ infoPtr->writeThread = CreateThread(NULL, 256, SerialWriterThread, infoPtr, 0, &id); } /* - * Files have default translation of AUTO and ^Z eof char, which - * means that a ^Z will be accepted as EOF when reading. + * Files have default translation of AUTO and ^Z eof char, which means + * that a ^Z will be accepted as EOF when reading. */ Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto"); Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}"); @@ -1530,11 +1551,11 @@ /* *---------------------------------------------------------------------- * * SerialErrorStr -- * - * Converts a Win32 serial error code to a list of readable errors + * Converts a Win32 serial error code to a list of readable errors. * * Results: * None. * * Side effects: @@ -1543,12 +1564,12 @@ *---------------------------------------------------------------------- */ static void SerialErrorStr(error, dsPtr) - DWORD error; /* Win32 serial error code */ - Tcl_DString *dsPtr; /* Where to store string */ + DWORD error; /* Win32 serial error code. */ + Tcl_DString *dsPtr; /* Where to store string. */ { if (error & CE_RXOVER) { Tcl_DStringAppendElement(dsPtr, "RXOVER"); } if (error & CE_OVERRUN) { @@ -1564,11 +1585,11 @@ Tcl_DStringAppendElement(dsPtr, "BREAK"); } if (error & CE_TXFULL) { Tcl_DStringAppendElement(dsPtr, "TXFULL"); } - if (error & CE_PTO) { /* PTO used to signal WRITE-TIMEOUT */ + if (error & CE_PTO) { /* PTO used to signal WRITE-TIMEOUT */ Tcl_DStringAppendElement(dsPtr, "TIMEOUT"); } if (error & ~((DWORD) (SERIAL_READ_ERRORS | SERIAL_WRITE_ERRORS))) { char buf[TCL_INTEGER_SPACE + 1]; @@ -1593,12 +1614,12 @@ *---------------------------------------------------------------------- */ static void SerialModemStatusStr(status, dsPtr) - DWORD status; /* Win32 modem status */ - Tcl_DString *dsPtr; /* Where to store string */ + DWORD status; /* Win32 modem status. */ + Tcl_DString *dsPtr; /* Where to store string. */ { Tcl_DStringAppendElement(dsPtr, "CTS"); Tcl_DStringAppendElement(dsPtr, (status & MS_CTS_ON) ? "1" : "0"); Tcl_DStringAppendElement(dsPtr, "DSR"); Tcl_DStringAppendElement(dsPtr, (status & MS_DSR_ON) ? "1" : "0"); @@ -1614,12 +1635,12 @@ * SerialSetOptionProc -- * * Sets an option on a channel. * * Results: - * A standard Tcl result. Also sets the interp's result on error - * if interp is not NULL. + * A standard Tcl result. Also sets the interp's result on error if + * interp is not NULL. * * Side effects: * May modify an option on a device. * *---------------------------------------------------------------------- @@ -1641,19 +1662,19 @@ int argc; CONST char **argv; infoPtr = (SerialInfo *) instanceData; - /* - * Parse options. This would be far easier if we had Tcl_Objs to - * work with as that would let us use Tcl_GetIndexFromObj()... + /* + * Parse options. This would be far easier if we had Tcl_Objs to work with + * as that would let us use Tcl_GetIndexFromObj()... */ len = strlen(optionName); vlen = strlen(value); - /* + /* * Option -mode baud,parity,databits,stopbits */ if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) { if (!GetCommState(infoPtr->handle, &dcb)) { @@ -1673,11 +1694,14 @@ (char *) NULL); } return TCL_ERROR; } - /* Default settings for serial communications */ + /* + * Default settings for serial communications. + */ + dcb.fBinary = TRUE; dcb.fErrorChar = FALSE; dcb.fNull = FALSE; dcb.fAbortOnError = FALSE; @@ -1688,11 +1712,11 @@ return TCL_ERROR; } return TCL_OK; } - /* + /* * Option -handshake none|xonxoff|rtscts|dtrdsr */ if ((len > 1) && (strncmp(optionName, "-handshake", len) == 0)) { if (!GetCommState(infoPtr->handle, &dcb)) { @@ -1701,30 +1725,31 @@ } return TCL_ERROR; } /* - * Reset all handshake options - * DTR and RTS are ON by default + * Reset all handshake options. DTR and RTS are ON by default. */ dcb.fOutX = dcb.fInX = FALSE; dcb.fOutxCtsFlow = dcb.fOutxDsrFlow = dcb.fDsrSensitivity = FALSE; dcb.fDtrControl = DTR_CONTROL_ENABLE; dcb.fRtsControl = RTS_CONTROL_ENABLE; dcb.fTXContinueOnXoff = FALSE; /* - * Adjust the handshake limits. - * Yes, the XonXoff limits seem to influence even hardware handshake + * Adjust the handshake limits. Yes, the XonXoff limits seem to + * influence even hardware handshake. */ dcb.XonLim = (WORD) (infoPtr->sysBufRead*1/2); dcb.XoffLim = (WORD) (infoPtr->sysBufRead*1/4); if (strnicmp(value, "NONE", vlen) == 0) { - /* leave all handshake options disabled */ + /* + * Leave all handshake options disabled. + */ } else if (strnicmp(value, "XONXOFF", vlen) == 0) { dcb.fOutX = dcb.fInX = TRUE; } else if (strnicmp(value, "RTSCTS", vlen) == 0) { dcb.fOutxCtsFlow = TRUE; dcb.fRtsControl = RTS_CONTROL_HANDSHAKE; @@ -1747,11 +1772,11 @@ return TCL_ERROR; } return TCL_OK; } - /* + /* * Option -xchar {\x11 \x13} */ if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) { if (!GetCommState(infoPtr->handle, &dcb)) { @@ -1765,16 +1790,17 @@ return TCL_ERROR; } if (argc == 2) { dcb.XonChar = argv[0][0]; dcb.XoffChar = argv[1][0]; + ckfree((char *) argv); } else { if (interp) { - Tcl_AppendResult(interp, - "bad value for -xchar: should be a list of two elements", - (char *) NULL); + Tcl_AppendResult(interp, "bad value for -xchar: ", + "should be a list of two elements", (char *) NULL); } + ckfree((char *) argv); return TCL_ERROR; } if (!SetCommState(infoPtr->handle, &dcb)) { if (interp) { @@ -1783,80 +1809,88 @@ return TCL_ERROR; } return TCL_OK; } - /* + /* * Option -ttycontrol {DTR 1 RTS 0 BREAK 0} */ if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) { + int i, result = TCL_OK; + if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; } if ((argc % 2) == 1) { if (interp) { Tcl_AppendResult(interp, "bad value for -ttycontrol: ", "should be a list of signal,value pairs", (char *) NULL); } - return TCL_ERROR; - } - while (argc > 1) { - if (Tcl_GetBoolean(interp, argv[1], &flag) == TCL_ERROR) { - return TCL_ERROR; - } - if (strnicmp(argv[0], "DTR", strlen(argv[0])) == 0) { - if (!EscapeCommFunction(infoPtr->handle, flag ? - (DWORD) SETDTR : (DWORD) CLRDTR)) { - if (interp) { - Tcl_AppendResult(interp, "can't set DTR signal", - (char *) NULL); - } - return TCL_ERROR; - } - } else if (strnicmp(argv[0], "RTS", strlen(argv[0])) == 0) { - if (!EscapeCommFunction(infoPtr->handle, flag ? - (DWORD) SETRTS : (DWORD) CLRRTS)) { - if (interp) { - Tcl_AppendResult(interp, "can't set RTS signal", - (char *) NULL); - } - return TCL_ERROR; - } - } else if (strnicmp(argv[0], "BREAK", strlen(argv[0])) == 0) { - if (!EscapeCommFunction(infoPtr->handle, flag ? - (DWORD) SETBREAK : (DWORD) CLRBREAK)) { - if (interp) { - Tcl_AppendResult(interp, "can't set BREAK signal", - (char *) NULL); - } - return TCL_ERROR; + ckfree((char *) argv); + return TCL_ERROR; + } + for (i = 0; i < argc - 1; i += 2) { + if (Tcl_GetBoolean(interp, argv[i+1], &flag) == TCL_ERROR) { + result = TCL_ERROR; + break; + } + if (strnicmp(argv[i], "DTR", strlen(argv[i])) == 0) { + if (!EscapeCommFunction(infoPtr->handle, flag ? + (DWORD) SETDTR : (DWORD) CLRDTR)) { + if (interp) { + Tcl_AppendResult(interp, + "can't set DTR signal", (char *) NULL); + } + result = TCL_ERROR; + break; + } + } else if (strnicmp(argv[i], "RTS", strlen(argv[i])) == 0) { + if (!EscapeCommFunction(infoPtr->handle, flag ? + (DWORD) SETRTS : (DWORD) CLRRTS)) { + if (interp) { + Tcl_AppendResult(interp, + "can't set RTS signal", (char *) NULL); + } + result = TCL_ERROR; + break; + } + } else if (strnicmp(argv[i], "BREAK", strlen(argv[i])) == 0) { + if (!EscapeCommFunction(infoPtr->handle, flag ? + (DWORD) SETBREAK : (DWORD) CLRBREAK)) { + if (interp) { + Tcl_AppendResult(interp, + "can't set BREAK signal", (char *) NULL); + } + result = TCL_ERROR; + break; } } else { if (interp) { Tcl_AppendResult(interp, "bad signal for -ttycontrol: ", "must be DTR, RTS or BREAK", (char *) NULL); } - return TCL_ERROR; - } - argc -= 2; - argv += 2; - } /* while (argc > 1) */ - - return TCL_OK; - } - - /* + result = TCL_ERROR; + break; + } + } + + ckfree((char *) argv); + return result; + } + + /* * Option -sysbuffer {read_size write_size} - * Option -sysbuffer read_size + * Option -sysbuffer read_size */ if ((len > 1) && (strncmp(optionName, "-sysbuffer", len) == 0)) { /* * -sysbuffer 4096 or -sysbuffer {64536 4096} */ + size_t inSize = (size_t) -1, outSize = (size_t) -1; if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; } @@ -1865,10 +1899,11 @@ outSize = infoPtr->sysBufWrite; } else if (argc == 2) { inSize = atoi(argv[0]); outSize = atoi(argv[1]); } + ckfree((char *) argv); if ((inSize <= 0) || (outSize <= 0)) { if (interp) { Tcl_AppendResult(interp, "bad value for -sysbuffer: ", "should be a list of one or two integers > 0", (char *) NULL); @@ -1883,13 +1918,13 @@ return TCL_ERROR; } infoPtr->sysBufRead = inSize; infoPtr->sysBufWrite = outSize; - /* - * Adjust the handshake limits. Yes, the XonXoff limits seem - * to influence even hardware handshake + /* + * Adjust the handshake limits. Yes, the XonXoff limits seem to + * influence even hardware handshake. */ if (!GetCommState(infoPtr->handle, &dcb)) { if (interp) { Tcl_AppendResult(interp, "can't get comm state", @@ -1907,11 +1942,11 @@ return TCL_ERROR; } return TCL_OK; } - /* + /* * Option -pollinterval msec */ if ((len > 1) && (strncmp(optionName, "-pollinterval", len) == 0)) { if (Tcl_GetInt(interp, value, &(infoPtr->blockTime)) != TCL_OK ) { @@ -1942,30 +1977,30 @@ return TCL_OK; } return Tcl_BadChannelOption(interp, optionName, - "mode handshake pollinterval sysbuffer timeout ttycontrol xchar"); + "mode handshake pollinterval sysbuffer timeout ttycontrol xchar"); } /* *---------------------------------------------------------------------- * * SerialGetOptionProc -- * - * Gets a mode associated with an IO channel. If the optionName - * arg is non NULL, retrieves the value of that option. If the - * optionName arg is NULL, retrieves a list of alternating option - * names and values for the given channel. + * Gets a mode associated with an IO channel. If the optionName arg is + * non NULL, retrieves the value of that option. If the optionName arg is + * NULL, retrieves a list of alternating option names and values for the + * given channel. * * Results: - * A standard Tcl result. Also sets the supplied DString to the - * string value of the option(s) returned. + * A standard Tcl result. Also sets the supplied DString to the string + * value of the option(s) returned. * * Side effects: - * The string returned by this function is in static storage and - * may be reused at any time subsequent to the call. + * The string returned by this function is in static storage and may be + * reused at any time subsequent to the call. * *---------------------------------------------------------------------- */ static int @@ -1976,11 +2011,11 @@ Tcl_DString *dsPtr; /* Where to store value(s). */ { SerialInfo *infoPtr; DCB dcb; size_t len; - int valid = 0; /* flag if valid option parsed */ + int valid = 0; /* Flag if valid option parsed. */ infoPtr = (SerialInfo *) instanceData; if (optionName == NULL) { len = 0; @@ -1987,11 +2022,11 @@ } else { len = strlen(optionName); } /* - * get option -mode + * Get option -mode */ if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-mode"); } @@ -2019,11 +2054,11 @@ dcb.ByteSize, stop); Tcl_DStringAppendElement(dsPtr, buf); } /* - * get option -pollinterval + * Get option -pollinterval */ if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-pollinterval"); } @@ -2034,11 +2069,11 @@ wsprintfA(buf, "%d", infoPtr->blockTime); Tcl_DStringAppendElement(dsPtr, buf); } /* - * get option -sysbuffer + * Get option -sysbuffer */ if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-sysbuffer"); Tcl_DStringStartSublist(dsPtr); @@ -2055,11 +2090,11 @@ if (len == 0) { Tcl_DStringEndSublist(dsPtr); } /* - * get option -xchar + * Get option -xchar */ if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-xchar"); Tcl_DStringStartSublist(dsPtr); @@ -2082,23 +2117,25 @@ if (len == 0) { Tcl_DStringEndSublist(dsPtr); } /* - * get option -lasterror - * option is readonly and returned by [fconfigure chan -lasterror] - * but not returned by unnamed [fconfigure chan] + * Get option -lasterror + * + * Option is readonly and returned by [fconfigure chan -lasterror] but not + * returned by unnamed [fconfigure chan]. */ if (len>1 && strncmp(optionName, "-lasterror", len)==0) { valid = 1; SerialErrorStr(infoPtr->lastError, dsPtr); } /* * get option -queue - * option is readonly and returned by [fconfigure chan -queue] + * + * Option is readonly and returned by [fconfigure chan -queue]. */ if (len>1 && strncmp(optionName, "-queue", len)==0) { char buf[TCL_INTEGER_SPACE + 1]; COMSTAT cStat; @@ -2106,11 +2143,11 @@ int inBuffered, outBuffered, count; valid = 1; /* - * Query the pending data in Tcl's internal queues + * Query the pending data in Tcl's internal queues. */ inBuffered = Tcl_InputBuffered(infoPtr->channel); outBuffered = Tcl_OutputBuffered(infoPtr->channel); @@ -2124,20 +2161,21 @@ EnterCriticalSection(&infoPtr->csWrite); ClearCommError( infoPtr->handle, &error, &cStat ); count = (int)cStat.cbOutQue + infoPtr->writeQueue; LeaveCriticalSection(&infoPtr->csWrite); - wsprintfA(buf, "%d", inBuffered + cStat.cbInQue); + wsprintfA(buf, "%d", inBuffered + cStat.cbInQue); Tcl_DStringAppendElement(dsPtr, buf); - wsprintfA(buf, "%d", outBuffered + count); + wsprintfA(buf, "%d", outBuffered + count); Tcl_DStringAppendElement(dsPtr, buf); } /* * get option -ttystatus - * option is readonly and returned by [fconfigure chan -ttystatus] - * but not returned by unnamed [fconfigure chan] + * + * Option is readonly and returned by [fconfigure chan -ttystatus] but not + * returned by unnamed [fconfigure chan]. */ if (len>4 && strncmp(optionName, "-ttystatus", len)==0) { DWORD status; @@ -2156,5 +2194,63 @@ } else { return Tcl_BadChannelOption(interp, optionName, "mode pollinterval lasterror queue sysbuffer ttystatus xchar"); } } + +/* + *---------------------------------------------------------------------- + * + * SerialThreadActionProc -- + * + * Insert or remove any thread local refs to this channel. + * + * Results: + * None. + * + * Side effects: + * Changes thread local list of valid channels. + * + *---------------------------------------------------------------------- + */ + +static void +SerialThreadActionProc(instanceData, action) + ClientData instanceData; + int action; +{ + SerialInfo *infoPtr = (SerialInfo *) instanceData; + + /* + * We do not access firstSerialPtr in the thread structures. This is not + * for all serials managed by the thread, but only those we are watching. + * Removal of the filevent handlers before transfer thus takes care of + * this structure. + */ + + Tcl_MutexLock(&serialMutex); + if (action == TCL_CHANNEL_THREAD_INSERT) { + /* + * We can't copy the thread information from the channel when the + * channel is created. At this time the channel back pointer has not + * been set yet. However in that case the threadId has already been + * set by TclpCreateCommandChannel itself, so the structure is still + * good. + */ + + SerialInit(); + if (infoPtr->channel != NULL) { + infoPtr->threadId = Tcl_GetChannelThread(infoPtr->channel); + } + } else { + infoPtr->threadId = NULL; + } + Tcl_MutexUnlock(&serialMutex); +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: win/tclWinSock.c ================================================================== --- win/tclWinSock.c +++ win/tclWinSock.c @@ -1,24 +1,25 @@ -/* +/* * tclWinSock.c -- * * This file contains Windows-specific socket related code. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinSock.c,v 1.44 2004/10/06 14:39:20 dkf Exp $ + * RCS: @(#) $Id: tclWinSock.c,v 1.44.2.2 2005/08/02 18:17:20 dgp Exp $ */ #include "tclWinInt.h" /* - * Make sure to remove the redirection defines set in tclWinPort.h - * that is in use in other sections of the core, except for us. + * Make sure to remove the redirection defines set in tclWinPort.h that is in + * use in other sections of the core, except for us. */ + #undef getservbyname #undef getsockopt #undef ntohs #undef setsockopt @@ -26,80 +27,82 @@ * The following variable is used to tell whether this module has been * initialized. */ static int initialized = 0; - -static int hostnameInitialized = 0; -static char hostname[255]; /* This buffer should be big enough for - * hostname plus domain name. */ - TCL_DECLARE_MUTEX(socketMutex) +/* + * The following variable holds the network name of this host. + */ + +static TclInitProcessGlobalValueProc InitializeHostName; +static ProcessGlobalValue hostName = + {0, 0, NULL, NULL, InitializeHostName, NULL, NULL}; /* * Mingw, Cygwin and OpenWatcom may not have LPFN_* typedefs. */ #ifdef HAVE_NO_LPFN_DECLS typedef SOCKET (PASCAL FAR *LPFN_ACCEPT)(SOCKET s, - struct sockaddr FAR * addr, int FAR * addrlen); + struct sockaddr FAR * addr, int FAR * addrlen); typedef int (PASCAL FAR *LPFN_BIND)(SOCKET s, - const struct sockaddr FAR *addr, int namelen); + const struct sockaddr FAR *addr, int namelen); typedef int (PASCAL FAR *LPFN_CLOSESOCKET)(SOCKET s); typedef int (PASCAL FAR *LPFN_CONNECT)(SOCKET s, - const struct sockaddr FAR *name, int namelen); + const struct sockaddr FAR *name, int namelen); typedef struct hostent FAR * (PASCAL FAR *LPFN_GETHOSTBYADDR) - (const char FAR *addr, int addrlen, int addrtype); + (const char FAR *addr, int addrlen, int addrtype); typedef struct hostent FAR * (PASCAL FAR *LPFN_GETHOSTBYNAME) - (const char FAR * name); + (const char FAR * name); typedef int (PASCAL FAR *LPFN_GETHOSTNAME)(char FAR * name, - int namelen); + int namelen); typedef int (PASCAL FAR *LPFN_GETPEERNAME)(SOCKET sock, - struct sockaddr FAR *name, int FAR *namelen); + struct sockaddr FAR *name, int FAR *namelen); typedef struct servent FAR * (PASCAL FAR *LPFN_GETSERVBYNAME) - (const char FAR * name, const char FAR * proto); + (const char FAR * name, const char FAR * proto); typedef int (PASCAL FAR *LPFN_GETSOCKNAME)(SOCKET sock, - struct sockaddr FAR *name, int FAR *namelen); + struct sockaddr FAR *name, int FAR *namelen); typedef int (PASCAL FAR *LPFN_GETSOCKOPT)(SOCKET s, int level, - int optname, char FAR * optval, int FAR *optlen); + int optname, char FAR * optval, int FAR *optlen); typedef u_short (PASCAL FAR *LPFN_HTONS)(u_short hostshort); typedef unsigned long (PASCAL FAR *LPFN_INET_ADDR) - (const char FAR * cp); + (const char FAR * cp); typedef char FAR * (PASCAL FAR *LPFN_INET_NTOA) - (struct in_addr in); + (struct in_addr in); typedef int (PASCAL FAR *LPFN_IOCTLSOCKET)(SOCKET s, - long cmd, u_long FAR *argp); + long cmd, u_long FAR *argp); typedef int (PASCAL FAR *LPFN_LISTEN)(SOCKET s, int backlog); typedef u_short (PASCAL FAR *LPFN_NTOHS)(u_short netshort); typedef int (PASCAL FAR *LPFN_RECV)(SOCKET s, char FAR * buf, - int len, int flags); + int len, int flags); typedef int (PASCAL FAR *LPFN_SELECT)(int nfds, - fd_set FAR * readfds, fd_set FAR * writefds, - fd_set FAR * exceptfds, - const struct timeval FAR * timeout); + fd_set FAR * readfds, fd_set FAR * writefds, + fd_set FAR * exceptfds, + const struct timeval FAR * timeout); typedef int (PASCAL FAR *LPFN_SEND)(SOCKET s, - const char FAR * buf, int len, int flags); + const char FAR * buf, int len, int flags); typedef int (PASCAL FAR *LPFN_SETSOCKOPT)(SOCKET s, - int level, int optname, const char FAR * optval, - int optlen); + int level, int optname, const char FAR * optval, + int optlen); typedef SOCKET (PASCAL FAR *LPFN_SOCKET)(int af, - int type, int protocol); + int type, int protocol); typedef int (PASCAL FAR *LPFN_WSAASYNCSELECT)(SOCKET s, - HWND hWnd, u_int wMsg, long lEvent); + HWND hWnd, u_int wMsg, long lEvent); typedef int (PASCAL FAR *LPFN_WSACLEANUP)(void); typedef int (PASCAL FAR *LPFN_WSAGETLASTERROR)(void); typedef int (PASCAL FAR *LPFN_WSASTARTUP)(WORD wVersionRequired, - LPWSADATA lpWSAData); + LPWSADATA lpWSAData); #endif /* - * The following structure contains pointers to all of the WinSock API - * entry points used by Tcl. It is initialized by InitSockets. Since - * we dynamically load the Winsock DLL on demand, we must use this - * function table to refer to functions in the winsock API. + * The following structure contains pointers to all of the WinSock API entry + * points used by Tcl. It is initialized by InitSockets. Since we dynamically + * load the Winsock DLL on demand, we must use this function table to refer to + * functions in the winsock API. */ static struct { HMODULE hModule; /* Handle to WinSock library. */ @@ -128,11 +131,10 @@ LPFN_SOCKET socket; LPFN_WSAASYNCSELECT WSAAsyncSelect; LPFN_WSACLEANUP WSACleanup; LPFN_WSAGETLASTERROR WSAGetLastError; LPFN_WSASTARTUP WSAStartup; - } winSock; /* * The following defines declare the messages used on socket windows. */ @@ -142,139 +144,131 @@ #define SOCKET_TERMINATE WM_USER+3 #define SELECT TRUE #define UNSELECT FALSE /* - * The following structure is used to store the data associated with - * each socket. + * The following structure is used to store the data associated with each + * socket. */ typedef struct SocketInfo { - Tcl_Channel channel; /* Channel associated with this - * socket. */ - SOCKET socket; /* Windows SOCKET handle. */ - int flags; /* Bit field comprised of the flags - * described below. */ - int watchEvents; /* OR'ed combination of FD_READ, - * FD_WRITE, FD_CLOSE, FD_ACCEPT and - * FD_CONNECT that indicate which - * events are interesting. */ - int readyEvents; /* OR'ed combination of FD_READ, - * FD_WRITE, FD_CLOSE, FD_ACCEPT and - * FD_CONNECT that indicate which - * events have occurred. */ - int selectEvents; /* OR'ed combination of FD_READ, - * FD_WRITE, FD_CLOSE, FD_ACCEPT and - * FD_CONNECT that indicate which - * events are currently being - * selected. */ - int acceptEventCount; /* Count of the current number of - * FD_ACCEPTs that have arrived and - * not yet processed. */ - Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ - ClientData acceptProcData; /* The data for the accept proc. */ - int lastError; /* Error code from last message. */ - struct SocketInfo *nextPtr; /* The next socket on the per-thread - * socket list. */ + Tcl_Channel channel; /* Channel associated with this socket. */ + SOCKET socket; /* Windows SOCKET handle. */ + int flags; /* Bit field comprised of the flags described + * below. */ + int watchEvents; /* OR'ed combination of FD_READ, FD_WRITE, + * FD_CLOSE, FD_ACCEPT and FD_CONNECT that + * indicate which events are interesting. */ + int readyEvents; /* OR'ed combination of FD_READ, FD_WRITE, + * FD_CLOSE, FD_ACCEPT and FD_CONNECT that + * indicate which events have occurred. */ + int selectEvents; /* OR'ed combination of FD_READ, FD_WRITE, + * FD_CLOSE, FD_ACCEPT and FD_CONNECT that + * indicate which events are currently being + * selected. */ + int acceptEventCount; /* Count of the current number of FD_ACCEPTs + * that have arrived and not yet processed. */ + Tcl_TcpAcceptProc *acceptProc; + /* Proc to call on accept. */ + ClientData acceptProcData; /* The data for the accept proc. */ + int lastError; /* Error code from last message. */ + struct SocketInfo *nextPtr; /* The next socket on the per-thread socket + * list. */ } SocketInfo; /* - * The following structure is what is added to the Tcl event queue when - * a socket event occurs. + * The following structure is what is added to the Tcl event queue when a + * socket event occurs. */ typedef struct SocketEvent { - Tcl_Event header; /* Information that is standard for - * all events. */ - SOCKET socket; /* Socket descriptor that is ready. Used - * to find the SocketInfo structure for - * the file (can't point directly to the - * SocketInfo structure because it could - * go away while the event is queued). */ + Tcl_Event header; /* Information that is standard for all + * events. */ + SOCKET socket; /* Socket descriptor that is ready. Used to + * find the SocketInfo structure for the file + * (can't point directly to the SocketInfo + * structure because it could go away while + * the event is queued). */ } SocketEvent; /* * This defines the minimum buffersize maintained by the kernel. */ #define TCP_BUFFER_SIZE 4096 /* - * The following macros may be used to set the flags field of - * a SocketInfo structure. + * The following macros may be used to set the flags field of a SocketInfo + * structure. */ -#define SOCKET_ASYNC (1<<0) /* The socket is in blocking - * mode. */ -#define SOCKET_EOF (1<<1) /* A zero read happened on - * the socket. */ -#define SOCKET_ASYNC_CONNECT (1<<2) /* This socket uses async - * connect. */ -#define SOCKET_PENDING (1<<3) /* A message has been sent - * for this socket */ +#define SOCKET_ASYNC (1<<0) /* The socket is in blocking mode. */ +#define SOCKET_EOF (1<<1) /* A zero read happened on the + * socket. */ +#define SOCKET_ASYNC_CONNECT (1<<2) /* This socket uses async connect. */ +#define SOCKET_PENDING (1<<3) /* A message has been sent for this + * socket */ typedef struct ThreadSpecificData { - HWND hwnd; /* Handle to window for socket messages. */ - HANDLE socketThread; /* Thread handling the window */ - Tcl_ThreadId threadId; /* Parent thread. */ - HANDLE readyEvent; /* Event indicating that a socket event is - * ready. Also used to indicate that the - * socketThread has been initialized and has - * started. */ - HANDLE socketListLock; /* Win32 Event to lock the socketList */ - SocketInfo *socketList; /* Every open socket in this thread has an - * entry on this list. */ + HWND hwnd; /* Handle to window for socket messages. */ + HANDLE socketThread; /* Thread handling the window */ + Tcl_ThreadId threadId; /* Parent thread. */ + HANDLE readyEvent; /* Event indicating that a socket event is + * ready. Also used to indicate that the + * socketThread has been initialized and has + * started. */ + HANDLE socketListLock; /* Win32 Event to lock the socketList */ + SocketInfo *socketList; /* Every open socket in this thread has an + * entry on this list. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; static WNDCLASS windowClass; /* * Static functions defined in this file. */ -static SocketInfo * CreateSocket _ANSI_ARGS_((Tcl_Interp *interp, - int port, CONST char *host, - int server, CONST char *myaddr, - int myport, int async)); -static int CreateSocketAddress _ANSI_ARGS_( - (LPSOCKADDR_IN sockaddrPtr, - CONST char *host, int port)); -static void InitSockets _ANSI_ARGS_((void)); -static SocketInfo * NewSocketInfo _ANSI_ARGS_((SOCKET socket)); -static Tcl_EventCheckProc SocketCheckProc; -static Tcl_EventProc SocketEventProc; -static void SocketExitHandler _ANSI_ARGS_(( - ClientData clientData)); -static LRESULT CALLBACK SocketProc _ANSI_ARGS_((HWND hwnd, - UINT message, WPARAM wParam, - LPARAM lParam)); -static Tcl_EventSetupProc SocketSetupProc; -static Tcl_ExitProc SocketThreadExitHandler; -static int SocketsEnabled _ANSI_ARGS_((void)); -static void TcpAccept _ANSI_ARGS_((SocketInfo *infoPtr)); +static SocketInfo * CreateSocket(Tcl_Interp *interp, int port, + CONST char *host, int server, CONST char *myaddr, + int myport, int async); +static int CreateSocketAddress(LPSOCKADDR_IN sockaddrPtr, + CONST char *host, int port); +static void InitSockets(void); +static SocketInfo * NewSocketInfo(SOCKET socket); +static void SocketExitHandler(ClientData clientData); +static LRESULT CALLBACK SocketProc(HWND hwnd, UINT message, WPARAM wParam, + LPARAM lParam); +static int SocketsEnabled(void); +static void TcpAccept(SocketInfo *infoPtr); +static int WaitForSocketEvent(SocketInfo *infoPtr, int events, + int *errorCodePtr); +static DWORD WINAPI SocketThread(LPVOID arg); +static void TcpThreadActionProc(ClientData instanceData, + int action); + +static Tcl_EventCheckProc SocketCheckProc; +static Tcl_EventProc SocketEventProc; +static Tcl_EventSetupProc SocketSetupProc; +static Tcl_ExitProc SocketThreadExitHandler; static Tcl_DriverBlockModeProc TcpBlockProc; static Tcl_DriverCloseProc TcpCloseProc; static Tcl_DriverSetOptionProc TcpSetOptionProc; static Tcl_DriverGetOptionProc TcpGetOptionProc; static Tcl_DriverInputProc TcpInputProc; static Tcl_DriverOutputProc TcpOutputProc; static Tcl_DriverWatchProc TcpWatchProc; static Tcl_DriverGetHandleProc TcpGetHandleProc; -static int WaitForSocketEvent _ANSI_ARGS_(( - SocketInfo *infoPtr, int events, - int *errorCodePtr)); -static DWORD WINAPI SocketThread _ANSI_ARGS_((LPVOID arg)); /* * This structure describes the channel type structure for TCP socket * based IO. */ static Tcl_ChannelType tcpChannelType = { "tcp", /* Type name. */ - TCL_CHANNEL_VERSION_2, /* v2 channel */ + TCL_CHANNEL_VERSION_4, /* v4 channel */ TcpCloseProc, /* Close proc. */ TcpInputProc, /* Input proc. */ TcpOutputProc, /* Output proc. */ NULL, /* Seek proc. */ TcpSetOptionProc, /* Set option proc. */ @@ -283,31 +277,32 @@ TcpGetHandleProc, /* Get an OS handle from channel. */ NULL, /* close2proc. */ TcpBlockProc, /* Set socket into (non-)blocking mode. */ NULL, /* flush proc. */ NULL, /* handler proc. */ + NULL, /* wide seek proc */ + TcpThreadActionProc, /* thread action proc */ }; /* *---------------------------------------------------------------------- * * InitSockets -- * - * Initialize the socket module. Attempts to load the wsock32.dll - * library and set up the winSock function table. If successful, - * registers the event window for the socket notifier code. + * Initialize the socket module. Attempts to load the wsock32.dll library + * and set up the winSock function table. If successful, registers the + * event window for the socket notifier code. * * Assumes Mutex is held. * * Results: * None. * * Side effects: - * Dynamically loads wsock32.dll, and registers a new window - * class and creates a window for use in asynchronous socket - * notification. + * Dynamically loads wsock32.dll, and registers a new window class and + * creates a window for use in asynchronous socket notification. * *---------------------------------------------------------------------- */ static void @@ -314,12 +309,12 @@ InitSockets() { DWORD id; WSADATA wsaData; DWORD err; - ThreadSpecificData *tsdPtr = - (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) + TclThreadDataKeyGet(&dataKey); if (!initialized) { initialized = 1; Tcl_CreateExitHandler(SocketExitHandler, (ClientData) NULL); @@ -326,11 +321,11 @@ winSock.hModule = LoadLibraryA("wsock32.dll"); if (winSock.hModule == NULL) { return; } - + /* * Initialize the function table. */ winSock.accept = (LPFN_ACCEPT) @@ -383,17 +378,16 @@ GetProcAddress(winSock.hModule, "WSACleanup"); winSock.WSAGetLastError = (LPFN_WSAGETLASTERROR) GetProcAddress(winSock.hModule, "WSAGetLastError"); winSock.WSAStartup = (LPFN_WSASTARTUP) GetProcAddress(winSock.hModule, "WSAStartup"); - + /* - * Now check that all fields are properly initialized. If not, - * return zero to indicate that we failed to initialize - * properly. + * Now check that all fields are properly initialized. If not, return + * zero to indicate that we failed to initialize properly. */ - + if ((winSock.accept == NULL) || (winSock.bind == NULL) || (winSock.closesocket == NULL) || (winSock.connect == NULL) || (winSock.gethostbyname == NULL) || @@ -415,22 +409,21 @@ (winSock.setsockopt == NULL) || (winSock.socket == NULL) || (winSock.WSAAsyncSelect == NULL) || (winSock.WSACleanup == NULL) || (winSock.WSAGetLastError == NULL) || - (winSock.WSAStartup == NULL)) - { + (winSock.WSAStartup == NULL)) { goto unloadLibrary; } - + /* - * Create the async notification window with a new class. We - * must create a new class to avoid a Windows 95 bug that causes - * us to get the wrong message number for socket events if the - * message window is a subclass of a static control. + * Create the async notification window with a new class. We must + * create a new class to avoid a Windows 95 bug that causes us to get + * the wrong message number for socket events if the message window is + * a subclass of a static control. */ - + windowClass.style = 0; windowClass.cbClsExtra = 0; windowClass.cbWndExtra = 0; windowClass.hInstance = TclWinGetTclInstance(); windowClass.hbrBackground = NULL; @@ -444,28 +437,28 @@ TclWinConvertError(GetLastError()); goto unloadLibrary; } /* - * Initialize the winsock library and check the interface - * version actually loaded. We only ask for the 1.1 interface - * and do require that it not be less than 1.1. + * Initialize the winsock library and check the interface version + * actually loaded. We only ask for the 1.1 interface and do require + * that it not be less than 1.1. */ -#define WSA_VERSION_MAJOR 1 -#define WSA_VERSION_MINOR 1 -#define WSA_VERSION_REQD MAKEWORD(WSA_VERSION_MAJOR, WSA_VERSION_MINOR) +#define WSA_VERSION_MAJOR 1 +#define WSA_VERSION_MINOR 1 +#define WSA_VERSION_REQD MAKEWORD(WSA_VERSION_MAJOR, WSA_VERSION_MINOR) if ((err = winSock.WSAStartup(WSA_VERSION_REQD, &wsaData)) != 0) { TclWinConvertWSAError(err); goto unloadLibrary; } /* - * Note the byte positions are swapped for the comparison, so - * that 0x0002 (2.0, MAKEWORD(2,0)) doesn't look less than 0x0101 - * (1.1). We want the comparison to be 0x0200 < 0x0101. + * Note the byte positions are swapped for the comparison, so that + * 0x0002 (2.0, MAKEWORD(2,0)) doesn't look less than 0x0101 (1.1). + * We want the comparison to be 0x0200 < 0x0101. */ if (MAKEWORD(HIBYTE(wsaData.wVersion), LOBYTE(wsaData.wVersion)) < MAKEWORD(WSA_VERSION_MINOR, WSA_VERSION_MAJOR)) { TclWinConvertWSAError(WSAVERNOTSUPPORTED); @@ -486,43 +479,41 @@ tsdPtr = TCL_TSD_INIT(&dataKey); tsdPtr->socketList = NULL; tsdPtr->hwnd = NULL; tsdPtr->threadId = Tcl_GetCurrentThread(); - + tsdPtr->readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL); tsdPtr->socketListLock = CreateEvent(NULL, FALSE, TRUE, NULL); tsdPtr->socketThread = CreateThread(NULL, 256, SocketThread, tsdPtr, 0, &id); SetThreadPriority(tsdPtr->socketThread, THREAD_PRIORITY_HIGHEST); if (tsdPtr->socketThread == NULL) { goto unloadLibrary; } - + /* - * Wait for the thread to signal that the window has - * been created and is ready to go. Timeout after twenty - * seconds. + * Wait for the thread to signal that the window has been created and + * is ready to go. Timeout after twenty seconds. */ - - if (WaitForSingleObject(tsdPtr->readyEvent, 20000) - == WAIT_TIMEOUT) { + + if (WaitForSingleObject(tsdPtr->readyEvent, 20000) == WAIT_TIMEOUT) { goto unloadLibrary; } if (tsdPtr->hwnd == NULL) { goto unloadLibrary; } - + Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); Tcl_CreateThreadExitHandler(SocketThreadExitHandler, NULL); } return; -unloadLibrary: + unloadLibrary: if (tsdPtr != NULL && tsdPtr->hwnd != NULL) { SocketThreadExitHandler(0); } FreeLibrary(winSock.hModule); winSock.hModule = NULL; @@ -575,36 +566,36 @@ */ /* ARGSUSED */ static void SocketExitHandler(clientData) - ClientData clientData; /* Not used. */ + ClientData clientData; /* Not used. */ { Tcl_MutexLock(&socketMutex); if (winSock.hModule) { /* - * Make sure the socket event handling window is cleaned-up - * for, at most, this thread. + * Make sure the socket event handling window is cleaned-up for, at + * most, this thread. */ + SocketThreadExitHandler(clientData); UnregisterClass("TclSocket", TclWinGetTclInstance()); winSock.WSACleanup(); FreeLibrary(winSock.hModule); winSock.hModule = NULL; } initialized = 0; - hostnameInitialized = 0; Tcl_MutexUnlock(&socketMutex); } /* *---------------------------------------------------------------------- * * SocketThreadExitHandler -- * - * Callback invoked during thread clean up to delete the socket - * event source. + * Callback invoked during thread clean up to delete the socket event + * source. * * Results: * None. * * Side effects: @@ -614,26 +605,27 @@ */ /* ARGSUSED */ static void SocketThreadExitHandler(clientData) - ClientData clientData; /* Not used. */ + ClientData clientData; /* Not used. */ { - ThreadSpecificData *tsdPtr = + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); if (tsdPtr != NULL && tsdPtr->socketThread != NULL) { DWORD exitCode; GetExitCodeThread(tsdPtr->socketThread, &exitCode); if (exitCode == STILL_ACTIVE) { PostMessage(tsdPtr->hwnd, SOCKET_TERMINATE, 0, 0); + /* - * Wait for the thread to close. This ensures that we are - * completely cleaned up before we leave this function. - * If Tcl_Finalize was called from DllMain, the thread - * is in a paused state so we need to timeout and continue. + * Wait for the thread to close. This ensures that we are + * completely cleaned up before we leave this function. If + * Tcl_Finalize was called from DllMain, the thread is in a paused + * state so we need to timeout and continue. */ WaitForSingleObject(tsdPtr->socketThread, 100); } CloseHandle(tsdPtr->socketThread); @@ -649,22 +641,22 @@ /* *---------------------------------------------------------------------- * * TclpHasSockets -- * - * This function determines whether sockets are available on the - * current system and returns an error in interp if they are not. - * Note that interp may be NULL. + * This function determines whether sockets are available on the current + * system and returns an error in interp if they are not. Note that + * interp may be NULL. * * Results: - * Returns TCL_OK if the system supports sockets, or TCL_ERROR with - * an error in interp. + * Returns TCL_OK if the system supports sockets, or TCL_ERROR with an + * error in interp (if non-NULL). * * Side effects: - * If not already prepared, initializes the TSD structure and - * socket message handling thread associated to the calling thread - * for the subsystem of the driver. + * If not already prepared, initializes the TSD structure and socket + * message handling thread associated to the calling thread for the + * subsystem of the driver. * *---------------------------------------------------------------------- */ int @@ -688,12 +680,12 @@ /* *---------------------------------------------------------------------- * * SocketSetupProc -- * - * This procedure is invoked before Tcl_DoOneEvent blocks waiting - * for an event. + * This function is invoked before Tcl_DoOneEvent blocks waiting for an + * event. * * Results: * None. * * Side effects: @@ -712,17 +704,17 @@ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!(flags & TCL_FILE_EVENTS)) { return; } - + /* - * Check to see if there is a ready socket. If so, poll. + * Check to see if there is a ready socket. If so, poll. */ WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - for (infoPtr = tsdPtr->socketList; infoPtr != NULL; + for (infoPtr = tsdPtr->socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (infoPtr->readyEvents & infoPtr->watchEvents) { Tcl_SetMaxBlockTime(&blockTime); break; } @@ -733,12 +725,12 @@ /* *---------------------------------------------------------------------- * * SocketCheckProc -- * - * This procedure is called by Tcl_DoOneEvent to check the socket - * event source for events. + * This function is called by Tcl_DoOneEvent to check the socket event + * source for events. * * Results: * None. * * Side effects: @@ -757,19 +749,19 @@ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!(flags & TCL_FILE_EVENTS)) { return; } - + /* * Queue events for any ready sockets that don't already have events * queued (caused by persistent states that won't generate WinSock * events). */ WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - for (infoPtr = tsdPtr->socketList; infoPtr != NULL; + for (infoPtr = tsdPtr->socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if ((infoPtr->readyEvents & infoPtr->watchEvents) && !(infoPtr->flags & SOCKET_PENDING)) { infoPtr->flags |= SOCKET_PENDING; evPtr = (SocketEvent *) ckalloc(sizeof(SocketEvent)); @@ -784,31 +776,31 @@ /* *---------------------------------------------------------------------- * * SocketEventProc -- * - * This procedure is called by Tcl_ServiceEvent when a socket event - * reaches the front of the event queue. This procedure is - * responsible for notifying the generic channel code. + * This function is called by Tcl_ServiceEvent when a socket event + * reaches the front of the event queue. This function is responsible for + * notifying the generic channel code. * * Results: - * Returns 1 if the event was handled, meaning it should be removed - * from the queue. Returns 0 if the event was not handled, meaning - * it should stay on the queue. The only time the event isn't - * handled is if the TCL_FILE_EVENTS flag bit isn't set. + * Returns 1 if the event was handled, meaning it should be removed from + * the queue. Returns 0 if the event was not handled, meaning it should + * stay on the queue. The only time the event isn't handled is if the + * TCL_FILE_EVENTS flag bit isn't set. * * Side effects: - * Whatever the channel callback procedures do. + * Whatever the channel callback functions do. * *---------------------------------------------------------------------- */ static int SocketEventProc(evPtr, flags) Tcl_Event *evPtr; /* Event to service. */ - int flags; /* Flags that indicate what events to - * handle, such as TCL_FILE_EVENTS. */ + int flags; /* Flags that indicate what events to handle, + * such as TCL_FILE_EVENTS. */ { SocketInfo *infoPtr; SocketEvent *eventPtr = (SocketEvent *) evPtr; int mask = 0; int events; @@ -821,11 +813,11 @@ /* * Find the specified socket on the socket list. */ WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - for (infoPtr = tsdPtr->socketList; infoPtr != NULL; + for (infoPtr = tsdPtr->socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (infoPtr->socket == eventPtr->socket) { break; } } @@ -849,25 +841,25 @@ TcpAccept(infoPtr); return 1; } /* - * Mask off unwanted events and compute the read/write mask so - * we can notify the channel. + * Mask off unwanted events and compute the read/write mask so we can + * notify the channel. */ events = infoPtr->readyEvents & infoPtr->watchEvents; if (events & FD_CLOSE) { /* - * If the socket was closed and the channel is still interested - * in read events, then we need to ensure that we keep polling - * for this event until someone does something with the channel. - * Note that we do this before calling Tcl_NotifyChannel so we don't - * have to watch out for the channel being deleted out from under - * us. This may cause a redundant trip through the event loop, but - * it's simpler than trying to do unwind protection. + * If the socket was closed and the channel is still interested in + * read events, then we need to ensure that we keep polling for this + * event until someone does something with the channel. Note that we + * do this before calling Tcl_NotifyChannel so we don't have to watch + * out for the channel being deleted out from under us. This may cause + * a redundant trip through the event loop, but it's simpler than + * trying to do unwind protection. */ Tcl_Time blockTime = { 0, 0 }; Tcl_SetMaxBlockTime(&blockTime); mask |= TCL_READABLE|TCL_WRITABLE; @@ -875,24 +867,24 @@ fd_set readFds; struct timeval timeout; /* * We must check to see if data is really available, since someone - * could have consumed the data in the meantime. Turn off async - * notification so select will work correctly. If the socket is - * still readable, notify the channel driver, otherwise reset the - * async select handler and keep waiting. + * could have consumed the data in the meantime. Turn off async + * notification so select will work correctly. If the socket is still + * readable, notify the channel driver, otherwise reset the async + * select handler and keep waiting. */ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, (LPARAM) infoPtr); FD_ZERO(&readFds); FD_SET(infoPtr->socket, &readFds); timeout.tv_usec = 0; timeout.tv_sec = 0; - + if (winSock.select(0, &readFds, NULL, NULL, &timeout) != 0) { mask |= TCL_READABLE; } else { infoPtr->readyEvents &= ~(FD_READ); SendMessage(tsdPtr->hwnd, SOCKET_SELECT, @@ -900,11 +892,14 @@ } } if (events & (FD_WRITE | FD_CONNECT)) { mask |= TCL_WRITABLE; if (events & FD_CONNECT && infoPtr->lastError != NO_ERROR) { - /* connect errors should also fire the readable handler. */ + /* + * Connect errors should also fire the readable handler. + */ + mask |= TCL_READABLE; } } if (mask) { @@ -931,11 +926,11 @@ static int TcpBlockProc(instanceData, mode) ClientData instanceData; /* The socket to block/un-block. */ int mode; /* TCL_MODE_BLOCKING or - * TCL_MODE_NONBLOCKING. */ + * TCL_MODE_NONBLOCKING. */ { SocketInfo *infoPtr = (SocketInfo *) instanceData; if (mode == TCL_MODE_NONBLOCKING) { infoPtr->flags |= SOCKET_ASYNC; @@ -948,13 +943,13 @@ /* *---------------------------------------------------------------------- * * TcpCloseProc -- * - * This procedure is called by the generic IO level to perform - * channel type specific cleanup on a socket based channel - * when the channel is closed. + * This function is called by the generic IO level to perform channel + * type specific cleanup on a socket based channel when the channel is + * closed. * * Results: * 0 if successful, the value of errno if failed. * * Side effects: @@ -968,66 +963,56 @@ TcpCloseProc(instanceData, interp) ClientData instanceData; /* The socket to close. */ Tcl_Interp *interp; /* Unused. */ { SocketInfo *infoPtr = (SocketInfo *) instanceData; - SocketInfo **nextPtrPtr; + /* TIP #218 */ int errorCode = 0; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* - * Check that WinSock is initialized; do not call it if not, to - * prevent system crashes. This can happen at exit time if the exit - * handler for WinSock ran before other exit handlers that want to - * use sockets. + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. */ if (SocketsEnabled()) { - - /* - * Clean up the OS socket handle. The default Windows setting - * for a socket is SO_DONTLINGER, which does a graceful shutdown - * in the background. - */ - - if (winSock.closesocket(infoPtr->socket) == SOCKET_ERROR) { - TclWinConvertWSAError((DWORD) winSock.WSAGetLastError()); - errorCode = Tcl_GetErrno(); - } - } - - /* - * Remove the socket from socketList. - */ - - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - for (nextPtrPtr = &(tsdPtr->socketList); (*nextPtrPtr) != NULL; - nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { - if ((*nextPtrPtr) == infoPtr) { - (*nextPtrPtr) = infoPtr->nextPtr; - break; - } - } - - SetEvent(tsdPtr->socketListLock); + /* + * Clean up the OS socket handle. The default Windows setting for a + * socket is SO_DONTLINGER, which does a graceful shutdown in the + * background. + */ + + if (winSock.closesocket(infoPtr->socket) == SOCKET_ERROR) { + TclWinConvertWSAError((DWORD) winSock.WSAGetLastError()); + errorCode = Tcl_GetErrno(); + } + } + + /* + * TIP #218. Removed the code removing the structure from the global + * socket list. This is now done by the thread action callbacks, and only + * there. This happens before this code is called. We can free without + * fear of damaging the list. + */ + ckfree((char *) infoPtr); return errorCode; } /* *---------------------------------------------------------------------- * * NewSocketInfo -- * - * This function allocates and initializes a new SocketInfo - * structure. + * This function allocates and initializes a new SocketInfo structure. * * Results: * Returns a newly allocated SocketInfo. * * Side effects: - * Adds the socket to the global socket list. + * None, except for allocation of memory. * *---------------------------------------------------------------------- */ static SocketInfo * @@ -1047,116 +1032,118 @@ infoPtr->acceptEventCount = 0; infoPtr->acceptProc = NULL; infoPtr->acceptProcData = NULL; infoPtr->lastError = 0; - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - infoPtr->nextPtr = tsdPtr->socketList; - tsdPtr->socketList = infoPtr; - SetEvent(tsdPtr->socketListLock); - + /* + * TIP #218. Removed the code inserting the new structure into the global + * list. This is now handled in the thread action callbacks, and only + * there. + */ + + infoPtr->nextPtr = NULL; + return infoPtr; } /* *---------------------------------------------------------------------- * * CreateSocket -- * - * This function opens a new socket and initializes the - * SocketInfo structure. + * This function opens a new socket and initializes the SocketInfo + * structure. * * Results: * Returns a new SocketInfo, or NULL with an error in interp. * * Side effects: - * Adds a new socket to the socketList. + * None, except for allocation of memory. * *---------------------------------------------------------------------- */ static SocketInfo * CreateSocket(interp, port, host, server, myaddr, myport, async) Tcl_Interp *interp; /* For error reporting; can be NULL. */ int port; /* Port number to open. */ CONST char *host; /* Name of host on which to open port. */ - int server; /* 1 if socket should be a server socket, - * else 0 for a client socket. */ + int server; /* 1 if socket should be a server socket, else + * 0 for a client socket. */ CONST char *myaddr; /* Optional client-side address */ int myport; /* Optional client-side port */ int async; /* If nonzero, connect client socket * asynchronously. */ { u_long flag = 1; /* Indicates nonblocking mode. */ - int asyncConnect = 0; /* Will be 1 if async connect is - * in progress. */ + int asyncConnect = 0; /* Will be 1 if async connect is in + * progress. */ SOCKADDR_IN sockaddr; /* Socket address */ SOCKADDR_IN mysockaddr; /* Socket address for client */ SOCKET sock; SocketInfo *infoPtr; /* The returned value. */ - ThreadSpecificData *tsdPtr = - (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) + TclThreadDataKeyGet(&dataKey); /* - * Check that WinSock is initialized; do not call it if not, to - * prevent system crashes. This can happen at exit time if the exit - * handler for WinSock ran before other exit handlers that want to - * use sockets. + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. */ if (!SocketsEnabled()) { - return NULL; + return NULL; } - if (! CreateSocketAddress(&sockaddr, host, port)) { + if (!CreateSocketAddress(&sockaddr, host, port)) { goto error; } if ((myaddr != NULL || myport != 0) && - ! CreateSocketAddress(&mysockaddr, myaddr, myport)) { + !CreateSocketAddress(&mysockaddr, myaddr, myport)) { goto error; } sock = winSock.socket(AF_INET, SOCK_STREAM, 0); if (sock == INVALID_SOCKET) { goto error; } /* - * Win-NT has a misfeature that sockets are inherited in child - * processes by default. Turn off the inherit bit. + * Win-NT has a misfeature that sockets are inherited in child processes + * by default. Turn off the inherit bit. */ - SetHandleInformation( (HANDLE) sock, HANDLE_FLAG_INHERIT, 0 ); - + SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0); + /* * Set kernel space buffering */ TclSockMinimumBuffers((int) sock, TCP_BUFFER_SIZE); if (server) { /* - * Bind to the specified port. Note that we must not call setsockopt + * Bind to the specified port. Note that we must not call setsockopt * with SO_REUSEADDR because Microsoft allows addresses to be reused * even if they are still in use. - * - * Bind should not be affected by the socket having already been - * set into nonblocking mode. If there is trouble, this is one place - * to look for bugs. + * + * Bind should not be affected by the socket having already been set + * into nonblocking mode. If there is trouble, this is one place to + * look for bugs. */ - + if (winSock.bind(sock, (SOCKADDR *) &sockaddr, sizeof(SOCKADDR_IN)) == SOCKET_ERROR) { - goto error; - } - - /* - * Set the maximum number of pending connect requests to the - * max value allowed on each platform (Win32 and Win32s may be - * different, and there may be differences between TCP/IP stacks). - */ - + goto error; + } + + /* + * Set the maximum number of pending connect requests to the max value + * allowed on each platform (Win32 and Win32s may be different, and + * there may be differences between TCP/IP stacks). + */ + if (winSock.listen(sock, SOMAXCONN) == SOCKET_ERROR) { goto error; } /* @@ -1171,29 +1158,29 @@ infoPtr->selectEvents = FD_ACCEPT; infoPtr->watchEvents |= FD_ACCEPT; } else { + /* + * Try to bind to a local port, if specified. + */ - /* - * Try to bind to a local port, if specified. - */ - - if (myaddr != NULL || myport != 0) { + if (myaddr != NULL || myport != 0) { if (winSock.bind(sock, (SOCKADDR *) &mysockaddr, sizeof(SOCKADDR_IN)) == SOCKET_ERROR) { goto error; } - } - + } + /* - * Set the socket into nonblocking mode if the connect should be - * done in the background. + * Set the socket into nonblocking mode if the connect should be done + * in the background. */ - + if (async) { - if (winSock.ioctlsocket(sock, (long) FIONBIO, &flag) == SOCKET_ERROR) { + if (winSock.ioctlsocket(sock, (long) FIONBIO, + &flag) == SOCKET_ERROR) { goto error; } } /* @@ -1200,30 +1187,30 @@ * Attempt to connect to the remote socket. */ if (winSock.connect(sock, (SOCKADDR *) &sockaddr, sizeof(SOCKADDR_IN)) == SOCKET_ERROR) { - TclWinConvertWSAError((DWORD) winSock.WSAGetLastError()); + TclWinConvertWSAError((DWORD) winSock.WSAGetLastError()); if (Tcl_GetErrno() != EWOULDBLOCK) { goto error; } /* * The connection is progressing in the background. */ asyncConnect = 1; - } + } /* * Add this socket to the global list of sockets. */ infoPtr = NewSocketInfo(sock); /* - * Set up the select mask for read/write events. If the connect + * Set up the select mask for read/write events. If the connect * attempt has not completed, include connect events. */ infoPtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE; if (asyncConnect) { @@ -1231,21 +1218,21 @@ infoPtr->selectEvents |= FD_CONNECT; } } /* - * Register for interest in events in the select mask. Note that this + * Register for interest in events in the select mask. Note that this * automatically places the socket into non-blocking mode. */ winSock.ioctlsocket(sock, (long) FIONBIO, &flag); SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, (LPARAM) infoPtr); return infoPtr; -error: + error: TclWinConvertWSAError((DWORD) winSock.WSAGetLastError()); if (interp != NULL) { Tcl_AppendResult(interp, "couldn't open socket: ", Tcl_PosixError(interp), (char *) NULL); } @@ -1261,73 +1248,72 @@ * CreateSocketAddress -- * * This function initializes a sockaddr structure for a host and port. * * Results: - * 1 if the host was valid, 0 if the host could not be converted to - * an IP address. + * 1 if the host was valid, 0 if the host could not be converted to an IP + * address. * * Side effects: * Fills in the *sockaddrPtr structure. * *---------------------------------------------------------------------- */ static int CreateSocketAddress(sockaddrPtr, host, port) - LPSOCKADDR_IN sockaddrPtr; /* Socket address */ - CONST char *host; /* Host. NULL implies INADDR_ANY */ - int port; /* Port number */ + LPSOCKADDR_IN sockaddrPtr; /* Socket address */ + CONST char *host; /* Host. NULL implies INADDR_ANY */ + int port; /* Port number */ { - struct hostent *hostent; /* Host database entry */ - struct in_addr addr; /* For 64/32 bit madness */ + struct hostent *hostent; /* Host database entry */ + struct in_addr addr; /* For 64/32 bit madness */ /* - * Check that WinSock is initialized; do not call it if not, to - * prevent system crashes. This can happen at exit time if the exit - * handler for WinSock ran before other exit handlers that want to - * use sockets. + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. */ if (!SocketsEnabled()) { - Tcl_SetErrno(EFAULT); - return 0; + Tcl_SetErrno(EFAULT); + return 0; } ZeroMemory(sockaddrPtr, sizeof(SOCKADDR_IN)); sockaddrPtr->sin_family = AF_INET; sockaddrPtr->sin_port = winSock.htons((u_short) (port & 0xFFFF)); if (host == NULL) { addr.s_addr = INADDR_ANY; } else { - addr.s_addr = winSock.inet_addr(host); - if (addr.s_addr == INADDR_NONE) { - hostent = winSock.gethostbyname(host); - if (hostent != NULL) { - memcpy(&addr, hostent->h_addr, (size_t) hostent->h_length); - } else { + addr.s_addr = winSock.inet_addr(host); + if (addr.s_addr == INADDR_NONE) { + hostent = winSock.gethostbyname(host); + if (hostent != NULL) { + memcpy(&addr, hostent->h_addr, (size_t) hostent->h_length); + } else { #ifdef EHOSTUNREACH - Tcl_SetErrno(EHOSTUNREACH); + Tcl_SetErrno(EHOSTUNREACH); #else #ifdef ENXIO - Tcl_SetErrno(ENXIO); + Tcl_SetErrno(ENXIO); #endif #endif return 0; /* Error. */ } } } /* - * NOTE: On 64 bit machines the assignment below is rumored to not - * do the right thing. Please report errors related to this if you - * observe incorrect behavior on 64 bit machines such as DEC Alphas. - * Should we modify this code to do an explicit memcpy? + * NOTE: On 64 bit machines the assignment below is rumored to not do the + * right thing. Please report errors related to this if you observe + * incorrect behavior on 64 bit machines such as DEC Alphas. Should we + * modify this code to do an explicit memcpy? */ sockaddrPtr->sin_addr.s_addr = addr.s_addr; - return 1; /* Success. */ + return 1; /* Success. */ } /* *---------------------------------------------------------------------- * @@ -1351,19 +1337,19 @@ int events; /* Events to look for. */ int *errorCodePtr; /* Where to store errors? */ { int result = 1; int oldMode; - ThreadSpecificData *tsdPtr = - (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) + TclThreadDataKeyGet(&dataKey); /* * Be sure to disable event servicing so we are truly modal. */ oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE); - + /* * Reset WSAAsyncSelect so we have a fresh set of events pending. */ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, @@ -1371,11 +1357,10 @@ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, (LPARAM) infoPtr); while (1) { - if (infoPtr->lastError) { *errorCodePtr = infoPtr->lastError; result = 0; break; } else if (infoPtr->readyEvents & events) { @@ -1387,13 +1372,14 @@ } /* * Wait until something happens. */ + WaitForSingleObject(tsdPtr->readyEvent, INFINITE); } - + (void) Tcl_SetServiceMode(oldMode); return result; } /* @@ -1402,28 +1388,28 @@ * Tcl_OpenTcpClient -- * * Opens a TCP client socket and creates a channel around it. * * Results: - * The channel or NULL if failed. An error message is returned - * in the interpreter on failure. + * The channel or NULL if failed. An error message is returned in the + * interpreter on failure. * * Side effects: * Opens a client socket and creates a new channel. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async) - Tcl_Interp *interp; /* For error reporting; can be NULL. */ - int port; /* Port number to open. */ - CONST char *host; /* Host on which to open port. */ - CONST char *myaddr; /* Client-side address */ - int myport; /* Client-side port */ - int async; /* If nonzero, should connect - * client socket asynchronously. */ + Tcl_Interp *interp; /* For error reporting; can be NULL. */ + int port; /* Port number to open. */ + CONST char *host; /* Host on which to open port. */ + CONST char *myaddr; /* Client-side address */ + int myport; /* Client-side port */ + int async; /* If nonzero, should connect client socket + * asynchronously. */ { SocketInfo *infoPtr; char channelName[16 + TCL_INTEGER_SPACE]; if (TclpHasSockets(interp) != TCL_OK) { @@ -1443,17 +1429,17 @@ infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, (ClientData) infoPtr, (TCL_READABLE | TCL_WRITABLE)); if (Tcl_SetChannelOption(interp, infoPtr->channel, "-translation", "auto crlf") == TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); - return (Tcl_Channel) NULL; + Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); + return (Tcl_Channel) NULL; } if (Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "") == TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); - return (Tcl_Channel) NULL; + Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); + return (Tcl_Channel) NULL; } return infoPtr->channel; } /* @@ -1517,28 +1503,28 @@ * Tcl_OpenTcpServer -- * * Opens a TCP server socket and creates a channel around it. * * Results: - * The channel or NULL if failed. An error message is returned - * in the interpreter on failure. + * The channel or NULL if failed. An error message is returned in the + * interpreter on failure. * * Side effects: * Opens a server socket and creates a new channel. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_OpenTcpServer(interp, port, host, acceptProc, acceptProcData) - Tcl_Interp *interp; /* For error reporting - may be - * NULL. */ - int port; /* Port number to open. */ - CONST char *host; /* Name of local host. */ - Tcl_TcpAcceptProc *acceptProc; /* Callback for accepting connections - * from new clients. */ - ClientData acceptProcData; /* Data for the callback. */ + Tcl_Interp *interp; /* For error reporting - may be NULL. */ + int port; /* Port number to open. */ + CONST char *host; /* Name of local host. */ + Tcl_TcpAcceptProc *acceptProc; + /* Callback for accepting connections from new + * clients. */ + ClientData acceptProcData; /* Data for the callback. */ { SocketInfo *infoPtr; char channelName[16 + TCL_INTEGER_SPACE]; if (TclpHasSockets(interp) != TCL_OK) { @@ -1561,24 +1547,24 @@ infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, (ClientData) infoPtr, 0); if (Tcl_SetChannelOption(interp, infoPtr->channel, "-eofchar", "") == TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); - return (Tcl_Channel) NULL; + Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); + return (Tcl_Channel) NULL; } return infoPtr->channel; } /* *---------------------------------------------------------------------- * * TcpAccept -- - * Accept a TCP socket connection. This is called by - * SocketEventProc and it in turns calls the registered accept - * procedure. + * + * Accept a TCP socket connection. This is called by SocketEventProc and + * it in turns calls the registered accept function. * * Results: * None. * * Side effects: @@ -1594,12 +1580,12 @@ SOCKET newSocket; SocketInfo *newInfoPtr; SOCKADDR_IN addr; int len; char channelName[16 + TCL_INTEGER_SPACE]; - ThreadSpecificData *tsdPtr = - (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) + TclThreadDataKeyGet(&dataKey); /* * Accept the incoming connection request. */ @@ -1608,12 +1594,12 @@ newSocket = winSock.accept(infoPtr->socket, (SOCKADDR *)&addr, &len); /* * Clear the ready mask so we can detect the next connection request. - * Note that connection requests are level triggered, so if there is - * a request already pending, a new event will be generated. + * Note that connection requests are level triggered, so if there is a + * request already pending, a new event will be generated. */ if (newSocket == INVALID_SOCKET) { infoPtr->acceptEventCount = 0; infoPtr->readyEvents &= ~(FD_ACCEPT); @@ -1620,11 +1606,11 @@ return; } /* * It is possible that more than one FD_ACCEPT has been sent, so an extra - * count must be kept. Decrement the count, and reset the readyEvent bit + * count must be kept. Decrement the count, and reset the readyEvent bit * if the count is no longer > 0. */ infoPtr->acceptEventCount--; @@ -1631,15 +1617,15 @@ if (infoPtr->acceptEventCount <= 0) { infoPtr->readyEvents &= ~(FD_ACCEPT); } /* - * Win-NT has a misfeature that sockets are inherited in child - * processes by default. Turn off the inherit bit. + * Win-NT has a misfeature that sockets are inherited in child processes + * by default. Turn off the inherit bit. */ - SetHandleInformation( (HANDLE) newSocket, HANDLE_FLAG_INHERIT, 0 ); + SetHandleInformation((HANDLE) newSocket, HANDLE_FLAG_INHERIT, 0); /* * Add this socket to the global list of sockets. */ @@ -1666,16 +1652,15 @@ Tcl_Close((Tcl_Interp *) NULL, newInfoPtr->channel); return; } /* - * Invoke the accept callback procedure. + * Invoke the accept callback function. */ if (infoPtr->acceptProc != NULL) { - (infoPtr->acceptProc) (infoPtr->acceptProcData, - newInfoPtr->channel, + (infoPtr->acceptProc) (infoPtr->acceptProcData, newInfoPtr->channel, winSock.inet_ntoa(addr.sin_addr), winSock.ntohs(addr.sin_port)); } } @@ -1682,12 +1667,12 @@ /* *---------------------------------------------------------------------- * * TcpInputProc -- * - * This procedure is called by the generic IO level to read data from - * a socket based channel. + * This function is called by the generic IO level to read data from a + * socket based channel. * * Results: * The number of bytes read or -1 on error. * * Side effects: @@ -1696,38 +1681,37 @@ *---------------------------------------------------------------------- */ static int TcpInputProc(instanceData, buf, toRead, errorCodePtr) - ClientData instanceData; /* The socket state. */ - char *buf; /* Where to store data. */ - int toRead; /* Maximum number of bytes to read. */ - int *errorCodePtr; /* Where to store error codes. */ + ClientData instanceData; /* The socket state. */ + char *buf; /* Where to store data. */ + int toRead; /* Maximum number of bytes to read. */ + int *errorCodePtr; /* Where to store error codes. */ { SocketInfo *infoPtr = (SocketInfo *) instanceData; int bytesRead; DWORD error; - ThreadSpecificData *tsdPtr = + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); - + *errorCodePtr = 0; /* - * Check that WinSock is initialized; do not call it if not, to - * prevent system crashes. This can happen at exit time if the exit - * handler for WinSock ran before other exit handlers that want to - * use sockets. + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. */ if (!SocketsEnabled()) { - *errorCodePtr = EFAULT; - return -1; + *errorCodePtr = EFAULT; + return -1; } /* - * First check to see if EOF was already detected, to prevent - * calling the socket stack after the first time EOF is detected. + * First check to see if EOF was already detected, to prevent calling the + * socket stack after the first time EOF is detected. */ if (infoPtr->flags & SOCKET_EOF) { return 0; } @@ -1738,83 +1722,83 @@ if ((infoPtr->flags & SOCKET_ASYNC_CONNECT) && ! WaitForSocketEvent(infoPtr, FD_CONNECT, errorCodePtr)) { return -1; } - + /* - * No EOF, and it is connected, so try to read more from the socket. - * Note that we clear the FD_READ bit because read events are level - * triggered so a new event will be generated if there is still data - * available to be read. We have to simulate blocking behavior here - * since we are always using non-blocking sockets. + * No EOF, and it is connected, so try to read more from the socket. Note + * that we clear the FD_READ bit because read events are level triggered + * so a new event will be generated if there is still data available to be + * read. We have to simulate blocking behavior here since we are always + * using non-blocking sockets. */ while (1) { SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, (LPARAM) infoPtr); bytesRead = winSock.recv(infoPtr->socket, buf, toRead, 0); infoPtr->readyEvents &= ~(FD_READ); - + /* * Check for end-of-file condition or successful read. */ - + if (bytesRead == 0) { infoPtr->flags |= SOCKET_EOF; } if (bytesRead != SOCKET_ERROR) { break; } - + /* - * If an error occurs after the FD_CLOSE has arrived, - * then ignore the error and report an EOF. + * If an error occurs after the FD_CLOSE has arrived, then ignore the + * error and report an EOF. */ - + if (infoPtr->readyEvents & FD_CLOSE) { infoPtr->flags |= SOCKET_EOF; bytesRead = 0; break; } - + /* * Check for error condition or underflow in non-blocking case. */ - + error = winSock.WSAGetLastError(); if ((infoPtr->flags & SOCKET_ASYNC) || (error != WSAEWOULDBLOCK)) { TclWinConvertWSAError(error); *errorCodePtr = Tcl_GetErrno(); bytesRead = -1; break; } /* - * In the blocking case, wait until the file becomes readable - * or closed and try again. + * In the blocking case, wait until the file becomes readable or + * closed and try again. */ if (!WaitForSocketEvent(infoPtr, FD_READ|FD_CLOSE, errorCodePtr)) { bytesRead = -1; break; - } + } } - + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, (LPARAM) infoPtr); - + return bytesRead; } /* *---------------------------------------------------------------------- * * TcpOutputProc -- * - * This procedure is called by the generic IO level to write data - * to a socket based channel. + * This function is called by the generic IO level to write data to a + * socket based channel. * * Results: * The number of bytes written or -1 on failure. * * Side effects: @@ -1823,39 +1807,38 @@ *---------------------------------------------------------------------- */ static int TcpOutputProc(instanceData, buf, toWrite, errorCodePtr) - ClientData instanceData; /* The socket state. */ - CONST char *buf; /* Where to get data. */ - int toWrite; /* Maximum number of bytes to write. */ - int *errorCodePtr; /* Where to store error codes. */ + ClientData instanceData; /* The socket state. */ + CONST char *buf; /* Where to get data. */ + int toWrite; /* Maximum number of bytes to write. */ + int *errorCodePtr; /* Where to store error codes. */ { SocketInfo *infoPtr = (SocketInfo *) instanceData; int bytesWritten; DWORD error; - ThreadSpecificData *tsdPtr = + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); *errorCodePtr = 0; /* - * Check that WinSock is initialized; do not call it if not, to - * prevent system crashes. This can happen at exit time if the exit - * handler for WinSock ran before other exit handlers that want to - * use sockets. + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. */ if (!SocketsEnabled()) { - *errorCodePtr = EFAULT; - return -1; + *errorCodePtr = EFAULT; + return -1; } /* * Check to see if the socket is connected before trying to write. */ - + if ((infoPtr->flags & SOCKET_ASYNC_CONNECT) && ! WaitForSocketEvent(infoPtr, FD_CONNECT, errorCodePtr)) { return -1; } @@ -1864,26 +1847,26 @@ (WPARAM) UNSELECT, (LPARAM) infoPtr); bytesWritten = winSock.send(infoPtr->socket, buf, toWrite, 0); if (bytesWritten != SOCKET_ERROR) { /* - * Since Windows won't generate a new write event until we hit - * an overflow condition, we need to force the event loop to - * poll until the condition changes. + * Since Windows won't generate a new write event until we hit an + * overflow condition, we need to force the event loop to poll + * until the condition changes. */ if (infoPtr->watchEvents & FD_WRITE) { Tcl_Time blockTime = { 0, 0 }; Tcl_SetMaxBlockTime(&blockTime); - } + } break; } - + /* - * Check for error condition or overflow. In the event of overflow, we + * Check for error condition or overflow. In the event of overflow, we * need to clear the FD_WRITE flag so we can detect the next writable - * event. Note that Windows only sends a new writable event after a + * event. Note that Windows only sends a new writable event after a * send fails with WSAEWOULDBLOCK. */ error = winSock.WSAGetLastError(); if (error == WSAEWOULDBLOCK) { @@ -1890,21 +1873,21 @@ infoPtr->readyEvents &= ~(FD_WRITE); if (infoPtr->flags & SOCKET_ASYNC) { *errorCodePtr = EWOULDBLOCK; bytesWritten = -1; break; - } + } } else { TclWinConvertWSAError(error); *errorCodePtr = Tcl_GetErrno(); bytesWritten = -1; break; } /* - * In the blocking case, wait until the file becomes writable - * or closed and try again. + * In the blocking case, wait until the file becomes writable or + * closed and try again. */ if (!WaitForSocketEvent(infoPtr, FD_WRITE|FD_CLOSE, errorCodePtr)) { bytesWritten = -1; break; @@ -1911,11 +1894,11 @@ } } SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, (LPARAM) infoPtr); - + return bytesWritten; } /* *---------------------------------------------------------------------- @@ -1945,21 +1928,20 @@ /* BOOL val = FALSE; int boolVar, rtn; */ /* - * Check that WinSock is initialized; do not call it if not, to - * prevent system crashes. This can happen at exit time if the exit - * handler for WinSock ran before other exit handlers that want to - * use sockets. + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. */ if (!SocketsEnabled()) { if (interp) { Tcl_AppendResult(interp, "winsock is not initialized", NULL); } - return TCL_ERROR; + return TCL_ERROR; } infoPtr = (SocketInfo *) instanceData; sock = infoPtr->socket; @@ -2007,36 +1989,34 @@ /* *---------------------------------------------------------------------- * * TcpGetOptionProc -- * - * Computes an option value for a TCP socket based channel, or a - * list of all options and their values. + * Computes an option value for a TCP socket based channel, or a list of + * all options and their values. * * Note: This code is based on code contributed by John Haxby. * * Results: - * A standard Tcl result. The value of the specified option or a - * list of all options and their values is returned in the - * supplied DString. + * A standard Tcl result. The value of the specified option or a list of + * all options and their values is returned in the supplied DString. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int TcpGetOptionProc(instanceData, interp, optionName, dsPtr) - ClientData instanceData; /* Socket state. */ - Tcl_Interp *interp; /* For error reporting - can be NULL */ - CONST char *optionName; /* Name of the option to - * retrieve the value for, or - * NULL to get all options and - * their values. */ - Tcl_DString *dsPtr; /* Where to store the computed - * value; initialized by caller. */ + ClientData instanceData; /* Socket state. */ + Tcl_Interp *interp; /* For error reporting - can be NULL */ + CONST char *optionName; /* Name of the option to retrieve the value + * for, or NULL to get all options and their + * values. */ + Tcl_DString *dsPtr; /* Where to store the computed value; + * initialized by caller. */ { SocketInfo *infoPtr; SOCKADDR_IN sockname; SOCKADDR_IN peername; struct hostent *hostEntPtr; @@ -2044,35 +2024,34 @@ int size = sizeof(SOCKADDR_IN); size_t len = 0; char buf[TCL_INTEGER_SPACE]; /* - * Check that WinSock is initialized; do not call it if not, to - * prevent system crashes. This can happen at exit time if the exit - * handler for WinSock ran before other exit handlers that want to - * use sockets. + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. */ if (!SocketsEnabled()) { if (interp) { Tcl_AppendResult(interp, "winsock is not initialized", NULL); } - return TCL_ERROR; + return TCL_ERROR; } - + infoPtr = (SocketInfo *) instanceData; sock = (int) infoPtr->socket; if (optionName != (char *) NULL) { - len = strlen(optionName); + len = strlen(optionName); } if ((len > 1) && (optionName[1] == 'e') && (strncmp(optionName, "-error", len) == 0)) { int optlen; DWORD err; int ret; - + optlen = sizeof(int); ret = TclWinGetSockOpt(sock, SOL_SOCKET, SO_ERROR, (char *)&err, &optlen); if (ret == SOCKET_ERROR) { err = winSock.WSAGetLastError(); @@ -2082,111 +2061,106 @@ Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1); } return TCL_OK; } - if ((len == 0) || - ((len > 1) && (optionName[1] == 'p') && - (strncmp(optionName, "-peername", len) == 0))) { - if (winSock.getpeername(sock, (LPSOCKADDR) &peername, &size) - == 0) { - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-peername"); - Tcl_DStringStartSublist(dsPtr); - } - Tcl_DStringAppendElement(dsPtr, - winSock.inet_ntoa(peername.sin_addr)); + if ((len == 0) || ((len > 1) && (optionName[1] == 'p') && + (strncmp(optionName, "-peername", len) == 0))) { + if (winSock.getpeername(sock, (LPSOCKADDR) &peername, &size) == 0) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-peername"); + Tcl_DStringStartSublist(dsPtr); + } + Tcl_DStringAppendElement(dsPtr, + winSock.inet_ntoa(peername.sin_addr)); if (peername.sin_addr.s_addr == 0) { - hostEntPtr = (struct hostent *) NULL; - } else { - hostEntPtr = winSock.gethostbyaddr( - (char *) &(peername.sin_addr), sizeof(peername.sin_addr), - AF_INET); - } - if (hostEntPtr != (struct hostent *) NULL) { - Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); - } else { - Tcl_DStringAppendElement(dsPtr, - winSock.inet_ntoa(peername.sin_addr)); - } + hostEntPtr = (struct hostent *) NULL; + } else { + hostEntPtr = winSock.gethostbyaddr( + (char *) &(peername.sin_addr), + sizeof(peername.sin_addr), AF_INET); + } + if (hostEntPtr != (struct hostent *) NULL) { + Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); + } else { + Tcl_DStringAppendElement(dsPtr, + winSock.inet_ntoa(peername.sin_addr)); + } TclFormatInt(buf, winSock.ntohs(peername.sin_port)); - Tcl_DStringAppendElement(dsPtr, buf); - if (len == 0) { - Tcl_DStringEndSublist(dsPtr); - } else { - return TCL_OK; - } - } else { - /* - * getpeername failed - but if we were asked for all the options - * (len==0), don't flag an error at that point because it could - * be an fconfigure request on a server socket. (which have - * no peer). {copied from unix/tclUnixChan.c} - */ - if (len) { + Tcl_DStringAppendElement(dsPtr, buf); + if (len == 0) { + Tcl_DStringEndSublist(dsPtr); + } else { + return TCL_OK; + } + } else { + /* + * getpeername failed - but if we were asked for all the options + * (len==0), don't flag an error at that point because it could be + * an fconfigure request on a server socket (which have no peer). + * {Copied from unix/tclUnixChan.c} + */ + + if (len) { TclWinConvertWSAError((DWORD) winSock.WSAGetLastError()); - if (interp) { - Tcl_AppendResult(interp, "can't get peername: ", - Tcl_PosixError(interp), - (char *) NULL); - } - return TCL_ERROR; - } - } - } - - if ((len == 0) || - ((len > 1) && (optionName[1] == 's') && - (strncmp(optionName, "-sockname", len) == 0))) { - if (winSock.getsockname(sock, (LPSOCKADDR) &sockname, &size) - == 0) { - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-sockname"); - Tcl_DStringStartSublist(dsPtr); - } - Tcl_DStringAppendElement(dsPtr, - winSock.inet_ntoa(sockname.sin_addr)); - if (sockname.sin_addr.s_addr == 0) { - hostEntPtr = (struct hostent *) NULL; - } else { - hostEntPtr = winSock.gethostbyaddr( - (char *) &(sockname.sin_addr), sizeof(peername.sin_addr), - AF_INET); - } - if (hostEntPtr != (struct hostent *) NULL) { - Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); - } else { - Tcl_DStringAppendElement(dsPtr, - winSock.inet_ntoa(sockname.sin_addr)); - } - TclFormatInt(buf, winSock.ntohs(sockname.sin_port)); - Tcl_DStringAppendElement(dsPtr, buf); - if (len == 0) { - Tcl_DStringEndSublist(dsPtr); - } else { - return TCL_OK; - } - } else { + if (interp) { + Tcl_AppendResult(interp, "can't get peername: ", + Tcl_PosixError(interp), (char *) NULL); + } + return TCL_ERROR; + } + } + } + + if ((len == 0) || ((len > 1) && (optionName[1] == 's') && + (strncmp(optionName, "-sockname", len) == 0))) { + if (winSock.getsockname(sock, (LPSOCKADDR) &sockname, &size) == 0) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-sockname"); + Tcl_DStringStartSublist(dsPtr); + } + Tcl_DStringAppendElement(dsPtr, + winSock.inet_ntoa(sockname.sin_addr)); + if (sockname.sin_addr.s_addr == 0) { + hostEntPtr = (struct hostent *) NULL; + } else { + hostEntPtr = winSock.gethostbyaddr( + (char *) &(sockname.sin_addr), + sizeof(peername.sin_addr), AF_INET); + } + if (hostEntPtr != (struct hostent *) NULL) { + Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); + } else { + Tcl_DStringAppendElement(dsPtr, + winSock.inet_ntoa(sockname.sin_addr)); + } + TclFormatInt(buf, winSock.ntohs(sockname.sin_port)); + Tcl_DStringAppendElement(dsPtr, buf); + if (len == 0) { + Tcl_DStringEndSublist(dsPtr); + } else { + return TCL_OK; + } + } else { if (interp) { TclWinConvertWSAError((DWORD) winSock.WSAGetLastError()); Tcl_AppendResult(interp, "can't get sockname: ", - Tcl_PosixError(interp), - (char *) NULL); + Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } } /* if (len == 0 || !strncmp(optionName, "-keepalive", len)) { int optlen; BOOL opt = FALSE; - - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-keepalive"); - } + + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-keepalive"); + } optlen = sizeof(BOOL); winSock.getsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, (char *)&opt, &optlen); if (opt) { Tcl_DStringAppendElement(dsPtr, "1"); @@ -2199,14 +2173,14 @@ } if (len == 0 || !strncmp(optionName, "-nagle", len)) { int optlen; BOOL opt = FALSE; - - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-nagle"); - } + + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-nagle"); + } optlen = sizeof(BOOL); winSock.getsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (char *)&opt, &optlen); if (opt) { Tcl_DStringAppendElement(dsPtr, "0"); @@ -2218,12 +2192,12 @@ } } */ if (len > 0) { - /*return Tcl_BadChannelOption(interp, optionName, "peername sockname keepalive nagle");*/ - return Tcl_BadChannelOption(interp, optionName, "peername sockname"); + /*return Tcl_BadChannelOption(interp, optionName, "peername sockname keepalive nagle");*/ + return Tcl_BadChannelOption(interp, optionName, "peername sockname"); } return TCL_OK; } @@ -2230,49 +2204,49 @@ /* *---------------------------------------------------------------------- * * TcpWatchProc -- * - * Informs the channel driver of the events that the generic - * channel code wishes to receive on this socket. + * Informs the channel driver of the events that the generic channel code + * wishes to receive on this socket. * * Results: * None. * * Side effects: - * May cause the notifier to poll if any of the specified - * conditions are already true. + * May cause the notifier to poll if any of the specified conditions are + * already true. * *---------------------------------------------------------------------- */ static void TcpWatchProc(instanceData, mask) - ClientData instanceData; /* The socket state. */ - int mask; /* Events of interest; an OR-ed - * combination of TCL_READABLE, - * TCL_WRITABLE and TCL_EXCEPTION. */ + ClientData instanceData; /* The socket state. */ + int mask; /* Events of interest; an OR-ed combination of + * TCL_READABLE, TCL_WRITABLE and + * TCL_EXCEPTION. */ { SocketInfo *infoPtr = (SocketInfo *) instanceData; - + /* - * Update the watch events mask. Only if the socket is not a - * server socket. Fix for SF Tcl Bug #557878. + * Update the watch events mask. Only if the socket is not a server + * socket. Fix for SF Tcl Bug #557878. */ - if (!infoPtr->acceptProc) { - infoPtr->watchEvents = 0; + if (!infoPtr->acceptProc) { + infoPtr->watchEvents = 0; if (mask & TCL_READABLE) { infoPtr->watchEvents |= (FD_READ|FD_CLOSE|FD_ACCEPT); } if (mask & TCL_WRITABLE) { infoPtr->watchEvents |= (FD_WRITE|FD_CLOSE|FD_CONNECT); } - + /* - * If there are any conditions already set, then tell the notifier to poll - * rather than block. + * If there are any conditions already set, then tell the notifier to + * poll rather than block. */ if (infoPtr->readyEvents & infoPtr->watchEvents) { Tcl_Time blockTime = { 0, 0 }; Tcl_SetMaxBlockTime(&blockTime); @@ -2329,20 +2303,20 @@ SocketThread(LPVOID arg) { MSG msg; ThreadSpecificData *tsdPtr = (ThreadSpecificData *)(arg); - tsdPtr->hwnd = CreateWindow("TclSocket", "TclSocket", + tsdPtr->hwnd = CreateWindow("TclSocket", "TclSocket", WS_TILED, 0, 0, 0, 0, NULL, NULL, windowClass.hInstance, arg); /* - * Signal the main thread that the window has been created - * and that the socket thread is ready to go. + * Signal the main thread that the window has been created and that the + * socket thread is ready to go. */ - + SetEvent(tsdPtr->readyEvent); - + if (tsdPtr->hwnd == NULL) { return 1; } /* @@ -2360,20 +2334,19 @@ /* *---------------------------------------------------------------------- * * SocketProc -- * - * This function is called when WSAAsyncSelect has been used - * to register interest in a socket event, and the event has - * occurred. + * This function is called when WSAAsyncSelect has been used to register + * interest in a socket event, and the event has occurred. * * Results: * 0 on success. * * Side effects: - * The flags for the given socket are updated to reflect the - * event that occured. + * The flags for the given socket are updated to reflect the event that + * occured. * *---------------------------------------------------------------------- */ static LRESULT CALLBACK @@ -2392,124 +2365,121 @@ #else (ThreadSpecificData *) GetWindowLong(hwnd, GWL_USERDATA); #endif switch (message) { - - default: - return DefWindowProc(hwnd, message, wParam, lParam); - break; - - case WM_CREATE: - /* - * store the initial tsdPtr, it's from a different thread, so it's - * not directly accessible, but needed. - */ - -#ifdef _WIN64 - SetWindowLongPtr(hwnd, GWLP_USERDATA, - (LONG_PTR) ((LPCREATESTRUCT)lParam)->lpCreateParams); -#else - SetWindowLong(hwnd, GWL_USERDATA, - (LONG) ((LPCREATESTRUCT)lParam)->lpCreateParams); -#endif - break; - - case WM_DESTROY: - PostQuitMessage(0); - break; - - case SOCKET_MESSAGE: - event = WSAGETSELECTEVENT(lParam); - error = WSAGETSELECTERROR(lParam); - socket = (SOCKET) wParam; - - /* - * Find the specified socket on the socket list and update its - * eventState flag. - */ - - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - for (infoPtr = tsdPtr->socketList; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (infoPtr->socket == socket) { - /* - * Update the socket state. - */ - - /* - * A count of FD_ACCEPTS is stored, so if an FD_CLOSE - * event happens, then clear the FD_ACCEPT count. - * Otherwise, increment the count if the current - * event is an FD_ACCEPT. - */ - - if (event & FD_CLOSE) { - infoPtr->acceptEventCount = 0; - infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT); - } else if (event & FD_ACCEPT) { - infoPtr->acceptEventCount++; - } - - if (event & FD_CONNECT) { - /* - * The socket is now connected, - * clear the async connect flag. - */ - - infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); - - /* - * Remember any error that occurred so we can report - * connection failures. - */ - - if (error != ERROR_SUCCESS) { - TclWinConvertWSAError((DWORD) error); - infoPtr->lastError = Tcl_GetErrno(); - } - - } - if (infoPtr->flags & SOCKET_ASYNC_CONNECT) { - infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); - if (error != ERROR_SUCCESS) { - TclWinConvertWSAError((DWORD) error); - infoPtr->lastError = Tcl_GetErrno(); - } - infoPtr->readyEvents |= FD_WRITE; - } - infoPtr->readyEvents |= event; - - /* - * Wake up the Main Thread. - */ - SetEvent(tsdPtr->readyEvent); - Tcl_ThreadAlert(tsdPtr->threadId); - break; - } - } - SetEvent(tsdPtr->socketListLock); - break; - - case SOCKET_SELECT: - infoPtr = (SocketInfo *) lParam; - if (wParam == SELECT) { - - winSock.WSAAsyncSelect(infoPtr->socket, hwnd, - SOCKET_MESSAGE, infoPtr->selectEvents); - } else { - /* - * Clear the selection mask - */ - - winSock.WSAAsyncSelect(infoPtr->socket, hwnd, 0, 0); - } - break; - - case SOCKET_TERMINATE: - DestroyWindow(hwnd); - break; + default: + return DefWindowProc(hwnd, message, wParam, lParam); + break; + + case WM_CREATE: + /* + * store the initial tsdPtr, it's from a different thread, so it's not + * directly accessible, but needed. + */ + +#ifdef _WIN64 + SetWindowLongPtr(hwnd, GWLP_USERDATA, + (LONG_PTR) ((LPCREATESTRUCT)lParam)->lpCreateParams); +#else + SetWindowLong(hwnd, GWL_USERDATA, + (LONG) ((LPCREATESTRUCT)lParam)->lpCreateParams); +#endif + break; + + case WM_DESTROY: + PostQuitMessage(0); + break; + + case SOCKET_MESSAGE: + event = WSAGETSELECTEVENT(lParam); + error = WSAGETSELECTERROR(lParam); + socket = (SOCKET) wParam; + + /* + * Find the specified socket on the socket list and update its + * eventState flag. + */ + + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + for (infoPtr = tsdPtr->socketList; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + if (infoPtr->socket == socket) { + /* + * Update the socket state. + */ + + /* + * A count of FD_ACCEPTS is stored, so if an FD_CLOSE event + * happens, then clear the FD_ACCEPT count. Otherwise, + * increment the count if the current event is an FD_ACCEPT. + */ + + if (event & FD_CLOSE) { + infoPtr->acceptEventCount = 0; + infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT); + } else if (event & FD_ACCEPT) { + infoPtr->acceptEventCount++; + } + + if (event & FD_CONNECT) { + /* + * The socket is now connected, clear the async connect + * flag. + */ + + infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); + + /* + * Remember any error that occurred so we can report + * connection failures. + */ + + if (error != ERROR_SUCCESS) { + TclWinConvertWSAError((DWORD) error); + infoPtr->lastError = Tcl_GetErrno(); + } + } + + if (infoPtr->flags & SOCKET_ASYNC_CONNECT) { + infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); + if (error != ERROR_SUCCESS) { + TclWinConvertWSAError((DWORD) error); + infoPtr->lastError = Tcl_GetErrno(); + } + infoPtr->readyEvents |= FD_WRITE; + } + infoPtr->readyEvents |= event; + + /* + * Wake up the Main Thread. + */ + SetEvent(tsdPtr->readyEvent); + Tcl_ThreadAlert(tsdPtr->threadId); + break; + } + } + SetEvent(tsdPtr->socketListLock); + break; + + case SOCKET_SELECT: + infoPtr = (SocketInfo *) lParam; + if (wParam == SELECT) { + winSock.WSAAsyncSelect(infoPtr->socket, hwnd, + SOCKET_MESSAGE, infoPtr->selectEvents); + } else { + /* + * Clear the selection mask + */ + + winSock.WSAAsyncSelect(infoPtr->socket, hwnd, 0, 0); + } + break; + + case SOCKET_TERMINATE: + DestroyWindow(hwnd); + break; } return 0; } @@ -2519,77 +2489,89 @@ * Tcl_GetHostName -- * * Returns the name of the local host. * * Results: - * A string containing the network name for this machine, or - * an empty string if we can't figure out the name. The caller - * must not modify or free this string. + * A string containing the network name for this machine. The caller must + * not modify or free this string. * * Side effects: - * None. + * Caches the name to return for future calls. * *---------------------------------------------------------------------- */ CONST char * Tcl_GetHostName() { - DWORD length; + return Tcl_GetString(TclGetProcessGlobalValue(&hostName)); +} + +/* + *---------------------------------------------------------------------- + * + * InitializeHostName -- + * + * This routine sets the process global value of the name of the local + * host on which the process is running. + * + * Results: + * None. + * + *---------------------------------------------------------------------- + */ + +void +InitializeHostName(valuePtr, lengthPtr, encodingPtr) + char **valuePtr; + int *lengthPtr; + Tcl_Encoding *encodingPtr; +{ WCHAR wbuf[MAX_COMPUTERNAME_LENGTH + 1]; - - Tcl_MutexLock(&socketMutex); - InitSockets(); - - if (hostnameInitialized) { - Tcl_MutexUnlock(&socketMutex); - return hostname; - } - Tcl_MutexUnlock(&socketMutex); - - if (TclpHasSockets(NULL) == TCL_OK) { - /* - * INTL: bug - */ - - if (winSock.gethostname(hostname, sizeof(hostname)) == 0) { - Tcl_MutexLock(&socketMutex); - hostnameInitialized = 1; - Tcl_MutexUnlock(&socketMutex); - return hostname; - } - } - Tcl_MutexLock(&socketMutex); - length = sizeof(hostname); + DWORD length = sizeof(wbuf) / sizeof(WCHAR); + Tcl_DString ds; + if ((*tclWinProcs->getComputerNameProc)(wbuf, &length) != 0) { /* * Convert string from native to UTF then change to lowercase. */ - Tcl_DString ds; - - lstrcpynA(hostname, Tcl_WinTCharToUtf((TCHAR *) wbuf, -1, &ds), - sizeof(hostname)); - Tcl_DStringFree(&ds); - Tcl_UtfToLower(hostname); - } else { - hostname[0] = '\0'; - } - hostnameInitialized = 1; - Tcl_MutexUnlock(&socketMutex); - return hostname; + Tcl_UtfToLower(Tcl_WinTCharToUtf((TCHAR *) wbuf, -1, &ds)); + + } else if (TclpHasSockets(NULL) == TCL_OK) { + /* + * Buffer length of 255 copied slavishly from previous version of this + * routine. Presumably there's a more "correct" macro value for a + * properly sized buffer for a gethostname() call. Maintainers are + * welcome to supply it. + */ + + Tcl_DStringInit(&ds); + Tcl_DStringSetLength(&ds, 255); + if (winSock.gethostname(Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds)) == 0) { + Tcl_DStringSetLength(&ds, 0); + } + } + + *encodingPtr = Tcl_GetEncoding(NULL, "utf-8"); + *lengthPtr = Tcl_DStringLength(&ds); + *valuePtr = ckalloc((unsigned int) (*lengthPtr)+1); + memcpy((VOID *) *valuePtr, (VOID *) Tcl_DStringValue(&ds), + (size_t)(*lengthPtr)+1); + Tcl_DStringFree(&ds); } /* *---------------------------------------------------------------------- * * TclWinGetSockOpt, et al. -- * - * These functions are wrappers that let us bind the WinSock - * API dynamically so we can run on systems that don't have - * the wsock32.dll. We need wrappers for these interfaces - * because they are called from the generic Tcl code. + * These functions are wrappers that let us bind the WinSock API + * dynamically so we can run on systems that don't have the wsock32.dll. + * We need wrappers for these interfaces because they are called from the + * generic Tcl code. * * Results: * As defined for each function. * * Side effects: @@ -2601,82 +2583,77 @@ int TclWinGetSockOpt(SOCKET s, int level, int optname, char * optval, int FAR *optlen) { /* - * Check that WinSock is initialized; do not call it if not, to - * prevent system crashes. This can happen at exit time if the exit - * handler for WinSock ran before other exit handlers that want to - * use sockets. + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. */ if (!SocketsEnabled()) { - return SOCKET_ERROR; + return SOCKET_ERROR; } - + return winSock.getsockopt(s, level, optname, optval, optlen); } int TclWinSetSockOpt(SOCKET s, int level, int optname, const char * optval, int optlen) { /* - * Check that WinSock is initialized; do not call it if not, to - * prevent system crashes. This can happen at exit time if the exit - * handler for WinSock ran before other exit handlers that want to - * use sockets. + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. */ + if (!SocketsEnabled()) { - return SOCKET_ERROR; + return SOCKET_ERROR; } return winSock.setsockopt(s, level, optname, optval, optlen); } u_short TclWinNToHS(u_short netshort) { /* - * Check that WinSock is initialized; do not call it if not, to - * prevent system crashes. This can happen at exit time if the exit - * handler for WinSock ran before other exit handlers that want to - * use sockets. + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. */ if (!SocketsEnabled()) { - return (u_short) -1; + return (u_short) -1; } return winSock.ntohs(netshort); } struct servent * TclWinGetServByName(const char * name, const char * proto) { /* - * Check that WinSock is initialized; do not call it if not, to - * prevent system crashes. This can happen at exit time if the exit - * handler for WinSock ran before other exit handlers that want to - * use sockets. + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. */ + if (!SocketsEnabled()) { - return (struct servent *) NULL; + return (struct servent *) NULL; } return winSock.getservbyname(name, proto); } - - /* *---------------------------------------------------------------------- * - * TclpCutSockChannel -- + * TcpThreadActionProc -- * - * Remove any thread local refs to this channel. See - * Tcl_CutChannel for more info. + * Insert or remove any thread local refs to this channel. * * Results: * None. * * Side effects: @@ -2683,118 +2660,83 @@ * Changes thread local list of valid channels. * *---------------------------------------------------------------------- */ -void -TclpCutSockChannel(chan) - Tcl_Channel chan; /* The channel being removed. Must - * not be referenced in any - * interpreter. */ -{ - ThreadSpecificData *tsdPtr; - SocketInfo *infoPtr; - SocketInfo **nextPtrPtr; - int removed = 0; - - if (Tcl_GetChannelType(chan) != &tcpChannelType) { - return; - } - - /* - * The initializtion of tsdPtr _after_ we have determined that we - * are dealing with socket is necessary. Doing it before causes - * the module to access th tdsPtr when it is not initialized yet, - * causing a lockup. - */ - - tsdPtr = TCL_TSD_INIT(&dataKey); - infoPtr = (SocketInfo *) Tcl_GetChannelInstanceData (chan); - - for (nextPtrPtr = &(tsdPtr->socketList); (*nextPtrPtr) != NULL; - nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { - if ((*nextPtrPtr) == infoPtr) { - (*nextPtrPtr) = infoPtr->nextPtr; - removed = 1; - break; - } - } - - /* - * This could happen if the channel was created in one thread - * and then moved to another without updating the thread - * local data in each thread. - */ - - if (!removed) { - Tcl_Panic("file info ptr not on thread channel list"); - } - - /* - * Stop notifications for the socket to occur in this thread. - */ - - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) UNSELECT, (LPARAM) infoPtr); -} - -/* - *---------------------------------------------------------------------- - * - * TclpSpliceSockChannel -- - * - * Insert thread local ref for this channel. - * Tcl_SpliceChannel for more info. - * - * Results: - * None. - * - * Side effects: - * Changes thread local list of valid channels. - * - *---------------------------------------------------------------------- - */ - -void -TclpSpliceSockChannel(chan) - Tcl_Channel chan; /* The channel being removed. Must - * not be referenced in any - * interpreter. */ -{ - ThreadSpecificData *tsdPtr; - SocketInfo *infoPtr; - - if (Tcl_GetChannelType(chan) != &tcpChannelType) { - return; - } - - /* - * Ensure that socket subsystem is initialized in this thread, or - * else sockets will not work. - */ - - Tcl_MutexLock(&socketMutex); - InitSockets(); - Tcl_MutexUnlock(&socketMutex); - - /* - * The initializtion of tsdPtr _after_ we have determined that we - * are dealing with socket is necessary. Doing it before causes - * the module to access th tdsPtr when it is not initialized yet, - * causing a lockup. - */ - - tsdPtr = TCL_TSD_INIT(&dataKey); - infoPtr = (SocketInfo *) Tcl_GetChannelInstanceData (chan); - - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - infoPtr->nextPtr = tsdPtr->socketList; - tsdPtr->socketList = infoPtr; - SetEvent(tsdPtr->socketListLock); - - /* - * Ensure that notifications for the socket occur in this thread. - */ - - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) SELECT, (LPARAM) infoPtr); -} +static void +TcpThreadActionProc (instanceData, action) + ClientData instanceData; + int action; +{ + ThreadSpecificData *tsdPtr; + SocketInfo *infoPtr = (SocketInfo *) instanceData; + int notifyCmd; + + if (action == TCL_CHANNEL_THREAD_INSERT) { + /* + * Ensure that socket subsystem is initialized in this thread, or else + * sockets will not work. + */ + + Tcl_MutexLock(&socketMutex); + InitSockets(); + Tcl_MutexUnlock(&socketMutex); + + tsdPtr = TCL_TSD_INIT(&dataKey); + + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + infoPtr->nextPtr = tsdPtr->socketList; + tsdPtr->socketList = infoPtr; + SetEvent(tsdPtr->socketListLock); + + notifyCmd = SELECT; + } else { + SocketInfo **nextPtrPtr; + int removed = 0; + + tsdPtr = TCL_TSD_INIT(&dataKey); + + /* + * TIP #218, Bugfix: All access to socketList has to be protected by + * the lock. + */ + + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + for (nextPtrPtr = &(tsdPtr->socketList); (*nextPtrPtr) != NULL; + nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { + if ((*nextPtrPtr) == infoPtr) { + (*nextPtrPtr) = infoPtr->nextPtr; + removed = 1; + break; + } + } + SetEvent(tsdPtr->socketListLock); + + /* + * This could happen if the channel was created in one thread and then + * moved to another without updating the thread local data in each + * thread. + */ + + if (!removed) { + Tcl_Panic("file info ptr not on thread channel list"); + } + + notifyCmd = UNSELECT; + } + + /* + * Ensure that, or stop, notifications for the socket occur in this + * thread. + */ + + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, + (WPARAM) notifyCmd, (LPARAM) infoPtr); +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: win/tclWinThrd.c ================================================================== --- win/tclWinThrd.c +++ win/tclWinThrd.c @@ -1,28 +1,28 @@ -/* +/* * tclWinThread.c -- * * This file implements the Windows-specific thread operations. * * Copyright (c) 1998 by Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinThrd.c,v 1.34 2004/10/27 20:53:38 davygrvy Exp $ + * RCS: @(#) $Id: tclWinThrd.c,v 1.34.2.6 2005/08/15 18:14:16 dgp Exp $ */ #include "tclWinInt.h" #include #include #include /* - * This is the master lock used to serialize access to other - * serialization data structures. + * This is the master lock used to serialize access to other serialization + * data structures. */ static CRITICAL_SECTION masterLock; static int init = 0; #define MASTER_LOCK TclpMasterLock() @@ -35,12 +35,12 @@ */ static CRITICAL_SECTION initLock; /* - * allocLock is used by Tcl's version of malloc for synchronization. - * For obvious reasons, cannot use any dyamically allocated storage. + * allocLock is used by Tcl's version of malloc for synchronization. For + * obvious reasons, cannot use any dyamically allocated storage. */ #ifdef TCL_THREADS static CRITICAL_SECTION allocLock; @@ -49,28 +49,27 @@ #endif /* TCL_THREADS */ /* * The joinLock serializes Create- and ExitThread. This is necessary to - * prevent a race where a new joinable thread exits before the creating - * thread had the time to create the necessary data structures in the - * emulation layer. + * prevent a race where a new joinable thread exits before the creating thread + * had the time to create the necessary data structures in the emulation + * layer. */ static CRITICAL_SECTION joinLock; /* - * Condition variables are implemented with a combination of a - * per-thread Windows Event and a per-condition waiting queue. - * The idea is that each thread has its own Event that it waits - * on when it is doing a ConditionWait; it uses the same event for - * all condition variables because it only waits on one at a time. - * Each condition variable has a queue of waiting threads, and a - * mutex used to serialize access to this queue. - * - * Special thanks to David Nichols and - * Jim Davidson for advice on the Condition Variable implementation. + * Condition variables are implemented with a combination of a per-thread + * Windows Event and a per-condition waiting queue. The idea is that each + * thread has its own Event that it waits on when it is doing a ConditionWait; + * it uses the same event for all condition variables because it only waits on + * one at a time. Each condition variable has a queue of waiting threads, and + * a mutex used to serialize access to this queue. + * + * Special thanks to David Nichols and Jim Davidson for advice on the + * Condition Variable implementation. */ /* * The per-thread event and queue pointers. */ @@ -87,79 +86,93 @@ #endif /* TCL_THREADS */ /* * State bits for the thread. - * WIN_THREAD_UNINIT Uninitialized. Must be zero because - * of the way ThreadSpecificData is created. + * WIN_THREAD_UNINIT Uninitialized. Must be zero because of the way + * ThreadSpecificData is created. * WIN_THREAD_RUNNING Running, not waiting. * WIN_THREAD_BLOCKED Waiting, or trying to wait. * WIN_THREAD_DEAD Dying - no per-thread event anymore. - */ + */ #define WIN_THREAD_UNINIT 0x0 #define WIN_THREAD_RUNNING 0x1 #define WIN_THREAD_BLOCKED 0x2 #define WIN_THREAD_DEAD 0x4 /* - * The per condition queue pointers and the - * Mutex used to serialize access to the queue. + * The per condition queue pointers and the Mutex used to serialize access to + * the queue. */ typedef struct WinCondition { - CRITICAL_SECTION condLock; /* Lock to serialize queuing on the condition */ + CRITICAL_SECTION condLock; /* Lock to serialize queuing on the + * condition. */ struct ThreadSpecificData *firstPtr; /* Queue pointers */ struct ThreadSpecificData *lastPtr; } WinCondition; +/* + * Additions by AOL for specialized thread memory allocator. + */ + +#ifdef USE_THREAD_ALLOC +static int once; +static DWORD tlsKey; + +typedef struct allocMutex { + Tcl_Mutex tlock; + CRITICAL_SECTION wlock; +} allocMutex; +#endif /* USE_THREAD_ALLOC */ /* *---------------------------------------------------------------------- * * TclpThreadCreate -- * * This procedure creates a new thread. * * Results: - * TCL_OK if the thread could be created. The thread ID is - * returned in a parameter. + * TCL_OK if the thread could be created. The thread ID is returned in a + * parameter. * * Side effects: * A new thread is created. * *---------------------------------------------------------------------- */ int TclpThreadCreate(idPtr, proc, clientData, stackSize, flags) - Tcl_ThreadId *idPtr; /* Return, the ID of the thread */ - Tcl_ThreadCreateProc proc; /* Main() function of the thread */ - ClientData clientData; /* The one argument to Main() */ - int stackSize; /* Size of stack for the new thread */ - int flags; /* Flags controlling behaviour of - * the new thread */ + Tcl_ThreadId *idPtr; /* Return, the ID of the thread. */ + Tcl_ThreadCreateProc proc; /* Main() function of the thread. */ + ClientData clientData; /* The one argument to Main(). */ + int stackSize; /* Size of stack for the new thread. */ + int flags; /* Flags controlling behaviour of the + * new thread. */ { HANDLE tHandle; EnterCriticalSection(&joinLock); #if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__) tHandle = (HANDLE) _beginthreadex(NULL, (unsigned) stackSize, proc, - clientData, 0, (unsigned *)idPtr); + clientData, 0, (unsigned *)idPtr); #else tHandle = CreateThread(NULL, (DWORD) stackSize, (LPTHREAD_START_ROUTINE) proc, (LPVOID) clientData, (DWORD) 0, (LPDWORD)idPtr); #endif if (tHandle == NULL) { - LeaveCriticalSection(&joinLock); + LeaveCriticalSection(&joinLock); return TCL_ERROR; } else { - if (flags & TCL_THREAD_JOINABLE) { - TclRememberJoinableThread (*idPtr); + if (flags & TCL_THREAD_JOINABLE) { + TclRememberJoinableThread(*idPtr); } /* * The only purpose of this is to decrement the reference count so the * OS resources will be reaquired when the thread closes. @@ -188,16 +201,15 @@ *---------------------------------------------------------------------- */ int Tcl_JoinThread(threadId, result) - Tcl_ThreadId threadId; /* Id of the thread to wait upon */ - int* result; /* Reference to the storage the result - * of the thread we wait upon will be - * written into. */ + Tcl_ThreadId threadId; /* Id of the thread to wait upon */ + int *result; /* Reference to the storage the result of the + * thread we wait upon will be written into. */ { - return TclJoinThread (threadId, result); + return TclJoinThread(threadId, result); } /* *---------------------------------------------------------------------- * @@ -217,11 +229,11 @@ void TclpThreadExit(status) int status; { EnterCriticalSection(&joinLock); - TclSignalExitThread (Tcl_GetCurrentThread (), status); + TclSignalExitThread(Tcl_GetCurrentThread(), status); LeaveCriticalSection(&joinLock); #if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__) _endthreadex((unsigned) status); #else @@ -246,22 +258,22 @@ */ Tcl_ThreadId Tcl_GetCurrentThread() { - return (Tcl_ThreadId)GetCurrentThreadId(); + return (Tcl_ThreadId) GetCurrentThreadId(); } /* *---------------------------------------------------------------------- * * TclpInitLock * * This procedure is used to grab a lock that serializes initialization - * and finalization of Tcl. On some platforms this may also initialize - * the mutex used to serialize creation of more mutexes and thread - * local storage keys. + * and finalization of Tcl. On some platforms this may also initialize + * the mutex used to serialize creation of more mutexes and thread local + * storage keys. * * Results: * None. * * Side effects: @@ -273,15 +285,16 @@ void TclpInitLock() { if (!init) { /* - * There is a fundamental race here that is solved by creating - * the first Tcl interpreter in a single threaded environment. - * Once the interpreter has been created, it is safe to create - * more threads that create interpreters in parallel. + * There is a fundamental race here that is solved by creating the + * first Tcl interpreter in a single threaded environment. Once the + * interpreter has been created, it is safe to create more threads + * that create interpreters in parallel. */ + init = 1; InitializeCriticalSection(&joinLock); InitializeCriticalSection(&initLock); InitializeCriticalSection(&masterLock); } @@ -291,12 +304,12 @@ /* *---------------------------------------------------------------------- * * TclpInitUnlock * - * This procedure is used to release a lock that serializes initialization - * and finalization of Tcl. + * This procedure is used to release a lock that serializes + * initialization and finalization of Tcl. * * Results: * None. * * Side effects: @@ -314,15 +327,15 @@ /* *---------------------------------------------------------------------- * * TclpMasterLock * - * This procedure is used to grab a lock that serializes creation - * of mutexes, condition variables, and thread local storage keys. + * This procedure is used to grab a lock that serializes creation of + * mutexes, condition variables, and thread local storage keys. * - * This lock must be different than the initLock because the - * initLock is held during creation of syncronization objects. + * This lock must be different than the initLock because the initLock is + * held during creation of syncronization objects. * * Results: * None. * * Side effects: @@ -334,15 +347,16 @@ void TclpMasterLock() { if (!init) { /* - * There is a fundamental race here that is solved by creating - * the first Tcl interpreter in a single threaded environment. - * Once the interpreter has been created, it is safe to create - * more threads that create interpreters in parallel. + * There is a fundamental race here that is solved by creating the + * first Tcl interpreter in a single threaded environment. Once the + * interpreter has been created, it is safe to create more threads + * that create interpreters in parallel. */ + init = 1; InitializeCriticalSection(&joinLock); InitializeCriticalSection(&initLock); InitializeCriticalSection(&masterLock); } @@ -352,12 +366,12 @@ /* *---------------------------------------------------------------------- * * TclpMasterUnlock * - * This procedure is used to release a lock that serializes creation - * and deletion of synchronization objects. + * This procedure is used to release a lock that serializes creation and + * deletion of synchronization objects. * * Results: * None. * * Side effects: @@ -375,17 +389,17 @@ /* *---------------------------------------------------------------------- * * Tcl_GetAllocMutex * - * This procedure returns a pointer to a statically initialized - * mutex for use by the memory allocator. The alloctor must - * use this lock, because all other locks are allocated... + * This procedure returns a pointer to a statically initialized mutex for + * use by the memory allocator. The alloctor must use this lock, because + * all other locks are allocated... * * Results: - * A pointer to a mutex that is suitable for passing to - * Tcl_MutexLock and Tcl_MutexUnlock. + * A pointer to a mutex that is suitable for passing to Tcl_MutexLock and + * Tcl_MutexUnlock. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -408,63 +422,70 @@ /* *---------------------------------------------------------------------- * * TclpFinalizeLock * - * This procedure is used to destroy all private resources used in - * this file. + * This procedure is used to destroy all private resources used in this + * file. * * Results: * None. * * Side effects: - * Destroys everything private. TclpInitLock must be held - * entering this function. + * Destroys everything private. TclpInitLock must be held entering this + * function. * *---------------------------------------------------------------------- */ void -TclFinalizeLock () +TclFinalizeLock() { MASTER_LOCK; DeleteCriticalSection(&joinLock); - /* Destroy the critical section that we are holding! */ + + /* + * Destroy the critical section that we are holding! + */ + DeleteCriticalSection(&masterLock); init = 0; + #ifdef TCL_THREADS if (allocOnce) { DeleteCriticalSection(&allocLock); allocOnce = 0; } #endif + LeaveCriticalSection(&initLock); - /* Destroy the critical section that we were holding. */ + + /* + * Destroy the critical section that we were holding. + */ + DeleteCriticalSection(&initLock); } #ifdef TCL_THREADS /* locally used prototype */ static void FinalizeConditionEvent(ClientData data); - /* *---------------------------------------------------------------------- * * Tcl_MutexLock -- * - * This procedure is invoked to lock a mutex. This is a self - * initializing mutex that is automatically finalized during - * Tcl_Finalize. + * This procedure is invoked to lock a mutex. This is a self initializing + * mutex that is automatically finalized during Tcl_Finalize. * * Results: * None. * * Side effects: - * May block the current thread. The mutex is aquired when - * this returns. + * May block the current thread. The mutex is aquired when this returns. * *---------------------------------------------------------------------- */ void @@ -473,16 +494,16 @@ { CRITICAL_SECTION *csPtr; if (*mutexPtr == NULL) { MASTER_LOCK; - /* + /* * Double inside master lock check to avoid a race. */ if (*mutexPtr == NULL) { - csPtr = (CRITICAL_SECTION *)ckalloc(sizeof(CRITICAL_SECTION)); + csPtr = (CRITICAL_SECTION *) ckalloc(sizeof(CRITICAL_SECTION)); InitializeCriticalSection(csPtr); *mutexPtr = (Tcl_Mutex)csPtr; TclRememberMutex(mutexPtr); } MASTER_UNLOCK; @@ -518,12 +539,12 @@ /* *---------------------------------------------------------------------- * * TclpFinalizeMutex -- * - * This procedure is invoked to clean up one mutex. This is only - * safe to call at the end of time. + * This procedure is invoked to clean up one mutex. This is only safe to + * call at the end of time. * * Results: * None. * * Side effects: @@ -545,221 +566,25 @@ } /* *---------------------------------------------------------------------- * - * TclpThreadDataKeyInit -- - * - * This procedure initializes a thread specific data block key. - * Each thread has table of pointers to thread specific data. - * all threads agree on which table entry is used by each module. - * this is remembered in a "data key", that is just an index into - * this table. To allow self initialization, the interface - * passes a pointer to this key and the first thread to use - * the key fills in the pointer to the key. The key should be - * a process-wide static. - * - * Results: - * None. - * - * Side effects: - * Will allocate memory the first time this process calls for - * this key. In this case it modifies its argument - * to hold the pointer to information about the key. - * - *---------------------------------------------------------------------- - */ - -void -TclpThreadDataKeyInit(keyPtr) - Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, - * really (DWORD **) */ -{ - DWORD *indexPtr; - DWORD newKey; - - MASTER_LOCK; - if (*keyPtr == NULL) { - indexPtr = (DWORD *)ckalloc(sizeof(DWORD)); - newKey = TlsAlloc(); - if (newKey != TLS_OUT_OF_INDEXES) { - *indexPtr = newKey; - } else { - Tcl_Panic("TlsAlloc failed from TclpThreadDataKeyInit!"); /* this should be a fatal error */ - } - *keyPtr = (Tcl_ThreadDataKey)indexPtr; - TclRememberDataKey(keyPtr); - } - MASTER_UNLOCK; -} - -/* - *---------------------------------------------------------------------- - * - * TclpThreadDataKeyGet -- - * - * This procedure returns a pointer to a block of thread local storage. - * - * Results: - * A thread-specific pointer to the data structure, or NULL - * if the memory has not been assigned to this key for this thread. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -VOID * -TclpThreadDataKeyGet(keyPtr) - Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, - * really (DWORD **) */ -{ - DWORD *indexPtr = *(DWORD **)keyPtr; - LPVOID result; - if (indexPtr == NULL) { - return NULL; - } else { - result = TlsGetValue(*indexPtr); - if ((result == NULL) && (GetLastError() != NO_ERROR)) { - Tcl_Panic("TlsGetValue failed from TclpThreadDataKeyGet!"); - } - return result; - } -} - -/* - *---------------------------------------------------------------------- - * - * TclpThreadDataKeySet -- - * - * This procedure sets the pointer to a block of thread local storage. - * - * Results: - * None. - * - * Side effects: - * Sets up the thread so future calls to TclpThreadDataKeyGet with - * this key will return the data pointer. - * - *---------------------------------------------------------------------- - */ - -void -TclpThreadDataKeySet(keyPtr, data) - Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, - * really (pthread_key_t **) */ - VOID *data; /* Thread local storage */ -{ - DWORD *indexPtr = *(DWORD **)keyPtr; - BOOL success; - success = TlsSetValue(*indexPtr, (void *)data); - if (!success) { - Tcl_Panic("TlsSetValue failed from TclpThreadDataKeySet!"); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclpFinalizeThreadData -- - * - * This procedure cleans up the thread-local storage. This is - * called once for each thread. - * - * Results: - * None. - * - * Side effects: - * Frees up the memory. - * - *---------------------------------------------------------------------- - */ - -void -TclpFinalizeThreadData(keyPtr) - Tcl_ThreadDataKey *keyPtr; -{ - VOID *result; - DWORD *indexPtr; - BOOL success; - -#ifdef USE_THREAD_ALLOC - TclWinFreeAllocCache(); -#endif - if (*keyPtr != NULL) { - indexPtr = *(DWORD **)keyPtr; - result = (VOID *)TlsGetValue(*indexPtr); - if (result != NULL) { - ckfree((char *)result); - success = TlsSetValue(*indexPtr, (void *)NULL); - if (!success) { - Tcl_Panic("TlsSetValue failed from TclpFinalizeThreadData!"); - } - } else { - if (GetLastError() != NO_ERROR) { - Tcl_Panic("TlsGetValue failed from TclpFinalizeThreadData!"); - } - } - } -} - -/* - *---------------------------------------------------------------------- - * - * TclpFinalizeThreadDataKey -- - * - * This procedure is invoked to clean up one key. This is a - * process-wide storage identifier. The thread finalization code - * cleans up the thread local storage itself. - * - * This assumes the master lock is held. - * - * Results: - * None. - * - * Side effects: - * The key is deallocated. - * - *---------------------------------------------------------------------- - */ - -void -TclpFinalizeThreadDataKey(keyPtr) - Tcl_ThreadDataKey *keyPtr; -{ - DWORD *indexPtr; - BOOL success; - if (*keyPtr != NULL) { - indexPtr = *(DWORD **)keyPtr; - success = TlsFree(*indexPtr); - if (!success) { - Tcl_Panic("TlsFree failed from TclpFinalizeThreadDataKey!"); - } - ckfree((char *)indexPtr); - *keyPtr = NULL; - } -} - -/* - *---------------------------------------------------------------------- - * * Tcl_ConditionWait -- * - * This procedure is invoked to wait on a condition variable. - * The mutex is atomically released as part of the wait, and - * automatically grabbed when the condition is signaled. + * This procedure is invoked to wait on a condition variable. The mutex + * is atomically released as part of the wait, and automatically grabbed + * when the condition is signaled. * * The mutex must be held when this procedure is called. * * Results: * None. * * Side effects: - * May block the current thread. The mutex is aquired when - * this returns. Will allocate memory for a HANDLE - * and initialize this the first time this Tcl_Condition is used. + * May block the current thread. The mutex is aquired when this returns. + * Will allocate memory for a HANDLE and initialize this the first time + * this Tcl_Condition is used. * *---------------------------------------------------------------------- */ void @@ -782,41 +607,39 @@ return; } /* - * Self initialize the two parts of the condition. - * The per-condition and per-thread parts need to be - * handled independently. + * Self initialize the two parts of the condition. The per-condition and + * per-thread parts need to be handled independently. */ if (tsdPtr->flags == WIN_THREAD_UNINIT) { MASTER_LOCK; - /* + /* * Create the per-thread event and queue pointers. */ if (tsdPtr->flags == WIN_THREAD_UNINIT) { tsdPtr->condEvent = CreateEvent(NULL, TRUE /* manual reset */, - FALSE /* non signaled */, NULL); + FALSE /* non signaled */, NULL); tsdPtr->nextPtr = NULL; tsdPtr->prevPtr = NULL; tsdPtr->flags = WIN_THREAD_RUNNING; doExit = 1; } MASTER_UNLOCK; if (doExit) { /* - * Create a per-thread exit handler to clean up the condEvent. - * We must be careful to do this outside the Master Lock - * because Tcl_CreateThreadExitHandler uses its own - * ThreadSpecificData, and initializing that may drop - * back into the Master Lock. + * Create a per-thread exit handler to clean up the condEvent. We + * must be careful to do this outside the Master Lock because + * Tcl_CreateThreadExitHandler uses its own ThreadSpecificData, + * and initializing that may drop back into the Master Lock. */ - + Tcl_CreateThreadExitHandler(FinalizeConditionEvent, (ClientData) tsdPtr); } } @@ -844,36 +667,36 @@ } else { wtime = timePtr->sec * 1000 + timePtr->usec / 1000; } /* - * Queue the thread on the condition, using - * the per-condition lock for serialization. + * Queue the thread on the condition, using the per-condition lock for + * serialization. */ tsdPtr->flags = WIN_THREAD_BLOCKED; tsdPtr->nextPtr = NULL; EnterCriticalSection(&winCondPtr->condLock); tsdPtr->prevPtr = winCondPtr->lastPtr; /* A: */ winCondPtr->lastPtr = tsdPtr; if (tsdPtr->prevPtr != NULL) { - tsdPtr->prevPtr->nextPtr = tsdPtr; + tsdPtr->prevPtr->nextPtr = tsdPtr; } if (winCondPtr->firstPtr == NULL) { - winCondPtr->firstPtr = tsdPtr; + winCondPtr->firstPtr = tsdPtr; } /* * Unlock the caller's mutex and wait for the condition, or a timeout. - * There is a minor issue here in that we don't count down the - * timeout if we get notified, but another thread grabs the condition - * before we do. In that race condition we'll wait again for the - * full timeout. Timed waits are dubious anyway. Either you have - * the locking protocol wrong and are masking a deadlock, - * or you are using conditions to pause your thread. + * There is a minor issue here in that we don't count down the timeout if + * we get notified, but another thread grabs the condition before we do. + * In that race condition we'll wait again for the full timeout. Timed + * waits are dubious anyway. Either you have the locking protocol wrong + * and are masking a deadlock, or you are using conditions to pause your + * thread. */ - + LeaveCriticalSection(csPtr); timeout = 0; while (!timeout && (tsdPtr->flags & WIN_THREAD_BLOCKED)) { ResetEvent(tsdPtr->condEvent); LeaveCriticalSection(&winCondPtr->condLock); @@ -882,36 +705,36 @@ } EnterCriticalSection(&winCondPtr->condLock); } /* - * Be careful on timeouts because the signal might arrive right around - * the time limit and someone else could have taken us off the queue. + * Be careful on timeouts because the signal might arrive right around the + * time limit and someone else could have taken us off the queue. */ - + if (timeout) { if (tsdPtr->flags & WIN_THREAD_RUNNING) { timeout = 0; } else { /* - * When dequeuing, we can leave the tsdPtr->nextPtr - * and tsdPtr->prevPtr with dangling pointers because - * they are reinitialilzed w/out reading them when the - * thread is enqueued later. + * When dequeuing, we can leave the tsdPtr->nextPtr and + * tsdPtr->prevPtr with dangling pointers because they are + * reinitialilzed w/out reading them when the thread is enqueued + * later. */ - if (winCondPtr->firstPtr == tsdPtr) { - winCondPtr->firstPtr = tsdPtr->nextPtr; - } else { - tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; - } - if (winCondPtr->lastPtr == tsdPtr) { - winCondPtr->lastPtr = tsdPtr->prevPtr; - } else { - tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; - } - tsdPtr->flags = WIN_THREAD_RUNNING; + if (winCondPtr->firstPtr == tsdPtr) { + winCondPtr->firstPtr = tsdPtr->nextPtr; + } else { + tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; + } + if (winCondPtr->lastPtr == tsdPtr) { + winCondPtr->lastPtr = tsdPtr->prevPtr; + } else { + tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; + } + tsdPtr->flags = WIN_THREAD_RUNNING; } } LeaveCriticalSection(&winCondPtr->condLock); EnterCriticalSection(csPtr); @@ -922,12 +745,12 @@ * * Tcl_ConditionNotify -- * * This procedure is invoked to signal a condition variable. * - * The mutex must be held during this call to avoid races, - * but this interface does not enforce that. + * The mutex must be held during this call to avoid races, but this + * interface does not enforce that. * * Results: * None. * * Side effects: @@ -944,13 +767,13 @@ ThreadSpecificData *tsdPtr; if (*condPtr != NULL) { winCondPtr = *((WinCondition **)condPtr); /* - * Loop through all the threads waiting on the condition - * and notify them (i.e., broadcast semantics). The queue - * manipulation is guarded by the per-condition coordinating mutex. + * Loop through all the threads waiting on the condition and notify + * them (i.e., broadcast semantics). The queue manipulation is guarded + * by the per-condition coordinating mutex. */ EnterCriticalSection(&winCondPtr->condLock); while (winCondPtr->firstPtr != NULL) { tsdPtr = winCondPtr->firstPtr; @@ -964,23 +787,23 @@ SetEvent(tsdPtr->condEvent); } LeaveCriticalSection(&winCondPtr->condLock); } else { /* - * Noone has used the condition variable, so there are no waiters. + * No-one has used the condition variable, so there are no waiters. */ } } /* *---------------------------------------------------------------------- * * FinalizeConditionEvent -- * - * This procedure is invoked to clean up the per-thread - * event used to implement condition waiting. - * This is only safe to call at the end of time. + * This procedure is invoked to clean up the per-thread event used to + * implement condition waiting. This is only safe to call at the end of + * time. * * Results: * None. * * Side effects: @@ -991,22 +814,22 @@ static void FinalizeConditionEvent(data) ClientData data; { - ThreadSpecificData *tsdPtr = (ThreadSpecificData *)data; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) data; tsdPtr->flags = WIN_THREAD_DEAD; CloseHandle(tsdPtr->condEvent); } /* *---------------------------------------------------------------------- * * TclpFinalizeCondition -- * - * This procedure is invoked to clean up a condition variable. - * This is only safe to call at the end of time. + * This procedure is invoked to clean up a condition variable. This is + * only safe to call at the end of time. * * This assumes the Master Lock is held. * * Results: * None. @@ -1022,14 +845,14 @@ Tcl_Condition *condPtr; { WinCondition *winCondPtr = *(WinCondition **)condPtr; /* - * Note - this is called long after the thread-local storage is - * reclaimed. The per-thread condition waiting event is - * reclaimed earlier in a per-thread exit handler, which is - * called before thread local storage is reclaimed. + * Note - this is called long after the thread-local storage is reclaimed. + * The per-thread condition waiting event is reclaimed earlier in a + * per-thread exit handler, which is called before thread local storage is + * reclaimed. */ if (winCondPtr != NULL) { DeleteCriticalSection(&winCondPtr->condLock); ckfree((char *)winCondPtr); @@ -1039,17 +862,10 @@ /* * Additions by AOL for specialized thread memory allocator. */ #ifdef USE_THREAD_ALLOC -static int once; -static DWORD key; - -typedef struct allocMutex { - Tcl_Mutex tlock; - CRITICAL_SECTION wlock; -} allocMutex; Tcl_Mutex * TclpNewAllocMutex(void) { struct allocMutex *lockPtr; @@ -1065,12 +881,15 @@ void TclpFreeAllocMutex(mutex) Tcl_Mutex *mutex; /* The alloc mutex to free. */ { - allocMutex* lockPtr = (allocMutex*) mutex; - if (!lockPtr) return; + allocMutex *lockPtr = (allocMutex *) mutex; + + if (!lockPtr) { + return; + } DeleteCriticalSection(&lockPtr->wlock); free(lockPtr); } void * @@ -1078,64 +897,74 @@ { VOID *result; if (!once) { /* - * We need to make sure that TclWinFreeAllocCache is called - * on each thread that calls this, but only on threads that - * call this. + * We need to make sure that TclpFreeAllocCache is called on each + * thread that calls this, but only on threads that call this. */ - key = TlsAlloc(); + + tlsKey = TlsAlloc(); once = 1; - if (key == TLS_OUT_OF_INDEXES) { + if (tlsKey == TLS_OUT_OF_INDEXES) { Tcl_Panic("could not allocate thread local storage"); } } - result = TlsGetValue(key); + result = TlsGetValue(tlsKey); if ((result == NULL) && (GetLastError() != NO_ERROR)) { - Tcl_Panic("TlsGetValue failed from TclpGetAllocCache!"); + Tcl_Panic("TlsGetValue failed from TclpGetAllocCache!"); } return result; } void TclpSetAllocCache(void *ptr) { BOOL success; - success = TlsSetValue(key, ptr); + success = TlsSetValue(tlsKey, ptr); if (!success) { - Tcl_Panic("TlsSetValue failed from TclpSetAllocCache!"); + Tcl_Panic("TlsSetValue failed from TclpSetAllocCache!"); } } void -TclWinFreeAllocCache(void) +TclpFreeAllocCache(void *ptr) { - void *ptr; BOOL success; - ptr = TlsGetValue(key); - if (ptr != NULL) { - success = TlsSetValue(key, NULL); - if (!success) { - Tcl_Panic("TlsSetValue failed from TclWinFreeAllocCache!"); - } - TclFreeAllocCache(ptr); - } else { - if (GetLastError() != NO_ERROR) { - Tcl_Panic("TlsGetValue failed from TclWinFreeAllocCache!"); - } - } - - if (once) { - success = TlsFree(key); - if (!success) { - Tcl_Panic("TlsFree failed from TclWinFreeAllocCache!"); - } - - once = 0; /* reset for next time. */ - } + if (ptr != NULL) { + /* + * Called by us in TclpFinalizeThreadData when a thread exits and + * destroys the tsd key which stores allocator caches. + */ + + TclFreeAllocCache(ptr); + success = TlsSetValue(tlsKey, NULL); + if (!success) { + panic("TlsSetValue failed from TclpFreeAllocCache!"); + } + } else if (once) { + /* + * Called by us in TclFinalizeThreadAlloc() during the library + * finalization initiated from Tcl_Finalize() + */ + + success = TlsFree(tlsKey); + if (!success) { + Tcl_Panic("TlsFree failed from TclpFreeAllocCache!"); + } + once = 0; /* reset for next time. */ + } + } #endif /* USE_THREAD_ALLOC */ #endif /* TCL_THREADS */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: win/tclWinTime.c ================================================================== --- win/tclWinTime.c +++ win/tclWinTime.c @@ -1,33 +1,34 @@ /* * tclWinTime.c -- * - * Contains Windows specific versions of Tcl functions that - * obtain time values from the operating system. + * Contains Windows specific versions of Tcl functions that obtain time + * values from the operating system. * * Copyright 1995-1998 by Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinTime.c,v 1.28 2004/09/07 17:39:00 kennykb Exp $ + * RCS: @(#) $Id: tclWinTime.c,v 1.28.2.2 2005/08/02 18:17:21 dgp Exp $ */ #include "tclInt.h" -#define SECSPERDAY (60L * 60L * 24L) -#define SECSPERYEAR (SECSPERDAY * 365L) -#define SECSPER4YEAR (SECSPERYEAR * 4L + SECSPERDAY) +#define SECSPERDAY (60L * 60L * 24L) +#define SECSPERYEAR (SECSPERDAY * 365L) +#define SECSPER4YEAR (SECSPERYEAR * 4L + SECSPERDAY) /* - * Number of samples over which to estimate the performance counter + * Number of samples over which to estimate the performance counter. */ -#define SAMPLES 64 + +#define SAMPLES 64 /* - * The following arrays contain the day of year for the last day of - * each month, where index 1 is January. + * The following arrays contain the day of year for the last day of each + * month, where index 1 is January. */ static int normalDays[] = { -1, 30, 58, 89, 119, 150, 180, 211, 242, 272, 303, 333, 364 }; @@ -45,59 +46,48 @@ /* * Data for managing high-resolution timers. */ typedef struct TimeInfo { - - CRITICAL_SECTION cs; /* Mutex guarding this structure */ - + CRITICAL_SECTION cs; /* Mutex guarding this structure. */ int initialized; /* Flag == 1 if this structure is * initialized. */ - - int perfCounterAvailable; /* Flag == 1 if the hardware has a - * performance counter */ - - HANDLE calibrationThread; /* Handle to the thread that keeps the - * virtual clock calibrated. */ - - HANDLE readyEvent; /* System event used to - * trigger the requesting thread - * when the clock calibration procedure - * is initialized for the first time */ - - HANDLE exitEvent; /* Event to signal out of an exit handler - * to tell the calibration loop to - * terminate */ - - LARGE_INTEGER nominalFreq; /* Nominal frequency of the system - * performance counter, that is, the value - * returned from QueryPerformanceFrequency. */ + int perfCounterAvailable; /* Flag == 1 if the hardware has a performance + * counter. */ + HANDLE calibrationThread; /* Handle to the thread that keeps the virtual + * clock calibrated. */ + HANDLE readyEvent; /* System event used to trigger the requesting + * thread when the clock calibration procedure + * is initialized for the first time. */ + HANDLE exitEvent; /* Event to signal out of an exit handler to + * tell the calibration loop to terminate. */ + LARGE_INTEGER nominalFreq; /* Nominal frequency of the system performance + * counter, that is, the value returned from + * QueryPerformanceFrequency. */ /* - * The following values are used for calculating virtual time. - * Virtual time is always equal to: + * The following values are used for calculating virtual time. Virtual + * time is always equal to: * lastFileTime + (current perf counter - lastCounter) * * 10000000 / curCounterFreq - * and lastFileTime and lastCounter are updated any time that - * virtual time is returned to a caller. + * and lastFileTime and lastCounter are updated any time that virtual time + * is returned to a caller. */ ULARGE_INTEGER fileTimeLastCall; LARGE_INTEGER perfCounterLastCall; LARGE_INTEGER curCounterFreq; /* - * Data used in developing the estimate of performance counter - * frequency + * Data used in developing the estimate of performance counter frequency */ + Tcl_WideUInt fileTimeSample[SAMPLES]; - /* Last 64 samples of system time */ + /* Last 64 samples of system time. */ Tcl_WideInt perfCounterSample[SAMPLES]; - /* Last 64 samples of performance counter */ - int sampleNo; /* Current sample number */ - - + /* Last 64 samples of performance counter. */ + int sampleNo; /* Current sample number. */ } TimeInfo; static TimeInfo timeInfo = { { NULL }, 0, @@ -123,31 +113,38 @@ /* * Declarations for functions defined later in this file. */ -static struct tm * ComputeGMT _ANSI_ARGS_((const time_t *tp)); -static void StopCalibration _ANSI_ARGS_(( ClientData )); -static DWORD WINAPI CalibrationThread _ANSI_ARGS_(( LPVOID arg )); -static void UpdateTimeEachSecond _ANSI_ARGS_(( void )); -static void ResetCounterSamples _ANSI_ARGS_(( - Tcl_WideUInt fileTime, - Tcl_WideInt perfCounter, - Tcl_WideInt perfFreq - )); -static Tcl_WideInt AccumulateSample _ANSI_ARGS_(( - Tcl_WideInt perfCounter, - Tcl_WideUInt fileTime - )); +static struct tm * ComputeGMT(const time_t *tp); +static void StopCalibration(ClientData clientData); +static DWORD WINAPI CalibrationThread(LPVOID arg); +static void UpdateTimeEachSecond(void); +static void ResetCounterSamples(Tcl_WideUInt fileTime, + Tcl_WideInt perfCounter, Tcl_WideInt perfFreq); +static Tcl_WideInt AccumulateSample(Tcl_WideInt perfCounter, + Tcl_WideUInt fileTime); +static void NativeScaleTime(Tcl_Time* timebuf, + ClientData clientData); +static void NativeGetTime(Tcl_Time* timebuf, + ClientData clientData); + +/* + * TIP #233 (Virtualized Time): Data for the time hooks, if any. + */ + +Tcl_GetTimeProc *tclGetTimeProcPtr = NativeGetTime; +Tcl_ScaleTimeProc *tclScaleTimeProcPtr = NativeScaleTime; +ClientData tclTimeClientData = NULL; /* *---------------------------------------------------------------------- * * TclpGetSeconds -- * - * This procedure returns the number of seconds from the epoch. - * On most Unix systems the epoch is Midnight Jan 1, 1970 GMT. + * This procedure returns the number of seconds from the epoch. On most + * Unix systems the epoch is Midnight Jan 1, 1970 GMT. * * Results: * Number of seconds from the epoch. * * Side effects: @@ -158,24 +155,24 @@ unsigned long TclpGetSeconds() { Tcl_Time t; - Tcl_GetTime( &t ); + + (*tclGetTimeProcPtr) (&t, tclTimeClientData); /* Tcl_GetTime inlined. */ return t.sec; } /* *---------------------------------------------------------------------- * * TclpGetClicks -- * - * This procedure returns a value that represents the highest - * resolution clock available on the system. There are no - * guarantees on what the resolution will be. In Tcl we will - * call this value a "click". The start time is also system - * dependant. + * This procedure returns a value that represents the highest resolution + * clock available on the system. There are no guarantees on what the + * resolution will be. In Tcl we will call this value a "click". The + * start time is also system dependant. * * Results: * Number of clicks from some start time. * * Side effects: @@ -186,31 +183,31 @@ unsigned long TclpGetClicks() { /* - * Use the Tcl_GetTime abstraction to get the time in microseconds, - * as nearly as we can, and return it. + * Use the Tcl_GetTime abstraction to get the time in microseconds, as + * nearly as we can, and return it. */ Tcl_Time now; /* Current Tcl time */ unsigned long retval; /* Value to return */ - Tcl_GetTime( &now ); - retval = ( now.sec * 1000000 ) + now.usec; + (*tclGetTimeProcPtr) (&now, tclTimeClientData); /* Tcl_GetTime inlined */ + + retval = (now.sec * 1000000) + now.usec; return retval; } /* *---------------------------------------------------------------------- * * TclpGetTimeZone -- * - * Determines the current timezone. The method varies wildly - * between different Platform implementations, so its hidden in - * this function. + * Determines the current timezone. The method varies wildly between + * different Platform implementations, so its hidden in this function. * * Results: * Minutes west of GMT. * * Side effects: @@ -218,12 +215,12 @@ * *---------------------------------------------------------------------- */ int -TclpGetTimeZone (currentTime) - unsigned long currentTime; +TclpGetTimeZone(currentTime) + unsigned long currentTime; { int timeZone; tzset(); timeZone = timezone / 60; @@ -234,214 +231,253 @@ /* *---------------------------------------------------------------------- * * Tcl_GetTime -- * - * Gets the current system time in seconds and microseconds - * since the beginning of the epoch: 00:00 UCT, January 1, 1970. + * Gets the current system time in seconds and microseconds since the + * beginning of the epoch: 00:00 UCT, January 1, 1970. * * Results: * Returns the current time in timePtr. * * Side effects: - * On the first call, initializes a set of static variables to - * keep track of the base value of the performance counter, the - * corresponding wall clock (obtained through ftime) and the - * frequency of the performance counter. Also spins a thread - * whose function is to wake up periodically and monitor these - * values, adjusting them as necessary to correct for drift - * in the performance counter's oscillator. + * On the first call, initializes a set of static variables to keep track + * of the base value of the performance counter, the corresponding wall + * clock (obtained through ftime) and the frequency of the performance + * counter. Also spins a thread whose function is to wake up periodically + * and monitor these values, adjusting them as necessary to correct for + * drift in the performance counter's oscillator. * *---------------------------------------------------------------------- */ void Tcl_GetTime(timePtr) Tcl_Time *timePtr; /* Location to store time information. */ { - + (*tclGetTimeProcPtr) (timePtr, tclTimeClientData); +} + +/* + *---------------------------------------------------------------------- + * + * NativeScaleTime -- + * + * TIP #233: Scale from virtual time to the real-time. For native scaling + * the relationship is 1:1 and nothing has to be done. + * + * Results: + * Scales the time in timePtr. + * + * Side effects: + * See above. + * + *---------------------------------------------------------------------- + */ + +static void +NativeScaleTime(timePtr, clientData) + Tcl_Time *timePtr; + ClientData clientData; +{ + /* + * Native scale is 1:1. Nothing is done. + */ +} + +/* + *---------------------------------------------------------------------- + * + * NativeGetTime -- + * + * TIP #233: Gets the current system time in seconds and microseconds + * since the beginning of the epoch: 00:00 UCT, January 1, 1970. + * + * Results: + * Returns the current time in timePtr. + * + * Side effects: + * On the first call, initializes a set of static variables to keep track + * of the base value of the performance counter, the corresponding wall + * clock (obtained through ftime) and the frequency of the performance + * counter. Also spins a thread whose function is to wake up periodically + * and monitor these values, adjusting them as necessary to correct for + * drift in the performance counter's oscillator. + * + *---------------------------------------------------------------------- + */ + +static void +NativeGetTime(timePtr, clientData) + Tcl_Time *timePtr; + ClientData clientData; +{ struct timeb t; - - int useFtime = 1; /* Flag == TRUE if we need to fall back - * on ftime rather than using the perf - * counter */ - - /* Initialize static storage on the first trip through. */ - - /* - * Note: Outer check for 'initialized' is a performance win - * since it avoids an extra mutex lock in the common case. - */ - - if ( !timeInfo.initialized ) { - TclpInitLock(); - if ( !timeInfo.initialized ) { - timeInfo.perfCounterAvailable - = QueryPerformanceFrequency( &timeInfo.nominalFreq ); - - /* - * Some hardware abstraction layers use the CPU clock - * in place of the real-time clock as a performance counter - * reference. This results in: + int useFtime = 1; /* Flag == TRUE if we need to fall back on + * ftime rather than using the perf counter. */ + + /* + * Initialize static storage on the first trip through. + * + * Note: Outer check for 'initialized' is a performance win since it + * avoids an extra mutex lock in the common case. + */ + + if (!timeInfo.initialized) { + TclpInitLock(); + if (!timeInfo.initialized) { + timeInfo.perfCounterAvailable = + QueryPerformanceFrequency(&timeInfo.nominalFreq); + + /* + * Some hardware abstraction layers use the CPU clock in place of + * the real-time clock as a performance counter reference. This + * results in: * - inconsistent results among the processors on * multi-processor systems. - * - unpredictable changes in performance counter frequency - * on "gearshift" processors such as Transmeta and - * SpeedStep. + * - unpredictable changes in performance counter frequency on + * "gearshift" processors such as Transmeta and SpeedStep. * * There seems to be no way to test whether the performance - * counter is reliable, but a useful heuristic is that - * if its frequency is 1.193182 MHz or 3.579545 MHz, it's - * derived from a colorburst crystal and is therefore - * the RTC rather than the TSC. - * - * A sloppier but serviceable heuristic is that the RTC crystal - * is normally less than 15 MHz while the TSC crystal is - * virtually assured to be greater than 100 MHz. Since Win98SE - * appears to fiddle with the definition of the perf counter - * frequency (perhaps in an attempt to calibrate the clock?) - * we use the latter rule rather than an exact match. - * - * We also assume (perhaps questionably) that the vendors - * have gotten their act together on Win64, so bypass all - * this rubbish on that platform. + * counter is reliable, but a useful heuristic is that if its + * frequency is 1.193182 MHz or 3.579545 MHz, it's derived from a + * colorburst crystal and is therefore the RTC rather than the + * TSC. + * + * A sloppier but serviceable heuristic is that the RTC crystal is + * normally less than 15 MHz while the TSC crystal is virtually + * assured to be greater than 100 MHz. Since Win98SE appears to + * fiddle with the definition of the perf counter frequency + * (perhaps in an attempt to calibrate the clock?), we use the + * latter rule rather than an exact match. + * + * We also assume (perhaps questionably) that the vendors have + * gotten their act together on Win64, so bypass all this rubbish + * on that platform. */ #if !defined(_WIN64) - if ( timeInfo.perfCounterAvailable - /* The following lines would do an exact match on - * crystal frequency: - * && timeInfo.nominalFreq.QuadPart != (Tcl_WideInt) 1193182 - * && timeInfo.nominalFreq.QuadPart != (Tcl_WideInt) 3579545 - */ - && timeInfo.nominalFreq.QuadPart > (Tcl_WideInt) 15000000 ) { - + if (timeInfo.perfCounterAvailable + /* + * The following lines would do an exact match on crystal + * frequency: + * && timeInfo.nominalFreq.QuadPart != (Tcl_WideInt)1193182 + * && timeInfo.nominalFreq.QuadPart != (Tcl_WideInt)3579545 + */ + && timeInfo.nominalFreq.QuadPart > (Tcl_WideInt) 15000000){ /* * As an exception, if every logical processor on the system * is on the same chip, we use the performance counter anyway, * presuming that everyone's TSC is locked to the same * oscillator. */ SYSTEM_INFO systemInfo; unsigned int regs[4]; - GetSystemInfo( &systemInfo ); - if ( TclWinCPUID( 0, regs ) == TCL_OK - - && regs[1] == 0x756e6547 /* "Genu" */ - && regs[3] == 0x49656e69 /* "ineI" */ - && regs[2] == 0x6c65746e /* "ntel" */ - - && TclWinCPUID( 1, regs ) == TCL_OK - - && ( (regs[0] & 0x00000F00) == 0x00000F00 /* Pentium 4 */ - || ( (regs[0] & 0x00F00000) /* Extended family */ - && (regs[3] & 0x10000000) ) ) /* Hyperthread */ - && ( ( ( regs[1] & 0x00FF0000 ) >> 16 ) /* CPU count */ - == systemInfo.dwNumberOfProcessors ) - - ) { + + GetSystemInfo(&systemInfo); + if (TclWinCPUID(0, regs) == TCL_OK + && regs[1] == 0x756e6547 /* "Genu" */ + && regs[3] == 0x49656e69 /* "ineI" */ + && regs[2] == 0x6c65746e /* "ntel" */ + && TclWinCPUID(1, regs) == TCL_OK + && ((regs[0]&0x00000F00) == 0x00000F00 /* Pentium 4 */ + || ((regs[0] & 0x00F00000) /* Extended family */ + && (regs[3] & 0x10000000))) /* Hyperthread */ + && (((regs[1]&0x00FF0000) >> 16)/* CPU count */ + == systemInfo.dwNumberOfProcessors)) { timeInfo.perfCounterAvailable = TRUE; } else { timeInfo.perfCounterAvailable = FALSE; } - } #endif /* above code is Win32 only */ /* * If the performance counter is available, start a thread to * calibrate it. */ - if ( timeInfo.perfCounterAvailable ) { + if (timeInfo.perfCounterAvailable) { DWORD id; - InitializeCriticalSection( &timeInfo.cs ); - timeInfo.readyEvent = CreateEvent( NULL, FALSE, FALSE, NULL ); - timeInfo.exitEvent = CreateEvent( NULL, FALSE, FALSE, NULL ); - timeInfo.calibrationThread = CreateThread( NULL, - 256, - CalibrationThread, - (LPVOID) NULL, - 0, - &id ); - SetThreadPriority( timeInfo.calibrationThread, - THREAD_PRIORITY_HIGHEST ); + + InitializeCriticalSection(&timeInfo.cs); + timeInfo.readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL); + timeInfo.exitEvent = CreateEvent(NULL, FALSE, FALSE, NULL); + timeInfo.calibrationThread = CreateThread(NULL, 256, + CalibrationThread, (LPVOID) NULL, 0, &id); + SetThreadPriority(timeInfo.calibrationThread, + THREAD_PRIORITY_HIGHEST); /* - * Wait for the thread just launched to start running, - * and create an exit handler that kills it so that it - * doesn't outlive unloading tclXX.dll + * Wait for the thread just launched to start running, and + * create an exit handler that kills it so that it doesn't + * outlive unloading tclXX.dll */ - WaitForSingleObject( timeInfo.readyEvent, INFINITE ); - CloseHandle( timeInfo.readyEvent ); - Tcl_CreateExitHandler( StopCalibration, (ClientData) NULL ); + WaitForSingleObject(timeInfo.readyEvent, INFINITE); + CloseHandle(timeInfo.readyEvent); + Tcl_CreateExitHandler(StopCalibration, (ClientData) NULL); } timeInfo.initialized = TRUE; } TclpInitUnlock(); } - if ( timeInfo.perfCounterAvailable - && timeInfo.curCounterFreq.QuadPart!=0 ) { - + if (timeInfo.perfCounterAvailable && timeInfo.curCounterFreq.QuadPart!=0) { /* - * Query the performance counter and use it to calculate the - * current time. + * Query the performance counter and use it to calculate the current + * time. */ LARGE_INTEGER curCounter; - /* Current performance counter */ - - Tcl_WideInt curFileTime; - /* Current estimated time, expressed - * as 100-ns ticks since the Windows epoch */ - + /* Current performance counter. */ + Tcl_WideInt curFileTime;/* Current estimated time, expressed as 100-ns + * ticks since the Windows epoch. */ static LARGE_INTEGER posixEpoch; - /* Posix epoch expressed as 100-ns ticks - * since the windows epoch */ - + /* Posix epoch expressed as 100-ns ticks since + * the windows epoch. */ Tcl_WideInt usecSincePosixEpoch; - /* Current microseconds since Posix epoch */ + /* Current microseconds since Posix epoch. */ posixEpoch.LowPart = 0xD53E8000; posixEpoch.HighPart = 0x019DB1DE; - EnterCriticalSection( &timeInfo.cs ); + EnterCriticalSection(&timeInfo.cs); - QueryPerformanceCounter( &curCounter ); + QueryPerformanceCounter(&curCounter); /* * If it appears to be more than 1.1 seconds since the last trip - * through the calibration loop, the performance counter may - * have jumped forward. (See MSDN Knowledge Base article - * Q274323 for a description of the hardware problem that makes - * this test necessary.) If the counter jumps, we don't want - * to use it directly. Instead, we must return system time. - * Eventually, the calibration loop should recover. + * through the calibration loop, the performance counter may have + * jumped forward. (See MSDN Knowledge Base article Q274323 for a + * description of the hardware problem that makes this test + * necessary.) If the counter jumps, we don't want to use it directly. + * Instead, we must return system time. Eventually, the calibration + * loop should recover. */ - if ( curCounter.QuadPart - timeInfo.perfCounterLastCall.QuadPart - < 11 * timeInfo.curCounterFreq.QuadPart / 10 ) { - - curFileTime = timeInfo.fileTimeLastCall.QuadPart - + ( ( curCounter.QuadPart - timeInfo.perfCounterLastCall.QuadPart ) - * 10000000 / timeInfo.curCounterFreq.QuadPart ); + + if (curCounter.QuadPart - timeInfo.perfCounterLastCall.QuadPart < + 11 * timeInfo.curCounterFreq.QuadPart / 10) { + curFileTime = timeInfo.fileTimeLastCall.QuadPart + + ((curCounter.QuadPart - timeInfo.perfCounterLastCall.QuadPart) + * 10000000 / timeInfo.curCounterFreq.QuadPart); timeInfo.fileTimeLastCall.QuadPart = curFileTime; timeInfo.perfCounterLastCall.QuadPart = curCounter.QuadPart; - usecSincePosixEpoch = ( curFileTime - posixEpoch.QuadPart ) / 10; - timePtr->sec = (time_t) ( usecSincePosixEpoch / 1000000 ); - timePtr->usec = (unsigned long ) ( usecSincePosixEpoch % 1000000 ); + usecSincePosixEpoch = (curFileTime - posixEpoch.QuadPart) / 10; + timePtr->sec = (time_t) (usecSincePosixEpoch / 1000000); + timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000); useFtime = 0; } - LeaveCriticalSection( &timeInfo.cs ); + LeaveCriticalSection(&timeInfo.cs); } - if ( useFtime ) { - - /* High resolution timer is not available. Just use ftime */ + if (useFtime) { + /* + * High resolution timer is not available. Just use ftime. + */ ftime(&t); timePtr->sec = t.time; timePtr->usec = t.millitm * 1000; } @@ -457,28 +493,30 @@ * * Results: * None. * * Side effects: - * Sets the 'exitEvent' event in the 'timeInfo' structure to ask - * the thread in question to exit, and waits for it to do so. + * Sets the 'exitEvent' event in the 'timeInfo' structure to ask the + * thread in question to exit, and waits for it to do so. * *---------------------------------------------------------------------- */ static void -StopCalibration( ClientData unused ) +StopCalibration(ClientData unused) /* Client data is unused */ { - SetEvent( timeInfo.exitEvent ); + SetEvent(timeInfo.exitEvent); + /* - * If Tcl_Finalize was called from DllMain, the calibration thread - * is in a paused state so we need to timeout and continue. + * If Tcl_Finalize was called from DllMain, the calibration thread is in a + * paused state so we need to timeout and continue. */ - WaitForSingleObject( timeInfo.calibrationThread, 100 ); - CloseHandle( timeInfo.exitEvent ); - CloseHandle( timeInfo.calibrationThread ); + + WaitForSingleObject(timeInfo.calibrationThread, 100); + CloseHandle(timeInfo.exitEvent); + CloseHandle(timeInfo.calibrationThread); } /* *---------------------------------------------------------------------- * @@ -507,25 +545,24 @@ /* * tzset() under Borland doesn't seem to set up tzname[] at all. * tzset() under MSVC has the following weird observed behavior: * First time we call "clock format [clock seconds] -format %Z -gmt 1" - * we get "GMT", but on all subsequent calls we get the current time - * zone string, even though env(TZ) is GMT and the variable _timezone - * is 0. + * we get "GMT", but on all subsequent calls we get the current time + * ezone string, even though env(TZ) is GMT and the variable _timezone + * is 0. */ name[0] = '\0'; zone = getenv("TZ"); if (zone != NULL) { /* - * TZ is of form "NST-4:30NDT", where "NST" would be the - * name of the standard time zone for this area, "-4:30" is - * the offset from GMT in hours, and "NDT is the name of - * the daylight savings time zone in this area. The offset - * and DST strings are optional. + * TZ is of form "NST-4:30NDT", where "NST" would be the name of the + * standard time zone for this area, "-4:30" is the offset from GMT in + * hours, and "NDT is the name of the daylight savings time zone in + * this area. The offset and DST strings are optional. */ len = strlen(zone); if (len > 3) { len = 3; @@ -549,13 +586,14 @@ sizeof(tsdPtr->tzName), NULL, NULL, NULL); } if (name[0] == '\0') { if (GetTimeZoneInformation(&tz) == TIME_ZONE_ID_UNKNOWN) { /* - * MSDN: On NT this is returned if DST is not used in - * the current TZ + * MSDN: On NT this is returned if DST is not used in the current + * TZ */ + dst = 0; } encoding = Tcl_GetEncoding(NULL, "unicode"); Tcl_ExternalToUtf(NULL, encoding, (char *) ((dst) ? tz.DaylightName : tz.StandardName), -1, @@ -568,13 +606,13 @@ /* *---------------------------------------------------------------------- * * TclpGetDate -- * - * This function converts between seconds and struct tm. If - * useGMT is true, then the returned date will be in Greenwich - * Mean Time (GMT). Otherwise, it will be in the local time zone. + * This function converts between seconds and struct tm. If useGMT is + * true, then the returned date will be in Greenwich Mean Time (GMT). + * Otherwise, it will be in the local time zone. * * Results: * Returns a static tm structure. * * Side effects: @@ -593,42 +631,45 @@ if (!useGMT) { tzset(); /* - * If we are in the valid range, let the C run-time library - * handle it. Otherwise we need to fake it. Note that this - * algorithm ignores daylight savings time before the epoch. + * If we are in the valid range, let the C run-time library handle it. + * Otherwise we need to fake it. Note that this algorithm ignores + * daylight savings time before the epoch. */ /* - Hm, Borland's localtime manages to return NULL under certain - circumstances (e.g. wintime.test, test 1.2). Nobody tests for this, - since 'localtime' isn't supposed to do this, possibly leading to - crashes. - Patch: We only call this function if we are at least one day into - the epoch, else we handle it ourselves (like we do for times < 0). - H. Giese, June 2003 - */ + * Hm, Borland's localtime manages to return NULL under certain + * circumstances (e.g. wintime.test, test 1.2). Nobody tests for this, + * since 'localtime' isn't supposed to do this, possibly leading to + * crashes. + * + * Patch: We only call this function if we are at least one day into + * the epoch, else we handle it ourselves (like we do for times < 0). + * H. Giese, June 2003 + */ + #ifdef __BORLANDC__ - if (*t >= SECSPERDAY) { +#define LOCALTIME_VALIDITY_BOUNDARY SECSPERDAY #else - if (*t >= 0) { +#define LOCALTIME_VALIDITY_BOUNDARY 0 #endif + + if (*t >= LOCALTIME_VALIDITY_BOUNDARY) { return TclpLocaltime(t); } time = *t - timezone; /* * If we aren't near to overflowing the long, just add the bias and - * use the normal calculation. Otherwise we will need to adjust - * the result at the end. + * use the normal calculation. Otherwise we will need to adjust the + * result at the end. */ - if (*t < (LONG_MAX - 2 * SECSPERDAY) - && *t > (LONG_MIN + 2 * SECSPERDAY)) { + if (*t < (LONG_MAX - 2*SECSPERDAY) && *t > (LONG_MIN + 2*SECSPERDAY)) { tmPtr = ComputeGMT(&time); } else { tmPtr = ComputeGMT(t); tzset(); @@ -673,12 +714,12 @@ /* *---------------------------------------------------------------------- * * ComputeGMT -- * - * This function computes GMT given the number of seconds since - * the epoch (midnight Jan 1 1970). + * This function computes GMT given the number of seconds since the epoch + * (midnight Jan 1 1970). * * Results: * Returns a (per thread) statically allocated struct tm. * * Side effects: @@ -714,13 +755,13 @@ tmp--; rem += SECSPER4YEAR; } /* - * Compute the year after 1900 by taking the 4 year span and adjusting - * for the remainder. This works because 2000 is a leap year, and - * 1900/2100 are out of the range. + * Compute the year after 1900 by taking the 4 year span and adjusting for + * the remainder. This works because 2000 is a leap year, and 1900/2100 + * are out of the range. */ tmp = (tmp * 4) + 70; isLeap = 0; if (rem >= SECSPERYEAR) { /* 1971, etc. */ @@ -738,12 +779,12 @@ } } tmPtr->tm_year = tmp; /* - * Compute the day of year and leave the seconds in the current day in - * the remainder. + * Compute the day of year and leave the seconds in the current day in the + * remainder. */ tmPtr->tm_yday = rem / SECSPERDAY; rem %= SECSPERDAY; @@ -760,10 +801,11 @@ * Compute the month and day of month. */ days = (isLeap) ? leapDays : normalDays; for (tmp = 1; days[tmp] < tmPtr->tm_yday; tmp++) { + /* empty body */ } tmPtr->tm_mon = --tmp; tmPtr->tm_mday = tmPtr->tm_yday - days[tmp]; /* @@ -785,64 +827,69 @@ /* *---------------------------------------------------------------------- * * CalibrationThread -- * - * Thread that manages calibration of the hi-resolution time - * derived from the performance counter, to keep it synchronized - * with the system clock. + * Thread that manages calibration of the hi-resolution time derived from + * the performance counter, to keep it synchronized with the system + * clock. * * Parameters: - * arg -- Client data from the CreateThread call. This parameter - * points to the static TimeInfo structure. + * arg - Client data from the CreateThread call. This parameter points to + * the static TimeInfo structure. * * Return value: - * None. This thread embeds an infinite loop. + * None. This thread embeds an infinite loop. * * Side effects: - * At an interval of 1 s, this thread performs virtual time discipline. + * At an interval of 1s, this thread performs virtual time discipline. * - * Note: When this thread is entered, TclpInitLock has been called - * to safeguard the static storage. There is therefore no synchronization - * in the body of this procedure. + * Note: When this thread is entered, TclpInitLock has been called to + * safeguard the static storage. There is therefore no synchronization in the + * body of this procedure. * *---------------------------------------------------------------------- */ static DWORD WINAPI -CalibrationThread( LPVOID arg ) +CalibrationThread(LPVOID arg) { FILETIME curFileTime; DWORD waitResult; - /* Get initial system time and performance counter */ + /* + * Get initial system time and performance counter. + */ - GetSystemTimeAsFileTime( &curFileTime ); - QueryPerformanceCounter( &timeInfo.perfCounterLastCall ); - QueryPerformanceFrequency( &timeInfo.curCounterFreq ); + GetSystemTimeAsFileTime(&curFileTime); + QueryPerformanceCounter(&timeInfo.perfCounterLastCall); + QueryPerformanceFrequency(&timeInfo.curCounterFreq); timeInfo.fileTimeLastCall.LowPart = curFileTime.dwLowDateTime; timeInfo.fileTimeLastCall.HighPart = curFileTime.dwHighDateTime; - ResetCounterSamples( timeInfo.fileTimeLastCall.QuadPart, - timeInfo.perfCounterLastCall.QuadPart, - timeInfo.curCounterFreq.QuadPart ); + ResetCounterSamples(timeInfo.fileTimeLastCall.QuadPart, + timeInfo.perfCounterLastCall.QuadPart, + timeInfo.curCounterFreq.QuadPart); /* - * Wake up the calling thread. When it wakes up, it will release the + * Wake up the calling thread. When it wakes up, it will release the * initialization lock. */ - SetEvent( timeInfo.readyEvent ); + SetEvent(timeInfo.readyEvent); - /* Run the calibration once a second */ + /* + * Run the calibration once a second. + */ while (timeInfo.perfCounterAvailable) { - - /* If the exitEvent is set, break out of the loop. */ + /* + * If the exitEvent is set, break out of the loop. + */ waitResult = WaitForSingleObjectEx(timeInfo.exitEvent, 1000, FALSE); - if ( waitResult == WAIT_OBJECT_0 ) { + if (waitResult == WAIT_OBJECT_0) { break; } UpdateTimeEachSecond(); } @@ -853,15 +900,15 @@ /* *---------------------------------------------------------------------- * * UpdateTimeEachSecond -- * - * Callback from the waitable timer in the clock calibration thread - * that updates system time. + * Callback from the waitable timer in the clock calibration thread that + * updates system time. * * Parameters: - * info -- Pointer to the static TimeInfo structure + * info - Pointer to the static TimeInfo structure * * Results: * None. * * Side effects: @@ -871,131 +918,118 @@ */ static void UpdateTimeEachSecond() { - LARGE_INTEGER curPerfCounter; /* Current value returned from - * QueryPerformanceCounter */ - - FILETIME curSysTime; /* Current system time */ - - LARGE_INTEGER curFileTime; /* File time at the time this callback - * was scheduled. */ - - Tcl_WideInt estFreq; /* Estimated perf counter frequency */ - - Tcl_WideInt vt0; /* Tcl time right now */ - Tcl_WideInt vt1; /* Tcl time one second from now */ - - Tcl_WideInt tdiff; /* Difference between system clock and - * Tcl time. */ - - Tcl_WideInt driftFreq; /* Frequency needed to drift virtual time - * into step over 1 second */ + * QueryPerformanceCounter. */ + FILETIME curSysTime; /* Current system time. */ + LARGE_INTEGER curFileTime; /* File time at the time this callback was + * scheduled. */ + Tcl_WideInt estFreq; /* Estimated perf counter frequency. */ + Tcl_WideInt vt0; /* Tcl time right now. */ + Tcl_WideInt vt1; /* Tcl time one second from now. */ + Tcl_WideInt tdiff; /* Difference between system clock and Tcl + * time. */ + Tcl_WideInt driftFreq; /* Frequency needed to drift virtual time into + * step over 1 second. */ /* * Sample performance counter and system time. */ - QueryPerformanceCounter( &curPerfCounter ); - GetSystemTimeAsFileTime( &curSysTime ); + QueryPerformanceCounter(&curPerfCounter); + GetSystemTimeAsFileTime(&curSysTime); curFileTime.LowPart = curSysTime.dwLowDateTime; curFileTime.HighPart = curSysTime.dwHighDateTime; - EnterCriticalSection( &timeInfo.cs ); + EnterCriticalSection(&timeInfo.cs); /* - * We devide by timeInfo.curCounterFreq.QuadPart in several places. - * That value should always be positive on a correctly functioning - * system. But it is good to be defensive about such matters. - * So if something goes wrong and the value does goes to zero, we - * clear the timeInfo.perfCounterAvailable in order to cause the - * calibration thread to shut itself down, then return without additional - * processing. + * We devide by timeInfo.curCounterFreq.QuadPart in several places. That + * value should always be positive on a correctly functioning system. But + * it is good to be defensive about such matters. So if something goes + * wrong and the value does goes to zero, we clear the + * timeInfo.perfCounterAvailable in order to cause the calibration thread + * to shut itself down, then return without additional processing. */ - if( timeInfo.curCounterFreq.QuadPart==0 ){ - LeaveCriticalSection( &timeInfo.cs ); + if (timeInfo.curCounterFreq.QuadPart == 0){ + LeaveCriticalSection(&timeInfo.cs); timeInfo.perfCounterAvailable = 0; return; } /* - * Several things may have gone wrong here that have to - * be checked for. - * (1) The performance counter may have jumped. - * (2) The system clock may have been reset. - * - * In either case, we'll need to reinitialize the circular buffer - * with samples relative to the current system time and the NOMINAL - * performance frequency (not the actual, because the actual has - * probably run slow in the first case). Our estimated frequency - * will be the nominal frequency. - */ - - /* - * Store the current sample into the circular buffer of samples, - * and estimate the performance counter frequency. - */ - - estFreq = AccumulateSample( curPerfCounter.QuadPart, - (Tcl_WideUInt) curFileTime.QuadPart ); + * Several things may have gone wrong here that have to be checked for. + * (1) The performance counter may have jumped. + * (2) The system clock may have been reset. + * + * In either case, we'll need to reinitialize the circular buffer with + * samples relative to the current system time and the NOMINAL performance + * frequency (not the actual, because the actual has probably run slow in + * the first case). Our estimated frequency will be the nominal frequency. + * + * Store the current sample into the circular buffer of samples, and + * estimate the performance counter frequency. + */ + + estFreq = AccumulateSample(curPerfCounter.QuadPart, + (Tcl_WideUInt) curFileTime.QuadPart); /* * We want to adjust things so that time appears to be continuous. - * Virtual file time, right now, is - * - * vt0 = 10000000 * ( curPerfCounter - perfCounterLastCall ) - * / curCounterFreq - * + fileTimeLastCall - * - * Ideally, we would like to drift the clock into place over a - * period of 2 sec, so that virtual time 2 sec from now will be + * Virtual file time, right now, is + * + * vt0 = 10000000 * (curPerfCounter - perfCounterLastCall) + * / curCounterFreq + * + fileTimeLastCall + * + * Ideally, we would like to drift the clock into place over a period of 2 + * sec, so that virtual time 2 sec from now will be * * vt1 = 20000000 + curFileTime * - * The frequency that we need to use to drift the counter back into - * place is estFreq * 20000000 / ( vt1 - vt0 ) + * The frequency that we need to use to drift the counter back into place + * is estFreq * 20000000 / (vt1 - vt0) */ - vt0 = 10000000 * ( curPerfCounter.QuadPart - - timeInfo.perfCounterLastCall.QuadPart ) - / timeInfo.curCounterFreq.QuadPart - + timeInfo.fileTimeLastCall.QuadPart; + vt0 = 10000000 * (curPerfCounter.QuadPart + - timeInfo.perfCounterLastCall.QuadPart) + / timeInfo.curCounterFreq.QuadPart + + timeInfo.fileTimeLastCall.QuadPart; vt1 = 20000000 + curFileTime.QuadPart; /* - * If we've gotten more than a second away from system time, - * then drifting the clock is going to be pretty hopeless. - * Just let it jump. Otherwise, compute the drift frequency and - * fill in everything. + * If we've gotten more than a second away from system time, then drifting + * the clock is going to be pretty hopeless. Just let it jump. Otherwise, + * compute the drift frequency and fill in everything. */ tdiff = vt0 - curFileTime.QuadPart; - if ( tdiff > 10000000 || tdiff < -10000000 ) { + if (tdiff > 10000000 || tdiff < -10000000) { timeInfo.fileTimeLastCall.QuadPart = curFileTime.QuadPart; timeInfo.curCounterFreq.QuadPart = estFreq; } else { - driftFreq = estFreq * 20000000 / ( vt1 - vt0 ); - if ( driftFreq > 1003 * estFreq / 1000 ) { - driftFreq = 1003 * estFreq / 1000; + driftFreq = estFreq * 20000000 / (vt1 - vt0); + + if (driftFreq > 1003*estFreq/1000) { + driftFreq = 1003*estFreq/1000; + } else if (driftFreq < 997*estFreq/1000) { + driftFreq = 997*estFreq/1000; } - if ( driftFreq < 997 * estFreq / 1000 ) { - driftFreq = 997 * estFreq / 1000; - } + timeInfo.fileTimeLastCall.QuadPart = vt0; timeInfo.curCounterFreq.QuadPart = driftFreq; } timeInfo.perfCounterLastCall.QuadPart = curPerfCounter.QuadPart; - LeaveCriticalSection( &timeInfo.cs ); - + LeaveCriticalSection(&timeInfo.cs); } - + /* *---------------------------------------------------------------------- * * ResetCounterSamples -- * @@ -1004,27 +1038,25 @@ * * Results: * None. * * Side effects: - * The array of samples is filled in so that it appears that there - * are SAMPLES samples at one-second intervals, separated by precisely - * the given frequency. + * The array of samples is filled in so that it appears that there are + * SAMPLES samples at one-second intervals, separated by precisely the + * given frequency. * *---------------------------------------------------------------------- */ static void -ResetCounterSamples( Tcl_WideUInt fileTime, - /* Current file time */ - Tcl_WideInt perfCounter, - /* Current performance counter */ - Tcl_WideInt perfFreq ) - /* Target performance frequency */ +ResetCounterSamples( + Tcl_WideUInt fileTime, /* Current file time */ + Tcl_WideInt perfCounter, /* Current performance counter */ + Tcl_WideInt perfFreq) /* Target performance frequency */ { int i; - for ( i = SAMPLES-1; i >= 0; --i ) { + for (i=SAMPLES-1 ; i>=0 ; --i) { timeInfo.perfCounterSample[i] = perfCounter; timeInfo.fileTimeSample[i] = fileTime; perfCounter -= perfFreq; fileTime -= 10000000; } @@ -1034,88 +1066,83 @@ /* *---------------------------------------------------------------------- * * AccumulateSample -- * - * Updates the circular buffer of performance counter and system - * time samples with a new data point. + * Updates the circular buffer of performance counter and system time + * samples with a new data point. * * Results: * None. * * Side effects: - * The new data point replaces the oldest point in the circular - * buffer, and the descriptive statistics are updated to accumulate - * the new point. - * - * Several things may have gone wrong here that have to - * be checked for. - * (1) The performance counter may have jumped. - * (2) The system clock may have been reset. - * - * In either case, we'll need to reinitialize the circular buffer - * with samples relative to the current system time and the NOMINAL - * performance frequency (not the actual, because the actual has - * probably run slow in the first case). + * The new data point replaces the oldest point in the circular buffer, + * and the descriptive statistics are updated to accumulate the new + * point. + * + * Several things may have gone wrong here that have to be checked for. + * (1) The performance counter may have jumped. + * (2) The system clock may have been reset. + * + * In either case, we'll need to reinitialize the circular buffer with samples + * relative to the current system time and the NOMINAL performance frequency + * (not the actual, because the actual has probably run slow in the first + * case). */ static Tcl_WideInt -AccumulateSample( Tcl_WideInt perfCounter, - Tcl_WideUInt fileTime ) -{ - Tcl_WideUInt workFTSample; /* File time sample being removed - * from or added to the circular buffer */ - - Tcl_WideInt workPCSample; /* Performance counter sample being - * removed from or added to the circular - * buffer */ - +AccumulateSample(Tcl_WideInt perfCounter, Tcl_WideUInt fileTime) +{ + Tcl_WideUInt workFTSample; /* File time sample being removed from or + * added to the circular buffer. */ + Tcl_WideInt workPCSample; /* Performance counter sample being removed + * from or added to the circular buffer. */ Tcl_WideUInt lastFTSample; /* Last file time sample recorded */ - Tcl_WideInt lastPCSample; /* Last performance counter sample recorded */ - Tcl_WideInt FTdiff; /* Difference between last FT and current */ - Tcl_WideInt PCdiff; /* Difference between last PC and current */ - Tcl_WideInt estFreq; /* Estimated performance counter frequency */ - /* Test for jumps and reset the samples if we have one. */ + /* + * Test for jumps and reset the samples if we have one. + */ - if ( timeInfo.sampleNo == 0 ) { - lastPCSample = timeInfo.perfCounterSample[ timeInfo.sampleNo - + SAMPLES - 1 ]; - lastFTSample = timeInfo.fileTimeSample[ timeInfo.sampleNo - + SAMPLES - 1 ]; + if (timeInfo.sampleNo == 0) { + lastPCSample = + timeInfo.perfCounterSample[timeInfo.sampleNo + SAMPLES - 1]; + lastFTSample = + timeInfo.fileTimeSample[timeInfo.sampleNo + SAMPLES - 1]; } else { - lastPCSample = timeInfo.perfCounterSample[ timeInfo.sampleNo - 1 ]; - lastFTSample = timeInfo.fileTimeSample[ timeInfo.sampleNo - 1 ]; + lastPCSample = timeInfo.perfCounterSample[timeInfo.sampleNo - 1]; + lastFTSample = timeInfo.fileTimeSample[timeInfo.sampleNo - 1]; } + PCdiff = perfCounter - lastPCSample; FTdiff = fileTime - lastFTSample; - if ( PCdiff < timeInfo.nominalFreq.QuadPart * 9 / 10 - || PCdiff > timeInfo.nominalFreq.QuadPart * 11 / 10 - || FTdiff < 9000000 - || FTdiff > 11000000 ) { - ResetCounterSamples( fileTime, perfCounter, - timeInfo.nominalFreq.QuadPart ); + if (PCdiff < timeInfo.nominalFreq.QuadPart * 9 / 10 + || PCdiff > timeInfo.nominalFreq.QuadPart * 11 / 10 + || FTdiff < 9000000 || FTdiff > 11000000) { + ResetCounterSamples(fileTime, perfCounter, + timeInfo.nominalFreq.QuadPart); return timeInfo.nominalFreq.QuadPart; - } else { - - /* Estimate the frequency */ - - workPCSample = timeInfo.perfCounterSample[ timeInfo.sampleNo ]; - workFTSample = timeInfo.fileTimeSample[ timeInfo.sampleNo ]; - estFreq = 10000000 * ( perfCounter - workPCSample ) - / ( fileTime - workFTSample ); - timeInfo.perfCounterSample[ timeInfo.sampleNo ] = perfCounter; - timeInfo.fileTimeSample[ timeInfo.sampleNo ] = (Tcl_WideInt) fileTime; - - /* Advance the sample number */ - - if ( ++timeInfo.sampleNo >= SAMPLES ) { + /* + * Estimate the frequency. + */ + + workPCSample = timeInfo.perfCounterSample[timeInfo.sampleNo]; + workFTSample = timeInfo.fileTimeSample[timeInfo.sampleNo]; + estFreq = 10000000 * (perfCounter - workPCSample) + / (fileTime - workFTSample); + timeInfo.perfCounterSample[timeInfo.sampleNo] = perfCounter; + timeInfo.fileTimeSample[timeInfo.sampleNo] = (Tcl_WideInt) fileTime; + + /* + * Advance the sample number. + */ + + if (++timeInfo.sampleNo >= SAMPLES) { timeInfo.sampleNo = 0; } return estFreq; } @@ -1124,12 +1151,11 @@ /* *---------------------------------------------------------------------- * * TclpGmtime -- * - * Wrapper around the 'gmtime' library function to make it thread - * safe. + * Wrapper around the 'gmtime' library function to make it thread safe. * * Results: * Returns a pointer to a 'struct tm' in thread-specific data. * * Side effects: @@ -1137,21 +1163,21 @@ * *---------------------------------------------------------------------- */ struct tm * -TclpGmtime( timePtr ) - CONST time_t *timePtr; /* Pointer to the number of seconds - * since the local system's epoch */ - +TclpGmtime(timePtr) + CONST time_t *timePtr; /* Pointer to the number of seconds since the + * local system's epoch */ { /* - * The MS implementation of gmtime is thread safe because - * it returns the time in a block of thread-local storage, - * and Windows does not provide a Posix gmtime_r function. + * The MS implementation of gmtime is thread safe because it returns the + * time in a block of thread-local storage, and Windows does not provide a + * Posix gmtime_r function. */ - return gmtime( timePtr ); + + return gmtime(timePtr); } /* *---------------------------------------------------------------------- * @@ -1168,17 +1194,87 @@ * *---------------------------------------------------------------------- */ struct tm * -TclpLocaltime( timePtr ) - CONST time_t *timePtr; /* Pointer to the number of seconds - * since the local system's epoch */ +TclpLocaltime(timePtr) + CONST time_t *timePtr; /* Pointer to the number of seconds since the + * local system's epoch */ { /* - * The MS implementation of localtime is thread safe because - * it returns the time in a block of thread-local storage, - * and Windows does not provide a Posix localtime_r function. + * The MS implementation of localtime is thread safe because it returns + * the time in a block of thread-local storage, and Windows does not + * provide a Posix localtime_r function. */ - return localtime( timePtr ); + + return localtime(timePtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetTimeProc -- + * + * TIP #233 (Virtualized Time): Registers two handlers for the + * virtualization of Tcl's access to time information. + * + * Results: + * None. + * + * Side effects: + * Remembers the handlers, alters core behaviour. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetTimeProc(getProc, scaleProc, clientData) + Tcl_GetTimeProc *getProc; + Tcl_ScaleTimeProc *scaleProc; + ClientData clientData; +{ + tclGetTimeProcPtr = getProc; + tclScaleTimeProcPtr = scaleProc; + tclTimeClientData = clientData; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_QueryTimeProc -- + * + * TIP #233 (Virtualized Time): Query which time handlers are registered. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_QueryTimeProc(getProc, scaleProc, clientData) + Tcl_GetTimeProc ** getProc; + Tcl_ScaleTimeProc **scaleProc; + ClientData *clientData; +{ + if (getProc) { + *getProc = tclGetTimeProcPtr; + } + if (scaleProc) { + *scaleProc = tclScaleTimeProcPtr; + } + if (clientData) { + *clientData = tclTimeClientData; + } } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */